Index: .fossil-settings/binary-glob ================================================================== --- .fossil-settings/binary-glob +++ .fossil-settings/binary-glob @@ -1,9 +1,12 @@ -compat/zlib/win32/zdll.lib -compat/zlib/win32/zlib1.dll -compat/zlib/win64/zdll.lib -compat/zlib/win64/zlib1.dll -compat/zlib/win64/libz.dll.a -compat/zlib/zlib.3.pdf +*.a *.bmp +*.dll +*.exe *.gif +*.gz +*.jpg +*.lib +*.pdf *.png +*.xlsx +*.zip Index: .fossil-settings/crlf-glob ================================================================== --- .fossil-settings/crlf-glob +++ .fossil-settings/crlf-glob @@ -1,8 +1,9 @@ compat/zlib/contrib/dotzlib/DotZLib/UnitTests.cs compat/zlib/contrib/vstudio/readme.txt compat/zlib/contrib/vstudio/*/zlib.rc +compat/zlib/contrib/vstudio/*/*.sln compat/zlib/win32/*.txt compat/zlib/win64/*.txt libtommath/*.dsp libtommath/*.sln libtommath/*.vcproj Index: .fossil-settings/ignore-glob ================================================================== --- .fossil-settings/ignore-glob +++ .fossil-settings/ignore-glob @@ -1,18 +1,22 @@ *.a *.dll *.dylib +*.dylib.E *.exe *.exp +*.la *.lib +*.lo *.o *.obj *.pdb *.res *.sl *.so */Makefile +*/autom4te.cache */config.cache */config.log */config.status */tclConfig.sh */tclsh* @@ -38,16 +42,27 @@ libtommath/logs/* libtommath/etc/* libtommath/demo/* libtommath/*.out libtommath/*.tex +macosx/configure unix/autoMkindex.tcl unix/dltest.marker +unix/dltest/*.bundle +unix/dltest/*.dll +unix/dltest/*.dylib +unix/dltest/*.o +unix/dltest/*.sl +unix/dltest/*.so unix/tcl.pc unix/tclIndex +unix/Tcl-Info.plist +unix/Tclsh-Info.plist unix/pkgs/* win/Debug* win/Release* +win/*.manifest win/pkgs/* win/coffbase.txt win/tcl.hpj +win/nmakehlp.out win/nmhlp-out.txt ADDED .fossil-settings/manifest Index: .fossil-settings/manifest ================================================================== --- /dev/null +++ .fossil-settings/manifest @@ -0,0 +1,1 @@ +u ADDED .gitattributes Index: .gitattributes ================================================================== --- /dev/null +++ .gitattributes @@ -0,0 +1,40 @@ +# Set the default behavior, in case people don't have core.autocrlf set. +* eol=lf +* text=auto + +# Explicitly declare text files you want to always be normalized and converted +# to native line endings on checkout. +*.3 text +*.c text +*.css text +*.enc text +*.h text +*.htm text +*.html text +*.java text +*.js text +*.json text +*.n text +*.svg text +*.ts text +*.tcl text +*.test text + +# Declare files that will always have CRLF line endings on checkout. +*.bat eol=crlf +*.sln eol=crlf +*.vc eol=crlf + +# Denote all files that are truly binary and should not be modified. +*.a binary +*.bmp binary +*.dll binary +*.exe binary +*.gif binary +*.gz binary +*.jpg binary +*.lib binary +*.pdf binary +*.png binary +*.xlsx binary +*.zip binary DELETED .github/ISSUE_TEMPLATE.md Index: .github/ISSUE_TEMPLATE.md ================================================================== --- .github/ISSUE_TEMPLATE.md +++ /dev/null @@ -1,3 +0,0 @@ -Important Note -========== -Please do not file issues with Tcl on Github. They are unlikely to be noticed in a timely fashion. Tcl issues are hosted in the [tcl fossil repository on core.tcl.tk](https://core.tcl.tk/tcl/tktnew); please post them there. DELETED .github/PULL_REQUEST_TEMPLATE.md Index: .github/PULL_REQUEST_TEMPLATE.md ================================================================== --- .github/PULL_REQUEST_TEMPLATE.md +++ /dev/null @@ -1,3 +0,0 @@ -Important Note -========== -Please do not file pull requests with Tcl on Github. They are unlikely to be noticed in a timely fashion. Tcl issues (including patches) are hosted in the [tcl fossil repository on core.tcl.tk](https://core.tcl.tk/tcl/tktnew); please post them there. ADDED .github/workflows/linux-build.yml Index: .github/workflows/linux-build.yml ================================================================== --- /dev/null +++ .github/workflows/linux-build.yml @@ -0,0 +1,45 @@ +name: Linux Build and Test +on: [push] +jobs: + gcc: + runs-on: ubuntu-latest + strategy: + matrix: + symbols: + - "no" + - "mem" + - "all" + defaults: + run: + shell: bash + working-directory: unix + steps: + - name: Checkout + uses: actions/checkout@v2 + - name: Configure (symbols=${{ matrix.symbols }}) + run: | + mkdir "${HOME}/install dir" + ./configure ${CFGOPT} "--prefix=$HOME/install dir" || (cat config.log && exit 1) + env: + CFGOPT: --enable-symbols=${{ matrix.symbols }} + - name: Prepare + run: touch tclStubInit.c tclOOStubInit.c + working-directory: generic + - name: Build + run: | + make all + - name: Build Test Harness + run: | + make tcltest + - name: Run Tests + run: | + make test + - name: Test-Drive Installation + run: | + make install + - name: Create Distribution Package + run: | + make dist + - name: Convert Documentation to HTML + run: | + make html-tcl ADDED .github/workflows/mac-build.yml Index: .github/workflows/mac-build.yml ================================================================== --- /dev/null +++ .github/workflows/mac-build.yml @@ -0,0 +1,61 @@ +name: macOS Build and Test +on: [push] +jobs: + with-Xcode: + runs-on: macos-latest + defaults: + run: + shell: bash + working-directory: macosx + steps: + - name: Checkout + uses: actions/checkout@v2 + - name: Prepare + run: touch tclStubInit.c tclOOStubInit.c + working-directory: generic + - name: Build + run: make all + - name: Run Tests + run: make test styles=develop + env: + ERROR_ON_FAILURES: 1 + MAC_CI: 1 + Unix-like: + runs-on: macos-latest + strategy: + matrix: + symbols: + - "no" + - "mem" + dtrace: + - "no" + - "yes" + defaults: + run: + shell: bash + working-directory: unix + steps: + - name: Checkout + uses: actions/checkout@v2 + - name: Prepare + run: | + touch tclStubInit.c tclOOStubInit.c + mkdir "$HOME/install dir" + working-directory: generic + - name: Configure (symbols=${{ matrix.symbols }} dtrace=${{ matrix.dtrace }}) + # Note that macOS is always a 64 bit platform + run: ./configure --enable-64bit ${CFGOPT} "--prefix=$HOME/install dir" || (cat config.log && exit 1) + env: + CFGOPT: --enable-symbols=${{ matrix.symbols }} --enable-dtrace=${{ matrix.dtrace }} + - name: Build + run: | + make all tcltest + - name: Run Tests + run: | + make test + env: + ERROR_ON_FAILURES: 1 + MAC_CI: 1 + - name: Trial Installation + run: | + make install ADDED .github/workflows/win-build.yml Index: .github/workflows/win-build.yml ================================================================== --- /dev/null +++ .github/workflows/win-build.yml @@ -0,0 +1,71 @@ +name: Windows Build and Test +on: [push] +jobs: + MSVC: + runs-on: windows-latest + defaults: + run: + shell: powershell + working-directory: win + # Using powershell means we need to explicitly stop on failure + steps: + - name: Checkout + uses: actions/checkout@v2 + - name: Init MSVC + uses: ilammy/msvc-dev-cmd@v1 + - name: Build + run: | + &nmake -f makefile.vc all + if ($lastexitcode -ne 0) { + throw "nmake exit code: $lastexitcode" + } + - name: Build Test Harness + run: | + &nmake -f makefile.vc tcltest + if ($lastexitcode -ne 0) { + throw "nmake exit code: $lastexitcode" + } + - name: Run Tests + run: | + &nmake -f makefile.vc test + if ($lastexitcode -ne 0) { + throw "nmake exit code: $lastexitcode" + } + env: + ERROR_ON_FAILURES: 1 + MSYS-gcc: + runs-on: windows-latest + defaults: + run: + shell: bash + working-directory: win + strategy: + matrix: + symbols: + - "no" + - "mem" + - "all" + # Using powershell means we need to explicitly stop on failure + steps: + - name: Checkout + uses: actions/checkout@v2 + - name: Install MSYS2 and Make + run: choco install msys2 make + - name: Prepare + run: | + touch tclStubInit.c tclOOStubInit.c + mkdir "${HOME}/install dir" + working-directory: generic + - name: Configure (symbols=${{ matrix.symbols }}) + run: | + ./configure ${CFGOPT} "--prefix=$HOME/install dir" || (cat config.log && exit 1) + env: + CFGOPT: --enable-64bit --enable-symbols=${{ matrix.symbols }} + - name: Build + run: make all + - name: Build Test Harness + run: make tcltest + - name: Run Tests + run: make test + env: + ERROR_ON_FAILURES: 1 ADDED .gitignore Index: .gitignore ================================================================== --- /dev/null +++ .gitignore @@ -0,0 +1,65 @@ +*.a +*.bundle +*.dll +*.dylib +*.dylib.E +*.exe +*.exp +*.lib +*.o +*.obj +*.pdb +*.res +*.sl +*.so +.fslckout +Makefile +Tcl-Info.plist +Tclsh-Info.plist +autom4te.cache +config.cache +config.log +config.status +config.status.lineno +html +manifest.uuid +_FOSSIL_ +*/tclConfig.sh +*/tclsh* +*/tcltest* +*/versions.vc +*/version.vc +*/libtcl.vfs +*/libtcl_*.zip +libtommath/bn.ilg +libtommath/bn.ind +libtommath/pretty.build +libtommath/tommath.src +libtommath/*.log +libtommath/*.pdf +libtommath/*.pl +libtommath/*.sh +libtommath/doc/* +libtommath/tombc/* +libtommath/pre_gen/* +libtommath/pics/* +libtommath/mtest/* +libtommath/logs/* +libtommath/etc/* +libtommath/demo/* +libtommath/*.out +libtommath/*.tex +macosx/configure +unix/autoMkindex.tcl +unix/dltest.marker +unix/tcl.pc +unix/tclIndex +unix/pkgs/* +win/Debug* +win/Release* +win/*.manifest +win/pkgs/* +win/coffbase.txt +win/tcl.hpj +win/nmakehlp.out +win/nmhlp-out.txt Index: .project ================================================================== --- .project +++ .project @@ -1,8 +1,8 @@ - tcl9 + tcl8.6 Index: .travis.yml ================================================================== --- .travis.yml +++ .travis.yml @@ -1,297 +1,388 @@ -sudo: false language: c - -matrix: +addons: + apt: + sources: + - ubuntu-toolchain-r-test + packages: + - binutils-mingw-w64-i686 + - binutils-mingw-w64-x86-64 + - gcc-mingw-w64 + - gcc-mingw-w64-base + - gcc-mingw-w64-i686 + - gcc-mingw-w64-x86-64 + - gcc-multilib +jobs: include: - - os: linux - dist: xenial - compiler: clang - env: - - BUILD_DIR=unix - - os: linux - dist: xenial - compiler: clang - env: - - CFGOPT=--disable-shared - - BUILD_DIR=unix - - os: linux - dist: xenial - compiler: gcc - env: - - BUILD_DIR=unix - - os: linux - dist: xenial - compiler: gcc - env: - - CFGOPT=--disable-shared - - BUILD_DIR=unix - - os: linux - dist: xenial - compiler: gcc-4.9 +# Testing on Linux GCC + - name: "Linux/GCC/Shared" + os: linux + dist: focal + compiler: gcc + env: + - BUILD_DIR=unix + - name: "Linux/GCC/Shared: UTF_MAX=4" + os: linux + dist: focal + compiler: gcc + env: + - BUILD_DIR=unix + - CFGOPT=CFLAGS=-DTCL_UTF_MAX=4 + - name: "Linux/GCC/Shared: UTF_MAX=6" + os: linux + dist: focal + compiler: gcc + env: + - BUILD_DIR=unix + - CFGOPT=CFLAGS=-DTCL_UTF_MAX=6 + - name: "Linux/GCC/Static" + os: linux + dist: focal + compiler: gcc + env: + - CFGOPT="--disable-shared" + - BUILD_DIR=unix + - name: "Linux/GCC/Debug" + os: linux + dist: focal + compiler: gcc + env: + - BUILD_DIR=unix + - CFGOPT="--enable-symbols" + - name: "Linux/GCC/Mem-Debug" + os: linux + dist: focal + compiler: gcc + env: + - BUILD_DIR=unix + - CFGOPT="--enable-symbols=mem" +# Newer/Older versions of GCC + - name: "Linux/GCC 10/Shared" + os: linux + dist: focal + compiler: gcc-10 addons: apt: - sources: - - ubuntu-toolchain-r-test packages: - - g++-4.9 + - g++-10 env: - BUILD_DIR=unix - - os: linux - dist: xenial + - name: "Linux/GCC 5/Shared" + os: linux + dist: bionic compiler: gcc-5 addons: apt: - sources: - - ubuntu-toolchain-r-test packages: - g++-5 env: - BUILD_DIR=unix - - os: linux - dist: xenial - compiler: gcc-6 - addons: - apt: - sources: - - ubuntu-toolchain-r-test - packages: - - g++-6 - env: - - BUILD_DIR=unix - - os: linux - dist: xenial - compiler: gcc-7 - addons: - apt: - sources: - - ubuntu-toolchain-r-test - packages: - - g++-7 - env: - - BUILD_DIR=unix - - os: linux - dist: xenial - compiler: gcc-7 - addons: - apt: - sources: - - ubuntu-toolchain-r-test - packages: - - g++-7 - env: - - BUILD_DIR=unix - - CFGOPT=CFLAGS=-DTCL_UTF_MAX=6 - - os: linux - dist: xenial - compiler: gcc-7 - addons: - apt: - sources: - - ubuntu-toolchain-r-test - packages: - - g++-7 - env: - - BUILD_DIR=unix - - CFGOPT=CFLAGS=-DTCL_UTF_MAX=3 - - os: linux - dist: xenial - compiler: gcc-7 - addons: - apt: - sources: - - ubuntu-toolchain-r-test - packages: - - g++-7 - env: - - BUILD_DIR=unix - - CFGOPT=CFLAGS=-DTCL_NO_DEPRECATED=1 - - os: osx - osx_image: xcode8 - env: - - BUILD_DIR=unix - - os: osx - osx_image: xcode8 - env: - - BUILD_DIR=macosx - - NO_DIRECT_CONFIGURE=1 - - os: osx - osx_image: xcode9 - env: - - BUILD_DIR=macosx - - NO_DIRECT_CONFIGURE=1 - - os: osx - osx_image: xcode10.2 - env: - - BUILD_DIR=macosx - - NO_DIRECT_CONFIGURE=1 -### C builds not currently supported on Windows instances -# - os: windows -# env: -# - BUILD_DIR=win -### ... so proxy with a Mingw cross-compile -# Test with mingw-w64 (32 bit) - - os: linux - dist: xenial - compiler: i686-w64-mingw32-gcc - addons: - apt: - packages: - - gcc-mingw-w64-base - - binutils-mingw-w64-i686 - - gcc-mingw-w64-i686 - - gcc-mingw-w64 - - gcc-multilib - - wine +# Testing on Linux Clang + - name: "Linux/Clang/Shared" + os: linux + dist: focal + compiler: clang + env: + - BUILD_DIR=unix + - name: "Linux/Clang/Static" + os: linux + dist: focal + compiler: clang + env: + - CFGOPT="--disable-shared" + - BUILD_DIR=unix + - name: "Linux/Clang/Debug" + os: linux + dist: focal + compiler: clang + env: + - BUILD_DIR=unix + - CFGOPT="--enable-symbols" + - name: "Linux/Clang/Mem-Debug" + os: linux + dist: focal + compiler: clang + env: + - BUILD_DIR=unix + - CFGOPT="--enable-symbols=mem" +# Testing on Mac, various styles + - name: "macOS/Xcode 12/Shared" + os: osx + osx_image: xcode12.2 + env: + - BUILD_DIR=macosx + install: [] + script: &mactest + - make all + # The styles=develop avoids some weird problems on OSX + - make test styles=develop + - name: "macOS/Xcode 12/Shared/Unix-like" + os: osx + osx_image: xcode12.2 + env: + - BUILD_DIR=unix + - CFGOPT="--enable-dtrace" +# Newer MacOS versions + - name: "macOS/Xcode 12/Universal Apps/Shared" + os: osx + osx_image: xcode12u + env: + - BUILD_DIR=macosx + install: [] + script: *mactest +# Older MacOS versions + - name: "macOS/Xcode 11/Shared" + os: osx + osx_image: xcode11.7 + env: + - BUILD_DIR=macosx + install: [] + script: *mactest + - name: "macOS/Xcode 10/Shared" + os: osx + osx_image: xcode10.3 + env: + - BUILD_DIR=macosx + install: [] + script: *mactest + - name: "macOS/Xcode 9/Shared" + os: osx + osx_image: xcode9.4 + env: + - BUILD_DIR=macosx + install: [] + script: *mactest + - name: "macOS/Xcode 8/Shared" + os: osx + osx_image: xcode8.3 + env: + - BUILD_DIR=macosx + install: [] + script: *mactest +# Test with mingw-w64 cross-compile +# Doesn't run tests because wine is only an imperfect Windows emulation + - name: "Linux-cross-Windows/GCC/Shared/no test" + os: linux + dist: focal + compiler: x86_64-w64-mingw32-gcc + env: + - BUILD_DIR=win + - CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit" + script: &crosstest + - make all tcltest + # Include a high visibility marker that tests are skipped outright + - > + echo "`tput setaf 3`SKIPPED TEST: CROSS COMPILING`tput sgr0`" +# Test with mingw-w64 (32 bit) cross-compile +# Doesn't run tests because wine is only an imperfect Windows emulation + - name: "Linux-cross-Windows-32/GCC/Shared/no test" + os: linux + dist: focal + compiler: i686-w64-mingw32-gcc env: - BUILD_DIR=win - CFGOPT=--host=i686-w64-mingw32 - - NO_DIRECT_TEST=1 - - os: linux - dist: xenial - compiler: i686-w64-mingw32-gcc - addons: - apt: - packages: - - gcc-mingw-w64-base - - binutils-mingw-w64-i686 - - gcc-mingw-w64-i686 - - gcc-mingw-w64 - - gcc-multilib - - wine - env: - - BUILD_DIR=win - - CFGOPT="--host=i686-w64-mingw32 --disable-shared" - - NO_DIRECT_TEST=1 - - os: linux - dist: xenial - compiler: i686-w64-mingw32-gcc - addons: - apt: - packages: - - gcc-mingw-w64-base - - binutils-mingw-w64-i686 - - gcc-mingw-w64-i686 - - gcc-mingw-w64 - - gcc-multilib - - wine - env: - - BUILD_DIR=win - - CFGOPT="--host=i686-w64-mingw32 CFLAGS=-DTCL_UTF_MAX=6" - - NO_DIRECT_TEST=1 - - os: linux - dist: xenial - compiler: i686-w64-mingw32-gcc - addons: - apt: - packages: - - gcc-mingw-w64-base - - binutils-mingw-w64-i686 - - gcc-mingw-w64-i686 - - gcc-mingw-w64 - - gcc-multilib - - wine - env: - - BUILD_DIR=win - - CFGOPT="--host=i686-w64-mingw32 CFLAGS=-DTCL_UTF_MAX=3" - - NO_DIRECT_TEST=1 - - os: linux - dist: xenial - compiler: i686-w64-mingw32-gcc - addons: - apt: - packages: - - gcc-mingw-w64-base - - binutils-mingw-w64-i686 - - gcc-mingw-w64-i686 - - gcc-mingw-w64 - - gcc-multilib - - wine - env: - - BUILD_DIR=win - - CFGOPT="--host=i686-w64-mingw32 CFLAGS=-DTCL_NO_DEPRECATED=1" - - NO_DIRECT_TEST=1 -# Test with mingw-w64 (64 bit) - - os: linux - dist: xenial - compiler: x86_64-w64-mingw32-gcc - addons: - apt: - packages: - - gcc-mingw-w64-base - - binutils-mingw-w64-x86-64 - - gcc-mingw-w64-x86-64 - - gcc-mingw-w64 - - wine - env: - - BUILD_DIR=win - - CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit" - - NO_DIRECT_TEST=1 - - os: linux - dist: xenial - compiler: x86_64-w64-mingw32-gcc - addons: - apt: - packages: - - gcc-mingw-w64-base - - binutils-mingw-w64-x86-64 - - gcc-mingw-w64-x86-64 - - gcc-mingw-w64 - - wine - env: - - BUILD_DIR=win - - CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit --disable-shared" - - NO_DIRECT_TEST=1 - - os: linux - dist: xenial - compiler: x86_64-w64-mingw32-gcc - addons: - apt: - packages: - - gcc-mingw-w64-base - - binutils-mingw-w64-x86-64 - - gcc-mingw-w64-x86-64 - - gcc-mingw-w64 - - wine - env: - - BUILD_DIR=win - - CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit CFLAGS=-DTCL_UTF_MAX=6" - - NO_DIRECT_TEST=1 - - os: linux - dist: xenial - compiler: x86_64-w64-mingw32-gcc - addons: - apt: - packages: - - gcc-mingw-w64-base - - binutils-mingw-w64-x86-64 - - gcc-mingw-w64-x86-64 - - gcc-mingw-w64 - - wine - env: - - BUILD_DIR=win - - CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit CFLAGS=-DTCL_UTF_MAX=3" - - NO_DIRECT_TEST=1 - - os: linux - dist: xenial - compiler: x86_64-w64-mingw32-gcc - addons: - apt: - packages: - - gcc-mingw-w64-base - - binutils-mingw-w64-x86-64 - - gcc-mingw-w64-x86-64 - - gcc-mingw-w64 - - wine - env: - - BUILD_DIR=win - - CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit CFLAGS=-DTCL_NO_DEPRECATED=1" - - NO_DIRECT_TEST=1 -before_install: - - export ERROR_ON_FAILURES=1 - - cd ${BUILD_DIR} -install: - - test -n "$NO_DIRECT_CONFIGURE" || ./configure ${CFGOPT} -script: - - make - # The styles=develop avoids some weird problems on OSX - - test -n "$NO_DIRECT_TEST" || make test styles=develop + script: *crosstest +# Test on Windows with MSVC native + - name: "Windows/MSVC/Shared" + os: windows + compiler: cl + env: &vcenv + - BUILD_DIR=win + - VCDIR="/C/Program Files (x86)/Microsoft Visual Studio/2017/BuildTools/VC/Auxiliary/Build" + before_install: &vcpreinst + - rm -rf tests/safe-stock8*.test + - touch generic/tclStubInit.c generic/tclOOStubInit.c + - PATH="$PATH:$VCDIR" + - cd ${BUILD_DIR} + install: [] + script: + - cmd.exe //C vcvarsall.bat x64 '&&' nmake '-f' makefile.vc all tcltest + - cmd.exe //C vcvarsall.bat x64 '&&' nmake '-f' makefile.vc test + - name: "Windows/MSVC/Shared: UTF_MAX=4" + os: windows + compiler: cl + env: *vcenv + before_install: *vcpreinst + install: [] + script: + - cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=utfmax' '-f' makefile.vc all tcltest + - cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=utfmax' '-f' makefile.vc test + - name: "Windows/MSVC/Static" + os: windows + compiler: cl + env: *vcenv + before_install: *vcpreinst + install: [] + script: + - cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=static,msvcrt' '-f' makefile.vc all tcltest + - cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=static,msvcrt' '-f' makefile.vc test + - name: "Windows/MSVC/StaticPackage" + os: windows + compiler: cl + env: *vcenv + before_install: *vcpreinst + install: [] + script: + - cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=static,staticpkg,msvcrt' '-f' makefile.vc all tcltest + - cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=static,staticpkg,msvcrt' '-f' makefile.vc test + - name: "Windows/MSVC/Debug" + os: windows + compiler: cl + env: *vcenv + before_install: *vcpreinst + install: [] + script: + - cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=symbols' '-f' makefile.vc all tcltest + - cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=symbols' '-f' makefile.vc test + - name: "Windows/MSVC/Mem-Debug" + os: windows + compiler: cl + env: *vcenv + before_install: *vcpreinst + install: [] + script: + - cmd.exe //C vcvarsall.bat x64 '&&' nmake 'STATS=memdbg' '-f' makefile.vc all tcltest + - cmd.exe //C vcvarsall.bat x64 '&&' nmake 'STATS=memdbg' '-f' makefile.vc test +# Test on Windows with MSVC native (32-bit) + - name: "Windows/MSVC-x86/Shared" + os: windows + compiler: cl + env: *vcenv + before_install: *vcpreinst + install: [] + script: + - cmd.exe //C vcvarsall.bat x86 '&&' nmake '-f' makefile.vc all tcltest + - cmd.exe //C vcvarsall.bat x86 '&&' nmake '-f' makefile.vc test + - name: "Windows/MSVC-x86/Shared: UTF_MAX=4" + os: windows + compiler: cl + env: *vcenv + before_install: *vcpreinst + install: [] + script: + - cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=utfmax' '-f' makefile.vc all tcltest + - cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=utfmax' '-f' makefile.vc test + - name: "Windows/MSVC-x86/Static" + os: windows + compiler: cl + env: *vcenv + before_install: *vcpreinst + install: [] + script: + - cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=static,msvcrt' '-f' makefile.vc all tcltest + - cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=static,msvcrt' '-f' makefile.vc test + - name: "Windows/MSVC-x86/Debug" + os: windows + compiler: cl + env: *vcenv + before_install: *vcpreinst + install: [] + script: + - cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=symbols' '-f' makefile.vc all tcltest + - cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=symbols' '-f' makefile.vc test + - name: "Windows/MSVC-x86/Mem-Debug" + os: windows + compiler: cl + env: *vcenv + before_install: *vcpreinst + install: [] + script: + - cmd.exe //C vcvarsall.bat x86 '&&' nmake 'STATS=memdbg' '-f' makefile.vc all tcltest + - cmd.exe //C vcvarsall.bat x86 '&&' nmake 'STATS=memdbg' '-f' makefile.vc test +# Test on Windows with GCC native + - name: "Windows/GCC/Shared" + os: windows + compiler: gcc + env: + - BUILD_DIR=win + - CFGOPT="--enable-64bit" + before_install: &makepreinst + - rm -rf tests/safe-stock8*.test + - touch generic/tclStubInit.c generic/tclOOStubInit.c + - choco install -y make + - cd ${BUILD_DIR} + - name: "Windows/GCC/Shared: UTF_MAX=4" + os: windows + compiler: gcc + env: + - BUILD_DIR=win + - CFGOPT="--enable-64bit CFLAGS=-DTCL_UTF_MAX=4" + before_install: *makepreinst + - name: "Windows/GCC/Static" + os: windows + compiler: gcc + env: + - BUILD_DIR=win + - CFGOPT="--enable-64bit --disable-shared" + before_install: *makepreinst + - name: "Windows/GCC/Debug" + os: windows + compiler: gcc + env: + - BUILD_DIR=win + - CFGOPT="--enable-64bit --enable-symbols" + before_install: *makepreinst + - name: "Windows/GCC/Mem-Debug" + os: windows + compiler: gcc + env: + - BUILD_DIR=win + - CFGOPT="--enable-64bit --enable-symbols=mem" + before_install: *makepreinst +# Test on Windows with GCC native (32-bit) + - name: "Windows/GCC-x86/Shared" + os: windows + compiler: gcc + env: + - BUILD_DIR=win + before_install: *makepreinst + - name: "Windows/GCC-x86/Shared: UTF_MAX=4" + os: windows + compiler: gcc + env: + - BUILD_DIR=win + - CFGOPT="CFLAGS=-DTCL_UTF_MAX=4" + before_install: *makepreinst + - name: "Windows/GCC-x86/Static" + os: windows + compiler: gcc + env: + - BUILD_DIR=win + - CFGOPT="--disable-shared" + before_install: *makepreinst + - name: "Windows/GCC-x86/Debug" + os: windows + compiler: gcc + env: + - BUILD_DIR=win + - CFGOPT="--enable-symbols" + before_install: *makepreinst + - name: "Windows/GCC-x86/Mem-Debug" + os: windows + compiler: gcc + env: + - BUILD_DIR=win + - CFGOPT="--enable-symbols=mem" + before_install: *makepreinst +# "make dist" only + - name: "Linux: make dist" + os: linux + dist: focal + compiler: gcc + env: + - BUILD_DIR=unix + script: + - make dist +before_install: + - rm -rf tests/safe-stock8*.test + - touch generic/tclStubInit.c generic/tclOOStubInit.c + - cd ${BUILD_DIR} +install: + - mkdir "$HOME/install dir" + - ./configure ${CFGOPT} "--prefix=$HOME/install dir" || (cat config.log && exit 1) +before_script: + - export ERROR_ON_FAILURES=1 +script: + - make all tcltest || echo "Something wrong, maybe a hickup, let's try again" + - make test + - make install Index: ChangeLog ================================================================== --- ChangeLog +++ ChangeLog @@ -1845,11 +1845,11 @@ 2012-01-22 Jan Nijtmans * tools/uniClass.tcl: [FRQ 3473670]: Various Unicode-related * tools/uniParse.tcl: speedups/robustness. Enhanced tools to be - * generic/tclUniData.c: able to handle characters > 0xffff. Done in + * generic/tclUniData.c: able to handle characters > 0xFFFF. Done in * generic/tclUtf.c: all branches in order to simplify merges for * generic/regc_locale.c: new Unicode versions (such as 6.1) 2012-01-22 Donal K. Fellows Index: ChangeLog.2000 ================================================================== --- ChangeLog.2000 +++ ChangeLog.2000 @@ -1777,11 +1777,11 @@ -all]. * generic/tclCmdMZ.c: Fixed infinite loop bug with [regexp -all] [Bug: 4981]. - * tests/*.test: Changed all occurances of "namespace import + * tests/*.test: Changed all occurrences of "namespace import ::tcltest" to "namespace import -force ::tcltest" [Bug: 3948]. 2000-04-09 Brent Welch * lib/httpd2.1/http.tcl: Worked on the "server closes before reading Index: ChangeLog.2001 ================================================================== --- ChangeLog.2001 +++ ChangeLog.2001 @@ -349,11 +349,11 @@ removed line continuation in #if clause as this breaks the mac resource compiler (note that *.r files include tcl.h) * mac/tclMacFile.c: fixed bug in permission checking code - * mac/tclMacLoad.c: corrected utf8 handling, comparison of package + * mac/tclMacLoad.c: corrected utf-8 handling, comparison of package names to code fragment names changed to only match on the length of package name, this allows for fragment names with version numbers appended. * mac/tclMacInt.h: @@ -3523,11 +3523,11 @@ 2001-03-06 Donal K. Fellows * generic/tclVar.c (Tcl_UnsetObjCmd): Rewrote argument parser to avoid a read off the end of the argument array that could occur when executing something like [unset -nocomplain] was executed. Improved - the error message given when too few arguments are given (-nocomplain + the error message given when not enough arguments are given (-nocomplain should obviously be *before* --, not after it) and also modified the test suite to take account of that and the documentation to use the same improvement. [Bug 405769] 2001-03-02 Donal K. Fellows Index: ChangeLog.2002 ================================================================== --- ChangeLog.2002 +++ ChangeLog.2002 @@ -1751,11 +1751,11 @@ * changes: added recent changes 2002-07-05 Reinhard Max - * generic/tclClock.c (FormatClock): Convert the format string to UTF8 + * generic/tclClock.c (FormatClock): Convert the format string to utf-8 before calling TclpStrftime, so that non-ASCII characters don't get mangled when the result string is being converted back. * tests/clock.test: Added a test for that. 2002-07-05 Donal K. Fellows Index: ChangeLog.2004 ================================================================== --- ChangeLog.2004 +++ ChangeLog.2004 @@ -2300,11 +2300,11 @@ * doc/OpenFileChnl.3: Added description of the behaviour of Tcl_ReadChars when its 'charsToRead' argument is set to -1. Fixes [Bug 934511]. * doc/CrtCommand.3: Added note that the arguments given to the command - proc of a Tcl_CreateCommand are in utf8 since Tcl 8.1. Closing [Patch + proc of a Tcl_CreateCommand are in utf-8 since Tcl 8.1. Closing [Patch 414778]. * doc/ChnlStack.3: Removed the declaration that the interp argument to Tcl_(un)StackChannel can be NULL. This fixes [Bug 881220], reported by Marco Maggi . @@ -2871,11 +2871,11 @@ for them. 2004-06-02 Jeff Hobbs * win/tclWinFile.c (TclpFindExecutable): when using GetModuleFileNameA - (Win9x), convert from CP_ACP to WCHAR then convert back to utf8. + (Win9x), convert from CP_ACP to WCHAR then convert back to utf-8. Adjunct to 2004-04-07 fix. 2004-06-02 David Gravereaux * tests/winPipe.test (winpipe-6.1): blocking set to 1 before closing Index: ChangeLog.2005 ================================================================== --- ChangeLog.2005 +++ ChangeLog.2005 @@ -2911,11 +2911,11 @@ * generic/tclExecute.c: Updated callers to call new routine. * generic/tclBasic.c: Updated callers to call new routine. * generic/tclCompCmds.c: Updated callers to call new routine. * generic/tclDictObj.c: Updated callers to call new routine. * tests/obj.test: Corrected bad tests that actually expected - values like "47" and "0xac" to be accepted as booleans. + values like "47" and "0xAC" to be accepted as booleans. * generic/tclLiteral.c: Disabled the code that forces some literals into the "int" Tcl_ObjType during registration. We can re-enable it if this change causes trouble, but it seems more sensible to let Tcl's "on-demand" shimmering rule, and not try to pre-guess things. Index: ChangeLog.2007 ================================================================== --- ChangeLog.2007 +++ ChangeLog.2007 @@ -1424,11 +1424,11 @@ * generic/tclCompCmds.c (TclCompileReturnCmd): Added crash protection to handle callers other than TclCompileScript() failing to meet the initialization assumptions of the TIP 280 code in CompileWord(). * generic/tclCompExpr.c: Suppress the attempt to convert to - numeric when pre-compiling a constant expression indicates an error. + numeric when pre-compiling a constant expresion indicates an error. 2007-08-22 Miguel Sofer * generic/tclExecute.c (TEBC): disable the new shortcut to frequent INSTs for debug builds. REVERTED (collision with alternative fix) Index: README.md ================================================================== --- README.md +++ README.md @@ -1,13 +1,26 @@ # README: Tcl -This is the **Tcl 9.0a0** source distribution. +This is the **Tcl 8.6.10** source distribution. You can get any source release of Tcl from [our distribution site](https://sourceforge.net/projects/tcl/files/Tcl/). -[![Build Status](https://travis-ci.org/tcltk/tcl.svg?branch=master)](https://travis-ci.org/tcltk/tcl) +8.6.10 +[![Build Status](https://github.com/tcltk/tcl/workflows/Linux%20Build%20and%20Test/badge.svg?branch=core-8-6-branch)](https://github.com/tcltk/tcl/actions?query=workflow%3A%22Linux+Build+and+Test%22+branch%3Acore-8-6-branch) +[![Build Status](https://github.com/tcltk/tcl/workflows/Windows%20Build%20and%20Test/badge.svg?branch=core-8-6-branch)](https://github.com/tcltk/tcl/actions?query=workflow%3A%22Windows+Build+and+Test%22+branch%3Acore-8-6-branch) +[![Build Status](https://github.com/tcltk/tcl/workflows/macOS%20Build%20and%20Test/badge.svg?branch=core-8-6-branch)](https://github.com/tcltk/tcl/actions?query=workflow%3A%22macOS+Build+and+Test%22+branch%3Acore-8-6-branch) +
+8.7a4 +[![Build Status](https://github.com/tcltk/tcl/workflows/Linux%20Build%20and%20Test/badge.svg?branch=core-8-branch)](https://github.com/tcltk/tcl/actions?query=workflow%3A%22Linux+Build+and+Test%22+branch%3Acore-8-branch) +[![Build Status](https://github.com/tcltk/tcl/workflows/Windows%20Build%20and%20Test/badge.svg?branch=core-8-branch)](https://github.com/tcltk/tcl/actions?query=workflow%3A%22Windows+Build+and+Test%22+branch%3Acore-8-branch) +[![Build Status](https://github.com/tcltk/tcl/workflows/macOS%20Build%20and%20Test/badge.svg?branch=core-8-branch)](https://github.com/tcltk/tcl/actions?query=workflow%3A%22macOS+Build+and+Test%22+branch%3Acore-8-branch) +
+9.0a2 +[![Build Status](https://github.com/tcltk/tcl/workflows/Linux%20Build%20and%20Test/badge.svg?branch=main)](https://github.com/tcltk/tcl/actions?query=workflow%3A%22Linux+Build+and+Test%22+branch%3Amain) +[![Build Status](https://github.com/tcltk/tcl/workflows/Windows%20Build%20and%20Test/badge.svg?branch=main)](https://github.com/tcltk/tcl/actions?query=workflow%3A%22Windows+Build+and+Test%22+branch%3Amain) +[![Build Status](https://github.com/tcltk/tcl/workflows/macOS%20Build%20and%20Test/badge.svg?branch=main)](https://github.com/tcltk/tcl/actions?query=workflow%3A%22macOS+Build+and+Test%22+branch%3Amain) ## Contents 1. [Introduction](#intro) 2. [Documentation](#doc) 3. [Compiling and installing Tcl](#build) @@ -41,22 +54,22 @@ `license.terms` for complete information. ## 2. Documentation Extensive documentation is available at our website. The home page for this release, including new features, is -[here](https://www.tcl.tk/software/tcltk/9.0.html). +[here](https://www.tcl.tk/software/tcltk/8.6.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.0 is [online, -here](https://www.tcl-lang.org/man/tcl9.0/). +The complete set of reference manual entries for Tcl 8.6 is [online, +here](https://www.tcl-lang.org/man/tcl8.6/). ### 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 ================================================================== --- changes +++ changes @@ -2305,11 +2305,11 @@ 9/6/96 (bug fix) If standard channel is NULL, because Tcl cannot connect to the standard channel, do not increment the refcount. The channel can be NULL if there is for example no standard input. (JL) 9/6/96 (portability improvement) Changed parsing of backslash sequences -like \n to translate directly to absolute values like 0xa instead of +like \n to translate directly to absolute values like 0xA instead of letting the compiler do the translation. This guarantees that the translation is done the same everywhere. (JO) 9/9/96 (bug fix) If channel is opened and not associated with any interpreter, but Tcl decides to use it as one of the standard channels, it @@ -8301,11 +8301,11 @@ 2013-09-19 (bug fix)[31661d2] mem leak in [lreplace] (ade,porter) Many optmizations, improvements, and tightened stack management in bytecode. ---- Released 8.6.1, September 20, 2013 --- http://core.tcl.tk/tcl/ for details +--- Released 8.6.1, September 20, 2013 --- https://core.tcl-lang.org/tcl/ for details 2013-09-27 (enhancement) improved ::env synchronization (fellows) 2013-10-20 (bug fix)[2835313] segfault from [apply {{} {while 1 {a {*}[return -level 0 -code continue]}}}] (fellows) @@ -8449,11 +8449,11 @@ 2014-08-17 (bug fix)[7d52e11] [info class subclasses oo::object] should include ::oo::class (fellows) 2014-08-25 (TIP 429) New command [string cat] (leitgeb,ferrieux) ---- Released 8.6.2, August 27, 2014 --- http://core.tcl.tk/tcl/ for details +--- Released 8.6.2, August 27, 2014 --- https://core.tcl-lang.org/tcl/ for details 2014-08-28 (bug)[b9e1a3] Correct Method Search Order (nadkarni,fellows) => TclOO 1.0.3 *** POTENTIAL INCOMPATIBILITY *** @@ -8489,11 +8489,11 @@ 2014-11-05 (bug)[214cc0] Restore [lappend v] return value (sayers,porter) 2014-11-06 (bug)[5adc35] Stop forcing EOF to be permanent (porter) ---- Released 8.6.3, November 12, 2014 --- http://core.tcl.tk/tcl/ for details +--- Released 8.6.3, November 12, 2014 --- https://core.tcl-lang.org/tcl/ for details 2014-11-21 (bug)[743338] Win: socket error encoding (ladayaroslav,nijtmans) 2014-12-01 (bug) restore tbcload/tclcompiler support (kupries) @@ -8525,11 +8525,11 @@ 2015-02-20 (bug)[32b615] Fix compiled [lreplace] (lreplace-4.[345]) (aspect) 2015-03-10 (enhancement) Revise OS X notifier for better Cocoa (walzer) *** POTENTIAL INCOMPATIBILITY *** ---- Released 8.6.4, March 12, 2015 --- http://core.tcl.tk/tcl/ for details +--- Released 8.6.4, March 12, 2015 --- https://core.tcl-lang.org/tcl/ for details 2015-03-19 (bug)[e66e44] Win: Ctrl-C/Ctrl-Break in console not EOF (nadkarni) 2015-03-21 (bug)[d87cb1] Proper tailcall from compiled ensembles (sofer) @@ -8621,11 +8621,11 @@ 2016-02-04 (bug)[3d96b7][593baa][cf74de] crashes in OO teardown (porter,fellows) 2016-02-22 (bug)[9b4702] [info exists env(missing)] kills trace (nijtmans) ---- Released 8.6.5, February 29, 2016 --- http://core.tcl.tk/tcl/ for details +--- Released 8.6.5, February 29, 2016 --- https://core.tcl-lang.org/tcl/ for details 2016-03-01 (bug)[803042] mem leak due to reference cycle (porter) 2016-03-08 (bug)[bbc304] reflected watch race condition (porter) @@ -8695,11 +8695,11 @@ 2016-07-10 (bug)[da340d] integer division in clock math (nadkarni) 2016-07-20 tzdata updated to Olson's tzdata2016f (venkat) ---- Released 8.6.6, July 27, 2016 --- http://core.tcl.tk/tcl/ for details +--- Released 8.6.6, July 27, 2016 --- https://core.tcl-lang.org/tcl/ for details 2016-09-07 (bug)[c09edf] Bad caching with custom resolver (neumann,nijtmans) 2016-09-07 (bug)[4dbdd9] Memleak in test var-8.3 (mr_calvin,porter) @@ -8792,11 +8792,11 @@ 2017-07-06 (bug)[adb198] Plug memleak in TclJoinPath (sebres,porter) 2017-07-17 (bug)[fb2208] Repeatable tclIndex generation (wiedemann,nijtmans) ---- Released 8.6.7, August 9, 2017 --- http://core.tcl.tk/tcl/ for details +--- Released 8.6.7, August 9, 2017 --- https://core.tcl-lang.org/tcl/ for details 2017-08-10 [array names -regexp] supports backrefs (goth) 2017-08-10 Fix gcc build failures due to #pragma placement (cassoff,fellows) @@ -8827,11 +8827,11 @@ 2017-12-08 (new)[TIP 477] nmake build system reform (nadkarni) 2017-12-19 (bug)[586e71] EvalObjv exception handling at level #0 (sebres,porter) ---- Released 8.6.8, December 22, 2017 --- http://core.tcl.tk/tcl/ for details +--- Released 8.6.8, December 22, 2017 --- https://core.tcl-lang.org/tcl/ for details 2018-02-11 (enhance) stop blocking conversion of object to/from class (coulter) 2018-02-12 (enhance) NR-enable [package require] (coulter) @@ -8893,60 +8893,55 @@ 2018-11-16 (bug)[00d04c] Repair [binary encode base64] (sebres) - Released 8.6.9, November 16, 2018 - details at http://core.tcl-lang.org/tcl/ - -Changes to 8.7a1 include all changes to the 8.6 line through 8.6.7, -plus the following, which focuses on the high-level feature changes -in this changeset (new minor version) rather than bug fixes: - -2016-03-17 (bug)[0b8c38] socket accept callbacks always in global ns (porter) - *** POTENTIAL INCOMPATIBILITY *** - -2016-07-01 Hack accommodations for legacy Itcl 3 disabled (porter) - -2016-07-12 Make TCL_HASH_TYPE build-time configurable (nijtmans) - -2016-07-19 (bug)[0363f0] Partial array search ID reform (porter) - -2016-07-19 (feature removed) Tcl_ObjType "array search" unregistered (porter) - *** POTENTIAL INCOMPATIBILITY for Tcl_GetObjType("array search") *** - -2016-10-04 Server socket on port 0 chooses port supporting IPv4 * IPv6 (max) - -2016-11-25 [array names -regexp] supports backrefs (goth) - -2017-01-04 (TIP 456) New routine Tcl_OpenTcpServerEx() (limeboy) - -2017-01-04 (TIP 459) New subcommand [package files] (nijtmans) - -2017-01-16 threaded allocator initialization repair (vasiljevic,nijtmans) - -2017-01-30 Add to Win shell builtins: assoc ftype move (ashok) - -2017-03-31 TCL_MEM_DEBUG facilities better support 64-bit memory (nijtmans) - -2017-04-13 \u escaped content in msg files converted to true utf-8 (nijtmans) - -2017-05-18 (TIP 458) New epoll or kqueue notifiers are default (alborboz) - -2017-05-31 Purge build support for SunOS-4.* (stu) - -2017-06-22 (TIP 463) New option [regsub ... -command ...] (fellows) - -2017-06-22 (TIP 470) Tcl_GetDefineContextObject();[oo::define [self]] (fellows) -=> TclOO 1.2.0 - -2017-06-23 (TIP 472) Support 0d as prefix of decimal numbers (iyer,griffin) - -2017-08-31 (bug)[2a9465] http state 100 continue handling broken (oehlmann) - -2017-09-02 (bug)[0e4d88] replace command, delete trace kills namespace (porter) - ---- Released 8.7a1, September 8, 2017 --- http://core.tcl.tk/tcl/ for details - -2018-03-12 (TIP 490) add oo support for msgcat => msgcat 1.7.0 (oehlmann) - -2018-03-12 (TIP 499) custom locale preference list (oehlmann) -=> msgcat 1.7.0 - -- Released 8.7a3, Nov 30, 2018 --- http://core.tcl-lang.org/tcl/ for details - +2018-11-22 (bug)[7a9dc5] [file normalize ~/~foo] segfault (sebres) + +2018-12-30 (bug)[3cf3a9] variable 'timezone' deprecated in vc2017 (nijtmans) + +2019-01-09 (bug)[cc1e91] [list [list {*}[set a " "]]] regression (sebres) + +2019-02-01 (bug)[e3f481] tests var-1.2[01] (sebres) + +2019-03-01 (new) Update to Unicode 12.0 (nijtmans) + +2019-03-05 (new)[TIP 527] New command [timerate] (sebres) + +2019-03-08 (bug)[39fed4] [package require] memory validity (hume,porter) + +2019-04-23 (new) New command tcl::unsupported::corotype (fellows) + +2019-05-04 (bug) memlink when namespace deletion kills linked var (porter) + +2019-05-28 (new) README file converted to README.md in Markdown (nijtmans) + +2019-06-17 (bug)[8b9854] [info level 0] regression with ensembles (porter) + +2019-06-20 (bug)[6bdadf] crash multi-arg write-traced [lappend] (fellows,porter) + +2019-06-21 (bug)[f8a33c] crash Tcl_Exit before init (brooks,sebres) + +2019-08-27 (bug)[fa6bf3] Bytecode fails epoch recovery at numLevel=0 (sebres) + +2019-08-29 (bug)[fec0c1] C stack overflow compiling bytecode (ade,sebres) + +2019-09-12 tzdata updated to Olson's tzdata2019c (jima) + +2019-09-20 (new) registry/dde no longer need -DUNICODE (nijtmans) +=> registry 1.3.4 +=> dde 1.4.2 + +2019-10-02 (bug)[16768d] Fix [info hostname] on NetBSD (rytaro) + +2019-10-23 (new) libtommath updated to release 1.2.0 (nijtmans) + +2019-10-25 OSX: system Tcl deprecated. End default use of its packages. (walzer) + +2019-10-28 (bug)[bcd100] bad fs cache when system encoding changes (coulter) + +2019-11-15 (bug)[135804] segfault in [next] after destroy (coulter,sebres) + +2019-11-18 (bug)[13657a] application/json us text, not binary (noe,nijtmans) +=> http 2.9.1 + +- Released 8.6.10, Nov 21, 2019 - details at http://core.tcl-lang.org/tcl/ - Index: compat/fake-rfc2553.c ================================================================== --- compat/fake-rfc2553.c +++ compat/fake-rfc2553.c @@ -215,11 +215,11 @@ return (EAI_MEMORY); return (0); } if (!hostname) { - *res = malloc_ai(port, htonl(0x7f000001), hints); + *res = malloc_ai(port, htonl(0x7F000001), hints); if (*res == NULL) return (EAI_MEMORY); return (0); } ADDED compat/float.h Index: compat/float.h ================================================================== --- /dev/null +++ compat/float.h @@ -0,0 +1,14 @@ +/* + * float.h -- + * + * This is a dummy header file to #include in Tcl when there + * is no float.h in /usr/include. Right now this file is empty: + * Tcl contains #ifdefs to deal with the lack of definitions; + * all it needs is for the #include statement to work. + * + * Copyright (c) 1993 The Regents of the University of California. + * Copyright (c) 1994 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ Index: compat/gettod.c ================================================================== --- compat/gettod.c +++ compat/gettod.c @@ -19,12 +19,13 @@ gettimeofday( struct timeval *tp, struct timezone *tz) { struct timeb t; + (void)tz; ftime(&t); tp->tv_sec = t.time; - tp->tv_usec = t. millitm * 1000; + tp->tv_usec = t.millitm * 1000; return 0; } Index: compat/mkstemp.c ================================================================== --- compat/mkstemp.c +++ compat/mkstemp.c @@ -34,11 +34,11 @@ mkstemp( char *template) /* Template for filename. */ { static const char alphanumerics[] = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"; - register char *a, *b; + char *a, *b; int fd, count, alphanumericsLen = strlen(alphanumerics); /* == 62 */ a = template + strlen(template); while (a > template && *(a-1) == 'X') { a--; Index: compat/opendir.c ================================================================== --- compat/opendir.c +++ compat/opendir.c @@ -18,19 +18,19 @@ DIR * opendir( char *name) { - register DIR *dirp; - register int fd; - char *myname; + DIR *dirp; + int fd; + const char *myname; myname = ((*name == '\0') ? "." : name); if ((fd = open(myname, 0, 0)) == -1) { return NULL; } - dirp = (DIR *) Tcl_Alloc(sizeof(DIR)); + dirp = (DIR *) ckalloc(sizeof(DIR)); if (dirp == NULL) { /* unreachable? */ close(fd); return NULL; } @@ -63,13 +63,13 @@ * get next entry in a directory. */ struct dirent * readdir( - register DIR *dirp) + DIR *dirp) { - register struct olddirect *dp; + struct olddirect *dp; static struct dirent dir; for (;;) { if (dirp->dd_loc == 0) { dirp->dd_size = read(dirp->dd_fd, dirp->dd_buf, DIRBLKSIZ); @@ -99,12 +99,12 @@ * close a directory. */ void closedir( - register DIR *dirp) + DIR *dirp) { close(dirp->dd_fd); dirp->dd_fd = -1; dirp->dd_loc = 0; - Tcl_Free(dirp); + ckfree((char *)dirp); } Index: compat/strstr.c ================================================================== --- compat/strstr.c +++ compat/strstr.c @@ -34,33 +34,33 @@ *---------------------------------------------------------------------- */ char * strstr( - register char *string, /* String to search. */ - char *substring) /* Substring to try to find in string. */ + const char *string, /* String to search. */ + const char *substring) /* Substring to try to find in string. */ { - register char *a, *b; + const char *a, *b; /* * First scan quickly through the two strings looking for a * single-character match. When it's found, then compare the rest of the * substring. */ b = substring; if (*b == 0) { - return string; + return (char *)string; } for ( ; *string != 0; string += 1) { if (*string != *b) { continue; } a = string; while (1) { if (*b == 0) { - return string; + return (char *)string; } if (*a++ != *b++) { break; } } Index: compat/strtol.c ================================================================== --- compat/strtol.c +++ compat/strtol.c @@ -43,19 +43,19 @@ * If 0, then the base is chosen from the * leading characters of string: "0x" means * hex, "0" means octal, anything else means * decimal. */ { - register const char *p; + const char *p; long result; /* * Skip any leading blanks. */ p = string; - while (TclIsSpaceProc(*p)) { + while (isspace(UCHAR(*p))) { p += 1; } /* * Check for a sign. Index: compat/strtoul.c ================================================================== --- compat/strtoul.c +++ compat/strtoul.c @@ -60,23 +60,23 @@ * If 0, then the base is chosen from the * leading characters of string: "0x" means * hex, "0" means octal, anything else means * decimal. */ { - register const char *p; - register unsigned long int result = 0; - register unsigned digit; + const char *p; + unsigned long int result = 0; + unsigned digit; int anyDigits = 0; int negative=0; int overflow=0; /* * Skip any leading blanks. */ p = string; - while (TclIsSpaceProc(*p)) { + while (isspace(UCHAR(*p))) { p += 1; } if (*p == '-') { negative = 1; p += 1; ADDED compat/unistd.h Index: compat/unistd.h ================================================================== --- /dev/null +++ compat/unistd.h @@ -0,0 +1,76 @@ +/* + * unistd.h -- + * + * Macros, constants and prototypes for Posix conformance. + * + * Copyright 1989 Regents of the University of California Permission to use, + * copy, modify, and distribute this software and its documentation for any + * purpose and without fee is hereby granted, provided that the above + * copyright notice appear in all copies. The University of California makes + * no representations about the suitability of this software for any purpose. + * It is provided "as is" without express or implied warranty. + */ + +#ifndef _UNISTD +#define _UNISTD + +#include + +#ifndef NULL +#define NULL 0 +#endif + +/* + * Strict POSIX stuff goes here. Extensions go down below, in the ifndef + * _POSIX_SOURCE section. + */ + +extern void _exit(int status); +extern int access(const char *path, int mode); +extern int chdir(const char *path); +extern int chown(const char *path, uid_t owner, gid_t group); +extern int close(int fd); +extern int dup(int oldfd); +extern int dup2(int oldfd, int newfd); +extern int execl(const char *path, ...); +extern int execle(const char *path, ...); +extern int execlp(const char *file, ...); +extern int execv(const char *path, char **argv); +extern int execve(const char *path, char **argv, char **envp); +extern int execvpw(const char *file, char **argv); +extern pid_t fork(void); +extern char * getcwd(char *buf, size_t size); +extern gid_t getegid(void); +extern uid_t geteuid(void); +extern gid_t getgid(void); +extern int getgroups(int bufSize, int *buffer); +extern pid_t getpid(void); +extern uid_t getuid(void); +extern int isatty(int fd); +extern long lseek(int fd, long offset, int whence); +extern int pipe(int *fildes); +extern int read(int fd, char *buf, size_t size); +extern int setgid(gid_t group); +extern int setuid(uid_t user); +extern unsigned sleep(unsigned seconds); +extern char * ttyname(int fd); +extern int unlink(const char *path); +extern int write(int fd, const char *buf, size_t size); + +#ifndef _POSIX_SOURCE +extern char * crypt(const char *, const char *); +extern int fchown(int fd, uid_t owner, gid_t group); +extern int flock(int fd, int operation); +extern int ftruncate(int fd, unsigned long length); +extern int ioctl(int fd, int request, ...); +extern int readlink(const char *path, char *buf, int bufsize); +extern int setegid(gid_t group); +extern int seteuidw(uid_t user); +extern int setreuid(int ruid, int euid); +extern int symlink(const char *, const char *); +extern int ttyslot(void); +extern int truncate(const char *path, unsigned long length); +extern int vfork(void); +#endif /* _POSIX_SOURCE */ + +#endif /* _UNISTD */ Index: compat/waitpid.c ================================================================== --- compat/waitpid.c +++ compat/waitpid.c @@ -68,11 +68,11 @@ int *statusPtr, /* Where to store wait status for the * process. */ int options) /* OR'ed combination of WNOHANG and * WUNTRACED. */ { - register WaitInfo *waitPtr, *prevPtr; + WaitInfo *waitPtr, *prevPtr; pid_t result; WAIT_STATUS_TYPE status; if ((pid < -1) || (pid == 0)) { errno = EINVAL; @@ -98,11 +98,11 @@ if (prevPtr == NULL) { deadList = waitPtr->nextPtr; } else { prevPtr->nextPtr = waitPtr->nextPtr; } - Tcl_Free(waitPtr); + ckfree((char *) waitPtr); return result; } /* * Wait for any process to stop or exit. If it's an acceptable one then @@ -154,15 +154,15 @@ if (waitPtr->pid == result) { waitPtr->status = status; goto waitAgain; } } - waitPtr = (WaitInfo *) Tcl_Alloc(sizeof(WaitInfo)); + waitPtr = (WaitInfo *) ckalloc(sizeof(WaitInfo)); waitPtr->pid = result; waitPtr->status = status; waitPtr->nextPtr = deadList; deadList = waitPtr; waitAgain: continue; } } Index: compat/zlib/contrib/minizip/crypt.h ================================================================== --- compat/zlib/contrib/minizip/crypt.h +++ compat/zlib/contrib/minizip/crypt.h @@ -27,24 +27,19 @@ Encryption is not supported. */ #define CRC32(c, b) ((*(pcrc_32_tab+(((int)(c) ^ (b)) & 0xff))) ^ ((c) >> 8)) -#ifdef Z_U4 - typedef Z_U4 z_crc_t; -#else - typedef unsigned long z_crc_t; -#endif - /*********************************************************************** * Return the next byte in the pseudo-random sequence */ static int decrypt_byte(unsigned long* pkeys, const z_crc_t* pcrc_32_tab) { unsigned temp; /* POTENTIAL BUG: temp*(temp^1) may overflow in an * unpredictable manner on 16-bit systems; not a problem * with any known compiler so far, though */ + (void)pcrc_32_tab; temp = ((unsigned)(*(pkeys+2)) & 0xffff) | 2; return (int)(((temp * (temp ^ 1)) >> 8) & 0xff); } @@ -55,11 +50,11 @@ { (*(pkeys+0)) = CRC32((*(pkeys+0)), c); (*(pkeys+1)) += (*(pkeys+0)) & 0xff; (*(pkeys+1)) = (*(pkeys+1)) * 134775813L + 1; { - register int keyshift = (int)((*(pkeys+1)) >> 24); + int keyshift = (int)((*(pkeys+1)) >> 24); (*(pkeys+2)) = CRC32((*(pkeys+2)), keyshift); } return c; } Index: compat/zlib/contrib/minizip/ioapi.c ================================================================== --- compat/zlib/contrib/minizip/ioapi.c +++ compat/zlib/contrib/minizip/ioapi.c @@ -12,11 +12,15 @@ #if defined(_WIN32) && (!(defined(_CRT_SECURE_NO_WARNINGS))) #define _CRT_SECURE_NO_WARNINGS #endif -#if defined(__APPLE__) || defined(IOAPI_NO_64) +#if defined(_WIN32) +#define FOPEN_FUNC(filename, mode) fopen(filename, mode) +#define FTELLO_FUNC(stream) _ftelli64(stream) +#define FSEEKO_FUNC(stream, offset, origin) _fseeki64(stream, offset, origin) +#elif defined(__APPLE__) || defined(IOAPI_NO_64) // In darwin and perhaps other BSD variants off_t is a 64 bit value, hence no need for specific 64 bit functions #define FOPEN_FUNC(filename, mode) fopen(filename, mode) #define FTELLO_FUNC(stream) ftello(stream) #define FSEEKO_FUNC(stream, offset, origin) fseeko(stream, offset, origin) #else Index: compat/zlib/contrib/minizip/minizip.c ================================================================== --- compat/zlib/contrib/minizip/minizip.c +++ compat/zlib/contrib/minizip/minizip.c @@ -25,11 +25,15 @@ #ifndef _FILE_OFFSET_BIT #define _FILE_OFFSET_BIT 64 #endif #endif -#if defined(__APPLE__) || defined(IOAPI_NO_64) +#if defined(_WIN32) +#define FOPEN_FUNC(filename, mode) fopen(filename, mode) +#define FTELLO_FUNC(stream) _ftelli64(stream) +#define FSEEKO_FUNC(stream, offset, origin) _fseeki64(stream, offset, origin) +#elif defined(__APPLE__) || defined(IOAPI_NO_64) // In darwin and perhaps other BSD variants off_t is a 64 bit value, hence no need for specific 64 bit functions #define FOPEN_FUNC(filename, mode) fopen(filename, mode) #define FTELLO_FUNC(stream) ftello(stream) #define FSEEKO_FUNC(stream, offset, origin) fseeko(stream, offset, origin) #else @@ -68,12 +72,12 @@ #define WRITEBUFFERSIZE (16384) #define MAXFILENAME (256) #ifdef _WIN32 uLong filetime(f, tmzip, dt) - char *f; /* name of file to get info on */ - tm_zip *tmzip; /* return value: access, modific. and creation times */ + const char *f; /* name of file to get info on */ + tm_zip *tmzip; /* return value: access, modific. and creation times */ uLong *dt; /* dostime */ { int ret = 0; { FILETIME ftLocal; @@ -92,11 +96,11 @@ return ret; } #else #if defined(unix) || defined(__APPLE__) uLong filetime(f, tmzip, dt) - char *f; /* name of file to get info on */ + const char *f; /* name of file to get info on */ tm_zip *tmzip; /* return value: access, modific. and creation times */ uLong *dt; /* dostime */ { int ret=0; struct stat s; /* results of stat() */ @@ -134,12 +138,12 @@ return ret; } #else uLong filetime(f, tmzip, dt) - char *f; /* name of file to get info on */ - tm_zip *tmzip; /* return value: access, modific. and creation times */ + const char *f; /* name of file to get info on */ + tm_zip *tmzip; /* return value: access, modific. and creation times */ uLong *dt; /* dostime */ { return 0; } #endif Index: compat/zlib/contrib/vstudio/vc10/zlibvc.sln ================================================================== --- compat/zlib/contrib/vstudio/vc10/zlibvc.sln +++ compat/zlib/contrib/vstudio/vc10/zlibvc.sln Index: compat/zlib/contrib/vstudio/vc11/zlibvc.sln ================================================================== --- compat/zlib/contrib/vstudio/vc11/zlibvc.sln +++ compat/zlib/contrib/vstudio/vc11/zlibvc.sln Index: compat/zlib/contrib/vstudio/vc12/zlibvc.sln ================================================================== --- compat/zlib/contrib/vstudio/vc12/zlibvc.sln +++ compat/zlib/contrib/vstudio/vc12/zlibvc.sln @@ -1,119 +1,119 @@ - -Microsoft Visual Studio Solution File, Format Version 12.00 -# Visual Studio 2013 -VisualStudioVersion = 12.0.40629.0 -MinimumVisualStudioVersion = 10.0.40219.1 -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "zlibvc", "zlibvc.vcxproj", "{8FD826F8-3739-44E6-8CC8-997122E53B8D}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "zlibstat", "zlibstat.vcxproj", "{745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "testzlib", "testzlib.vcxproj", "{AA6666AA-E09F-4135-9C0C-4FE50C3C654B}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "testzlibdll", "testzlibdll.vcxproj", "{C52F9E7B-498A-42BE-8DB4-85A15694366A}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "minizip", "minizip.vcxproj", "{48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "miniunz", "miniunz.vcxproj", "{C52F9E7B-498A-42BE-8DB4-85A15694382A}" -EndProject -Global - GlobalSection(SolutionConfigurationPlatforms) = preSolution - Debug|Itanium = Debug|Itanium - Debug|Win32 = Debug|Win32 - Debug|x64 = Debug|x64 - Release|Itanium = Release|Itanium - Release|Win32 = Release|Win32 - Release|x64 = Release|x64 - ReleaseWithoutAsm|Itanium = ReleaseWithoutAsm|Itanium - ReleaseWithoutAsm|Win32 = ReleaseWithoutAsm|Win32 - ReleaseWithoutAsm|x64 = ReleaseWithoutAsm|x64 - EndGlobalSection - GlobalSection(ProjectConfigurationPlatforms) = postSolution - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Itanium.ActiveCfg = Debug|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Win32.ActiveCfg = Debug|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Win32.Build.0 = Debug|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|x64.ActiveCfg = Debug|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|x64.Build.0 = Debug|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Itanium.ActiveCfg = Release|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Win32.ActiveCfg = Release|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Win32.Build.0 = Release|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|x64.ActiveCfg = Release|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|x64.Build.0 = Release|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Itanium.ActiveCfg = Debug|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Win32.ActiveCfg = Debug|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Win32.Build.0 = Debug|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|x64.ActiveCfg = Debug|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|x64.Build.0 = Debug|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Itanium.ActiveCfg = Release|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Win32.ActiveCfg = Release|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Win32.Build.0 = Release|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|x64.ActiveCfg = Release|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|x64.Build.0 = Release|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Itanium.ActiveCfg = Debug|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.ActiveCfg = Debug|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.Build.0 = Debug|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.ActiveCfg = Debug|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.Build.0 = Debug|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Itanium.ActiveCfg = Release|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.ActiveCfg = Release|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.Build.0 = Release|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.ActiveCfg = Release|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.Build.0 = Release|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Itanium.ActiveCfg = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Win32.ActiveCfg = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Win32.Build.0 = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|x64.ActiveCfg = Debug|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|x64.Build.0 = Debug|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Itanium.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Win32.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Win32.Build.0 = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|x64.ActiveCfg = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|x64.Build.0 = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Itanium.ActiveCfg = Debug|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.ActiveCfg = Debug|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.Build.0 = Debug|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.ActiveCfg = Debug|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.Build.0 = Debug|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Itanium.ActiveCfg = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.ActiveCfg = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.Build.0 = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.ActiveCfg = Release|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.Build.0 = Release|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Itanium.ActiveCfg = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Win32.ActiveCfg = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Win32.Build.0 = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|x64.ActiveCfg = Debug|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|x64.Build.0 = Debug|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Itanium.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Win32.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Win32.Build.0 = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|x64.ActiveCfg = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|x64.Build.0 = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 - EndGlobalSection - GlobalSection(SolutionProperties) = preSolution - HideSolutionNode = FALSE - EndGlobalSection -EndGlobal + +Microsoft Visual Studio Solution File, Format Version 12.00 +# Visual Studio 2013 +VisualStudioVersion = 12.0.40629.0 +MinimumVisualStudioVersion = 10.0.40219.1 +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "zlibvc", "zlibvc.vcxproj", "{8FD826F8-3739-44E6-8CC8-997122E53B8D}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "zlibstat", "zlibstat.vcxproj", "{745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "testzlib", "testzlib.vcxproj", "{AA6666AA-E09F-4135-9C0C-4FE50C3C654B}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "testzlibdll", "testzlibdll.vcxproj", "{C52F9E7B-498A-42BE-8DB4-85A15694366A}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "minizip", "minizip.vcxproj", "{48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "miniunz", "miniunz.vcxproj", "{C52F9E7B-498A-42BE-8DB4-85A15694382A}" +EndProject +Global + GlobalSection(SolutionConfigurationPlatforms) = preSolution + Debug|Itanium = Debug|Itanium + Debug|Win32 = Debug|Win32 + Debug|x64 = Debug|x64 + Release|Itanium = Release|Itanium + Release|Win32 = Release|Win32 + Release|x64 = Release|x64 + ReleaseWithoutAsm|Itanium = ReleaseWithoutAsm|Itanium + ReleaseWithoutAsm|Win32 = ReleaseWithoutAsm|Win32 + ReleaseWithoutAsm|x64 = ReleaseWithoutAsm|x64 + EndGlobalSection + GlobalSection(ProjectConfigurationPlatforms) = postSolution + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Itanium.ActiveCfg = Debug|Win32 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Win32.ActiveCfg = Debug|Win32 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Win32.Build.0 = Debug|Win32 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|x64.ActiveCfg = Debug|x64 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|x64.Build.0 = Debug|x64 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Itanium.ActiveCfg = Release|Win32 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Win32.ActiveCfg = Release|Win32 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Win32.Build.0 = Release|Win32 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|x64.ActiveCfg = Release|x64 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|x64.Build.0 = Release|x64 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Win32 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Itanium.ActiveCfg = Debug|Win32 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Win32.ActiveCfg = Debug|Win32 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Win32.Build.0 = Debug|Win32 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|x64.ActiveCfg = Debug|x64 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|x64.Build.0 = Debug|x64 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Itanium.ActiveCfg = Release|Win32 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Win32.ActiveCfg = Release|Win32 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Win32.Build.0 = Release|Win32 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|x64.ActiveCfg = Release|x64 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|x64.Build.0 = Release|x64 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Win32 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Itanium.ActiveCfg = Debug|Win32 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.ActiveCfg = Debug|Win32 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.Build.0 = Debug|Win32 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.ActiveCfg = Debug|x64 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.Build.0 = Debug|x64 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Itanium.ActiveCfg = Release|Win32 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.ActiveCfg = Release|Win32 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.Build.0 = Release|Win32 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.ActiveCfg = Release|x64 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.Build.0 = Release|x64 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Win32 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Itanium.ActiveCfg = Debug|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Win32.ActiveCfg = Debug|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Win32.Build.0 = Debug|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|x64.ActiveCfg = Debug|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|x64.Build.0 = Debug|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Itanium.ActiveCfg = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Win32.ActiveCfg = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Win32.Build.0 = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|x64.ActiveCfg = Release|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|x64.Build.0 = Release|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Itanium.ActiveCfg = Debug|Win32 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.ActiveCfg = Debug|Win32 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.Build.0 = Debug|Win32 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.ActiveCfg = Debug|x64 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.Build.0 = Debug|x64 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Itanium.ActiveCfg = Release|Win32 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.ActiveCfg = Release|Win32 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.Build.0 = Release|Win32 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.ActiveCfg = Release|x64 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.Build.0 = Release|x64 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Win32 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Itanium.ActiveCfg = Debug|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Win32.ActiveCfg = Debug|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Win32.Build.0 = Debug|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|x64.ActiveCfg = Debug|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|x64.Build.0 = Debug|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Itanium.ActiveCfg = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Win32.ActiveCfg = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Win32.Build.0 = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|x64.ActiveCfg = Release|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|x64.Build.0 = Release|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 + EndGlobalSection + GlobalSection(SolutionProperties) = preSolution + HideSolutionNode = FALSE + EndGlobalSection +EndGlobal Index: compat/zlib/contrib/vstudio/vc14/zlibvc.sln ================================================================== --- compat/zlib/contrib/vstudio/vc14/zlibvc.sln +++ compat/zlib/contrib/vstudio/vc14/zlibvc.sln @@ -1,119 +1,119 @@ - -Microsoft Visual Studio Solution File, Format Version 12.00 -# Visual Studio 14 -VisualStudioVersion = 14.0.25420.1 -MinimumVisualStudioVersion = 10.0.40219.1 -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "zlibvc", "zlibvc.vcxproj", "{8FD826F8-3739-44E6-8CC8-997122E53B8D}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "zlibstat", "zlibstat.vcxproj", "{745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "testzlib", "testzlib.vcxproj", "{AA6666AA-E09F-4135-9C0C-4FE50C3C654B}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "testzlibdll", "testzlibdll.vcxproj", "{C52F9E7B-498A-42BE-8DB4-85A15694366A}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "minizip", "minizip.vcxproj", "{48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "miniunz", "miniunz.vcxproj", "{C52F9E7B-498A-42BE-8DB4-85A15694382A}" -EndProject -Global - GlobalSection(SolutionConfigurationPlatforms) = preSolution - Debug|Itanium = Debug|Itanium - Debug|Win32 = Debug|Win32 - Debug|x64 = Debug|x64 - Release|Itanium = Release|Itanium - Release|Win32 = Release|Win32 - Release|x64 = Release|x64 - ReleaseWithoutAsm|Itanium = ReleaseWithoutAsm|Itanium - ReleaseWithoutAsm|Win32 = ReleaseWithoutAsm|Win32 - ReleaseWithoutAsm|x64 = ReleaseWithoutAsm|x64 - EndGlobalSection - GlobalSection(ProjectConfigurationPlatforms) = postSolution - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Itanium.ActiveCfg = Debug|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Win32.ActiveCfg = Debug|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Win32.Build.0 = Debug|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|x64.ActiveCfg = Debug|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|x64.Build.0 = Debug|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Itanium.ActiveCfg = Release|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Win32.ActiveCfg = Release|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Win32.Build.0 = Release|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|x64.ActiveCfg = Release|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|x64.Build.0 = Release|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Itanium.ActiveCfg = Debug|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Win32.ActiveCfg = Debug|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Win32.Build.0 = Debug|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|x64.ActiveCfg = Debug|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|x64.Build.0 = Debug|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Itanium.ActiveCfg = Release|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Win32.ActiveCfg = Release|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Win32.Build.0 = Release|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|x64.ActiveCfg = Release|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|x64.Build.0 = Release|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Itanium.ActiveCfg = Debug|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.ActiveCfg = Debug|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.Build.0 = Debug|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.ActiveCfg = Debug|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.Build.0 = Debug|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Itanium.ActiveCfg = Release|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.ActiveCfg = Release|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.Build.0 = Release|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.ActiveCfg = Release|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.Build.0 = Release|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Itanium.ActiveCfg = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Win32.ActiveCfg = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Win32.Build.0 = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|x64.ActiveCfg = Debug|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|x64.Build.0 = Debug|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Itanium.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Win32.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Win32.Build.0 = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|x64.ActiveCfg = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|x64.Build.0 = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Itanium.ActiveCfg = Debug|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.ActiveCfg = Debug|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.Build.0 = Debug|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.ActiveCfg = Debug|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.Build.0 = Debug|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Itanium.ActiveCfg = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.ActiveCfg = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.Build.0 = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.ActiveCfg = Release|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.Build.0 = Release|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Itanium.ActiveCfg = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Win32.ActiveCfg = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Win32.Build.0 = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|x64.ActiveCfg = Debug|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|x64.Build.0 = Debug|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Itanium.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Win32.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Win32.Build.0 = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|x64.ActiveCfg = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|x64.Build.0 = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 - EndGlobalSection - GlobalSection(SolutionProperties) = preSolution - HideSolutionNode = FALSE - EndGlobalSection -EndGlobal + +Microsoft Visual Studio Solution File, Format Version 12.00 +# Visual Studio 14 +VisualStudioVersion = 14.0.25420.1 +MinimumVisualStudioVersion = 10.0.40219.1 +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "zlibvc", "zlibvc.vcxproj", "{8FD826F8-3739-44E6-8CC8-997122E53B8D}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "zlibstat", "zlibstat.vcxproj", "{745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "testzlib", "testzlib.vcxproj", "{AA6666AA-E09F-4135-9C0C-4FE50C3C654B}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "testzlibdll", "testzlibdll.vcxproj", "{C52F9E7B-498A-42BE-8DB4-85A15694366A}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "minizip", "minizip.vcxproj", "{48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "miniunz", "miniunz.vcxproj", "{C52F9E7B-498A-42BE-8DB4-85A15694382A}" +EndProject +Global + GlobalSection(SolutionConfigurationPlatforms) = preSolution + Debug|Itanium = Debug|Itanium + Debug|Win32 = Debug|Win32 + Debug|x64 = Debug|x64 + Release|Itanium = Release|Itanium + Release|Win32 = Release|Win32 + Release|x64 = Release|x64 + ReleaseWithoutAsm|Itanium = ReleaseWithoutAsm|Itanium + ReleaseWithoutAsm|Win32 = ReleaseWithoutAsm|Win32 + ReleaseWithoutAsm|x64 = ReleaseWithoutAsm|x64 + EndGlobalSection + GlobalSection(ProjectConfigurationPlatforms) = postSolution + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Itanium.ActiveCfg = Debug|Win32 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Win32.ActiveCfg = Debug|Win32 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Win32.Build.0 = Debug|Win32 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|x64.ActiveCfg = Debug|x64 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|x64.Build.0 = Debug|x64 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Itanium.ActiveCfg = Release|Win32 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Win32.ActiveCfg = Release|Win32 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Win32.Build.0 = Release|Win32 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|x64.ActiveCfg = Release|x64 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|x64.Build.0 = Release|x64 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Win32 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Itanium.ActiveCfg = Debug|Win32 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Win32.ActiveCfg = Debug|Win32 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Win32.Build.0 = Debug|Win32 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|x64.ActiveCfg = Debug|x64 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|x64.Build.0 = Debug|x64 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Itanium.ActiveCfg = Release|Win32 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Win32.ActiveCfg = Release|Win32 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Win32.Build.0 = Release|Win32 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|x64.ActiveCfg = Release|x64 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|x64.Build.0 = Release|x64 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Win32 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Itanium.ActiveCfg = Debug|Win32 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.ActiveCfg = Debug|Win32 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.Build.0 = Debug|Win32 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.ActiveCfg = Debug|x64 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.Build.0 = Debug|x64 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Itanium.ActiveCfg = Release|Win32 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.ActiveCfg = Release|Win32 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.Build.0 = Release|Win32 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.ActiveCfg = Release|x64 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.Build.0 = Release|x64 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Win32 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Itanium.ActiveCfg = Debug|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Win32.ActiveCfg = Debug|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Win32.Build.0 = Debug|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|x64.ActiveCfg = Debug|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|x64.Build.0 = Debug|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Itanium.ActiveCfg = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Win32.ActiveCfg = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Win32.Build.0 = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|x64.ActiveCfg = Release|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|x64.Build.0 = Release|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Itanium.ActiveCfg = Debug|Win32 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.ActiveCfg = Debug|Win32 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.Build.0 = Debug|Win32 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.ActiveCfg = Debug|x64 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.Build.0 = Debug|x64 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Itanium.ActiveCfg = Release|Win32 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.ActiveCfg = Release|Win32 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.Build.0 = Release|Win32 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.ActiveCfg = Release|x64 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.Build.0 = Release|x64 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Win32 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Itanium.ActiveCfg = Debug|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Win32.ActiveCfg = Debug|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Win32.Build.0 = Debug|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|x64.ActiveCfg = Debug|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|x64.Build.0 = Debug|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Itanium.ActiveCfg = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Win32.ActiveCfg = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Win32.Build.0 = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|x64.ActiveCfg = Release|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|x64.Build.0 = Release|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 + EndGlobalSection + GlobalSection(SolutionProperties) = preSolution + HideSolutionNode = FALSE + EndGlobalSection +EndGlobal Index: compat/zlib/contrib/vstudio/vc9/zlibvc.sln ================================================================== --- compat/zlib/contrib/vstudio/vc9/zlibvc.sln +++ compat/zlib/contrib/vstudio/vc9/zlibvc.sln Index: doc/AddErrInfo.3 ================================================================== --- doc/AddErrInfo.3 +++ doc/AddErrInfo.3 @@ -7,11 +7,11 @@ '\" .TH Tcl_AddErrorInfo 3 8.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME -Tcl_GetReturnOptions, Tcl_SetReturnOptions, Tcl_AddErrorInfo, Tcl_AppendObjToErrorInfo, Tcl_AddObjErrorInfo, Tcl_SetObjErrorCode, Tcl_SetErrorCode, Tcl_SetErrorLine, Tcl_GetErrorLine, Tcl_PosixError, Tcl_LogCommandInfo \- retrieve or record information about errors and other return options +Tcl_GetReturnOptions, Tcl_SetReturnOptions, Tcl_AddErrorInfo, Tcl_AppendObjToErrorInfo, Tcl_AddObjErrorInfo, Tcl_SetObjErrorCode, Tcl_SetErrorCode, Tcl_SetErrorCodeVA, Tcl_SetErrorLine, Tcl_GetErrorLine, Tcl_PosixError, Tcl_LogCommandInfo \- retrieve or record information about errors and other return options .SH SYNOPSIS .nf \fB#include \fR .sp Tcl_Obj * @@ -27,10 +27,12 @@ \fBTcl_AddObjErrorInfo\fR(\fIinterp, message, length\fR) .sp \fBTcl_SetObjErrorCode\fR(\fIinterp, errorObjPtr\fR) .sp \fBTcl_SetErrorCode\fR(\fIinterp, element, element, ... \fB(char *) NULL\fR) +.sp +\fBTcl_SetErrorCodeVA\fR(\fIinterp, argList\fR) .sp \fBTcl_GetErrorLine\fR(\fIinterp\fR) .sp \fBTcl_SetErrorLine\fR(\fIinterp, lineNum\fR) .sp @@ -56,14 +58,14 @@ This byte array may contain embedded null bytes unless \fIlength\fR is negative. .AP Tcl_Obj *objPtr in A message to be appended to the \fB\-errorinfo\fR return option in the form of a Tcl_Obj value. -.AP size_t length in +.AP int length in The number of bytes to copy from \fImessage\fR when appending to the \fB\-errorinfo\fR return option. -If TCL_AUTO_LENGTH, all bytes up to the first null byte are used. +If negative, all bytes up to the first null byte are used. .AP Tcl_Obj *errorObjPtr in The \fB\-errorcode\fR return option will be set to this value. .AP char *element in String to record as one element of the \fB\-errorcode\fR return option. Last \fIelement\fR argument must be NULL. @@ -115,11 +117,11 @@ A typical usage for \fBTcl_GetReturnOptions\fR is to retrieve the stack trace when script evaluation returns \fBTCL_ERROR\fR, like so: .PP .CS -int code = Tcl_EvalEx(interp, script, -1, 0); +int code = Tcl_Eval(interp, script); if (code == TCL_ERROR) { Tcl_Obj *options = \fBTcl_GetReturnOptions\fR(interp, code); Tcl_Obj *key = Tcl_NewStringObj("-errorinfo", -1); Tcl_Obj *stackTrace; Tcl_IncrRefCount(key); @@ -241,10 +243,13 @@ The procedure \fBTcl_SetErrorCode\fR is also used to set the \fB\-errorcode\fR return option. However, it takes one or more strings to record instead of a value. Otherwise, it is similar to \fBTcl_SetObjErrorCode\fR in behavior. .PP +\fBTcl_SetErrorCodeVA\fR is the same as \fBTcl_SetErrorCode\fR except that +instead of taking a variable number of arguments it takes an argument list. +.PP The procedure \fBTcl_GetErrorLine\fR is used to read the integer value of the \fB\-errorline\fR return option without the overhead of a full call to \fBTcl_GetReturnOptions\fR. Likewise, \fBTcl_SetErrorLine\fR sets the \fB\-errorline\fR return option value. .PP Index: doc/Alloc.3 ================================================================== --- doc/Alloc.3 +++ doc/Alloc.3 @@ -6,11 +6,11 @@ '\" .TH Tcl_Alloc 3 7.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME -Tcl_Alloc, Tcl_Free, Tcl_Realloc, Tcl_AttemptAlloc, Tcl_AttemptRealloc \- allocate or free heap memory +Tcl_Alloc, Tcl_Free, Tcl_Realloc, Tcl_AttemptAlloc, Tcl_AttemptRealloc, ckalloc, ckfree, ckrealloc, attemptckalloc, attemptckrealloc \- allocate or free heap memory .SH SYNOPSIS .nf \fB#include \fR .sp char * @@ -17,18 +17,33 @@ \fBTcl_Alloc\fR(\fIsize\fR) .sp void \fBTcl_Free\fR(\fIptr\fR) .sp -void * +char * \fBTcl_Realloc\fR(\fIptr, size\fR) .sp -void * +char * \fBTcl_AttemptAlloc\fR(\fIsize\fR) .sp -void * +char * \fBTcl_AttemptRealloc\fR(\fIptr, size\fR) +.sp +char * +\fBckalloc\fR(\fIsize\fR) +.sp +void +\fBckfree\fR(\fIptr\fR) +.sp +char * +\fBckrealloc\fR(\fIptr, size\fR) +.sp +char * +\fBattemptckalloc\fR(\fIsize\fR) +.sp +char * +\fBattemptckrealloc\fR(\fIptr, size\fR) .SH ARGUMENTS .AS char *size .AP "unsigned int" size in Size in bytes of the memory block to allocate. .AP char *ptr in @@ -62,12 +77,16 @@ interpreter to \fBpanic\fR if the memory allocation fails. If the allocation fails, these functions will return NULL. Note that on some platforms, but not all, attempting to allocate a zero-sized block of memory will also cause these functions to return NULL. .PP -When a module or Tcl itself is compiled with \fBTCL_MEM_DEBUG\fR defined, -the procedures \fBTcl_Alloc\fR, \fBTcl_Free\fR, \fBTcl_Realloc\fR, -\fBTcl_AttemptAlloc\fR, and \fBTcl_AttempRealloc\fR are implemented -as macros, redefined to be special debugging versions of these procedures. +The procedures \fBckalloc\fR, \fBckfree\fR, \fBckrealloc\fR, +\fBattemptckalloc\fR, and \fBattemptckrealloc\fR are implemented +as macros. Normally, they are synonyms for the corresponding +procedures documented on this page. When Tcl and all modules +calling Tcl are compiled with \fBTCL_MEM_DEBUG\fR defined, however, +these macros are redefined to be special debugging versions +of these procedures. To support Tcl's memory debugging within a +module, use the macros rather than direct calls to \fBTcl_Alloc\fR, etc. .SH KEYWORDS alloc, allocation, free, malloc, memory, realloc, TCL_MEM_DEBUG Index: doc/AllowExc.3 ================================================================== --- doc/AllowExc.3 +++ doc/AllowExc.3 @@ -28,11 +28,12 @@ terminates with a completion code other than \fBTCL_OK\fR, \fBTCL_ERROR\fR or \fBTCL_RETURN\fR, then Tcl normally converts this into a \fBTCL_ERROR\fR return with an appropriate message. The particular script evaluation procedures of Tcl that act in the manner are \fBTcl_EvalObjEx\fR, \fBTcl_EvalObjv\fR, \fBTcl_Eval\fR, \fBTcl_EvalEx\fR, -\fBTcl_GlobalEval\fR, \fBTcl_GlobalEvalObj\fR and \fBTcl_VarEval\fR. +\fBTcl_GlobalEval\fR, \fBTcl_GlobalEvalObj\fR, \fBTcl_VarEval\fR and +\fBTcl_VarEvalVA\fR. .PP However, if \fBTcl_AllowExceptions\fR is invoked immediately before calling one of those a procedures, then arbitrary completion codes are permitted from the script, and they are returned without modification. Index: doc/AssocData.3 ================================================================== --- doc/AssocData.3 +++ doc/AssocData.3 @@ -11,11 +11,11 @@ Tcl_GetAssocData, Tcl_SetAssocData, Tcl_DeleteAssocData \- manage associations of string keys and user specified data with Tcl interpreters .SH SYNOPSIS .nf \fB#include \fR .sp -void * +ClientData \fBTcl_GetAssocData\fR(\fIinterp, key, delProcPtr\fR) .sp \fBTcl_SetAssocData\fR(\fIinterp, key, delProc, clientData\fR) .sp \fBTcl_DeleteAssocData\fR(\fIinterp, key\fR) @@ -29,11 +29,11 @@ .AP Tcl_InterpDeleteProc *delProc in Procedure to call when \fIinterp\fR is deleted. .AP Tcl_InterpDeleteProc **delProcPtr in Pointer to location in which to store address of current deletion procedure for association. Ignored if NULL. -.AP void *clientData in +.AP ClientData clientData in Arbitrary one-word value associated with the given key in this interpreter. This data is owned by the caller. .BE .SH DESCRIPTION @@ -62,11 +62,11 @@ is deleted. \fIDeleteProc\fR should have arguments and result that match the type \fBTcl_InterpDeleteProc\fR: .PP .CS typedef void \fBTcl_InterpDeleteProc\fR( - void *\fIclientData\fR, + ClientData \fIclientData\fR, Tcl_Interp *\fIinterp\fR); .CE .PP When \fIdeleteProc\fR is invoked the \fIclientData\fR and \fIinterp\fR arguments will be the same as the corresponding arguments passed to Index: doc/Async.3 ================================================================== --- doc/Async.3 +++ doc/Async.3 @@ -28,11 +28,11 @@ \fBTcl_AsyncReady\fR() .SH ARGUMENTS .AS Tcl_AsyncHandler clientData .AP Tcl_AsyncProc *proc in Procedure to invoke to handle an asynchronous event. -.AP void *clientData in +.AP ClientData clientData in One-word value to pass to \fIproc\fR. .AP Tcl_AsyncHandler async in Token for asynchronous event handler. .AP Tcl_Interp *interp in Tcl interpreter in which command was being evaluated when handler was @@ -82,11 +82,11 @@ \fIProc\fR should have arguments and result that match the type \fBTcl_AsyncProc\fR: .PP .CS typedef int \fBTcl_AsyncProc\fR( - void *\fIclientData\fR, + ClientData \fIclientData\fR, Tcl_Interp *\fIinterp\fR, int \fIcode\fR); .CE .PP The \fIclientData\fR will be the same as the \fIclientData\fR ADDED doc/Backslash.3 Index: doc/Backslash.3 ================================================================== --- /dev/null +++ doc/Backslash.3 @@ -0,0 +1,47 @@ +'\" +'\" Copyright (c) 1989-1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +.TH Tcl_Backslash 3 "8.1" Tcl "Tcl Library Procedures" +.so man.macros +.BS +.SH NAME +Tcl_Backslash \- parse a backslash sequence +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +char +\fBTcl_Backslash\fR(\fIsrc, countPtr\fR) +.SH ARGUMENTS +.AS char *countPtr out +.AP char *src in +Pointer to a string starting with a backslash. +.AP int *countPtr out +If \fIcountPtr\fR is not NULL, \fI*countPtr\fR gets filled +in with number of characters in the backslash sequence, including +the backslash character. +.BE + +.SH DESCRIPTION +.PP +The use of \fBTcl_Backslash\fR is deprecated in favor of +\fBTcl_UtfBackslash\fR. +.PP +This is a utility procedure provided for backwards compatibility with +non-internationalized Tcl extensions. It parses a backslash sequence and +returns the low byte of the Unicode character corresponding to the sequence. +\fBTcl_Backslash\fR modifies \fI*countPtr\fR to contain the number of +characters in the backslash sequence. +.PP +See the Tcl manual entry for information on the valid backslash sequences. +All of the sequences described in the Tcl manual entry are supported by +\fBTcl_Backslash\fR. +.SH "SEE ALSO" +Tcl(n), Tcl_UtfBackslash(3) + +.SH KEYWORDS +backslash, parse Index: doc/ByteArrObj.3 ================================================================== --- doc/ByteArrObj.3 +++ doc/ByteArrObj.3 @@ -27,12 +27,12 @@ .SH ARGUMENTS .AS "const unsigned char" *lengthPtr in/out .AP "const unsigned char" *bytes in The array of bytes used to initialize or set a byte-array value. May be NULL even if \fIlength\fR is non-zero. -.AP size_t length in -The length of the array of bytes. +.AP int length in +The length of the array of bytes. It must be >= 0. .AP Tcl_Obj *objPtr in/out For \fBTcl_SetByteArrayObj\fR, this points to the value to be converted to byte-array type. For \fBTcl_GetByteArrayFromObj\fR and \fBTcl_SetByteArrayLength\fR, this points to the value from which to get the byte-array value; if \fIobjPtr\fR does not already point to a byte-array Index: doc/CallDel.3 ================================================================== --- doc/CallDel.3 +++ doc/CallDel.3 @@ -21,11 +21,11 @@ .AS Tcl_InterpDeleteProc clientData .AP Tcl_Interp *interp in Interpreter with which to associated callback. .AP Tcl_InterpDeleteProc *proc in Procedure to call when \fIinterp\fR is deleted. -.AP void *clientData in +.AP ClientData clientData in Arbitrary one-word value to pass to \fIproc\fR. .BE .SH DESCRIPTION .PP \fBTcl_CallWhenDeleted\fR arranges for \fIproc\fR to be called by @@ -36,11 +36,11 @@ \fIProc\fR should have arguments and result that match the type \fBTcl_InterpDeleteProc\fR: .PP .CS typedef void \fBTcl_InterpDeleteProc\fR( - void *\fIclientData\fR, + ClientData \fIclientData\fR, Tcl_Interp *\fIinterp\fR); .CE .PP The \fIclientData\fR and \fIinterp\fR parameters are copies of the \fIclientData\fR and \fIinterp\fR arguments given Index: doc/Cancel.3 ================================================================== --- doc/Cancel.3 +++ doc/Cancel.3 @@ -28,11 +28,11 @@ .AP int flags in ORed combination of flag bits that specify additional options. For \fBTcl_CancelEval\fR, only \fBTCL_CANCEL_UNWIND\fR is currently supported. For \fBTcl_Canceled\fR, only \fBTCL_LEAVE_ERR_MSG\fR and \fBTCL_CANCEL_UNWIND\fR are currently supported. -.AP void *clientData in +.AP ClientData clientData in Currently reserved for future use. It should be set to NULL. .BE .SH DESCRIPTION .PP Index: doc/ChnlStack.3 ================================================================== --- doc/ChnlStack.3 +++ doc/ChnlStack.3 @@ -30,11 +30,11 @@ .AS Tcl_ChannelType clientData .AP Tcl_Interp *interp in Interpreter for error reporting. .AP "const Tcl_ChannelType" *typePtr in The new channel I/O procedures to use for \fIchannel\fR. -.AP void *clientData in +.AP ClientData clientData in Arbitrary one-word value to pass to channel I/O procedures. .AP int mask in Conditions under which \fIchannel\fR will be used: OR-ed combination of \fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR and \fBTCL_EXCEPTION\fR. This can be a subset of the operations currently allowed on \fIchannel\fR. Index: doc/Class.3 ================================================================== --- doc/Class.3 +++ doc/Class.3 @@ -39,26 +39,26 @@ \fBTcl_CopyObjectInstance\fR(\fIinterp, object, name, nsName\fR) .sp int \fBTcl_ObjectDeleted\fR(\fIobject\fR) .sp -void * +ClientData \fBTcl_ObjectGetMetadata\fR(\fIobject, metaTypePtr\fR) .sp \fBTcl_ObjectSetMetadata\fR(\fIobject, metaTypePtr, metadata\fR) .sp -void * +ClientData \fBTcl_ClassGetMetadata\fR(\fIclass, metaTypePtr\fR) .sp \fBTcl_ClassSetMetadata\fR(\fIclass, metaTypePtr, metadata\fR) .sp Tcl_ObjectMapMethodNameProc \fBTcl_ObjectGetMethodNameMapper\fR(\fIobject\fR) .sp \fBTcl_ObjectSetMethodNameMapper\fR(\fIobject\fR, \fImethodNameMapper\fR) .SH ARGUMENTS -.AS void *metadata in/out +.AS ClientData metadata in/out .AP Tcl_Interp *interp in/out Interpreter providing the context for looking up or creating an object, and into whose result error messages will be written on failure. .AP Tcl_Obj *objPtr in The name of the object to look up. @@ -77,15 +77,17 @@ The number of elements in the \fIobjv\fR array. .AP "Tcl_Obj *const" *objv in The arguments to the command to create the instance of the class. .AP int skip in The number of arguments at the start of the argument array, \fIobjv\fR, that -are not arguments to any constructors. +are not arguments to any constructors. This allows the generation of correct +error messages even when complicated calling patterns are used (e.g., via the +\fBnext\fR command). .AP Tcl_ObjectMetadataType *metaTypePtr in The type of \fImetadata\fR being set with \fBTcl_ClassSetMetadata\fR or retrieved with \fBTcl_ClassGetMetadata\fR. -.AP void *metadata in +.AP ClientData metadata in An item of metadata to attach to the class, or NULL to remove the metadata associated with a particular \fImetaTypePtr\fR. .AP "Tcl_ObjectMapMethodNameProc" "methodNameMapper" in A pointer to a function to call to adjust the mapping of objects and method names to implementations, or NULL when no such mapping is required. @@ -107,11 +109,13 @@ Every object has its own command and namespace associated with it. The command may be retrieved using the \fBTcl_GetObjectCommand\fR function, the name of the object (and hence the name of the command) with \fBTcl_GetObjectName\fR, and the namespace may be retrieved using the \fBTcl_GetObjectNamespace\fR function. Note that the Tcl_Obj reference returned by \fBTcl_GetObjectName\fR -is a shared reference. +is a shared reference. You can also get whether the object has been marked for +deletion with \fBTcl_ObjectDeleted\fR (it returns true if deletion of the +object has begun); this can be useful during the processing of methods. .PP Instances of classes are created using \fBTcl_NewObjectInstance\fR, which creates an object from any class (and which is internally called by both the \fBcreate\fR and \fBnew\fR methods of the \fBoo::class\fR class). It takes parameters that optionally give the name of the object and namespace to @@ -119,10 +123,20 @@ (if any). The result of the function will be either a reference to the newly created object, or NULL if the creation failed (when an error message will be left in the interpreter result). In addition, objects may be copied by using \fBTcl_CopyObjectInstance\fR which creates a copy of an object without running any constructors. +.PP +Note that the lifetime management of objects is handled internally within +TclOO, and does not use \fBTcl_Preserve\fR. \fIIt is not safe to put a +Tcl_Object handle in a C structure with a lifespan different to the object;\fR +you should use the object's command name (as retrieved with +\fBTcl_GetObjectName\fR) instead. It is safe to use a Tcl_Object handle for +the lifespan of a call of a method on that object; handles do not become +invalid while there is an outstanding call on their object (even if the only +operation guaranteed to be safe on them is \fBTcl_ObjectDeleted\fR; the other +operations are only guaranteed to work on non-deleted objects). .SH "OBJECT AND CLASS METADATA" .PP Every object and every class may have arbitrary amounts of metadata attached to it, which the object or class attaches no meaning to beyond what is described in a Tcl_ObjectMetadataType structure instance. Metadata to be @@ -169,11 +183,11 @@ Functions matching this signature are used to delete metadata associated with a class or object. .PP .CS typedef void \fBTcl_ObjectMetadataDeleteProc\fR( - void *\fImetadata\fR); + ClientData \fImetadata\fR); .CE .PP The \fImetadata\fR argument gives the address of the metadata to be deleted. .SS "TCL_CLONEPROC FUNCTION SIGNATURE" @@ -182,12 +196,12 @@ associated with a class or object. .PP .CS typedef int \fBTcl_CloneProc\fR( Tcl_Interp *\fIinterp\fR, - void *\fIsrcMetadata\fR, - void **\fIdstMetadataPtr\fR); + ClientData \fIsrcMetadata\fR, + ClientData *\fIdstMetadataPtr\fR); .CE .PP The \fIinterp\fR argument gives a place to write an error message when the attempt to clone the object is to fail, in which case the clone procedure must also return TCL_ERROR; it should return TCL_OK otherwise. ADDED doc/CrtAlias.3 Index: doc/CrtAlias.3 ================================================================== --- /dev/null +++ doc/CrtAlias.3 @@ -0,0 +1,263 @@ +'\" +'\" Copyright (c) 1995-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +.TH Tcl_CreateAlias 3 7.6 Tcl "Tcl Library Procedures" +.so man.macros +.BS +.SH NAME +Tcl_IsSafe, Tcl_MakeSafe, Tcl_CreateChild, Tcl_CreateSlave, Tcl_GetChild, Tcl_GetSlave, Tcl_GetParent, Tcl_GetMaster, Tcl_GetInterpPath, Tcl_CreateAlias, Tcl_CreateAliasObj, Tcl_GetAlias, Tcl_GetAliasObj, Tcl_ExposeCommand, Tcl_HideCommand \- manage multiple Tcl interpreters, aliases and hidden commands +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +int +\fBTcl_IsSafe\fR(\fIinterp\fR) +.sp +int +\fBTcl_MakeSafe\fR(\fIinterp\fR) +.sp +.VS "TIP 581" +Tcl_Interp * +\fBTcl_CreateChild\fR(\fIinterp, name, isSafe\fR) +.VE "TIP 581" +.sp +Tcl_Interp * +\fBTcl_CreateSlave\fR(\fIinterp, name, isSafe\fR) +.sp +.VS "TIP 581" +Tcl_Interp * +\fBTcl_GetChild\fR(\fIinterp, name\fR) +.VE "TIP 581" +.sp +Tcl_Interp * +\fBTcl_GetSlave\fR(\fIinterp, name\fR) +.sp +.VS "TIP 581" +Tcl_Interp * +\fBTcl_GetParent\fR(\fIinterp\fR) +.VE "TIP 581" +.sp +Tcl_Interp * +\fBTcl_GetMaster\fR(\fIinterp\fR) +.sp +int +\fBTcl_GetInterpPath\fR(\fIinterp, childInterp\fR) +.sp +int +\fBTcl_CreateAlias\fR(\fIchildInterp, childCmd, targetInterp, targetCmd, + argc, argv\fR) +.sp +int +\fBTcl_CreateAliasObj\fR(\fIchildInterp, childCmd, targetInterp, targetCmd, + objc, objv\fR) +.sp +int +\fBTcl_GetAlias\fR(\fIinterp, childCmd, targetInterpPtr, targetCmdPtr, + argcPtr, argvPtr\fR) +.sp +int +\fBTcl_GetAliasObj\fR(\fIinterp, childCmd, targetInterpPtr, targetCmdPtr, + objcPtr, objvPtr\fR) +.sp +int +\fBTcl_ExposeCommand\fR(\fIinterp, hiddenCmdName, cmdName\fR) +.sp +int +\fBTcl_HideCommand\fR(\fIinterp, cmdName, hiddenCmdName\fR) +.SH ARGUMENTS +.AS "const char *const" **targetInterpPtr out +.AP Tcl_Interp *interp in +Interpreter in which to execute the specified command. +.AP "const char" *name in +Name of child interpreter to create or manipulate. +.AP int isSafe in +If non-zero, a +.QW safe +child that is suitable for running untrusted code +is created, otherwise a trusted child is created. +.AP Tcl_Interp *childInterp in +Interpreter to use for creating the source command for an alias (see +below). +.AP "const char" *childCmd in +Name of source command for alias. +.AP Tcl_Interp *targetInterp in +Interpreter that contains the target command for an alias. +.AP "const char" *targetCmd in +Name of target command for alias in \fItargetInterp\fR. +.AP int argc in +Count of additional arguments to pass to the alias command. +.AP "const char *const" *argv in +Vector of strings, the additional arguments to pass to the alias command. +This storage is owned by the caller. +.AP int objc in +Count of additional value arguments to pass to the aliased command. +.AP Tcl_Obj **objv in +Vector of Tcl_Obj structures, the additional value arguments to pass to +the aliased command. +This storage is owned by the caller. +.AP Tcl_Interp **targetInterpPtr in +Pointer to location to store the address of the interpreter where a target +command is defined for an alias. +.AP "const char" **targetCmdPtr out +Pointer to location to store the address of the name of the target command +for an alias. +.AP int *argcPtr out +Pointer to location to store count of additional arguments to be passed to +the alias. The location is in storage owned by the caller. +.AP "const char" ***argvPtr out +Pointer to location to store a vector of strings, the additional arguments +to pass to an alias. The location is in storage owned by the caller, the +vector of strings is owned by the called function. +.AP int *objcPtr out +Pointer to location to store count of additional value arguments to be +passed to the alias. The location is in storage owned by the caller. +.AP Tcl_Obj ***objvPtr out +Pointer to location to store a vector of Tcl_Obj structures, the additional +arguments to pass to an alias command. The location is in storage +owned by the caller, the vector of Tcl_Obj structures is owned by the +called function. +.AP "const char" *cmdName in +Name of an exposed command to hide or create. +.AP "const char" *hiddenCmdName in +Name under which a hidden command is stored and with which it can be +exposed or invoked. +.BE + +.SH DESCRIPTION +.PP +These procedures are intended for access to the multiple interpreter +facility from inside C programs. They enable managing multiple interpreters +in a hierarchical relationship, and the management of aliases, commands +that when invoked in one interpreter execute a command in another +interpreter. The return value for those procedures that return an \fBint\fR +is either \fBTCL_OK\fR or \fBTCL_ERROR\fR. If \fBTCL_ERROR\fR is returned +then the interpreter's result contains an error message. +.PP +\fBTcl_CreateSlave\fR creates a new interpreter as a child of \fIinterp\fR. +It also creates a child command named \fIchildName\fR in \fIinterp\fR which +allows \fIinterp\fR to manipulate the new child. +If \fIisSafe\fR is zero, the command creates a trusted child in which Tcl +code has access to all the Tcl commands. +If it is \fB1\fR, the command creates a +.QW safe +child in which Tcl code has access only to set of Tcl commands defined as +.QW "Safe Tcl" ; +see the manual entry for the Tcl \fBinterp\fR command for details. +If the creation of the new child interpreter failed, \fBNULL\fR is returned. +.PP +.VS "TIP 581" +\fBTcl_CreateChild\fR is a synonym for \fBTcl_CreateSlave\fR. +.VE "TIP 581" +.PP +\fBTcl_IsSafe\fR returns \fB1\fR if \fIinterp\fR is +.QW safe +(was created with the \fBTCL_SAFE_INTERPRETER\fR flag specified), +\fB0\fR otherwise. +.PP +\fBTcl_MakeSafe\fR marks \fIinterp\fR as +.QW safe , +so that future +calls to \fBTcl_IsSafe\fR will return 1. It also removes all known +potentially-unsafe core functionality (both commands and variables) +from \fIinterp\fR. However, it cannot know what parts of an extension +or application are safe and does not make any attempt to remove those +parts, so safety is not guaranteed after calling \fBTcl_MakeSafe\fR. +Callers will want to take care with their use of \fBTcl_MakeSafe\fR +to avoid false claims of safety. For many situations, \fBTcl_CreateSlave\fR +may be a better choice, since it creates interpreters in a known-safe state. +.PP +\fBTcl_GetSlave\fR returns a pointer to a child interpreter of +\fIinterp\fR. The child interpreter is identified by \fIchildName\fR. +If no such child interpreter exists, \fBNULL\fR is returned. +.PP +.VS "TIP 581" +\fBTcl_GetChild\fR is a synonym for \fBTcl_GetSlave\fR. +.VE "TIP 581" +.PP +\fBTcl_GetMaster\fR returns a pointer to the master interpreter of +\fIinterp\fR. If \fIinterp\fR has no master (it is a +top-level interpreter) then \fBNULL\fR is returned. +.PP +.VS "TIP 581" +\fBTcl_GetParent\fR is a synonym for \fBTcl_GetMaster\fR. +.VE "TIP 581" +.PP +\fBTcl_GetInterpPath\fR stores in the result of \fIinterp\fR +the relative path between \fIinterp\fR and \fIchildInterp\fR; +\fIchildInterp\fR must be a child of \fIinterp\fR. If the computation +of the relative path succeeds, \fBTCL_OK\fR is returned, else +\fBTCL_ERROR\fR is returned and an error message is stored as the +result of \fIinterp\fR. +.PP +\fBTcl_CreateAlias\fR creates a command named \fIchildCmd\fR in +\fIchildInterp\fR that when invoked, will cause the command \fItargetCmd\fR +to be invoked in \fItargetInterp\fR. The arguments specified by the strings +contained in \fIargv\fR are always prepended to any arguments supplied in the +invocation of \fIchildCmd\fR and passed to \fItargetCmd\fR. +This operation returns \fBTCL_OK\fR if it succeeds, or \fBTCL_ERROR\fR if +it fails; in that case, an error message is left in the value result +of \fIchildInterp\fR. +Note that there are no restrictions on the ancestry relationship (as +created by \fBTcl_CreateSlave\fR) between \fIchildInterp\fR and +\fItargetInterp\fR. Any two interpreters can be used, without any +restrictions on how they are related. +.PP +\fBTcl_CreateAliasObj\fR is similar to \fBTcl_CreateAlias\fR except +that it takes a vector of values to pass as additional arguments instead +of a vector of strings. +.PP +\fBTcl_GetAlias\fR returns information about an alias \fIaliasName\fR +in \fIinterp\fR. Any of the result fields can be \fBNULL\fR, in +which case the corresponding datum is not returned. If a result field is +non\-\fBNULL\fR, the address indicated is set to the corresponding datum. +For example, if \fItargetNamePtr\fR is non\-\fBNULL\fR it is set to a +pointer to the string containing the name of the target command. +.PP +\fBTcl_GetAliasObj\fR is similar to \fBTcl_GetAlias\fR except that it +returns a pointer to a vector of Tcl_Obj structures instead of a vector of +strings. +.PP +\fBTcl_ExposeCommand\fR moves the command named \fIhiddenCmdName\fR from +the set of hidden commands to the set of exposed commands, putting +it under the name +\fIcmdName\fR. +\fIHiddenCmdName\fR must be the name of an existing hidden +command, or the operation will return \fBTCL_ERROR\fR and +leave an error message as the result of \fIinterp\fR. +If an exposed command named \fIcmdName\fR already exists, +the operation returns \fBTCL_ERROR\fR and leaves an error message as +the result of \fIinterp\fR. +If the operation succeeds, it returns \fBTCL_OK\fR. +After executing this command, attempts to use \fIcmdName\fR in any +script evaluation mechanism will again succeed. +.PP +\fBTcl_HideCommand\fR moves the command named \fIcmdName\fR from the set of +exposed commands to the set of hidden commands, under the name +\fIhiddenCmdName\fR. +\fICmdName\fR must be the name of an existing exposed +command, or the operation will return \fBTCL_ERROR\fR and leave an error +message as the result of \fIinterp\fR. +Currently both \fIcmdName\fR and \fIhiddenCmdName\fR must not contain +namespace qualifiers, or the operation will return \fBTCL_ERROR\fR and +leave an error message as the result of \fIinterp\fR. +The \fICmdName\fR will be looked up in the global namespace, and not +relative to the current namespace, even if the current namespace is not the +global one. +If a hidden command whose name is \fIhiddenCmdName\fR already +exists, the operation also returns \fBTCL_ERROR\fR and an error +message is left as the result of \fIinterp\fR. +If the operation succeeds, it returns \fBTCL_OK\fR. +After executing this command, attempts to use \fIcmdName\fR in +any script evaluation mechanism will fail. +.PP +For a description of the Tcl interface to multiple interpreters, see +\fIinterp(n)\fR. +.SH "SEE ALSO" +interp + +.SH KEYWORDS +alias, command, exposed commands, hidden commands, interpreter, invoke, +parent, child Index: doc/CrtChannel.3 ================================================================== --- doc/CrtChannel.3 +++ doc/CrtChannel.3 @@ -15,11 +15,11 @@ \fB#include \fR .sp Tcl_Channel \fBTcl_CreateChannel\fR(\fItypePtr, channelName, instanceData, mask\fR) .sp -void * +ClientData \fBTcl_GetChannelInstanceData\fR(\fIchannel\fR) .sp const Tcl_ChannelType * \fBTcl_GetChannelType\fR(\fIchannel\fR) .sp @@ -126,11 +126,11 @@ The name of this channel, such as \fBfile3\fR; must not be in use by any other channel. Can be NULL, in which case the channel is created without a name. If the created channel is assigned to one of the standard channels (\fBstdin\fR, \fBstdout\fR or \fBstderr\fR), the assigned channel name will be the name of the standard channel. -.AP void *instanceData in +.AP ClientData instanceData in Arbitrary one-word value to be associated with this channel. This value is passed to procedures in \fItypePtr\fR when they are invoked. .AP int mask in OR-ed combination of \fBTCL_READABLE\fR and \fBTCL_WRITABLE\fR to indicate whether a channel is readable and writable. @@ -137,11 +137,11 @@ .AP Tcl_Channel channel in The channel to operate on. .AP int direction in \fBTCL_READABLE\fR means the input handle is wanted; \fBTCL_WRITABLE\fR means the output handle is wanted. -.AP void **handlePtr out +.AP ClientData *handlePtr out Points to the location where the desired OS-specific handle should be stored. .AP int size in The size, in bytes, of buffers to allocate in this channel. .AP int mask in @@ -257,11 +257,12 @@ .PP \fBTcl_NotifyChannel\fR is called by a channel driver to indicate to the generic layer that the events specified by \fImask\fR have occurred on the channel. Channel drivers are responsible for invoking this function whenever the channel handlers need to be called for the -channel. See \fBWATCHPROC\fR below for more details. +channel (or other pending tasks like a write flush should be performed). +See \fBWATCHPROC\fR below for more details. .PP \fBTcl_BadChannelOption\fR is called from driver specific \fIsetOptionProc\fR or \fIgetOptionProc\fR to generate a complete error message. .PP @@ -397,11 +398,11 @@ the generic layer to set blocking and nonblocking mode on the device. \fIBlockModeProc\fR should match the following prototype: .PP .CS typedef int \fBTcl_DriverBlockModeProc\fR( - void *\fIinstanceData\fR, + ClientData \fIinstanceData\fR, int \fImode\fR); .CE .PP The \fIinstanceData\fR is the same as the value passed to \fBTcl_CreateChannel\fR when this channel was created. The \fImode\fR @@ -432,11 +433,11 @@ generic layer to clean up driver-related information when the channel is closed. \fICloseProc\fR must match the following prototype: .PP .CS typedef int \fBTcl_DriverCloseProc\fR( - void *\fIinstanceData\fR, + ClientData \fIinstanceData\fR, Tcl_Interp *\fIinterp\fR); .CE .PP The \fIinstanceData\fR argument is the same as the value provided to \fBTcl_CreateChannel\fR when the channel was created. The function should @@ -454,11 +455,11 @@ \fIclose2Proc\fR to the address of a function that matches the following prototype: .PP .CS typedef int \fBTcl_DriverClose2Proc\fR( - void *\fIinstanceData\fR, + ClientData \fIinstanceData\fR, Tcl_Interp *\fIinterp\fR, int \fIflags\fR); .CE .PP The \fIclose2Proc\fR will be called with \fIflags\fR set to an OR'ed @@ -485,11 +486,11 @@ generic layer to read data from the file or device and store it in an internal buffer. \fIInputProc\fR must match the following prototype: .PP .CS typedef int \fBTcl_DriverInputProc\fR( - void *\fIinstanceData\fR, + ClientData \fIinstanceData\fR, char *\fIbuf\fR, int \fIbufSize\fR, int *\fIerrorCodePtr\fR); .CE .PP @@ -529,11 +530,11 @@ generic layer to transfer data from an internal buffer to the output device. \fIOutputProc\fR must match the following prototype: .PP .CS typedef int \fBTcl_DriverOutputProc\fR( - void *\fIinstanceData\fR, + ClientData \fIinstanceData\fR, const char *\fIbuf\fR, int \fItoWrite\fR, int *\fIerrorCodePtr\fR); .CE .PP @@ -568,11 +569,11 @@ operations will be applied. \fISeekProc\fR must match the following prototype: .PP .CS typedef int \fBTcl_DriverSeekProc\fR( - void *\fIinstanceData\fR, + ClientData \fIinstanceData\fR, long \fIoffset\fR, int \fIseekMode\fR, int *\fIerrorCodePtr\fR); .CE .PP @@ -598,11 +599,11 @@ \fIwideSeekProc\fR is defined. \fIWideSeekProc\fR must match the following prototype: .PP .CS typedef Tcl_WideInt \fBTcl_DriverWideSeekProc\fR( - void *\fIinstanceData\fR, + ClientData \fIinstanceData\fR, Tcl_WideInt \fIoffset\fR, int \fIseekMode\fR, int *\fIerrorCodePtr\fR); .CE .PP @@ -620,11 +621,11 @@ the generic layer to set a channel type specific option on a channel. \fIsetOptionProc\fR must match the following prototype: .PP .CS typedef int \fBTcl_DriverSetOptionProc\fR( - void *\fIinstanceData\fR, + ClientData \fIinstanceData\fR, Tcl_Interp *\fIinterp\fR, const char *\fIoptionName\fR, const char *\fInewValue\fR); .CE .PP @@ -646,12 +647,12 @@ It should call \fBTcl_BadChannelOption\fR which itself returns \fBTCL_ERROR\fR if the \fIoptionName\fR is unrecognized. If \fInewValue\fR specifies a value for the option that is not supported or if a system call error occurs, -the function should leave an error message in the -\fIresult\fR field of \fIinterp\fR if \fIinterp\fR is not NULL. The +the function should leave an error message in the result +of \fIinterp\fR if \fIinterp\fR is not NULL. The function should also call \fBTcl_SetErrno\fR to store an appropriate POSIX error code. .PP This value can be retrieved with \fBTcl_ChannelSetOptionProc\fR, which returns a pointer to the function. @@ -661,11 +662,11 @@ the generic layer to get the value of a channel type specific option on a channel. \fIgetOptionProc\fR must match the following prototype: .PP .CS typedef int \fBTcl_DriverGetOptionProc\fR( - void *\fIinstanceData\fR, + ClientData \fIinstanceData\fR, Tcl_Interp *\fIinterp\fR, const char *\fIoptionName\fR, Tcl_DString *\fIoptionValue\fR); .CE .PP @@ -699,11 +700,11 @@ notice events of interest on this channel. \fIWatchProc\fR should match the following prototype: .PP .CS typedef void \fBTcl_DriverWatchProc\fR( - void *\fIinstanceData\fR, + ClientData \fIinstanceData\fR, int \fImask\fR); .CE .PP The \fIinstanceData\fR is the same as the value passed to \fBTcl_CreateChannel\fR when this channel was created. The \fImask\fR @@ -730,13 +731,13 @@ the generic layer to retrieve a device-specific handle from the channel. \fIGetHandleProc\fR should match the following prototype: .PP .CS typedef int \fBTcl_DriverGetHandleProc\fR( - void *\fIinstanceData\fR, + ClientData \fIinstanceData\fR, int \fIdirection\fR, - void **\fIhandlePtr\fR); + ClientData *\fIhandlePtr\fR); .CE .PP \fIInstanceData\fR is the same as the value passed to \fBTcl_CreateChannel\fR when this channel was created. The \fIdirection\fR argument is either \fBTCL_READABLE\fR to retrieve the handle used @@ -759,11 +760,11 @@ It should be set to NULL. \fIFlushProc\fR should match the following prototype: .PP .CS typedef int \fBTcl_DriverFlushProc\fR( - void *\fIinstanceData\fR); + ClientData \fIinstanceData\fR); .CE .PP This value can be retrieved with \fBTcl_ChannelFlushProc\fR, which returns a pointer to the function. .SS HANDLERPROC @@ -774,11 +775,11 @@ that occur on the underlying (stacked) channel. \fIHandlerProc\fR should match the following prototype: .PP .CS typedef int \fBTcl_DriverHandlerProc\fR( - void *\fIinstanceData\fR, + ClientData \fIinstanceData\fR, int \fIinterestMask\fR); .CE .PP \fIInstanceData\fR is the same as the value passed to \fBTcl_CreateChannel\fR when this channel was created. The \fIinterestMask\fR is an OR-ed @@ -803,11 +804,11 @@ might be maintaining using the calling thread as the associate. See \fBTcl_CutChannel\fR and \fBTcl_SpliceChannel\fR for more detail. .PP .CS typedef void \fBTcl_DriverThreadActionProc\fR( - void *\fIinstanceData\fR, + ClientData \fIinstanceData\fR, int \fIaction\fR); .CE .PP \fIInstanceData\fR is the same as the value passed to \fBTcl_CreateChannel\fR when this channel was created. @@ -820,11 +821,11 @@ called by the generic layer when a channel is truncated to some length. It can be NULL. .PP .CS typedef int \fBTcl_DriverTruncateProc\fR( - void *\fIinstanceData\fR, + ClientData \fIinstanceData\fR, Tcl_WideInt \fIlength\fR); .CE .PP \fIInstanceData\fR is the same as the value passed to \fBTcl_CreateChannel\fR when this channel was created, and Index: doc/CrtChnlHdlr.3 ================================================================== --- doc/CrtChnlHdlr.3 +++ doc/CrtChnlHdlr.3 @@ -30,11 +30,11 @@ \fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR and \fBTCL_EXCEPTION\fR. Specify a zero value to temporarily disable an existing handler. .AP Tcl_FileProc *proc in Procedure to invoke whenever the channel indicated by \fIchannel\fR meets the conditions specified by \fImask\fR. -.AP void *clientData in +.AP ClientData clientData in Arbitrary one-word value to pass to \fIproc\fR. .BE .SH DESCRIPTION .PP \fBTcl_CreateChannelHandler\fR arranges for \fIproc\fR to be called in the @@ -46,11 +46,11 @@ what it means for a channel to be readable or writable. \fIProc\fR must conform to the following prototype: .PP .CS typedef void \fBTcl_ChannelProc\fR( - void *\fIclientData\fR, + ClientData \fIclientData\fR, int \fImask\fR); .CE .PP The \fIclientData\fR argument is the same as the value passed to \fBTcl_CreateChannelHandler\fR when the handler was created. Typically, Index: doc/CrtCloseHdlr.3 ================================================================== --- doc/CrtCloseHdlr.3 +++ doc/CrtCloseHdlr.3 @@ -24,11 +24,11 @@ .AS Tcl_CloseProc clientData .AP Tcl_Channel channel in The channel for which to create or delete a close callback. .AP Tcl_CloseProc *proc in The procedure to call as the callback. -.AP void *clientData in +.AP ClientData clientData in Arbitrary one-word value to pass to \fIproc\fR. .BE .SH DESCRIPTION .PP \fBTcl_CreateCloseHandler\fR arranges for \fIproc\fR to be called when @@ -36,11 +36,11 @@ \fBTcl_UnregisterChannel\fR, or using the Tcl \fBclose\fR command. \fIProc\fR should match the following prototype: .PP .CS typedef void \fBTcl_CloseProc\fR( - void *\fIclientData\fR); + ClientData \fIclientData\fR); .CE .PP The \fIclientData\fR is the same as the value provided in the call to \fBTcl_CreateCloseHandler\fR. .PP Index: doc/CrtCommand.3 ================================================================== --- doc/CrtCommand.3 +++ doc/CrtCommand.3 @@ -23,11 +23,11 @@ .AP "const char" *cmdName in Name of command. .AP Tcl_CmdProc *proc in Implementation of new command: \fIproc\fR will be called whenever \fIcmdName\fR is invoked as a command. -.AP voie *clientData in +.AP ClientData clientData in Arbitrary one-word value to pass to \fIproc\fR and \fIdeleteProc\fR. .AP Tcl_CmdDeleteProc *deleteProc in Procedure to call before \fIcmdName\fR is deleted from the interpreter; allows for command-specific cleanup. If NULL, then no procedure is called before the command is deleted. @@ -73,11 +73,11 @@ \fIProc\fR should have arguments and result that match the type \fBTcl_CmdProc\fR: .PP .CS typedef int \fBTcl_CmdProc\fR( - void *\fIclientData\fR, + ClientData \fIclientData\fR, Tcl_Interp *\fIinterp\fR, int \fIargc\fR, const char *\fIargv\fR[]); .CE .PP @@ -129,15 +129,15 @@ with the command. \fIDeleteProc\fR should have arguments and result that match the type \fBTcl_CmdDeleteProc\fR: .PP .CS typedef void \fBTcl_CmdDeleteProc\fR( - void *\fIclientData\fR); + ClientData \fIclientData\fR); .CE .PP The \fIclientData\fR argument will be the same as the \fIclientData\fR argument passed to \fBTcl_CreateCommand\fR. .SH "SEE ALSO" Tcl_CreateObjCommand, Tcl_DeleteCommand, Tcl_GetCommandInfo, Tcl_SetCommandInfo, Tcl_GetCommandName, Tcl_SetObjResult .SH KEYWORDS bind, command, create, delete, interpreter, namespace Index: doc/CrtFileHdlr.3 ================================================================== --- doc/CrtFileHdlr.3 +++ doc/CrtFileHdlr.3 @@ -27,11 +27,11 @@ and \fBTCL_EXCEPTION\fR. May be set to 0 to temporarily disable a handler. .AP Tcl_FileProc *proc in Procedure to invoke whenever the file or device indicated by \fIfile\fR meets the conditions specified by \fImask\fR. -.AP void *clientData in +.AP ClientData clientData in Arbitrary one-word value to pass to \fIproc\fR. .BE .SH DESCRIPTION .PP \fBTcl_CreateFileHandler\fR arranges for \fIproc\fR to be @@ -49,11 +49,11 @@ \fIProc\fR should have arguments and result that match the type \fBTcl_FileProc\fR: .PP .CS typedef void \fBTcl_FileProc\fR( - void *\fIclientData\fR, + ClientData \fIclientData\fR, int \fImask\fR); .CE .PP The \fIclientData\fR parameter to \fIproc\fR is a copy of the \fIclientData\fR ADDED doc/CrtMathFnc.3 Index: doc/CrtMathFnc.3 ================================================================== --- /dev/null +++ doc/CrtMathFnc.3 @@ -0,0 +1,162 @@ +'\" +'\" Copyright (c) 1989-1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +.TH Tcl_CreateMathFunc 3 8.4 Tcl "Tcl Library Procedures" +.so man.macros +.BS +.SH NAME +Tcl_CreateMathFunc, Tcl_GetMathFuncInfo, Tcl_ListMathFuncs \- Define, query and enumerate math functions for expressions +.SH "NOTICE OF EVENTUAL DEPRECATION" +.PP +The \fBTcl_CreateMathFunc\fR and \fBTcl_GetMathFuncInfo\fR functions +are rendered somewhat obsolete by the ability to create functions for +expressions by placing commands in the \fBtcl::mathfunc\fR namespace, +as described in the \fBmathfunc\fR manual page; the API described on +this page is not expected to be maintained indefinitely. +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +void +\fBTcl_CreateMathFunc\fR(\fIinterp, name, numArgs, argTypes, proc, clientData\fR) +.sp +int +\fBTcl_GetMathFuncInfo\fR(\fIinterp, name, numArgsPtr, argTypesPtr, procPtr, + clientDataPtr\fR) +.sp +Tcl_Obj * +\fBTcl_ListMathFuncs\fR(\fIinterp, pattern\fR) +.SH ARGUMENTS +.AS Tcl_ValueType *clientDataPtr out +.AP Tcl_Interp *interp in +Interpreter in which new function will be defined. +.AP "const char" *name in +Name for new function. +.AP int numArgs in +Number of arguments to new function; also gives size of \fIargTypes\fR array. +.AP Tcl_ValueType *argTypes in +Points to an array giving the permissible types for each argument to +function. +.AP Tcl_MathProc *proc in +Procedure that implements the function. +.AP ClientData clientData in +Arbitrary one-word value to pass to \fIproc\fR when it is invoked. +.AP int *numArgsPtr out +Points to a variable that will be set to contain the number of +arguments to the function. +.AP Tcl_ValueType **argTypesPtr out +Points to a variable that will be set to contain a pointer to an array +giving the permissible types for each argument to the function which +will need to be freed up using \fITcl_Free\fR. +.AP Tcl_MathProc **procPtr out +Points to a variable that will be set to contain a pointer to the +implementation code for the function (or NULL if the function is +implemented directly in bytecode). +.AP ClientData *clientDataPtr out +Points to a variable that will be set to contain the clientData +argument passed to \fITcl_CreateMathFunc\fR when the function was +created if the function is not implemented directly in bytecode. +.AP "const char" *pattern in +Pattern to match against function names so as to filter them (by +passing to \fITcl_StringMatch\fR), or NULL to not apply any filter. +.BE +.SH DESCRIPTION +.PP +Tcl allows a number of mathematical functions to be used in +expressions, such as \fBsin\fR, \fBcos\fR, and \fBhypot\fR. +These functions are represented by commands in the namespace, +\fBtcl::mathfunc\fR. The \fBTcl_CreateMathFunc\fR function is +an obsolete way for applications to add additional functions +to those already provided by Tcl or to replace existing functions. +It should not be used by new applications, which should create +math functions using \fBTcl_CreateObjCommand\fR to create a command +in the \fBtcl::mathfunc\fR namespace. +.PP +In the \fBTcl_CreateMathFunc\fR interface, +\fIName\fR is the name of the function as it will appear in expressions. +If \fIname\fR does not already exist in the \fB::tcl::mathfunc\fR +namespace, then a new command is created in that namespace. +If \fIname\fR does exist, then the existing function is replaced. +\fINumArgs\fR and \fIargTypes\fR describe the arguments to the function. +Each entry in the \fIargTypes\fR array must be +one of \fBTCL_INT\fR, \fBTCL_DOUBLE\fR, \fBTCL_WIDE_INT\fR, +or \fBTCL_EITHER\fR to indicate whether the corresponding argument must be an +integer, a double-precision floating value, a wide (64-bit) integer, +or any, respectively. +.PP +Whenever the function is invoked in an expression Tcl will invoke +\fIproc\fR. \fIProc\fR should have arguments and result that match +the type \fBTcl_MathProc\fR: +.PP +.CS +typedef int \fBTcl_MathProc\fR( + ClientData \fIclientData\fR, + Tcl_Interp *\fIinterp\fR, + Tcl_Value *\fIargs\fR, + Tcl_Value *\fIresultPtr\fR); +.CE +.PP +When \fIproc\fR is invoked the \fIclientData\fR and \fIinterp\fR +arguments will be the same as those passed to \fBTcl_CreateMathFunc\fR. +\fIArgs\fR will point to an array of \fInumArgs\fR Tcl_Value structures, +which describe the actual arguments to the function: +.PP +.CS +typedef struct Tcl_Value { + Tcl_ValueType \fItype\fR; + long \fIintValue\fR; + double \fIdoubleValue\fR; + Tcl_WideInt \fIwideValue\fR; +} \fBTcl_Value\fR; +.CE +.PP +The \fItype\fR field indicates the type of the argument and is +one of \fBTCL_INT\fR, \fBTCL_DOUBLE\fR or \fBTCL_WIDE_INT\fR. +It will match the \fIargTypes\fR value specified for the function unless +the \fIargTypes\fR value was \fBTCL_EITHER\fR. Tcl converts +the argument supplied in the expression to the type requested in +\fIargTypes\fR, if that is necessary. +Depending on the value of the \fItype\fR field, the \fIintValue\fR, +\fIdoubleValue\fR or \fIwideValue\fR +field will contain the actual value of the argument. +.PP +\fIProc\fR should compute its result and store it either as an integer +in \fIresultPtr->intValue\fR or as a floating value in +\fIresultPtr->doubleValue\fR. +It should set also \fIresultPtr->type\fR to one of +\fBTCL_INT\fR, \fBTCL_DOUBLE\fR or \fBTCL_WIDE_INT\fR +to indicate which value was set. +Under normal circumstances \fIproc\fR should return \fBTCL_OK\fR. +If an error occurs while executing the function, \fIproc\fR should +return \fBTCL_ERROR\fR and leave an error message in the interpreter's result. +.PP +\fBTcl_GetMathFuncInfo\fR retrieves the values associated with +function \fIname\fR that were passed to a preceding +\fBTcl_CreateMathFunc\fR call. Normally, the return code is +\fBTCL_OK\fR but if the named function does not exist, \fBTCL_ERROR\fR +is returned and an error message is placed in the interpreter's +result. +.PP +If an error did not occur, the array reference placed in the variable +pointed to by \fIargTypesPtr\fR is newly allocated, and should be +released by passing it to \fBTcl_Free\fR. Some functions (the +standard set implemented in the core, and those defined by placing +commands in the \fBtcl::mathfunc\fR namespace) do not have +argument type information; attempting to retrieve values for +them causes a NULL to be stored in the variable pointed to by +\fIprocPtr\fR and the variable pointed to by \fIclientDataPtr\fR +will not be modified. The variable pointed to by \fInumArgsPointer\fR +will contain -1, and no argument types will be stored in the variable +pointed to by \fIargTypesPointer\fR. +.PP +\fBTcl_ListMathFuncs\fR returns a Tcl value containing a list of all +the math functions defined in the interpreter whose name matches +\fIpattern\fR. The returned value has a reference count of zero. +.SH "SEE ALSO" +expr(n), info(n), Tcl_CreateObjCommand(3), Tcl_Free(3), Tcl_NewListObj(3) +.SH KEYWORDS +expression, mathematical function Index: doc/CrtObjCmd.3 ================================================================== --- doc/CrtObjCmd.3 +++ doc/CrtObjCmd.3 @@ -6,11 +6,11 @@ '\" .TH Tcl_CreateObjCommand 3 8.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME -Tcl_CreateObjCommand, Tcl_DeleteCommand, Tcl_DeleteCommandFromToken, Tcl_GetCommandInfo, Tcl_GetCommandInfoFromToken, Tcl_SetCommandInfo, Tcl_SetCommandInfoFromToken, Tcl_GetCommandName, Tcl_GetCommandFullName, Tcl_GetCommandFromObj, Tcl_RegisterCommandTypeName, Tcl_GetCommandTypeName \- implement new commands in C +Tcl_CreateObjCommand, Tcl_DeleteCommand, Tcl_DeleteCommandFromToken, Tcl_GetCommandInfo, Tcl_GetCommandInfoFromToken, Tcl_SetCommandInfo, Tcl_SetCommandInfoFromToken, Tcl_GetCommandName, Tcl_GetCommandFullName, Tcl_GetCommandFromObj \- implement new commands in C .SH SYNOPSIS .nf \fB#include \fR .sp Tcl_Command @@ -40,28 +40,20 @@ void \fBTcl_GetCommandFullName\fR(\fIinterp, token, objPtr\fR) .sp Tcl_Command \fBTcl_GetCommandFromObj\fR(\fIinterp, objPtr\fR) -.sp -.VS "info cmdtype feature" -void -\fBTcl_RegisterCommandTypeName\fR(\fIproc, typeName\fR) -.sp -const char * -\fBTcl_GetCommandTypeName\fR(\fItoken\fR) -.VE "info cmdtype feature" .SH ARGUMENTS .AS Tcl_CmdDeleteProc *deleteProc in/out .AP Tcl_Interp *interp in Interpreter in which to create a new command or that contains a command. .AP char *cmdName in Name of command. .AP Tcl_ObjCmdProc *proc in Implementation of the new command: \fIproc\fR will be called whenever \fIcmdName\fR is invoked as a command. -.AP void *clientData in +.AP ClientData clientData in Arbitrary one-word value to pass to \fIproc\fR and \fIdeleteProc\fR. .AP Tcl_CmdDeleteProc *deleteProc in Procedure to call before \fIcmdName\fR is deleted from the interpreter; allows for command-specific cleanup. If NULL, then no procedure is called before the command is deleted. @@ -71,13 +63,10 @@ .AP Tcl_CmdInfo *infoPtr in/out Pointer to structure containing various information about a Tcl command. .AP Tcl_Obj *objPtr in Value containing the name of a Tcl command. -.AP "const char" *typeName in -Indicates the name of the type of command implementation associated -with a particular \fIproc\fR, or NULL to break the association. .BE .SH DESCRIPTION .PP \fBTcl_CreateObjCommand\fR defines a new command in \fIinterp\fR and associates it with procedure \fIproc\fR @@ -100,11 +89,11 @@ \fIproc\fR should have arguments and result that match the type \fBTcl_ObjCmdProc\fR: .PP .CS typedef int \fBTcl_ObjCmdProc\fR( - void *\fIclientData\fR, + ClientData \fIclientData\fR, Tcl_Interp *\fIinterp\fR, int \fIobjc\fR, Tcl_Obj *const \fIobjv\fR[]); .CE .PP @@ -173,11 +162,11 @@ with the command. \fIDeleteProc\fR should have arguments and result that match the type \fBTcl_CmdDeleteProc\fR: .PP .CS typedef void \fBTcl_CmdDeleteProc\fR( - void *\fIclientData\fR); + ClientData \fIclientData\fR); .CE .PP The \fIclientData\fR argument will be the same as the \fIclientData\fR argument passed to \fBTcl_CreateObjCommand\fR. .PP @@ -215,15 +204,15 @@ .PP .CS typedef struct Tcl_CmdInfo { int \fIisNativeObjectProc\fR; Tcl_ObjCmdProc *\fIobjProc\fR; - void *\fIobjClientData\fR; + ClientData \fIobjClientData\fR; Tcl_CmdProc *\fIproc\fR; - void *\fIclientData\fR; + ClientData \fIclientData\fR; Tcl_CmdDeleteProc *\fIdeleteProc\fR; - void *\fIdeleteData\fR; + ClientData \fIdeleteData\fR; Tcl_Namespace *\fInamespacePtr\fR; } \fBTcl_CmdInfo\fR; .CE .PP The \fIisNativeObjectProc\fR field has the value 1 @@ -245,11 +234,11 @@ this is the procedure passed to it; otherwise, this is a compatibility procedure registered by \fBTcl_CreateObjCommand\fR that simply calls the command's value-based procedure after converting its string arguments to Tcl values. -The field \fIdeleteData\fR is the clientData value +The field \fIdeleteData\fR is the ClientData value to pass to \fIdeleteProc\fR; it is normally the same as \fIclientData\fR but may be set independently using the \fBTcl_SetCommandInfo\fR procedure. The field \fInamespacePtr\fR holds a pointer to the Tcl_Namespace that contains the command. @@ -259,11 +248,11 @@ from \fBTcl_CreateObjCommand\fR in place of the command name. If the \fItoken\fR parameter is NULL, it returns 0; otherwise, it returns 1 and fills in the structure designated by \fIinfoPtr\fR. .PP \fBTcl_SetCommandInfo\fR is used to modify the procedures and -clientData values associated with a command. +ClientData values associated with a command. Its \fIcmdName\fR argument is the name of a command in \fIinterp\fR. \fIcmdName\fR may include \fB::\fR namespace qualifiers to identify a command in a particular namespace. If this command does not exist then \fBTcl_SetCommandInfo\fR returns 0. Otherwise, it copies the information from \fI*infoPtr\fR to @@ -275,13 +264,13 @@ If the \fItoken\fR parameter is NULL, it returns 0. Otherwise, it copies the information from \fI*infoPtr\fR to Tcl's internal structure for the command and returns 1. .PP Note that \fBTcl_SetCommandInfo\fR and -\fBTcl_SetCommandInfoFromToken\fR both allow the clientData for a +\fBTcl_SetCommandInfoFromToken\fR both allow the ClientData for a command's deletion procedure to be given a different value than the -clientData for its command procedure. +ClientData for its command procedure. .PP Note that neither \fBTcl_SetCommandInfo\fR nor \fBTcl_SetCommandInfoFromToken\fR will change a command's namespace. Use \fBTcl_Eval\fR to call the \fBrename\fR command to do that. .PP @@ -305,25 +294,9 @@ .PP \fBTcl_GetCommandFromObj\fR returns a token for the command specified by the name in a \fBTcl_Obj\fR. The command name is resolved relative to the current namespace. Returns NULL if the command is not found. -.PP -.VS "info cmdtype feature" -\fBTcl_RegisterCommandTypeName\fR is used to associate a name (the -\fItypeName\fR argument) with a particular implementation function so that it -can then be looked up with \fBTcl_GetCommandTypeName\fR, which in turn is -called with a command token that information is wanted for and which returns -the name of the type that was registered for the implementation function used -for that command. (The lookup functionality is surfaced virtually directly in Tcl via -\fBinfo cmdtype\fR.) If there is no function registered for a particular -function, the result will be the string literal -.QW \fBnative\fR . -The registration of a name can be undone by registering a mapping to NULL -instead. The result from \fBTcl_GetCommandTypeName\fR will be exactly that -string which was registered, and not a copy; use of a compile-time constant -string is \fIstrongly recommended\fR. -.VE "info cmdtype feature" .SH "SEE ALSO" Tcl_CreateCommand(3), Tcl_ResetResult(3), Tcl_SetObjResult(3) .SH KEYWORDS bind, command, create, delete, namespace, value DELETED doc/CrtSlave.3 Index: doc/CrtSlave.3 ================================================================== --- doc/CrtSlave.3 +++ /dev/null @@ -1,236 +0,0 @@ -'\" -'\" Copyright (c) 1995-1996 Sun Microsystems, Inc. -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH Tcl_CreateSlave 3 7.6 Tcl "Tcl Library Procedures" -.so man.macros -.BS -.SH NAME -Tcl_IsSafe, Tcl_MakeSafe, Tcl_CreateSlave, Tcl_GetSlave, Tcl_GetMaster, Tcl_GetInterpPath, Tcl_CreateAlias, Tcl_CreateAliasObj, Tcl_GetAlias, Tcl_GetAliasObj, Tcl_ExposeCommand, Tcl_HideCommand \- manage multiple Tcl interpreters, aliases and hidden commands -.SH SYNOPSIS -.nf -\fB#include \fR -.sp -int -\fBTcl_IsSafe\fR(\fIinterp\fR) -.sp -int -\fBTcl_MakeSafe\fR(\fIinterp\fR) -.sp -Tcl_Interp * -\fBTcl_CreateSlave\fR(\fIinterp, slaveName, isSafe\fR) -.sp -Tcl_Interp * -\fBTcl_GetSlave\fR(\fIinterp, slaveName\fR) -.sp -Tcl_Interp * -\fBTcl_GetMaster\fR(\fIinterp\fR) -.sp -int -\fBTcl_GetInterpPath\fR(\fIaskingInterp, slaveInterp\fR) -.sp -int -\fBTcl_CreateAlias\fR(\fIslaveInterp, slaveCmd, targetInterp, targetCmd, - argc, argv\fR) -.sp -int -\fBTcl_CreateAliasObj\fR(\fIslaveInterp, slaveCmd, targetInterp, targetCmd, - objc, objv\fR) -.sp -int -\fBTcl_GetAlias\fR(\fIinterp, slaveCmd, targetInterpPtr, targetCmdPtr, - argcPtr, argvPtr\fR) -.sp -int -\fBTcl_GetAliasObj\fR(\fIinterp, slaveCmd, targetInterpPtr, targetCmdPtr, - objcPtr, objvPtr\fR) -.sp -int -\fBTcl_ExposeCommand\fR(\fIinterp, hiddenCmdName, cmdName\fR) -.sp -int -\fBTcl_HideCommand\fR(\fIinterp, cmdName, hiddenCmdName\fR) -.SH ARGUMENTS -.AS "const char *const" **targetInterpPtr out -.AP Tcl_Interp *interp in -Interpreter in which to execute the specified command. -.AP "const char" *slaveName in -Name of slave interpreter to create or manipulate. -.AP int isSafe in -If non-zero, a -.QW safe -slave that is suitable for running untrusted code -is created, otherwise a trusted slave is created. -.AP Tcl_Interp *slaveInterp in -Interpreter to use for creating the source command for an alias (see -below). -.AP "const char" *slaveCmd in -Name of source command for alias. -.AP Tcl_Interp *targetInterp in -Interpreter that contains the target command for an alias. -.AP "const char" *targetCmd in -Name of target command for alias in \fItargetInterp\fR. -.AP int argc in -Count of additional arguments to pass to the alias command. -.AP "const char *const" *argv in -Vector of strings, the additional arguments to pass to the alias command. -This storage is owned by the caller. -.AP int objc in -Count of additional value arguments to pass to the aliased command. -.AP Tcl_Obj **objv in -Vector of Tcl_Obj structures, the additional value arguments to pass to -the aliased command. -This storage is owned by the caller. -.AP Tcl_Interp **targetInterpPtr in -Pointer to location to store the address of the interpreter where a target -command is defined for an alias. -.AP "const char" **targetCmdPtr out -Pointer to location to store the address of the name of the target command -for an alias. -.AP int *argcPtr out -Pointer to location to store count of additional arguments to be passed to -the alias. The location is in storage owned by the caller. -.AP "const char" ***argvPtr out -Pointer to location to store a vector of strings, the additional arguments -to pass to an alias. The location is in storage owned by the caller, the -vector of strings is owned by the called function. -.AP int *objcPtr out -Pointer to location to store count of additional value arguments to be -passed to the alias. The location is in storage owned by the caller. -.AP Tcl_Obj ***objvPtr out -Pointer to location to store a vector of Tcl_Obj structures, the additional -arguments to pass to an alias command. The location is in storage -owned by the caller, the vector of Tcl_Obj structures is owned by the -called function. -.AP "const char" *cmdName in -Name of an exposed command to hide or create. -.AP "const char" *hiddenCmdName in -Name under which a hidden command is stored and with which it can be -exposed or invoked. -.BE - -.SH DESCRIPTION -.PP -These procedures are intended for access to the multiple interpreter -facility from inside C programs. They enable managing multiple interpreters -in a hierarchical relationship, and the management of aliases, commands -that when invoked in one interpreter execute a command in another -interpreter. The return value for those procedures that return an \fBint\fR -is either \fBTCL_OK\fR or \fBTCL_ERROR\fR. If \fBTCL_ERROR\fR is returned -then the \fBresult\fR field of the interpreter contains an error message. -.PP -\fBTcl_CreateSlave\fR creates a new interpreter as a slave of \fIinterp\fR. -It also creates a slave command named \fIslaveName\fR in \fIinterp\fR which -allows \fIinterp\fR to manipulate the new slave. -If \fIisSafe\fR is zero, the command creates a trusted slave in which Tcl -code has access to all the Tcl commands. -If it is \fB1\fR, the command creates a -.QW safe -slave in which Tcl code has access only to set of Tcl commands defined as -.QW "Safe Tcl" ; -see the manual entry for the Tcl \fBinterp\fR command for details. -If the creation of the new slave interpreter failed, \fBNULL\fR is returned. -.PP -\fBTcl_IsSafe\fR returns \fB1\fR if \fIinterp\fR is -.QW safe -(was created with the \fBTCL_SAFE_INTERPRETER\fR flag specified), -\fB0\fR otherwise. -.PP -\fBTcl_MakeSafe\fR marks \fIinterp\fR as -.QW safe , -so that future -calls to \fBTcl_IsSafe\fR will return 1. It also removes all known -potentially-unsafe core functionality (both commands and variables) -from \fIinterp\fR. However, it cannot know what parts of an extension -or application are safe and does not make any attempt to remove those -parts, so safety is not guaranteed after calling \fBTcl_MakeSafe\fR. -Callers will want to take care with their use of \fBTcl_MakeSafe\fR -to avoid false claims of safety. For many situations, \fBTcl_CreateSlave\fR -may be a better choice, since it creates interpreters in a known-safe state. -.PP -\fBTcl_GetSlave\fR returns a pointer to a slave interpreter of -\fIinterp\fR. The slave interpreter is identified by \fIslaveName\fR. -If no such slave interpreter exists, \fBNULL\fR is returned. -.PP -\fBTcl_GetMaster\fR returns a pointer to the master interpreter of -\fIinterp\fR. If \fIinterp\fR has no master (it is a -top-level interpreter) then \fBNULL\fR is returned. -.PP -\fBTcl_GetInterpPath\fR sets the \fIresult\fR field in \fIaskingInterp\fR -to the relative path between \fIaskingInterp\fR and \fIslaveInterp\fR; -\fIslaveInterp\fR must be a slave of \fIaskingInterp\fR. If the computation -of the relative path succeeds, \fBTCL_OK\fR is returned, else -\fBTCL_ERROR\fR is returned and the \fIresult\fR field in -\fIaskingInterp\fR contains the error message. -.PP -\fBTcl_CreateAlias\fR creates a command named \fIslaveCmd\fR in -\fIslaveInterp\fR that when invoked, will cause the command \fItargetCmd\fR -to be invoked in \fItargetInterp\fR. The arguments specified by the strings -contained in \fIargv\fR are always prepended to any arguments supplied in the -invocation of \fIslaveCmd\fR and passed to \fItargetCmd\fR. -This operation returns \fBTCL_OK\fR if it succeeds, or \fBTCL_ERROR\fR if -it fails; in that case, an error message is left in the value result -of \fIslaveInterp\fR. -Note that there are no restrictions on the ancestry relationship (as -created by \fBTcl_CreateSlave\fR) between \fIslaveInterp\fR and -\fItargetInterp\fR. Any two interpreters can be used, without any -restrictions on how they are related. -.PP -\fBTcl_CreateAliasObj\fR is similar to \fBTcl_CreateAlias\fR except -that it takes a vector of values to pass as additional arguments instead -of a vector of strings. -.PP -\fBTcl_GetAlias\fR returns information about an alias \fIaliasName\fR -in \fIinterp\fR. Any of the result fields can be \fBNULL\fR, in -which case the corresponding datum is not returned. If a result field is -non\-\fBNULL\fR, the address indicated is set to the corresponding datum. -For example, if \fItargetNamePtr\fR is non\-\fBNULL\fR it is set to a -pointer to the string containing the name of the target command. -.PP -\fBTcl_GetAliasObj\fR is similar to \fBTcl_GetAlias\fR except that it -returns a pointer to a vector of Tcl_Obj structures instead of a vector of -strings. -.PP -\fBTcl_ExposeCommand\fR moves the command named \fIhiddenCmdName\fR from -the set of hidden commands to the set of exposed commands, putting -it under the name -\fIcmdName\fR. -\fIHiddenCmdName\fR must be the name of an existing hidden -command, or the operation will return \fBTCL_ERROR\fR and leave an error -message in the \fIresult\fR field in \fIinterp\fR. -If an exposed command named \fIcmdName\fR already exists, -the operation returns \fBTCL_ERROR\fR and leaves an error message in the -value result of \fIinterp\fR. -If the operation succeeds, it returns \fBTCL_OK\fR. -After executing this command, attempts to use \fIcmdName\fR in a call to -\fBTcl_Eval\fR or with the Tcl \fBeval\fR command will again succeed. -.PP -\fBTcl_HideCommand\fR moves the command named \fIcmdName\fR from the set of -exposed commands to the set of hidden commands, under the name -\fIhiddenCmdName\fR. -\fICmdName\fR must be the name of an existing exposed -command, or the operation will return \fBTCL_ERROR\fR and leave an error -message in the value result of \fIinterp\fR. -Currently both \fIcmdName\fR and \fIhiddenCmdName\fR must not contain -namespace qualifiers, or the operation will return \fBTCL_ERROR\fR and -leave an error message in the value result of \fIinterp\fR. -The \fICmdName\fR will be looked up in the global namespace, and not -relative to the current namespace, even if the current namespace is not the -global one. -If a hidden command whose name is \fIhiddenCmdName\fR already -exists, the operation also returns \fBTCL_ERROR\fR and the \fIresult\fR -field in \fIinterp\fR contains an error message. -If the operation succeeds, it returns \fBTCL_OK\fR. -After executing this command, attempts to use \fIcmdName\fR in a call to -\fBTcl_Eval\fR or with the Tcl \fBeval\fR command will fail. -.PP -For a description of the Tcl interface to multiple interpreters, see -\fIinterp(n)\fR. -.SH "SEE ALSO" -interp - -.SH KEYWORDS -alias, command, exposed commands, hidden commands, interpreter, invoke, -master, slave Index: doc/CrtTimerHdlr.3 ================================================================== --- doc/CrtTimerHdlr.3 +++ doc/CrtTimerHdlr.3 @@ -22,11 +22,11 @@ .AS Tcl_TimerToken milliseconds .AP int milliseconds in How many milliseconds to wait before invoking \fIproc\fR. .AP Tcl_TimerProc *proc in Procedure to invoke after \fImilliseconds\fR have elapsed. -.AP void *clientData in +.AP ClientData clientData in Arbitrary one-word value to pass to \fIproc\fR. .AP Tcl_TimerToken token in Token for previously created timer handler (the return value from some previous call to \fBTcl_CreateTimerHandler\fR). .BE @@ -49,11 +49,11 @@ \fIProc\fR should have arguments and return value that match the type \fBTcl_TimerProc\fR: .PP .CS typedef void \fBTcl_TimerProc\fR( - void *\fIclientData\fR); + ClientData \fIclientData\fR); .CE .PP The \fIclientData\fR parameter to \fIproc\fR is a copy of the \fIclientData\fR argument given to \fBTcl_CreateTimerHandler\fR when the callback Index: doc/CrtTrace.3 ================================================================== --- doc/CrtTrace.3 +++ doc/CrtTrace.3 @@ -39,11 +39,11 @@ Procedure to call for each command that is executed. See below for details of the calling sequence. .AP Tcl_CmdTraceProc *proc in Procedure to call for each command that is executed. See below for details on the calling sequence. -.AP void *clientData in +.AP ClientData clientData in Arbitrary one-word value to pass to \fIobjProc\fR or \fIproc\fR. .AP Tcl_CmdObjTraceDeleteProc *deleteProc in Procedure to call when the trace is deleted. See below for details of the calling sequence. A NULL pointer is permissible and results in no callback when the trace is deleted. @@ -64,11 +64,11 @@ \fIobjProc\fR should have arguments and result that match the type, \fBTcl_CmdObjTraceProc\fR: .PP .CS typedef int \fBTcl_CmdObjTraceProc\fR( - \fBvoid *\fR \fIclientData\fR, + \fBClientData\fR \fIclientData\fR, \fBTcl_Interp\fR* \fIinterp\fR, int \fIlevel\fR, const char *\fIcommand\fR, \fBTcl_Command\fR \fIcommandToken\fR, int \fIobjc\fR, @@ -75,11 +75,11 @@ \fBTcl_Obj\fR *const \fIobjv\fR[]); .CE .PP The \fIclientData\fR and \fIinterp\fR parameters are copies of the corresponding arguments given to \fBTcl_CreateTrace\fR. -\fIclientData\fR typically points to an application-specific data +\fIClientData\fR typically points to an application-specific data structure that describes what to do when \fIobjProc\fR is invoked. The \fIlevel\fR parameter gives the nesting level of the command (1 for top-level commands passed to \fBTcl_Eval\fR by the application, 2 for the next-level commands passed to \fBTcl_Eval\fR as part of parsing or interpreting level-1 commands, and so on). The \fIcommand\fR parameter @@ -142,11 +142,11 @@ \fBTcl_CreateObjTrace\fR. The \fIdeleteProc\fR must match the type, \fBTcl_CmdObjTraceDeleteProc\fR: .PP .CS typedef void \fBTcl_CmdObjTraceDeleteProc\fR( - \fBvoid *\fR \fIclientData\fR); + \fBClientData\fR \fIclientData\fR); .CE .PP The \fIclientData\fR parameter will be the same as the \fIclientData\fR parameter that was originally passed to \fBTcl_CreateObjTrace\fR. @@ -158,16 +158,16 @@ that its \fIproc\fR parameter should have arguments and result that match the type \fBTcl_CmdTraceProc\fR: .PP .CS typedef void \fBTcl_CmdTraceProc\fR( - void *\fIclientData\fR, + ClientData \fIclientData\fR, Tcl_Interp *\fIinterp\fR, int \fIlevel\fR, char *\fIcommand\fR, Tcl_CmdProc *\fIcmdProc\fR, - void *\fIcmdClientData\fR, + ClientData \fIcmdClientData\fR, int \fIargc\fR, const char *\fIargv\fR[]); .CE .PP The parameters to the \fIproc\fR callback are similar to those of the Index: doc/DString.3 ================================================================== --- doc/DString.3 +++ doc/DString.3 @@ -7,11 +7,11 @@ '\" .TH Tcl_DString 3 7.4 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME -Tcl_DStringInit, Tcl_DStringAppend, Tcl_DStringAppendElement, Tcl_DStringStartSublist, Tcl_DStringEndSublist, Tcl_DStringLength, Tcl_DStringValue, Tcl_DStringSetLength, Tcl_DStringFree, Tcl_DStringResult, Tcl_DStringGetResult \- manipulate dynamic strings +Tcl_DStringInit, Tcl_DStringAppend, Tcl_DStringAppendElement, Tcl_DStringStartSublist, Tcl_DStringEndSublist, Tcl_DStringLength, Tcl_DStringValue, Tcl_DStringSetLength, Tcl_DStringTrunc, Tcl_DStringFree, Tcl_DStringResult, Tcl_DStringGetResult \- manipulate dynamic strings .SH SYNOPSIS .nf \fB#include \fR .sp \fBTcl_DStringInit\fR(\fIdsPtr\fR) @@ -24,17 +24,19 @@ .sp \fBTcl_DStringStartSublist\fR(\fIdsPtr\fR) .sp \fBTcl_DStringEndSublist\fR(\fIdsPtr\fR) .sp -size_t +int \fBTcl_DStringLength\fR(\fIdsPtr\fR) .sp char * \fBTcl_DStringValue\fR(\fIdsPtr\fR) .sp \fBTcl_DStringSetLength\fR(\fIdsPtr, newLength\fR) +.sp +\fBTcl_DStringTrunc\fR(\fIdsPtr, newLength\fR) .sp \fBTcl_DStringFree\fR(\fIdsPtr\fR) .sp \fBTcl_DStringResult\fR(\fIinterp, dsPtr\fR) .sp @@ -45,14 +47,14 @@ Pointer to structure that is used to manage a dynamic string. .AP "const char" *bytes in Pointer to characters to append to dynamic string. .AP "const char" *element in Pointer to characters to append as list element to dynamic string. -.AP size_t length in -Number of bytes from \fIbytes\fR to add to dynamic string. If TCL_AUTO_LENGTH, +.AP int length in +Number of bytes from \fIbytes\fR to add to dynamic string. If -1, add all characters up to null terminating character. -.AP size_t newLength in +.AP int newLength in New length for dynamic string, not including null terminating character. .AP Tcl_Interp *interp in/out Interpreter whose result is to be set from or moved to the dynamic string. @@ -123,10 +125,14 @@ space except to provide a terminating null character; it is up to the caller to fill in the new space. \fBTcl_DStringSetLength\fR does not free up the string's storage space even if the string is truncated to zero length, so \fBTcl_DStringFree\fR will still need to be called. +.PP +\fBTcl_DStringTrunc\fR changes the length of a dynamic string. +This procedure is now deprecated. \fBTcl_DStringSetLength\fR should +be used instead. .PP \fBTcl_DStringFree\fR should be called when you are finished using the string. It frees up any memory that was allocated for the string and reinitializes the string's value to an empty string. .PP Index: doc/DoWhenIdle.3 ================================================================== --- doc/DoWhenIdle.3 +++ doc/DoWhenIdle.3 @@ -19,11 +19,11 @@ \fBTcl_CancelIdleCall\fR(\fIproc, clientData\fR) .SH ARGUMENTS .AS Tcl_IdleProc clientData .AP Tcl_IdleProc *proc in Procedure to invoke. -.AP coid *clientData in +.AP ClientData clientData in Arbitrary one-word value to pass to \fIproc\fR. .BE .SH DESCRIPTION .PP \fBTcl_DoWhenIdle\fR arranges for \fIproc\fR to be invoked @@ -41,11 +41,11 @@ \fIProc\fR should have arguments and result that match the type \fBTcl_IdleProc\fR: .PP .CS typedef void \fBTcl_IdleProc\fR( - void *\fIclientData\fR); + ClientData \fIclientData\fR); .CE .PP The \fIclientData\fR parameter to \fIproc\fR is a copy of the \fIclientData\fR argument given to \fBTcl_DoWhenIdle\fR. Typically, \fIclientData\fR points to a data structure containing application-specific information about Index: doc/DumpActiveMemory.3 ================================================================== --- doc/DumpActiveMemory.3 +++ doc/DumpActiveMemory.3 @@ -41,11 +41,11 @@ is not defined, these functions are all no-ops. .PP \fBTcl_DumpActiveMemory\fR will output a list of all currently allocated memory to the specified file. The information output for each allocated block of memory is: starting and ending addresses -(excluding guard zone), size, source file where \fBTcl_Alloc\fR was +(excluding guard zone), size, source file where \fBckalloc\fR was called to allocate the block and line number in that file. It is especially useful to call \fBTcl_DumpActiveMemory\fR after the Tcl interpreter has been deleted. .PP \fBTcl_InitMemory\fR adds the Tcl \fBmemory\fR command to the @@ -53,16 +53,16 @@ by \fBTcl_Main\fR. .PP \fBTcl_ValidateAllMemory\fR forces a validation of the guard zones of all currently allocated blocks of memory. Normally validation of a block occurs when its freed, unless full validation is enabled, in -which case validation of all blocks occurs when \fBTcl_Alloc\fR and -\fBTcl_Free\fR are called. This function forces the validation to occur +which case validation of all blocks occurs when \fBckalloc\fR and +\fBckfree\fR are called. This function forces the validation to occur at any point. .SH "SEE ALSO" TCL_MEM_DEBUG, memory .SH KEYWORDS memory, debug Index: doc/Encoding.3 ================================================================== --- doc/Encoding.3 +++ doc/Encoding.3 @@ -6,11 +6,11 @@ '\" .TH Tcl_GetEncoding 3 "8.1" Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME -Tcl_GetEncoding, Tcl_FreeEncoding, Tcl_GetEncodingFromObj, Tcl_ExternalToUtfDString, Tcl_ExternalToUtf, Tcl_UtfToExternalDString, Tcl_UtfToExternal, Tcl_WinTCharToUtf, Tcl_WinUtfToTChar, Tcl_GetEncodingName, Tcl_SetSystemEncoding, Tcl_GetEncodingNameFromEnvironment, Tcl_GetEncodingNames, Tcl_CreateEncoding, Tcl_GetEncodingSearchPath, Tcl_SetEncodingSearchPath \- procedures for creating and using encodings +Tcl_GetEncoding, Tcl_FreeEncoding, Tcl_GetEncodingFromObj, Tcl_ExternalToUtfDString, Tcl_ExternalToUtf, Tcl_UtfToExternalDString, Tcl_UtfToExternal, Tcl_WinTCharToUtf, Tcl_WinUtfToTChar, Tcl_GetEncodingName, Tcl_SetSystemEncoding, Tcl_GetEncodingNameFromEnvironment, Tcl_GetEncodingNames, Tcl_CreateEncoding, Tcl_GetEncodingSearchPath, Tcl_SetEncodingSearchPath, Tcl_GetDefaultEncodingDir, Tcl_SetDefaultEncodingDir \- procedures for creating and using encodings .SH SYNOPSIS .nf \fB#include \fR .sp Tcl_Encoding @@ -60,10 +60,16 @@ Tcl_Obj * \fBTcl_GetEncodingSearchPath\fR() .sp int \fBTcl_SetEncodingSearchPath\fR(\fIsearchPath\fR) +.sp +const char * +\fBTcl_GetDefaultEncodingDir\fR(\fIvoid\fR) +.sp +void +\fBTcl_SetDefaultEncodingDir\fR(\fIpath\fR) .SH ARGUMENTS .AS "const Tcl_EncodingType" *dstWrotePtr in/out .AP Tcl_Interp *interp in Interpreter to use for error reporting, or NULL if no error reporting is desired. @@ -81,11 +87,11 @@ specified encoding that are to be converted to UTF-8. For the \fBTcl_UtfToExternal\fR and \fBTcl_WinUtfToTChar\fR functions, an array of UTF-8 characters to be converted to the specified encoding. .AP "const TCHAR" *tsrc in An array of Windows TCHAR characters to convert to UTF-8. -.AP size_t srcLen in +.AP int srcLen in Length of \fIsrc\fR or \fItsrc\fR in bytes. If the length is negative, the encoding-specific length of the string is used. .AP Tcl_DString *dstPtr out Pointer to an uninitialized or free \fBTcl_DString\fR in which the converted result will be stored. @@ -279,11 +285,11 @@ the encoding name to it. The \fBTcl_DStringValue\fR is returned. .PP \fBTcl_GetEncodingNames\fR sets the \fIinterp\fR result to a list consisting of the names of all the encodings that are currently defined or can be dynamically loaded, searching the encoding path specified by -\fBTcl_SetEncodingSearchPath\fR. This procedure does not ensure that the +\fBTcl_SetDefaultEncodingDir\fR. This procedure does not ensure that the dynamically-loadable encoding files contain valid data, but merely that they exist. .PP \fBTcl_CreateEncoding\fR defines a new encoding and registers the C procedures that are called back to convert between the encoding and @@ -306,11 +312,11 @@ typedef struct Tcl_EncodingType { const char *\fIencodingName\fR; Tcl_EncodingConvertProc *\fItoUtfProc\fR; Tcl_EncodingConvertProc *\fIfromUtfProc\fR; Tcl_EncodingFreeProc *\fIfreeProc\fR; - void *\fIclientData\fR; + ClientData \fIclientData\fR; int \fInullSize\fR; } \fBTcl_EncodingType\fR; .CE .PP The \fIencodingName\fR provides a string name for the encoding, by @@ -337,11 +343,11 @@ The callback procedures \fItoUtfProc\fR and \fIfromUtfProc\fR should match the type \fBTcl_EncodingConvertProc\fR: .PP .CS typedef int \fBTcl_EncodingConvertProc\fR( - void *\fIclientData\fR, + ClientData \fIclientData\fR, const char *\fIsrc\fR, int \fIsrcLen\fR, int \fIflags\fR, Tcl_EncodingState *\fIstatePtr\fR, char *\fIdst\fR, @@ -369,11 +375,11 @@ The callback procedure \fIfreeProc\fR, if non-NULL, should match the type \fBTcl_EncodingFreeProc\fR: .PP .CS typedef void \fBTcl_EncodingFreeProc\fR( - void *\fIclientData\fR); + ClientData \fIclientData\fR); .CE .PP This \fIfreeProc\fR function is called when the encoding is deleted. The \fIclientData\fR parameter is the same as the \fIclientData\fR field specified to \fBTcl_CreateEncoding\fR when the encoding was created. @@ -394,10 +400,19 @@ causes \fBTCL_ERROR\fR to be returned. The elements of \fIsearchPath\fR are not verified as existing readable filesystem directories. When searching for encoding data files takes place, and non-existent or non-readable filesystem directories on the \fIsearchPath\fR are silently ignored. +.PP +\fBTcl_GetDefaultEncodingDir\fR and \fBTcl_SetDefaultEncodingDir\fR +are obsolete interfaces best replaced with calls to +\fBTcl_GetEncodingSearchPath\fR and \fBTcl_SetEncodingSearchPath\fR. +They are called to access and set the first element of the \fIsearchPath\fR +list. Since Tcl searches \fIsearchPath\fR for encoding data files in +list order, these routines establish the +.QW default +directory in which to find encoding data files. .SH "ENCODING FILES" Space would prohibit precompiling into Tcl every possible encoding algorithm, so many encodings are stored on disk as dynamically-loadable encoding files. This behavior also allows the user to create additional encoding files that can be loaded using the same mechanism. These Index: doc/Eval.3 ================================================================== --- doc/Eval.3 +++ doc/Eval.3 @@ -8,11 +8,11 @@ '\" .TH Tcl_Eval 3 8.1 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME -Tcl_EvalObjEx, Tcl_EvalFile, Tcl_EvalObjv, Tcl_Eval, Tcl_EvalEx, Tcl_GlobalEval, Tcl_GlobalEvalObj, Tcl_VarEval \- execute Tcl scripts +Tcl_EvalObjEx, Tcl_EvalFile, Tcl_EvalObjv, Tcl_Eval, Tcl_EvalEx, Tcl_GlobalEval, Tcl_GlobalEvalObj, Tcl_VarEval, Tcl_VarEvalVA \- execute Tcl scripts .SH SYNOPSIS .nf \fB#include \fR .sp int @@ -36,10 +36,13 @@ int \fBTcl_GlobalEvalObj\fR(\fIinterp, objPtr\fR) .sp int \fBTcl_VarEval\fR(\fIinterp, part, part, ... \fB(char *) NULL\fR) +.sp +int +\fBTcl_VarEvalVA\fR(\fIinterp, argList\fR) .SH ARGUMENTS .AS Tcl_Interp **termPtr .AP Tcl_Interp *interp in Interpreter in which to execute the script. The interpreter's result is modified to hold the result or error message from the script. @@ -62,10 +65,13 @@ first null byte are used. .AP "const char" *script in Points to first byte of script to execute (null-terminated and UTF-8). .AP char *part in String forming part of a Tcl script. +.AP va_list argList in +An argument list which must have been initialized using +\fBva_start\fR, and cleared using \fBva_end\fR. .BE .SH DESCRIPTION .PP The procedures described here are invoked to execute Tcl scripts in @@ -120,14 +126,20 @@ might be a UTF-8 special code. The string is parsed and executed directly (using \fBTcl_EvalObjv\fR) instead of compiling it and executing the bytecodes. In situations where it is known that the script will never be executed again, \fBTcl_Eval\fR may be faster than \fBTcl_EvalObjEx\fR. \fBTcl_Eval\fR returns a completion code and result just like -\fBTcl_EvalObjEx\fR. +\fBTcl_EvalObjEx\fR. Note: for backward compatibility with versions before +Tcl 8.0, \fBTcl_Eval\fR copies the value result in \fIinterp\fR to +\fIinterp->result\fR (use is deprecated) where it can be accessed directly. + This makes \fBTcl_Eval\fR somewhat slower than \fBTcl_EvalEx\fR, which +does not do the copy. .PP \fBTcl_EvalEx\fR is an extended version of \fBTcl_Eval\fR that takes -additional arguments \fInumBytes\fR and \fIflags\fR. +additional arguments \fInumBytes\fR and \fIflags\fR. For the +efficiency reason given above, \fBTcl_EvalEx\fR is generally preferred +over \fBTcl_Eval\fR. .PP \fBTcl_GlobalEval\fR and \fBTcl_GlobalEvalObj\fR are older procedures that are now deprecated. They are similar to \fBTcl_EvalEx\fR and \fBTcl_EvalObjEx\fR except that the script is evaluated in the global namespace and its variable context consists of global variables only @@ -139,10 +151,14 @@ then calls \fBTcl_Eval\fR to execute that string as a Tcl command. It returns the result of the command and also modifies \fIinterp->result\fR in the same way as \fBTcl_Eval\fR. The last argument to \fBTcl_VarEval\fR must be NULL to indicate the end of arguments. \fBTcl_VarEval\fR is now deprecated. +.PP +\fBTcl_VarEvalVA\fR is the same as \fBTcl_VarEval\fR except that +instead of taking a variable number of arguments it takes an argument +list. Like \fBTcl_VarEval\fR, \fBTcl_VarEvalVA\fR is deprecated. .SH "FLAG BITS" .PP Any ORed combination of the following values may be used for the \fIflags\fR argument to procedures such as \fBTcl_EvalObjEx\fR: Index: doc/Exit.3 ================================================================== --- doc/Exit.3 +++ doc/Exit.3 @@ -40,11 +40,11 @@ usually means that an error occurred. .AP Tcl_ExitProc *proc in Procedure to invoke before exiting application, or (for \fBTcl_SetExitProc\fR) NULL to uninstall the current application exit procedure. -.AP void *clientData in +.AP ClientData clientData in Arbitrary one-word value to pass to \fIproc\fR. .BE .SH DESCRIPTION .PP @@ -62,11 +62,11 @@ \fBTcl_Exit\fR, the exit handlers will not be run. \fBTcl_Exit\fR internally invokes the \fBexit\fR system call, thus it never returns control to its caller. If an application exit handler has been installed (see \fBTcl_SetExitProc\fR), that handler is invoked with an argument -consisting of the exit status (cast to void *); the application +consisting of the exit status (cast to ClientData); the application exit handler should not return control to Tcl. .PP \fBTcl_Finalize\fR is similar to \fBTcl_Exit\fR except that it does not exit from the current process. It is useful for cleaning up when a process is finished using \fBTcl\fR but @@ -91,11 +91,11 @@ and freeing global memory. \fIProc\fR should match the type \fBTcl_ExitProc\fR: .PP .CS typedef void \fBTcl_ExitProc\fR( - void *\fIclientData\fR); + ClientData \fIclientData\fR); .CE .PP The \fIclientData\fR parameter to \fIproc\fR is a copy of the \fIclientData\fR argument given to \fBTcl_CreateExitHandler\fR or \fBTcl_CreateThreadExitHandler\fR when @@ -131,12 +131,10 @@ application handler was installed. If an application exit handler is installed, that exit handler takes over complete responsibility for finalization of Tcl's subsystems via \fBTcl_Finalize\fR at an appropriate time. The argument passed to \fIproc\fR when it is invoked will be the exit status code (as passed to \fBTcl_Exit\fR) -cast to a void *value. -.PP -\fBTcl_SetExitProc\fR can not be used in stub-enabled extensions. +cast to a ClientData value. .SH "SEE ALSO" exit(n) .SH KEYWORDS abort, callback, cleanup, dynamic loading, end application, exit, unloading, thread Index: doc/FileSystem.3 ================================================================== --- doc/FileSystem.3 +++ doc/FileSystem.3 @@ -18,11 +18,11 @@ \fBTcl_FSRegister\fR(\fIclientData, fsPtr\fR) .sp int \fBTcl_FSUnregister\fR(\fIfsPtr\fR) .sp -void * +ClientData \fBTcl_FSData\fR(\fIfsPtr\fR) .sp void \fBTcl_FSMountsChanged\fR(\fIfsPtr\fR) .sp @@ -123,11 +123,11 @@ \fBTcl_FSJoinToPath\fR(\fIbasePtr, objc, objv\fR) .sp int \fBTcl_FSConvertToPathType\fR(\fIinterp, pathPtr\fR) .sp -void * +ClientData \fBTcl_FSGetInternalRep\fR(\fIpathPtr, fsPtr\fR) .sp Tcl_Obj * \fBTcl_FSGetTranslatedPath\fR(\fIinterp, pathPtr\fR) .sp @@ -210,11 +210,11 @@ Only files or directories matching the type descriptions contained in this structure will be returned. This parameter may be NULL. .AP Tcl_Interp *interp in Interpreter to use either for results, evaluation, or reporting error messages. -.AP void *clientData in +.AP ClientData clientData in The native description of the path value to create. .AP Tcl_Obj *firstPtr in The first of two path values to compare. The value may be converted to \fBpath\fR type. .AP Tcl_Obj *secondPtr in @@ -247,11 +247,11 @@ Name of a procedure to look up in the file's symbol table .AP Tcl_PackageInitProc **proc1Ptr out Filled with the init function for this code. .AP Tcl_PackageInitProc **proc2Ptr out Filled with the safe-init function for this code. -.AP void **clientDataPtr out +.AP ClientData *clientDataPtr out Filled with the clientData value to pass to this code's unload function when it is called. .AP Tcl_LoadHandle *loadHandlePtr out Filled with an abstract token representing the loaded file. .AP Tcl_FSUnloadFileProc **unloadProcPtr out @@ -722,11 +722,11 @@ better functions to use for most purposes. .PP \fBTcl_FSGetTranslatedStringPath\fR does the same as \fBTcl_FSGetTranslatedPath\fR, but returns a character string or NULL. The string returned is dynamically allocated and owned by the caller, -which must store it or call \fBTcl_Free\fR to ensure it is freed. Again, +which must store it or call \fBckfree\fR to ensure it is freed. Again, \fBTcl_FSGetNormalizedPath\fR or \fBTcl_FSGetNativePath\fR are usually better functions to use for most purposes. .PP \fBTcl_FSNewNativePath\fR performs something like the reverse of the usual obj->path->nativerep conversions. If some code retrieves a path @@ -789,11 +789,11 @@ It returns one of \fBTCL_PATH_ABSOLUTE\fR, \fBTCL_PATH_RELATIVE\fR, or \fBTCL_PATH_VOLUME_RELATIVE\fR .SS "PORTABLE STAT RESULT API" .PP \fBTcl_AllocStatBuf\fR allocates a \fITcl_StatBuf\fR on the system heap (which -may be deallocated by being passed to \fBTcl_Free\fR). This allows extensions to +may be deallocated by being passed to \fBckfree\fR). This allows extensions to invoke \fBTcl_FSStat\fR and \fBTcl_FSLstat\fR without being dependent on the size of the buffer. That in turn depends on the flags used to build Tcl. .PP .VS 8.6 The portable fields of a \fITcl_StatBuf\fR may be read using the following @@ -839,11 +839,11 @@ .PP \fBTcl_FSUnregister\fR removes the given filesystem structure from the list of known filesystems, if it is known, and returns \fBTCL_OK\fR. If the filesystem is not currently registered, \fBTCL_ERROR\fR is returned. .PP -\fBTcl_FSData\fR will return the clientData associated with the given +\fBTcl_FSData\fR will return the ClientData associated with the given filesystem, if that filesystem is registered. Otherwise it will return NULL. .PP \fBTcl_FSMountsChanged\fR is used to inform the Tcl's core that the set of mount points for the given (already registered) filesystem @@ -1016,31 +1016,31 @@ Tcl's internal list of known filesystems. .PP .CS typedef int \fBTcl_FSPathInFilesystemProc\fR( Tcl_Obj *\fIpathPtr\fR, - void **\fIclientDataPtr\fR); + ClientData *\fIclientDataPtr\fR); .CE .SS DUPINTERNALREPPROC .PP This function makes a copy of a path's internal representation, and is called when Tcl needs to duplicate a path value. If NULL, Tcl will simply not copy the internal representation, which may then need to be regenerated later. .PP .CS -typedef void *\fBTcl_FSDupInternalRepProc\fR( - void *\fIclientData\fR); +typedef ClientData \fBTcl_FSDupInternalRepProc\fR( + ClientData \fIclientData\fR); .CE .SS FREEINTERNALREPPROC Free the internal representation. This must be implemented if internal representations need freeing (i.e.\ if some memory is allocated when an internal representation is generated), but may otherwise be NULL. .PP .CS typedef void \fBTcl_FSFreeInternalRepProc\fR( - void *\fIclientData\fR); + ClientData \fIclientData\fR); .CE .SS INTERNALTONORMALIZEDPROC .PP Function to convert internal representation to a normalized path. Only required if the filesystem creates pure path values with no string/path @@ -1047,11 +1047,11 @@ representation. The return value is a Tcl value whose string representation is the normalized path. .PP .CS typedef Tcl_Obj *\fBTcl_FSInternalToNormalizedProc\fR( - void *\fIclientData\fR); + ClientData \fIclientData\fR); .CE .SS CREATEINTERNALREPPROC .PP Function to take a path value, and calculate an internal representation for it, and store that native representation in the @@ -1058,11 +1058,11 @@ value. May be NULL if paths have no internal representation, or if the \fITcl_FSPathInFilesystemProc\fR for this filesystem always immediately creates an internal representation for paths it accepts. .PP .CS -typedef void *\fBTcl_FSCreateInternalRepProc\fR( +typedef ClientData \fBTcl_FSCreateInternalRepProc\fR( Tcl_Obj *\fIpathPtr\fR); .CE .SS NORMALIZEPATHPROC .PP Function to normalize a path. Should be implemented for all @@ -1348,15 +1348,15 @@ NULL (or an empty list) if no volumes are provided. The result value is considered to be owned by the filesystem (not by Tcl's core), but should be given a reference count for Tcl. Tcl will use the contents of the list and then decrement that reference count. This allows filesystems to choose whether they actually want to retain a -.QW "master list" +.QW "global list" of volumes or not (if not, they generate the list on the fly and pass it to Tcl with a reference count of 1 and then forget about the list, if yes, then -they simply increment the reference count of their master list and pass it +they simply increment the reference count of their global list and pass it to Tcl which will copy the contents and then decrement the count back to where it was). .PP Therefore, Tcl considers return values from this proc to be read-only. .SS FILEATTRSTRINGSPROC Index: doc/FindExec.3 ================================================================== --- doc/FindExec.3 +++ doc/FindExec.3 @@ -56,9 +56,8 @@ internal full path name of the executable file as computed by \fBTcl_FindExecutable\fR. This procedure call is the C API equivalent to the \fBinfo nameofexecutable\fR command. NULL is returned if the internal full path name has not been computed or unknown. -.PP -\fBTcl_FindExecutable\fR can not be used in stub-enabled extensions. + .SH KEYWORDS binary, executable file Index: doc/GetInt.3 ================================================================== --- doc/GetInt.3 +++ doc/GetInt.3 @@ -55,19 +55,19 @@ followed by white space. If the first two characters of \fIsrc\fR after the optional white space and sign are .QW \fB0x\fR then \fIsrc\fR is expected to be in hexadecimal form; otherwise, if the first such characters are -.QW \fB0d\fR -then \fIsrc\fR is expected to be in decimal form; otherwise, -if the first such characters are .QW \fB0o\fR then \fIsrc\fR is expected to be in octal form; otherwise, if the first such characters are .QW \fB0b\fR +then \fIsrc\fR is expected to be in binary form; otherwise, +if the first such character is +.QW \fB0\fR then \fIsrc\fR -is expected to be in binary form; otherwise, \fIsrc\fR is +is expected to be in octal form; otherwise, \fIsrc\fR is expected to be in decimal form. .PP \fBTcl_GetDouble\fR expects \fIsrc\fR to consist of a floating-point number, which is: white space; a sign; a sequence of digits; a decimal point Index: doc/GetOpnFl.3 ================================================================== --- doc/GetOpnFl.3 +++ doc/GetOpnFl.3 @@ -26,11 +26,11 @@ Non-zero means the file will be used for writing, zero means it will be used for reading. .AP int checkUsage in If non-zero, then an error will be generated if the file was not opened for the access indicated by \fIwrite\fR. -.AP void **filePtr out +.AP ClientData *filePtr out Points to word in which to store pointer to FILE structure for the file given by \fIchanID\fR. .BE .SH DESCRIPTION Index: doc/GetTime.3 ================================================================== --- doc/GetTime.3 +++ doc/GetTime.3 @@ -25,17 +25,17 @@ .AP Tcl_GetTimeProc getProc in Pointer to handler function replacing \fBTcl_GetTime\fR's access to the OS. .AP Tcl_ScaleTimeProc scaleProc in Pointer to handler function for the conversion of time delays in the virtual domain to real-time. -.AP void *clientData in +.AP ClientData clientData in Value passed through to the two handler functions. .AP Tcl_GetTimeProc *getProcPtr out Pointer to place the currently registered get handler function into. .AP Tcl_ScaleTimeProc *scaleProcPtr out Pointer to place the currently registered scale handler function into. -.AP void **clientDataPtr out +.AP ClientData *clientDataPtr out Pointer to place the currently registered pass-through value into. .BE .SH DESCRIPTION .PP The \fBTcl_GetTime\fR function retrieves the current time as a @@ -81,14 +81,14 @@ The signatures of the handler functions are as follows: .PP .CS typedef void \fBTcl_GetTimeProc\fR( Tcl_Time *\fItimebuf\fR, - void *\fIclientData\fR); + ClientData \fIclientData\fR); typedef void \fBTcl_ScaleTimeProc\fR( Tcl_Time *\fItimebuf\fR, - void *\fIclientData\fR); + ClientData \fIclientData\fR); .CE .PP The \fItimebuf\fR fields contain the time to manipulate, and the \fIclientData\fR fields contain a pointer supplied at the time the handler functions were registered. Index: doc/Hash.3 ================================================================== --- doc/Hash.3 +++ doc/Hash.3 @@ -28,11 +28,11 @@ \fBTcl_DeleteHashEntry\fR(\fIentryPtr\fR) .sp Tcl_HashEntry * \fBTcl_FindHashEntry\fR(\fItablePtr, key\fR) .sp -void * +ClientData \fBTcl_GetHashValue\fR(\fIentryPtr\fR) .sp \fBTcl_SetHashValue\fR(\fIentryPtr, value\fR) .sp void * @@ -64,12 +64,13 @@ .AP int *newPtr out The word at \fI*newPtr\fR is set to 1 if a new entry was created and 0 if there was already an entry for \fIkey\fR. .AP Tcl_HashEntry *entryPtr in Pointer to hash table entry. -.AP void *value in -New value to assign to hash table entry. +.AP ClientData value in +New value to assign to hash table entry. Need not have type +ClientData, but must fit in same space as ClientData. .AP Tcl_HashSearch *searchPtr in Pointer to record to use to keep track of progress in enumerating all the entries in a hash table. .BE .SH DESCRIPTION @@ -183,10 +184,15 @@ except that it does not create a new entry if the key doesn't exist; instead, it returns NULL as result. .PP \fBTcl_GetHashValue\fR and \fBTcl_SetHashValue\fR are used to read and write an entry's value, respectively. +Values are stored and retrieved as type +.QW ClientData , +which is +large enough to hold a pointer value. On almost all machines this is +large enough to hold an integer value too. .PP \fBTcl_GetHashKey\fR returns the key for a given hash table entry, either as a pointer to a string, a one-word .PQ "char *" key, or @@ -221,11 +227,11 @@ \fBTcl_HashStats\fR returns a dynamically-allocated string with overall information about a hash table, such as the number of entries it contains, the number of buckets in its hash array, and the utilization of the buckets. It is the caller's responsibility to free the result string -by passing it to \fBTcl_Free\fR. +by passing it to \fBckfree\fR. .PP The header file \fBtcl.h\fR defines the actual data structures used to implement hash tables. This is necessary so that clients can allocate Tcl_HashTable structures and so that macros can be used to read and write @@ -273,11 +279,11 @@ .PP The \fIhashKeyProc\fR member contains the address of a function called to calculate a hash value for the key. .PP .CS -typedef TCL_HASH_TYPE \fBTcl_HashKeyProc\fR( +typedef unsigned int \fBTcl_HashKeyProc\fR( Tcl_HashTable *\fItablePtr\fR, void *\fIkeyPtr\fR); .CE .PP If this is NULL then \fIkeyPtr\fR is used and Index: doc/InitStubs.3 ================================================================== --- doc/InitStubs.3 +++ doc/InitStubs.3 @@ -21,15 +21,15 @@ Tcl interpreter handle. .AP "const char" *version in A version string consisting of one or more decimal numbers separated by dots. .AP int exact in -1 means that only the particular version specified by +Non-zero means that only the particular version specified by \fIversion\fR is acceptable. -0 means that versions newer than \fIversion\fR are also +Zero means that versions newer than \fIversion\fR are also acceptable as long as they have the same major version number -as \fIversion\fR. Other bits have no effect. +as \fIversion\fR. .BE .SH INTRODUCTION .PP The Tcl stubs mechanism defines a way to dynamically bind extensions to a particular Tcl implementation at run time. @@ -61,13 +61,13 @@ .IP 2) 5 Define the \fBUSE_TCL_STUBS\fR symbol. Typically, you would include the \fB\-DUSE_TCL_STUBS\fR flag when compiling the extension. .IP 3) 5 Link the extension with the Tcl stubs library instead of the standard -Tcl library. For example, to use the Tcl 9.0 ABI on Unix platforms, -the library name is \fIlibtclstub9.0.a\fR; on Windows platforms, the -library name is \fItclstub90.lib\fR. +Tcl library. For example, to use the Tcl 8.6 ABI on Unix platforms, +the library name is \fIlibtclstub8.6.a\fR; on Windows platforms, the +library name is \fItclstub86.lib\fR. .PP If the extension also requires the Tk API, it must also call \fBTk_InitStubs\fR to initialize the Tk stubs interface and link with the Tk stubs libraries. See the \fBTk_InitStubs\fR page for more information. Index: doc/IntObj.3 ================================================================== --- doc/IntObj.3 +++ doc/IntObj.3 @@ -6,11 +6,11 @@ '\" .TH Tcl_IntObj 3 8.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME -Tcl_NewIntObj, Tcl_NewLongObj, Tcl_NewWideIntObj, Tcl_SetIntObj, Tcl_SetLongObj, Tcl_SetWideIntObj, Tcl_GetIntFromObj, Tcl_GetIntForIndex, Tcl_GetLongFromObj, Tcl_GetWideIntFromObj, Tcl_NewBignumObj, Tcl_SetBignumObj, Tcl_GetBignumFromObj, Tcl_TakeBignumFromObj \- manipulate Tcl values as integers +Tcl_NewIntObj, Tcl_NewLongObj, Tcl_NewWideIntObj, Tcl_SetIntObj, Tcl_SetLongObj, Tcl_SetWideIntObj, Tcl_GetIntFromObj, Tcl_GetLongFromObj, Tcl_GetWideIntFromObj, Tcl_NewBignumObj, Tcl_SetBignumObj, Tcl_GetBignumFromObj, Tcl_TakeBignumFromObj \- manipulate Tcl values as integers .SH SYNOPSIS .nf \fB#include \fR .sp Tcl_Obj * @@ -29,13 +29,10 @@ \fBTcl_SetWideIntObj\fR(\fIobjPtr, wideValue\fR) .sp int \fBTcl_GetIntFromObj\fR(\fIinterp, objPtr, intPtr\fR) .sp -int -\fBTcl_GetIntForIndex\fR(\fIinterp, objPtr, endValue, intPtr\fR) -.sp int \fBTcl_GetLongFromObj\fR(\fIinterp, objPtr, longPtr\fR) .sp int \fBTcl_GetWideIntFromObj\fR(\fIinterp, objPtr, widePtr\fR) @@ -56,12 +53,10 @@ .sp int \fBTcl_InitBignumFromDouble\fR(\fIinterp, doubleValue, bigValue\fR) .SH ARGUMENTS .AS Tcl_WideInt doubleValue in/out -.AP int endValue in -\fBTcl_GetIntForIndex\fR will return this when the input value is "end". .AP int intValue in Integer value used to initialize or set a Tcl value. .AP long longValue in Long integer value used to initialize or set a Tcl value. .AP Tcl_WideInt wideValue in @@ -100,11 +95,11 @@ \fBTcl_WideInt\fR, and \fBmp_int\fR. The \fBint\fR and \fBlong int\fR types are provided by the C language standard. The \fBTcl_WideInt\fR type is a typedef defined to be whatever signed integral type covers at least the 64-bit integer range (-9223372036854775808 to 9223372036854775807). Depending on the platform and the C compiler, the actual type might be -\fBlong long int\fR, \fB__int64\fR, or something else. +\fBlong int\fR, \fBlong long int\fR, \fB__int64\fR, or something else. The \fBmp_int\fR type is a multiple-precision integer type defined by the LibTomMath multiple-precision integer library. .PP The \fBTcl_NewIntObj\fR, \fBTcl_NewLongObj\fR, \fBTcl_NewWideIntObj\fR, and \fBTcl_NewBignumObj\fR routines each create and return a new @@ -118,20 +113,10 @@ unshared Tcl value. Any attempt to set the value of a shared Tcl value violates Tcl's copy-on-write policy. Any existing string representation or internal representation in the unshared Tcl value will be freed as a consequence of setting the new value. .PP -The \fBTcl_GetIntForIndex\fR routine attempts to retrieve an index -value from the Tcl value \fIobjPtr\fR. If the attempt succeeds, -then \fBTCL_OK\fR is returned, and the value is written to the -storage provided by the caller. The attempt might fail if -\fIobjPtr\fR does not hold an index value. If the attempt fails, -then \fBTCL_ERROR\fR is returned, and if \fIinterp\fR is non-NULL, -an error message is left in \fIinterp\fR. The \fBTcl_ObjType\fR -of \fIobjPtr\fR may be changed to make subsequent calls to the -same routine more efficient. -.PP The \fBTcl_GetIntFromObj\fR, \fBTcl_GetLongFromObj\fR, \fBTcl_GetWideIntFromObj\fR, \fBTcl_GetBignumFromObj\fR, and \fBTcl_TakeBignumFromObj\fR routines attempt to retrieve an integral value of the appropriate type from the Tcl value \fIobjPtr\fR. If the attempt succeeds, then \fBTCL_OK\fR is returned, and the value is Index: doc/Interp.3 ================================================================== --- doc/Interp.3 +++ doc/Interp.3 @@ -31,10 +31,23 @@ other routines in the Tcl interface. Accessing fields directly through the pointer as described below is no longer supported. The supported public routines \fBTcl_SetResult\fR, \fBTcl_GetResult\fR, \fBTcl_SetErrorLine\fR, \fBTcl_GetErrorLine\fR must be used instead. .PP +For legacy programs and extensions no longer being maintained, compiles +against the Tcl 8.6 header files are only possible with the compiler +directives +.CS +#define USE_INTERP_RESULT +.CE +and/or +.CS +#define USE_INTERP_ERRORLINE +.CE +depending on which fields of the \fBTcl_Interp\fR struct are accessed. +These directives may be embedded in code or supplied via compiler options. +.PP The \fIresult\fR and \fIfreeProc\fR fields are used to return results or error messages from commands. This information is returned by command procedures back to \fBTcl_Eval\fR, and by \fBTcl_Eval\fR back to its callers. The \fIresult\fR field points to the string that represents the @@ -86,11 +99,11 @@ and \fIinterp->freeProc\fR just before calling the command procedure for the command. The \fIfreeProc\fR field will be initialized to zero, and \fIinterp->result\fR will point to an empty string. Commands that do not return any value can simply leave the fields alone. Furthermore, the empty string pointed to by \fIresult\fR is actually -part of an array of approximately 200 characters. +part of an array of \fBTCL_RESULT_SIZE\fR characters (approximately 200). If a command wishes to return a short string, it can simply copy it to the area pointed to by \fIinterp->result\fR. Or, it can use the sprintf procedure to generate a short result string at the location pointed to by \fIinterp->result\fR. .PP Index: doc/Limit.3 ================================================================== --- doc/Limit.3 +++ doc/Limit.3 @@ -81,11 +81,11 @@ the limited interpreter will be permitted to continue to process after the handler returns. Many handlers may be attached to the same interpreter limit; their order of execution is not defined, and they must be identified by \fIhandlerProc\fR and \fIclientData\fR when they are deleted. -.AP void *clientData in +.AP ClientData clientData in Arbitrary pointer-sized word used to pass some context to the \fIhandlerProc\fR function. .AP Tcl_LimitHandlerDeleteProc *deleteProc in Function to call whenever a handler is deleted. May be NULL if the \fIclientData\fR requires no deletion. @@ -114,11 +114,11 @@ When a limit is exceeded (and the callbacks have run; the order of execution of the callbacks is unspecified) execution in the limited interpreter is stopped by raising an error and setting a flag that prevents the \fBcatch\fR command in that interpreter from trapping that error. It is up to the context that started execution in that -interpreter (typically a master interpreter) to handle the error. +interpreter (typically the main interpreter) to handle the error. .SH "LIMIT CHECKING API" .PP To check the resource limits for an interpreter, call \fBTcl_LimitCheck\fR, which returns \fBTCL_OK\fR if the limit was not exceeded (after processing callbacks) and \fBTCL_ERROR\fR if the limit was @@ -160,11 +160,11 @@ the function that will actually be called; it should have the following prototype: .PP .CS typedef void \fBTcl_LimitHandlerProc\fR( - void *\fIclientData\fR, + ClientData \fIclientData\fR, Tcl_Interp *\fIinterp\fR); .CE .PP The \fIclientData\fR argument to the handler will be whatever is passed to the \fIclientData\fR argument to \fBTcl_LimitAddHandler\fR, @@ -177,11 +177,11 @@ \fBTcl_Free\fR. Otherwise, it should refer to a function with the following prototype: .PP .CS typedef void \fBTcl_LimitHandlerDeleteProc\fR( - void *\fIclientData\fR); + ClientData \fIclientData\fR); .CE .PP A limit handler may be deleted using \fBTcl_LimitRemoveHandler\fR; the handler removed will be the first one found (out of the handlers added with \fBTcl_LimitAddHandler\fR) with exactly matching \fItype\fR, Index: doc/LinkVar.3 ================================================================== --- doc/LinkVar.3 +++ doc/LinkVar.3 @@ -7,64 +7,39 @@ '\" .TH Tcl_LinkVar 3 7.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME -Tcl_LinkArray, Tcl_LinkVar, Tcl_UnlinkVar, Tcl_UpdateLinkedVar \- link Tcl variable to C variable +Tcl_LinkVar, Tcl_UnlinkVar, Tcl_UpdateLinkedVar \- link Tcl variable to C variable .SH SYNOPSIS .nf \fB#include \fR .sp int \fBTcl_LinkVar\fR(\fIinterp, varName, addr, type\fR) .sp -.VS "TIP 312" -int -\fBTcl_LinkArray\fR(\fIinterp, varName, addr, type, size\fR) -.VE "TIP 312" -.sp \fBTcl_UnlinkVar\fR(\fIinterp, varName\fR) .sp \fBTcl_UpdateLinkedVar\fR(\fIinterp, varName\fR) .SH ARGUMENTS -.AS Tcl_Interp varName in +.AS Tcl_Interp writable .AP Tcl_Interp *interp in Interpreter that contains \fIvarName\fR. Also used by \fBTcl_LinkVar\fR to return error messages. .AP "const char" *varName in Name of global variable. -.AP void *addr in +.AP char *addr in Address of C variable that is to be linked to \fIvarName\fR. -.sp -.VS "TIP 312" -In \fBTcl_LinkArray\fR, may be NULL to tell Tcl to create the storage -for the array in the variable. -.VE "TIP 312" .AP int type in -Type of C variable for \fBTcl_LinkVar\fR or type of array element for -\fBTcl_LinkArray\fR. Must be one of \fBTCL_LINK_INT\fR, +Type of C variable. Must be one of \fBTCL_LINK_INT\fR, \fBTCL_LINK_UINT\fR, \fBTCL_LINK_CHAR\fR, \fBTCL_LINK_UCHAR\fR, \fBTCL_LINK_SHORT\fR, \fBTCL_LINK_USHORT\fR, \fBTCL_LINK_LONG\fR, \fBTCL_LINK_ULONG\fR, \fBTCL_LINK_WIDE_INT\fR, -\fBTCL_LINK_WIDE_UINT\fR, \fBTCL_LINK_FLOAT\fR, \fBTCL_LINK_DOUBLE\fR, -\fBTCL_LINK_BOOLEAN\fR, or one of the extra ones listed below. -.sp -In \fBTcl_LinkVar\fR, the additional linked type \fBTCL_LINK_STRING\fR may be -used. -.sp -.VS "TIP 312" -In \fBTcl_LinkArray\fR, the additional linked types \fBTCL_LINK_CHARS\fR and -\fBTCL_LINK_BYTES\fR may be used. -.VE "TIP 312" -.sp -All the above for both functions may be -optionally OR'ed with \fBTCL_LINK_READ_ONLY\fR to make the Tcl -variable read-only. -.AP size_t size in -.VS "TIP 312" -The number of elements in the C array. Must be greater than zero. -.VE "TIP 312" +\fBTCL_LINK_WIDE_UINT\fR, \fBTCL_LINK_FLOAT\fR, +\fBTCL_LINK_DOUBLE\fR, \fBTCL_LINK_BOOLEAN\fR, or +\fBTCL_LINK_STRING\fR, optionally OR'ed with \fBTCL_LINK_READ_ONLY\fR +to make Tcl variable read-only. .BE .SH DESCRIPTION .PP \fBTcl_LinkVar\fR uses variable traces to keep the Tcl variable named by \fIvarName\fR in sync with the C variable at the address @@ -75,171 +50,123 @@ \fBTcl_LinkVar\fR normally returns \fBTCL_OK\fR; if an error occurs while setting up the link (e.g. because \fIvarName\fR is the name of array) then \fBTCL_ERROR\fR is returned and the interpreter's result contains an error message. .PP -.VS "TIP 312" -\fBTcl_LinkArray\fR is similar, but for arrays of fixed size (given by -the \fIsize\fR argument). When asked to allocate the backing C array -storage (via the \fIaddr\fR argument being NULL), it writes the -address that it allocated to the Tcl interpreter result. -.VE "TIP 312" -.PP The \fItype\fR argument specifies the type of the C variable, -or the type of the elements of the C array, and must have one of the following values, optionally OR'ed with \fBTCL_LINK_READ_ONLY\fR: .TP \fBTCL_LINK_INT\fR -. -The C variable, or each element of the C array, is of type \fBint\fR. +The C variable is of type \fBint\fR. Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetIntFromObj\fR; attempts to write non-integer values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_UINT\fR -. -The C variable, or each element of the C array, is of type \fBunsigned int\fR. +The C variable is of type \fBunsigned int\fR. Any value written into the Tcl variable must have a proper unsigned integer form acceptable to \fBTcl_GetWideIntFromObj\fR and in the platform's defined range for the \fBunsigned int\fR type; attempts to write non-integer values (or values outside the range) into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_CHAR\fR -. -The C variable, or each element of the C array, is of type \fBchar\fR. +The C variable is of type \fBchar\fR. Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetIntFromObj\fR and be in the range of the \fBchar\fR datatype; attempts to write non-integer or out-of-range values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. -.RS -.PP -.VS "TIP 312" -If using an array of these, consider using \fBTCL_LINK_CHARS\fR instead. -.VE "TIP 312" -.RE -.TP -\fBTCL_LINK_CHARS\fR -.VS "TIP 312" -The C array is of type \fBchar *\fR and is mapped into Tcl as a string. -Any value written into the Tcl variable must have the same length as -the underlying storage. Only supported with \fBTcl_LinkArray\fR. -.VE "TIP 312" .TP \fBTCL_LINK_UCHAR\fR -. -The C variable, or each element of the C array, is of type \fBunsigned char\fR. +The C variable is of type \fBunsigned char\fR. Any value written into the Tcl variable must have a proper unsigned integer form acceptable to \fBTcl_GetIntFromObj\fR and in the platform's defined range for the \fBunsigned char\fR type; attempts to write non-integer values (or values outside the range) into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. -.RS -.PP -.VS "TIP 312" -If using an array of these, consider using \fBTCL_LINK_BYTES\fR instead. -.VE "TIP 312" -.RE -.TP -\fBTCL_LINK_BYTES\fR -.VS "TIP 312" -The C array is of type \fBunsigned char *\fR and is mapped into Tcl -as a bytearray. -Any value written into the Tcl variable must have the same length as -the underlying storage. Only supported with \fBTcl_LinkArray\fR. -.VE "TIP 312" .TP \fBTCL_LINK_SHORT\fR -. -The C variable, or each element of the C array, is of type \fBshort\fR. +The C variable is of type \fBshort\fR. Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetIntFromObj\fR and be in the range of the \fBshort\fR datatype; attempts to write non-integer or out-of-range values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_USHORT\fR -. -The C variable, or each element of the C array, is of type \fBunsigned short\fR. +The C variable is of type \fBunsigned short\fR. Any value written into the Tcl variable must have a proper unsigned integer form acceptable to \fBTcl_GetIntFromObj\fR and in the platform's defined range for the \fBunsigned short\fR type; attempts to write non-integer values (or values outside the range) into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_LONG\fR -. -The C variable, or each element of the C array, is of type \fBlong\fR. +The C variable is of type \fBlong\fR. Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetLongFromObj\fR; attempts to write non-integer or out-of-range values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_ULONG\fR -. -The C variable, or each element of the C array, is of type \fBunsigned long\fR. +The C variable is of type \fBunsigned long\fR. Any value written into the Tcl variable must have a proper unsigned integer form acceptable to \fBTcl_GetWideIntFromObj\fR and in the platform's defined range for the \fBunsigned long\fR type; attempts to write non-integer values (or values outside the range) into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_DOUBLE\fR -. -The C variable, or each element of the C array, is of type \fBdouble\fR. +The C variable is of type \fBdouble\fR. Any value written into the Tcl variable must have a proper real form acceptable to \fBTcl_GetDoubleFromObj\fR; attempts to write non-real values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer or real representations (like the empty string, '.', '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_FLOAT\fR -. -The C variable, or each element of the C array, is of type \fBfloat\fR. +The C variable is of type \fBfloat\fR. Any value written into the Tcl variable must have a proper real form acceptable to \fBTcl_GetDoubleFromObj\fR and must be within the range acceptable for a \fBfloat\fR; attempts to write non-real values (or values outside the range) into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer or real representations (like the empty string, '.', '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_WIDE_INT\fR -. -The C variable, or each element of the C array, is of type \fBTcl_WideInt\fR -(which is an integer type +The C variable is of type \fBTcl_WideInt\fR (which is an integer type at least 64-bits wide on all platforms that can support it.) Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetWideIntFromObj\fR; attempts to write non-integer values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_WIDE_UINT\fR -. -The C variable, or each element of the C array, is of type \fBTcl_WideUInt\fR -(which is an unsigned integer type at least 64-bits wide on all platforms that -can support it.) +The C variable is of type \fBTcl_WideUInt\fR (which is an unsigned +integer type at least 64-bits wide on all platforms that can support +it.) Any value written into the Tcl variable must have a proper unsigned integer form acceptable to \fBTcl_GetWideIntFromObj\fR (it will be cast to unsigned); .\" FIXME! Use bignums instead. attempts to write non-integer values into \fIvarName\fR will be @@ -246,12 +173,11 @@ rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_BOOLEAN\fR -. -The C variable, or each element of the C array, is of type \fBint\fR. +The C variable is of type \fBint\fR. If its value is zero then it will read from Tcl as .QW 0 ; otherwise it will read from Tcl as .QW 1 . Whenever \fIvarName\fR is @@ -260,21 +186,19 @@ form acceptable to \fBTcl_GetBooleanFromObj\fR; attempts to write non-boolean values into \fIvarName\fR will be rejected with Tcl errors. .TP \fBTCL_LINK_STRING\fR -. The C variable is of type \fBchar *\fR. If its value is not NULL then it must be a pointer to a string -allocated with \fBTcl_Alloc\fR. +allocated with \fBTcl_Alloc\fR or \fBckalloc\fR. Whenever the Tcl variable is modified the current C string will be freed and new memory will be allocated to hold a copy of the variable's new value. If the C variable contains a NULL pointer then the Tcl variable will read as .QW NULL . -This is only supported by \fBTcl_LinkVar\fR. .PP If the \fBTCL_LINK_READ_ONLY\fR flag is present in \fItype\fR then the variable will be read-only from Tcl, so that its value can only be changed by modifying the C variable. Attempts to write the variable from Tcl will be rejected with errors. Index: doc/ListObj.3 ================================================================== --- doc/ListObj.3 +++ doc/ListObj.3 @@ -136,11 +136,13 @@ \fBTcl_NewListObj\fR and \fBTcl_SetListObj\fR create a new value or modify an existing value to hold the \fIobjc\fR elements of the array referenced by \fIobjv\fR where each element is a pointer to a Tcl value. If \fIobjc\fR is less than or equal to zero, -they return an empty value. +they return an empty value. If \fIobjv\fR is NULL, the resulting list +contains 0 elements, with reserved space in an internal representation +for \fIobjc\fR more elements (to avoid its reallocation later). The new value's string representation is left invalid. The two procedures increment the reference counts of the elements in \fIobjc\fR since the list value now refers to them. The new list value returned by \fBTcl_NewListObj\fR has reference count zero. Index: doc/Method.3 ================================================================== --- doc/Method.3 +++ doc/Method.3 @@ -7,22 +7,22 @@ .TH Tcl_Method 3 0.1 TclOO "TclOO Library Functions" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -Tcl_ClassSetConstructor, Tcl_ClassSetDestructor, Tcl_MethodDeclarerClass, Tcl_MethodDeclarerObject, Tcl_MethodIsPublic, Tcl_MethodIsPrivate, Tcl_MethodIsType, Tcl_MethodName, Tcl_NewInstanceMethod, Tcl_NewMethod, Tcl_ObjectContextInvokeNext, Tcl_ObjectContextIsFiltering, Tcl_ObjectContextMethod, Tcl_ObjectContextObject, Tcl_ObjectContextSkippedArgs \- manipulate methods and method-call contexts +Tcl_ClassSetConstructor, Tcl_ClassSetDestructor, Tcl_MethodDeclarerClass, Tcl_MethodDeclarerObject, Tcl_MethodIsPublic, Tcl_MethodIsType, Tcl_MethodName, Tcl_NewInstanceMethod, Tcl_NewMethod, Tcl_ObjectContextInvokeNext, Tcl_ObjectContextIsFiltering, Tcl_ObjectContextMethod, Tcl_ObjectContextObject, Tcl_ObjectContextSkippedArgs \- manipulate methods and method-call contexts .SH SYNOPSIS .nf \fB#include \fR .sp Tcl_Method -\fBTcl_NewMethod\fR(\fIinterp, class, nameObj, flags, methodTypePtr, - clientData\fR) +\fBTcl_NewMethod\fR(\fIinterp, class, nameObj, isPublic, + methodTypePtr, clientData\fR) .sp Tcl_Method -\fBTcl_NewInstanceMethod\fR(\fIinterp, object, nameObj, flags, methodTypePtr, - clientData\fR) +\fBTcl_NewInstanceMethod\fR(\fIinterp, object, nameObj, isPublic, + methodTypePtr, clientData\fR) .sp \fBTcl_ClassSetConstructor\fR(\fIinterp, class, method\fR) .sp \fBTcl_ClassSetDestructor\fR(\fIinterp, class, method\fR) .sp @@ -33,17 +33,12 @@ \fBTcl_MethodDeclarerObject\fR(\fImethod\fR) .sp Tcl_Obj * \fBTcl_MethodName\fR(\fImethod\fR) .sp -.VS TIP500 int \fBTcl_MethodIsPublic\fR(\fImethod\fR) -.VE TIP500 -.sp -int -\fBTcl_MethodIsPrivate\fR(\fImethod\fR) .sp int \fBTcl_MethodIsType\fR(\fImethod, methodTypePtr, clientDataPtr\fR) .sp int @@ -59,36 +54,31 @@ \fBTcl_ObjectContextObject\fR(\fIcontext\fR) .sp int \fBTcl_ObjectContextSkippedArgs\fR(\fIcontext\fR) .SH ARGUMENTS -.AS void *clientData in +.AS ClientData clientData in .AP Tcl_Interp *interp in/out The interpreter holding the object or class to create or update a method in. .AP Tcl_Object object in The object to create the method in. .AP Tcl_Class class in The class to create the method in. .AP Tcl_Obj *nameObj in The name of the method to create. Should not be NULL unless creating constructors or destructors. -.AP int flags in -A flag saying (currently) what the visibility of the method is. The supported -public values of this flag are \fBTCL_OO_METHOD_PUBLIC\fR (which is fixed at 1 -for backward compatibility) for an exported method, -\fBTCL_OO_METHOD_UNEXPORTED\fR (which is fixed at 0 for backward -compatibility) for a non-exported method, -.VS TIP500 -and \fBTCL_OO_METHOD_PRIVATE\fR for a private method. -.VE TIP500 +.AP int isPublic in +A flag saying what the visibility of the method is. The only supported public +values of this flag are 0 for a non-exported method, and 1 for an exported +method. .AP Tcl_MethodType *methodTypePtr in A description of the type of the method to create, or the type of method to compare against. -.AP void *clientData in +.AP ClientData clientData in A piece of data that is passed to the implementation of the method without interpretation. -.AP void **clientDataPtr out +.AP ClientData *clientDataPtr out A pointer to a variable in which to write the \fIclientData\fR value supplied when the method was created. If NULL, the \fIclientData\fR value will not be retrieved. .AP Tcl_Method method in A reference to a method to query. @@ -113,16 +103,12 @@ Given a method, the entity that declared it can be found using \fBTcl_MethodDeclarerClass\fR which returns the class that the method is attached to (or NULL if the method is not attached to any class) and \fBTcl_MethodDeclarerObject\fR which returns the object that the method is attached to (or NULL if the method is not attached to an object). The name of -the method can be retrieved with \fBTcl_MethodName\fR, whether the method -is exported is retrieved with \fBTcl_MethodIsPublic\fR, -.VS TIP500 -and whether the method is private is retrieved with \fBTcl_MethodIsPrivate\fR. -.VE TIP500 -The type of the method +the method can be retrieved with \fBTcl_MethodName\fR and whether the method +is exported is retrieved with \fBTcl_MethodIsPublic\fR. The type of the method can also be introspected upon to a limited degree; the function \fBTcl_MethodIsType\fR returns whether a method is of a particular type, assigning the per-method \fIclientData\fR to the variable pointed to by \fIclientDataPtr\fR if (that is non-NULL) if the type is matched. .SS "METHOD CREATION" @@ -129,16 +115,12 @@ .PP Methods are created by \fBTcl_NewMethod\fR and \fBTcl_NewInstanceMethod\fR, which create a method attached to a class or an object respectively. In both cases, the \fInameObj\fR argument gives the name of the method to create, the -\fIflags\fR argument states whether the method should be exported -initially -.VS TIP500 -or be marked as a private method, -.VE TIP500 -the \fImethodTypePtr\fR argument describes the implementation of +\fIisPublic\fR argument states whether the method should be exported +initially, the \fImethodTypePtr\fR argument describes the implementation of the method (see the \fBMETHOD TYPES\fR section below) and the \fIclientData\fR argument gives some implementation-specific data that is passed on to the implementation of the method when it is called. .PP When the \fInameObj\fR argument to \fBTcl_NewMethod\fR is NULL, an @@ -211,11 +193,11 @@ .PP Functions matching this signature are called when the method is invoked. .PP .CS typedef int \fBTcl_MethodCallProc\fR( - void *\fIclientData\fR, + ClientData \fIclientData\fR, Tcl_Interp *\fIinterp\fR, Tcl_ObjectContext \fIobjectContext\fR, int \fIobjc\fR, Tcl_Obj *const *\fIobjv\fR); .CE @@ -232,11 +214,11 @@ Functions matching this signature are used when a method is deleted, whether through a new method being created or because the object or class is deleted. .PP .CS typedef void \fBTcl_MethodDeleteProc\fR( - void *\fIclientData\fR); + ClientData \fIclientData\fR); .CE .PP The \fIclientData\fR argument to a Tcl_MethodDeleteProc will be the same as the value passed to the \fIclientData\fR argument to \fBTcl_NewMethod\fR or \fBTcl_NewInstanceMethod\fR when the method was created. @@ -246,12 +228,12 @@ class is copied using \fBTcl_CopyObjectInstance\fR (or \fBoo::copy\fR). .PP .CS typedef int \fBTcl_CloneProc\fR( Tcl_Interp *\fIinterp\fR, - void *\fIoldClientData\fR, - void **\fInewClientDataPtr\fR); + ClientData \fIoldClientData\fR, + ClientData *\fInewClientDataPtr\fR); .CE .PP The \fIinterp\fR argument gives a place to write an error message when the attempt to clone the object is to fail, in which case the clone procedure must also return TCL_ERROR; it should return TCL_OK otherwise. Index: doc/NRE.3 ================================================================== --- doc/NRE.3 +++ doc/NRE.3 @@ -47,11 +47,11 @@ \fBTcl_NRCallObjProc\fR to call \fInreProc\fR using a new trampoline. Behaves in the same way as the \fIproc\fR argument to \fBTcl_CreateObjCommand\fR(3) (\fIq.v.\fR). .AP Tcl_ObjCmdProc *nreProc in Called instead of \fIproc\fR when a trampoline is already in use. -.AP void *clientData in +.AP ClientData clientData in Arbitrary one-word value passed to \fIproc\fR, \fInreProc\fR, \fIdeleteProc\fR and \fIobjProc\fR. .AP Tcl_CmdDeleteProc *deleteProc in/out Called before \fIcmdName\fR is deleted from the interpreter, allowing for command-specific cleanup. May be NULL. @@ -70,14 +70,14 @@ .AP Tcl_Obj *resultPtr out Pointer to an unshared Tcl_Obj where the result of the evaluation is stored if the return code is TCL_OK. .AP Tcl_NRPostProc *postProcPtr in A function to push. -.AP void *data0 in -.AP void *data1 in -.AP void *data2 in -.AP void *data3 in +.AP ClientData data0 in +.AP ClientData data1 in +.AP ClientData data2 in +.AP ClientData data3 in \fIdata0\fR through \fIdata3\fR are four one-word values that will be passed to the function designated by \fIpostProcPtr\fR when it is invoked. .BE .SH DESCRIPTION .PP @@ -128,11 +128,11 @@ \fBTcl_NRPostProc\fR is: .PP .CS typedef int \fBTcl_NRPostProc\fR( - \fBvoid *\fR \fIdata\fR[], + \fBClientData\fR \fIdata\fR[], \fBTcl_Interp\fR *\fIinterp\fR, int \fIresult\fR); .CE .PP \fIdata\fR is a pointer to an array containing \fIdata0\fR through \fIdata3\fR. @@ -144,11 +144,11 @@ stack, to evalute a script: .PP .CS int \fITheCmdOldObjProc\fR( - void *clientData, + ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { int result; @@ -175,11 +175,11 @@ call \fITheCmdNRObjProc\fR: .PP .CS int \fITheCmdOldObjProc\fR( - void *clientData, + ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { return \fBTcl_NRCallObjProc\fR(interp, \fITheCmdNRObjProc\fR, @@ -188,11 +188,11 @@ .CE .PP .CS int \fITheCmdNRObjProc\fR - void *clientData, + ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Tcl_Obj *objPtr; @@ -209,11 +209,11 @@ .CE .PP .CS int \fITheCmdNRPostProc\fR( - void *data[], + ClientData data[], Tcl_Interp *interp, int result) { /* \fIdata[0] .. data[3]\fR are the four words of data * passed to \fBTcl_NRAddCallback\fR */ Index: doc/Namespace.3 ================================================================== --- doc/Namespace.3 +++ doc/Namespace.3 @@ -55,11 +55,11 @@ .AP Tcl_Interp *interp in/out The interpreter in which the namespace exists and where name lookups are performed. Also where error result messages are written. .AP "const char" *name in The name of the namespace or command to be created or accessed. -.AP void *clientData in +.AP ClientData clientData in A context pointer by the creator of the namespace. Not interpreted by Tcl at all. .AP Tcl_NamespaceDeleteProc *deleteProc in A pointer to function to call when the namespace is deleted, or NULL if no such callback is to be performed. @@ -115,11 +115,11 @@ \fBTcl_CreateNamespace\fR creates a new namespace. The \fIdeleteProc\fR will have the following type signature: .PP .CS typedef void \fBTcl_NamespaceDeleteProc\fR( - void *\fIclientData\fR); + ClientData \fIclientData\fR); .CE .PP \fBTcl_DeleteNamespace\fR deletes a namespace, calling the \fIdeleteProc\fR defined for the namespace (if any). .PP Index: doc/Notifier.3 ================================================================== --- doc/Notifier.3 +++ doc/Notifier.3 @@ -36,11 +36,11 @@ \fBTcl_GetCurrentThread\fR() .sp void \fBTcl_DeleteEvents\fR(\fIdeleteProc, clientData\fR) .sp -void * +ClientData \fBTcl_InitNotifier\fR() .sp void \fBTcl_FinalizeNotifier\fR(\fIclientData\fR) .sp @@ -76,11 +76,11 @@ Procedure to invoke to prepare for event wait in \fBTcl_DoOneEvent\fR. .AP Tcl_EventCheckProc *checkProc in Procedure for \fBTcl_DoOneEvent\fR to invoke after waiting for events. Checks to see if any events have occurred and, if so, queues them. -.AP void *clientData in +.AP ClientData clientData in Arbitrary one-word value to pass to \fIsetupProc\fR, \fIcheckProc\fR, or \fIdeleteProc\fR. .AP "const Tcl_Time" *timePtr in Indicates the maximum amount of time to wait for an event. This is specified as an interval (how long to wait), not an absolute @@ -87,11 +87,11 @@ time (when to wakeup). If the pointer passed to \fBTcl_WaitForEvent\fR is NULL, it means there is no maximum wait time: wait forever if necessary. .AP Tcl_Event *evPtr in An event to add to the event queue. The storage for the event must -have been allocated by the caller using \fBTcl_Alloc\fR. +have been allocated by the caller using \fBTcl_Alloc\fR or \fBckalloc\fR. .AP Tcl_QueuePosition position in Where to add the new event in the queue: \fBTCL_QUEUE_TAIL\fR, \fBTCL_QUEUE_HEAD\fR, or \fBTCL_QUEUE_MARK\fR. .AP Tcl_ThreadId threadId in A unique identifier for a thread. @@ -228,11 +228,11 @@ the event source. \fISetupProc\fR should match the following prototype: .PP .CS typedef void \fBTcl_EventSetupProc\fR( - void *\fIclientData\fR, + ClientData \fIclientData\fR, int \fIflags\fR); .CE .PP The \fIclientData\fR argument will be the same as the \fIclientData\fR argument to \fBTcl_CreateEventSource\fR; it is typically used to @@ -306,11 +306,11 @@ \fBTcl_CreateEventSource\fR. \fICheckProc\fR must match the following prototype: .PP .CS typedef void \fBTcl_EventCheckProc\fR( - void *\fIclientData\fR, + ClientData \fIclientData\fR, int \fIflags\fR); .CE .PP The arguments to this procedure are the same as those for \fIsetupProc\fR. \fBCheckProc\fR is invoked by \fBTcl_DoOneEvent\fR after it has waited @@ -397,11 +397,11 @@ of window events. .PP When \fIproc\fR returns 1, \fBTcl_ServiceEvent\fR will remove the event from the event queue and free its storage. Note that the storage for an event must be allocated by -the event source (using \fBTcl_Alloc\fR) +the event source (using \fBTcl_Alloc\fR or the Tcl macro \fBckalloc\fR) before calling \fBTcl_QueueEvent\fR, but it will be freed by \fBTcl_ServiceEvent\fR, not by the event source. .PP Threaded applications work in a similar manner, except that there is a separate event queue for @@ -426,11 +426,11 @@ queue. \fIProc\fR should match the following prototype: .PP .CS typedef int \fBTcl_EventDeleteProc\fR( Tcl_Event *\fIevPtr\fR, - void *\fIclientData\fR); + ClientData \fIclientData\fR); .CE .PP The \fIclientData\fR argument will be the same as the \fIclientData\fR argument to \fBTcl_DeleteEvents\fR; it is typically used to point to private information managed by the event source. The \fIevPtr\fR will Index: doc/Object.3 ================================================================== --- doc/Object.3 +++ doc/Object.3 @@ -109,13 +109,13 @@ Each Tcl value is represented by a \fBTcl_Obj\fR structure which is defined as follows. .PP .CS typedef struct Tcl_Obj { - size_t \fIrefCount\fR; + int \fIrefCount\fR; char *\fIbytes\fR; - size_t \fIlength\fR; + int \fIlength\fR; const Tcl_ObjType *\fItypePtr\fR; union { long \fIlongValue\fR; double \fIdoubleValue\fR; void *\fIotherValuePtr\fR; Index: doc/ObjectType.3 ================================================================== --- doc/ObjectType.3 +++ doc/ObjectType.3 @@ -83,18 +83,16 @@ and leaves an error message in the result value for \fIinterp\fR unless \fIinterp\fR is NULL. Otherwise, it returns \fBTCL_OK\fR. Passing a NULL \fIinterp\fR allows this procedure to be used as a test whether the conversion can be done (and in fact was done). -.VS 8.5 .PP In many cases, the \fItypePtr->setFromAnyProc\fR routine will set \fIobjPtr->typePtr\fR to the argument value \fItypePtr\fR, but that is no longer guaranteed. The \fIsetFromAnyProc\fR is free to set the internal representation for \fIobjPtr\fR to make use of another related Tcl_ObjType, if it sees fit. -.VE 8.5 .SH "THE TCL_OBJTYPE STRUCTURE" .PP Extension writers can define new value types by defining four procedures and initializing a Tcl_ObjType structure to describe the type. @@ -184,12 +182,12 @@ and to have no null bytes before that; this allows string representations to be treated as conventional null character-terminated C strings. These restrictions are easily met by using Tcl's internal UTF encoding for the string representation, same as one would do for other Tcl routines accepting string values as arguments. -Storage for the byte array must be allocated in the heap by \fBTcl_Alloc\fR. -Note that \fIupdateStringProc\fRs must allocate +Storage for the byte array must be allocated in the heap by \fBTcl_Alloc\fR +or \fBckalloc\fR. Note that \fIupdateStringProc\fRs must allocate enough storage for the string's bytes and the terminating null byte. .PP The \fIupdateStringProc\fR for Tcl's built-in double type, for example, calls Tcl_PrintDouble to write to a buffer of size TCL_DOUBLE_SPACE, then allocates and copies the string representation to just enough Index: doc/OpenFileChnl.3 ================================================================== --- doc/OpenFileChnl.3 +++ doc/OpenFileChnl.3 @@ -51,32 +51,32 @@ \fBTcl_ReadChars\fR(\fIchannel, readObjPtr, charsToRead, appendFlag\fR) .sp int \fBTcl_Read\fR(\fIchannel, readBuf, bytesToRead\fR) .sp -size_t +int \fBTcl_GetsObj\fR(\fIchannel, lineObjPtr\fR) .sp -size_t +int \fBTcl_Gets\fR(\fIchannel, lineRead\fR) .sp -size_t +int \fBTcl_Ungets\fR(\fIchannel, input, inputLen, addAtEnd\fR) .sp -size_t +int \fBTcl_WriteObj\fR(\fIchannel, writeObjPtr\fR) .sp -size_t +int \fBTcl_WriteChars\fR(\fIchannel, charBuf, bytesToWrite\fR) .sp -size_t +int \fBTcl_Write\fR(\fIchannel, byteBuf, bytesToWrite\fR) .sp -size_t +int \fBTcl_ReadRaw\fR(\fIchannel, readBuf, bytesToRead\fR) .sp -size_t +int \fBTcl_WriteRaw\fR(\fIchannel, byteBuf, bytesToWrite\fR) .sp int \fBTcl_Eof\fR(\fIchannel\fR) .sp @@ -132,11 +132,11 @@ input of the invoking process; likewise for \fBTCL_STDOUT\fR and \fBTCL_STDERR\fR. If \fBTCL_ENFORCE_MODE\fR is not set, then the pipe can redirect stdio handles to override the stdio handles for which \fBTCL_STDIN\fR, \fBTCL_STDOUT\fR and \fBTCL_STDERR\fR have been set. If it is set, then such redirections cause an error. -.AP void *handle in +.AP ClientData handle in Operating system specific handle for I/O to a file. For Unix this is a file descriptor, for Windows it is a HANDLE. .AP int readOrWrite in OR-ed combination of \fBTCL_READABLE\fR and \fBTCL_WRITABLE\fR to indicate what operations are valid on \fIhandle\fR. @@ -152,20 +152,20 @@ A Tcl channel for input or output. Must have been the return value from a procedure such as \fBTcl_OpenFileChannel\fR. .AP Tcl_Obj *readObjPtr in/out A pointer to a Tcl value in which to store the characters read from the channel. -.AP size_t charsToRead in +.AP int charsToRead in The number of characters to read from the channel. If the channel's encoding is \fBbinary\fR, this is equivalent to the number of bytes to read from the channel. .AP int appendFlag in If non-zero, data read from the channel will be appended to the value. Otherwise, the data will replace the existing contents of the value. .AP char *readBuf out A buffer in which to store the bytes read from the channel. -.AP size_t bytesToRead in +.AP int bytesToRead in The number of bytes to read from the channel. The buffer \fIreadBuf\fR must be large enough to hold this many bytes. .AP Tcl_Obj *lineObjPtr in/out A pointer to a Tcl value in which to store the line read from the channel. The line read will be appended to the current value of the @@ -174,11 +174,11 @@ A pointer to a Tcl dynamic string in which to store the line read from the channel. Must have been initialized by the caller. The line read will be appended to any data already in the dynamic string. .AP "const char" *input in The input to add to a channel buffer. -.AP size_t inputLen in +.AP int inputLen in Length of the input .AP int addAtEnd in Flag indicating whether the input should be added to the end or beginning of the channel buffer. .AP Tcl_Obj *writeObjPtr in @@ -185,11 +185,11 @@ A pointer to a Tcl value whose contents will be output to the channel. .AP "const char" *charBuf in A buffer containing the characters to output to the channel. .AP "const char" *byteBuf in A buffer containing the bytes to output to the channel. -.AP size_t bytesToWrite in +.AP int bytesToWrite in The number of bytes to consume from \fIcharBuf\fR or \fIbyteBuf\fR and output to the channel. .AP Tcl_WideInt offset in How far to move the access point in the channel at which the next input or output operation will be applied, measured in bytes from the position @@ -275,11 +275,11 @@ .PP If an error occurs while opening the channel, \fBTcl_OpenCommandChannel\fR returns NULL and records a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. In addition, \fBTcl_OpenCommandChannel\fR leaves an error message in -the interpreter's result if \fIinterp\fR is not NULL. +the interpreter's result. \fIinterp\fR cannot be NULL. .PP The newly created channel is not registered in the supplied interpreter; to register it, use \fBTcl_RegisterChannel\fR, described below. If one of the standard channels, \fBstdin\fR, \fBstdout\fR or \fBstderr\fR was previously closed, the act of creating the new channel also assigns it as a Index: doc/OpenTcp.3 ================================================================== --- doc/OpenTcp.3 +++ doc/OpenTcp.3 @@ -2,16 +2,16 @@ '\" Copyright (c) 1996-7 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.TH Tcl_OpenTcpClient 3 8.7 Tcl "Tcl Library Procedures" +.TH Tcl_OpenTcpClient 3 8.0 Tcl "Tcl Library Procedures" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -Tcl_OpenTcpClient, Tcl_MakeTcpClientChannel, Tcl_OpenTcpServer, Tcl_OpenTcpServerEx \- procedures to open channels using TCP sockets +Tcl_OpenTcpClient, Tcl_MakeTcpClientChannel, Tcl_OpenTcpServer \- procedures to open channels using TCP sockets .SH SYNOPSIS .nf \fB#include \fR .sp Tcl_Channel @@ -21,23 +21,17 @@ \fBTcl_MakeTcpClientChannel\fR(\fIsock\fR) .sp Tcl_Channel \fBTcl_OpenTcpServer\fR(\fIinterp, port, myaddr, proc, clientData\fR) .sp -Tcl_Channel -\fBTcl_OpenTcpServerEx\fR(\fIinterp, service, myaddr, flags, proc, clientData\fR) -.sp .SH ARGUMENTS .AS Tcl_TcpAcceptProc clientData .AP Tcl_Interp *interp in Tcl interpreter to use for error reporting. If non-NULL and an error occurs, an error message is left in the interpreter's result. .AP int port in A port number to connect to as a client or to listen on as a server. -.AP "const char" *service in -A string specifying the port number to connect to as a client or to listen on as - a server. .AP "const char" *host in A string specifying a host name or address for the remote end of the connection. .AP int myport in A port number for the client's end of the socket. If 0, a port number is allocated at random. @@ -45,19 +39,16 @@ A string specifying the host name or address for network interface to use for the local end of the connection. If NULL, a default interface is chosen. .AP int async in If nonzero, the client socket is connected asynchronously to the server. -.AP "unsigned int" flags in -ORed combination of \fBTCL_TCPSERVER\fR flags that specify additional -informations about the socket being created. -.AP void *sock in +.AP ClientData sock in Platform-specific handle for client TCP socket. .AP Tcl_TcpAcceptProc *proc in Pointer to a procedure to invoke each time a new connection is accepted via the socket. -.AP void *clientData in +.AP ClientData clientData in Arbitrary one-word value to pass to \fIproc\fR. .BE .SH DESCRIPTION .PP These functions are convenience procedures for creating @@ -125,11 +116,11 @@ for the new connection and invokes \fIproc\fR with information about the channel. \fIProc\fR must match the following prototype: .PP .CS typedef void \fBTcl_TcpAcceptProc\fR( - void *\fIclientData\fR, + ClientData \fIclientData\fR, Tcl_Channel \fIchannel\fR, char *\fIhostName\fR, int \fIport\fR); .CE .PP @@ -165,19 +156,14 @@ The newly created channel is not registered in the supplied interpreter; to register it, use \fBTcl_RegisterChannel\fR. If one of the standard channels, \fBstdin\fR, \fBstdout\fR or \fBstderr\fR was previously closed, the act of creating the new channel also assigns it as a replacement for the standard channel. -.SS TCL_OPENTCPSERVEREX -.PP -\fBTcl_OpenTcpServerEx\fR behaviour is identical to \fBTcl_OpenTcpServer\fR but -gives more flexibility to the user by providing a mean to further customize some -aspects of the socket via the \fIflags\fR parameter. .SH "PLATFORM ISSUES" .PP On Unix platforms, the socket handle is a Unix file descriptor as returned by the \fBsocket\fR system call. On the Windows platform, the socket handle is a \fBSOCKET\fR as defined in the WinSock API. .SH "SEE ALSO" Tcl_OpenFileChannel(3), Tcl_RegisterChannel(3), vwait(n) .SH KEYWORDS channel, client, server, socket, TCP Index: doc/Panic.3 ================================================================== --- doc/Panic.3 +++ doc/Panic.3 @@ -5,23 +5,23 @@ .TH Tcl_Panic 3 8.4 Tcl "Tcl Library Procedures" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -Tcl_Panic, Tcl_SetPanicProc, Tcl_ConsolePanic \- report fatal error and abort +Tcl_Panic, Tcl_PanicVA, Tcl_SetPanicProc \- report fatal error and abort .SH SYNOPSIS .nf \fB#include \fR .sp void \fBTcl_Panic\fR(\fIformat\fR, \fIarg\fR, \fIarg\fR, \fI...\fR) .sp void -\fBTcl_SetPanicProc\fR(\fIpanicProc\fR) +\fBTcl_PanicVA\fR(\fIformat\fR, \fIargList\fR) .sp void -\fBTcl_ConsolePanic\fR(\fIformat\fR, \fIarg\fR, \fIarg\fR, \fI...\fR) +\fBTcl_SetPanicProc\fR(\fIpanicProc\fR) .sp .SH ARGUMENTS .AS Tcl_PanicProc *panicProc .AP "const char*" format in A printf-style format string. @@ -48,22 +48,14 @@ .PP In a freshly loaded Tcl library, \fBTcl_Panic\fR prints the formatted error message to the standard error file of the process, and then calls \fBabort\fR to terminate the process. \fBTcl_Panic\fR does not return. On Windows, when a debugger is running, the formatted error -message is sent to the debugger in stead. If the windows executable +message is sent to the debugger instead. If the windows executable does not have a stderr channel (e.g. \fBwish.exe\fR), then a system dialog box is used to display the panic message. .PP -If your application doesn't use \fBTcl_Main\fR or \fBTk_Main\fR -and you want to implicitly use the stderr channel of your -application's C runtime (in stead of the stderr channel of the -C runtime used by Tcl), you can call \fBTcl_SetPanicProc\fR -with \fBTcl_ConsolePanic\fR as its argument. On platforms which -only have one C runtime (almost all platforms except Windows) -\fBTcl_ConsolePanic\fR is equivalent to NULL. -.PP \fBTcl_SetPanicProc\fR may be used to modify the behavior of \fBTcl_Panic\fR. The \fIpanicProc\fR argument should match the type \fBTcl_PanicProc\fR: .PP .CS @@ -87,10 +79,11 @@ the Tcl library, \fBTcl_Panic\fR is a public function and may be called by any extension or application that wishes to abort the process and have a panic message displayed the same way that panic messages from Tcl will be displayed. .PP -This function can not be used in stub-enabled extensions. +\fBTcl_PanicVA\fR is the same as \fBTcl_Panic\fR except that instead of +taking a variable number of arguments it takes an argument list. .SH "SEE ALSO" abort(3), printf(3), exec(n), format(n) .SH KEYWORDS abort, fatal, error Index: doc/ParseArgs.3 ================================================================== --- doc/ParseArgs.3 +++ doc/ParseArgs.3 @@ -29,11 +29,11 @@ The array of arguments to be parsed. .AP Tcl_Obj ***remObjv out Pointer to a variable that will hold the array of unprocessed arguments. Should be NULL if no return of unprocessed arguments is required. If \fIobjcPtr\fR is updated to a non-zero value, the array returned through this -must be deallocated using \fBTcl_Free\fR. +must be deallocated using \fBckfree\fR. .BE .SH DESCRIPTION .PP The \fBTcl_ParseArgsObjv\fR function provides a system for parsing argument lists of the form @@ -82,11 +82,11 @@ int \fItype\fR; const char *\fIkeyStr\fR; void *\fIsrcPtr\fR; void *\fIdstPtr\fR; const char *\fIhelpStr\fR; - void *\fIclientData\fR; + ClientData \fIclientData\fR; } \fBTcl_ArgvInfo\fR; .CE .PP The \fIkeyStr\fR field contains the name of the option; by convention, this will normally begin with a @@ -101,11 +101,11 @@ \fItype\fR: .TP \fBTCL_ARGV_CONSTANT\fR . The argument does not take any following value argument. If this argument is -present, the \fIsrcPtr\fR field (casted to \fIint\fR) is copied to the variable +present, the (integer) value of the \fIsrcPtr\fR field is copied to the variable pointed to by the \fIdstPtr\fR field. The \fIclientData\fR field is ignored. .TP \fBTCL_ARGV_END\fR . This value marks the end of all option descriptors in the table. All other @@ -125,11 +125,11 @@ have the following signature: .RS .PP .CS typedef int (\fBTcl_ArgvFuncProc\fR)( - void *\fIclientData\fR, + ClientData \fIclientData\fR, Tcl_Obj *\fIobjPtr\fR, void *\fIdstPtr\fR); .CE .PP The result is a boolean value indicating whether to consume the following @@ -147,11 +147,11 @@ function will have the following signature: .RS .PP .CS typedef int (\fBTcl_ArgvGenFuncProc\fR)( - void *\fIclientData\fR, + ClientData \fIclientData\fR, Tcl_Interp *\fIinterp\fR, int \fIobjc\fR, Tcl_Obj *const *\fIobjv\fR, void *\fIdstPtr\fR); .CE Index: doc/ParseCmd.3 ================================================================== --- doc/ParseCmd.3 +++ doc/ParseCmd.3 @@ -6,11 +6,11 @@ '\" .TH Tcl_ParseCommand 3 8.3 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME -Tcl_ParseCommand, Tcl_ParseExpr, Tcl_ParseBraces, Tcl_ParseQuotedString, Tcl_ParseVarName, Tcl_ParseVar, Tcl_FreeParse, Tcl_EvalTokensStandard \- parse Tcl scripts and expressions +Tcl_ParseCommand, Tcl_ParseExpr, Tcl_ParseBraces, Tcl_ParseQuotedString, Tcl_ParseVarName, Tcl_ParseVar, Tcl_FreeParse, Tcl_EvalTokens, Tcl_EvalTokensStandard \- parse Tcl scripts and expressions .SH SYNOPSIS .nf \fB#include \fR .sp int @@ -31,20 +31,24 @@ const char * \fBTcl_ParseVar\fR(\fIinterp, start, termPtr\fR) .sp \fBTcl_FreeParse\fR(\fIusedParsePtr\fR) .sp +Tcl_Obj * +\fBTcl_EvalTokens\fR(\fIinterp, tokenPtr, numTokens\fR) +.sp int \fBTcl_EvalTokensStandard\fR(\fIinterp, tokenPtr, numTokens\fR) .SH ARGUMENTS .AS Tcl_Interp *usedParsePtr out .AP Tcl_Interp *interp out -For procedures other than \fBTcl_FreeParse\fR and -\fBTcl_EvalTokensStandard\fR, used only for error reporting; +For procedures other than \fBTcl_FreeParse\fR, \fBTcl_EvalTokens\fR +and \fBTcl_EvalTokensStandard\fR, used only for error reporting; if NULL, then no error messages are left after errors. -For \fBTcl_EvalTokensStandard\fR, determines the context for evaluating -the script and also is used for error reporting; must not be NULL. +For \fBTcl_EvalTokens\fR and \fBTcl_EvalTokensStandard\fR, +determines the context for evaluating the +script and also is used for error reporting; must not be NULL. .AP "const char" *start in Pointer to first character in string to parse. .AP int numBytes in Number of bytes in string to parse, not including any terminating null character. If less than 0 then the script consists of all characters @@ -185,10 +189,20 @@ code with one of the values \fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR, or possibly some other integer value originating in an extension. In addition, a result value or error message is left in \fIinterp\fR's result; it can be retrieved using \fBTcl_GetObjResult\fR. +.PP +\fBTcl_EvalTokens\fR differs from \fBTcl_EvalTokensStandard\fR only in +the return convention used: it returns the result in a new Tcl_Obj. +The reference count of the value returned as result has been +incremented, so the caller must +invoke \fBTcl_DecrRefCount\fR when it is finished with the value. +If an error or other exception occurs while evaluating the tokens +(such as a reference to a non-existent variable) then the return value +is NULL and an error message is left in \fIinterp\fR's result. The use +of \fBTcl_EvalTokens\fR is deprecated. .SH "TCL_PARSE STRUCTURE" .PP \fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseBraces\fR, \fBTcl_ParseQuotedString\fR, and \fBTcl_ParseVarName\fR return parse information in two data structures, Tcl_Parse and Tcl_Token: @@ -206,12 +220,12 @@ } \fBTcl_Parse\fR; typedef struct Tcl_Token { int \fItype\fR; const char *\fIstart\fR; - size_t \fIsize\fR; - size_t \fInumComponents\fR; + int \fIsize\fR; + int \fInumComponents\fR; } \fBTcl_Token\fR; .CE .PP The first five fields of a Tcl_Parse structure are filled in only by \fBTcl_ParseCommand\fR. @@ -286,11 +300,11 @@ The token describes a range of literal text that is part of a word. The \fInumComponents\fR field is always 0. .TP \fBTCL_TOKEN_BS\fR . -The token describes a backslash sequence such as \fB\en\fR or \fB\e0xa3\fR. +The token describes a backslash sequence such as \fB\en\fR or \fB\e0xA3\fR. The \fInumComponents\fR field is always 0. .TP \fBTCL_TOKEN_COMMAND\fR . The token describes a command whose result must be substituted into Index: doc/Preserve.3 ================================================================== --- doc/Preserve.3 +++ doc/Preserve.3 @@ -19,11 +19,11 @@ \fBTcl_Release\fR(\fIclientData\fR) .sp \fBTcl_EventuallyFree\fR(\fIclientData, freeProc\fR) .SH ARGUMENTS .AS Tcl_FreeProc clientData -.AP void *clientData in +.AP ClientData clientData in Token describing structure to be freed or reallocated. Usually a pointer to memory for structure. .AP Tcl_FreeProc *freeProc in Procedure to invoke to free \fIclientData\fR. .BE @@ -89,11 +89,11 @@ \fIclientData\fR argument to \fBTcl_EventuallyFree\fR for historical reasons, but the value is the same. .PP When the \fIclientData\fR argument to \fBTcl_EventuallyFree\fR refers to storage allocated and returned by a prior call to -\fBTcl_Alloc\fR or another function of the Tcl library, +\fBTcl_Alloc\fR, \fBckalloc\fR, or another function of the Tcl library, then the \fIfreeProc\fR argument should be given the special value of \fBTCL_DYNAMIC\fR. .PP This mechanism can be used to solve the problem described above by placing \fBTcl_Preserve\fR and \fBTcl_Release\fR calls around Index: doc/PrintDbl.3 ================================================================== --- doc/PrintDbl.3 +++ doc/PrintDbl.3 @@ -16,11 +16,14 @@ .sp \fBTcl_PrintDouble\fR(\fIinterp, value, dst\fR) .SH ARGUMENTS .AS Tcl_Interp *interp out .AP Tcl_Interp *interp in -This argument is ignored. +Before Tcl 8.0, the \fBtcl_precision\fR variable in this interpreter +controlled the conversion. As of Tcl 8.0, this argument is ignored and +the conversion is controlled by the \fBtcl_precision\fR variable +that is now shared by all interpreters. .AP double value in Floating-point value to be converted. .AP char *dst out Where to store the string representing \fIvalue\fR. Must have at least \fBTCL_DOUBLE_SPACE\fR characters of storage. @@ -36,11 +39,13 @@ .QW e so that it does not look like an integer. Where \fB%g\fR would generate an integer with no decimal point, \fBTcl_PrintDouble\fR adds .QW .0 . .PP -The result will have the fewest digits needed to +If the \fBtcl_precision\fR value is non-zero, the result will have +precisely that many digits of significance. If the value is zero +(the default), the result will have the fewest digits needed to represent the number in such a way that \fBTcl_NewDoubleObj\fR will generate the same number when presented with the given string. IEEE semantics of rounding to even apply to the conversion. .SH KEYWORDS conversion, double-precision, floating-point, string Index: doc/RecEvalObj.3 ================================================================== --- doc/RecEvalObj.3 +++ doc/RecEvalObj.3 @@ -29,11 +29,13 @@ .BE .SH DESCRIPTION .PP \fBTcl_RecordAndEvalObj\fR is invoked to record a command as an event -on the history list and then execute it using \fBTcl_EvalObjEx\fR. +on the history list and then execute it using \fBTcl_EvalObjEx\fR +(or \fBTcl_GlobalEvalObj\fR if the \fBTCL_EVAL_GLOBAL\fR bit is set +in \fIflags\fR). It returns a completion code such as \fBTCL_OK\fR just like \fBTcl_EvalObjEx\fR, as well as a result value containing additional information (a result value or error message) that can be retrieved using \fBTcl_GetObjResult\fR. If you do not want the command recorded on the history list then Index: doc/RegExp.3 ================================================================== --- doc/RegExp.3 +++ doc/RegExp.3 @@ -62,11 +62,11 @@ If \fItext\fR is just a portion of some other string, this argument identifies the beginning of the larger string. If it is not the same as \fItext\fR, then no .QW \fB^\fR matches will be allowed. -.AP size_t index in +.AP int index in Specifies which range is desired: 0 means the range of the entire match, 1 or greater means the range that matched a parenthesized sub-expression. .AP "const char" **startPtr out The address of the first character in the range is stored here, or @@ -78,18 +78,18 @@ OR-ed combination of the compilation flags \fBTCL_REG_ADVANCED\fR, \fBTCL_REG_EXTENDED\fR, \fBTCL_REG_BASIC\fR, \fBTCL_REG_EXPANDED\fR, \fBTCL_REG_QUOTE\fR, \fBTCL_REG_NOCASE\fR, \fBTCL_REG_NEWLINE\fR, \fBTCL_REG_NLSTOP\fR, \fBTCL_REG_NLANCH\fR, \fBTCL_REG_NOSUB\fR, and \fBTCL_REG_CANMATCH\fR. See below for more information. -.AP size_t offset in +.AP int offset in The character offset into the text where matching should begin. The value of the offset has no impact on \fB^\fR matches. This behavior is controlled by \fIeflags\fR. -.AP size_t nmatches in +.AP int nmatches in The number of matching subexpressions that should be remembered for later use. If this value is 0, then no subexpression match -information will be computed. If the value is TCL_INDEX_NONE, then +information will be computed. If the value is \-1, then all of the matching subexpressions will be remembered. Any other value will be taken as the maximum number of subexpressions to remember. .AP int eflags in OR-ed combination of the execution flags \fBTCL_REG_NOTBOL\fR and @@ -335,13 +335,13 @@ \fIinfoPtr\fR argument contains a pointer to a structure that is defined as follows: .PP .CS typedef struct Tcl_RegExpInfo { - size_t \fInsubs\fR; + int \fInsubs\fR; Tcl_RegExpIndices *\fImatches\fR; - size_t \fIextendStart\fR; + long \fIextendStart\fR; } \fBTcl_RegExpInfo\fR; .CE .PP The \fInsubs\fR field contains a count of the number of parenthesized subexpressions within the regular expression. If the \fBTCL_REG_NOSUB\fR @@ -353,12 +353,12 @@ appear in the pattern. Each element is a structure that is defined as follows: .PP .CS typedef struct Tcl_RegExpIndices { - size_t \fIstart\fR; - size_t \fIend\fR; + long \fIstart\fR; + long \fIend\fR; } \fBTcl_RegExpIndices\fR; .CE .PP The \fIstart\fR and \fIend\fR values are Unicode character indices relative to the offset location within \fIobjPtr\fR where matching began. Index: doc/SaveResult.3 ================================================================== --- doc/SaveResult.3 +++ doc/SaveResult.3 @@ -1,20 +1,17 @@ '\" '\" Copyright (c) 1997 by Sun Microsystems, Inc. '\" Contributions from Don Porter, NIST, 2004. (not subject to US copyright) -'\" Copyright (c) 2018 Nathan Coulter. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_SaveResult 3 8.1 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME -Tcl_SaveInterpState, Tcl_RestoreInterpState, Tcl_DiscardInterpState, -Tcl_SaveResult, Tcl_RestoreResult, Tcl_DiscardResult \- Save and restore the -state of an an interpreter. +Tcl_SaveInterpState, Tcl_RestoreInterpState, Tcl_DiscardInterpState, Tcl_SaveResult, Tcl_RestoreResult, Tcl_DiscardResult \- save and restore an interpreter's state .SH SYNOPSIS .nf \fB#include \fR .sp Tcl_InterpState @@ -31,55 +28,93 @@ .sp \fBTcl_DiscardResult\fR(\fIsavedPtr\fR) .SH ARGUMENTS .AS Tcl_InterpState savedPtr .AP Tcl_Interp *interp in -The interpreter for the operation. +Interpreter for which state should be saved. .AP int status in -The return code for the state. +Return code value to save as part of interpreter state. .AP Tcl_InterpState state in -A token for saved state. +Saved state token to be restored or discarded. .AP Tcl_SavedResult *savedPtr in -A pointer to storage for saved state. +Pointer to location where interpreter result should be saved or restored. .BE .SH DESCRIPTION .PP -These routines save the state of an interpreter before a call to a routine such -as \fBTcl_Eval\fR, and restore the state afterwards. -.PP -\fBTcl_SaveInterpState\fR saves the parts of \fIinterp\fR that comprise the -result of a script, including the resulting value, the return code passed as -\fIstatus\fR, and any options such as \fB\-errorinfo\fR and \fB\-errorcode\fR. -It returns a token for the saved state. The interpreter result is not reset -and no interpreter state is changed. -.PP -\fBTcl_RestoreInterpState\fR restores the state indicated by \fIstate\fR and -returns the \fIstatus\fR originally passed in the corresponding call to -\fBTcl_SaveInterpState\fR. -.PP -If a saved state is not restored, \fBTcl_DiscardInterpState\fR must be called -to release it. A token used to discard or restore state must not be used -again. -.PP -\fBTcl_SaveResult\fR, \fBTcl_RestoreResult\fR, and \fBTcl_DiscardResult\fR are -deprecated. Instead use \fBTcl_SaveInterpState\fR, -\fBTcl_RestoreInterpState\fR, and \fBTcl_DiscardInterpState\fR, which are more -capable. -.PP -\fBTcl_SaveResult\fR moves the result of \fIinterp\fR to the location -\fIstatePtr\fR points to and returns the interpreter result to its initial -state. It does not save options such as \fB\-errorcode\fR or -\fB\-errorinfo\fR. -.PP -\fBTcl_RestoreResult\fR clears any existing result or error in \fIinterp\fR and -moves the result from \fIstatePtr\fR back to \fIinterp\fR. \fIstatePtr\fR is -then in an undefined state and must not be used until passed again to -\fBTcl_SaveResult\fR. -.PP -\fBTcl_DiscardResult\fR releases the state stored at \fBstatePtr\fR, which is -then in an undefined state and must not be used until passed again to -\fBTcl_SaveResult\fR. -.PP -If a saved result is not restored, \fBTcl_DiscardResult\fR must be called to -release it. +These routines allows a C procedure to take a snapshot of the current +state of an interpreter so that it can be restored after a call +to \fBTcl_Eval\fR or some other routine that modifies the interpreter +state. There are two triplets of routines meant to work together. +.PP +The first triplet stores the snapshot of interpreter state in +an opaque token returned by \fBTcl_SaveInterpState\fR. That token +value may then be passed back to one of \fBTcl_RestoreInterpState\fR +or \fBTcl_DiscardInterpState\fR, depending on whether the interp +state is to be restored. So long as one of the latter two routines +is called, Tcl will take care of memory management. +.PP +The second triplet stores the snapshot of only the interpreter +result (not its complete state) in memory allocated by the caller. +These routines are passed a pointer to \fBTcl_SavedResult\fR +that is used to store enough information to restore the interpreter result. +\fBTcl_SavedResult\fR can be allocated on the stack of the calling +procedure. These routines do not save the state of any error +information in the interpreter (e.g. the \fB\-errorcode\fR or +\fB\-errorinfo\fR return options, when an error is in progress). +.PP +Because the routines \fBTcl_SaveInterpState\fR, +\fBTcl_RestoreInterpState\fR, and \fBTcl_DiscardInterpState\fR perform +a superset of the functions provided by the other routines, +any new code should only make use of the more powerful routines. +The older, weaker routines \fBTcl_SaveResult\fR, \fBTcl_RestoreResult\fR, +and \fBTcl_DiscardResult\fR continue to exist only for the sake +of existing programs that may already be using them. +.PP +\fBTcl_SaveInterpState\fR takes a snapshot of those portions of +interpreter state that make up the full result of script evaluation. +This include the interpreter result, the return code (passed in +as the \fIstatus\fR argument, and any return options, including +\fB\-errorinfo\fR and \fB\-errorcode\fR when an error is in progress. +This snapshot is returned as an opaque token of type \fBTcl_InterpState\fR. +The call to \fBTcl_SaveInterpState\fR does not itself change the +state of the interpreter. Unlike \fBTcl_SaveResult\fR, it does +not reset the interpreter. +.PP +\fBTcl_RestoreInterpState\fR accepts a \fBTcl_InterpState\fR token +previously returned by \fBTcl_SaveInterpState\fR and restores the +state of the interp to the state held in that snapshot. The return +value of \fBTcl_RestoreInterpState\fR is the status value originally +passed to \fBTcl_SaveInterpState\fR when the snapshot token was +created. +.PP +\fBTcl_DiscardInterpState\fR is called to release a \fBTcl_InterpState\fR +token previously returned by \fBTcl_SaveInterpState\fR when that +snapshot is not to be restored to an interp. +.PP +The \fBTcl_InterpState\fR token returned by \fBTcl_SaveInterpState\fR +must eventually be passed to either \fBTcl_RestoreInterpState\fR +or \fBTcl_DiscardInterpState\fR to avoid a memory leak. Once +the \fBTcl_InterpState\fR token is passed to one of them, the +token is no longer valid and should not be used anymore. +.PP +\fBTcl_SaveResult\fR moves the string and value results +of \fIinterp\fR into the location specified by \fIstatePtr\fR. +\fBTcl_SaveResult\fR clears the result for \fIinterp\fR and +leaves the result in its normal empty initialized state. +.PP +\fBTcl_RestoreResult\fR moves the string and value results from +\fIstatePtr\fR back into \fIinterp\fR. Any result or error that was +already in the interpreter will be cleared. The \fIstatePtr\fR is left +in an uninitialized state and cannot be used until another call to +\fBTcl_SaveResult\fR. +.PP +\fBTcl_DiscardResult\fR releases the saved interpreter state +stored at \fBstatePtr\fR. The state structure is left in an +uninitialized state and cannot be used until another call to +\fBTcl_SaveResult\fR. +.PP +Once \fBTcl_SaveResult\fR is called to save the interpreter +result, either \fBTcl_RestoreResult\fR or +\fBTcl_DiscardResult\fR must be called to properly clean up the +memory associated with the saved state. .SH KEYWORDS result, state, interp Index: doc/SetRecLmt.3 ================================================================== --- doc/SetRecLmt.3 +++ doc/SetRecLmt.3 @@ -27,11 +27,11 @@ .SH DESCRIPTION .PP At any given time Tcl enforces a limit on the number of recursive calls that may be active for \fBTcl_Eval\fR and related procedures -such as \fBTcl_EvalEx\fR. +such as \fBTcl_GlobalEval\fR. Any call to \fBTcl_Eval\fR that exceeds this depth is aborted with an error. By default the recursion limit is 1000. .PP \fBTcl_SetRecursionLimit\fR may be used to change the maximum Index: doc/SetResult.3 ================================================================== --- doc/SetResult.3 +++ doc/SetResult.3 @@ -3,15 +3,15 @@ '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.TH Tcl_SetResult 3 8.0 Tcl "Tcl Library Procedures" +.TH Tcl_SetResult 3 8.6 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME -Tcl_SetObjResult, Tcl_GetObjResult, Tcl_SetResult, Tcl_GetStringResult, Tcl_AppendResult, Tcl_AppendElement, Tcl_ResetResult, Tcl_TransferResult, Tcl_FreeResult \- manipulate Tcl result +Tcl_SetObjResult, Tcl_GetObjResult, Tcl_SetResult, Tcl_GetStringResult, Tcl_AppendResult, Tcl_AppendResultVA, Tcl_AppendElement, Tcl_ResetResult, Tcl_TransferResult, Tcl_FreeResult \- manipulate Tcl result .SH SYNOPSIS .nf \fB#include \fR .sp \fBTcl_SetObjResult\fR(\fIinterp, objPtr\fR) @@ -24,14 +24,16 @@ const char * \fBTcl_GetStringResult\fR(\fIinterp\fR) .sp \fBTcl_AppendResult\fR(\fIinterp, result, result, ... , \fB(char *) NULL\fR) .sp +\fBTcl_AppendResultVA\fR(\fIinterp, argList\fR) +.sp \fBTcl_ResetResult\fR(\fIinterp\fR) .sp .VS 8.6 -\fBTcl_TransferResult\fR(\fIsourceInterp, result, targetInterp\fR) +\fBTcl_TransferResult\fR(\fIsourceInterp, code, targetInterp\fR) .VE 8.6 .sp \fBTcl_AppendElement\fR(\fIinterp, element\fR) .sp \fBTcl_FreeResult\fR(\fIinterp\fR) @@ -54,20 +56,19 @@ .AP va_list argList in An argument list which must have been initialized using \fBva_start\fR, and cleared using \fBva_end\fR. .AP Tcl_Interp *sourceInterp in .VS 8.6 -Interpreter that the result and error information should be copied from. +Interpreter that the result and return options should be transferred from. .VE 8.6 .AP Tcl_Interp *targetInterp in .VS 8.6 -Interpreter that the result and error information should be copied to. +Interpreter that the result and return options should be transferred to. .VE 8.6 -.AP int result in +.AP int code in .VS 8.6 -If \fBTCL_OK\fR, only copy the result. If \fBTCL_ERROR\fR, copy the error -information as well. +Return code value that controls transfer of return options. .VE 8.6 .BE .SH DESCRIPTION .PP The procedures described here are utilities for manipulating the @@ -148,15 +149,22 @@ \fIinterp\fR so as to handle backward-compatibility with old-style extensions. Any number of \fIresult\fR arguments may be passed in a single call; the last argument in the list must be a NULL pointer. .PP +\fBTcl_AppendResultVA\fR is the same as \fBTcl_AppendResult\fR except that +instead of taking a variable number of arguments it takes an argument list. +.PP .VS 8.6 -\fBTcl_TransferResult\fR moves a result from one interpreter to another, -optionally (dependent on the \fIresult\fR parameter) including the error -information dictionary as well. The interpreters must be in the same thread. -The source interpreter will have its result reset by this operation. +\fBTcl_TransferResult\fR transfers interpreter state from \fIsourceInterp\fR +to \fItargetInterp\fR. The two interpreters must have been created in the +same thread. If \fIsourceInterp\fR and \fItargetInterp\fR are the same, +nothing is done. Otherwise, \fBTcl_TransferResult\fR moves the result +from \fIsourceInterp\fR to \fItargetInterp\fR, and resets the result +in \fIsourceInterp\fR. It also moves the return options dictionary as +controlled by the return code value \fIcode\fR in the same manner +as \fBTcl_GetReturnOptions\fR. .VE 8.6 .SH "DEPRECATED INTERFACES" .SS "OLD STRING PROCEDURES" .PP Use of the following procedures is deprecated @@ -190,10 +198,23 @@ It frees up the memory associated with \fIinterp\fR's result. It also sets \fIinterp->freeProc\fR to zero, but does not change \fIinterp->result\fR or clear error state. \fBTcl_FreeResult\fR is most commonly used when a procedure is about to replace one result value with another. +.SS "DIRECT ACCESS TO INTERP->RESULT" +.PP +It used to be legal for programs to +directly read and write \fIinterp->result\fR +to manipulate the interpreter result. The Tcl headers no longer +permit this access by default, and C code still doing this must +be updated to use supported routines \fBTcl_GetObjResult\fR, +\fBTcl_GetStringResult\fR, \fBTcl_SetObjResult\fR, and \fBTcl_SetResult\fR. +As a migration aid, access can be restored with the compiler directive +.CS +#define USE_INTERP_RESULT +.CE +but this is meant only to offer life support to otherwise dead code. .SH "THE TCL_FREEPROC ARGUMENT TO TCL_SETRESULT" .PP \fBTcl_SetResult\fR's \fIfreeProc\fR argument specifies how the Tcl system is to manage the storage for the \fIresult\fR argument. If \fBTcl_SetResult\fR or \fBTcl_SetObjResult\fR are called @@ -230,8 +251,9 @@ .CE .PP When \fIfreeProc\fR is called, its \fIblockPtr\fR will be set to the value of \fIresult\fR passed to \fBTcl_SetResult\fR. .SH "SEE ALSO" -Tcl_AddErrorInfo, Tcl_CreateObjCommand, Tcl_SetErrorCode, Tcl_Interp +Tcl_AddErrorInfo, Tcl_CreateObjCommand, Tcl_SetErrorCode, Tcl_Interp, +Tcl_GetReturnOptions .SH KEYWORDS append, command, element, list, value, result, return value, interpreter Index: doc/SplitList.3 ================================================================== --- doc/SplitList.3 +++ doc/SplitList.3 @@ -18,20 +18,20 @@ \fBTcl_SplitList\fR(\fIinterp, list, argcPtr, argvPtr\fR) .sp char * \fBTcl_Merge\fR(\fIargc, argv\fR) .sp -size_t +int \fBTcl_ScanElement\fR(\fIsrc, flagsPtr\fR) .sp -size_t +int \fBTcl_ScanCountedElement\fR(\fIsrc, length, flagsPtr\fR) .sp -size_t +int \fBTcl_ConvertElement\fR(\fIsrc, dst, flags\fR) .sp -size_t +int \fBTcl_ConvertCountedElement\fR(\fIsrc, length, dst, flags\fR) .SH ARGUMENTS .AS "const char *const" ***argvPtr out .AP Tcl_Interp *interp out Interpreter to use for error reporting. If NULL, then no error message @@ -53,11 +53,11 @@ .AP "const char" *src in String that is to become an element of a list. .AP int *flagsPtr in Pointer to word to fill in with information about \fIsrc\fR. The value of *\fIflagsPtr\fR must be passed to \fBTcl_ConvertElement\fR. -.AP size_t length in +.AP int length in Number of bytes in string \fIsrc\fR. .AP char *dst in Place to copy converted list element. Must contain enough characters to hold converted string. .AP int flags in Index: doc/StaticPkg.3 ================================================================== --- doc/StaticPkg.3 +++ doc/StaticPkg.3 @@ -62,11 +62,9 @@ \fBTCL_ERROR\fR to indicate whether or not it completed successfully; in the event of an error it should set the interpreter's result to point to an error message. The result or error from the initialization procedure will be returned as the result of the \fBload\fR command that caused the initialization procedure to be invoked. -.PP -This function can not be used in stub-enabled extensions. .SH KEYWORDS initialization procedure, package, static linking .SH "SEE ALSO" load(n), package(n), Tcl_PkgRequire(3) 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 \- 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_AppendStringsToObjVA, 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 * @@ -35,11 +35,11 @@ \fBTcl_GetUnicodeFromObj\fR(\fIobjPtr, lengthPtr\fR) .sp Tcl_UniChar * \fBTcl_GetUnicode\fR(\fIobjPtr\fR) .sp -int +Tcl_UniChar \fBTcl_GetUniChar\fR(\fIobjPtr, index\fR) .sp int \fBTcl_GetCharLength\fR(\fIobjPtr\fR) .sp @@ -56,10 +56,13 @@ \fBTcl_AppendObjToObj\fR(\fIobjPtr, appendObjPtr\fR) .sp void \fBTcl_AppendStringsToObj\fR(\fIobjPtr, string, string, ... \fB(char *) NULL\fR) .sp +void +\fBTcl_AppendStringsToObjVA\fR(\fIobjPtr, argList\fR) +.sp void \fBTcl_AppendLimitedToObj\fR(\fIobjPtr, bytes, length, limit, ellipsis\fR) .sp Tcl_Obj * \fBTcl_Format\fR(\fIinterp, format, objc, objv\fR) @@ -85,33 +88,33 @@ .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 used to set or append to a string value. This byte array may contain embedded null characters -unless \fInumChars\fR is TCL_AUTO_LENGTH. (Applications needing null bytes -should represent them as the two-byte sequence \fI\e700\e600\fR, use +unless \fInumChars\fR is negative. (Applications needing null bytes +should represent them as the two-byte sequence \fI\e300\e200\fR, use \fBTcl_ExternalToUtf\fR to convert, or \fBTcl_NewByteArrayObj\fR if the string is a collection of uninterpreted bytes.) -.AP size_t length in +.AP int length in The number of bytes to copy from \fIbytes\fR when initializing, setting, or appending to a string value. -If TCL_AUTO_LENGTH, all bytes up to the first null are used. +If negative, all bytes up to the first null are used. .AP "const Tcl_UniChar" *unicode in Points to the first byte of an array of Unicode characters used to set or append to a string value. This byte array may contain embedded null characters unless \fInumChars\fR is negative. -.AP size_t numChars in +.AP int numChars in The number of Unicode characters to copy from \fIunicode\fR when initializing, setting, or appending to a string value. -If TCL_AUTO_LENGTH, all characters up to the first null character are used. -.AP size_t index in +If negative, all characters up to the first null character are used. +.AP int index in The index of the Unicode character to return. -.AP size_t first in +.AP int first in The index of the first Unicode character in the Unicode range to be returned as a new value. -.AP size_t last in +.AP int last in The index of the last Unicode character in the Unicode range to be returned as a new value. .AP Tcl_Obj *objPtr in/out Points to a value to manipulate. .AP Tcl_Obj *appendObjPtr in @@ -122,11 +125,11 @@ .AP "const char" *string in Null-terminated string value to append to \fIobjPtr\fR. .AP va_list argList in An argument list which must have been initialized using \fBva_start\fR, and cleared using \fBva_end\fR. -.AP size_t limit in +.AP int limit in Maximum number of bytes to be appended. .AP "const char" *ellipsis in Suffix to append when the limit leads to string truncation. If NULL is passed then the suffix .QW "..." @@ -135,11 +138,11 @@ Format control string including % conversion specifiers. .AP int objc in The number of elements to format or concatenate. .AP Tcl_Obj *objv[] in The array of values to format or concatenate. -.AP size_t newLength in +.AP int newLength in New length for the string value of \fIobjPtr\fR, not including the final null character. .BE .SH DESCRIPTION .PP @@ -199,12 +202,12 @@ the caller. The procedure \fBTcl_GetUnicode\fR is used in the common case where the caller does not need the length of the unicode string representation. .PP \fBTcl_GetUniChar\fR returns the \fIindex\fR'th character in the -value's Unicode representation. If the index is out of range or -it references a low surrogate preceded by a high surrogate, it returns -1; +value's Unicode representation. The index is assumed to be in the +appropriate range. .PP \fBTcl_GetRange\fR returns a newly created value comprised of the characters between \fIfirst\fR and \fIlast\fR (inclusive) in the value's Unicode representation. If the value's Unicode representation is invalid, the Unicode representation is regenerated @@ -241,10 +244,14 @@ except that it can be passed more than one value to append and each value must be a null-terminated string (i.e. none of the values may contain internal null characters). Any number of \fIstring\fR arguments may be provided, but the last argument must be a NULL pointer to indicate the end of the list. +.PP +\fBTcl_AppendStringsToObjVA\fR is the same as \fBTcl_AppendStringsToObj\fR +except that instead of taking a variable number of arguments it takes an +argument list. .PP \fBTcl_AppendLimitedToObj\fR is similar to \fBTcl_AppendToObj\fR except that it imposes a limit on how many bytes are appended. This can be handy when the string to be appended might be very large, but the value being constructed should not be allowed to grow Index: doc/TCL_MEM_DEBUG.3 ================================================================== --- doc/TCL_MEM_DEBUG.3 +++ doc/TCL_MEM_DEBUG.3 @@ -32,30 +32,30 @@ functions \fBTcl_ValidateAllMemory\fR, and \fBTcl_DumpActiveMemory\fR, and the Tcl \fBmemory\fR command can be used to validate and examine memory usage. .SH "GUARD ZONES" .PP -When memory debugging is enabled, whenever a call to \fBTcl_Alloc\fR is +When memory debugging is enabled, whenever a call to \fBckalloc\fR is made, slightly more memory than requested is allocated so the memory debugging code can keep track of the allocated memory, and eight-byte .QW "guard zones" are placed in front of and behind the space that will be returned to the caller. (The sizes of the guard zones are defined by the C #define \fBLOW_GUARD_SIZE\fR and #define \fBHIGH_GUARD_SIZE\fR in the file \fIgeneric/tclCkalloc.c\fR \(em it can be extended if you suspect large overwrite problems, at some cost in performance.) A known pattern is written into the guard zones and, on -a call to \fBTcl_Free\fR, the guard zones of the space being freed are +a call to \fBckfree\fR, the guard zones of the space being freed are checked to see if either zone has been modified in any way. If one has been, the guard bytes and their new contents are identified, and a .QW "low guard failed" or .QW "high guard failed" message is issued. The .QW "guard failed" message includes the address of the memory packet and -the file name and line number of the code that called \fBTcl_Free\fR. +the file name and line number of the code that called \fBckfree\fR. This allows you to detect the common sorts of one-off problems, where not enough space was allocated to contain the data written, for example. .SH "DEBUGGING DIFFICULT MEMORY CORRUPTION PROBLEMS" .PP @@ -64,17 +64,17 @@ the memory command can help isolate difficult problems. If you suspect (or know) that corruption is occurring before the Tcl interpreter comes up far enough for you to issue commands, you can set \fBMEM_VALIDATE\fR define, recompile tclCkalloc.c and rebuild Tcl. This will enable memory validation from the first call to -\fBTcl_Alloc\fR, again, at a large performance impact. +\fBckalloc\fR, again, at a large performance impact. .PP If you are desperate and validating memory on every call to -\fBTcl_Alloc\fR and \fBTcl_Free\fR is not enough, you can explicitly call +\fBckalloc\fR and \fBckfree\fR is not enough, you can explicitly call \fBTcl_ValidateAllMemory\fR directly at any point. It takes a \fIchar *\fR and an \fIint\fR which are normally the filename and line number of the caller, but they can actually be anything you want. Remember to remove the calls after you find the problem. .SH "SEE ALSO" -Tcl_Alloc, memory, Tcl_ValidateAllMemory, Tcl_DumpActiveMemory +ckalloc, memory, Tcl_ValidateAllMemory, Tcl_DumpActiveMemory .SH KEYWORDS memory, debug Index: doc/Tcl.n ================================================================== --- doc/Tcl.n +++ doc/Tcl.n @@ -26,14 +26,14 @@ A command is evaluated in two steps. First, the Tcl interpreter breaks the command into \fIwords\fR and performs substitutions as described below. These substitutions are performed in the same way for all commands. -Secondly, the first word is used to locate a routine to -carry out the command, and the remaining words of the command are -passed to that routine. -The routine is free to interpret each of its words +Secondly, the first word is used to locate a command procedure to +carry out the command, then all of the words of the command are +passed to the command procedure. +The command procedure is free to interpret each of its words in any way it likes, such as an integer, variable name, list, or Tcl script. Different commands interpret their words differently. .IP "[3] \fBWords.\fR" Words of a command are separated by white space (except for Index: doc/TclZlib.3 ================================================================== --- doc/TclZlib.3 +++ doc/TclZlib.3 @@ -86,11 +86,11 @@ .AP "unsigned int" initValue in The initial value for the checksum algorithm. .AP "unsigned char" *bytes in An array of bytes to run the checksum algorithm over, or NULL to get the recommended initial value for the checksum algorithm. -.AP size_t length in +.AP int length in The number of bytes in the array. .AP int mode in What mode to operate the stream in. Should be either \fBTCL_ZLIB_STREAM_DEFLATE\fR for a compressing stream or \fBTCL_ZLIB_STREAM_INFLATE\fR for a decompressing stream. @@ -105,13 +105,13 @@ if the currently compressed data must be made available for access using \fBTcl_ZlibStreamGet\fR, \fBTCL_ZLIB_FULLFLUSH\fR if the stream must be put into a state where the decompressor can recover from on corruption, or \fBTCL_ZLIB_FINALIZE\fR to ensure that the stream is finished and that any trailer demanded by the format is written. -.AP size_t count in -The maximum number of bytes to get from the stream, or TCL_AUTO_LENGTH to get -all remaining bytes from the stream's buffers. +.AP int count in +The maximum number of bytes to get from the stream, or -1 to get all remaining +bytes from the stream's buffers. .AP Tcl_Obj *compDict in A byte array value that is the compression dictionary to use with the stream. Note that this is \fInot a Tcl dictionary\fR, and it is recommended that this only ever be used with streams that were created with their \fIformat\fR set to \fBTCL_ZLIB_FORMAT_ZLIB\fR because the other formats have no mechanism to Index: doc/Tcl_Main.3 ================================================================== --- doc/Tcl_Main.3 +++ doc/Tcl_Main.3 @@ -77,11 +77,11 @@ stub library. Programs that call \fBTcl_Main\fR must be linked against the standard Tcl library. Extensions (stub-enabled or not) are not intended to call \fBTcl_Main\fR. .PP \fBTcl_Main\fR is not thread-safe. It should only be called by -a single master thread of a multi-threaded application. This +a single main thread of a multi-threaded application. This restriction is not a problem with normal use described above. .PP \fBTcl_Main\fR and therefore all applications based upon it, like \fBtclsh\fR, use \fBTcl_GetStdChannel\fR to initialize the standard channels to their default values. See \fBTcl_StandardChannels\fR for @@ -110,11 +110,11 @@ .PP The file name and encoding values managed by the routines \fBTcl_SetStartupScript\fR and \fBTcl_GetStartupScript\fR are stored per-thread. Although the storage and retrieval functions of these routines work in any thread, only those -calls in the same master thread as \fBTcl_Main\fR can have +calls in the same main thread as \fBTcl_Main\fR can have any influence on it. .PP The caller of \fBTcl_Main\fR may call \fBTcl_SetStartupScript\fR first to establish its desired startup script. If \fBTcl_Main\fR finds that no such startup script has been established, it consults @@ -124,11 +124,11 @@ then \fIfileName\fR is taken to be the name of a file containing a \fIstartup script\fR, and \fIname\fR is taken to be the name of the encoding of the contents of that file. \fBTcl_Main\fR then calls \fBTcl_SetStartupScript\fR with these values. .PP -\fBTcl_Main\fR then defines in its master interpreter +\fBTcl_Main\fR then defines in its main interpreter the Tcl variables \fIargc\fR, \fIargv\fR, \fIargv0\fR, and \fItcl_interactive\fR, as described in the documentation for \fBtclsh\fR. .PP When it has finished its own initialization, but before it processes commands, \fBTcl_Main\fR calls the procedure given by the @@ -152,21 +152,21 @@ When the \fIappInitProc\fR is finished, \fBTcl_Main\fR calls \fBTcl_GetStartupScript\fR to determine what startup script has been requested, if any. If a startup script has been provided, \fBTcl_Main\fR attempts to evaluate it. Otherwise, interactive mode begins with examination of the variable \fItcl_rcFileName\fR -in the master interpreter. If that variable exists and holds the +in the main interpreter. If that variable exists and holds the name of a readable file, the contents of that file are evaluated -in the master interpreter. Then interactive operations begin, +in the main interpreter. Then interactive operations begin, with prompts and command evaluation results written to the standard output channel, and commands read from the standard input channel and then evaluated. The prompts written to the standard output channel may be customized by defining the Tcl variables \fItcl_prompt1\fR and \fItcl_prompt2\fR as described in the documentation for \fBtclsh\fR. The prompts and command evaluation results are written to the standard output channel only if the Tcl variable \fItcl_interactive\fR in the -master interpreter holds a non-zero integer value. +main interpreter holds a non-zero integer value. .PP \fBTcl_SetMainLoop\fR allows setting an event loop procedure to be run. This allows, for example, Tk to be dynamically loaded and set its event loop. The event loop will run following the startup script. If you are in interactive mode, setting the main loop procedure will cause the @@ -187,12 +187,10 @@ itself will evaluate the \fBexit\fR command after the main loop procedure (if any) returns. In non-interactive mode, after \fBTcl_Main\fR evaluates the startup script, and the main loop procedure (if any) returns, \fBTcl_Main\fR will also evaluate the \fBexit\fR command. -.PP -This function can not be used in stub-enabled extensions. .SH "SEE ALSO" tclsh(1), Tcl_GetStdChannel(3), Tcl_StandardChannels(3), Tcl_AppInit(3), exit(n), encoding(n) .SH KEYWORDS application-specific initialization, command-line arguments, main program Index: doc/Thread.3 ================================================================== --- doc/Thread.3 +++ doc/Thread.3 @@ -43,13 +43,11 @@ .SH ARGUMENTS .AS Tcl_CreateThreadProc proc out .AP Tcl_Condition *condPtr in A condition variable, which must be associated with a mutex lock. .AP Tcl_Mutex *mutexPtr in -.VS TIP509 -A recursive mutex lock. -.VE TIP509 +A mutex lock. .AP "const Tcl_Time" *timePtr in A time limit on the condition wait. NULL to wait forever. Note that a polling value of 0 seconds does not make much sense. .AP Tcl_ThreadDataKey *keyPtr in This identifies a block of thread local storage. The key should be @@ -65,11 +63,11 @@ .AP Tcl_ThreadId id in Id of the thread waited upon. .AP Tcl_ThreadCreateProc *proc in This procedure will act as the \fBmain()\fR of the newly created thread. The specified \fIclientData\fR will be its sole argument. -.AP void *clientData in +.AP ClientData clientData in Arbitrary information. Passed as sole argument to the \fIproc\fR. .AP int stackSize in The size of the stack given to the new thread. .AP int flags in Bitmask containing flags allowing the caller to modify behavior of @@ -140,16 +138,12 @@ A mutex is a lock that is used to serialize all threads through a piece of code by calling \fBTcl_MutexLock\fR and \fBTcl_MutexUnlock\fR. If one thread holds a mutex, any other thread calling \fBTcl_MutexLock\fR will block until \fBTcl_MutexUnlock\fR is called. A mutex can be destroyed after its use by calling \fBTcl_MutexFinalize\fR. -.VS TIP509 -Mutexes are reentrant: they can be locked several times from the same -thread. However there must be exactly one call to -\fBTcl_MutexUnlock\fR for each call to \fBTcl_MutexLock\fR in order -for a thread to release a mutex completely. -.VE TIP509 +The result of locking a mutex twice from the same thread is undefined. +On some platforms it will result in a deadlock. The \fBTcl_MutexLock\fR, \fBTcl_MutexUnlock\fR and \fBTcl_MutexFinalize\fR procedures are defined as empty macros if not compiling with threads enabled. For declaration of mutexes the \fBTCL_DECLARE_MUTEX\fR macro should be used. This macro assures correct mutex handling even when the core is compiled without threads enabled. @@ -206,11 +200,11 @@ value and then finishes. .PP .CS static \fBTcl_ThreadCreateType\fR MyThreadImplFunc( - void *clientData) + ClientData clientData) { int i, limit = (int) clientData; for (i=0 ; i\fR .sp -int +Tcl_UniChar \fBTcl_UniCharToUpper\fR(\fIch\fR) .sp -int +Tcl_UniChar \fBTcl_UniCharToLower\fR(\fIch\fR) .sp -int +Tcl_UniChar \fBTcl_UniCharToTitle\fR(\fIch\fR) .sp int \fBTcl_UtfToUpper\fR(\fIstr\fR) .sp @@ -76,7 +76,14 @@ .PP \fBTcl_UtfToTitle\fR is the same as \fBTcl_UtfToUpper\fR except it turns the first character in the string into its title-case equivalent and all following characters into their lower-case equivalents. +.SH BUGS +.PP +At this time, the case conversions are only defined for the Unicode +plane 0 characters. The result for Unicode characters above 0xFFFF +is undefined, but - actually - only the lower 16 bits of the +character value is handled. + .SH KEYWORDS utf, unicode, toupper, tolower, totitle, case Index: doc/TraceCmd.3 ================================================================== --- doc/TraceCmd.3 +++ doc/TraceCmd.3 @@ -11,11 +11,11 @@ Tcl_CommandTraceInfo, Tcl_TraceCommand, Tcl_UntraceCommand \- monitor renames and deletes of a command .SH SYNOPSIS .nf \fB#include \fR .sp -void * +ClientData \fBTcl_CommandTraceInfo(\fIinterp, cmdName, flags, proc, prevClientData\fB)\fR .sp int \fBTcl_TraceCommand(\fIinterp, cmdName, flags, proc, clientData\fB)\fR .sp @@ -30,13 +30,13 @@ .AP int flags in OR'ed collection of the values \fBTCL_TRACE_RENAME\fR and \fBTCL_TRACE_DELETE\fR. .AP Tcl_CommandTraceProc *proc in Procedure to call when specified operations occur to \fIcmdName\fR. -.AP void *clientData in +.AP ClientData clientData in Arbitrary argument to pass to \fIproc\fR. -.AP void *prevClientData in +.AP ClientData prevClientData in If non-NULL, gives last value returned by \fBTcl_CommandTraceInfo\fR, so this call will return information about next trace. If NULL, this call will return information about first trace. .BE .SH DESCRIPTION @@ -63,20 +63,20 @@ \fIproc\fR will be invoked. It should have arguments and result that match the type \fBTcl_CommandTraceProc\fR: .PP .CS typedef void \fBTcl_CommandTraceProc\fR( - void *\fIclientData\fR, + ClientData \fIclientData\fR, Tcl_Interp *\fIinterp\fR, const char *\fIoldName\fR, const char *\fInewName\fR, int \fIflags\fR); .CE .PP The \fIclientData\fR and \fIinterp\fR parameters will have the same values as those passed to \fBTcl_TraceCommand\fR when the trace was -created. \fIclientData\fR typically points to an application-specific +created. \fIClientData\fR typically points to an application-specific data structure that describes what to do when \fIproc\fR is invoked. \fIOldName\fR gives the name of the command being renamed, and \fInewName\fR gives the name that the command is being renamed to (or NULL when the command is being deleted.) \fIFlags\fR is an OR'ed combination of bits potentially providing Index: doc/TraceVar.3 ================================================================== --- doc/TraceVar.3 +++ doc/TraceVar.3 @@ -22,17 +22,17 @@ .sp \fBTcl_UntraceVar(\fIinterp, varName, flags, proc, clientData\fB)\fR .sp \fBTcl_UntraceVar2(\fIinterp, name1, name2, flags, proc, clientData\fB)\fR .sp -void * +ClientData \fBTcl_VarTraceInfo(\fIinterp, varName, flags, proc, prevClientData\fB)\fR .sp -void * +ClientData \fBTcl_VarTraceInfo2(\fIinterp, name1, name2, flags, proc, prevClientData\fB)\fR .SH ARGUMENTS -.AS void *prevClientData +.AS Tcl_VarTraceProc prevClientData .AP Tcl_Interp *interp in Interpreter containing variable. .AP "const char" *varName in Name of variable. May refer to a scalar variable, to an array variable with no index, or to an array variable @@ -44,19 +44,19 @@ \fBTCL_TRACE_RESULT_DYNAMIC\fR and \fBTCL_TRACE_RESULT_OBJECT\fR. Not all flags are used by all procedures. See below for more information. .AP Tcl_VarTraceProc *proc in Procedure to invoke whenever one of the traced operations occurs. -.AP void *clientData in +.AP ClientData clientData in Arbitrary one-word value to pass to \fIproc\fR. .AP "const char" *name1 in Name of scalar or array variable (without array index). .AP "const char" *name2 in For a trace on an element of an array, gives the index of the element. For traces on scalar variables or on whole arrays, is NULL. -.AP void *prevClientData in +.AP ClientData prevClientData in If non-NULL, gives last value returned by \fBTcl_VarTraceInfo\fR or \fBTcl_VarTraceInfo2\fR, so this call will return information about next trace. If NULL, this call will return information about first trace. .BE @@ -105,11 +105,11 @@ before an array set, but that will trigger write traces. .TP \fBTCL_TRACE_RESULT_DYNAMIC\fR The result of invoking the \fIproc\fR is a dynamically allocated string that will be released by the Tcl library via a call to -\fBTcl_Free\fR. Must not be specified at the same time as +\fBckfree\fR. Must not be specified at the same time as \fBTCL_TRACE_RESULT_OBJECT\fR. .TP \fBTCL_TRACE_RESULT_OBJECT\fR The result of invoking the \fIproc\fR is a Tcl_Obj* (cast to a char*) with a reference count of at least one. The ownership of that @@ -122,21 +122,21 @@ It should have arguments and result that match the type \fBTcl_VarTraceProc\fR: .PP .CS typedef char *\fBTcl_VarTraceProc\fR( - void *\fIclientData\fR, + ClientData \fIclientData\fR, Tcl_Interp *\fIinterp\fR, char *\fIname1\fR, char *\fIname2\fR, int \fIflags\fR); .CE .PP The \fIclientData\fR and \fIinterp\fR parameters will have the same values as those passed to \fBTcl_TraceVar\fR when the trace was created. -\fIclientData\fR typically points to an application-specific +\fIClientData\fR typically points to an application-specific data structure that describes what to do when \fIproc\fR is invoked. \fIName1\fR and \fIname2\fR give the name of the traced variable in the normal two-part form (see the description of \fBTcl_TraceVar2\fR below for details). @@ -310,11 +310,11 @@ error occurred. The return value must be a pointer to a static character string containing an error message, unless (\fIexactly\fR one of) the \fBTCL_TRACE_RESULT_DYNAMIC\fR and \fBTCL_TRACE_RESULT_OBJECT\fR flags is set, which specify that the result is -either a dynamic string (to be released with \fBTcl_Free\fR) or a +either a dynamic string (to be released with \fBckfree\fR) or a Tcl_Obj* (cast to char* and to be released with \fBTcl_DecrRefCount\fR) containing the error message. If a trace procedure returns an error, no further traces are invoked for the access and the traced access aborts with the given message. Index: doc/UniCharIsAlpha.3 ================================================================== --- doc/UniCharIsAlpha.3 +++ doc/UniCharIsAlpha.3 @@ -46,11 +46,11 @@ int \fBTcl_UniCharIsWordChar\fR(\fIch\fR) .SH ARGUMENTS .AS int ch .AP int ch in -The Unicode character to be examined. +The Tcl_UniChar to be examined. .BE .SH DESCRIPTION .PP All of the routines described examine Unicode characters and return a Index: doc/Utf.3 ================================================================== --- doc/Utf.3 +++ doc/Utf.3 @@ -29,23 +29,23 @@ .sp int \fBTcl_UniCharLen\fR(\fIuniStr\fR) .sp int -\fBTcl_UniCharNcmp\fR(\fIucs, uct, uniLength\fR) +\fBTcl_UniCharNcmp\fR(\fIucs, uct, numChars\fR) .sp int -\fBTcl_UniCharNcasecmp\fR(\fIucs, uct, uniLength\fR) +\fBTcl_UniCharNcasecmp\fR(\fIucs, uct, numChars\fR) .sp int \fBTcl_UniCharCaseMatch\fR(\fIuniStr, uniPattern, nocase\fR) .sp int -\fBTcl_UtfNcmp\fR(\fIcs, ct, length\fR) +\fBTcl_UtfNcmp\fR(\fIcs, ct, numChars\fR) .sp int -\fBTcl_UtfNcasecmp\fR(\fIcs, ct, length\fR) +\fBTcl_UtfNcasecmp\fR(\fIcs, ct, numChars\fR) .sp int \fBTcl_UtfCharComplete\fR(\fIsrc, length\fR) .sp int @@ -61,17 +61,17 @@ \fBTcl_UtfNext\fR(\fIsrc\fR) .sp const char * \fBTcl_UtfPrev\fR(\fIsrc, start\fR) .sp -int +Tcl_UniChar \fBTcl_UniCharAtIndex\fR(\fIsrc, index\fR) .sp const char * \fBTcl_UtfAtIndex\fR(\fIsrc, index\fR) .sp -size_t +int \fBTcl_UtfBackslash\fR(\fIsrc, readPtr, dst\fR) .SH ARGUMENTS .AS "const Tcl_UniChar" *uniPattern in/out .AP char *buf out Buffer in which the UTF-8 representation of the Tcl_UniChar is stored. At most @@ -92,20 +92,23 @@ A null-terminated Unicode string. .AP "const Tcl_UniChar" *uct in A null-terminated Unicode string. .AP "const Tcl_UniChar" *uniPattern in A null-terminated Unicode string. -.AP size_t length in +.AP int length in The length of the UTF-8 string in bytes (not UTF-8 characters). If -TCL_AUTO_LENGTH, all bytes up to the first null byte are used. -.AP size_t uniLength in -The length of the Unicode string in characters. +negative, all bytes up to the first null byte are used. +.AP int uniLength in +The length of the Unicode string in characters. Must be greater than or +equal to 0. .AP "Tcl_DString" *dsPtr in/out A pointer to a previously initialized \fBTcl_DString\fR. +.AP "unsigned long" numChars in +The number of characters to compare. .AP "const char" *start in Pointer to the beginning of a UTF-8 string. -.AP size_t index in +.AP int index in The index of a character (not byte) in the UTF-8 string. .AP int *readPtr out If non-NULL, filled with the number of bytes in the backslash sequence, including the backslash character. .AP char *dst out @@ -116,39 +119,32 @@ case-insensitive (1). .BE .SH DESCRIPTION .PP -These routines convert between UTF-8 strings and Unicode characters. An -Unicode character represented as an unsigned, fixed-size +These routines convert between UTF-8 strings and Tcl_UniChars. A +Tcl_UniChar is a Unicode character represented as an unsigned, fixed-size quantity. A UTF-8 character is a Unicode character represented as a varying-length sequence of up to \fBTCL_UTF_MAX\fR bytes. A multibyte UTF-8 sequence consists of a lead byte followed by some number of trail bytes. .PP \fBTCL_UTF_MAX\fR is the maximum number of bytes that it takes to represent one Unicode character in the UTF-8 representation. .PP -\fBTcl_UniCharToUtf\fR stores the character \fIch\fR as a UTF-8 string +\fBTcl_UniCharToUtf\fR stores the Tcl_UniChar \fIch\fR as a UTF-8 string in starting at \fIbuf\fR. The return value is the number of bytes stored -in \fIbuf\fR. If ch is a high surrogate (range U+D800 - U+DBFF), then -the return value will be 1 and a single byte in the range 0xF0 - 0xF4 -will be stored. If you still want to produce UTF-8 output for it (even -though knowing it's an illegal code-point on its own), just call -\fBTcl_UniCharToUtf\fR again specifying ch = -1. +in \fIbuf\fR. .PP \fBTcl_UtfToUniChar\fR reads one UTF-8 character starting at \fIsrc\fR and stores it as a Tcl_UniChar in \fI*chPtr\fR. The return value is the number of bytes read from \fIsrc\fR. The caller must ensure that the source buffer is long enough such that this routine does not run off the end and dereference non-existent or random memory; if the source buffer is known to be null-terminated, this will not happen. If the input is -a byte in the range 0x80 - 0x9F, \fBTcl_UtfToUniChar\fR assumes the -cp1252 encoding, stores the corresponding Tcl_UniChar in \fI*chPtr\fR -and returns 1. If the input is otherwise not in proper UTF-8 format, \fBTcl_UtfToUniChar\fR will store the first -byte of \fIsrc\fR in \fI*chPtr\fR as a Tcl_UniChar between 0x0000 and -0x00ff and return 1. +byte of \fIsrc\fR in \fI*chPtr\fR as a Tcl_UniChar between 0x0080 and +0x00FF and return 1. .PP \fBTcl_UniCharToUtfDString\fR converts the given Unicode string to UTF-8, storing the result in a previously initialized \fBTcl_DString\fR. You must specify \fIuniLength\fR, the length of the given Unicode string. The return value is a pointer to the UTF-8 representation of the @@ -171,11 +167,11 @@ the number of Unicode characters (not bytes) in that string. .PP \fBTcl_UniCharNcmp\fR and \fBTcl_UniCharNcasecmp\fR correspond to \fBstrncmp\fR and \fBstrncasecmp\fR, respectively, for Unicode characters. They accept two null-terminated Unicode strings and the number of characters -to compare. Both strings are assumed to be at least \fIuniLength\fR characters +to compare. Both strings are assumed to be at least \fInumChars\fR characters long. \fBTcl_UniCharNcmp\fR compares the two strings character-by-character according to the Unicode character ordering. It returns an integer greater than, equal to, or less than 0 if the first string is greater than, equal to, or less than the second string respectively. \fBTcl_UniCharNcasecmp\fR is the Unicode case insensitive version. @@ -185,11 +181,11 @@ a Unicode pattern, and a boolean value specifying whether the match should be case sensitive and returns whether the string matches the pattern. .PP \fBTcl_UtfNcmp\fR corresponds to \fBstrncmp\fR for UTF-8 strings. It accepts two null-terminated UTF-8 strings and the number of characters -to compare. (Both strings are assumed to be at least \fIlength\fR +to compare. (Both strings are assumed to be at least \fInumChars\fR characters long.) \fBTcl_UtfNcmp\fR compares the two strings character-by-character according to the Unicode character ordering. It returns an integer greater than, equal to, or less than 0 if the first string is greater than, equal to, or less than the second string respectively. @@ -202,51 +198,65 @@ \fBTcl_UtfCharComplete\fR returns 1 if the source UTF-8 string \fIsrc\fR of \fIlength\fR bytes is long enough to be decoded by \fBTcl_UtfToUniChar\fR, or 0 otherwise. This function does not guarantee that the UTF-8 string is properly formed. This routine is used by procedures that are operating on a byte at a time and need to know if a -full Unicode character has been seen. +full Tcl_UniChar has been seen. .PP \fBTcl_NumUtfChars\fR corresponds to \fBstrlen\fR for UTF-8 strings. It returns the number of Tcl_UniChars that are represented by the UTF-8 string \fIsrc\fR. The length of the source string is \fIlength\fR bytes. If the length is negative, all bytes up to the first null byte are used. .PP \fBTcl_UtfFindFirst\fR corresponds to \fBstrchr\fR for UTF-8 strings. It -returns a pointer to the first occurrence of the Unicode character \fIch\fR +returns a pointer to the first occurrence of the Tcl_UniChar \fIch\fR in the null-terminated UTF-8 string \fIsrc\fR. The null terminator is considered part of the UTF-8 string. .PP \fBTcl_UtfFindLast\fR corresponds to \fBstrrchr\fR for UTF-8 strings. It -returns a pointer to the last occurrence of the Unicode character \fIch\fR +returns a pointer to the last occurrence of the Tcl_UniChar \fIch\fR in the null-terminated UTF-8 string \fIsrc\fR. The null terminator is considered part of the UTF-8 string. .PP Given \fIsrc\fR, a pointer to some location in a UTF-8 string, \fBTcl_UtfNext\fR returns a pointer to the next UTF-8 character in the string. The caller must not ask for the next character after the last character in the string if the string is not terminated by a null character. .PP -Given \fIsrc\fR, a pointer to some location in a UTF-8 string (or to a -null byte immediately following such a string), \fBTcl_UtfPrev\fR -returns a pointer to the closest preceding byte that starts a UTF-8 -character. -This function will not back up to a position before \fIstart\fR, -the start of the UTF-8 string. If \fIsrc\fR was already at \fIstart\fR, the -return value will be \fIstart\fR. +\fBTcl_UtfPrev\fR is used to step backward through but not beyond the +UTF-8 string that begins at \fIstart\fR. If the UTF-8 string is made +up entirely of complete and well-formed characters, and \fIsrc\fR points +to the lead byte of one of those characters (or to the location one byte +past the end of the string), then repeated calls of \fBTcl_UtfPrev\fR will +return pointers to the lead bytes of each character in the string, one +character at a time, terminating when it returns \fIstart\fR. +.PP +When the conditions of completeness and well-formedness may not be satisfied, +a more precise description of the function of \fBTcl_UtfPrev\fR is necessary. +It always returns a pointer greater than or equal to \fIstart\fR; that is, +always a pointer to a location in the string. It always returns a pointer to +a byte that begins a character when scanning for characters beginning +from \fIstart\fR. When \fIsrc\fR is greater than \fIstart\fR, it +always returns a pointer less than \fIsrc\fR and greater than or +equal to (\fIsrc\fR - \fBTCL_UTF_MAX\fR). The character that begins +at the returned pointer is the first one that either includes the +byte \fIsrc[-1]\fR, or might include it if the right trail bytes are +present at \fIsrc\fR and greater. \fBTcl_UtfPrev\fR never reads the +byte \fIsrc[0]\fR nor the byte \fIstart[-1]\fR nor the byte +\fIsrc[-\fBTCL_UTF_MAX\fI-1]\fR. .PP \fBTcl_UniCharAtIndex\fR corresponds to a C string array dereference or the Pascal Ord() function. It returns the Tcl_UniChar represented at the specified character (not byte) \fIindex\fR in the UTF-8 string \fIsrc\fR. The source string must contain at least \fIindex\fR -characters. +characters. Behavior is undefined if a negative \fIindex\fR is given. .PP \fBTcl_UtfAtIndex\fR returns a pointer to the specified character (not byte) \fIindex\fR in the UTF-8 string \fIsrc\fR. The source string must contain at least \fIindex\fR characters. This is equivalent to calling -\fBTcl_UtfNext\fR \fIindex\fR times. If \fIindex\fR is TCL_INDEX_NONE, +\fBTcl_UtfToUniChar\fR \fIindex\fR times. If a negative \fIindex\fR is given, the return pointer points to the first character in the source string. .PP \fBTcl_UtfBackslash\fR is a utility procedure used by several of the Tcl commands. It parses a backslash sequence and stores the properly formed UTF-8 character represented by the backslash sequence in the output DELETED doc/abstract.n Index: doc/abstract.n ================================================================== --- doc/abstract.n +++ /dev/null @@ -1,77 +0,0 @@ -'\" -'\" Copyright (c) 2018 Donal K. Fellows -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH abstract n 0.3 TclOO "TclOO Commands" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -oo::abstract \- a class that does not allow direct instances of itself -.SH SYNOPSIS -.nf -package require TclOO - -\fBoo::abstract\fI method \fR?\fIarg ...\fR? -.fi -.SH "CLASS HIERARCHY" -.nf -\fBoo::object\fR - \(-> \fBoo::class\fR - \(-> \fBoo::abstract\fR -.fi -.BE -.SH DESCRIPTION -Abstract classes are classes that can contain definitions, but which cannot be -directly manufactured; they are intended to only ever be inherited from and -instantiated indirectly. The characteristic methods of \fBoo::class\fR -(\fBcreate\fR and \fBnew\fR) are not exported by an instance of -\fBoo::abstract\fR. -.PP -Note that \fBoo::abstract\fR is not itself an instance of \fBoo::abstract\fR. -.SS CONSTRUCTOR -The \fBoo::abstract\fR class does not define an explicit constructor; this -means that it is effectively the same as the constructor of the -\fBoo::class\fR class. -.SS DESTRUCTOR -The \fBoo::abstract\fR class does not define an explicit destructor; -destroying an instance of it is just like destroying an ordinary class (and -will destroy all its subclasses). -.SS "EXPORTED METHODS" -The \fBoo::abstract\fR class defines no new exported methods. -.SS "NON-EXPORTED METHODS" -The \fBoo::abstract\fR class explicitly states that \fBcreate\fR, -\fBcreateWithNamespace\fR, and \fBnew\fR are unexported. -.SH EXAMPLES -.PP -This example defines a simple class hierarchy and creates a new instance of -it. It then invokes a method of the object before destroying the hierarchy and -showing that the destruction is transitive. -.PP -.CS -\fBoo::abstract\fR create fruit { - method eat {} { - puts "yummy!" - } -} -oo::class create banana { - superclass fruit - method peel {} { - puts "skin now off" - } -} -set b [banana \fBnew\fR] -$b peel \fI\(-> prints 'skin now off'\fR -$b eat \fI\(-> prints 'yummy!'\fR -set f [fruit new] \fI\(-> error 'unknown method "new"...'\fR -.CE -.SH "SEE ALSO" -oo::define(n), oo::object(n) -.SH KEYWORDS -abstract class, class, metaclass, object -.\" Local variables: -.\" mode: nroff -.\" fill-column: 78 -.\" End: Index: doc/append.n ================================================================== --- doc/append.n +++ doc/append.n @@ -18,15 +18,10 @@ .PP Append all of the \fIvalue\fR arguments to the current value of variable \fIvarName\fR. If \fIvarName\fR does not exist, it is given a value equal to the concatenation of all the \fIvalue\fR arguments. -.VS TIP508 -If \fIvarName\fR indicate an element that does not exist of an array that has -a default value set, the concatenation of the default value and all the -\fIvalue\fR arguments will be stored in the array element. -.VE TIP508 The result of this command is the new value stored in variable \fIvarName\fR. This command provides an efficient way to build up long variables incrementally. For example, @@ -47,9 +42,8 @@ .CE .SH "SEE ALSO" concat(n), lappend(n) .SH KEYWORDS append, variable -.\" Local variables: -.\" mode: nroff -.\" fill-column: 78 -.\" End: +'\" Local Variables: +'\" mode: nroff +'\" End: Index: doc/array.n ================================================================== --- doc/array.n +++ doc/array.n @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.TH array n 8.7 Tcl "Tcl Built-In Commands" +.TH array n 8.3 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME array \- Manipulate array variables @@ -33,57 +33,10 @@ invocation of \fBarray startsearch\fR. This option is particularly useful if an array has an element with an empty name, since the return value from \fBarray nextelement\fR will not indicate whether the search has been completed. -.TP -\fBarray default \fIsubcommand arrayName args...\fR -.VS TIP508 -Manages the default value of the array. Arrays initially have no default -value, but this command allows you to set one; the default value will be -returned when reading from an element of the array \fIarrayName\fR if the read -would otherwise result in an error. Note that this may cause the \fBappend\fR, -\fBdict\fR, \fBincr\fR and \fBlappend\fR commands to change their behavior in -relation to non-existing array elements. -.RS -.PP -The \fIsubcommand\fR argument controls what exact operation will be performed -on the default value of \fIarrayName\fR. Supported \fIsubcommand\fRs are: -.VE TIP508 -.TP -\fBarray default exists \fIarrayName\fR -.VS TIP508 -This returns a boolean value indicating whether a default value has been set -for the array \fIarrayName\fR. Returns a false value if \fIarrayName\fR does -not exist. Raises an error if \fIarrayName\fR is an existing variable that is -not an array. -.VE TIP508 -.TP -\fBarray default get \fIarrayName\fR -.VS TIP508 -This returns the current default value for the array \fIarrayName\fR. Raises -an error if \fIarrayName\fR is an existing variable that is not an array, or -if \fIarrayName\fR is an array without a default value. -.VE TIP508 -.TP -\fBarray default set \fIarrayName value\fR -.VS TIP508 -This sets the default value for the array \fIarrayName\fR to \fIvalue\fR. -Returns the empty string. Raises an error if \fIarrayName\fR is an existing -variable that is not an array, or if \fIarrayName\fR is an illegal name for an -array. If \fIarrayName\fR does not currently exist, it is created as an empty -array as well as having its default value set. -.VE TIP508 -.TP -\fBarray default unset \fIarrayName\fR -.VS TIP508 -This removes the default value for the array \fIarrayName\fR and returns the -empty string. Does nothing if \fIarrayName\fR does not have a default -value. Raises an error if \fIarrayName\fR is an existing variable that is not -an array. -.VE TIP508 -.RE .TP \fBarray donesearch \fIarrayName searchId\fR This command terminates an array search and destroys all the state associated with that search. \fISearchId\fR indicates which search on \fIarrayName\fR to destroy, and must have @@ -92,19 +45,10 @@ .TP \fBarray exists \fIarrayName\fR Returns 1 if \fIarrayName\fR is an array variable, 0 if there is no variable by that name or if it is a scalar variable. .TP -\fBarray for {\fIkeyVariable valueVariable\fB} \fIarrayName body\fP -The first argument is a two element list of variable names for the -key and value of each entry in the array. The second argument is the -array name to iterate over. The third argument is the body to execute -for each key and value returned. -The ordering of the returned keys is undefined. -If an array element is deleted or a new array element is inserted during -the \fIarray for\fP process, the command will terminate with an error. -.TP \fBarray get \fIarrayName\fR ?\fIpattern\fR? Returns a list containing pairs of elements. The first element in each pair is the name of an element in \fIarrayName\fR and the second element of each pair is the value of the array element. The order of the pairs is undefined. @@ -239,9 +183,5 @@ .CE .SH "SEE ALSO" list(n), string(n), variable(n), trace(n), foreach(n) .SH KEYWORDS array, element names, search -.\" Local variables: -.\" mode: nroff -.\" fill-column: 78 -.\" End: Index: doc/binary.n ================================================================== --- doc/binary.n +++ doc/binary.n @@ -10,14 +10,16 @@ .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME binary \- Insert and extract fields from binary strings .SH SYNOPSIS +.VS 8.6 \fBbinary decode \fIformat\fR ?\fI\-option value ...\fR? \fIdata\fR .br \fBbinary encode \fIformat\fR ?\fI\-option value ...\fR? \fIdata\fR .br +.VE 8.6 \fBbinary format \fIformatString \fR?\fIarg arg ...\fR? .br \fBbinary scan \fIstring formatString \fR?\fIvarName varName ...\fR? .BE .SH DESCRIPTION @@ -27,21 +29,24 @@ Tcl values. For example, given the values 16 and 22, on a 32-bit architecture, it might produce an 8-byte binary string consisting of two 4-byte integers, one for each of the numbers. The subcommand \fBbinary scan\fR, does the opposite: it extracts data from a binary string and returns it as ordinary Tcl string values. +.VS 8.6 The \fBbinary encode\fR and \fBbinary decode\fR subcommands convert binary data to or from string encodings such as base64 (used in MIME messages for example). +.VE 8.6 .PP Note that other operations on binary data, such as taking a subsequence of it, getting its length, or reinterpreting it as a string in some encoding, are done by other Tcl commands (respectively \fBstring range\fR, \fBstring length\fR and \fBencoding convertfrom\fR in the example cases). A binary string in Tcl is merely one where all the characters it contains are in the range \eu0000\-\eu00FF. .SH "BINARY ENCODE AND DECODE" +.VS 8.6 .PP When encoding binary data as a readable string, the starting binary data is passed to the \fBbinary encode\fR command, together with the name of the encoding to use and any encoding-specific options desired. Data which has been encoded can be converted back to binary form using \fBbinary decode\fR. The @@ -71,11 +76,13 @@ .PP During decoding, the following options are supported: .TP \fB\-strict\fR . -Instructs the decoder to throw an error if it encounters whitespace characters. Otherwise it ignores them. +Instructs the decoder to throw an error if it encounters any characters +that are not strictly part of the encoding itself. Otherwise it ignores them. +RFC 2045 calls for base64 decoders to be non-strict. .RE .TP \fBhex\fR . The \fBhex\fR binary encoding converts each byte to a pair of hexadecimal @@ -85,11 +92,12 @@ No options are supported during encoding. During decoding, the following options are supported: .TP \fB\-strict\fR . -Instructs the decoder to throw an error if it encounters whitespace characters. Otherwise it ignores them. +Instructs the decoder to throw an error if it encounters whitespace characters. +Otherwise it ignores them. .RE .TP \fBuuencode\fR . The \fBuuencode\fR binary encoding used to be common for transfer of data @@ -100,31 +108,36 @@ During encoding, the following options are supported (though changing them may produce files that other implementations of decoders cannot process): .TP \fB\-maxlen \fIlength\fR . -Indicates that the output should be split into lines of no more than -\fIlength\fR characters. By default, lines are split every 61 characters, and -this must be in the range 3 to 85 due to limitations in the encoding. +Indicates the maximum number of characters to produce for each encoded line. +The valid range is 5 to 85. Line lengths outside that range cannot be +accommodated by the encoding format. The default value is 61. .TP \fB\-wrapchar \fIcharacter\fR . -Indicates that, when lines are split because of the \fB\-maxlen\fR option, -\fIcharacter\fR should be used to separate lines. By default, this is a -newline character, -.QW \en . +Indicates the character(s) to use to mark the end of each encoded line. +Acceptable values are a sequence of zero or more characters from the +set { \\x09 (TAB), \\x0B (VT), \\x0C (FF), \\x0D (CR) } followed +by zero or one newline \\x0A (LF). Any other values are rejected because +they would generate encoded text that could not be decoded. The default value +is a single newline. .PP During decoding, the following options are supported: .TP \fB\-strict\fR . -Instructs the decoder to throw an error if it encounters unexpected whitespace -characters. Otherwise it ignores them. +Instructs the decoder to throw an error if it encounters anything +outside of the standard encoding format. Without this option, the +decoder tolerates some deviations, mostly to forgive reflows of lines +between the encoder and decoder. .PP Note that neither the encoder nor the decoder handle the header and footer of the uuencode format. .RE +.VE 8.6 .SH "BINARY FORMAT" .PP The \fBbinary format\fR command generates a binary string whose layout is specified by the \fIformatString\fR and whose contents come from the additional arguments. The resulting binary value is returned. @@ -135,21 +148,18 @@ by an optional numeric \fIcount\fR. Most field specifiers consume one argument to obtain the value to be formatted. The type character specifies how the value is to be formatted. The \fIcount\fR typically indicates how many items of the specified type are taken from the value. If present, the \fIcount\fR -is a non-negative decimal integer or -.QW \fB*\fR , -which normally indicates +is a non-negative decimal integer or \fB*\fR, which normally indicates that all of the items in the value are to be used. If the number of arguments does not match the number of fields in the format string that consume arguments, then an error is generated. The flag character is ignored for \fBbinary format\fR. .PP Here is a small example to clarify the relation between the field specifiers and the arguments: -.PP .CS \fBbinary format\fR d3d {1.0 2.0 3.0 4.0} 0.1 .CE .PP The first argument is a list of four numbers, but because of the count @@ -173,232 +183,145 @@ if this truncation is not desired (i.e. if the characters are not part of the ISO 8859\-1 character set.) If \fIarg\fR has fewer than \fIcount\fR bytes, then additional zero bytes are used to pad out the field. If \fIarg\fR is longer than the specified length, the extra characters will be ignored. If -\fIcount\fR is -.QW \fB*\fR , -then all of the bytes in \fIarg\fR will be +\fIcount\fR is \fB*\fR, then all of the bytes in \fIarg\fR will be formatted. If \fIcount\fR is omitted, then one character will be -formatted. For example, the command: +formatted. For example, .RS -.PP .CS \fBbinary format\fR a7a*a alpha bravo charlie .CE -.PP -will return a binary string equivalent to: -.PP -.CS -\fBalpha\e000\e000bravoc\fR -.CE -.PP -the command: -.PP +will return a string equivalent to \fBalpha\e000\e000bravoc\fR, .CS \fBbinary format\fR a* [encoding convertto utf-8 \eu20ac] .CE -.PP -will return a binary string equivalent to: -.PP -.CS -\fB\e342\e202\e254\fR -.CE -.PP -(which is the -UTF-8 byte sequence for a Euro-currency character), and the command: -.PP +will return a string equivalent to \fB\e342\e202\e254\fR (which is the +UTF-8 byte sequence for a Euro-currency character) and .CS \fBbinary format\fR a* [encoding convertto iso8859-15 \eu20ac] .CE -.PP -will return a binary string equivalent to: -.PP -.CS -\fB\e244\fR -.CE -.PP -(which is the ISO +will return a string equivalent to \fB\e244\fR (which is the ISO 8859\-15 byte sequence for a Euro-currency character). Contrast these last two with: -.PP .CS \fBbinary format\fR a* \eu20ac .CE -.PP -which returns a binary string equivalent to: -.PP -.CS -\fB\e254\fR -.CE -.PP -(i.e. \fB\exac\fR) by +which returns a string equivalent to \fB\e254\fR (i.e. \fB\exac\fR) by truncating the high-bits of the character, and which is probably not what is desired. .RE .IP \fBA\fR 5 This form is the same as \fBa\fR except that spaces are used for padding instead of nulls. For example, .RS -.PP .CS \fBbinary format\fR A6A*A alpha bravo charlie .CE -.PP -will return -.PP -.CS -\fBalpha bravoc\fR -.CE +will return \fBalpha bravoc\fR. .RE .IP \fBb\fR 5 Stores a string of \fIcount\fR binary digits in low-to-high order -within each byte in the output binary string. \fIArg\fR must contain a +within each byte in the output string. \fIArg\fR must contain a sequence of \fB1\fR and \fB0\fR characters. The resulting bytes are emitted in first to last order with the bits being formatted in low-to-high order within each byte. If \fIarg\fR has fewer than \fIcount\fR digits, then zeros will be used for the remaining bits. If \fIarg\fR has more than the specified number of digits, the extra -digits will be ignored. If \fIcount\fR is -.QW \fB*\fR , -then all of the +digits will be ignored. If \fIcount\fR is \fB*\fR, then all of the digits in \fIarg\fR will be formatted. If \fIcount\fR is omitted, then one digit will be formatted. If the number of bits formatted does not end at a byte boundary, the remaining bits of the last byte will be zeros. For example, .RS -.PP .CS \fBbinary format\fR b5b* 11100 111000011010 .CE -.PP -will return a binary string equivalent to: -.PP -.CS -\fB\ex07\ex87\ex05\fR -.CE +will return a string equivalent to \fB\ex07\ex87\ex05\fR. .RE .IP \fBB\fR 5 This form is the same as \fBb\fR except that the bits are stored in high-to-low order within each byte. For example, .RS -.PP .CS \fBbinary format\fR B5B* 11100 111000011010 .CE -.PP -will return a binary string equivalent to: -.PP -.CS -\fB\exe0\exe1\exa0\fR -.CE +will return a string equivalent to \fB\exe0\exe1\exa0\fR. .RE .IP \fBH\fR 5 Stores a string of \fIcount\fR hexadecimal digits in high-to-low -within each byte in the output binary string. \fIArg\fR must contain a +within each byte in the output string. \fIArg\fR must contain a sequence of characters in the set .QW 0123456789abcdefABCDEF . The resulting bytes are emitted in first to last order with the hex digits being formatted in high-to-low order within each byte. If \fIarg\fR has fewer than \fIcount\fR digits, then zeros will be used for the remaining digits. If \fIarg\fR has more than the specified number of digits, the extra digits will be ignored. If \fIcount\fR is -.QW \fB*\fR , -then all of the digits in \fIarg\fR will be formatted. If +\fB*\fR, then all of the digits in \fIarg\fR will be formatted. If \fIcount\fR is omitted, then one digit will be formatted. If the number of digits formatted does not end at a byte boundary, the remaining bits of the last byte will be zeros. For example, .RS -.PP .CS \fBbinary format\fR H3H*H2 ab DEF 987 .CE -.PP -will return a binary string equivalent to: -.PP -.CS -\fB\exab\ex00\exde\exf0\ex98\fR -.CE +will return a string equivalent to \fB\exab\ex00\exde\exf0\ex98\fR. .RE .IP \fBh\fR 5 This form is the same as \fBH\fR except that the digits are stored in low-to-high order within each byte. This is seldom required. For example, .RS -.PP .CS \fBbinary format\fR h3h*h2 AB def 987 .CE -.PP -will return a binary string equivalent to: -.PP -.CS -\fB\exba\ex00\exed\ex0f\ex89\fR -.CE +will return a string equivalent to \fB\exba\ex00\exed\ex0f\ex89\fR. .RE .IP \fBc\fR 5 Stores one or more 8-bit integer values in the output string. If no \fIcount\fR is specified, then \fIarg\fR must consist of an integer value. If \fIcount\fR is specified, \fIarg\fR must consist of a list containing at least that many integers. The low-order 8 bits of each integer -are stored as a one-byte value at the cursor position. If \fIcount\fR is -.QW \fB*\fR , -then all of the integers in the list are formatted. If the +are stored as a one-byte value at the cursor position. If \fIcount\fR +is \fB*\fR, then all of the integers in the list are formatted. If the number of elements in the list is greater than \fIcount\fR, then the extra elements are ignored. For example, .RS -.PP .CS \fBbinary format\fR c3cc* {3 -3 128 1} 260 {2 5} .CE -.PP -will return a binary string equivalent to: -.PP -.CS -\fB\ex03\exfd\ex80\ex04\ex02\ex05\fR -.CE -.PP -whereas: -.PP +will return a string equivalent to +\fB\ex03\exfd\ex80\ex04\ex02\ex05\fR, whereas .CS \fBbinary format\fR c {2 5} .CE -.PP will generate an error. .RE .IP \fBs\fR 5 This form is the same as \fBc\fR except that it stores one or more 16-bit integers in little-endian byte order in the output string. The low-order 16-bits of each integer are stored as a two-byte value at the cursor position with the least significant byte stored first. For example, .RS -.PP .CS \fBbinary format\fR s3 {3 -3 258 1} .CE -.PP -will return a binary string equivalent to: -.PP -.CS -\fB\ex03\ex00\exfd\exff\ex02\ex01\fR -.CE +will return a string equivalent to +\fB\ex03\ex00\exfd\exff\ex02\ex01\fR. .RE .IP \fBS\fR 5 This form is the same as \fBs\fR except that it stores one or more 16-bit integers in big-endian byte order in the output string. For example, .RS -.PP .CS \fBbinary format\fR S3 {3 -3 258 1} .CE -.PP -will return a binary string equivalent to: -.PP -.CS -\fB\ex00\ex03\exff\exfd\ex01\ex02\fR -.CE +will return a string equivalent to +\fB\ex00\ex03\exff\exfd\ex01\ex02\fR. .RE .IP \fBt\fR 5 This form (mnemonically \fItiny\fR) is the same as \fBs\fR and \fBS\fR except that it stores the 16-bit integers in the output string in the native byte order of the machine where the Tcl script is running. @@ -409,36 +332,26 @@ 32-bit integers in little-endian byte order in the output string. The low-order 32-bits of each integer are stored as a four-byte value at the cursor position with the least significant byte stored first. For example, .RS -.PP .CS \fBbinary format\fR i3 {3 -3 65536 1} .CE -.PP -will return a binary string equivalent to: -.PP -.CS +will return a string equivalent to \fB\ex03\ex00\ex00\ex00\exfd\exff\exff\exff\ex00\ex00\ex01\ex00\fR -.CE .RE .IP \fBI\fR 5 This form is the same as \fBi\fR except that it stores one or more one or more 32-bit integers in big-endian byte order in the output string. For example, .RS -.PP .CS \fBbinary format\fR I3 {3 -3 65536 1} .CE -.PP -will return a binary string equivalent to: -.PP -.CS +will return a string equivalent to \fB\ex00\ex00\ex00\ex03\exff\exff\exff\exfd\ex00\ex01\ex00\ex00\fR -.CE .RE .IP \fBn\fR 5 This form (mnemonically \fInumber\fR or \fInormal\fR) is the same as \fBi\fR and \fBI\fR except that it stores the 32-bit integers in the output string in the native byte order of the machine where the Tcl @@ -450,28 +363,24 @@ 64-bit integers in little-endian byte order in the output string. The low-order 64-bits of each integer are stored as an eight-byte value at the cursor position with the least significant byte stored first. For example, .RS -.PP .CS \fBbinary format\fR w 7810179016327718216 .CE -.PP -will return the binary string \fBHelloTcl\fR. +will return the string \fBHelloTcl\fR .RE .IP \fBW\fR 5 This form is the same as \fBw\fR except that it stores one or more one or more 64-bit integers in big-endian byte order in the output string. For example, .RS -.PP .CS \fBbinary format\fR Wc 4785469626960341345 110 .CE -.PP -will return the binary string \fBBigEndian\fR +will return the string \fBBigEndian\fR .RE .IP \fBm\fR 5 This form (mnemonically the mirror of \fBw\fR) is the same as \fBw\fR and \fBW\fR except that it stores the 64-bit integers in the output string in the native byte order of the machine where the Tcl script is @@ -490,20 +399,15 @@ as defined by the system will be used instead. Because Tcl uses double-precision floating point numbers internally, there may be some loss of precision in the conversion to single-precision. For example, on a Windows system running on an Intel Pentium processor, .RS -.PP .CS \fBbinary format\fR f2 {1.6 3.4} .CE -.PP -will return a binary string equivalent to: -.PP -.CS -\fB\excd\excc\excc\ex3f\ex9a\ex99\ex59\ex40\fR -.CE +will return a string equivalent to +\fB\excd\excc\excc\ex3f\ex9a\ex99\ex59\ex40\fR. .RE .IP \fBr\fR 5 This form (mnemonically \fIreal\fR) is the same as \fBf\fR except that it stores the single-precision floating point numbers in little-endian order. This conversion only produces meaningful output when used on @@ -516,20 +420,15 @@ This form is the same as \fBf\fR except that it stores one or more one or more double-precision floating point numbers in the machine's native representation in the output string. For example, on a Windows system running on an Intel Pentium processor, .RS -.PP .CS \fBbinary format\fR d1 {1.6} .CE -.PP -will return a binary string equivalent to: -.PP -.CS -\fB\ex9a\ex99\ex99\ex99\ex99\ex99\exf9\ex3f\fR -.CE +will return a string equivalent to +\fB\ex9a\ex99\ex99\ex99\ex99\ex99\exf9\ex3f\fR. .RE .IP \fBq\fR 5 This form (mnemonically the mirror of \fBd\fR) is the same as \fBd\fR except that it stores the double-precision floating point numbers in little-endian order. This conversion only produces meaningful output @@ -538,65 +437,46 @@ .IP \fBQ\fR 5 This form is the same as \fBq\fR except that it stores the double-precision floating point numbers in big-endian order. .IP \fBx\fR 5 Stores \fIcount\fR null bytes in the output string. If \fIcount\fR is -not specified, stores one null byte. If \fIcount\fR is -.QW \fB*\fR , +not specified, stores one null byte. If \fIcount\fR is \fB*\fR, generates an error. This type does not consume an argument. For example, .RS -.PP .CS \fBbinary format\fR a3xa3x2a3 abc def ghi .CE -.PP -will return a binary string equivalent to: -.PP -.CS -\fBabc\e000def\e000\e000ghi\fR -.CE +will return a string equivalent to \fBabc\e000def\e000\e000ghi\fR. .RE .IP \fBX\fR 5 Moves the cursor back \fIcount\fR bytes in the output string. If -\fIcount\fR is -.QW \fB*\fR -or is larger than the current cursor position, +\fIcount\fR is \fB*\fR or is larger than the current cursor position, then the cursor is positioned at location 0 so that the next byte stored will be the first byte in the result string. If \fIcount\fR is omitted then the cursor is moved back one byte. This type does not consume an argument. For example, .RS -.PP .CS \fBbinary format\fR a3X*a3X2a3 abc def ghi .CE -.PP will return \fBdghi\fR. .RE .IP \fB@\fR 5 Moves the cursor to the absolute location in the output string specified by \fIcount\fR. Position 0 refers to the first byte in the output string. If \fIcount\fR refers to a position beyond the last byte stored so far, then null bytes will be placed in the uninitialized locations and the cursor will be placed at the specified location. If -\fIcount\fR is -.QW \fB*\fR , -then the cursor is moved to the current end of +\fIcount\fR is \fB*\fR, then the cursor is moved to the current end of the output string. If \fIcount\fR is omitted, then an error will be generated. This type does not consume an argument. For example, .RS -.PP .CS \fBbinary format\fR a5@2a1@*a3@10a1 abcde f ghi j .CE -.PP -will return -.PP -.CS -\fBabfdeghi\e000\e000j\fR -.CE +will return \fBabfdeghi\e000\e000j\fR. .RE .SH "BINARY SCAN" .PP The \fBbinary scan\fR command parses fields from a binary string, returning the number of conversions performed. \fIString\fR gives the @@ -614,13 +494,12 @@ Most field specifiers consume one argument to obtain the variable into which the scanned values should be placed. The type character specifies how the binary data is to be interpreted. The \fIcount\fR typically indicates how many items of the specified type are taken from the data. If present, the -\fIcount\fR is a non-negative decimal integer or -.QW \fB*\fR , -which normally indicates that all of the remaining items in the data are to +\fIcount\fR is a non-negative decimal integer or \fB*\fR, which +normally indicates that all of the remaining items in the data are to be used. If there are not enough bytes left after the current cursor position to satisfy the current field specifier, then the corresponding variable is left untouched and \fBbinary scan\fR returns immediately with the number of variables that were set. If there are not enough arguments for all of the fields in the format string that @@ -630,11 +509,10 @@ is accepted for all field types but is ignored for non-integer fields. .PP A similar example as with \fBbinary format\fR should explain the relation between field specifiers and arguments in case of the binary scan subcommand: -.PP .CS \fBbinary scan\fR $bytes s3s first second .CE .PP This command (provided the binary string in the variable \fIbytes\fR @@ -642,19 +520,16 @@ \fIfirst\fR and assigns a single value to the variable \fIsecond\fR. If \fIbytes\fR contains fewer than 8 bytes (i.e. four 2-byte integers), no assignment to \fIsecond\fR will be made, and if \fIbytes\fR contains fewer than 6 bytes (i.e. three 2-byte integers), no assignment to \fIfirst\fR will be made. Hence: -.PP .CS puts [\fBbinary scan\fR abcdefg s3s first second] puts $first puts $second .CE -.PP will print (assuming neither variable is set previously): -.PP .CS 1 25185 25699 26213 can't read "second": no such variable .CE @@ -662,21 +537,18 @@ It is \fIimportant\fR to note that the \fBc\fR, \fBs\fR, and \fBS\fR (and \fBi\fR and \fBI\fR on 64bit systems) will be scanned into long data size values. In doing this, values that have their high bit set (0x80 for chars, 0x8000 for shorts, 0x80000000 for ints), will be sign extended. Thus the following will occur: -.PP .CS set signShort [\fBbinary format\fR s1 0x8000] \fBbinary scan\fR $signShort s1 val; \fI# val == 0xFFFF8000\fR .CE -.PP If you require unsigned values you can include the .QW u flag character following the field type. For example, to read an unsigned short value: -.PP .CS set signShort [\fBbinary format\fR s1 0x8000] \fBbinary scan\fR $signShort su1 val; \fI# val == 0x00008000\fR .CE .PP @@ -683,45 +555,38 @@ Each type-count pair moves an imaginary cursor through the binary data, reading bytes from the current position. The cursor is initially at position 0 at the beginning of the data. The type may be any one of the following characters: .IP \fBa\fR 5 -The data is a byte string of length \fIcount\fR. If \fIcount\fR is -.QW \fB*\fR , -then all of the remaining bytes in \fIstring\fR will be +The data is a byte string of length \fIcount\fR. If \fIcount\fR +is \fB*\fR, then all of the remaining bytes in \fIstring\fR will be scanned into the variable. If \fIcount\fR is omitted, then one byte will be scanned. All bytes scanned will be interpreted as being characters in the range \eu0000-\eu00ff so the \fBencoding convertfrom\fR command will be needed if the string is not a binary string or a string encoded in ISO 8859\-1. For example, .RS -.PP .CS \fBbinary scan\fR abcde\e000fghi a6a10 var1 var2 .CE -.PP will return \fB1\fR with the string equivalent to \fBabcde\e000\fR stored in \fIvar1\fR and \fIvar2\fR left unmodified, and -.PP .CS \fBbinary scan\fR \e342\e202\e254 a* var1 set var2 [encoding convertfrom utf-8 $var1] .CE -.PP will store a Euro-currency character in \fIvar2\fR. .RE .IP \fBA\fR 5 This form is the same as \fBa\fR, except trailing blanks and nulls are stripped from the scanned value before it is stored in the variable. For example, .RS -.PP .CS \fBbinary scan\fR "abc efghi \e000" A* var1 .CE -.PP will return \fB1\fR with \fBabc efghi\fR stored in \fIvar1\fR. .RE .IP \fBb\fR 5 The data is turned into a string of \fIcount\fR binary digits in low-to-high order represented as a sequence of @@ -728,32 +593,27 @@ .QW 1 and .QW 0 characters. The data bytes are scanned in first to last order with the bits being taken in low-to-high order within each byte. Any extra -bits in the last byte are ignored. If \fIcount\fR is -.QW \fB*\fR , -then all of the remaining bits in \fIstring\fR will be scanned. If +bits in the last byte are ignored. If \fIcount\fR is \fB*\fR, then +all of the remaining bits in \fIstring\fR will be scanned. If \fIcount\fR is omitted, then one bit will be scanned. For example, .RS -.PP .CS \fBbinary scan\fR \ex07\ex87\ex05 b5b* var1 var2 .CE -.PP will return \fB2\fR with \fB11100\fR stored in \fIvar1\fR and \fB1110000110100000\fR stored in \fIvar2\fR. .RE .IP \fBB\fR 5 This form is the same as \fBb\fR, except the bits are taken in high-to-low order within each byte. For example, .RS -.PP .CS \fBbinary scan\fR \ex70\ex87\ex05 B5B* var1 var2 .CE -.PP will return \fB2\fR with \fB01110\fR stored in \fIvar1\fR and \fB1000011100000101\fR stored in \fIvar2\fR. .RE .IP \fBH\fR 5 The data is turned into a string of \fIcount\fR hexadecimal digits in @@ -760,198 +620,175 @@ high-to-low order represented as a sequence of characters in the set .QW 0123456789abcdef . The data bytes are scanned in first to last order with the hex digits being taken in high-to-low order within each byte. Any extra bits in the last byte are ignored. If \fIcount\fR is -.QW \fB*\fR , -then all of the remaining hex digits in \fIstring\fR will be +\fB*\fR, then all of the remaining hex digits in \fIstring\fR will be scanned. If \fIcount\fR is omitted, then one hex digit will be scanned. For example, .RS -.PP .CS \fBbinary scan\fR \ex07\exC6\ex05\ex1f\ex34 H3H* var1 var2 .CE -.PP will return \fB2\fR with \fB07c\fR stored in \fIvar1\fR and \fB051f34\fR stored in \fIvar2\fR. .RE .IP \fBh\fR 5 This form is the same as \fBH\fR, except the digits are taken in reverse (low-to-high) order within each byte. For example, .RS -.PP .CS \fBbinary scan\fR \ex07\ex86\ex05\ex12\ex34 h3h* var1 var2 .CE -.PP will return \fB2\fR with \fB706\fR stored in \fIvar1\fR and \fB502143\fR stored in \fIvar2\fR. .PP Note that most code that wishes to parse the hexadecimal digits from multiple bytes in order should use the \fBH\fR format. .RE .IP \fBc\fR 5 The data is turned into \fIcount\fR 8-bit signed integers and stored -in the corresponding variable as a list, or as unsigned if \fBu\fR is placed -immediately after the \fBc\fR. If \fIcount\fR is -.QW \fB*\fR , +in the corresponding variable as a list. If \fIcount\fR is \fB*\fR, then all of the remaining bytes in \fIstring\fR will be scanned. If \fIcount\fR is omitted, then one 8-bit integer will be scanned. For example, .RS -.PP .CS \fBbinary scan\fR \ex07\ex86\ex05 c2c* var1 var2 .CE -.PP will return \fB2\fR with \fB7 -122\fR stored in \fIvar1\fR and \fB5\fR -stored in \fIvar2\fR. Note that the integers returned are signed unless -\fBcu\fR in place of \fBc\fR. +stored in \fIvar2\fR. Note that the integers returned are signed, but +they can be converted to unsigned 8-bit quantities using an expression +like: +.CS +set num [expr { $num & 0xFF }] +.CE .RE .IP \fBs\fR 5 The data is interpreted as \fIcount\fR 16-bit signed integers -represented in little-endian byte order, or as unsigned if \fBu\fR is placed -immediately after the \fBs\fR. The integers are stored in -the corresponding variable as a list. If \fIcount\fR is -.QW \fB*\fR , -then all of the remaining bytes in \fIstring\fR will be scanned. If +represented in little-endian byte order. The integers are stored in +the corresponding variable as a list. If \fIcount\fR is \fB*\fR, then +all of the remaining bytes in \fIstring\fR will be scanned. If \fIcount\fR is omitted, then one 16-bit integer will be scanned. For example, .RS -.PP .CS \fBbinary scan\fR \ex05\ex00\ex07\ex00\exf0\exff s2s* var1 var2 .CE -.PP will return \fB2\fR with \fB5 7\fR stored in \fIvar1\fR and \fB\-16\fR -stored in \fIvar2\fR. Note that the integers returned are signed unless -\fBsu\fR is used in place of \fBs\fR. +stored in \fIvar2\fR. Note that the integers returned are signed, but +they can be converted to unsigned 16-bit quantities using an expression +like: +.CS +set num [expr { $num & 0xFFFF }] +.CE .RE .IP \fBS\fR 5 This form is the same as \fBs\fR except that the data is interpreted -as \fIcount\fR 16-bit integers represented in big-endian byte +as \fIcount\fR 16-bit signed integers represented in big-endian byte order. For example, .RS -.PP .CS \fBbinary scan\fR \ex00\ex05\ex00\ex07\exff\exf0 S2S* var1 var2 .CE -.PP will return \fB2\fR with \fB5 7\fR stored in \fIvar1\fR and \fB\-16\fR stored in \fIvar2\fR. .RE .IP \fBt\fR 5 The data is interpreted as \fIcount\fR 16-bit signed integers represented in the native byte order of the machine running the Tcl -script, or as unsigned if \fBu\fR is placed -immediately after the \fBt\fR. It is otherwise identical to \fBs\fR and \fBS\fR. +script. It is otherwise identical to \fBs\fR and \fBS\fR. To determine what the native byte order of the machine is, refer to the \fBbyteOrder\fR element of the \fBtcl_platform\fR array. .IP \fBi\fR 5 The data is interpreted as \fIcount\fR 32-bit signed integers -represented in little-endian byte order, or as unsigned if \fBu\fR is placed -immediately after the \fBi\fR. The integers are stored in -the corresponding variable as a list. If \fIcount\fR is -.QW \fB*\fR , -then all of the remaining bytes in \fIstring\fR will be scanned. If +represented in little-endian byte order. The integers are stored in +the corresponding variable as a list. If \fIcount\fR is \fB*\fR, then +all of the remaining bytes in \fIstring\fR will be scanned. If \fIcount\fR is omitted, then one 32-bit integer will be scanned. For example, .RS -.PP .CS set str \ex05\ex00\ex00\ex00\ex07\ex00\ex00\ex00\exf0\exff\exff\exff \fBbinary scan\fR $str i2i* var1 var2 .CE -.PP will return \fB2\fR with \fB5 7\fR stored in \fIvar1\fR and \fB\-16\fR -stored in \fIvar2\fR. Note that the integers returned are signed unless -\fBiu\fR is used in place of \fBi\fR. +stored in \fIvar2\fR. Note that the integers returned are signed, but +they can be converted to unsigned 32-bit quantities using an expression +like: +.CS +set num [expr { $num & 0xFFFFFFFF }] +.CE .RE .IP \fBI\fR 5 This form is the same as \fBI\fR except that the data is interpreted as \fIcount\fR 32-bit signed integers represented in big-endian byte -order, or as unsigned if \fBu\fR is placed -immediately after the \fBI\fR. For example, +order. For example, .RS -.PP .CS set str \ex00\ex00\ex00\ex05\ex00\ex00\ex00\ex07\exff\exff\exff\exf0 \fBbinary scan\fR $str I2I* var1 var2 .CE -.PP will return \fB2\fR with \fB5 7\fR stored in \fIvar1\fR and \fB\-16\fR stored in \fIvar2\fR. .RE .IP \fBn\fR 5 The data is interpreted as \fIcount\fR 32-bit signed integers represented in the native byte order of the machine running the Tcl -script, or as unsigned if \fBu\fR is placed -immediately after the \fBn\fR. It is otherwise identical to \fBi\fR and \fBI\fR. +script. It is otherwise identical to \fBi\fR and \fBI\fR. To determine what the native byte order of the machine is, refer to the \fBbyteOrder\fR element of the \fBtcl_platform\fR array. .IP \fBw\fR 5 The data is interpreted as \fIcount\fR 64-bit signed integers -represented in little-endian byte order, or as unsigned if \fBu\fR is placed -immediately after the \fBw\fR. The integers are stored in -the corresponding variable as a list. If \fIcount\fR is -.QW \fB*\fR , -then all of the remaining bytes in \fIstring\fR will be scanned. If +represented in little-endian byte order. The integers are stored in +the corresponding variable as a list. If \fIcount\fR is \fB*\fR, then +all of the remaining bytes in \fIstring\fR will be scanned. If \fIcount\fR is omitted, then one 64-bit integer will be scanned. For example, .RS -.PP .CS set str \ex05\ex00\ex00\ex00\ex07\ex00\ex00\ex00\exf0\exff\exff\exff \fBbinary scan\fR $str wi* var1 var2 .CE -.PP will return \fB2\fR with \fB30064771077\fR stored in \fIvar1\fR and -\fB\-16\fR stored in \fIvar2\fR. +\fB\-16\fR stored in \fIvar2\fR. Note that the integers returned are +signed and cannot be represented by Tcl as unsigned values. .RE .IP \fBW\fR 5 This form is the same as \fBw\fR except that the data is interpreted as \fIcount\fR 64-bit signed integers represented in big-endian byte -order, or as unsigned if \fBu\fR is placed -immediately after the \fBW\fR. For example, +order. For example, .RS -.PP .CS set str \ex00\ex00\ex00\ex05\ex00\ex00\ex00\ex07\exff\exff\exff\exf0 \fBbinary scan\fR $str WI* var1 var2 .CE -.PP will return \fB2\fR with \fB21474836487\fR stored in \fIvar1\fR and \fB\-16\fR stored in \fIvar2\fR. .RE .IP \fBm\fR 5 The data is interpreted as \fIcount\fR 64-bit signed integers represented in the native byte order of the machine running the Tcl -script, or as unsigned if \fBu\fR is placed -immediately after the \fBm\fR. It is otherwise identical to \fBw\fR and \fBW\fR. +script. It is otherwise identical to \fBw\fR and \fBW\fR. To determine what the native byte order of the machine is, refer to the \fBbyteOrder\fR element of the \fBtcl_platform\fR array. .IP \fBf\fR 5 The data is interpreted as \fIcount\fR single-precision floating point numbers in the machine's native representation. The floating point numbers are stored in the corresponding variable as a list. If -\fIcount\fR is -.QW \fB*\fR , -then all of the remaining bytes in +\fIcount\fR is \fB*\fR, then all of the remaining bytes in \fIstring\fR will be scanned. If \fIcount\fR is omitted, then one single-precision floating point number will be scanned. The size of a floating point number may vary across architectures, so the number of bytes that are scanned may vary. If the data does not represent a valid floating point number, the resulting value is undefined and compiler dependent. For example, on a Windows system running on an Intel Pentium processor, .RS -.PP .CS \fBbinary scan\fR \ex3f\excc\excc\excd f var1 .CE -.PP will return \fB1\fR with \fB1.6000000238418579\fR stored in \fIvar1\fR. .RE .IP \fBr\fR 5 This form is the same as \fBf\fR except that the data is interpreted @@ -967,15 +804,13 @@ This form is the same as \fBf\fR except that the data is interpreted as \fIcount\fR double-precision floating point numbers in the machine's native representation. For example, on a Windows system running on an Intel Pentium processor, .RS -.PP .CS \fBbinary scan\fR \ex9a\ex99\ex99\ex99\ex99\ex99\exf9\ex3f d var1 .CE -.PP will return \fB1\fR with \fB1.6000000000000001\fR stored in \fIvar1\fR. .RE .IP \fBq\fR 5 This form is the same as \fBd\fR except that the data is interpreted @@ -987,40 +822,32 @@ as \fIcount\fR double-precision floating point number in big-endian order. This conversion is not portable to the minority of systems not using IEEE floating point representations. .IP \fBx\fR 5 Moves the cursor forward \fIcount\fR bytes in \fIstring\fR. If -\fIcount\fR is -.QW \fB*\fR -or is larger than the number of bytes after the +\fIcount\fR is \fB*\fR or is larger than the number of bytes after the current cursor position, then the cursor is positioned after the last byte in \fIstring\fR. If \fIcount\fR is omitted, then the cursor is moved forward one byte. Note that this type does not consume an argument. For example, .RS -.PP .CS \fBbinary scan\fR \ex01\ex02\ex03\ex04 x2H* var1 .CE -.PP will return \fB1\fR with \fB0304\fR stored in \fIvar1\fR. .RE .IP \fBX\fR 5 Moves the cursor back \fIcount\fR bytes in \fIstring\fR. If -\fIcount\fR is -.QW \fB*\fR -or is larger than the current cursor position, +\fIcount\fR is \fB*\fR or is larger than the current cursor position, then the cursor is positioned at location 0 so that the next byte scanned will be the first byte in \fIstring\fR. If \fIcount\fR is omitted then the cursor is moved back one byte. Note that this type does not consume an argument. For example, .RS -.PP .CS \fBbinary scan\fR \ex01\ex02\ex03\ex04 c2XH* var1 var2 .CE -.PP will return \fB2\fR with \fB1 2\fR stored in \fIvar1\fR and \fB020304\fR stored in \fIvar2\fR. .RE .IP \fB@\fR 5 Moves the cursor to the absolute location in the data string specified @@ -1027,15 +854,13 @@ by \fIcount\fR. Note that position 0 refers to the first byte in \fIstring\fR. If \fIcount\fR refers to a position beyond the end of \fIstring\fR, then the cursor is positioned after the last byte. If \fIcount\fR is omitted, then an error will be generated. For example, .RS -.PP .CS \fBbinary scan\fR \ex01\ex02\ex03\ex04 c2@1H* var1 var2 .CE -.PP will return \fB2\fR with \fB1 2\fR stored in \fIvar1\fR and \fB020304\fR stored in \fIvar2\fR. .RE .SH "PORTABILITY ISSUES" .PP DELETED doc/callback.n Index: doc/callback.n ================================================================== --- doc/callback.n +++ /dev/null @@ -1,88 +0,0 @@ -'\" -'\" Copyright (c) 2018 Donal K. Fellows -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH callback n 0.3 TclOO "TclOO Commands" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -callback, mymethod \- generate callbacks to methods -.SH SYNOPSIS -.nf -package require TclOO - -\fBcallback\fR \fImethodName\fR ?\fIarg ...\fR? -\fBmymethod\fR \fImethodName\fR ?\fIarg ...\fR? -.fi -.BE -.SH DESCRIPTION -The \fBcallback\fR command, -'\" Based on notes in the tcllib docs, we know the provenance of mymethod -also called \fBmymethod\fR for compatibility with the ooutil and snit packages -of Tcllib, -and which should only be used from within the context of a call to a method -(i.e. inside a method, constructor or destructor body) is used to generate a -script fragment that will invoke the method, \fImethodName\fR, on the current -object (as reported by \fBself\fR) when executed. Any additional arguments -provided will be provided as leading arguments to the callback. The resulting -script fragment shall be a proper list. -.PP -Note that it is up to the caller to ensure that the current object is able to -handle the call of \fImethodName\fR; this command does not check that. -\fImethodName\fR may refer to any exported or unexported method, but may not -refer to a private method as those can only be invoked directly from within -methods. If there is no such method present at the point when the callback is -invoked, the standard \fBunknown\fR method handler will be called. -.SH EXAMPLE -This is a simple echo server class. The \fBcallback\fR command is used in two -places, to arrange for the incoming socket connections to be handled by the -\fIAccept\fR method, and to arrange for the incoming bytes on those -connections to be handled by the \fIReceive\fR method. -.PP -.CS -oo::class create EchoServer { - variable server clients - constructor {port} { - set server [socket -server [\fBcallback\fR Accept] $port] - set clients {} - } - destructor { - chan close $server - foreach client [dict keys $clients] { - chan close $client - } - } - - method Accept {channel clientAddress clientPort} { - dict set clients $channel [dict create \e - address $clientAddress port $clientPort] - chan event $channel readable [\fBcallback\fR Receive $channel] - } - method Receive {channel} { - if {[chan gets $channel line] >= 0} { - my echo $channel $line - } else { - chan close $channel - dict unset clients $channel - } - } - - method echo {channel line} { - dict with clients $channel { - chan puts $channel \e - [format {[%s:%d] %s} $address $port $line] - } - } -} -.CE -.SH "SEE ALSO" -chan(n), fileevent(n), my(n), self(n), socket(n), trace(n) -.SH KEYWORDS -callback, object -.\" Local Variables: -.\" mode: nroff -.\" fill-column: 78 -.\" End: ADDED doc/case.n Index: doc/case.n ================================================================== --- /dev/null +++ doc/case.n @@ -0,0 +1,60 @@ +'\" +'\" Copyright (c) 1993 The Regents of the University of California. +'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +.TH case n 7.0 Tcl "Tcl Built-In Commands" +.so man.macros +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +case \- Evaluate one of several scripts, depending on a given value +.SH SYNOPSIS +\fBcase\fI string \fR?\fBin\fR? \fIpatList body \fR?\fIpatList body \fR...? +.sp +\fBcase\fI string \fR?\fBin\fR? {\fIpatList body \fR?\fIpatList body \fR...?} +.BE + +.SH DESCRIPTION +.PP +\fINote: the \fBcase\fI command is obsolete and is supported only +for backward compatibility. At some point in the future it may be +removed entirely. You should use the \fBswitch\fI command instead.\fR +.PP +The \fBcase\fR command matches \fIstring\fR against each of +the \fIpatList\fR arguments in order. +Each \fIpatList\fR argument is a list of one or +more patterns. If any of these patterns matches \fIstring\fR then +\fBcase\fR evaluates the following \fIbody\fR argument +by passing it recursively to the Tcl interpreter and returns the result +of that evaluation. +Each \fIpatList\fR argument consists of a single +pattern or list of patterns. Each pattern may contain any of the wild-cards +described under \fBstring match\fR. If a \fIpatList\fR +argument is \fBdefault\fR, the corresponding body will be evaluated +if no \fIpatList\fR matches \fIstring\fR. If no \fIpatList\fR argument +matches \fIstring\fR and no default is given, then the \fBcase\fR +command returns an empty string. +.PP +Two syntaxes are provided for the \fIpatList\fR and \fIbody\fR arguments. +The first uses a separate argument for each of the patterns and commands; +this form is convenient if substitutions are desired on some of the +patterns or commands. +The second form places all of the patterns and commands together into +a single argument; the argument must have proper list structure, with +the elements of the list being the patterns and commands. +The second form makes it easy to construct multi-line case commands, +since the braces around the whole list make it unnecessary to include a +backslash at the end of each line. +Since the \fIpatList\fR arguments are in braces in the second form, +no command or variable substitutions are performed on them; this makes +the behavior of the second form different than the first form in some +cases. + +.SH "SEE ALSO" +switch(n) + +.SH KEYWORDS +case, match, regular expression Index: doc/cd.n ================================================================== --- doc/cd.n +++ doc/cd.n @@ -39,9 +39,5 @@ .CE .SH "SEE ALSO" filename(n), glob(n), pwd(n) .SH KEYWORDS working directory -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: DELETED doc/classvariable.n Index: doc/classvariable.n ================================================================== --- doc/classvariable.n +++ /dev/null @@ -1,78 +0,0 @@ -'\" -'\" Copyright (c) 2011-2015 Andreas Kupries -'\" Copyright (c) 2018 Donal K. Fellows -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH classvariable n 0.3 TclOO "TclOO Commands" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -classvariable \- create link from local variable to variable in class -.SH SYNOPSIS -.nf -package require TclOO - -\fBclassvariable\fR \fIvariableName\fR ?\fI...\fR? -.fi -.BE -.SH DESCRIPTION -The \fBclassvariable\fR command is available within methods. It takes a series -of one or more variable names and makes them available in the method's scope; -those variable names must not be qualified and must not refer to array -elements. The originating scope for the variables is the namespace of the -class that the method was defined by. In other words, the referenced variables -are shared between all instances of that class. -.PP -Note: This command is equivalent to the command \fBtypevariable\fR provided by -the snit package in tcllib for approximately the same purpose. If used in a -method defined directly on a class instance (e.g., through the -\fBoo::objdefine\fR \fBmethod\fR definition) this is very much like just -using: -.PP -.CS -namespace upvar [namespace current] $var $var -.CE -.PP -for each variable listed to \fBclassvariable\fR. -.SH EXAMPLE -This class counts how many instances of it have been made. -.PP -.CS -oo::class create Counted { - initialise { - variable count 0 - } - - variable number - constructor {} { - \fBclassvariable\fR count - set number [incr count] - } - - method report {} { - \fBclassvariable\fR count - puts "This is instance $number of $count" - } -} - -set a [Counted new] -set b [Counted new] -$a report - \fI\(-> This is instance 1 of 2\fR -set c [Counted new] -$b report - \fI\(-> This is instance 2 of 3\fR -$c report - \fI\(-> This is instance 3 of 3\fR -.CE -.SH "SEE ALSO" -global(n), namespace(n), oo::class(n), oo::define(n), upvar(n), variable(n) -.SH KEYWORDS -class, class variable, variable -.\" Local Variables: -.\" mode: nroff -.\" fill-column: 78 -.\" End: Index: doc/clock.n ================================================================== --- doc/clock.n +++ doc/clock.n @@ -87,13 +87,14 @@ back in sync with UTC; its data model does not represent minutes that have 59 or 61 seconds. .TP \fIunit\fR One of the words, \fBseconds\fR, \fBminutes\fR, \fBhours\fR, -\fBdays\fR, \fBweekdays\fR, \fBweeks\fR, \fBmonths\fR, or \fByears\fR. -Used in conjunction with \fIcount\fR to identify an interval of time, -for example, \fI3 seconds\fR or \fI1 year\fR. +\fBdays\fR, \fBweeks\fR, \fBmonths\fR, or \fByears\fR, or +any unique prefix of such a word. Used in conjunction with \fIcount\fR +to identify an interval of time, for example, \fI3 seconds\fR or +\fI1 year\fR. .SS "OPTIONS" .TP \fB\-base\fR time Specifies that any relative times present in a \fBclock scan\fR command are to be given relative to \fItime\fR. \fItime\fR must be expressed as @@ -172,11 +173,12 @@ (expressed as nominal seconds from the epoch time of 1 January 1970, 00:00 UTC) given as its first argument. The remaining arguments (other than the possible \fB\-timezone\fR, \fB\-locale\fR and \fB\-gmt\fR options) are integers and keywords in alternation, where the keywords are chosen from \fBseconds\fR, \fBminutes\fR, \fBhours\fR, -\fBdays\fR, \fBweekdays\fR, \fBweeks\fR, \fBmonths\fR, or \fByears\fR. +\fBdays\fR, \fBweeks\fR, \fBmonths\fR, or \fByears\fR, or +any unique prefix of such a word. .PP Addition of seconds, minutes and hours is fairly straightforward; the given time increment (times sixty for minutes, or 3600 for hours) is simply added to the \fItimeVal\fR given to the \fBclock add\fR command. The result is interpreted as @@ -209,12 +211,11 @@ Adding and subtracting days and weeks is accomplished by converting the given time to a calendar day and time of day in the appropriate time zone and locale. The requisite number of days (weeks are converted to days by multiplying by seven) is added to the calendar day, and the date and time are then converted back to a count of seconds from -the epoch time. The \fBweekdays\fR keyword is similar to \fBdays\fR, -with the only difference that weekends - Saturdays and Sundays - are skipped. +the epoch time. .PP Adding and subtracting a given number of days across the point that the time changes at the start or end of summer time (Daylight Saving Time) results in the \fIsame local time\fR on the day in question. For instance, the following code sets the value of \fBx\fR to \fB05:00:00\fR. @@ -469,40 +470,40 @@ .PP The following format groups are recognized by the \fBclock scan\fR and \fBclock format\fR commands. .TP \fB%a\fR -On output, receives an abbreviation (\fIe.g.,\fR \fBMon\fR) for the day +On output, produces an abbreviation (\fIe.g.,\fR \fBMon\fR) for the day of the week in the given locale. On input, matches the name of the day of the week in the given locale (in either abbreviated or full form, or any unique prefix of either form). .TP \fB%A\fR -On output, receives the full name (\fIe.g.,\fR \fBMonday\fR) of the day +On output, produces the full name (\fIe.g.,\fR \fBMonday\fR) of the day of the week in the given locale. On input, matches the name of the day of the week in the given locale (in either abbreviated or full form, or any unique prefix of either form). .TP \fB%b\fR -On output, receives an abbreviation (\fIe.g.,\fR \fBJan\fR) for the name +On output, produces an abbreviation (\fIe.g.,\fR \fBJan\fR) for the name of the month in the given locale. On input, matches the name of the month in the given locale (in either abbreviated or full form, or any unique prefix of either form). .TP \fB%B\fR -On output, receives the full name (\fIe.g.,\fR \fBJanuary\fR) +On output, produces the full name (\fIe.g.,\fR \fBJanuary\fR) of the month in the given locale. On input, matches the name of the month in the given locale (in either abbreviated or full form, or any unique prefix of either form). .TP \fB%c\fR -On output, receives a localized representation of date and time of day; +On output, produces a localized representation of date and time of day; the localized representation is expected to use the Gregorian calendar. On input, matches whatever \fB%c\fR produces. .TP \fB%C\fR -On output, receives the number of the century in Indo-Arabic numerals. +On output, produces the number of the century in Indo-Arabic numerals. On input, matches one or two digits, possibly with leading whitespace, that are expected to be the number of the century. .TP \fB%d\fR On output, produces the number of the day of the month, as two decimal @@ -884,50 +885,45 @@ .PP The \fIinputString\fR argument consists of zero or more specifications of the following form: .TP \fItime\fR -. -A time of day, which is of the form: -.QW "\fIhh\fR?\fB:\fImm\fR?\fB:\fIss\fR?? ?\fImeridian\fR? ?\fIzone\fR?" -or -.QW "\fBhhmm \fR?\fBmeridian\fR? ?\fBzone\fR?" . -If no \fImeridian\fR is specified, \fIhh\fR is interpreted on +A time of day, which is of the form: \fBhh?:mm?:ss?? ?meridian? ?zone?\fR +or \fBhhmm ?meridian? ?zone?\fR +If no meridian is specified, \fBhh\fR is interpreted on a 24-hour clock. .TP \fIdate\fR -. A specific month and day with optional year. The acceptable formats are -.QW "\fImm\fB/\fIdd\fR?\fB/\fIyy\fR?" , -.QW "\fImonthname dd\fR?\fB, \fIyy\fR?" , -.QW "\fIday\fB, \fIdd monthname \fR?\fIyy\fR?" , -.QW "\fIdd monthname yy\fR" , -.QW "?\fICC\fR?\fIyymmdd\fR" , +.QW "\fBmm/dd\fR?\fB/yy\fR?" , +.QW "\fBmonthname dd\fR?\fB, yy\fR?" , +.QW "\fBday, dd monthname \fR?\fByy\fR?" , +.QW "\fBdd monthname yy\fR" , +.QW "?\fBCC\fR?\fByymmdd\fR" , and -.QW "\fIdd\fB-\fImonthname\fB-\fR?\fICC\fR?\fIyy\fR" . +.QW "\fBdd-monthname-\fR?\fBCC\fR?\fByy\fR" . The default year is the current year. If the year is less than 100, we treat the years 00-68 as 2000-2068 and the years 69-99 as 1969-1999. Not all platforms can represent the years 38-70, so an error may result if these years are used. .TP \fIISO 8601 point-in-time\fR -. An ISO 8601 point-in-time specification, such as .QW \fICCyymmdd\fBT\fIhhmmss\fR, where \fBT\fR is the literal .QW T , .QW "\fICCyymmdd hhmmss\fR" , +.QW \fICCyymmdd\fBT\fIhh:mm:ss\fR , or -.QW \fICCyymmdd\fBT\fIhh\fB:\fImm\fB:\fIss\fR . -Note that only these three formats are accepted. +.QW \fICCyy-mm-dd\fBT\fIhh:mm:ss\fR. +Note that only these four formats are accepted. The command does \fInot\fR accept the full range of point-in-time specifications specified in ISO8601. Other formats can be recognized by giving an explicit \fB\-format\fR option to the \fBclock scan\fR command. .TP \fIrelative time\fR -. A specification relative to the current time. The format is \fBnumber unit\fR. Acceptable units are \fByear\fR, \fBfortnight\fR, \fBmonth\fR, \fBweek\fR, \fBday\fR, \fBhour\fR, \fBminute\fR (or \fBmin\fR), and \fBsecond\fR (or \fBsec\fR). The unit can be specified as a singular or plural, as in \fB3 weeks\fR. Index: doc/continue.n ================================================================== --- doc/continue.n +++ doc/continue.n @@ -21,11 +21,11 @@ It returns a 4 (\fBTCL_CONTINUE\fR) result code, which causes a continue exception to occur. The exception causes the current script to be aborted out to the innermost containing loop command, which then continues with the next iteration of the loop. -Continue exceptions are also handled in a few other situations, such +Catch exceptions are also handled in a few other situations, such as the \fBcatch\fR command and the outermost scripts of procedure bodies. .SH EXAMPLE .PP Print a line for each of the integers from 0 to 10 \fIexcept\fR 5: DELETED doc/cookiejar.n Index: doc/cookiejar.n ================================================================== --- doc/cookiejar.n +++ /dev/null @@ -1,217 +0,0 @@ -'\" -'\" Copyright (c) 2014-2018 Donal K. Fellows. -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH "cookiejar" n 0.1 http "Tcl Bundled Packages" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -cookiejar \- Implementation of the Tcl http package cookie jar protocol -.SH SYNOPSIS -.nf -\fBpackage require\fR \fBcookiejar\fR ?\fB0.1\fR? - -\fB::http::cookiejar configure\fR ?\fIoptionName\fR? ?\fIoptionValue\fR? -\fB::http::cookiejar create\fR \fIname\fR ?\fIfilename\fR? -\fB::http::cookiejar new\fR ?\fIfilename\fR? - -\fIcookiejar\fR \fBdestroy\fR -\fIcookiejar\fR \fBforceLoadDomainData\fR -\fIcookiejar\fR \fBgetCookies\fR \fIprotocol host path\fR -\fIcookiejar\fR \fBstoreCookie\fR \fIoptions\fR -\fIcookiejar\fR \fBlookup\fR ?\fIhost\fR? ?\fIkey\fR? -.fi -.SH DESCRIPTION -.PP -The cookiejar package provides an implementation of the http package's cookie -jar protocol using an SQLite database. It provides one main command, -\fB::http::cookiejar\fR, which is a TclOO class that should be instantiated to -create a cookie jar that manages a particular HTTP session. -.PP -The database management policy can be controlled at the package level by the -\fBconfigure\fR method on the \fB::http::cookiejar\fR class object: -.TP -\fB::http::cookiejar configure\fR ?\fIoptionName\fR? ?\fIoptionValue\fR? -. -If neither \fIoptionName\fR nor \fIoptionValue\fR are supplied, this returns a -copy of the configuration as a Tcl dictionary. If just \fIoptionName\fR is -supplied, just the value of the named option is returned. If both -\fIoptionName\fR and \fIoptionValue\fR are given, the named option is changed -to be the given value. -.RS -.PP -Supported options are: -.TP -\fB\-domainfile \fIfilename\fR -. -A file (defaulting to within the cookiejar package) with a description of the -list of top-level domains (e.g., \fB.com\fR or \fB.co.jp\fR). Such domains -\fImust not\fR accept cookies set upon them. Note that the list of such -domains is both security-sensitive and \fInot\fR constant and should be -periodically refetched. Cookie jars maintain their own cache of the domain -list. -.TP -\fB\-domainlist \fIurl\fR -. -A URL to fetch the list of top-level domains (e.g., \fB.com\fR or -\fB.co.jp\fR) from. Such domains \fImust not\fR accept cookies set upon -them. Note that the list of such domains is both security-sensitive and -\fInot\fR constant and should be periodically refetched. Cookie jars maintain -their own cache of the domain list. -.TP -\fB\-domainrefresh \fIintervalMilliseconds\fR -. -The number of milliseconds between checks of the \fI\-domainlist\fR for new -domains. -.TP -\fB\-loglevel \fIlevel\fR -. -The logging level of this package. The logging level must be (in order of -decreasing verbosity) one of \fBdebug\fR, \fBinfo\fR, \fBwarn\fR, or -\fBerror\fR. -.TP -\fB\-offline \fIflag\fR -. -Allows the cookie managment engine to be placed into offline mode. In offline -mode, the list of domains is read immediately from the file configured in the -\fB\-domainfile\fR option, and the \fB\-domainlist\fR option is not used; it -also makes the \fB\-domainrefresh\fR option be effectively ignored. -.TP -\fB\-purgeold \fIintervalMilliseconds\fR -. -The number of milliseconds between checks of the database for expired -cookies; expired cookies are deleted. -.TP -\fB\-retain \fIcookieCount\fR -. -The maximum number of cookies to retain in the database. -.TP -\fB\-vacuumtrigger \fIdeletionCount\fR -. -A count of the number of persistent cookie deletions to go between vacuuming -the database. -.RE -.PP -Cookie jar instances may be made with any of the standard TclOO instance -creation methods (\fBcreate\fR or \fBnew\fR). -.TP -\fB::http::cookiejar new\fR ?\fIfilename\fR? -. -If a \fIfilename\fR argument is provided, it is the name of a file containing -an SQLite database that will contain the persistent cookies maintained by the -cookie jar; the database will be created if the file does not already -exist. If \fIfilename\fR is not supplied, the database will be held entirely within -memory, which effectively forces all cookies within it to be session cookies. -.SS "INSTANCE METHODS" -.PP -The following methods are supported on the instances: -.TP -\fIcookiejar\fR \fBdestroy\fR -. -This is the standard TclOO destruction method. It does \fInot\fR delete the -SQLite database if it is written to disk. Callers are responsible for ensuring -that the cookie jar is not in use by the http package at the time of -destruction. -.TP -\fIcookiejar\fR \fBforceLoadDomainData\fR -. -This method causes the cookie jar to immediately load (and cache) the domain -list data. The domain list will be loaded from the \fB\-domainlist\fR -configured a the package level if that is enabled, and otherwise will be -obtained from the \fB\-domainfile\fR configured at the package level. -.TP -\fIcookiejar\fR \fBgetCookies\fR \fIprotocol host path\fR -. -This method obtains the cookies for a particular HTTP request. \fIThis -implements the http cookie jar protocol.\fR -.TP -\fIcookiejar\fR \fBpolicyAllow\fR \fIoperation domain path\fR -. -This method is called by the \fBstoreCookie\fR method to get a decision on -whether to allow \fIoperation\fR to be performed for the \fIdomain\fR and -\fIpath\fR. This is checked immediately before the database is updated but -after the built-in security checks are done, and should return a boolean -value; if the value is false, the operation is rejected and the database is -not modified. The supported \fIoperation\fRs are: -.RS -.TP -\fBdelete\fR -. -The \fIdomain\fR is seeking to delete a cookie. -.TP -\fBsession\fR -. -The \fIdomain\fR is seeking to create or update a session cookie. -.TP -\fBset\fR -. -The \fIdomain\fR is seeking to create or update a persistent cookie (with a -defined lifetime). -.PP -The default implementation of this method just returns true, but subclasses of -this class may impose their own rules. -.RE -.TP -\fIcookiejar\fR \fBstoreCookie\fR \fIoptions\fR -. -This method stores a single cookie from a particular HTTP response. Cookies -that fail security checks are ignored. \fIThis implements the http cookie jar -protocol.\fR -.TP -\fIcookiejar\fR \fBlookup\fR ?\fIhost\fR? ?\fIkey\fR? -. -This method looks a cookie by exact host (or domain) matching. If neither -\fIhost\fR nor \fIkey\fR are supplied, the list of hosts for which a cookie is -stored is returned. If just \fIhost\fR (which may be a hostname or a domain -name) is supplied, the list of cookie keys stored for that host is returned. -If both \fIhost\fR and \fIkey\fR are supplied, the value for that key is -returned; it is an error if no such host or key match exactly. -.SH "EXAMPLES" -.PP -The simplest way of using a cookie jar is to just permanently configure it at -the start of the application. -.PP -.CS -package require http -\fBpackage require cookiejar\fR - -set cookiedb ~/.tclcookies.db -http::configure -cookiejar [\fBhttp::cookiejar new\fR $cookiedb] - -# No further explicit steps are required to use cookies -set tok [http::geturl http://core.tcl.tk/] -.CE -.PP -To only allow a particular domain to use cookies, perhaps because you only -want to enable a particular host to create and manipulate sessions, create a -subclass that imposes that policy. -.PP -.CS -package require http -\fBpackage require cookiejar\fR - -oo::class create MyCookieJar { - superclass \fBhttp::cookiejar\fR - - method \fBpolicyAllow\fR {operation domain path} { - return [expr {$domain eq "my.example.com"}] - } -} - -set cookiedb ~/.tclcookies.db -http::configure -cookiejar [MyCookieJar new $cookiedb] - -# No further explicit steps are required to use cookies -set tok [http::geturl http://core.tcl.tk/] -.CE -.SH "SEE ALSO" -http(n), oo::class(n), sqlite3(n) -.SH KEYWORDS -cookie, internet, security policy, www -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/coroutine.n ================================================================== --- doc/coroutine.n +++ doc/coroutine.n @@ -12,17 +12,14 @@ coroutine, yield, yieldto \- Create and produce values from coroutines .SH SYNOPSIS .nf \fBcoroutine \fIname command\fR ?\fIarg...\fR? \fByield\fR ?\fIvalue\fR? +.VS TIP396 \fByieldto\fR \fIcommand\fR ?\fIarg...\fR? \fIname\fR ?\fIvalue...\fR? -.sp -.VS "8.7, TIP383" -\fBcoroinject \fIcoroName command\fR ?\fIarg...\fR? -\fBcoroprobe \fIcoroName command\fR ?\fIarg...\fR? -.VE "8.7, TIP383" +.VE TIP396 .fi .BE .SH DESCRIPTION .PP The \fBcoroutine\fR command creates a new coroutine context (with associated @@ -40,10 +37,11 @@ that caused the context to be suspended. If the coroutine context never yields and instead returns conventionally, the result of the \fBcoroutine\fR command will be the result of the evaluation of the context. .PP +.VS TIP396 The coroutine may also suspend its execution by use of the \fByieldto\fR command, which instead of returning, cedes execution to some command called \fIcommand\fR (resolved in the context of the coroutine) and to which \fIany number\fR of arguments may be passed. Since every coroutine has a context command, \fByieldto\fR can be used to transfer control directly from one @@ -58,14 +56,15 @@ The recommended way of writing a version of \fByield\fR that allows resumption with multiple arguments is by using \fByieldto\fR and the \fBreturn\fR command, like this: .PP .CS -proc yieldMultiple {value} { - tailcall \fByieldto\fR string cat $value +proc yieldm {value} { + \fByieldto\fR return -level 0 $value } .CE +.VE TIP396 .PP The coroutine can also be deleted by destroying the command \fIname\fR, and the name of the current coroutine can be retrieved by using \fBinfo coroutine\fR. If there are deletion traces on variables in the coroutine's @@ -74,55 +73,10 @@ .PP At the point when \fIcommand\fR is called, the current namespace will be the global namespace and there will be no stack frames above it (in the sense of \fBupvar\fR and \fBuplevel\fR). However, which command to call will be determined in the namespace that the \fBcoroutine\fR command was called from. -.PP -.VS "8.7, TIP383" -A suspended coroutine (i.e., one that has \fByield\fRed or \fByieldto\fR-d) -may have its state inspected (or modified) at that point by using -\fBcoroprobe\fR to run a command at the point where the coroutine is at. The -command takes the name of the coroutine to run the command in, \fIcoroName\fR, -and the name of a command (any any arguments it requires) to immediately run -at that point. The result of that command is the result of the \fBcoroprobe\fR -command, and the gross state of the coroutine remains the same afterwards -(i.e., the coroutine is still expecting the results of a \fByield\fR or -\fByieldto\fR as before) though variables may have been changed. -.PP -Similarly, the \fBcoroinject\fR command may be used to place a command to be -run inside a suspended coroutine (when it is resumed) to process arguments, -with quite a bit of similarity to \fBcoroprobe\fR. However, with -\fBcoroinject\fR there are several key differences: -.VE "8.7, TIP383" -.IP \(bu -.VS "8.7, TIP383" -The coroutine is not immediately resumed after the injection has been done. A -consequence of this is that multiple injections may be done before the -coroutine is resumed. There injected commands are performed in \fIreverse -order of definition\fR (that is, they are internally stored on a stack). -.VE "8.7, TIP383" -.IP \(bu -.VS "8.7, TIP383" -An additional two arguments are appended to the list of arguments to be run -(that is, the \fIcommand\fR and its \fIargs\fR are extended by two elements). -The first is the name of the command that suspended the coroutine (\fByield\fR -or \fByieldto\fR), and the second is the argument (or list of arguments, in -the case of \fByieldto\fR) that is the current resumption value. -.VE "8.7, TIP383" -.IP \(bu -.VS "8.7, TIP383" -The result of the injected command is used as the result of the \fByield\fR or -\fByieldto\fR that caused the coroutine to become suspended. Where there are -multiple injected commands, the result of one becomes the resumption value -processed by the next. -.PP -The injection is a one-off. It is not retained once it has been executed. It -may \fByield\fR or \fByieldto\fR as part of its execution. -.PP -Note that running coroutines may be neither probed nor injected; the -operations may only be applied to -.VE "8.7, TIP383" .SH EXAMPLES .PP This example shows a coroutine that will produce an infinite sequence of even values, and a loop that consumes the first ten of them. .PP @@ -182,10 +136,11 @@ for {set i 1} {$i <= 20} {incr i} { puts "prime#$i = [\fIeratosthenes\fR]" } .CE .PP +.VS TIP396 This example shows how a value can be passed around a group of three coroutines that yield to each other: .PP .CS proc juggler {name target {value ""}} { @@ -193,61 +148,18 @@ set value [\fByield\fR [info coroutine]] } while {$value ne ""} { puts "$name : $value" set value [string range $value 0 end-1] - lassign [\fByieldto\fR \fI$target\fR $value] value + lassign [\fByieldto\fR $target $value] value } } \fBcoroutine\fR j1 juggler Larry [ \fBcoroutine\fR j2 juggler Curly [ \fBcoroutine\fR j3 juggler Moe j1]] "Nyuck!Nyuck!Nyuck!" .CE -.PP -.VS "8.7, TIP383" -This example shows a simple coroutine that collects non-empty values and -returns a list of them when not given an argument. It also shows how we can -look inside the coroutine to find out what it is doing, and how we can modify -the input on a one-off basis. -.PP -.CS -proc collectorImpl {} { - set me [info coroutine] - set accumulator {} - for {set val [\fByield\fR $me]} {$val ne ""} {set val [\fByield\fR]} { - lappend accumulator $val - } - return $accumulator -} - -\fBcoroutine\fR collect collectorImpl -\fIcollect\fR 123 -\fIcollect\fR "abc def" -\fIcollect\fR 456 - -puts [\fBcoroprobe \fIcollect\fR set accumulator] -# ==> 123 {abc def} 456 - -\fIcollect\fR "pqr" - -\fBcoroinject \fIcollect\fR apply {{type value} { - puts "Received '$value' at a $type in [info coroutine]" - return [string toupper $value] -}} - -\fIcollect\fR rst -# ==> Received 'rst' at a yield in ::collect -\fIcollect\fR xyz - -puts [\fIcollect\fR] -# ==> 123 {abc def} 456 pqr RST xyz -.CE -.PP -This example shows a simple coroutine that collects non-empty values and -returns a list of them when not given an argument. It also shows how we can -look inside the coroutine to find out what it is doing. -.VE "8.7, TIP383" +.VE TIP396 .SS "DETAILED SEMANTICS" .PP This example demonstrates that coroutines start from the global namespace, and that \fIcommand\fR resolution happens before the coroutine stack is created. .PP Index: doc/define.n ================================================================== --- doc/define.n +++ doc/define.n @@ -1,7 +1,7 @@ '\" -'\" Copyright (c) 2007-2018 Donal K. Fellows +'\" Copyright (c) 2007 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH define n 0.3 TclOO "TclOO Commands" @@ -32,40 +32,15 @@ configuration). The way in which the configuration is done is controlled by either the \fIdefScript\fR argument or by the \fIsubcommand\fR and following \fIarg\fR arguments; when the second is present, it is exactly as if all the arguments from \fIsubcommand\fR onwards are made into a list and that list is used as the \fIdefScript\fR argument. -.PP -Note that the constructor for \fBoo::class\fR will call \fBoo::define\fR on -the script argument that it is provided. This is a convenient way to create -and define a class in one step. -.SH "CONFIGURING CLASSES" +.SS "CONFIGURING CLASSES" .PP The following commands are supported in the \fIdefScript\fR for \fBoo::define\fR, each of which may also be used in the \fIsubcommand\fR form: .TP -\fBclassmethod\fI name\fR ?\fIargList bodyScrip\fR? -.VS TIP478 -This creates a class method, or (if \fIargList\fR and \fIbodyScript\fR are -omitted) promotes an existing method on the class object to be a class -method. The \fIname\fR, \fIargList\fR and \fIbodyScript\fR arguments are as in -the \fBmethod\fR definition, below. -.RS -.PP -Class methods can be called on either the class itself or on the instances of -that class. When they are called, the current object (see the \fBsel\fR and -\fBmy\fR commands) is the class on which they are called or the class of the -instance on which they are called, depending on whether they are called on the -class or an instance of the class, respectively. If called on a subclass or -instance of the subclass, the current object is the subclass. -.PP -In a private definition context, the methods as invoked on classes are -\fInot\fR private, but the methods as invoked on instances of classes are -private. -.RE -.VE TIP478 -.TP \fBconstructor\fI argList bodyScript\fR . This creates or updates the constructor for a class. The formal arguments to the constructor (defined using the same format as for the Tcl \fBproc\fR command) will be \fIargList\fR, and the body of the constructor will be @@ -72,15 +47,18 @@ \fIbodyScript\fR. When the body of the constructor is evaluated, the current namespace of the constructor will be a namespace that is unique to the object being constructed. Within the constructor, the \fBnext\fR command should be used to call the superclasses' constructors. If \fIbodyScript\fR is the empty string, the constructor will be deleted. -.RS -.PP -Classes do not need to have a constructor defined. If none is specified, the -superclass's constructor will be used instead. -.RE +.TP +\fBdeletemethod\fI name\fR ?\fIname ...\fR? +. +This deletes each of the methods called \fIname\fR from a class. The methods +must have previously existed in that class. Does not affect the superclasses +of the class, nor does it affect the subclasses or instances of the class +(except when they have a call chain through the class being modified) or the +class object itself. .TP \fBdestructor\fI bodyScript\fR . This creates or updates the destructor for a class. Destructors take no arguments, and the body of the destructor will be \fIbodyScript\fR. The @@ -101,10 +79,23 @@ This arranges for each of the named methods, \fIname\fR, to be exported (i.e. usable outside an instance through the instance object's command) by the class being defined. Note that the methods themselves may be actually defined by a superclass; subclass exports override superclass visibility, and may in turn be overridden by instances. +.TP +\fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR? +.VS +This slot (see \fBSLOTTED DEFINITIONS\fR below) +.VE +sets or updates the list of method names that are used to guard whether +method call to instances of the class may be called and what the method's +results are. Each \fImethodName\fR names a single filtering method (which may +be exposed or not exposed); it is not an error for a non-existent method to be +named since they may be defined by subclasses. +.VS +By default, this slot works by appending. +.VE .TP \fBforward\fI name cmdName \fR?\fIarg ...\fR? . This creates or updates a forwarded method called \fIname\fR. The method is defined be forwarded to the command called \fIcmdName\fR, with additional @@ -113,107 +104,71 @@ rules of the invoking objects' namespaces, i.e., when \fIcmdName\fR is not fully-qualified, the command will be searched for in each object's namespace, using the instances' namespace's path, or by looking in the global namespace. The method will be exported if \fIname\fR starts with a lower-case letter, and non-exported otherwise. -.RS -.PP -.VS TIP500 -If in a private definition context (see the \fBprivate\fR definition command, -below), this command creates private forwarded methods. -.VE TIP500 -.RE -.TP -\fBinitialise\fI script\fR -.TP -\fBinitialize\fI script\fR -.VS TIP478 -This evaluates \fIscript\fR in a context which supports local variables and -where the current namespace is the instance namespace of the class object -itself. This is useful for setting up, e.g., class-scoped variables. -.VE TIP478 -.TP -\fBmethod\fI name \fR?\fIoption\fR? \fIargList bodyScript\fR +.TP +\fBmethod\fI name argList bodyScript\fR . This creates or updates a method that is implemented as a procedure-like script. The name of the method is \fIname\fR, the formal arguments to the method (defined using the same format as for the Tcl \fBproc\fR command) will be \fIargList\fR, and the body of the method will be \fIbodyScript\fR. When the body of the method is evaluated, the current namespace of the method will be a namespace that is unique to the current object. The method will be exported if \fIname\fR starts with a lower-case letter, and non-exported otherwise; this behavior can be overridden via \fBexport\fR and -\fBunexport\fR -.VS TIP519 -or by specifying \fB\-export\fR, \fB\-private\fR or \fB\-unexport\fR in the -optional parameter \fIoption\fR. -.VE TIP519 -.RS -.PP -.VS TIP500 -If in a private definition context (see the \fBprivate\fR definition command, -below) or if the \fB\-private\fR flag is given for \fIoption\fR, this command -creates private procedure-like methods. -.VE TIP500 -.RE -.TP -\fBprivate \fIcmd arg...\fR -.TP -\fBprivate \fIscript\fR -. -.VS TIP500 -This evaluates the \fIscript\fR (or the list of command and arguments given by -\fIcmd\fR and \fIarg\fRs) in a context where the definitions made on the -current class will be private definitions. -.RS -.PP -The following class definition commands are affected by \fBprivate\fR: -\fBforward\fR, \fBmethod\fR, \fBself\fR, and \fBvariable\fR. Nesting -\fBprivate\fR inside \fBprivate\fR has no cumulative effect; the innermost -definition context is just a private definition context. All other definition -commands have no difference in behavior when used in a private definition -context. -.RE -.VE TIP500 +\fBunexport\fR. +.TP +\fBmixin\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR? +.VS +This slot (see \fBSLOTTED DEFINITIONS\fR below) +.VE +sets or updates the list of additional classes that are to be mixed into +all the instances of the class being defined. Each \fIclassName\fR argument +names a single class that is to be mixed in. +.VS +By default, this slot works by replacement. +.VE +.TP +\fBrenamemethod\fI fromName toName\fR +. +This renames the method called \fIfromName\fR in a class to \fItoName\fR. The +method must have previously existed in the class, and \fItoName\fR must not +previously refer to a method in that class. Does not affect the superclasses +of the class, nor does it affect the subclasses or instances of the class +(except when they have a call chain through the class being modified), or the +class object itself. Does +not change the export status of the method; if it was exported before, it will +be afterwards. .TP \fBself\fI subcommand arg ...\fR .TP \fBself\fI script\fR -.TP -\fBself\fR . This command is equivalent to calling \fBoo::objdefine\fR on the class being defined (see \fBCONFIGURING OBJECTS\fR below for a description of the supported values of \fIsubcommand\fR). It follows the same general pattern of argument handling as the \fBoo::define\fR and \fBoo::objdefine\fR commands, and .QW "\fBoo::define \fIcls \fBself \fIsubcommand ...\fR" operates identically to .QW "\fBoo::objdefine \fIcls subcommand ...\fR" . -.RS -.PP -.VS TIP470 -If no arguments at all are used, this gives the name of the class currently -being configured. -.VE TIP470 -.VS TIP500 -If in a private definition context (see the \fBprivate\fR definition command, -below), the definitions on the class object will also be made in a private -definition context. -.VE TIP500 -.RE .TP \fBsuperclass\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR? -. +.VS This slot (see \fBSLOTTED DEFINITIONS\fR below) +.VE allows the alteration of the superclasses of the class being defined. Each \fIclassName\fR argument names one class that is to be a superclass of the defined class. Note that objects must not be changed from being classes to being non-classes or vice-versa, that an empty parent class is equivalent to \fBoo::object\fR, and that the parent classes of \fBoo::object\fR and \fBoo::class\fR may not be modified. +.VS By default, this slot works by replacement. +.VE .TP \fBunexport\fI name \fR?\fIname ...\fR? . This arranges for each of the named methods, \fIname\fR, to be not exported (i.e. not usable outside the instance through the instance object's command, @@ -221,216 +176,28 @@ context) by the class being defined. Note that the methods themselves may be actually defined by a superclass; subclass unexports override superclass visibility, and may be overridden by instance unexports. .TP \fBvariable\fR ?\fI\-slotOperation\fR? ?\fIname ...\fR? -. +.VS This slot (see \fBSLOTTED DEFINITIONS\fR below) arranges for each of the named variables to be automatically made available in the methods, constructor and destructor declared by the class being defined. Each variable name must not have any namespace separators and must not look like an array access. All variables will be -actually present in the namespace of the instance object on which the method -is executed. Note +actually present in the instance object on which the method is executed. Note that the variable lists declared by a superclass or subclass are completely disjoint, as are variable lists declared by instances; the list of variable names is just for methods (and constructors and destructors) declared by this class. By default, this slot works by appending. -.RS -.PP -.VS TIP500 -If in a private definition context (see the \fBprivate\fR definition command, -below), this slot manipulates the list of private variable bindings for this -class. In a private variable binding, the name of the variable within the -instance object is different to the name given in the definition; the name -used in the definition is the name that you use to access the variable within -the methods of this class, and the name of the variable in the instance -namespace has a unique prefix that makes accidental use from other classes -extremely unlikely. -.VE TIP500 -.RE -.SS "ADVANCED CLASS CONFIGURATION OPTIONS" -.PP -The following definitions are also supported, but are not required in simple -programs: -.TP -\fBdefinitionnamespace\fR ?\fIkind\fR? \fInamespaceName\fR -.VS TIP524 -This allows control over what namespace will be used by the \fBoo::define\fR -and \fBoo::objdefine\fR commands to look up the definition commands they -use. When any object has a definition operation applied to it, \fIthe class that -it is an instance of\fR (and its superclasses and mixins) is consulted for -what definition namespace to use. \fBoo::define\fR gets the class definition -namespace, and \fB::oo::objdefine\fR gets the instance definition namespace, -but both otherwise use the identical lookup operation. -.RS -.PP -This sets the definition namespace of kind \fIkind\fR provided by the current -class to \fInamespaceName\fR. The \fInamespaceName\fR must refer to a -currently existing namespace, or must be the empty string (to stop the current -class from having such a namespace connected). The \fIkind\fR, if supplied, -must be either \fB\-class\fR (the default) or \fB\-instance\fR to specify the -whether the namespace for use with \fBoo::define\fR or \fBoo::objdefine\fR -respectively is being set. -.PP -The class \fBoo::object\fR has its instance namespace locked to -\fB::oo::objdefine\fR, and the class \fBoo::class\fR has its class namespace -locked to \fB::oo::define\fR. A consequence of this is that effective use of -this feature for classes requires the definition of a metaclass. -.RE -.VE TIP524 -.TP -\fBdeletemethod\fI name\fR ?\fIname ...\fR? -. -This deletes each of the methods called \fIname\fR from a class. The methods -must have previously existed in that class. Does not affect the superclasses -of the class, nor does it affect the subclasses or instances of the class -(except when they have a call chain through the class being modified) or the -class object itself. -.TP -\fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR? -. -This slot (see \fBSLOTTED DEFINITIONS\fR below) -sets or updates the list of method names that are used to guard whether -method call to instances of the class may be called and what the method's -results are. Each \fImethodName\fR names a single filtering method (which may -be exposed or not exposed); it is not an error for a non-existent method to be -named since they may be defined by subclasses. -By default, this slot works by appending. -.TP -\fBmixin\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR? -. -This slot (see \fBSLOTTED DEFINITIONS\fR below) -sets or updates the list of additional classes that are to be mixed into -all the instances of the class being defined. Each \fIclassName\fR argument -names a single class that is to be mixed in. -By default, this slot works by replacement. -.TP -\fBrenamemethod\fI fromName toName\fR -. -This renames the method called \fIfromName\fR in a class to \fItoName\fR. The -method must have previously existed in the class, and \fItoName\fR must not -previously refer to a method in that class. Does not affect the superclasses -of the class, nor does it affect the subclasses or instances of the class -(except when they have a call chain through the class being modified), or the -class object itself. Does -not change the export status of the method; if it was exported before, it will -be afterwards. -.SH "CONFIGURING OBJECTS" +.VE +.SS "CONFIGURING OBJECTS" .PP The following commands are supported in the \fIdefScript\fR for \fBoo::objdefine\fR, each of which may also be used in the \fIsubcommand\fR form: .TP -\fBexport\fI name \fR?\fIname ...\fR? -. -This arranges for each of the named methods, \fIname\fR, to be exported -(i.e. usable outside the object through the object's command) by the object -being defined. Note that the methods themselves may be actually defined by a -class or superclass; object exports override class visibility. -.TP -\fBforward\fI name cmdName \fR?\fIarg ...\fR? -. -This creates or updates a forwarded object method called \fIname\fR. The -method is defined be forwarded to the command called \fIcmdName\fR, with -additional arguments, \fIarg\fR etc., added before those arguments specified -by the caller of the method. Forwarded methods should be deleted using the -\fBmethod\fR subcommand. The method will be exported if \fIname\fR starts with -a lower-case letter, and non-exported otherwise. -.RS -.PP -.VS TIP500 -If in a private definition context (see the \fBprivate\fR definition command, -below), this command creates private forwarded methods. -.VE TIP500 -.RE -.TP -\fBmethod\fI name \fR?\fIoption\fR? \fIargList bodyScript\fR -. -This creates, updates or deletes an object method. The name of the method is -\fIname\fR, the formal arguments to the method (defined using the same format -as for the Tcl \fBproc\fR command) will be \fIargList\fR, and the body of the -method will be \fIbodyScript\fR. When the body of the method is evaluated, the -current namespace of the method will be a namespace that is unique to the -object. The method will be exported if \fIname\fR starts with a lower-case -letter, and non-exported otherwise; -.VS TIP519 -this can be overridden by specifying \fB\-export\fR, \fB\-private\fR or -\fB\-unexport\fR in the optional parameter \fIoption\fR, or via the -\fBexport\fR and \fBunexport\fR definitions. -.VE TIP519 -.RS -.PP -.VS TIP500 -If in a private definition context (see the \fBprivate\fR definition command, -below) or if the \fB\-private\fR flag is given for \fIoption\fR, this command -creates private procedure-like methods. -.VE TIP500 -.RE -.TP -\fBmixin\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR? -. -This slot (see \fBSLOTTED DEFINITIONS\fR below) -sets or updates a per-object list of additional classes that are to be -mixed into the object. Each argument, \fIclassName\fR, names a single class -that is to be mixed in. -By default, this slot works by replacement. -.TP -\fBprivate \fIcmd arg...\fR -.TP -\fBprivate \fIscript\fR -.VS TIP500 -This evaluates the \fIscript\fR (or the list of command and arguments given by -\fIcmd\fR and \fIarg\fRs) in a context where the definitions made on the -current object will be private definitions. -.RS -.PP -The following class definition commands are affected by \fBprivate\fR: -\fBforward\fR, \fBmethod\fR, and \fBvariable\fR. Nesting \fBprivate\fR inside -\fBprivate\fR has no cumulative effect; the innermost definition context is -just a private definition context. All other definition commands have no -difference in behavior when used in a private definition context. -.RE -.VE TIP500 -.TP -\fBunexport\fI name \fR?\fIname ...\fR? -. -This arranges for each of the named methods, \fIname\fR, to be not exported -(i.e. not usable outside the object through the object's command, but instead -just through the \fBmy\fR command visible in the object's context) by the -object being defined. Note that the methods themselves may be actually defined -by a class; instance unexports override class visibility. -.TP -\fBvariable\fR ?\fI\-slotOperation\fR? ?\fIname ...\fR? -. -This slot (see \fBSLOTTED DEFINITIONS\fR below) arranges for each of the named -variables to be automatically made available in the methods declared by the -object being defined. Each variable name must not have any namespace -separators and must not look like an array access. All variables will be -actually present in the namespace of the object on which the method is -executed. Note that the -variable lists declared by the classes and mixins of which the object is an -instance are completely disjoint; the list of variable names is just for -methods declared by this object. By default, this slot works by appending. -.RS -.PP -.VS TIP500 -If in a private definition context (see the \fBprivate\fR definition command, -below), this slot manipulates the list of private variable bindings for this -object. In a private variable binding, the name of the variable within the -instance object is different to the name given in the definition; the name -used in the definition is the name that you use to access the variable within -the methods of this instance object, and the name of the variable in the -instance namespace has a unique prefix that makes accidental use from -superclass methods extremely unlikely. -.VE TIP500 -.RE -.SS "ADVANCED OBJECT CONFIGURATION OPTIONS" -.PP -The following definitions are also supported, but are not required in simple -programs: -.TP \fBclass\fI className\fR . This allows the class of an object to be changed after creation. Note that the class's constructors are not called when this is done, and so the object may well be in an inconsistent state unless additional configuration work is done. @@ -441,20 +208,60 @@ must have previously existed in that object (e.g., because it was created through \fBoo::objdefine method\fR). Does not affect the classes that the object is an instance of, or remove the exposure of those class-provided methods in the instance of that class. .TP +\fBexport\fI name \fR?\fIname ...\fR? +. +This arranges for each of the named methods, \fIname\fR, to be exported +(i.e. usable outside the object through the object's command) by the object +being defined. Note that the methods themselves may be actually defined by a +class or superclass; object exports override class visibility. +.TP \fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR? -. +.VS This slot (see \fBSLOTTED DEFINITIONS\fR below) +.VE sets or updates the list of method names that are used to guard whether a method call to the object may be called and what the method's results are. Each \fImethodName\fR names a single filtering method (which may be exposed or not exposed); it is not an error for a non-existent method to be named. Note that the actual list of filters also depends on the filters set upon any classes that the object is an instance of. +.VS By default, this slot works by appending. +.VE +.TP +\fBforward\fI name cmdName \fR?\fIarg ...\fR? +. +This creates or updates a forwarded object method called \fIname\fR. The +method is defined be forwarded to the command called \fIcmdName\fR, with +additional arguments, \fIarg\fR etc., added before those arguments specified +by the caller of the method. Forwarded methods should be deleted using the +\fBmethod\fR subcommand. The method will be exported if \fIname\fR starts with +a lower-case letter, and non-exported otherwise. +.TP +\fBmethod\fI name argList bodyScript\fR +. +This creates, updates or deletes an object method. The name of the method is +\fIname\fR, the formal arguments to the method (defined using the same format +as for the Tcl \fBproc\fR command) will be \fIargList\fR, and the body of the +method will be \fIbodyScript\fR. When the body of the method is evaluated, the +current namespace of the method will be a namespace that is unique to the +object. The method will be exported if \fIname\fR starts with a lower-case +letter, and non-exported otherwise. +.TP +\fBmixin\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR? +.VS +This slot (see \fBSLOTTED DEFINITIONS\fR below) +.VE +sets or updates a per-object list of additional classes that are to be +mixed into the object. Each argument, \fIclassName\fR, names a single class +that is to be mixed in. +.VS +By default, this slot works by replacement. +.VE .TP \fBrenamemethod\fI fromName toName\fR . This renames the method called \fIfromName\fR in an object to \fItoName\fR. The method must have previously existed in the object, and \fItoName\fR must @@ -462,55 +269,49 @@ that the object is an instance of and cannot rename in an instance object the methods provided by those classes (though a \fBoo::objdefine forward\fRed method may provide an equivalent capability). Does not change the export status of the method; if it was exported before, it will be afterwards. .TP -\fBself \fR -.VS TIP470 -This gives the name of the object currently being configured. -.VE TIP470 -.SH "PRIVATE METHODS" -.VS TIP500 -When a class or instance has a private method, that private method can only be -invoked from within methods of that class or instance. Other callers of the -object's methods \fIcannot\fR invoke private methods, it is as if the private -methods do not exist. However, a private method of a class \fIcan\fR be -invoked from the class's methods when those methods are being used on another -instance object; this means that a class can use them to coordinate behaviour -between several instances of itself without interfering with how other -classes (especially either subclasses or superclasses) interact. Private -methods precede all mixed in classes in the method call order (as reported by -\fBself call\fR). -.VE TIP500 +\fBunexport\fI name \fR?\fIname ...\fR? +. +This arranges for each of the named methods, \fIname\fR, to be not exported +(i.e. not usable outside the object through the object's command, but instead +just through the \fBmy\fR command visible in the object's context) by the +object being defined. Note that the methods themselves may be actually defined +by a class; instance unexports override class visibility. +.TP +\fBvariable\fR ?\fI\-slotOperation\fR? ?\fIname ...\fR? +.VS +This slot (see \fBSLOTTED DEFINITIONS\fR below) arranges for each of the named +variables to be automatically made available in the methods declared by the +object being defined. Each variable name must not have any namespace +separators and must not look like an array access. All variables will be +actually present in the object on which the method is executed. Note that the +variable lists declared by the classes and mixins of which the object is an +instance are completely disjoint; the list of variable names is just for +methods declared by this object. By default, this slot works by appending. .SH "SLOTTED DEFINITIONS" Some of the configurable definitions of a class or object are \fIslotted definitions\fR. This means that the configuration is implemented by a slot object, that is an instance of the class \fBoo::Slot\fR, which manages a list of values (class names, variable names, etc.) that comprises the contents of -the slot. The class defines five operations (as methods) that may be done on +the slot. The class defines three operations (as methods) that may be done on the slot: +.VE .TP \fIslot\fR \fB\-append\fR ?\fImember ...\fR? -. +.VS This appends the given \fImember\fR elements to the slot definition. +.VE .TP \fIslot\fR \fB\-clear\fR -. +.VS This sets the slot definition to the empty list. -.TP -\fIslot\fR \fB\-prepend\fR ?\fImember ...\fR? -.VS TIP516 -This prepends the given \fImember\fR elements to the slot definition. -.VE TIP516 -.TP -\fIslot\fR \fB\-remove\fR ?\fImember ...\fR? -.VS TIP516 -This removes the given \fImember\fR elements from the slot definition. -.VE TIP516 +.VE .TP \fIslot\fR \fB\-set\fR ?\fImember ...\fR? -. +.VS This replaces the slot definition with the given \fImember\fR elements. .PP A consequence of this is that any use of a slot's default operation where the first member argument begins with a hyphen will be an error. One of the above operations should be used explicitly in those circumstances. @@ -519,78 +320,36 @@ which is forwarded to the default operation of the slot (thus, for the class .QW \fBvariable\fR slot, this is forwarded to .QW "\fBmy \-append\fR" ), and these methods which provide the implementation interface: +.VE .TP \fIslot\fR \fBGet\fR -. -Returns a list that is the current contents of the slot, but does not modify -the slot. This method must always be called from a stack frame created by a -call to \fBoo::define\fR or \fBoo::objdefine\fR. This method \fIshould not\fR -return an error unless it is called from outside a definition context or with -the wrong number of arguments. -.RS -.PP -.VS TIP516 -The elements of the list should be fully resolved, if that is a meaningful -concept to the slot. -.VE TIP516 -.RE -.TP -\fIslot\fR \fBResolve\fR \fIslotElement\fR -.VS TIP516 -Returns \fIslotElement\fR with a resolution operation applied to it, but does -not modify the slot. For slots of simple strings, this is an operation that -does nothing, whereas for slots of classes, this maps a class name to its -fully-qualified class name. This method must always be called from a stack -frame created by a call to \fBoo::define\fR or \fBoo::objdefine\fR. This -method \fIshould not\fR return an error unless it is called from outside a -definition context or with the wrong number of arguments; unresolvable -arguments should be returned as is (as not all slot operations strictly -require that values are resolvable to work). -.RS -.PP -Implementations \fIshould not\fR enforce uniqueness and ordering constraints -in this method; that is the responsibility of the \fBSet\fR method. -.RE -.VE TIP516 +.VS +Returns a list that is the current contents of the slot. This method must +always be called from a stack frame created by a call to \fBoo::define\fR or +\fBoo::objdefine\fR. +.VE .TP \fIslot\fR \fBSet \fIelementList\fR -. +.VS Sets the contents of the slot to the list \fIelementList\fR and returns the empty string. This method must always be called from a stack frame created by -a call to \fBoo::define\fR or \fBoo::objdefine\fR. This method may return an -error if it rejects the change to the slot contents (e.g., because of invalid -values) as well as if it is called from outside a definition context or with -the wrong number of arguments. -.RS -.PP -This method \fImay\fR reorder and filter the elements if this is necessary in -order to satisfy the underlying constraints of the slot. (For example, slots -of classes enforce a uniqueness constraint that places each element in the -earliest location in the slot that it can.) -.RE +a call to \fBoo::define\fR or \fBoo::objdefine\fR. .PP The implementation of these methods is slot-dependent (and responsible for accessing the correct part of the class or object definition). Slots also have an unknown method handler to tie all these pieces together, and they hide their \fBdestroy\fR method so that it is not invoked inadvertently. It is \fIrecommended\fR that any user changes to the slot mechanism be restricted to defining new operations whose names start with a hyphen. -.PP -.VS TIP516 -Most slot operations will initially \fBResolve\fR their argument list, combine -it with the results of the \fBGet\fR method, and then \fBSet\fR the result. -Some operations omit one or both of the first two steps; omitting the third -would result in an idempotent read-only operation (but the standard mechanism -for reading from slots is via \fBinfo class\fR and \fBinfo object\fR). -.VE TIP516 +.VE .SH EXAMPLES This example demonstrates how to use both forms of the \fBoo::define\fR and \fBoo::objdefine\fR commands (they work in the same way), as well as -illustrating four of their subcommands. +illustrating four of the subcommands of them. .PP .CS oo::class create c c create o \fBoo::define\fR c \fBmethod\fR foo {} { @@ -639,145 +398,13 @@ \fBmixin -append\fR B } inst m1 \fI\(-> prints "red brick"\fR inst m2 \fI\(-> prints "blue brick"\fR .CE -.PP -.VS TIP478 -This example shows how to create and use class variables. It is a class that -counts how many instances of itself have been made. -.PP -.CS -oo::class create Counted -\fBoo::define\fR Counted { - \fBinitialise\fR { - variable count 0 - } - - \fBvariable\fR number - \fBconstructor\fR {} { - classvariable count - set number [incr count] - } - - \fBmethod\fR report {} { - classvariable count - puts "This is instance $number of $count" - } -} - -set a [Counted new] -set b [Counted new] -$a report - \fI\(-> This is instance 1 of 2\fR -set c [Counted new] -$b report - \fI\(-> This is instance 2 of 3\fR -$c report - \fI\(-> This is instance 3 of 3\fR -.CE -.PP -This example demonstrates how to use class methods. (Note that the constructor -for \fBoo::class\fR calls \fBoo::define\fR on the class.) -.PP -.CS -oo::class create DBTable { - \fBclassmethod\fR find {description} { - puts "DB: locate row from [self] matching $description" - return [my new] - } - \fBclassmethod\fR insert {description} { - puts "DB: create row in [self] matching $description" - return [my new] - } - \fBmethod\fR update {description} { - puts "DB: update row [self] with $description" - } - \fBmethod\fR delete {} { - puts "DB: delete row [self]" - my destroy; # Just delete the object, not the DB row - } -} - -oo::class create Users { - \fBsuperclass\fR DBTable -} -oo::class create Groups { - \fBsuperclass\fR DBTable -} - -set u1 [Users insert "username=abc"] - \fI\(-> DB: create row from ::Users matching username=abc\fR -set u2 [Users insert "username=def"] - \fI\(-> DB: create row from ::Users matching username=def\fR -$u2 update "group=NULL" - \fI\(-> DB: update row ::oo::Obj124 with group=NULL\fR -$u1 delete - \fI\(-> DB: delete row ::oo::Obj123\fR -set g [Group find "groupname=webadmins"] - \fI\(-> DB: locate row ::Group with groupname=webadmins\fR -$g update "emailaddress=admins" - \fI\(-> DB: update row ::oo::Obj125 with emailaddress=admins\fR -.CE -.VE TIP478 -.PP -.VS TIP524 -This example shows how to make a custom definition for a class. Note that it -explicitly includes delegation to the existing definition commands via -\fBnamespace path\fR. -.PP -.CS -namespace eval myDefinitions { - # Delegate to existing definitions where not overridden - namespace path \fB::oo::define\fR - - # A custom type of method - proc exprmethod {name arguments body} { - tailcall \fBmethod\fR $name $arguments [list expr $body] - } - - # A custom way of building a constructor - proc parameters args { - uplevel 1 [list \fBvariable\fR {*}$args] - set body [join [lmap a $args { - string map [list VAR $a] { - set [my varname VAR] [expr {double($VAR)}] - } - }] ";"] - tailcall \fBconstructor\fR $args $body - } -} - -# Bind the namespace into a (very simple) metaclass for use -oo::class create exprclass { - \fBsuperclass\fR oo::class - \fBdefinitionnamespace\fR myDefinitions -} - -# Use the custom definitions -exprclass create quadratic { - parameters a b c - exprmethod evaluate {x} { - ($a * $x**2) + ($b * $x) + $c - } -} - -# Showing the resulting class and object in action -quadratic create quad 1 2 3 -for {set x 0} {$x <= 4} {incr x} { - puts [format "quad(%d) = %.2f" $x [quad evaluate $x]] -} - \fI\(-> quad(0) = 3.00\fR - \fI\(-> quad(1) = 6.00\fR - \fI\(-> quad(2) = 11.00\fR - \fI\(-> quad(3) = 18.00\fR - \fI\(-> quad(4) = 27.00\fR -.CE -.VE TIP524 .SH "SEE ALSO" next(n), oo::class(n), oo::object(n) .SH KEYWORDS class, definition, method, object, slot .\" Local variables: .\" mode: nroff .\" fill-column: 78 .\" End: Index: doc/dict.n ================================================================== --- doc/dict.n +++ doc/dict.n @@ -25,15 +25,10 @@ This appends the given string (or strings) to the value that the given key maps to in the dictionary value contained in the given variable, writing the resulting dictionary value back to that variable. Non-existent keys are treated as if they map to an empty string. The updated dictionary value is returned. -.VS TIP508 -If \fIdictionaryVarable\fR indicates an element that does not exist of an -array that has a default value set, the default value and will be used as the -value of the dictionary prior to the appending operation. -.VE TIP508 .TP \fBdict create \fR?\fIkey value ...\fR? . Return a new dictionary that contains each of the key/value mappings listed as arguments (keys and values alternating, with each key being @@ -61,11 +56,11 @@ .TP \fBdict filter \fIdictionaryValue \fBscript {\fIkeyVariable valueVariable\fB} \fIscript\fR . The script rule tests for matching by assigning the key to the \fIkeyVariable\fR and the value to the \fIvalueVariable\fR, and then evaluating -the given script which should return a boolean value (with the +the given script which should result in a boolean value (with the key/value pair only being included in the result of the \fBdict filter\fR when a true value is returned.) Note that the first argument after the rule selection word is a two-element list. If the \fIscript\fR returns with a condition of \fBTCL_BREAK\fR, no further key/value pairs are considered for inclusion in the resulting @@ -118,40 +113,19 @@ .PP It is an error to attempt to retrieve a value for a key that is not present in the dictionary. .RE .TP -\fBdict getdef \fIdictionaryValue \fR?\fIkey ...\fR? \fIkey default\fR -.TP -\fBdict getwithdefault \fIdictionaryValue \fR?\fIkey ...\fR? \fIkey default\fR -.VS "8.7, TIP342" -This behaves the same as \fBdict get\fR (with at least one \fIkey\fR -argument), returning the value that the key path maps to in the -dictionary \fIdictionaryValue\fR, except that instead of producing an -error because the \fIkey\fR (or one of the \fIkey\fRs on the key path) -is absent, it returns the \fIdefault\fR argument instead. -.RS -.PP -Note that there must always be at least one \fIkey\fR provided, and that -\fBdict getdef\fR and \fBdict getwithdefault\fR are aliases for each other. -.RE -.VE "8.7, TIP342" -.TP \fBdict incr \fIdictionaryVariable key \fR?\fIincrement\fR? . This adds the given increment value (an integer that defaults to 1 if not specified) to the value that the given key maps to in the dictionary value contained in the given variable, writing the resulting dictionary value back to that variable. Non-existent keys are treated as if they map to 0. It is an error to increment a value for an existing key if that value is not an integer. The updated dictionary value is returned. -.VS TIP508 -If \fIdictionaryVarable\fR indicates an element that does not exist of an -array that has a default value set, the default value and will be used as the -value of the dictionary prior to the incrementing operation. -.VE TIP508 .TP \fBdict info \fIdictionaryValue\fR . This returns information (intended for display to people) about the given dictionary though the format of this data is dependent on the @@ -173,15 +147,10 @@ the resulting dictionary value back to that variable. Non-existent keys are treated as if they map to an empty list, and it is legal for there to be no items to append to the list. It is an error for the value that the key maps to to not be representable as a list. The updated dictionary value is returned. -.VS TIP508 -If \fIdictionaryVarable\fR indicates an element that does not exist of an -array that has a default value set, the default value and will be used as the -value of the dictionary prior to the list-appending operation. -.VE TIP508 .TP \fBdict map \fR{\fIkeyVariable valueVariable\fR} \fIdictionaryValue body\fR . This command applies a transformation to each element of a dictionary, returning a new dictionary. It takes three arguments: the first is a @@ -235,15 +204,10 @@ This operation takes the name of a variable containing a dictionary value and places an updated dictionary value in that variable containing a mapping from the given key to the given value. When multiple keys are present, this operation creates or updates a chain of nested dictionaries. The updated dictionary value is returned. -.VS TIP508 -If \fIdictionaryVarable\fR indicates an element that does not exist of an -array that has a default value set, the default value and will be used as the -value of the dictionary prior to the value insert/update operation. -.VE TIP508 .TP \fBdict size \fIdictionaryValue\fR . Return the number of key/value mappings in the given dictionary value. .TP @@ -255,15 +219,10 @@ the given key. Where multiple keys are present, this describes a path through nested dictionaries to the mapping to remove. At least one key must be specified, but the last key on the key-path need not exist. All other components on the path must exist. The updated dictionary value is returned. -.VS TIP508 -If \fIdictionaryVarable\fR indicates an element that does not exist of an -array that has a default value set, the default value and will be used as the -value of the dictionary prior to the value remove operation. -.VE TIP508 .TP \fBdict update \fIdictionaryVariable key varName \fR?\fIkey varName ...\fR? \fIbody\fR . Execute the Tcl script in \fIbody\fR with the value for each \fIkey\fR (as found by reading the dictionary value in \fIdictionaryVariable\fR) @@ -275,15 +234,10 @@ \fIdictionaryVariable\fR itself becomes unreadable, when all updates are silently discarded), even if the result of \fIbody\fR is an error or some other kind of exceptional exit. The result of \fBdict update\fR is (unless some kind of error occurs) the result of the evaluation of \fIbody\fR. -.VS TIP508 -If \fIdictionaryVarable\fR indicates an element that does not exist of an -array that has a default value set, the default value and will be used as the -value of the dictionary prior to the update operation. -.VE TIP508 .RS .PP Each \fIvarName\fR is mapped in the scope enclosing the \fBdict update\fR; it is recommended that this command only be used in a local scope (\fBproc\fRedure, lambda term for \fBapply\fR, or method). Because of @@ -314,15 +268,10 @@ dictionary be discarded, and this also happens if the contents of \fIdictionaryVariable\fR are adjusted so that the chain of dictionaries no longer exists. The result of \fBdict with\fR is (unless some kind of error occurs) the result of the evaluation of \fIbody\fR. -.VS TIP508 -If \fIdictionaryVarable\fR indicates an element that does not exist of an -array that has a default value set, the default value and will be used as the -value of the dictionary prior to the updating operation. -.VE TIP508 .RS .PP The variables are mapped in the scope enclosing the \fBdict with\fR; it is recommended that this command only be used in a local scope (\fBproc\fRedure, lambda term for \fBapply\fR, or method). Because of Index: doc/eof.n ================================================================== --- doc/eof.n +++ doc/eof.n @@ -57,9 +57,5 @@ .CE .SH "SEE ALSO" file(n), open(n), close(n), fblocked(n), Tcl_StandardChannels(3) .SH KEYWORDS channel, end of file -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/exit.n ================================================================== --- doc/exit.n +++ doc/exit.n @@ -47,9 +47,5 @@ .CE .SH "SEE ALSO" exec(n) .SH KEYWORDS abort, exit, process -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/expr.n ================================================================== --- doc/expr.n +++ doc/expr.n @@ -15,310 +15,322 @@ .SH SYNOPSIS \fBexpr \fIarg \fR?\fIarg arg ...\fR? .BE .SH DESCRIPTION .PP -Concatenates \fIarg\fRs, separated by a space, into an expression, and evaluates -that expression, returning its value. -The operators permitted in an expression include a subset of +Concatenates \fIarg\fRs (adding separator spaces between them), +evaluates the result as a Tcl expression, and returns the value. +The operators permitted in Tcl expressions include a subset of the operators permitted in C expressions. For those operators common to both Tcl and C, Tcl applies the same meaning and precedence as the corresponding C operators. -The value of an expression is often a numeric result, either an integer or a -floating-point value, but may also be a non-numeric value. +Expressions almost always yield numeric results +(integer or floating-point values). For example, the expression .PP .CS \fBexpr\fR 8.2 + 6 .CE .PP evaluates to 14.2. -Expressions differ from C expressions in the way that -operands are specified. Expressions also support -non-numeric operands, string comparisons, and some +Tcl expressions differ from C expressions in the way that +operands are specified. Also, Tcl expressions support +non-numeric operands and string comparisons, as well as some additional operators not found in C. -.PP -When an expression evaluates to an integer, the value is the decimal form of -the integer, and when an expression evaluates to a floating-point number, the -value is the form produced by the \fB%g\fR format specifier of Tcl's -\fBformat\fR command. .SS OPERANDS .PP -An expression consists of a combination of operands, operators, parentheses and -commas, possibly with whitespace between any of these elements, which is -ignored. -An integer operand may be specified in decimal (the normal case, the optional -first two characters are \fB0d\fR), binary -(the first two characters are \fB0b\fR), octal -(the first two characters are \fB0o\fR), or hexadecimal -(the first two characters are \fB0x\fR) form. -A floating-point number may be specified in any of several -common decimal formats, and may use the decimal point \fB.\fR, -\fBe\fR or \fBE\fR for scientific notation, and -the sign characters \fB+\fR and \fB\-\fR. The -following are all valid floating-point numbers: 2.1, 3., 6e4, 7.91e+16. -The strings \fBInf\fR -and \fBNaN\fR, in any combination of case, are also recognized as floating point -values. An operand that doesn't have a numeric interpretation must be quoted -with either braces or with double quotes. +A Tcl expression consists of a combination of operands, operators, +parentheses and commas. +White space may be used between the operands and operators and +parentheses (or commas); it is ignored by the expression's instructions. +Where possible, operands are interpreted as integer values. +Integer values may be specified in decimal (the normal case), in binary +(if the first two characters of the operand are \fB0b\fR), in octal +(if the first two characters of the operand are \fB0o\fR), or in hexadecimal +(if the first two characters of the operand are \fB0x\fR). For +compatibility with older Tcl releases, an octal integer value is also +indicated simply when the first character of the operand is \fB0\fR, +whether or not the second character is also \fBo\fR. +If an operand does not have one of the integer formats given +above, then it is treated as a floating-point number if that is +possible. Floating-point numbers may be specified in any of several +common formats making use of the decimal digits, the decimal point \fB.\fR, +the characters \fBe\fR or \fBE\fR indicating scientific notation, and +the sign characters \fB+\fR or \fB\-\fR. For example, all of the +following are valid floating-point numbers: 2.1, 3., 6e4, 7.91e+16. +Also recognized as floating point values are the strings \fBInf\fR +and \fBNaN\fR making use of any case for each character. +If no numeric interpretation is possible (note that all literal +operands that are not numeric or boolean must be quoted with either +braces or with double quotes), then an operand is left as a string +(and only a limited set of operators may be applied to it). .PP -An operand may be specified in any of the following ways: +Operands may be specified in any of the following ways: .IP [1] As a numeric value, either integer or floating-point. .IP [2] As a boolean value, using any form understood by \fBstring is\fR \fBboolean\fR. .IP [3] -As a variable, using standard \fB$\fR notation. -The value of the variable is then the value of the operand. +As a Tcl variable, using standard \fB$\fR notation. +The variable's value will be used as the operand. .IP [4] As a string enclosed in double-quotes. -Backslash, variable, and command substitution are performed as described in -\fBTcl\fR. +The expression parser will perform backslash, variable, and +command substitutions on the information between the quotes, +and use the resulting value as the operand .IP [5] As a string enclosed in braces. -The operand is treated as a braced value as described in \fBTcl\fR. +The characters between the open brace and matching close brace +will be used as the operand without any substitutions. .IP [6] As a Tcl command enclosed in brackets. -Command substitution is performed as described in \fBTcl\fR. +The command will be executed and its result will be used as +the operand. .IP [7] -As a mathematical function such as \fBsin($x)\fR, whose arguments have any of the above -forms for operands. See \fBMATH FUNCTIONS\fR below for +As a mathematical function whose arguments have any of the above +forms for operands, such as \fBsin($x)\fR. See \fBMATH FUNCTIONS\fR below for a discussion of how mathematical functions are handled. .PP -Because \fBexpr\fR parses and performs substitutions on values that have -already been parsed and substituted by \fBTcl\fR, it is usually best to enclose -expressions in braces to avoid the first round of substitutions by -\fBTcl\fR. +Where the above substitutions occur (e.g. inside quoted strings), they +are performed by the expression's instructions. +However, the command parser may already have performed one round of +substitution before the expression processor was called. +As discussed below, it is usually best to enclose expressions +in braces to prevent the command parser from performing substitutions +on the contents. .PP -Below are some examples of simple expressions where the value of \fBa\fR is 3 -and the value of \fBb\fR is 6. The command on the left side of each line -produces the value on the right side. +For some examples of simple expressions, suppose the variable +\fBa\fR has the value 3 and +the variable \fBb\fR has the value 6. +Then the command on the left side of each of the lines below +will produce the value on the right side of the line: .PP .CS .ta 9c -\fBexpr\fR 3.1 + $a \fI6.1\fR -\fBexpr\fR 2 + "$a.$b" \fI5.6\fR -\fBexpr\fR 4*[llength "6 2"] \fI8\fR +\fBexpr\fR {3.1 + $a} \fI6.1\fR +\fBexpr\fR {2 + "$a.$b"} \fI5.6\fR +\fBexpr\fR {4*[llength "6 2"]} \fI8\fR \fBexpr\fR {{word one} < "word $a"} \fI0\fR .CE .SS OPERATORS .PP -For operators having both a numeric mode and a string mode, the numeric mode is -chosen when all operands have a numeric interpretation. The integer -interpretation of an operand is preferred over the floating-point -interpretation. To ensure string operations on arbitrary values it is generally a -good idea to use \fBeq\fR, \fBne\fR, or the \fBstring\fR command instead of -more versatile operators such as \fB==\fR. -.PP -Unless otherwise specified, operators accept non-numeric operands. The value -of a boolean operation is 1 if true, 0 otherwise. See also \fBstring is\fR -\fBboolean\fR. The valid operators, most of which are also available as -commands in the \fBtcl::mathop\fR namespace (see \fBmathop\fR(n)), are listed -below, grouped in decreasing order of precedence: +The valid operators (most of which are also available as commands in +the \fBtcl::mathop\fR namespace; see the \fBmathop\fR(n) manual page +for details) are listed below, grouped in decreasing order of precedence: .TP 20 \fB\-\0\0+\0\0~\0\0!\fR . -Unary minus, unary plus, bit-wise NOT, logical NOT. These operators -may only be applied to numeric operands, and bit-wise NOT may only be -applied to integers. +Unary minus, unary plus, bit-wise NOT, logical NOT. None of these operators +may be applied to string operands, and bit-wise NOT may be +applied only to integers. .TP 20 \fB**\fR . -Exponentiation. Valid for numeric operands. The maximum exponent value +Exponentiation. Valid for any numeric operands. The maximum exponent value that Tcl can handle if the first number is an integer > 1 is 268435455. .TP 20 \fB*\0\0/\0\0%\fR . -Multiply and divide, which are valid for numeric operands, and remainder, which -is valid for integers. The remainder, an absolute value smaller than the -absolute value of the divisor, has the same sign as the divisor. +Multiply, divide, remainder. None of these operators may be +applied to string operands, and remainder may be applied only +to integers. +The remainder will always have the same sign as the divisor and +an absolute value smaller than the absolute value of the divisor. .RS .PP -When applied to integers, division and remainder can be -considered to partition the number line into a sequence of -adjacent non-overlapping pieces, where each piece is the size of the divisor; -the quotient identifies which piece the dividend lies within, and the -remainder identifies where within that piece the dividend lies. A +When applied to integers, the division and remainder operators can be +considered to partition the number line into a sequence of equal-sized +adjacent non-overlapping pieces where each piece is the size of the divisor; +the division result identifies which piece the divisor lay within, and the +remainder result identifies where within that piece the divisor lay. A consequence of this is that the result of .QW "-57 \fB/\fR 10" is always -6, and the result of .QW "-57 \fB%\fR 10" is always 3. .RE .TP 20 \fB+\0\0\-\fR . -Add and subtract. Valid for numeric operands. +Add and subtract. Valid for any numeric operands. .TP 20 \fB<<\0\0>>\fR . -Left and right shift. Valid for integers. +Left and right shift. Valid for integer operands only. A right shift always propagates the sign bit. .TP 20 \fB<\0\0>\0\0<=\0\0>=\fR . -Boolean numeric-preferring comparisons: less than, greater than, less than or -equal, and greater than or equal. If either argument is not numeric, the -comparison is done using UNICODE string comparison, as with the string -comparison operators below, which have the same precedence. -.TP 20 -\fBlt\0\0gt\0\0le\0\0ge\fR -.VS "8.7, TIP461" -Boolean string comparisons: less than, greater than, less than or equal, and -greater than or equal. These always compare values using their UNICODE strings -(also see \fBstring compare\fR), unlike with the numeric-preferring -comparisons abov, which have the same precedence. -.VE "8.7, TIP461" +Boolean less, greater, less than or equal, and greater than or equal. +Each operator produces 1 if the condition is true, 0 otherwise. +These operators may be applied to strings as well as numeric operands, +in which case string comparison is used. .TP 20 \fB==\0\0!=\fR . -Boolean equal and not equal. +Boolean equal and not equal. Each operator produces a zero/one result. +Valid for all operand types. .TP 20 \fBeq\0\0ne\fR . -Boolean string equal and string not equal. +Boolean string equal and string not equal. Each operator produces a +zero/one result. The operand types are interpreted only as strings. .TP 20 \fBin\0\0ni\fR . -List containment and negated list containment. The first argument is -interpreted as a string, the second as a list. \fBin\fR tests for membership -in the list, and \fBni\fR is the inverse. +List containment and negated list containment. Each operator produces +a zero/one result and treats its first argument as a string and its +second argument as a Tcl list. The \fBin\fR operator indicates +whether the first argument is a member of the second argument list; +the \fBni\fR operator inverts the sense of the result. .TP 20 \fB&\fR . -Bit-wise AND. Valid for integer operands. +Bit-wise AND. Valid for integer operands only. .TP 20 \fB^\fR . -Bit-wise exclusive OR. Valid for integer operands. +Bit-wise exclusive OR. Valid for integer operands only. .TP 20 \fB|\fR . -Bit-wise OR. Valid for integer operands. +Bit-wise OR. Valid for integer operands only. .TP 20 \fB&&\fR . -Logical AND. If both operands are true, the result is 1, or 0 otherwise. -This operator evaluates lazily; it only evaluates its second operand if it -must in order to determine its result. +Logical AND. Produces a 1 result if both operands are non-zero, +0 otherwise. +Valid for boolean and numeric (integers or floating-point) operands only. This operator evaluates lazily; it only evaluates its second operand if it must in order to determine its result. .TP 20 \fB||\fR . -Logical OR. If both operands are false, the result is 0, or 1 otherwise. +Logical OR. Produces a 0 result if both operands are zero, 1 otherwise. +Valid for boolean and numeric (integers or floating-point) operands only. This operator evaluates lazily; it only evaluates its second operand if it must in order to determine its result. .TP 20 \fIx \fB?\fI y \fB:\fI z\fR . -If-then-else, as in C. If \fIx\fR is false , the result is the value of -\fIy\fR. Otherwise the result is the value of \fIz\fR. +If-then-else, as in C. If \fIx\fR +evaluates to non-zero, then the result is the value of \fIy\fR. +Otherwise the result is the value of \fIz\fR. +The \fIx\fR operand must have a boolean or numeric value. This operator evaluates lazily; it evaluates only one of \fIy\fR or \fIz\fR. .PP -The exponentiation operator promotes types in the same way that the multiply -and divide operators do, and the result is is the same as the result of -\fBpow\fR. -Exponentiation groups right-to-left within a precedence level. Other binary -operators group left-to-right. For example, the value of +See the C manual for more details on the results +produced by each operator. +The exponentiation operator promotes types like the multiply and +divide operators, and produces a result that is the same as the output +of the \fBpow\fR function (after any type conversions.) +All of the binary operators but exponentiation group left-to-right +within the same precedence level; exponentiation groups right-to-left. For example, the command .PP .PP .CS \fBexpr\fR {4*2 < 7} .CE .PP -is 0, while the value of +returns 0, while .PP .CS \fBexpr\fR {2**3**2} .CE .PP -is 512. +returns 512. .PP -As in C, \fB&&\fR, \fB||\fR, and \fB?:\fR feature +The \fB&&\fR, \fB||\fR, and \fB?:\fR operators have .QW "lazy evaluation" , -which means that operands are not evaluated if they are -not needed to determine the outcome. For example, in +just as in C, which means that operands are not evaluated if they are +not needed to determine the outcome. For example, in the command .PP .CS -\fBexpr\fR {$v ? [a] : [b]} +\fBexpr\fR {$v?[a]:[b]} .CE .PP -only one of \fB[a]\fR or \fB[b]\fR is evaluated, -depending on the value of \fB$v\fR. This is not true of the normal Tcl parser, -so it is normally recommended to enclose the arguments to \fBexpr\fR in braces. -Without braces, as in -\fBexpr\fR $v ? [a] : [b] -both \fB[a]\fR and \fB[b]\fR are evaluated before \fBexpr\fR is even called. -.PP -For more details on the results -produced by each operator, see the documentation for C. +only one of +.QW \fB[a]\fR +or +.QW \fB[b]\fR +will actually be evaluated, +depending on the value of \fB$v\fR. Note, however, that this is +only true if the entire expression is enclosed in braces; otherwise +the Tcl parser will evaluate both +.QW \fB[a]\fR +and +.QW \fB[b]\fR +before invoking the \fBexpr\fR command. .SS "MATH FUNCTIONS" .PP -A mathematical function such as \fBsin($x)\fR is replaced with a call to an ordinary -Tcl command in the \fBtcl::mathfunc\fR namespace. The evaluation -of an expression such as +When the expression parser encounters a mathematical function +such as \fBsin($x)\fR, it replaces it with a call to an ordinary +Tcl command in the \fBtcl::mathfunc\fR namespace. The processing +of an expression such as: .PP .CS \fBexpr\fR {sin($x+$y)} .CE .PP -is the same in every way as the evaluation of +is the same in every way as the processing of: .PP .CS \fBexpr\fR {[tcl::mathfunc::sin [\fBexpr\fR {$x+$y}]]} .CE .PP -which in turn is the same as the evaluation of +which in turn is the same as the processing of: .PP .CS tcl::mathfunc::sin [\fBexpr\fR {$x+$y}] .CE .PP -\fBtcl::mathfunc::sin\fR is resolved as described in -\fBNAMESPACE RESOLUTION\fR in the \fBnamespace\fR(n) documentation. Given the -default value of \fBnamespace path\fR, \fB[namespace -current]::tcl::mathfunc::sin\fR or \fB::tcl::mathfunc::sin\fR are the typical -resolutions. +The executor will search for \fBtcl::mathfunc::sin\fR using the usual +rules for resolving functions in namespaces. Either +\fB::tcl::mathfunc::sin\fR or \fB[namespace +current]::tcl::mathfunc::sin\fR will satisfy the request, and others +may as well (depending on the current \fBnamespace path\fR setting). .PP -As in C, a mathematical function may accept multiple arguments separated by commas. Thus, +Some mathematical functions have several arguments, separated by commas like in C. Thus: .PP .CS \fBexpr\fR {hypot($x,$y)} .CE .PP -becomes +ends up as .PP .CS tcl::mathfunc::hypot $x $y .CE .PP -See the \fBmathfunc\fR(n) documentation for the math functions that are +See the \fBmathfunc\fR(n) manual page for the math functions that are available by default. .SS "TYPES, OVERFLOW, AND PRECISION" .PP -When needed to guarantee exact performance, internal computations involving -integers use the LibTomMath multiple precision integer library. In Tcl releases -prior to 8.5, integer calculations were performed using one of the C types +All internal computations involving integers are done calling on the +LibTomMath multiple precision integer library as required so that all +integer calculations are performed exactly. Note that in Tcl releases +prior to 8.5, integer calculations were performed with one of the C types \fIlong int\fR or \fITcl_WideInt\fR, causing implicit range truncation in those calculations where values overflowed the range of those types. -Any code that relied on these implicit truncations should instead call -\fBint()\fR or \fBwide()\fR, which do truncate. +Any code that relied on these implicit truncations will need to explicitly +add \fBint()\fR or \fBwide()\fR function calls to expressions at the points +where such truncation is required to take place. .PP -Internal floating-point computations are -performed using the \fIdouble\fR C type. -When converting a string to floating-point value, exponent overflow is +All internal computations involving floating-point are +done with the C type \fIdouble\fR. +When converting a string to floating-point, exponent overflow is detected and results in the \fIdouble\fR value of \fBInf\fR or \fB\-Inf\fR as appropriate. Floating-point overflow and underflow are detected to the degree supported by the hardware, which is generally -fairly reliable. +pretty reliable. .PP -Conversion among internal representations for integer, floating-point, and -string operands is done automatically as needed. For arithmetic computations, -integers are used until some floating-point number is introduced, after which -floating-point values are used. For example, +Conversion among internal representations for integer, floating-point, +and string operands is done automatically as needed. +For arithmetic computations, integers are used until some +floating-point number is introduced, after which floating-point is used. +For example, .PP .CS \fBexpr\fR {5 / 4} .CE .PP @@ -328,58 +340,83 @@ \fBexpr\fR {5 / 4.0} \fBexpr\fR {5 / ( [string length "abcd"] + 0.0 )} .CE .PP both return 1.25. -A floating-point result can be distinguished from an integer result by the -presence of either +Floating-point values are always returned with a .QW \fB.\fR -or +or an .QW \fBe\fR -.PP -. For example, +so that they will not look like integer values. For example, .PP .CS \fBexpr\fR {20.0/5.0} .CE .PP returns \fB4.0\fR, not \fB4\fR. +.SS "STRING OPERATIONS" +.PP +String values may be used as operands of the comparison operators, +although the expression evaluator tries to do comparisons as integer +or floating-point when it can, +i.e., when all arguments to the operator allow numeric interpretations, +except in the case of the \fBeq\fR and \fBne\fR operators. +If one of the operands of a comparison is a string and the other +has a numeric value, a canonical string representation of the numeric +operand value is generated to compare with the string operand. +Canonical string representation for integer values is a decimal string +format. Canonical string representation for floating-point values +is that produced by the \fB%g\fR format specifier of Tcl's +\fBformat\fR command. For example, the commands +.PP +.CS +\fBexpr\fR {"0x03" > "2"} +\fBexpr\fR {"0y" > "0x12"} +.CE +.PP +both return 1. The first comparison is done using integer +comparison, and the second is done using string comparison. +Because of Tcl's tendency to treat values as numbers whenever +possible, it is not generally a good idea to use operators like \fB==\fR +when you really want string comparison and the values of the +operands could be arbitrary; it is better in these cases to use +the \fBeq\fR or \fBne\fR operators, or the \fBstring\fR command instead. .SH "PERFORMANCE CONSIDERATIONS" .PP -Where an expression contains syntax that Tcl would otherwise perform -substitutions on, enclosing an expression in braces or otherwise quoting it -so that it's a static value allows the Tcl compiler to generate bytecode for -the expression, resulting in better speed and smaller storage requirements. -This also avoids issues that can arise if Tcl is allowed to perform -substitution on the value before \fBexpr\fR is called. +Enclose expressions in braces for the best speed and the smallest +storage requirements. +This allows the Tcl bytecode compiler to generate the best code. .PP -In the following example, the value of the expression is 11 because the Tcl parser first -substitutes \fB$b\fR and \fBexpr\fR then substitutes \fB$a\fR as part -of evaluating the expression -.QW "$a + 2*4" . -Enclosing the -expression in braces would result in a syntax error as \fB$b\fR does -not evaluate to a numeric value. +As mentioned above, expressions are substituted twice: +once by the Tcl parser and once by the \fBexpr\fR command. +For example, the commands .PP .CS set a 3 set b {$a + 2} \fBexpr\fR $b*4 .CE .PP -When an expression is generated at runtime, like the one above is, the bytecode -compiler must ensure that new code is generated each time the expression -is evaluated. This is the most costly kind of expression from a performance -perspective. In such cases, consider directly using the commands described in -the \fBmathfunc\fR(n) or \fBmathop\fR(n) documentation instead of \fBexpr\fR. +return 11, not a multiple of 4. +This is because the Tcl parser will first substitute +.QW "\fB$a + 2\fR" +for the variable \fBb\fR, +then the \fBexpr\fR command will evaluate the expression +.QW "\fB$a + 2*4\fR" . .PP -Most expressions are not formed at runtime, but are literal strings or contain -substitutions that don't introduce other substitutions. To allow the bytecode -compiler to work with an expression as a string literal at compilation time, -ensure that it contains no substitutions or that it is enclosed in braces or -otherwise quoted to prevent Tcl from performing substitutions, allowing -\fBexpr\fR to perform them instead. +Most expressions do not require a second round of substitutions. +Either they are enclosed in braces or, if not, +their variable and command substitutions yield numbers or strings +that do not themselves require substitutions. +However, because a few unbraced expressions +need two rounds of substitutions, +the bytecode compiler must emit +additional instructions to handle this situation. +The most expensive code is required for +unbraced expressions that contain command substitutions. +These expressions must be implemented by generating new code +each time the expression is executed. .PP If it is necessary to include a non-constant expression string within the wider context of an otherwise-constant expression, the most efficient technique is to put the varying part inside a recursive \fBexpr\fR, as this at least allows for the compilation of the outer part, though it does mean that @@ -391,37 +428,15 @@ set a 3 set b {$a + 2} \fBexpr\fR {[\fBexpr\fR $b] * 4} .CE .PP -In general, you should enclose your expression in braces wherever possible, -and where not possible, the argument to \fBexpr\fR should be an expression -defined elsewhere as simply as possible. It is usually more efficient and -safer to use other techniques (e.g., the commands in the \fBtcl::mathop\fR -namespace) than it is to do complex expression generation. +When the expression is unbraced to allow the substitution of a function or +operator, consider using the commands documented in the \fBmathfunc\fR(n) or +\fBmathop\fR(n) manual pages directly instead. .SH EXAMPLES .PP -A numeric comparison whose result is 1: -.PP -.CS -\fBexpr\fR {"0x03" > "2"} -.CE -.PP -A string comparison whose result is 1: -.PP -.CS -\fBexpr\fR {"0y" > "0x12"} -.CE -.PP -.VS "8.7, TIP461" -A forced string comparison whose result is 0: -.PP -.CS -\fBexpr\fR {"0x03" gt "2"} -.CE -.VE "8.7, TIP461" -.PP Define a procedure that computes an .QW interesting mathematical function: .PP .CS @@ -451,12 +466,12 @@ .PP .CS puts "a and b are [\fBexpr\fR {$a eq $b ? {equal} : {different}}]" .CE .PP -Set a variable indicating whether an environment variable is defined and has -value of true: +Set a variable to whether an environment variable is both defined at +all and also set to a true boolean value: .PP .CS set isTrue [\fBexpr\fR { [info exists ::env(SOME_ENV_VAR)] && [string is true -strict $::env(SOME_ENV_VAR)] @@ -473,12 +488,13 @@ string(n), Tcl(n), while(n) .SH KEYWORDS arithmetic, boolean, compare, expression, fuzzy comparison .SH COPYRIGHT .nf -Copyright \(co 1993 The Regents of the University of California. -Copyright \(co 1994-2000 Sun Microsystems Incorporated. -Copyright \(co 2005 by Kevin B. Kenny . All rights reserved. +Copyright (c) 1993 The Regents of the University of California. +Copyright (c) 1994-2000 Sun Microsystems Incorporated. +Copyright (c) 2005 by Kevin B. Kenny . All rights reserved. .fi '\" Local Variables: '\" mode: nroff +'\" fill-column: 78 '\" End: Index: doc/fblocked.n ================================================================== --- doc/fblocked.n +++ doc/fblocked.n @@ -63,9 +63,5 @@ .CE .SH "SEE ALSO" gets(n), open(n), read(n), socket(n), Tcl_StandardChannels(3) .SH KEYWORDS blocking, nonblocking -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/file.n ================================================================== --- doc/file.n +++ doc/file.n @@ -388,11 +388,11 @@ to ensure that later commands that use the third component do not attempt to perform tilde substitution. .RE .TP -\fBfile stat \fIname varName\fR +\fBfile stat \fIname varName\fR . Invokes the \fBstat\fR kernel call on \fIname\fR, and uses the variable given by \fIvarName\fR to hold information returned from the kernel call. \fIVarName\fR is treated as an array variable, and the following elements of that variable are set: \fBatime\fR, \fBctime\fR, \fBdev\fR, \fBgid\fR, @@ -431,40 +431,10 @@ \fIname\fR. Any trailing directory separator in \fIname\fR is ignored. If \fIname\fR contains no separators then returns \fIname\fR. So, \fBfile tail a/b\fR, \fBfile tail a/b/\fR and \fBfile tail b\fR all return \fBb\fR. .TP -\fBfile tempdir\fR ?\fItemplate\fR? -.VS "8.7, TIP 431" -Creates a temporary directory (guaranteed to be newly created and writable by -the current script) and returns its name. If \fItemplate\fR is given, it -specifies one of or both of the existing directory (on a filesystem controlled -by the operating system) to contain the temporary directory, and the base part -of the directory name; it is considered to have the location of the directory -if there is a directory separator in the name, and the base part is everything -after the last directory separator (if non-empty). The default containing -directory is determined by system-specific operations, and the default base -name prefix is -.QW \fBtcl\fR . -.RS -.PP -The following output is typical and illustrative; the actual output will vary -between platforms: -.PP -.CS -% \fBfile tempdir\fR -/var/tmp/tcl_u0kuy5 - % \fBfile tempdir\fR /tmp/myapp -/tmp/myapp_8o7r9L -% \fBfile tempdir\fR /tmp/ -/tmp/tcl_1mOJHD -% \fBfile tempdir\fR myapp -/var/tmp/myapp_0ihS0n -.CE -.RE -.VE "8.7, TIP 431" -.TP \fBfile tempfile\fR ?\fInameVar\fR? ?\fItemplate\fR? '\" TIP #210 .VS 8.6 Creates a temporary file and returns a read-write channel opened on that file. If the \fInameVar\fR is given, it specifies a variable that the name of the Index: doc/fileevent.n ================================================================== --- doc/fileevent.n +++ doc/fileevent.n @@ -152,9 +152,5 @@ .SH "SEE ALSO" fconfigure(n), gets(n), interp(n), puts(n), read(n), Tcl_StandardChannels(3) .SH KEYWORDS asynchronous I/O, blocking, channel, event handler, nonblocking, readable, script, writable. -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/filename.n ================================================================== --- doc/filename.n +++ doc/filename.n @@ -174,9 +174,5 @@ .SH "SEE ALSO" file(n), glob(n) .SH KEYWORDS current directory, absolute file name, relative file name, volume-relative file name, portability -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/flush.n ================================================================== --- doc/flush.n +++ doc/flush.n @@ -41,9 +41,5 @@ .CE .SH "SEE ALSO" file(n), open(n), socket(n), Tcl_StandardChannels(3) .SH KEYWORDS blocking, buffer, channel, flush, nonblocking, output -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/foreach.n ================================================================== --- doc/foreach.n +++ doc/foreach.n @@ -100,9 +100,5 @@ .SH "SEE ALSO" for(n), while(n), break(n), continue(n) .SH KEYWORDS foreach, iteration, list, loop -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/format.n ================================================================== --- doc/format.n +++ doc/format.n @@ -81,19 +81,16 @@ \fB0\fR Specifies that the number should be padded on the left with zeroes instead of spaces. .TP 10 \fB#\fR -Requests an alternate output form. For \fBo\fR conversions, -\fB0o\fR will be added to the beginning of the result unless -it is zero. For \fBx\fR or \fBX\fR conversions, \fB0x\fR +Requests an alternate output form. For \fBo\fR +conversions it guarantees that the first digit is always \fB0\fR. +For \fBx\fR or \fBX\fR conversions, \fB0x\fR or \fB0X\fR (respectively) will be added to the beginning of the result unless it is zero. For \fBb\fR conversions, \fB0b\fR will be added to the beginning of the result unless it is zero. -For \fBd\fR conversions, \fB0d\fR there is no effect unless -the \fB0\fR specifier is used as well: In that case, \fB0d\fR -will be added to the beginning. For all floating-point conversions (\fBe\fR, \fBE\fR, \fBf\fR, \fBg\fR, and \fBG\fR) it guarantees that the result always has a decimal point. For \fBg\fR and \fBG\fR conversions it specifies that trailing zeroes should not be removed. @@ -131,21 +128,19 @@ then the next argument to the \fBformat\fR command determines the precision; it must be a numeric string. .SS "OPTIONAL SIZE MODIFIER" .PP The fifth part of a conversion specifier is a size modifier, -which must be \fBll\fR, \fBh\fR, \fBl\fR, or \fBL\fR. +which must be \fBll\fR, \fBh\fR, or \fBl\fR. If it is \fBll\fR it specifies that an integer value is taken without truncation for conversion to a formatted substring. If it is \fBh\fR it specifies that an integer value is truncated to a 16-bit range before converting. This option is rarely useful. If it is \fBl\fR it specifies that the integer value is truncated to the same range as that produced by the \fBwide()\fR function of the \fBexpr\fR command (at least a 64-bit range). -If it is \fBL\fR it specifies that an integer or double value is taken -without truncation for conversion to a formatted substring. -If neither \fBh\fR nor \fBl\fR nor \fBL\fR are present, the integer value is +If neither \fBh\fR nor \fBl\fR are present, the integer value is truncated to the same range as that produced by the \fBint()\fR function of the \fBexpr\fR command (at least a 32-bit range, but determined by the value of the \fBwordSize\fR element of the \fBtcl_platform\fR array). .SS "MANDATORY CONVERSION TYPE" @@ -201,37 +196,27 @@ precision, then convert number as for \fB%e\fR or \fB%E\fR. Otherwise convert as for \fB%f\fR. Trailing zeroes and a trailing decimal point are omitted. .TP 10 -\fBa\fR or \fBA\fR -Convert double to hexadecimal notation in the form -\fI0x1.yyy\fBp\(+-\fIzz\fR, where the number of \fIy\fR's is -determined by the precision (default: 13). -If the \fBA\fR form is used then the hex characters -are printed in uppercase. -.TP 10 \fB%\fR No conversion: just insert \fB%\fR. -.TP 10 -\fBp\fR -Shorthand form for \fB0x%zx\fR, so it outputs the integer in -hexadecimal form with \fB0x\fR prefix. .SH "DIFFERENCES FROM ANSI SPRINTF" .PP The behavior of the format command is the same as the ANSI C \fBsprintf\fR procedure except for the following differences: .IP [1] Tcl guarantees that it will be working with UNICODE characters. .IP [2] -\fB%n\fR specifier is not supported. +\fB%p\fR and \fB%n\fR specifiers are not supported. .IP [3] For \fB%c\fR conversions the argument must be an integer value, which will then be converted to the corresponding character value. .IP [4] The size modifiers are ignored when formatting floating-point values. +The \fBll\fR modifier has no \fBsprintf\fR counterpart. The \fBb\fR specifier has no \fBsprintf\fR counterpart. .SH EXAMPLES .PP Convert the numeric value of a UNICODE character to the character itself: DELETED doc/fpclassify.n Index: doc/fpclassify.n ================================================================== --- doc/fpclassify.n +++ /dev/null @@ -1,83 +0,0 @@ -'\" -'\" Copyright (c) 2018 by Kevin B. Kenny . All rights reserved -'\" Copyright (c) 2019 by Donal Fellows -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH fpclassify n 8.7 Tcl "Tcl Float Classifier" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -fpclassify \- Floating point number classification of Tcl values -.SH SYNOPSIS -package require \fBTcl 8.7\fR -.sp -\fBfpclassify \fIvalue\fR -.BE -.SH DESCRIPTION -The \fBfpclassify\fR command takes a floating point number, \fIvalue\fR, and -returns one of the following strings that describe it: -.TP -\fBzero\fR -. -\fIvalue\fR is a floating point zero. -.TP -\fBsubnormal\fR -. -\fIvalue\fR is the result of a gradual underflow. -.TP -\fBnormal\fR -. -\fIvalue\fR is an ordinary floating-point number (not zero, subnormal, -infinite, nor NaN). -.TP -\fBinfinite\fR -. -\fIvalue\fR is a floating-point infinity. -.TP -\fBnan\fR -. -\fIvalue\fR is Not-a-Number. -.PP -The \fBfpclassify\fR command throws an error if value is not a floating-point -value and cannot be converted to one. -.SH EXAMPLE -.PP -This shows how to check whether the result of a computation is numerically -safe or not. (Note however that it does not guard against numerical errors; -just against representational problems.) -.PP -.CS -set value [command-that-computes-a-value] -switch [\fBfpclassify\fR $value] { - normal - zero { - puts "Result is $value" - } - infinite { - puts "Result is infinite" - } - subnormal { - puts "Result is $value - WARNING! precision lost" - } - nan { - puts "Computation completely failed" - } -} -.CE -.SH "SEE ALSO" -expr(n), mathfunc(n) -.SH KEYWORDS -floating point -.SH STANDARDS -This command depends on the \fBfpclassify\fR() C macro conforming to -.QW "ISO C99" -(i.e., to ISO/IEC 9899:1999). -.SH COPYRIGHT -.nf -Copyright \(co 2018 by Kevin B. Kenny . All rights reserved -.fi -'\" Local Variables: -'\" mode: nroff -'\" End: Index: doc/global.n ================================================================== --- doc/global.n +++ doc/global.n @@ -54,9 +54,5 @@ .CE .SH "SEE ALSO" namespace(n), upvar(n), variable(n) .SH KEYWORDS global, namespace, procedure, variable -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/history.n ================================================================== --- doc/history.n +++ doc/history.n @@ -98,9 +98,5 @@ If you want to redo an event without modifying history, then use the \fBevent\fR operation to retrieve some event, and the \fBadd\fR operation to add it to history and execute it. .SH KEYWORDS event, history, record -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/http.n ================================================================== --- doc/http.n +++ doc/http.n @@ -11,14 +11,14 @@ .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME http \- Client-side implementation of the HTTP/1.1 protocol .SH SYNOPSIS -\fBpackage require http\fI ?\fB2.8\fR? +\fBpackage require http ?2.9?\fR .\" See Also -useragent option documentation in body! .sp -\fB::http::config\fR ?\fI\-option value\fR ...? +\fB::http::config ?\fI\-option value\fR ...? .sp \fB::http::geturl \fIurl\fR ?\fI\-option value\fR ...? .sp \fB::http::formatQuery\fR \fIkey value\fR ?\fIkey value\fR ...? .sp @@ -76,10 +76,13 @@ HTTP request and the callback is invoked when the transaction completes. For this to work, the Tcl event loop must be active. In Tk applications this is always true. For pure-Tcl applications, the caller can use \fB::http::wait\fR after calling \fB::http::geturl\fR to start the event loop. +.PP +\fBNote:\fR The event queue is even used without the \fB-command\fR option. +As a side effect, arbitrary commands may be processed while \fBhttp::geturl\fR is running. .SH COMMANDS .TP \fB::http::config\fR ?\fIoptions\fR? . The \fB::http::config\fR command is used to set and query the name of the @@ -97,19 +100,10 @@ all types of documents are accepted. Otherwise you can supply a comma-separated list of mime type patterns that you are willing to receive. For example, .QW "image/gif, image/jpeg, text/*" . .TP -\fB\-cookiejar\fR \fIcommand\fR -.VS TIP406 -The cookie store for the package to use to manage HTTP cookies. -\fIcommand\fR is a command prefix list; if the empty list (the -default value) is used, no cookies will be sent by requests or stored -from responses. The command indicated by \fIcommand\fR, if supplied, -must obey the \fBCOOKIE JAR PROTOCOL\fR described below. -.VE TIP406 -.TP \fB\-pipeline\fR \fIboolean\fR . Specifies whether HTTP/1.1 transactions on a persistent socket will be pipelined. See the \fBPERSISTENT SOCKETS\fR section for details. The default is 1. @@ -168,11 +162,11 @@ \fB\-useragent\fR \fIstring\fR . The value of the User-Agent header in the HTTP request. In an unsafe interpreter, the default value depends upon the operating system, and the version numbers of \fBhttp\fR and \fBTcl\fR, and is (for example) -.QW "\fBMozilla/5.0 (Windows; U; Windows NT 10.0) http/2.8.12 Tcl/8.6.8\fR" . +.QW "\fBMozilla/5.0 (Windows; U; Windows NT 10.0) http/2.9.0 Tcl/8.6.9\fR" . A safe interpreter cannot determine its operating system, and so the default in a safe interpreter is to use a Windows 10 value with the current version numbers of \fBhttp\fR and \fBTcl\fR. .TP \fB\-zip\fR \fIboolean\fR @@ -257,10 +251,14 @@ set nbytes [string length $data] ... return $nbytes } .CE +.PP +The \fBhttp::geturl\fR code for the \fB-handler\fR option is not compatible with either compression or chunked transfer-encoding. If \fB-handler\fR is specified, then to work around these issues \fBhttp::geturl\fR will reduce the HTTP protocol to 1.0, and override the \fB-zip\fR option (i.e. it will not send the header "\fBAccept-Encoding: gzip,deflate,compress\fR"). +.PP +If options \fB-handler\fR and \fB-channel\fR are used together, the handler is responsible for copying the data from the HTTP socket to the specified channel. The name of the channel is available to the handler as element \fB-channel\fR of the token array. .RE .TP \fB\-headers\fR \fIkeyvaluelist\fR . This option is used to add headers not already specified @@ -319,13 +317,15 @@ otherwise complain about HTTP/1.1. .TP \fB\-query\fR \fIquery\fR . This flag causes \fB::http::geturl\fR to do a POST request that passes the -\fIquery\fR to the server. The \fIquery\fR must be an x-url-encoding -formatted query. The \fB::http::formatQuery\fR procedure can be used to -do the formatting. +\fIquery\fR as payload verbatim to the server. +The content format (and encoding) of \fIquery\fR is announced by the header +field \fBcontent-type\fR set by the option \fB-type\fR. +\fIquery\fR is an x-url-encoding formatted query, if used for html forms. +The \fB::http::formatQuery\fR procedure can be used to do the formatting. .TP \fB\-queryblocksize\fR \fIsize\fR . The block size used when posting query data to the URL. At most @@ -545,10 +545,18 @@ .TP \fBerror\fR . The error message will also be stored in the \fBerror\fR status array element, accessible via \fB::http::error\fR. +.TP +\fBtimeout\fR +. +A timeout occurred before the transaction could complete +.TP +\fBreset\fR +. +user-reset .PP Another error possibility is that \fB::http::geturl\fR is unable to write all the post query data to the server before the server responds and closes the socket. The error message is saved in the \fBposterror\fR status array @@ -660,14 +668,13 @@ The error, if any, that occurred while writing the post query data to the server. .TP \fBstatus\fR . -Either \fBok\fR, for successful completion, \fBreset\fR for -user-reset, \fBtimeout\fR if a timeout occurred before the transaction -could complete, or \fBerror\fR for an error condition. During the -transaction this value is the empty string. +See description in the chapter \fBERRORS\fR above for a +list and description of \fBstatus\fR. +During the transaction this value is the empty string. .TP \fBtotalsize\fR . A copy of the \fBContent-Length\fR meta-data value. .TP @@ -777,112 +784,10 @@ Subsequent GET and HEAD requests in a failed pipeline will also be retried. \fIThe -repost option should be used only if the application understands that the retry is appropriate\fR - specifically, the application must know that if the failed POST successfully modified the state of the server, a repeat POST would have no adverse effect. -.VS TIP406 -.SH "COOKIE JAR PROTOCOL" -.PP -Cookies are short key-value pairs used to implement sessions within the -otherwise-stateless HTTP protocol. (See RFC 6265 for details; Tcl does not -implement the Cookie2 protocol as that is rarely seen in the wild.) -.PP -Cookie storage managment commands \(em -.QW "cookie jars" -\(em must support these subcommands which form the HTTP cookie storage -management protocol. Note that \fIcookieJar\fR below does not have to be a -command name; it is properly a command prefix (a Tcl list of words that will -be expanded in place) and admits many possible implementations. -.PP -Though not formally part of the protocol, it is expected that particular -values of \fIcookieJar\fR will correspond to sessions; it is up to the caller -of \fB::http::config\fR to decide what session applies and to manage the -deletion of said sessions when they are no longer desired (which should be -when they not configured as the current cookie jar). -.TP -\fIcookieJar \fBgetCookies \fIprotocol host requestPath\fR -. -This command asks the cookie jar what cookies should be supplied for a -particular request. It should take the \fIprotocol\fR (typically \fBhttp\fR or -\fBhttps\fR), \fIhost\fR name and \fIrequestPath\fR (parsed from the \fIurl\fR -argument to \fB::http::geturl\fR) and return a list of cookie keys and values -that describe the cookies to supply to the remote host. The list must have an -even number of elements. -.RS -.PP -There should only ever be at most one cookie with a particular key for any -request (typically the one with the most specific \fIhost\fR/domain match and -most specific \fIrequestPath\fR/path match), but there may be many cookies -with different names in any request. -.RE -.TP -\fIcookieJar \fBstoreCookie \fIcookieDictionary\fR -. -This command asks the cookie jar to store a particular cookie that was -returned by a request; the result of this command is ignored. The cookie -(which will have been parsed by the http package) is described by a -dictionary, \fIcookieDictionary\fR, that may have the following keys: -.RS -.TP -\fBdomain\fR -. -This is always present. Its value describes the domain hostname \fIor -prefix\fR that the cookie should be returned for. The checking of the domain -against the origin (below) should be careful since sites that issue cookies -should only do so for domains related to themselves. Cookies that do not obey -a relevant origin matching rule should be ignored. -.TP -\fBexpires\fR -. -This is optional. If present, the cookie is intended to be a persistent cookie -and the value of the option is the Tcl timestamp (in seconds from the same -base as \fBclock seconds\fR) of when the cookie expires (which may be in the -past, which should result in the cookie being deleted immediately). If absent, -the cookie is intended to be a session cookie that should be not persisted -beyond the lifetime of the cookie jar. -.TP -\fBhostonly\fR -. -This is always present. Its value is a boolean that describes whether the -cookie is a single host cookie (true) or a domain-level cookie (false). -.TP -\fBhttponly\fR -. -This is always present. Its value is a boolean that is true when the site -wishes the cookie to only ever be used with HTTP (or HTTPS) traffic. -.TP -\fBkey\fR -. -This is always present. Its value is the \fIkey\fR of the cookie, which is -part of the information that must be return when sending this cookie back in a -future request. -.TP -\fBorigin\fR -. -This is always present. Its value describes where the http package believes it -received the cookie from, which may be useful for checking whether the -cookie's domain is valid. -.TP -\fBpath\fR -. -This is always present. Its value describes the path prefix of requests to the -cookie domain where the cookie should be returned. -.TP -\fBsecure\fR -. -This is always present. Its value is a boolean that is true when the cookie -should only used on requests sent over secure channels (typically HTTPS). -.TP -\fBvalue\fR -. -This is always present. Its value is the value of the cookie, which is part of -the information that must be return when sending this cookie back in a future -request. -.PP -Other keys may always be ignored; they have no meaning in this protocol. -.RE -.VE TIP406 .SH EXAMPLE .PP This example creates a procedure to copy a URL to a file while printing a progress meter, and prints the meta-data associated with the URL. .PP DELETED doc/idna.n Index: doc/idna.n ================================================================== --- doc/idna.n +++ /dev/null @@ -1,88 +0,0 @@ -'\" -'\" Copyright (c) 2014-2018 Donal K. Fellows. -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH "idna" n 0.1 http "Tcl Bundled Packages" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -tcl::idna \- Support for normalization of Internationalized Domain Names -.SH SYNOPSIS -.nf -package require tcl::idna 1.0 - -\fBtcl::idna decode\fR \fIhostname\fR -\fBtcl::idna encode\fR \fIhostname\fR -\fBtcl::idna puny decode\fR \fIstring\fR ?\fIcase\fR? -\fBtcl::idna puny encode\fR \fIstring\fR ?\fIcase\fR? -\fBtcl::idna version\fR -.fi -.SH DESCRIPTION -This package provides an implementation of the punycode scheme used in -Internationalised Domain Names, and some access commands. (See RFC 3492 for a -description of punycode.) -.TP -\fBtcl::idna decode\fR \fIhostname\fR -. -This command takes the name of a host that potentially contains -punycode-encoded character sequences, \fIhostname\fR, and returns the hostname -as might be displayed to the user. Note that there are often UNICODE -characters that have extremely similar glyphs, so care should be taken with -displaying hostnames to users. -.TP -\fBtcl::idna encode\fR \fIhostname\fR -. -This command takes the name of a host as might be displayed to the user, -\fIhostname\fR, and returns the version of the hostname with characters not -permitted in basic hostnames encoded with punycode. -.TP -\fBtcl::idna puny\fR \fIsubcommand ...\fR -. -This command provides direct access to the basic punycode encoder and -decoder. It supports two \fIsubcommand\fRs: -.RS -.TP -\fBtcl::idna puny decode\fR \fIstring\fR ?\fIcase\fR? -. -This command decodes the punycode-encoded string, \fIstring\fR, and returns -the result. If \fIcase\fR is provided, it is a boolean to make the case be -folded to upper case (if \fIcase\fR is true) or lower case (if \fIcase\fR is -false) during the decoding process; if omitted, no case transformation is -applied. -.TP -\fBtcl::idna puny encode\fR \fIstring\fR ?\fIcase\fR? -. -This command encodes the string, \fIstring\fR, and returns the -punycode-encoded version of the string. If \fIcase\fR is provided, it is a -boolean to make the case be folded to upper case (if \fIcase\fR is true) or -lower case (if \fIcase\fR is false) during the encoding process; if omitted, -no case transformation is applied. -.RE -.TP -\fBtcl::idna version\fR -. -This returns the version of the \fBtcl::idna\fR package. -.SH "EXAMPLE" -.PP -This is an example of how punycoding of a string works: -.PP -.CS -package require tcl::idna - -puts [\fBtcl::idna puny encode\fR "abc\(->def"] -# prints: \fIabcdef-kn2c\fR -puts [\fBtcl::idna puny decode\fR "abcdef-kn2c"] -# prints: \fIabc\(->def\fR -.CE -'\" TODO: show how it handles a real domain name -.SH "SEE ALSO" -http(n), cookiejar(n) -.SH KEYWORDS -internet, www -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/incr.n ================================================================== --- doc/incr.n +++ doc/incr.n @@ -25,15 +25,10 @@ and also returned as result. .PP Starting with the Tcl 8.5 release, the variable \fIvarName\fR passed to \fBincr\fR may be unset, and in that case, it will be set to the value \fIincrement\fR or to the default increment value of \fB1\fR. -.VS TIP508 -If \fIvarName\fR indicate an element that does not exist of an array that has -a default value set, the sum of the default value and the \fIincrement\fR (or -1) will be stored in the array element. -.VE TIP508 .SH EXAMPLES .PP Add one to the contents of the variable \fIx\fR: .PP .CS @@ -62,9 +57,5 @@ .CE .SH "SEE ALSO" expr(n), set(n) .SH KEYWORDS add, increment, variable, value -.\" Local variables: -.\" mode: nroff -.\" fill-column: 78 -.\" End: Index: doc/info.n ================================================================== --- doc/info.n +++ doc/info.n @@ -11,218 +11,235 @@ .TH info n 8.4 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -info \- Information about the state of the Tcl interpreter +info \- Return information about the state of the Tcl interpreter .SH SYNOPSIS \fBinfo \fIoption \fR?\fIarg arg ...\fR? .BE .SH DESCRIPTION .PP -Available commands: +This command provides information about various internals of the Tcl +interpreter. +The legal \fIoption\fRs (which may be abbreviated) are: .TP \fBinfo args \fIprocname\fR . -Returns the names of the parameters to the procedure named \fIprocname\fR. +Returns a list containing the names of the arguments to procedure +\fIprocname\fR, in order. \fIProcname\fR must be the name of a +Tcl command procedure. .TP \fBinfo body \fIprocname\fR . -Returns the body of the procedure named \fIprocname\fR. +Returns the body of procedure \fIprocname\fR. \fIProcname\fR must be +the name of a Tcl command procedure. .TP \fBinfo class\fI subcommand class\fR ?\fIarg ...\fR -. -Returns information about the class named \fIclass\fR. -See \fBCLASS INTROSPECTION\fR below. +.VS 8.6 +Returns information about the class, \fIclass\fR. The \fIsubcommand\fRs are +described in \fBCLASS INTROSPECTION\fR below. +.VE 8.6 .TP \fBinfo cmdcount\fR . -Returns the total number of commands evaluated in this interpreter. -.TP -\fBinfo cmdtype \fIcommandName\fR -.VS TIP426 -Returns a the type of the command named \fIcommandName\fR. -Built-in types are: -.RS -.IP \fBalias\fR -\fIcommandName\fR was created by \fBinterp alias\fR. -In a safe interpreter an alias is only visible if both the alias and the -target are visible. -.IP \fBcoroutine\fR -\fIcommandName\fR was created by \fBcoroutine\fR. -.IP \fBensemble\fR -\fIcommandName\fR was created by \fBnamespace ensemble\fR. -.IP \fBimport\fR -\fIcommandName\fR was created by \fBnamespace import\fR. -.IP \fBnative\fR -\fIcommandName\fR was created by the \fBTcl_CreateObjProc\fR -interface directly without further registration of the type of command. -.IP \fBobject\fR -\fIcommandName\fR is the public command that represents an -instance of \fBoo::object\fR or one of its subclasses. -.IP \fBprivateObject\fR -\fIcommandName\fR is the private command, \fBmy\fR by default, -that represents an instance of \fBoo::object\fR or one of its subclasses. -.IP \fBproc\fR -\fIcommandName\fR was created by \fBproc\fR. -.IP \fBslave\fR -\fIcommandName\fR was created by \fBinterp create\fR. -.IP \fBzlibStream\fR -\fIcommandName\fR was created by \fBzlib stream\fR. -.PP -Other types may be also registered as well. See \fBTcl_RegisterCommandTypeName\fR. -.RE -.VE TIP426 +Returns a count of the total number of commands that have been invoked +in this interpreter. .TP \fBinfo commands \fR?\fIpattern\fR? . -Returns the names of all commands visible in the current namespace. If -\fIpattern\fR is given, returns only those names that match according to -\fBstring match\fR. Only the last component of \fIpattern\fR is a pattern. -Other components identify a namespace. See \fBNAMESPACE RESOLUTION\fR in the -\fBnamespace\fR(n) documentation. +If \fIpattern\fR is not specified, +returns a list of names of all the Tcl commands visible +(i.e. executable without using a qualified name) to the current namespace, +including both the built-in commands written in C and +the command procedures defined using the \fBproc\fR command. +If \fIpattern\fR is specified, +only those names matching \fIpattern\fR are returned. +Matching is determined using the same rules as for \fBstring match\fR. +\fIpattern\fR can be a qualified name like \fBFoo::print*\fR. +That is, it may specify a particular namespace +using a sequence of namespace names separated by double colons (\fB::\fR), +and may have pattern matching special characters +at the end to specify a set of commands in that namespace. +If \fIpattern\fR is a qualified name, +the resulting list of command names has each one qualified with the name +of the specified namespace, and only the commands defined in the named +namespace are returned. +.\" Technically, most of this hasn't changed; that's mostly just the +.\" way it always worked. Hardly anyone knew that though. .TP \fBinfo complete \fIcommand\fR . -Returns 1 if \fIcommand\fR is a complete command, and \fB0\fR otherwise. -Typically used in line-oriented input environments -to allow users to type in commands that span multiple lines. +Returns 1 if \fIcommand\fR is a complete Tcl command in the sense of +having no unclosed quotes, braces, brackets or array element names. +If the command does not appear to be complete then 0 is returned. +This command is typically used in line-oriented input environments +to allow users to type in commands that span multiple lines; if the +command is not complete, the script can delay evaluating it until additional +lines have been typed to complete the command. .TP \fBinfo coroutine\fR -. -Returns the name of the current \fBcoroutine\fR, or the empty -string if there is no current coroutine or the current coroutine -has been deleted. +.VS 8.6 +Returns the name of the currently executing \fBcoroutine\fR, or the empty +string if either no coroutine is currently executing, or the current coroutine +has been deleted (but has not yet returned or yielded since deletion). +.VE 8.6 .TP -\fBinfo default \fIprocname parameter varname\fR +\fBinfo default \fIprocname arg varname\fR . -If the parameter \fIparameter\fR for the procedure named \fIprocname\fR has a -default value, stores that value in \fIvarname\fR and returns \fB1\fR. -Otherwise, returns \fB0\fR. +\fIProcname\fR must be the name of a Tcl command procedure and \fIarg\fR +must be the name of an argument to that procedure. If \fIarg\fR +does not have a default value then the command returns \fB0\fR. +Otherwise it returns \fB1\fR and places the default value of \fIarg\fR +into variable \fIvarname\fR. .TP \fBinfo errorstack \fR?\fIinterp\fR? -. -Returns a description of the active command at each level for the -last error in the current interpreter, or in the interpreter named -\fIinterp\fR if given. +.VS 8.6 +Returns, in a form that is programmatically easy to parse, the function names +and arguments at each level from the call stack of the last error in the given +\fIinterp\fR, or in the current one if not specified. .RS .PP -The description is a dictionary of tokens and parameters. Tokens are +This form is an even-sized list alternating tokens and parameters. Tokens are currently either \fBCALL\fR, \fBUP\fR, or \fBINNER\fR, but other values may be -introduced in the future. \fBCALL\fR indicates a command call, and its +introduced in the future. \fBCALL\fR indicates a procedure call, and its parameter is the corresponding \fBinfo level\fR \fB0\fR. \fBUP\fR indicates a shift in variable frames generated by \fBuplevel\fR or similar, and applies to the previous \fBCALL\fR item. Its parameter is the level offset. \fBINNER\fR identifies the .QW "inner context" , which is the innermost atomic command or bytecode instruction that raised the error, along with its arguments when available. While \fBCALL\fR and \fBUP\fR -provide a trail of the call path, \fBINNER\fR provides details of the offending -operation in the innermost procedure call, even to sub-expression +allow to follow complex call paths, \fBINNER\fR homes in on the offending +operation in the innermost procedure call, even going to sub-expression granularity. .PP This information is also present in the \fB\-errorstack\fR entry of the options dictionary returned by 3-argument \fBcatch\fR; \fBinfo errorstack\fR is a convenient way of retrieving it for uncaught errors at top-level in an -interactive \fBinterpreter\fR. +interactive \fBtclsh\fR. .RE +.VE 8.6 .TP \fBinfo exists \fIvarName\fR . -Returns \fB1\fR if a variable named \fIvarName\fR is visible and has been -defined, and \fB0\fR otherwise. -.TP -\fBinfo frame\fR ?\fIdepth\fR? -. -Returns the depth of the call to \fBinfo frame\fR itself. Otherwise, returns a -dictionary describing the active command at the \fIdepth\fR, which counts all -commands visible to \fBinfo level\fR, plus commands that don't create a new -level, such as \fBeval\fR, \fBsource\fR, or \fIuplevel\fR. The frame depth is -always greater than the current level. +Returns \fB1\fR if the variable named \fIvarName\fR exists in the +current context (either as a global or local variable) and has been +defined by being given a value, returns \fB0\fR otherwise. +.TP +\fBinfo frame\fR ?\fInumber\fR? +. +This command provides access to all frames on the stack, even those +hidden from \fBinfo level\fR. If \fInumber\fR is not specified, this +command returns a number giving the frame level of the command. This +is 1 if the command is invoked at top-level. If \fInumber\fR is +specified, then the result is a dictionary containing the location +information for the command at the \fInumber\fRed level on the stack. .RS .PP -If \fIdepth\fR is greater than \fB0\fR it is the frame at that depth. Otherwise -it is the number of frames up from the current frame. +If \fInumber\fR is positive (> 0) then it selects a particular stack +level (1 refers to the outer-most active command, 2 to the command it +called, and so on, up to the current frame level which refers to +\fBinfo frame\fR itself); otherwise it gives a level relative to the +current command (0 refers to the current command, i.e., \fBinfo +frame\fR itself, -1 to its caller, and so on). +.PP +This is similar to how \fBinfo level\fR works, except that this +subcommand reports all frames, like \fBsource\fRd scripts, +\fBeval\fRs, \fBuplevel\fRs, etc. .PP -As with \fBinfo level\fR and error traces, for nested commands like +Note that for nested commands, like .QW "foo [bar [x]]" , only .QW x -is seen by \fBinfo frame\fR invoked within +will be seen by an \fBinfo frame\fR invoked within .QW x . +This is the same as for \fBinfo level\fR and error stack traces. .PP -The dictionary may contain the following keys: +The result dictionary may contain the keys listed below, with the +specified meanings for their values: .TP \fBtype\fR . -Always present. Possible values are \fBsource\fR, \fBproc\fR, +This entry is always present and describes the nature of the location +for the command. The recognized values are \fBsource\fR, \fBproc\fR, \fBeval\fR, and \fBprecompiled\fR. .RS .TP \fBsource\fR\0\0\0\0\0\0\0\0 . -A script loaded via the \fBsource\fR +means that the command is found in a script loaded by the \fBsource\fR command. .TP \fBproc\fR\0\0\0\0\0\0\0\0 . -The body of a procedure that could not be traced back to a -line in a particular script. +means that the command is found in dynamically created procedure body. .TP \fBeval\fR\0\0\0\0\0\0\0\0 . -The body of a script provided to \fBeval\fR or \fBuplevel\fR. +means that the command is executed by \fBeval\fR or \fBuplevel\fR. .TP \fBprecompiled\fR\0\0\0\0\0\0\0\0 . -A pre-compiled script (loadable by the package -\fBtbcload\fR), and no further information is available. +means that the command is found in a pre-compiled script (loadable by +the package \fBtbcload\fR), and no further information will be +available. .RE .TP \fBline\fR . -The line number of of the command inside its script. Not available for -\fBprecompiled\fR commands. When the type is \fBsource\fR, the line number is -relative to the beginning of the file, whereas for the last two types it is -relative to the start of the script. +This entry provides the number of the line the command is at inside of +the script it is a part of. This information is not present for type +\fBprecompiled\fR. For type \fBsource\fR this information is counted +relative to the beginning of the file, whereas for the last two types +the line is counted relative to the start of the script. .TP \fBfile\fR . -For type \fBsource\fR, provides the normalized path of the file that contains -the command. +This entry is present only for type \fBsource\fR. It provides the +normalized path of the file the command is in. .TP \fBcmd\fR . -The command before substitutions were performed. +This entry provides the string representation of the command. This is +usually the unsubstituted form, however for commands which are a +canonically-constructed list (e.g., as produced by the \fBlist\fR command) +executed by \fBeval\fR it is the substituted form as they have no other +string representation. Care is taken that the canonicality property of +the latter is not spoiled. .TP \fBproc\fR . -For type \fBprod\fR, the name of the procedure containing the command. +This entry is present only if the command is found in the body of a +regular Tcl procedure. It then provides the name of that procedure. .TP \fBlambda\fR . -For a command in a script evaluated as the body of an unnamed routine via the -\fBapply\fR command, the definition of that routine. +This entry is present only if the command is found in the body of an +anonymous Tcl procedure, i.e. a lambda. It then provides the entire +definition of the lambda in question. .TP \fBlevel\fR . -For a frame that corresponds to a level, (to be determined). +This entry is present only if the queried frame has a corresponding +frame returned by \fBinfo level\fR. It provides the index of this +frame, relative to the current level (0 and negative numbers). .PP -When a command can be traced to its literal definition in some script, e.g. -procedures nested in statically defined procedures, and literal eval scripts in -files or statically defined procedures, its type is \fBsource\fR and its -location is the absolute line number in the script. Otherwise, its type is -\fBproc\fR and its location is its line number within the body of the -procedure. +A thing of note is that for procedures statically defined in files the +locations of commands in their bodies will be reported with type +\fBsource\fR and absolute line numbers, and not as type +\fBproc\fR. The same is true for procedures nested in statically +defined procedures, and literal eval scripts in files or statically +defined procedures. .PP In contrast, procedure definitions and \fBeval\fR within a dynamically \fBeval\fRuated environment count line numbers relative to the start of their script, even if they would be able to count relative to the start of the outer dynamic script. That type of number usually makes more sense. .PP -A different way of describing this behaviour is that file-based +A different way of describing this behaviour is that file based locations are tracked as deeply as possible, and where this is not possible the lines are counted based on the smallest possible \fBeval\fR or procedure body, as that scope is usually easier to find than any dynamic outer scope. .PP @@ -232,133 +249,171 @@ counted relative to the start of each word (smallest scope) .RE .TP \fBinfo functions \fR?\fIpattern\fR? . -If \fIpattern\fR is not given, returns a list of all the math +If \fIpattern\fR is not specified, returns a list of all the math functions currently defined. -If \fIpattern\fR is given, returns only those names that match -\fIpattern\fR according to \fBstring match\fR. +If \fIpattern\fR is specified, only those functions whose name matches +\fIpattern\fR are returned. Matching is determined using the same +rules as for \fBstring match\fR. .TP \fBinfo globals \fR?\fIpattern\fR? . -If \fIpattern\fR is not given, returns a list of all the names +If \fIpattern\fR is not specified, returns a list of all the names of currently-defined global variables. Global variables are variables in the global namespace. -If \fIpattern\fR is given, only those names matching \fIpattern\fR +If \fIpattern\fR is specified, only those names matching \fIpattern\fR are returned. Matching is determined using the same rules as for \fBstring match\fR. .TP \fBinfo hostname\fR . -Returns the name of the current host. - -This name is not guaranteed to be the fully-qualified domain -name of the host. Where machines have several different names, as is +Returns the name of the computer on which this invocation is being +executed. +Note that this name is not guaranteed to be the fully qualified domain +name of the host. Where machines have several different names (as is common on systems with both TCP/IP (DNS) and NetBIOS-based networking -installed, it is the name that is suitable for TCP/IP networking that +installed,) it is the name that is suitable for TCP/IP networking that is returned. .TP -\fBinfo level\fR ?\fIlevel\fR? -. -If \fInumber\fR is not given, the level this routine was called from. -Otherwise returns the complete command active at the given level. If -\fInumber\fR is greater than \fB0\fR, it is the desired level. Otherwise, it -is \fInumber\fR levels up from the current level. A complete command is the -words in the command, with all subsitutions performed, meaning that it is a -list. See \fBuplevel\fR for more information on levels. +\fBinfo level\fR ?\fInumber\fR? +. +If \fInumber\fR is not specified, this command returns a number +giving the stack level of the invoking procedure, or 0 if the +command is invoked at top-level. If \fInumber\fR is specified, +then the result is a list consisting of the name and arguments for the +procedure call at level \fInumber\fR on the stack. If \fInumber\fR +is positive then it selects a particular stack level (1 refers +to the top-most active procedure, 2 to the procedure it called, and +so on); otherwise it gives a level relative to the current level +(0 refers to the current procedure, -1 to its caller, and so on). +See the \fBuplevel\fR command for more information on what stack +levels mean. .TP \fBinfo library\fR . -Returns the value of \fBtcl_library\fR, which is the name of the library -directory in which the scripts distributed with Tcl scripts are stored. -.TP -\fBinfo loaded \fR?\fIinterp\fR? ?\fIpackage\fR? -. -Returns the name of each file loaded in \fIinterp\fR va \fBload\fR as part of -\fIpackage\fR . If \fIpackage\fR is not given, returns a list where each item -is the name of the loaded file and the name of the package for which the file -was loaded. For a statically-loaded package the name of the file is the empty -string. For \fInterp\fR, the empty string is the current interpreter. +Returns the name of the library directory in which standard Tcl +scripts are stored. +This is actually the value of the \fBtcl_library\fR +variable and may be changed by setting \fBtcl_library\fR. +.TP +\fBinfo loaded \fR?\fIinterp\fR? +. +Returns a list describing all of the packages that have been loaded into +\fIinterp\fR with the \fBload\fR command. +Each list element is a sub-list with two elements consisting of the +name of the file from which the package was loaded and the name of +the package. +For statically-loaded packages the file name will be an empty string. +If \fIinterp\fR is omitted then information is returned for all packages +loaded in any interpreter in the process. +To get a list of just the packages in the current interpreter, specify +an empty string for the \fIinterp\fR argument. .TP \fBinfo locals \fR?\fIpattern\fR? . -If \fIpattern\fR is given, returns the name of each local variable matching -\fIpattern\fR according to \fBstring match\fR. Otherwise, returns the name of -each local variable. A variables defined with the \fBglobal\fR, \fBupvar\fR or -\fBvariable\fR is not local. - +If \fIpattern\fR is not specified, returns a list of all the names +of currently-defined local variables, including arguments to the +current procedure, if any. +Variables defined with the \fBglobal\fR, \fBupvar\fR and +\fBvariable\fR commands will not be returned. +If \fIpattern\fR is specified, only those names matching \fIpattern\fR +are returned. Matching is determined using the same rules as for +\fBstring match\fR. .TP \fBinfo nameofexecutable\fR . -Returns the absolute pathname of the program for the current interpreter. If -such a file can not be identified an empty string is returned. +Returns the full path name of the binary file from which the application +was invoked. If Tcl was unable to identify the file, then an empty +string is returned. .TP \fBinfo object\fI subcommand object\fR ?\fIarg ...\fR -. -Returns information about the object named \fIobject\fR. \fIsubcommand\fR is -described \fBOBJECT INTROSPECTION\fR below. +.VS 8.6 +Returns information about the object, \fIobject\fR. The \fIsubcommand\fRs are +described in \fBOBJECT INTROSPECTION\fR below. +.VE 8.6 .TP \fBinfo patchlevel\fR . -Returns the value of the global variable \fBtcl_patchLevel\fR, in which the -exact version of the Tcl library initially stored. +Returns the value of the global variable \fBtcl_patchLevel\fR, which holds +the exact version of the Tcl library by default. .TP \fBinfo procs \fR?\fIpattern\fR? . -Returns the names of all visible procedures. If \fIpattern\fR is given, returns -only those names that match according to \fBstring match\fR. Only the final -component in \fIpattern\fR is actually considered a pattern. Any qualifying -components simply select a namespace. See \fBNAMESPACE RESOLUTION\fR in the -\fBnamespace\fR(n) documentation. +If \fIpattern\fR is not specified, returns a list of all the +names of Tcl command procedures in the current namespace. +If \fIpattern\fR is specified, +only those procedure names in the current namespace +matching \fIpattern\fR are returned. +Matching is determined using the same rules as for +\fBstring match\fR. +If \fIpattern\fR contains any namespace separators, they are used to +select a namespace relative to the current namespace (or relative to +the global namespace if \fIpattern\fR starts with \fB::\fR) to match +within; the matching pattern is taken to be the part after the last +namespace separator. .TP \fBinfo script\fR ?\fIfilename\fR? . -Returns the pathname of the innermost script currently being evaluated, or the -empty string if no pathname can be determined. If \fIfilename\fR is given, -sets the return value of any future calls to \fBinfo script\fR for the duration -of the innermost active script. This is useful in virtual file system -applications. +If a Tcl script file is currently being evaluated (i.e. there is a +call to \fBTcl_EvalFile\fR active or there is an active invocation +of the \fBsource\fR command), then this command returns the name +of the innermost file being processed. If \fIfilename\fR is specified, +then the return value of this command will be modified for the +duration of the active invocation to return that name. This is +useful in virtual file system applications. +Otherwise the command returns an empty string. .TP \fBinfo sharedlibextension\fR . -Returns the extension used on this platform for names of shared libraries, e.g. -\fB.so\fR under Solaris. Returns the empty string if shared libraries are not -supported on this platform. +Returns the extension used on this platform for the names of files +containing shared libraries (for example, \fB.so\fR under Solaris). +If shared libraries are not supported on this platform then an empty +string is returned. .TP \fBinfo tclversion\fR . -Returns the value of the global variable \fBtcl_version\fR, in which the -major and minor version of the Tcl library are stored. +Returns the value of the global variable \fBtcl_version\fR, which holds the +major and minor version of the Tcl library by default. .TP \fBinfo vars\fR ?\fIpattern\fR? . -If \fIpattern\fR is not given, returns the names of all visible variables. If -\fIpattern\fR is given, returns only those names that match according to -\fBstring match\fR. Only the last component of \fIpattern\fR is a pattern. -Other components identify a namespace. See \fBNAMESPACE RESOLUTION\fR in the -\fBnamespace\fR(n) documentation. When \fIpattern\fR is a qualified name, -results are fully qualified. - -A variable that has declared but not yet defined is included in the results. +If \fIpattern\fR is not specified, +returns a list of all the names of currently-visible variables. +This includes locals and currently-visible globals. +If \fIpattern\fR is specified, only those names matching \fIpattern\fR +are returned. Matching is determined using the same rules as for +\fBstring match\fR. +\fIpattern\fR can be a qualified name like \fBFoo::option*\fR. +That is, it may specify a particular namespace +using a sequence of namespace names separated by double colons (\fB::\fR), +and may have pattern matching special characters +at the end to specify a set of variables in that namespace. +If \fIpattern\fR is a qualified name, +the resulting list of variable names +has each matching namespace variable qualified with the name +of its namespace. +Note that a currently-visible variable may not yet +.QW exist +if it has not +been set (e.g. a variable declared but not set by \fBvariable\fR). .SS "CLASS INTROSPECTION" +.VS 8.6 .PP The following \fIsubcommand\fR values are supported by \fBinfo class\fR: +.VE 8.6 .TP \fBinfo class call\fI class method\fR -. +.VS Returns a description of the method implementations that are used to provide a stereotypical instance of \fIclass\fR's implementation of \fImethod\fR (stereotypical instances being objects instantiated by a class without having any object-specific definitions added). This consists of a list of lists of four elements, where each sublist consists of a word that describes the general type of method implementation (being one of \fBmethod\fR for an -ordinary method, \fBfilter\fR for an applied filter, -.VS TIP500 -\fBprivate\fR for a private method, -.VE TIP500 -and \fBunknown\fR for a +ordinary method, \fBfilter\fR for an applied filter, and \fBunknown\fR for a method that is invoked as part of unknown method handling), a word giving the name of the particular method invoked (which is always the same as \fImethod\fR for the \fBmethod\fR type, and .QW \fBunknown\fR for the \fBunknown\fR type), a word giving the fully qualified name of the @@ -365,171 +420,126 @@ class that defined the method, and a word describing the type of method implementation (see \fBinfo class methodtype\fR). .RS .PP Note that there is no inspection of whether the method implementations -actually use \fBnext\fR to transfer control along the call chain, -.VS TIP500 -and the call chains that this command files do not actually contain private -methods. -.VE TIP500 +actually use \fBnext\fR to transfer control along the call chain. .RE +.VE 8.6 .TP \fBinfo class constructor\fI class\fR -. +.VS 8.6 This subcommand returns a description of the definition of the constructor of class \fIclass\fR. The definition is described as a two element list; the first element is the list of arguments to the constructor in a form suitable for passing to another call to \fBproc\fR or a method definition, and the second element is the body of the constructor. If no constructor is present, this returns the empty list. +.VE 8.6 .TP \fBinfo class definition\fI class method\fR -. +.VS 8.6 This subcommand returns a description of the definition of the method named \fImethod\fR of class \fIclass\fR. The definition is described as a two element list; the first element is the list of arguments to the method in a form suitable for passing to another call to \fBproc\fR or a method definition, and the second element is the body of the method. -.TP -\fBinfo class definitionnamespace\fI class\fR ?\fIkind\fR? -.VS TIP524 -This subcommand returns the definition namespace for \fIkind\fR definitions of -the class \fIclass\fR; the definition namespace only affects the instances of -\fIclass\fR, not \fIclass\fR itself. The \fIkind\fR can be either -\fB\-class\fR to return the definition namespace used for \fBoo::define\fR, or -\fB\-instance\fR to return the definition namespace used for -\fBoo::objdefine\fR; the \fB\-class\fR kind is default (though this is only -actually useful on classes that are subclasses of \fBoo::class\fR). -.RS -.PP -If \fIclass\fR does not provide a definition namespace of the given kind, -this command returns the empty string. In those circumstances, the -\fBoo::define\fR and \fBoo::objdefine\fR commands look up which definition -namespace to use using the class inheritance hierarchy. -.RE -.VE TIP524 +.VE 8.6 .TP \fBinfo class destructor\fI class\fR -. +.VS 8.6 This subcommand returns the body of the destructor of class \fIclass\fR. If no destructor is present, this returns the empty string. +.VE 8.6 .TP \fBinfo class filters\fI class\fR -. +.VS 8.6 This subcommand returns the list of filter methods set on the class. +.VE 8.6 .TP \fBinfo class forward\fI class method\fR -. +.VS 8.6 This subcommand returns the argument list for the method forwarding called \fImethod\fR that is set on the class called \fIclass\fR. +.VE 8.6 .TP \fBinfo class instances\fI class\fR ?\fIpattern\fR? -. +.VS 8.6 This subcommand returns a list of instances of class \fIclass\fR. If the optional \fIpattern\fR argument is present, it constrains the list of returned instances to those that match it according to the rules of \fBstring match\fR. +.VE 8.6 .TP \fBinfo class methods\fI class\fR ?\fIoptions...\fR? -. +.VS 8.6 This subcommand returns a list of all public (i.e. exported) methods of the class called \fIclass\fR. Any of the following \fIoption\fRs may be -given, controlling exactly which method names are returned: +specified, controlling exactly which method names are returned: .RS +.VE 8.6 .TP \fB\-all\fR -. -If the \fB\-all\fR flag is given, -.VS TIP500 -and the \fB\-scope\fR flag is not given, -.VE TIP500 -the list of methods will include those +.VS 8.6 +If the \fB\-all\fR flag is given, the list of methods will include those methods defined not just by the class, but also by the class's superclasses and mixins. +.VE 8.6 .TP \fB\-private\fR -. -If the \fB\-private\fR flag is given, -.VS TIP500 -and the \fB\-scope\fR flag is not given, -.VE TIP500 -the list of methods will also include -the non-exported methods of the class (and superclasses and +.VS 8.6 +If the \fB\-private\fR flag is given, the list of methods will also include +the private (i.e. non-exported) methods of the class (and superclasses and mixins, if \fB\-all\fR is also given). -.VS TIP500 -Note that this naming is an unfortunate clash with true private methods; this -option name is retained for backward compatibility. -.VE TIP500 -.TP -\fB\-scope\fI scope\fR -.VS TIP500 -Returns a list of all methods on \fIclass\fR that have the given visibility -\fIscope\fR. When this option is supplied, both the \fB\-all\fR and -\fB\-private\fR options are ignored. The valid values for \fIscope\fR are: -.RS -.IP \fBpublic\fR 3 -Only methods with \fIpublic\fR scope (i.e., callable from anywhere by any instance -of this class) are to be returned. -.IP \fBunexported\fR 3 -Only methods with \fIunexported\fR scope (i.e., only callable via \fBmy\fR) are to -be returned. -.IP \fBprivate\fR 3 -Only methods with \fIprivate\fR scope (i.e., only callable from within this class's -methods) are to be returned. -.RE -.VE TIP500 -.RE +.RE +.VE 8.6 .TP \fBinfo class methodtype\fI class method\fR -. +.VS 8.6 This subcommand returns a description of the type of implementation used for the method named \fImethod\fR of class \fIclass\fR. When the result is \fBmethod\fR, further information can be discovered with \fBinfo class definition\fR, and when the result is \fBforward\fR, further information can be discovered with \fBinfo class forward\fR. +.VE 8.6 .TP \fBinfo class mixins\fI class\fR -. +.VS 8.6 This subcommand returns a list of all classes that have been mixed into the class named \fIclass\fR. +.VE 8.6 .TP \fBinfo class subclasses\fI class\fR ?\fIpattern\fR? -. +.VS 8.6 This subcommand returns a list of direct subclasses of class \fIclass\fR. If the optional \fIpattern\fR argument is present, it constrains the list of returned classes to those that match it according to the rules of \fBstring match\fR. +.VE 8.6 .TP \fBinfo class superclasses\fI class\fR -. +.VS 8.6 This subcommand returns a list of direct superclasses of class \fIclass\fR in inheritance precedence order. +.VE 8.6 .TP -\fBinfo class variables\fI class\fR ?\fB\-private\fR? -. +\fBinfo class variables\fI class\fR +.VS 8.6 This subcommand returns a list of all variables that have been declared for the class named \fIclass\fR (i.e. that are automatically present in the class's methods, constructor and destructor). -.VS TIP500 -If the \fB\-private\fR option is given, this lists the private variables -declared instead. -.VE TIP500 .SS "OBJECT INTROSPECTION" .PP The following \fIsubcommand\fR values are supported by \fBinfo object\fR: +.VE 8.6 .TP \fBinfo object call\fI object method\fR -. +.VS 8.6 Returns a description of the method implementations that are used to provide \fIobject\fR's implementation of \fImethod\fR. This consists of a list of lists of four elements, where each sublist consists of a word that describes the general type of method implementation (being one of \fBmethod\fR for an -ordinary method, \fBfilter\fR for an applied filter, -.VS TIP500 -\fBprivate\fR for a private method, -.VE TIP500 -and \fBunknown\fR for a +ordinary method, \fBfilter\fR for an applied filter, and \fBunknown\fR for a method that is invoked as part of unknown method handling), a word giving the name of the particular method invoked (which is always the same as \fImethod\fR for the \fBmethod\fR type, and .QW \fBunknown\fR for the \fBunknown\fR type), a word giving what defined the method (the fully @@ -537,172 +547,141 @@ implementation is on an instance), and a word describing the type of method implementation (see \fBinfo object methodtype\fR). .RS .PP Note that there is no inspection of whether the method implementations -actually use \fBnext\fR to transfer control along the call chain, -.VS TIP500 -and the call chains that this command files do not actually contain private -methods. -.VE TIP500 +actually use \fBnext\fR to transfer control along the call chain. .RE +.VE 8.6 .TP \fBinfo object class\fI object\fR ?\fIclassName\fR? -. -If \fIclassName\fR is not given, this subcommand returns class of the +.VS 8.6 +If \fIclassName\fR is unspecified, this subcommand returns class of the \fIobject\fR object. If \fIclassName\fR is present, this subcommand returns a boolean value indicating whether the \fIobject\fR is of that class. -.TP -\fBinfo object creationid\fI object\fR -.VS TIP500 -Returns the unique creation identifier for the \fIobject\fR object. This -creation identifier is unique to the object (within a Tcl interpreter) and -cannot be controlled at object creation time or altered afterwards. -.RS -.PP -\fIImplementation note:\fR the creation identifier is used to generate unique -identifiers associated with the object, especially for private variables. -.RE -.VE TIP500 +.VE 8.6 .TP \fBinfo object definition\fI object method\fR -. +.VS 8.6 This subcommand returns a description of the definition of the method named \fImethod\fR of object \fIobject\fR. The definition is described as a two element list; the first element is the list of arguments to the method in a form suitable for passing to another call to \fBproc\fR or a method definition, and the second element is the body of the method. +.VE 8.6 .TP \fBinfo object filters\fI object\fR -. +.VS 8.6 This subcommand returns the list of filter methods set on the object. +.VE 8.6 .TP \fBinfo object forward\fI object method\fR -. +.VS 8.6 This subcommand returns the argument list for the method forwarding called \fImethod\fR that is set on the object called \fIobject\fR. +.VE 8.6 .TP \fBinfo object isa\fI category object\fR ?\fIarg\fR? -. +.VS 8.6 This subcommand tests whether an object belongs to a particular category, returning a boolean value that indicates whether the \fIobject\fR argument meets the criteria for the category. The supported categories are: +.VE 8.6 .RS .TP \fBinfo object isa class\fI object\fR -. +.VS 8.6 This returns whether \fIobject\fR is a class (i.e. an instance of \fBoo::class\fR or one of its subclasses). +.VE 8.6 .TP \fBinfo object isa metaclass\fI object\fR -. +.VS 8.6 This returns whether \fIobject\fR is a class that can manufacture classes (i.e. is \fBoo::class\fR or a subclass of it). +.VE 8.6 .TP \fBinfo object isa mixin\fI object class\fR -. +.VS 8.6 This returns whether \fIclass\fR is directly mixed into \fIobject\fR. +.VE 8.6 .TP \fBinfo object isa object\fI object\fR -. +.VS 8.6 This returns whether \fIobject\fR really is an object. +.VE 8.6 .TP \fBinfo object isa typeof\fI object class\fR -. +.VS 8.6 This returns whether \fIclass\fR is the type of \fIobject\fR (i.e. whether \fIobject\fR is an instance of \fIclass\fR or one of its subclasses, whether direct or indirect). .RE +.VE 8.6 .TP \fBinfo object methods\fI object\fR ?\fIoption...\fR? -. +.VS 8.6 This subcommand returns a list of all public (i.e. exported) methods of the object called \fIobject\fR. Any of the following \fIoption\fRs may be -given, controlling exactly which method names are returned: +specified, controlling exactly which method names are returned: .RS +.VE 8.6 .TP \fB\-all\fR -. -If the \fB\-all\fR flag is given, -.VS TIP500 -and the \fB\-scope\fR flag is not given, -.VE TIP500 -the list of methods will include those +.VS 8.6 +If the \fB\-all\fR flag is given, the list of methods will include those methods defined not just by the object, but also by the object's class and mixins, plus the superclasses of those classes. +.VE 8.6 .TP \fB\-private\fR -. -If the \fB\-private\fR flag is given, -.VS TIP500 -and the \fB\-scope\fR flag is not given, -.VE TIP500 -the list of methods will also include -the non-exported methods of the object (and classes, if +.VS 8.6 +If the \fB\-private\fR flag is given, the list of methods will also include +the private (i.e. non-exported) methods of the object (and classes, if \fB\-all\fR is also given). -.VS TIP500 -Note that this naming is an unfortunate clash with true private methods; this -option name is retained for backward compatibility. -.VE TIP500 -.TP -\fB\-scope\fI scope\fR -.VS TIP500 -Returns a list of all methods on \fIobject\fR that have the given visibility -\fIscope\fR. When this option is supplied, both the \fB\-all\fR and -\fB\-private\fR options are ignored. The valid values for \fIscope\fR are: -.RS -.IP \fBpublic\fR 3 -Only methods with \fIpublic\fR scope (i.e., callable from anywhere) are to be -returned. -.IP \fBunexported\fR 3 -Only methods with \fIunexported\fR scope (i.e., only callable via \fBmy\fR) are to -be returned. -.IP \fBprivate\fR 3 -Only methods with \fIprivate\fR scope (i.e., only callable from within this object's -instance methods) are to be returned. -.RE -.VE TIP500 -.RE +.RE +.VE 8.6 .TP \fBinfo object methodtype\fI object method\fR -. +.VS 8.6 This subcommand returns a description of the type of implementation used for the method named \fImethod\fR of object \fIobject\fR. When the result is \fBmethod\fR, further information can be discovered with \fBinfo object definition\fR, and when the result is \fBforward\fR, further information can be discovered with \fBinfo object forward\fR. +.VE 8.6 .TP \fBinfo object mixins\fI object\fR -. +.VS 8.6 This subcommand returns a list of all classes that have been mixed into the object named \fIobject\fR. +.VE 8.6 .TP \fBinfo object namespace\fI object\fR -. +.VS 8.6 This subcommand returns the name of the internal namespace of the object named \fIobject\fR. +.VE 8.6 .TP -\fBinfo object variables\fI object\fRR ?\fB\-private\fR? -. +\fBinfo object variables\fI object\fR +.VS 8.6 This subcommand returns a list of all variables that have been declared for the object named \fIobject\fR (i.e. that are automatically present in the object's methods). -.VS TIP500 -If the \fB\-private\fR option is given, this lists the private variables -declared instead. -.VE TIP500 +.VE 8.6 .TP \fBinfo object vars\fI object\fR ?\fIpattern\fR? -. +.VS 8.6 This subcommand returns a list of all variables in the private namespace of the object named \fIobject\fR. If the optional \fIpattern\fR argument is given, it is a filter (in the syntax of a \fBstring match\fR glob pattern) that constrains the list of variables returned. Note that this is different from the list returned by \fBinfo object variables\fR; that can include variables that are currently unset, whereas this can include variables that are not automatically included by any of \fIobject\fR's methods (or those of its class, superclasses or mixins). +.VE 8.6 .SH EXAMPLES .PP This command prints out a procedure suitable for saving in a Tcl script: .PP @@ -721,10 +700,11 @@ } puts [lappend result $formals [\fBinfo body\fR $procName]] } .CE .SS "EXAMPLES WITH OBJECTS" +.VS 8.6 .PP Every object necessarily knows what its class is; this information is trivially extractable through introspection: .PP .CS @@ -741,14 +721,12 @@ .PP .CS proc getDef {obj method} { foreach inf [\fBinfo object call\fR $obj $method] { lassign $inf calltype name locus methodtype - # Assume no forwards or filters, and hence no $calltype # or $methodtype checks... - if {$locus eq "object"} { return [\fBinfo object definition\fR $obj $name] } else { return [\fBinfo class definition\fR $locus $name] } @@ -767,30 +745,33 @@ proc getDef {obj method} { if {$method in [\fBinfo object methods\fR $obj]} { # Assume no forwards return [\fBinfo object definition\fR $obj $method] } - set cls [\fBinfo object class\fR $obj] - while {$method ni [\fBinfo class methods\fR $cls]} { # Assume the simple case set cls [lindex [\fBinfo class superclass\fR $cls] 0] if {$cls eq ""} { error "no definition for $method" } } - # Assume no forwards return [\fBinfo class definition\fR $cls $method] } .CE +.VE 8.6 .SH "SEE ALSO" +.VS 8.6 global(n), oo::class(n), oo::define(n), oo::object(n), proc(n), self(n), +.VE 8.6 tcl_library(n), tcl_patchLevel(n), tcl_version(n) .SH KEYWORDS command, information, interpreter, introspection, level, namespace, -object, procedure, variable +.VS 8.6 +object, +.VE 8.6 +procedure, variable '\" Local Variables: '\" mode: nroff '\" fill-column: 78 '\" End: Index: doc/interp.n ================================================================== --- doc/interp.n +++ doc/interp.n @@ -17,22 +17,22 @@ .BE .SH DESCRIPTION .PP This command makes it possible to create one or more new Tcl interpreters that co-exist with the creating interpreter in the -same application. The creating interpreter is called the \fImaster\fR -and the new interpreter is called a \fIslave\fR. -A master can create any number of slaves, and each slave can -itself create additional slaves for which it is master, resulting +same application. The creating interpreter is called the \fIparent\fR +and the new interpreter is called a \fIchild\fR. +A parent can create any number of children, and each child can +itself create additional children for which it is parent, resulting in a hierarchy of interpreters. .PP Each interpreter is independent from the others: it has its own name space for commands, procedures, and global variables. -A master interpreter may create connections between its slaves and +A parent interpreter may create connections between its children and itself using a mechanism called an \fIalias\fR. An \fIalias\fR is -a command in a slave interpreter which, when invoked, causes a -command to be invoked in its master interpreter or in another slave +a command in a child interpreter which, when invoked, causes a +command to be invoked in its parent interpreter or in another child interpreter. The only other connections between interpreters are through environment variables (the \fBenv\fR variable), which are normally shared among all interpreters in the application, and by resource limit exceeded callbacks. Note that the name space for files (such as the names returned by the \fBopen\fR command) @@ -39,11 +39,11 @@ is no longer shared between interpreters. Explicit commands are provided to share files and to transfer references to open files from one interpreter to another. .PP The \fBinterp\fR command also provides support for \fIsafe\fR -interpreters. A safe interpreter is a slave whose functions have +interpreters. A safe interpreter is a child whose functions have been greatly restricted, so that it is safe to execute untrusted scripts without fear of them damaging other interpreters or the application's environment. For example, all IO channel creation commands and subprocess creation commands are made inaccessible to safe interpreters. @@ -52,22 +52,22 @@ The dangerous functionality is not removed from the safe interpreter; instead, it is \fIhidden\fR, so that only trusted interpreters can obtain access to it. For a detailed explanation of hidden commands, see \fBHIDDEN COMMANDS\fR, below. The alias mechanism can be used for protected communication (analogous to a -kernel call) between a slave interpreter and its master. +kernel call) between a child interpreter and its parent. See \fBALIAS INVOCATION\fR, below, for more details on how the alias mechanism works. .PP -A qualified interpreter name is a proper Tcl lists containing a subset of its +A qualified interpreter name is a proper Tcl list containing a subset of its ancestors in the interpreter hierarchy, terminated by the string naming the -interpreter in its immediate master. Interpreter names are relative to the +interpreter in its immediate parent. Interpreter names are relative to the interpreter in which they are used. For example, if .QW \fBa\fR -is a slave of the current interpreter and it has a slave +is a child of the current interpreter and it has a child .QW \fBa1\fR , -which in turn has a slave +which in turn has a child .QW \fBa11\fR , the qualified name of .QW \fBa11\fR in .QW \fBa\fR @@ -75,53 +75,53 @@ .QW "\fBa1 a11\fR" . .PP The \fBinterp\fR command, described below, accepts qualified interpreter names as arguments; the interpreter in which the command is being evaluated can always be referred to as \fB{}\fR (the empty list or string). Note that -it is impossible to refer to a master (ancestor) interpreter by name in a -slave interpreter except through aliases. Also, there is no global name by +it is impossible to refer to a parent (ancestor) interpreter by name in a +child interpreter except through aliases. Also, there is no global name by which one can refer to the first interpreter created in an application. Both restrictions are motivated by safety concerns. .SH "THE INTERP COMMAND" .PP The \fBinterp\fR command is used to create, delete, and manipulate -slave interpreters, and to share or transfer +child interpreters, and to share or transfer channels between interpreters. It can have any of several forms, depending on the \fIsubcommand\fR argument: .TP \fBinterp\fR \fBalias\fR \fIsrcPath\fR \fIsrcToken\fR . Returns a Tcl list whose elements are the \fItargetCmd\fR and \fIarg\fRs associated with the alias represented by \fIsrcToken\fR (this is the value returned when the alias was created; it is possible that the name of the source command in the -slave is different from \fIsrcToken\fR). +child is different from \fIsrcToken\fR). .TP \fBinterp\fR \fBalias\fR \fIsrcPath\fR \fIsrcToken\fR \fB{}\fR . -Deletes the alias for \fIsrcToken\fR in the slave interpreter identified by +Deletes the alias for \fIsrcToken\fR in the child interpreter identified by \fIsrcPath\fR. \fIsrcToken\fR refers to the value returned when the alias was created; if the source command has been renamed, the renamed command will be deleted. .TP \fBinterp\fR \fBalias\fR \fIsrcPath\fR \fIsrcCmd\fR \fItargetPath\fR \fItargetCmd \fR?\fIarg arg ...\fR? . -This command creates an alias between one slave and another (see the -\fBalias\fR slave command below for creating aliases between a slave -and its master). In this command, either of the slave interpreters +This command creates an alias between one child and another (see the +\fBalias\fR child command below for creating aliases between a child +and its parent). In this command, either of the child interpreters may be anywhere in the hierarchy of interpreters under the interpreter invoking the command. \fISrcPath\fR and \fIsrcCmd\fR identify the source of the alias. \fISrcPath\fR is a Tcl list whose elements select a particular interpreter. For example, .QW "\fBa b\fR" identifies an interpreter .QW \fBb\fR , -which is a slave of interpreter +which is a child of interpreter .QW \fBa\fR , -which is a slave of the invoking interpreter. An empty list specifies +which is a child of the invoking interpreter. An empty list specifies the interpreter invoking the command. \fIsrcCmd\fR gives the name of a new command, which will be created in the source interpreter. \fITargetPath\fR and \fItargetCmd\fR specify a target interpreter and command, and the \fIarg\fR arguments, if any, specify additional arguments to \fItargetCmd\fR which are prepended to any arguments specified @@ -169,37 +169,37 @@ used. .VE 8.6 .TP \fBinterp\fR \fBcreate \fR?\fB\-safe\fR? ?\fB\-\|\-\fR? ?\fIpath\fR? . -Creates a slave interpreter identified by \fIpath\fR and a new command, -called a \fIslave command\fR. The name of the slave command is the last -component of \fIpath\fR. The new slave interpreter and the slave command +Creates a child interpreter identified by \fIpath\fR and a new command, +called a \fIchild command\fR. The name of the child command is the last +component of \fIpath\fR. The new child interpreter and the child command are created in the interpreter identified by the path obtained by removing the last component from \fIpath\fR. For example, if \fIpath\fR is \fBa b -c\fR then a new slave interpreter and slave command named \fBc\fR are +c\fR then a new child interpreter and child command named \fBc\fR are created in the interpreter identified by the path \fBa b\fR. -The slave command may be used to manipulate the new interpreter as +The child command may be used to manipulate the new interpreter as described below. If \fIpath\fR is omitted, Tcl creates a unique name of the form \fBinterp\fIx\fR, where \fIx\fR is an integer, and uses it for the -interpreter and the slave command. If the \fB\-safe\fR switch is specified -(or if the master interpreter is a safe interpreter), the new slave +interpreter and the child command. If the \fB\-safe\fR switch is specified +(or if the parent interpreter is a safe interpreter), the new child interpreter will be created as a safe interpreter with limited -functionality; otherwise the slave will include the full set of Tcl +functionality; otherwise the child will include the full set of Tcl built-in commands and variables. The \fB\-\|\-\fR switch can be used to mark the end of switches; it may be needed if \fIpath\fR is an unusual value such as \fB\-safe\fR. The result of the command is the name of the -new interpreter. The name of a slave interpreter must be unique among all -the slaves for its master; an error occurs if a slave interpreter by the -given name already exists in this master. -The initial recursion limit of the slave interpreter is set to the +new interpreter. The name of a child interpreter must be unique among all +the children for its parent; an error occurs if a child interpreter by the +given name already exists in this parent. +The initial recursion limit of the child interpreter is set to the current recursion limit of its parent interpreter. .TP \fBinterp\fR \fBdebug \fIpath\fR ?\fB\-frame\fR ?\fIbool\fR?? . Controls whether frame-level stack information is captured in the -slave interpreter identified by \fIpath\fR. If no arguments are +child interpreter identified by \fIpath\fR. If no arguments are given, option and current setting are returned. If \fB\-frame\fR is given, the debug setting is set to the given boolean if provided and the current setting is returned. This only affects the output of \fBinfo frame\fR, in that exact frame-level information for command invocation at the bytecode level @@ -234,36 +234,36 @@ Note that once it is on, this flag cannot be switched back off: such attempts are silently ignored. This is needed to maintain the consistency of the underlying interpreter's state. .RE .TP -\fBinterp\fR \fBdelete \fR?\fIpath ...\fR? +\fBinterp\fR \fBdelete \fR?\fIpath ...?\fR . Deletes zero or more interpreters given by the optional \fIpath\fR -arguments, and for each interpreter, it also deletes its slaves. The -command also deletes the slave command for each interpreter deleted. +arguments, and for each interpreter, it also deletes its children. The +command also deletes the child command for each interpreter deleted. For each \fIpath\fR argument, if no interpreter by that name exists, the command raises an error. .TP \fBinterp\fR \fBeval\fR \fIpath arg \fR?\fIarg ...\fR? . This command concatenates all of the \fIarg\fR arguments in the same fashion as the \fBconcat\fR command, then evaluates the resulting string as -a Tcl script in the slave interpreter identified by \fIpath\fR. The result +a Tcl script in the child interpreter identified by \fIpath\fR. The result of this evaluation (including all \fBreturn\fR options, such as \fB\-errorinfo\fR and \fB\-errorcode\fR information, if an error occurs) is returned to the invoking interpreter. Note that the script will be executed in the current context stack frame of the -\fIpath\fR interpreter; this is so that the implementations (in a master -interpreter) of aliases in a slave interpreter can execute scripts in -the slave that find out information about the slave's current state +\fIpath\fR interpreter; this is so that the implementations (in a parent +interpreter) of aliases in a child interpreter can execute scripts in +the child that find out information about the child's current state and stack frame. .TP \fBinterp exists \fIpath\fR . -Returns \fB1\fR if a slave interpreter by the specified \fIpath\fR -exists in this master, \fB0\fR otherwise. If \fIpath\fR is omitted, the +Returns \fB1\fR if a child interpreter by the specified \fIpath\fR +exists in this parent, \fB0\fR otherwise. If \fIpath\fR is omitted, the invoking interpreter is used. .TP \fBinterp expose \fIpath\fR \fIhiddenName\fR ?\fIexposedCmdName\fR? . Makes the hidden command \fIhiddenName\fR exposed, eventually bringing @@ -285,11 +285,11 @@ fails. Currently both \fIexposedCmdName\fR and \fIhiddenCmdName\fR can not contain namespace qualifiers, or an error is raised. Commands to be hidden by \fBinterp hide\fR are looked up in the global namespace even if the current namespace is not the global one. This -prevents slaves from fooling a master interpreter into hiding the wrong +prevents children from fooling a parent interpreter into hiding the wrong command, by making the current namespace be different from the global one. Hidden commands are explained in more detail in \fBHIDDEN COMMANDS\fR, below. .TP \fBinterp\fR \fBhidden\fR \fIpath\fR . @@ -371,13 +371,19 @@ channels accessible in an interpreter are automatically closed when an interpreter is destroyed. .TP \fBinterp\fR \fBslaves\fR ?\fIpath\fR? . -Returns a Tcl list of the names of all the slave interpreters associated +Returns a Tcl list of the names of all the child interpreters associated with the interpreter identified by \fIpath\fR. If \fIpath\fR is omitted, the invoking interpreter is used. +.VS "TIP 581" +.TP +\fBinterp\fR \fBchildren\fR ?\fIpath\fR? +. +Synonym for . \fBinterp\fR \fBslaves\fR ?\fIpath\fR? +.VE "TIP 581" .TP \fBinterp\fR \fBtarget\fR \fIpath alias\fR . Returns a Tcl list describing the target interpreter for an alias. The alias is specified with an interpreter path and source command name, just @@ -391,161 +397,161 @@ \fBinterp\fR \fBtransfer\fR \fIsrcPath channelId destPath\fR . Causes the IO channel identified by \fIchannelId\fR to become available in the interpreter identified by \fIdestPath\fR and unavailable in the interpreter identified by \fIsrcPath\fR. -.SH "SLAVE COMMAND" +.SH "child COMMAND" .PP -For each slave interpreter created with the \fBinterp\fR command, a -new Tcl command is created in the master interpreter with the same +For each child interpreter created with the \fBinterp\fR command, a +new Tcl command is created in the parent interpreter with the same name as the new interpreter. This command may be used to invoke various operations on the interpreter. It has the following general form: .PP .CS -\fIslave command \fR?\fIarg arg ...\fR? +\fIchild command \fR?\fIarg arg ...\fR? .CE .PP -\fISlave\fR is the name of the interpreter, and \fIcommand\fR +\fIchild\fR is the name of the interpreter, and \fIcommand\fR and the \fIarg\fRs determine the exact behavior of the command. The valid forms of this command are: .TP -\fIslave \fBaliases\fR +\fIchild \fBaliases\fR . Returns a Tcl list whose elements are the tokens of all the -aliases in \fIslave\fR. The tokens correspond to the values returned when +aliases in \fIchild\fR. The tokens correspond to the values returned when the aliases were created (which may not be the same as the current names of the commands). .TP -\fIslave \fBalias \fIsrcToken\fR +\fIchild \fBalias \fIsrcToken\fR . Returns a Tcl list whose elements are the \fItargetCmd\fR and \fIarg\fRs associated with the alias represented by \fIsrcToken\fR (this is the value returned when the alias was created; it is possible that the actual source command in the -slave is different from \fIsrcToken\fR). +child is different from \fIsrcToken\fR). .TP -\fIslave \fBalias \fIsrcToken \fB{}\fR +\fIchild \fBalias \fIsrcToken \fB{}\fR . -Deletes the alias for \fIsrcToken\fR in the slave interpreter. +Deletes the alias for \fIsrcToken\fR in the child interpreter. \fIsrcToken\fR refers to the value returned when the alias was created; if the source command has been renamed, the renamed command will be deleted. .TP -\fIslave \fBalias \fIsrcCmd targetCmd \fR?\fIarg ..\fR? +\fIchild \fBalias \fIsrcCmd targetCmd \fR?\fIarg ..\fR? . Creates an alias such that whenever \fIsrcCmd\fR is invoked -in \fIslave\fR, \fItargetCmd\fR is invoked in the master. +in \fIchild\fR, \fItargetCmd\fR is invoked in the parent. The \fIarg\fR arguments will be passed to \fItargetCmd\fR as additional arguments, prepended before any arguments passed in the invocation of \fIsrcCmd\fR. See \fBALIAS INVOCATION\fR below for details. The command returns a token that uniquely identifies the command created \fIsrcCmd\fR, even if the command is renamed afterwards. The token may but does not have to be equal to \fIsrcCmd\fR. .TP -\fIslave \fBbgerror\fR ?\fIcmdPrefix\fR? +\fIchild \fBbgerror\fR ?\fIcmdPrefix\fR? . This command either gets or sets the current background exception handler -for the \fIslave\fR interpreter. If \fIcmdPrefix\fR is +for the \fIchild\fR interpreter. If \fIcmdPrefix\fR is absent, the current background exception handler is returned, and if it is present, it is a list of words (of minimum length one) that describes what to set the interpreter's background exception handler to. See the \fBBACKGROUND EXCEPTION HANDLING\fR section for more details. .TP -\fIslave \fBeval \fIarg \fR?\fIarg ..\fR? +\fIchild \fBeval \fIarg \fR?\fIarg ..\fR? . This command concatenates all of the \fIarg\fR arguments in the same fashion as the \fBconcat\fR command, then evaluates -the resulting string as a Tcl script in \fIslave\fR. +the resulting string as a Tcl script in \fIchild\fR. The result of this evaluation (including all \fBreturn\fR options, such as \fB\-errorinfo\fR and \fB\-errorcode\fR information, if an error occurs) is returned to the invoking interpreter. Note that the script will be executed in the current context stack frame -of \fIslave\fR; this is so that the implementations (in a master -interpreter) of aliases in a slave interpreter can execute scripts in -the slave that find out information about the slave's current state +of \fIchild\fR; this is so that the implementations (in a parent +interpreter) of aliases in a child interpreter can execute scripts in +the child that find out information about the child's current state and stack frame. .TP -\fIslave \fBexpose \fIhiddenName \fR?\fIexposedCmdName\fR? +\fIchild \fBexpose \fIhiddenName \fR?\fIexposedCmdName\fR? . This command exposes the hidden command \fIhiddenName\fR, eventually bringing it back under a new \fIexposedCmdName\fR name (this name is currently accepted only if it is a valid global name space name without any ::), -in \fIslave\fR. +in \fIchild\fR. If an exposed command with the targeted name already exists, this command fails. For more details on hidden commands, see \fBHIDDEN COMMANDS\fR, below. .TP -\fIslave \fBhide \fIexposedCmdName\fR ?\fIhiddenCmdName\fR? +\fIchild \fBhide \fIexposedCmdName\fR ?\fIhiddenCmdName\fR? . This command hides the exposed command \fIexposedCmdName\fR, renaming it to the hidden command \fIhiddenCmdName\fR, or keeping the same name if the -argument is not given, in the \fIslave\fR interpreter. +argument is not given, in the \fIchild\fR interpreter. If a hidden command with the targeted name already exists, this command fails. Currently both \fIexposedCmdName\fR and \fIhiddenCmdName\fR can not contain namespace qualifiers, or an error is raised. Commands to be hidden are looked up in the global namespace even if the current namespace is not the global one. This -prevents slaves from fooling a master interpreter into hiding the wrong +prevents children from fooling a parent interpreter into hiding the wrong command, by making the current namespace be different from the global one. For more details on hidden commands, see \fBHIDDEN COMMANDS\fR, below. .TP -\fIslave \fBhidden\fR +\fIchild \fBhidden\fR . -Returns a list of the names of all hidden commands in \fIslave\fR. +Returns a list of the names of all hidden commands in \fIchild\fR. .TP -\fIslave \fBinvokehidden\fR ?\fI\-option ...\fR? \fIhiddenName \fR?\fIarg ..\fR? +\fIchild \fBinvokehidden\fR ?\fI\-option ...\fR? \fIhiddenName \fR?\fIarg ..\fR? . This command invokes the hidden command \fIhiddenName\fR with the -supplied arguments, in \fIslave\fR. No substitutions or evaluations are +supplied arguments, in \fIchild\fR. No substitutions or evaluations are applied to the arguments. Three \fI\-option\fRs are supported, all of which start with \fB\-\fR: \fB\-namespace\fR (which takes a single argument afterwards, \fInsName\fR), \fB\-global\fR, and \fB\-\|\-\fR. If the \fB\-namespace\fR flag is given, the hidden command is invoked in -the specified namespace in the slave. +the specified namespace in the child. If the \fB\-global\fR flag is given, the command is invoked at the global -level in the slave; otherwise it is invoked at the current call frame and +level in the child; otherwise it is invoked at the current call frame and can access local variables in that or outer call frames. The \fB\-\|\-\fR flag allows the \fIhiddenCmdName\fR argument to start with a .QW \- character, and is otherwise unnecessary. If both the \fB\-namespace\fR and \fB\-global\fR flags are given, the \fB\-namespace\fR flag is ignored. Note that the hidden command will be executed (by default) in the -current context stack frame of \fIslave\fR. +current context stack frame of \fIchild\fR. For more details on hidden commands, see \fBHIDDEN COMMANDS\fR, below. .TP -\fIslave \fBissafe\fR +\fIchild \fBissafe\fR . -Returns \fB1\fR if the slave interpreter is safe, \fB0\fR otherwise. +Returns \fB1\fR if the child interpreter is safe, \fB0\fR otherwise. .TP -\fIslave \fBlimit\fR \fIlimitType\fR ?\fI\-option\fR? ?\fIvalue\fR \fI...\fR? +\fIchild \fBlimit\fR \fIlimitType\fR ?\fI\-option\fR? ?\fIvalue\fR \fI...\fR? . Sets up, manipulates and queries the configuration of the resource -limit \fIlimitType\fR for the slave interpreter. If no \fI\-option\fR +limit \fIlimitType\fR for the child interpreter. If no \fI\-option\fR is specified, return the current configuration of the limit. If \fI\-option\fR is the sole argument, return the value of that option. Otherwise, a list of \fI\-option\fR/\fIvalue\fR argument pairs must supplied. See \fBRESOURCE LIMITS\fR below for a more detailed explanation of what limits and options are supported. .TP -\fIslave \fBmarktrusted\fR +\fIchild \fBmarktrusted\fR . -Marks the slave interpreter as trusted. Can only be invoked by a +Marks the child interpreter as trusted. Can only be invoked by a trusted interpreter. This command does not expose any hidden -commands in the slave interpreter. The command has no effect if the slave +commands in the child interpreter. The command has no effect if the child is already trusted. .TP -\fIslave\fR \fBrecursionlimit\fR ?\fInewlimit\fR? +\fIchild\fR \fBrecursionlimit\fR ?\fInewlimit\fR? . -Returns the maximum allowable nesting depth for the \fIslave\fR interpreter. -If \fInewlimit\fR is specified, the recursion limit in \fIslave\fR will be +Returns the maximum allowable nesting depth for the \fIchild\fR interpreter. +If \fInewlimit\fR is specified, the recursion limit in \fIchild\fR will be set so that nesting of more than \fInewlimit\fR calls to \fBTcl_Eval()\fR -and related procedures in \fIslave\fR will return an error. +and related procedures in \fIchild\fR will return an error. The \fInewlimit\fR value is also returned. The \fInewlimit\fR value must be a positive integer between 1 and the maximum value of a non-long integer on the platform. .RS .PP @@ -565,18 +571,18 @@ safe, certain commands and variables are removed from the interpreter. For example, commands to create files on disk are removed, and the \fBexec\fR command is removed, since it could be used to cause damage through subprocesses. Limited access to these facilities can be provided, by creating -aliases to the master interpreter which check their arguments carefully +aliases to the parent interpreter which check their arguments carefully and provide restricted access to a safe subset of facilities. For example, file creation might be allowed in a particular subdirectory and subprocess invocation might be allowed for a carefully selected and fixed set of programs. .PP A safe interpreter is created by specifying the \fB\-safe\fR switch -to the \fBinterp create\fR command. Furthermore, any slave created +to the \fBinterp create\fR command. Furthermore, any child created by a safe interpreter will also be safe. .PP A safe interpreter is created with exactly the following set of built-in commands: .DS @@ -659,19 +665,19 @@ A safe interpreter may not alter the recursion limit of any interpreter, including itself. .SH "ALIAS INVOCATION" .PP The alias mechanism has been carefully designed so that it can -be used safely when an untrusted script is executing -in a safe slave and the target of the alias is a trusted -master. The most important thing in guaranteeing safety is to -ensure that information passed from the slave to the master is -never evaluated or substituted in the master; if this were to -occur, it would enable an evil script in the slave to invoke -arbitrary functions in the master, which would compromise security. +be used safely in an untrusted script which is being executed in a +safe interpreter even if the target of the alias is not a safe +interpreter. The most important thing in guaranteeing safety is to +ensure that information passed from the child to the parent is +never evaluated or substituted in the parent; if this were to +occur, it would enable an evil script in the child to invoke +arbitrary functions in the parent, which would compromise security. .PP -When the source for an alias is invoked in the slave interpreter, the +When the source for an alias is invoked in the child interpreter, the usual Tcl substitutions are performed when parsing that command. These substitutions are carried out in the source interpreter just as they would be for any other command invoked in that interpreter. The command procedure for the source command takes its arguments and merges them with the \fItargetCmd\fR and \fIarg\fRs for the @@ -694,12 +700,12 @@ the alias's source command is parsed in the source interpreter. .PP When writing the \fItargetCmd\fRs for aliases in safe interpreters, it is very important that the arguments to that command never be evaluated or substituted, since this would provide an escape -mechanism whereby the slave interpreter could execute arbitrary -code in the master. This in turn would compromise the security +mechanism whereby the child interpreter could execute arbitrary +code in the parent. This in turn would compromise the security of the system. .SH "HIDDEN COMMANDS" .PP Safe interpreters greatly restrict the functionality available to Tcl programs executing within them. @@ -722,32 +728,32 @@ interpreter, in the context of the safe interpreter, using \fBinterp invoke\fR. Hidden commands and exposed commands reside in separate name spaces. It is possible to define a hidden command and an exposed command by the same name within one interpreter. .PP -Hidden commands in a slave interpreter can be invoked in the body of -procedures called in the master during alias invocation. For example, an -alias for \fBsource\fR could be created in a slave interpreter. When it is -invoked in the slave interpreter, a procedure is called in the master +Hidden commands in a child interpreter can be invoked in the body of +procedures called in the parent during alias invocation. For example, an +alias for \fBsource\fR could be created in a child interpreter. When it is +invoked in the child interpreter, a procedure is called in the parent interpreter to check that the operation is allowable (e.g. it asks to -source a file that the slave interpreter is allowed to access). The -procedure then it invokes the hidden \fBsource\fR command in the slave +source a file that the child interpreter is allowed to access). The +procedure then it invokes the hidden \fBsource\fR command in the child interpreter to actually source in the contents of the file. Note that two -commands named \fBsource\fR exist in the slave interpreter: the alias, and +commands named \fBsource\fR exist in the child interpreter: the alias, and the hidden command. .PP -Because a master interpreter may invoke a hidden command as part of +Because a parent interpreter may invoke a hidden command as part of handling an alias invocation, great care must be taken to avoid evaluating any arguments passed in through the alias invocation. -Otherwise, malicious slave interpreters could cause a trusted master +Otherwise, malicious child interpreters could cause a trusted parent interpreter to execute dangerous commands on their behalf. See the section on \fBALIAS INVOCATION\fR for a more complete discussion of this topic. To help avoid this problem, no substitutions or evaluations are applied to arguments of \fBinterp invokehidden\fR. .PP Safe interpreters are not allowed to invoke hidden commands in themselves -or in their descendants. This prevents safe slaves from gaining access to +or in their descendants. This prevents them from gaining access to hidden functionality in themselves or their descendants. .PP The set of hidden commands in an interpreter can be manipulated by a trusted interpreter using \fBinterp expose\fR and \fBinterp hide\fR. The \fBinterp expose\fR command moves a hidden command to the @@ -762,25 +768,25 @@ Currently, the names of hidden commands cannot contain namespace qualifiers, and you must first rename a command in a namespace to the global namespace before you can hide it. Commands to be hidden by \fBinterp hide\fR are looked up in the global namespace even if the current namespace is not the global one. This -prevents slaves from fooling a master interpreter into hiding the wrong +prevents children from fooling a parent interpreter into hiding the wrong command, by making the current namespace be different from the global one. .SH "RESOURCE LIMITS" .PP Every interpreter has two kinds of resource limits that may be imposed by any -master interpreter upon its slaves. Command limits (of type \fBcommand\fR) +parent interpreter upon its children. Command limits (of type \fBcommand\fR) restrict the total number of Tcl commands that may be executed by an interpreter (as can be inspected via the \fBinfo cmdcount\fR command), and time limits (of type \fBtime\fR) place a limit by which execution within the interpreter must complete. Note that time limits are expressed as \fIabsolute\fR times (as in \fBclock seconds\fR) and not relative times (as in \fBafter\fR) because they may be modified after creation. .PP When a limit is exceeded for an interpreter, first any handler callbacks -defined by master interpreters are called. If those callbacks increase or +defined by parent interpreters are called. If those callbacks increase or remove the limit, execution within the (previously) limited interpreter continues. If the limit is still in force, an error is generated at that point and normal processing of errors within the interpreter (by the \fBcatch\fR command) is disabled, so the error propagates outwards (building a stack-trace as it goes) to the point where the limited interpreter was invoked (e.g. by @@ -833,17 +839,17 @@ . This option specifies the number of commands that the interpreter may execute before triggering the command limit. This option may be the empty string, which indicates that a command limit is not set for the interpreter. .PP -Where an interpreter with a resource limit set on it creates a slave -interpreter, that slave interpreter will have resource limits imposed on it -that are at least as restrictive as the limits on the creating master -interpreter. If the master interpreter of the limited master wishes to relax +Where an interpreter with a resource limit set on it creates a child +interpreter, that child interpreter will have resource limits imposed on it +that are at least as restrictive as the limits on the creating parent +interpreter. If the parent interpreter of the limited parent wishes to relax these conditions, it should hide the \fBinterp\fR command in the child and then use aliases and the \fBinterp invokehidden\fR subcommand to provide such -access as it chooses to the \fBinterp\fR command to the limited master as +access as it chooses to the \fBinterp\fR command to the limited parent as necessary. .SH "BACKGROUND EXCEPTION HANDLING" .PP When an exception happens in a situation where it cannot be reported directly up the stack (e.g. when processing events in an \fBupdate\fR or \fBvwait\fR call) @@ -900,11 +906,11 @@ puts "Counting up... [incr x]" } } .CE .SH "SEE ALSO" -bgerror(n), load(n), safe(n), Tcl_CreateSlave(3), Tcl_Eval(3), Tcl_BackgroundException(3) +bgerror(n), load(n), safe(n), Tcl_CreateChild(3), Tcl_Eval(3), Tcl_BackgroundException(3) .SH KEYWORDS -alias, master interpreter, safe interpreter, slave interpreter +alias, parent interpreter, safe interpreter, child interpreter '\"Local Variables: '\"mode: nroff '\"End: Index: doc/join.n ================================================================== --- doc/join.n +++ doc/join.n @@ -40,9 +40,5 @@ .CE .SH "SEE ALSO" list(n), lappend(n), split(n) .SH KEYWORDS element, join, list, separator -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/lappend.n ================================================================== --- doc/lappend.n +++ doc/lappend.n @@ -20,16 +20,10 @@ This command treats the variable given by \fIvarName\fR as a list and appends each of the \fIvalue\fR arguments to that list as a separate element, with spaces between elements. If \fIvarName\fR does not exist, it is created as a list with elements given by the \fIvalue\fR arguments. -.VS TIP508 -If \fIvarName\fR indicate an element that does not exist of an array that has -a default value set, list that is comprised of the default value with all the -\fIvalue\fR arguments appended as elements will be stored in the array -element. -.VE TIP508 \fBLappend\fR is similar to \fBappend\fR except that the \fIvalue\fRs are appended as list elements rather than raw text. This command provides a relatively efficient way to build up large lists. For example, .QW "\fBlappend a $b\fR" @@ -51,9 +45,5 @@ .SH "SEE ALSO" list(n), lindex(n), linsert(n), llength(n), lset(n), lsort(n), lrange(n) .SH KEYWORDS append, element, list, variable -.\" Local variables: -.\" mode: nroff -.\" fill-column: 78 -.\" End: Index: doc/library.n ================================================================== --- doc/library.n +++ doc/library.n @@ -122,11 +122,11 @@ .PP will read all the \fB.tcl\fR files in subdirectory \fBfoo\fR and generate a new index file \fBfoo/tclIndex\fR. .PP \fBAuto_mkindex\fR parses the Tcl scripts by sourcing them into a -slave interpreter and monitoring the proc and namespace commands that +child interpreter and monitoring the proc and namespace commands that are executed. Extensions can use the (undocumented) auto_mkindex_parser package to register other commands that can contribute to the auto_load index. You will have to read through auto.tcl to see how this works. .PP Index: doc/lindex.n ================================================================== --- doc/lindex.n +++ doc/lindex.n @@ -11,11 +11,11 @@ .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lindex \- Retrieve an element from a list .SH SYNOPSIS -\fBlindex \fIlist\fR ?\fIindex ...\fR? +\fBlindex \fIlist ?index ...?\fR .BE .SH DESCRIPTION .PP The \fBlindex\fR command accepts a parameter, \fIlist\fR, which it treats as a Tcl list. It also accepts zero or more \fIindices\fR into DELETED doc/link.n Index: doc/link.n ================================================================== --- doc/link.n +++ /dev/null @@ -1,124 +0,0 @@ -'\" -'\" Copyright (c) 2011-2015 Andreas Kupries -'\" Copyright (c) 2018 Donal K. Fellows -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH link n 0.3 TclOO "TclOO Commands" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -link \- create link from command to method of object -.SH SYNOPSIS -.nf -package require TclOO - -\fBlink\fR \fImethodName\fR ?\fI...\fR? -\fBlink\fR \fB{\fIcommandName methodName\fB}\fR ?\fI...\fR? -.fi -.BE -.SH DESCRIPTION -The \fBlink\fR command is available within methods. It takes a series of one -or more method names (\fImethodName ...\fR) and/or pairs of command- and -method-name (\fB{\fIcommandName methodName\fB}\fR) and makes the named methods -available as commands without requiring the explicit use of the name of the -object or the \fBmy\fR command. The method does not need to exist at the time -that the link is made; if the link command is invoked when the method does not -exist, the standard \fBunknown\fR method handling system is used. -.PP -The command name under which the method becomes available defaults to the -method name, except where explicitly specified through an alias/method pair. -Formally, every argument must be a list; if the list has two elements, the -first element is the name of the command to create and the second element is -the name of the method of the current object to which the command links; -otherwise, the name of the command and the name of the method are the same -string (the first element of the list). -.PP -If the name of the command is not a fully-qualified command name, it will be -resolved with respect to the current namespace (i.e., the object namespace). -.SH EXAMPLES -This demonstrates linking a single method in various ways. First it makes a -simple link, then a renamed link, then an external link. Note that the method -itself is unexported, but that it can still be called directly from outside -the class. -.PP -.CS -oo::class create ABC { - method Foo {} { - puts "This is Foo in [self]" - } - - constructor {} { - \fBlink\fR Foo - # The method foo is now directly accessible as foo here - \fBlink\fR {bar Foo} - # The method foo is now directly accessible as bar - \fBlink\fR {::ExternalCall Foo} - # The method foo is now directly accessible in the global - # namespace as ExternalCall - } - - method grill {} { - puts "Step 1:" - Foo - puts "Step 2:" - bar - } -} - -ABC create abc -abc grill - \fI\(-> Step 1:\fR - \fI\(-> This is foo in ::abc\fR - \fI\(-> Step 2:\fR - \fI\(-> This is foo in ::abc\fR -# Direct access via the linked command -puts "Step 3:"; ExternalCall - \fI\(-> Step 3:\fR - \fI\(-> This is foo in ::abc\fR -.CE -.PP -This example shows that multiple linked commands can be made in a call to -\fBlink\fR, and that they can handle arguments. -.PP -.CS -oo::class create Ex { - constructor {} { - \fBlink\fR a b c - # The methods a, b, and c (defined below) are all now - # directly acessible within methods under their own names. - } - - method a {} { - puts "This is a" - } - method b {x} { - puts "This is b($x)" - } - method c {y z} { - puts "This is c($y,$z)" - } - - method call {p q r} { - a - b $p - c $q $r - } -} - -set o [Ex new] -$o 3 5 7 - \fI\(-> This is a\fR - \fI\(-> This is b(3)\fR - \fI\(-> This is c(5,7)\fR -.CE -.SH "SEE ALSO" -interp(n), my(n), oo::class(n), oo::define(n) -.SH KEYWORDS -command, method, object -.\" Local Variables: -.\" mode: nroff -.\" fill-column: 78 -.\" End: Index: doc/llength.n ================================================================== --- doc/llength.n +++ doc/llength.n @@ -51,9 +51,5 @@ .SH "SEE ALSO" list(n), lappend(n), lindex(n), linsert(n), lsearch(n), lset(n), lsort(n), lrange(n), lreplace(n) .SH KEYWORDS element, list, length -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/load.n ================================================================== --- doc/load.n +++ doc/load.n @@ -152,11 +152,11 @@ The following is a minimal extension: .PP .CS #include #include -static int fooCmd(void *clientData, +static int fooCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { printf("called with %d arguments\en", objc); return TCL_OK; } int Foo_Init(Tcl_Interp *interp) { DELETED doc/lpop.n Index: doc/lpop.n ================================================================== --- doc/lpop.n +++ /dev/null @@ -1,96 +0,0 @@ -'\" -'\" Copyright (c) 2018 by Peter Spjuth. All rights reserved. -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH lpop n 8.7 Tcl "Tcl Built-In Commands" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -lpop \- Get and remove an element in a list -.SH SYNOPSIS -\fBlpop \fIvarName ?index ...?\fR -.BE -.SH DESCRIPTION -.PP -The \fBlpop\fR command accepts a parameter, \fIvarName\fR, which -it interprets as the name of a variable containing a Tcl list. -It also accepts one or more \fIindices\fR into -the list. If no indices are presented, it defaults to "end". -.PP -When presented with a single index, the \fBlpop\fR command -addresses the \fIindex\fR'th element in it, removes if from the list -and returns the element. -.PP -If \fIindex\fR is negative or greater or equal than the number -of elements in \fI$varName\fR, then an error occurs. -.PP -The interpretation of each simple \fIindex\fR value is the same as -for the command \fBstring index\fR, supporting simple index -arithmetic and indices relative to the end of the list. -.PP -If additional \fIindex\fR arguments are supplied, then each argument is -used in turn to address an element within a sublist designated -by the previous indexing operation, -allowing the script to remove elements in sublists. -The command, -.PP -.CS -\fBlpop\fR a 1 2 -.CE -.PP -gets and removes element 2 of sublist 1. -.PP -.SH EXAMPLES -.PP -In each of these examples, the initial value of \fIx\fR is: -.PP -.CS -set x [list [list a b c] [list d e f] [list g h i]] - \fI\(-> {a b c} {d e f} {g h i}\fR -.CE -.PP -The indicated value becomes the new value of \fIx\fR -(except in the last case, which is an error which leaves the value of -\fIx\fR unchanged.) -.PP -.CS -\fBlpop\fR x 0 - \fI\(-> {d e f} {g h i}\fR -\fBlpop\fR x 2 - \fI\(-> {a b c} {d e f}\fR -\fBlpop\fR x end - \fI\(-> {a b c} {d e f}\fR -\fBlpop\fR x end-1 - \fI\(-> {a b c} {g h i}\fR -\fBlpop\fR x 2 1 - \fI\(-> {a b c} {d e f} {g i}\fR -\fBlpop\fR x 2 3 j - \fI\(-> list index out of range\fR -.CE -.PP -In the following examples, the initial value of \fIx\fR is: -.PP -.CS -set x [list [list [list a b] [list c d]] \e - [list [list e f] [list g h]]] - \fI\(-> {{a b} {c d}} {{e f} {g h}}\fR -.CE -.PP -The indicated value becomes the new value of \fIx\fR. -.PP -.CS -\fBlpop\fR x 1 1 0 - \fI\(-> {{a b} {c d}} {{e f} h}\fR -.CE -.SH "SEE ALSO" -list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), -lsort(n), lrange(n), lreplace(n), lset(n) -string(n) -.SH KEYWORDS -element, index, list, remove, pop, stack, queue -'\"Local Variables: -'\"mode: nroff -'\"End: Index: doc/lrange.n ================================================================== --- doc/lrange.n +++ doc/lrange.n @@ -70,13 +70,9 @@ % \fBlrange\fR $var 1 1 {elements to} .CE .SH "SEE ALSO" list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), -lset(n), lremove(n), lreplace(n), lsort(n), +lset(n), lreplace(n), lsort(n), string(n) .SH KEYWORDS element, list, range, sublist -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: DELETED doc/lremove.n Index: doc/lremove.n ================================================================== --- doc/lremove.n +++ /dev/null @@ -1,55 +0,0 @@ -'\" -'\" Copyright (c) 2019 Donal K. Fellows. -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH lremove n 8.7 Tcl "Tcl Built-In Commands" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -lremove \- Remove elements from a list by index -.SH SYNOPSIS -\fBlremove \fIlist\fR ?\fIindex ...\fR? -.BE -.SH DESCRIPTION -.PP -\fBlremove\fR returns a new list formed by simultaneously removing zero or -more elements of \fIlist\fR at each of the indices given by an arbirary number -of \fIindex\fR arguments. The indices may be in any order and may be repeated; -the element at index will only be removed once. The index values are -interpreted the same as index values for the command \fBstring index\fR, -supporting simple index arithmetic and indices relative to the end of the -list. 0 refers to the first element of the list, and \fBend\fR refers to the -last element of the list. -.SH EXAMPLES -.PP -Removing the third element of a list: -.PP -.CS -% \fBlremove\fR {a b c d e} 2 -a b d e -.CE -.PP -Removing two elements from a list: -.PP -.CS -% \fBlremove\fR {a b c d e} end-1 1 -a c e -.CE -.PP -Removing the same element indicated in two different ways: -.PP -.CS -% \fBlremove\fR {a b c d e} 2 end-2 -a b d e -.CE -.SH "SEE ALSO" -list(n), lrange(n), lsearch(n), lsearch(n) -.SH KEYWORDS -element, list, remove -.\" Local variables: -.\" mode: nroff -.\" fill-column: 78 -.\" End: Index: doc/lrepeat.n ================================================================== --- doc/lrepeat.n +++ doc/lrepeat.n @@ -31,11 +31,8 @@ \fBlrepeat\fR 3 [\fBlrepeat\fR 2 a] b c \fI\(-> {a a} b c {a a} b c {a a} b c\fR .CE .SH "SEE ALSO" list(n), lappend(n), linsert(n), llength(n), lset(n) + .SH KEYWORDS element, index, list -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/lreplace.n ================================================================== --- doc/lreplace.n +++ doc/lreplace.n @@ -94,11 +94,11 @@ a b c d e f g h i .CE .VE TIP505 .SH "SEE ALSO" list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), -lset(n), lrange(n), lremove(n), lsort(n), +lset(n), lrange(n), lsort(n), string(n) .SH KEYWORDS element, list, replace .\" Local variables: .\" mode: nroff Index: doc/lsearch.n ================================================================== --- doc/lsearch.n +++ doc/lsearch.n @@ -20,11 +20,12 @@ .PP This command searches the elements of \fIlist\fR to see if one of them matches \fIpattern\fR. If so, the command returns the index of the first matching element (unless the options \fB\-all\fR or \fB\-inline\fR are specified.) -If not, the command returns \fB\-1\fR. The \fIoption\fR arguments +If not, the command returns \fB\-1\fR or (if options \fB\-all\fR +or \fB\-inline\fR are specified) the empty string. The \fIoption\fR arguments indicates how the elements of the list are to be matched against \fIpattern\fR and must have one of the values below: .SS "MATCHING STYLE OPTIONS" .PP If all matching style options are omitted, the default matching style @@ -146,23 +147,10 @@ .SS "NESTED LIST OPTIONS" .PP These options are used to search lists of lists. They may be used with any other options. .TP -\fB\-stride\0\fIstrideLength\fR -. -If this option is specified, the list is treated as consisting of -groups of \fIstrideLength\fR elements and the groups are searched by -either their first element or, if the \fB\-index\fR option is used, -by the element within each group given by the first index passed to -\fB\-index\fR (which is then ignored by \fB\-index\fR). The resulting -index always points to the first element in a group. -.PP -The list length must be an integer multiple of \fIstrideLength\fR, which -in turn must be at least 1. A \fIstrideLength\fR of 1 is the default and -indicates no grouping. -.TP \fB\-index\fR\0\fIindexList\fR . This option is designed for use when searching within nested lists. The \fIindexList\fR argument gives a path of indices (much as might be used with the \fBlindex\fR or \fBlset\fR commands) within each element @@ -219,17 +207,10 @@ .PP .CS \fBlsearch\fR -index 1 -all -inline {{a abc} {b bcd} {c cde}} *bc* \fI\(-> {a abc} {b bcd}\fR .CE -.PP -The same thing for a flattened list: -.PP -.CS -\fBlsearch\fR -stride 2 -index 1 -all -inline {a abc b bcd c cde} *bc* - \fI\(-> {a abc b bcd}\fR -.CE .SH "SEE ALSO" foreach(n), list(n), lappend(n), lindex(n), linsert(n), llength(n), lset(n), lsort(n), lrange(n), lreplace(n), string(n) .SH KEYWORDS Index: doc/mathfunc.n ================================================================== --- doc/mathfunc.n +++ doc/mathfunc.n @@ -45,28 +45,12 @@ .br \fB::tcl::mathfunc::hypot\fR \fIx\fR \fIy\fR .br \fB::tcl::mathfunc::int\fR \fIarg\fR .br -.VS "8.7, TIP 521" -\fB::tcl::mathfunc::isfinite\fR \fIarg\fR -.br -\fB::tcl::mathfunc::isinf\fR \fIarg\fR -.br -\fB::tcl::mathfunc::isnan\fR \fIarg\fR -.br -\fB::tcl::mathfunc::isnormal\fR \fIarg\fR -.VE "8.7, TIP 521" -.br \fB::tcl::mathfunc::isqrt\fR \fIarg\fR .br -.VS "8.7, TIP 521" -\fB::tcl::mathfunc::issubnormal\fR \fIarg\fR -.br -\fB::tcl::mathfunc::isunordered\fR \fIx y\fR -.VE "8.7, TIP 521" -.br \fB::tcl::mathfunc::log\fR \fIarg\fR .br \fB::tcl::mathfunc::log10\fR \fIarg\fR .br \fB::tcl::mathfunc::max\fR \fIarg\fR ?\fIarg\fR ...? @@ -106,27 +90,28 @@ directly. .PP Tcl supports the following mathematical functions in expressions, all of which work solely with floating-point numbers unless otherwise noted: .DS -.ta 3.2c 6.4c 9.6c +.ta 3c 6c 9c \fBabs\fR \fBacos\fR \fBasin\fR \fBatan\fR \fBatan2\fR \fBbool\fR \fBceil\fR \fBcos\fR \fBcosh\fR \fBdouble\fR \fBentier\fR \fBexp\fR \fBfloor\fR \fBfmod\fR \fBhypot\fR \fBint\fR -\fBisfinite\fR \fBisinf\fR \fBisnan\fR \fBisnormal\fR -\fBisqrt\fR \fBissubnormal\fR \fBisunordered\fR \fBlog\fR -\fBlog10\fR \fBmax\fR \fBmin\fR \fBpow\fR -\fBrand\fR \fBround\fR \fBsin\fR \fBsinh\fR -\fBsqrt\fR \fBsrand\fR \fBtan\fR \fBtanh\fR -\fBwide\fR +\fBisqrt\fR \fBlog\fR \fBlog10\fR \fBmax\fR +\fBmin\fR \fBpow\fR \fBrand\fR \fBround\fR +\fBsin\fR \fBsinh\fR \fBsqrt\fR \fBsrand\fR +\fBtan\fR \fBtanh\fR \fBwide\fR .DE .PP In addition to these predefined functions, applications may define additional functions by using \fBproc\fR (or any other method, such as \fBinterp alias\fR or \fBTcl_CreateObjCommand\fR) to define -new commands in the \fBtcl::mathfunc\fR namespace. +new commands in the \fBtcl::mathfunc\fR namespace. In addition, an +obsolete interface named \fBTcl_CreateMathFunc\fR() is available to +extensions that are written in C. The latter interface is not recommended +for new implementations. .SS "DETAILED DEFINITIONS" .TP \fBabs \fIarg\fR . Returns the absolute value of \fIarg\fR. \fIArg\fR may be either @@ -222,62 +207,17 @@ is determined, and then the low order bits of that integer value up to the machine word size are returned as an integer value. For reference, the number of bytes in the machine word are stored in the \fBwordSize\fR element of the \fBtcl_platform\fR array. .TP -\fBisfinite \fIarg\fR -.VS "8.7, TIP 521" -Returns 1 if the floating-point number \fIarg\fR is finite. That is, if it is -zero, subnormal, or normal. Returns 0 if the number is infinite or NaN. Throws -an error if \fIarg\fR cannot be promoted to a floating-point value. -.VE "8.7, TIP 521" -.TP -\fBisinf \fIarg\fR -.VS "8.7, TIP 521" -Returns 1 if the floating-point number \fIarg\fR is infinite. Returns 0 if the -number is finite or NaN. Throws an error if \fIarg\fR cannot be promoted to a -floating-point value. -.VE "8.7, TIP 521" -.TP -\fBisnan \fIarg\fR -.VS "8.7, TIP 521" -Returns 1 if the floating-point number \fIarg\fR is Not-a-Number. Returns 0 if -the number is finite or infinite. Throws an error if \fIarg\fR cannot be -promoted to a floating-point value. -.VE "8.7, TIP 521" -.TP -\fBisnormal \fIarg\fR -.VS "8.7, TIP 521" -Returns 1 if the floating-point number \fIarg\fR is normal. Returns 0 if the -number is zero, subnormal, infinite or NaN. Throws an error if \fIarg\fR -cannot be promoted to a floating-point value. -.VE "8.7, TIP 521" -.TP \fBisqrt \fIarg\fR . Computes the integer part of the square root of \fIarg\fR. \fIArg\fR must be a positive value, either an integer or a floating point number. Unlike \fBsqrt\fR, which is limited to the precision of a floating point number, \fIisqrt\fR will return a result of arbitrary precision. .TP -\fBissubnormal \fIarg\fR -.VS "8.7, TIP 521" -Returns 1 if the floating-point number \fIarg\fR is subnormal, i.e., the -result of gradual underflow. Returns 0 if the number is zero, normal, infinite -or NaN. Throws an error if \fIarg\fR cannot be promoted to a floating-point -value. -.VE "8.7, TIP 521" -.TP -\fBisunordered \fIx y\fR -.VS "8.7, TIP 521" -Returns 1 if \fIx\fR and \fIy\fR cannot be compared for ordering, that is, if -either one is NaN. Returns 0 if both values can be ordered, that is, if they -are both chosen from among the set of zero, subnormal, normal and infinite -values. Throws an error if either \fIx\fR or \fIy\fR cannot be promoted to a -floating-point value. -.VE "8.7, TIP 521" -.TP \fBlog \fIarg\fR . Returns the natural logarithm of \fIarg\fR. \fIArg\fR must be a positive value. .TP @@ -350,16 +290,16 @@ . The argument may be any numeric value. The integer part of \fIarg\fR is determined, and then the low order 64 bits of that integer value are returned as an integer value. .SH "SEE ALSO" -expr(n), fpclassify(n), mathop(n), namespace(n) +expr(n), mathop(n), namespace(n) .SH "COPYRIGHT" .nf -Copyright \(co 1993 The Regents of the University of California. -Copyright \(co 1994-2000 Sun Microsystems Incorporated. -Copyright \(co 2005, 2006 by Kevin B. Kenny . +Copyright (c) 1993 The Regents of the University of California. +Copyright (c) 1994-2000 Sun Microsystems Incorporated. +Copyright (c) 2005, 2006 by Kevin B. Kenny . .fi '\" Local Variables: '\" mode: nroff '\" fill-column: 78 '\" End: Index: doc/mathop.n ================================================================== --- doc/mathop.n +++ doc/mathop.n @@ -53,20 +53,10 @@ .br \fB::tcl::mathop::eq\fR ?\fIarg\fR ...? .br \fB::tcl::mathop::ne\fR \fIarg arg\fR .br -.VS "8.7, TIP461" -\fB::tcl::mathop::lt\fR ?\fIarg\fR ...? -.br -\fB::tcl::mathop::le\fR ?\fIarg\fR ...? -.br -\fB::tcl::mathop::gt\fR ?\fIarg\fR ...? -.br -\fB::tcl::mathop::ge\fR ?\fIarg\fR ...? -.VE "8.7, TIP461" -.br \fB::tcl::mathop::in\fR \fIarg list\fR .br \fB::tcl::mathop::ni\fR \fIarg list\fR .sp .BE @@ -84,12 +74,11 @@ .ta 2c 4c 6c 8c \fB~\fR \fB!\fR \fB+\fR \fB\-\fR \fB*\fR \fB/\fR \fB%\fR \fB**\fR \fB&\fR \fB|\fR \fB^\fR \fB>>\fR \fB<<\fR \fB==\fR \fBeq\fR \fB!=\fR \fBne\fR \fB<\fR \fB<=\fR \fB>\fR -\fB>=\fR \fBin\fR \fBni\fR \fBlt\fR \fBle\fR -\fBgt\fR \fBge\fR +\fB>=\fR \fBin\fR \fBni\fR .DE .SS "MATHEMATICAL OPERATORS" .PP The behaviors of the mathematical operator commands are as follows: .TP @@ -201,74 +190,42 @@ Returns whether the arbitrarily-many arguments are ordered, with each argument after the first having to be strictly more than the one preceding it. Comparisons are performed preferentially on the numeric values, and are otherwise performed using UNICODE string comparison. If fewer than two arguments are present, this operation always returns a true value. When the -arguments are numeric but should be compared as strings, the \fBlt\fR -operator or the \fBstring compare\fR command should be used instead. +arguments are numeric but should be compared as strings, the \fBstring +compare\fR command should be used instead. .TP \fB<=\fR ?\fIarg\fR ...? . Returns whether the arbitrarily-many arguments are ordered, with each argument after the first having to be equal to or more than the one preceding it. Comparisons are performed preferentially on the numeric values, and are otherwise performed using UNICODE string comparison. If fewer than two arguments are present, this operation always returns a true value. When the -arguments are numeric but should be compared as strings, the \fBle\fR -operator or the \fBstring compare\fR command should be used instead. +arguments are numeric but should be compared as strings, the \fBstring +compare\fR command should be used instead. .TP \fB>\fR ?\fIarg\fR ...? . Returns whether the arbitrarily-many arguments are ordered, with each argument after the first having to be strictly less than the one preceding it. Comparisons are performed preferentially on the numeric values, and are otherwise performed using UNICODE string comparison. If fewer than two arguments are present, this operation always returns a true value. When the -arguments are numeric but should be compared as strings, the \fBgt\fR -operator or the \fBstring compare\fR command should be used instead. +arguments are numeric but should be compared as strings, the \fBstring +compare\fR command should be used instead. .TP \fB>=\fR ?\fIarg\fR ...? . Returns whether the arbitrarily-many arguments are ordered, with each argument after the first having to be equal to or less than the one preceding it. Comparisons are performed preferentially on the numeric values, and are otherwise performed using UNICODE string comparison. If fewer than two arguments are present, this operation always returns a true value. When the -arguments are numeric but should be compared as strings, the \fBge\fR -operator or the \fBstring compare\fR command should be used instead. -.TP -\fBlt\fR ?\fIarg\fR ...? -.VS "8.7, TIP461" -Returns whether the arbitrarily-many arguments are ordered, with each argument -after the first having to be strictly more than the one preceding it. -Comparisons are performed using UNICODE string comparison. If fewer than two -arguments are present, this operation always returns a true value. -.VE "8.7, TIP461" -.TP -\fBle\fR ?\fIarg\fR ...? -.VS "8.7, TIP461" -Returns whether the arbitrarily-many arguments are ordered, with each argument -after the first having to be equal to or strictly more than the one preceding it. -Comparisons are performed using UNICODE string comparison. If fewer than two -arguments are present, this operation always returns a true value. -.VE "8.7, TIP461" -.TP -\fBgt\fR ?\fIarg\fR ...? -.VS "8.7, TIP461" -Returns whether the arbitrarily-many arguments are ordered, with each argument -after the first having to be strictly less than the one preceding it. -Comparisons are performed using UNICODE string comparison. If fewer than two -arguments are present, this operation always returns a true value. -.VE "8.7, TIP461" -.TP -\fBge\fR ?\fIarg\fR ...? -.VS "8.7, TIP461" -Returns whether the arbitrarily-many arguments are ordered, with each argument -after the first having to be equal to or strictly less than the one preceding it. -Comparisons are performed using UNICODE string comparison. If fewer than two -arguments are present, this operation always returns a true value. -.VE "8.7, TIP461" +arguments are numeric but should be compared as strings, the \fBstring +compare\fR command should be used instead. .SS "BIT-WISE OPERATORS" .PP The behaviors of the bit-wise operator commands (all of which only operate on integral arguments) are as follows: .TP @@ -340,19 +297,15 @@ set gotIt [\fBin\fR 3 $list] \fI# Test to see if a value is within some defined range\fR set inRange [\fB<=\fR 1 $x 5] -\fI# Test to see if a list is numerically sorted\fR +\fI# Test to see if a list is sorted\fR set sorted [\fB<=\fR {*}$list] - -\fI# Test to see if a list is lexically sorted\fR -set alphaList {a b c d e f} -set sorted [\fBle\fR {*}$alphaList] .CE .SH "SEE ALSO" expr(n), mathfunc(n), namespace(n) .SH KEYWORDS command, expression, operator '\" Local Variables: '\" mode: nroff '\" End: Index: doc/memory.n ================================================================== --- doc/memory.n +++ doc/memory.n @@ -23,22 +23,22 @@ . Write a list of all currently allocated memory to the specified \fIfile\fR. .TP \fBmemory break_on_malloc\fR \fIcount\fR . -After the \fIcount\fR allocations have been performed, \fBTcl_Alloc\fR +After the \fIcount\fR allocations have been performed, \fBckalloc\fR outputs a message to this effect and that it is now attempting to enter the C debugger. Tcl will then issue a \fISIGINT\fR signal against itself. If you are running Tcl under a C debugger, it should then enter the debugger command mode. .TP \fBmemory info\fR . Returns a report containing the total allocations and frees since Tcl began, the current packets allocated (the current -number of calls to \fBTcl_Alloc\fR not met by a corresponding call -to \fBTcl_Free\fR), the current bytes allocated, and the maximum number +number of calls to \fBckalloc\fR not met by a corresponding call +to \fBckfree\fR), the current bytes allocated, and the maximum number of packets and bytes allocated. .TP \fBmemory init \fR[\fBon\fR|\fBoff\fR] . Turn on or off the pre-initialization of all allocated memory @@ -57,38 +57,38 @@ during the finalization of Tcl's memory subsystem. Useful for checking that memory is properly cleaned up during process exit. .TP \fBmemory tag\fR \fIstring\fR . -Each packet of memory allocated by \fBTcl_Alloc\fR can have associated +Each packet of memory allocated by \fBckalloc\fR can have associated with it a string-valued tag. In the lists of allocated memory generated by \fBmemory active\fR and \fBmemory onexit\fR, the tag for each packet is printed along with other information about the packet. The \fBmemory tag\fR command sets the tag value for subsequent calls -to \fBTcl_Alloc\fR to be \fIstring\fR. +to \fBckalloc\fR to be \fIstring\fR. .TP \fBmemory trace \fR[\fBon\fR|\fBoff\fR] . Turns memory tracing on or off. When memory tracing is on, every call -to \fBTcl_Alloc\fR causes a line of trace information to be written to -\fIstderr\fR, consisting of the word \fITcl_Alloc\fR, followed by the +to \fBckalloc\fR causes a line of trace information to be written to +\fIstderr\fR, consisting of the word \fIckalloc\fR, followed by the address returned, the amount of memory allocated, and the C filename and line number of the code performing the allocation. For example: .RS .PP .CS -Tcl_Alloc 40e478 98 tclProc.c 1406 +ckalloc 40e478 98 tclProc.c 1406 .CE .PP -Calls to \fBTcl_Free\fR are traced in the same manner. +Calls to \fBckfree\fR are traced in the same manner. .RE .TP \fBmemory trace_on_at_malloc\fR \fIcount\fR . -Enable memory tracing after \fIcount\fR \fBTcl_Alloc\fRs have been performed. +Enable memory tracing after \fIcount\fR \fBckalloc\fRs have been performed. For example, if you enter \fBmemory trace_on_at_malloc 100\fR, -after the 100th call to \fBTcl_Alloc\fR, memory trace information will begin +after the 100th call to \fBckalloc\fR, memory trace information will begin being displayed for all allocations and frees. Since there can be a lot of memory activity before a problem occurs, judicious use of this option can reduce the slowdown caused by tracing (and the amount of trace information produced), if you can identify a number of allocations that occur before the problem sets in. The current number of memory allocations that have @@ -95,21 +95,21 @@ occurred since Tcl started is printed on a guard zone failure. .TP \fBmemory validate \fR[\fBon\fR|\fBoff\fR] . Turns memory validation on or off. When memory validation is enabled, -on every call to \fBTcl_Alloc\fR or \fBTcl_Free\fR, the guard zones are +on every call to \fBckalloc\fR or \fBckfree\fR, the guard zones are checked for every piece of memory currently in existence that was -allocated by \fBTcl_Alloc\fR. This has a large performance impact and +allocated by \fBckalloc\fR. This has a large performance impact and should only be used when overwrite problems are strongly suspected. The advantage of enabling memory validation is that a guard zone -overwrite can be detected on the first call to \fBTcl_Alloc\fR or -\fBTcl_Free\fR after the overwrite occurred, rather than when the +overwrite can be detected on the first call to \fBckalloc\fR or +\fBckfree\fR after the overwrite occurred, rather than when the specific memory with the overwritten guard zone(s) is freed, which may occur long after the overwrite occurred. .SH "SEE ALSO" -Tcl_Alloc, Tcl_Free, Tcl_ValidateAllMemory, Tcl_DumpActiveMemory, TCL_MEM_DEBUG +ckalloc, ckfree, Tcl_ValidateAllMemory, Tcl_DumpActiveMemory, TCL_MEM_DEBUG .SH KEYWORDS memory, debug '\"Local Variables: '\"mode: nroff '\"End: Index: doc/msgcat.n ================================================================== --- doc/msgcat.n +++ doc/msgcat.n @@ -9,31 +9,25 @@ .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME msgcat \- Tcl message catalog .SH SYNOPSIS -\fBpackage require Tcl 8.7\fR +\fBpackage require Tcl 8.5\fR .sp -\fBpackage require msgcat 1.7\fR +\fBpackage require msgcat 1.6\fR .sp \fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR? .sp \fB::msgcat::mcmax ?\fIsrc-string src-string ...\fR? .sp .VS "TIP 412" \fB::msgcat::mcexists\fR ?\fB-exactnamespace\fR? ?\fB-exactlocale\fR? \fIsrc-string\fR .VE "TIP 412" .sp -.VS "TIP 490" -\fB::msgcat::mcpackagenamespaceget\fR -.VE "TIP 490" -.sp \fB::msgcat::mclocale \fR?\fInewLocale\fR? .sp -.VS "TIP 499" -\fB::msgcat::mcpreferences\fR ?\fIlocale preference\fR? ... -.VE "TIP 499" +\fB::msgcat::mcpreferences\fR .sp .VS "TIP 412" \fB::msgcat::mcloadedlocales subcommand\fR ?\fIlocale\fR? .VE "TIP 412" .sp @@ -54,14 +48,10 @@ .sp \fB::msgcat::mcpackageconfig subcommand\fR \fIoption\fR ?\fIvalue\fR? .sp \fB::msgcat::mcforgetpackage\fR .VE "TIP 412" -.sp -.VS "TIP 499" -\fB::msgcat::mcutil subcommand\fR ?\fIlocale\fR? -.VS "TIP 499" .BE .SH DESCRIPTION .PP The \fBmsgcat\fR package provides a set of functions that can be used to manage multi-lingual user interfaces. @@ -79,15 +69,10 @@ A \fIlocale\fR is a specification string describing a user language like \fBde_ch\fR for Swiss German. In \fBmsgcat\fR, there is a global locale initialized by the system locale of the current system. Each package may decide to use the global locale or to use a package specific locale. .PP The global locale may be changed on demand, for example by a user initiated language change or within a multi user application like a web server. -.PP -.VS tip490 -Object oriented programming is supported by the use of a package namespace. -.VE tip490 -.PP .SH COMMANDS .TP \fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR? . Returns a translation of \fIsrc-string\fR according to the @@ -108,118 +93,57 @@ application can pass the English string through \fB::msgcat::mc\fR and use the result. If an application is written for a single language in this fashion, then it is easy to add support for additional languages later simply by defining new message catalog entries. .RE -.VS "TIP 490" -.TP -\fB::msgcat::mcn \fInamespace\fR \fIsrc-string\fR ?\fIarg arg ...\fR? -. -Like \fB::msgcat::mc\fR, but with the message namespace specified as first argument. -.PP -.RS -\fBmcn\fR may be used for cases where the package namespace is not the namespace of the caller. -An example is shown within the description of the command \fB::msgcat::mcpackagenamespaceget\fR below. -.RE -.PP .TP \fB::msgcat::mcmax ?\fIsrc-string src-string ...\fR? . Given several source strings, \fB::msgcat::mcmax\fR returns the length of the longest translated string. This is useful when designing localized GUIs, which may require that all buttons, for example, be a fixed width (which will be the width of the widest button). -.VS "TIP 412" .TP -\fB::msgcat::mcexists\fR ?\fB-exactnamespace\fR? ?\fB-exactlocale\fR? ?\fB-namespace\fR \fInamespace\fR? \fIsrc-string\fR +\fB::msgcat::mcexists\fR ?\fB-exactnamespace\fR? ?\fB-exactlocale\fR? \fIsrc-string\fR . +.VS "TIP 412" Return true, if there is a translation for the given \fIsrc-string\fR. .PP .RS The search may be limited by the option \fB\-exactnamespace\fR to only check the current namespace and not any parent namespaces. .PP It may also be limited by the option \fB\-exactlocale\fR to only check the first prefered locale (e.g. first element returned by \fB::msgcat::mcpreferences\fR if global locale is used). -.PP -.VE "TIP 412" -.VS "TIP 490" -An explicit package namespace may be specified by the option \fB-namespace\fR. -The namespace of the caller is used if not explicitly specified. -.RE -.PP -.VE "TIP 490" -.VS "TIP 490" -.TP -\fB::msgcat::mcpackagenamespaceget\fR -. -Return the package namespace of the caller. -This command handles all cases described in section \fBOBJECT ORIENTED PROGRAMMING\fR. -.PP -.RS -Example usage is a tooltip package, which saves the caller package namespace to update the translation each time the tooltip is shown: -.CS -proc ::tooltip::tooltip {widget message} { - ... - set messagenamespace [uplevel 1 {::msgcat::mcpackagenamespaceget}] - ... - bind $widget [list ::tooltip::show $widget $messagenamespace $message] -} - -proc ::tooltip::show {widget messagenamespace message} { - ... - set message [::msgcat::mcn $messagenamespace $message] - ... -} -.CE -.RE -.PP -.VE "TIP 490" +.RE +.VE "TIP 412" .TP \fB::msgcat::mclocale \fR?\fInewLocale\fR? . -If \fInewLocale\fR is omitted, the current locale is returned, otherwise the current locale -is set to \fInewLocale\fR. -.PP -.RS -If the new locale is set to \fInewLocale\fR, the corresponding preferences are calculated and set. -For example, if the current locale is en_US_funky, then \fB::msgcat::mcpreferences\fR returns \fB{en_us_funky en_us en {}}\fR. -.PP -The same result may be acheved by \fB::msgcat::mcpreferences\fR {*}[\fB::msgcat::mcutil getpreferences\fR \fInewLocale\fR]. -.PP -The current locale is always the first element of the list returned by \fBmcpreferences\fR. -.PP -msgcat stores and compares the locale in a +This function sets the locale to \fInewLocale\fR. If \fInewLocale\fR +is omitted, the current locale is returned, otherwise the current locale +is set to \fInewLocale\fR. msgcat stores and compares the locale in a case-insensitive manner, and returns locales in lowercase. The initial locale is determined by the locale specified in the user's environment. See \fBLOCALE SPECIFICATION\fR below for a description of the locale string format. +.RS .PP .VS "TIP 412" If the locale is set, the preference list of locales is evaluated. Locales in this list are loaded now, if not jet loaded. .VE "TIP 412" .RE .TP -\fB::msgcat::mcpreferences\fR ?\fIlocale preference\fR? ... -. -Without arguments, returns an ordered list of the locales preferred by -the user. -The list is ordered from most specific to least preference. -.PP -.VS "TIP 499" -.RS -A set of locale preferences may be given to set the list of locale preferences. -The current locale is also set, which is the first element of the locale preferences list. -.PP -Locale preferences are loaded now, if not jet loaded. -.PP -As an example, the user may prefer French or English text. This may be configured by: -.CS -::msgcat::mcpreferences fr en {} -.CE -.RE -.PP -.VS "TIP 499" +\fB::msgcat::mcpreferences\fR +. +Returns an ordered list of the locales preferred by +the user, based on the user's language specification. +The list is ordered from most specific to least +preference. The list is derived from the current +locale set in msgcat by \fB::msgcat::mclocale\fR, and +cannot be set independently. For example, if the +current locale is en_US_funky, then \fB::msgcat::mcpreferences\fR +returns \fB{en_us_funky en_us en {}}\fR. .TP \fB::msgcat:mcloadedlocales subcommand\fR ?\fIlocale\fR? . This group of commands manage the list of loaded locales for packages not setting a package locale. .PP @@ -306,26 +230,10 @@ \fB::msgcat::mcforgetpackage\fR . The calling package clears all its state within the \fBmsgcat\fR package including all settings and translations. .VE "TIP 412" .PP -.VS "TIP 499" -.TP -\fB::msgcat::mcutil getpreferences\fR \fIlocale\fR -. -Return the preferences list of the given locale as described in section \fBLOCALE SPECIFICATION\fR. -An example is the composition of a preference list for the bilingual region "Biel/Bienne" as a concatenation of swiss german and swiss french: -.CS -% concat [lrange [msgcat::mcutil getpreferences fr_CH] 0 end-1] [msgcat::mcutil getpreferences de_CH] -fr_ch fr de_ch de {} -.CE -.TP -\fB::msgcat::mcutil getsystemlocale\fR -. -The system locale is returned as described by the section \fBLOCALE SPECIFICATION\fR. -.VE "TIP 499" -.PP .SH "LOCALE SPECIFICATION" .PP The locale is specified to \fBmsgcat\fR by a locale string passed to \fB::msgcat::mclocale\fR. The locale string consists of @@ -527,11 +435,11 @@ \fBmsgcat::mc\fR {Produced %1$d at %2$s} $num $city # ... where that key is mapped to one of the # human-oriented versions by \fBmsgcat::mcset\fR .CE .VS "TIP 412" -.SH "PACKAGE PRIVATE LOCALE" +.SH Package private locale .PP A package using \fBmsgcat\fR may choose to use its own package private locale and its own set of loaded locales, independent to the global locale set by \fB::msgcat::mclocale\fR. .PP @@ -551,26 +459,14 @@ .TP \fB::msgcat::mcpackagelocale get\fR . Return the package private locale or the global locale, if no package private locale is set. .TP -\fB::msgcat::mcpackagelocale preferences\fR ?\fIlocale preference\fR? ... -. -With no parameters, return the package private preferences or the global preferences, -if no package private locale is set. -The package locale state (set or not) is not changed (in contrast to the command \fB::msgcat::mcpackagelocale set\fR). -.PP -.RS -.VS "TIP 499" -If a set of locale preferences is given, it is set as package locale preference list. -The package locale is set to the first element of the preference list. -A package locale is activated, if it was not set so far. -.PP -Locale preferences are loaded now for the package, if not jet loaded. -.VE "TIP 499" -.RE -.PP +\fB::msgcat::mcpackagelocale preferences\fR +. +Return the package private preferences or the global preferences, +if no package private locale is set. .TP \fB::msgcat::mcpackagelocale loaded\fR . Return the list of locales loaded for this package. .TP @@ -590,11 +486,11 @@ .TP \fB::msgcat::mcpackagelocale clear\fR . Clear any loaded locales of the package not present in the package preferences. .PP -.SH "CHANGING PACKAGE OPTIONS" +.SH Changing package options .PP Each package using msgcat has a set of options within \fBmsgcat\fR. The package options are described in the next sectionPackage options. Each package option may be set or unset individually using the following ensemble: .TP @@ -665,11 +561,11 @@ A generic unknown handler is used if set to the empty string. This consists in returning the key if no arguments are given. With given arguments, format is used to process the arguments. .PP See section \fBcallback invocation\fR below. The appended arguments are identical to \fB::msgcat::mcunknown\fR. .RE -.SH "Callback invocation" +.SS Callback invocation A package may decide to register one or multiple callbacks, as described above. .PP Callbacks are invoked, if: .PP 1. the callback command is set, @@ -679,58 +575,11 @@ 3. the registering namespace exists. .PP If a called routine fails with an error, the \fBbgerror\fR routine for the interpreter is invoked after command completion. Only exception is the callback \fBunknowncmd\fR, where an error causes the invoking \fBmc\fR-command to fail with that error. .PP -.VS tip490 -.SH "OBJECT ORIENTED PROGRAMMING" -\fBmsgcat\fR supports packages implemented by object oriented programming. -Objects and classes should be defined within a package namespace. -.PP -There are 3 supported cases where package namespace sensitive commands of msgcat (\fBmc\fR, \fBmcexists\fR, \fBmcpackagelocale\fR, \fBmcforgetpackage\fR, \fBmcpackagenamespaceget\fR, \fBmcpackageconfig\fR, \fBmcset\fR and \fBmcmset\fR) may be called: -.PP -.TP -\fB1) In class definition script\fR -. -\fBmsgcat\fR command is called within a class definition script. -.CS -namespace eval ::N2 { - mcload $dir/msgs - oo::class create C1 {puts [mc Hi!]} -} -.CE -.PP -.TP -\fB2) method defined in a class\fR -. -\fBmsgcat\fR command is called from a method in an object and the method is defined in a class. -.CS -namespace eval ::N3Class { - mcload $dir/msgs - oo::class create C1 - oo::define C1 method m1 { - puts [mc Hi!] - } -} -.CE -.PP -.TP -\fB3) method defined in a classless object\fR -. -\fBmsgcat\fR command is called from a method of a classless object. -.CS -namespace eval ::N4 { - mcload $dir/msgs - oo::object create O1 - oo::objdefine O1 method m1 {} { - puts [mc Hi!] - } -} -.CE -.PP -.VE tip490 -.SH EXAMPLES +.SS Examples Packages which display a GUI may update their widgets when the global locale changes. To register to a callback, use: .CS namespace eval gui { msgcat::mcpackageconfig changecmd updateGUI @@ -792,11 +641,11 @@ .VE "TIP 412" .SH CREDITS .PP The message catalog code was developed by Mark Harrison. .SH "SEE ALSO" -format(n), scan(n), namespace(n), package(n), oo::class(n), oo::object +format(n), scan(n), namespace(n), package(n) .SH KEYWORDS -internationalization, i18n, localization, l10n, message, text, translation, class, object +internationalization, i18n, localization, l10n, message, text, translation .\" Local Variables: .\" mode: nroff .\" End: Index: doc/my.n ================================================================== --- doc/my.n +++ doc/my.n @@ -7,49 +7,29 @@ .TH my n 0.1 TclOO "TclOO Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -my, myclass \- invoke any method of current object or its class +my \- invoke any method of current object .SH SYNOPSIS .nf package require TclOO \fBmy\fI methodName\fR ?\fIarg ...\fR? -\fBmyclass\fI methodName\fR ?\fIarg ...\fR? .fi .BE .SH DESCRIPTION .PP -The \fBmy\fR command is used to allow methods of objects to invoke methods -of the object (or its class), -.VS TIP478 -and he \fBmyclass\fR command is used to allow methods of objects to invoke -methods of the current class of the object \fIas an object\fR. -.VE TIP478 -In particular, the set of valid values for -\fImethodName\fR is the set of all methods supported by an object and its -superclasses, including those that are not exported -.VS TIP500 -and private methods of the object or class when used within another method -defined by that object or class. -.VE TIP500 -.PP -The object upon which the method is invoked via \fBmy\fR is the one that owns -the namespace that the \fBmy\fR command is contained in initially (\fBNB:\fR the link -remains if the command is renamed), which is the currently invoked object by -default. -.VS TIP478 -Similarly, the object on which the method is invoked via \fBmyclass\fR is the -object that is the current class of the object that owns the namespace that -the \fBmyclass\fR command is contained in initially. As with \fBmy\fR, the -link remains even if the command is renamed into another namespace, and -defaults to being the manufacturing class of the current object. -.VE TIP478 -.PP -Each object has its own \fBmy\fR and \fBmyclass\fR commands, contained in its -instance namespace. +The \fBmy\fR command is used to allow methods of objects to invoke any method +of the object (or its class). In particular, the set of valid values for +\fImethodName\fR is the set of all methods supported by an object and its +superclasses, including those that are not exported. The object upon which the +method is invoked is always the one that is the current context of the method +(i.e. the object that is returned by \fBself object\fR) from which the +\fBmy\fR command is invoked. +.PP +Each object has its own \fBmy\fR command, contained in its instance namespace. .SH EXAMPLES .PP This example shows basic use of \fBmy\fR to use the \fBvariables\fR method of the \fBoo::object\fR class, which is not publicly visible by default: .PP @@ -58,74 +38,19 @@ method count {} { \fBmy\fR variable counter puts [incr counter] } } - c create o o count \fI\(-> prints "1"\fR o count \fI\(-> prints "2"\fR o count \fI\(-> prints "3"\fR .CE -.PP -This example shows how you can use \fBmy\fR to make callbacks to private -methods from outside the object (from a \fBtrace\fR), using -\fBnamespace code\fR to enter the correct context. (See the \fBcallback\fR -command for the recommended way of doing this.) -.PP -.CS -oo::class create HasCallback { - method makeCallback {} { - return [namespace code { - \fBmy\fR Callback - }] - } - - method Callback {args} { - puts "callback: $args" - } -} - -set o [HasCallback new] -trace add variable xyz write [$o makeCallback] -set xyz "called" \fI\(-> prints "callback: xyz {} write"\fR -.CE -.PP -.VS TIP478 -This example shows how to access a private method of a class from an instance -of that class. (See the \fBclassmethod\fR declaration in \fBoo::define\fR for -a higher level interface for doing this.) -.PP -.CS -oo::class create CountedSteps { - self { - variable count - method Count {} { - return [incr count] - } - } - method advanceTwice {} { - puts "in [self] step A: [\fBmyclass\fR Count]" - puts "in [self] step B: [\fBmyclass\fR Count]" - } -} - -CountedSteps create x -CountedSteps create y -x advanceTwice \fI\(-> prints "in ::x step A: 1"\fR - \fI\(-> prints "in ::x step B: 2"\fR -y advanceTwice \fI\(-> prints "in ::y step A: 3"\fR - \fI\(-> prints "in ::y step B: 4"\fR -x advanceTwice \fI\(-> prints "in ::x step A: 5"\fR - \fI\(-> prints "in ::x step B: 6"\fR -y advanceTwice \fI\(-> prints "in ::y step A: 7"\fR - \fI\(-> prints "in ::y step B: 8"\fR -.CE -.VE TIP478 .SH "SEE ALSO" next(n), oo::object(n), self(n) .SH KEYWORDS method, method visibility, object, private method, public method + .\" Local variables: .\" mode: nroff .\" fill-column: 78 .\" End: Index: doc/next.n ================================================================== --- doc/next.n +++ doc/next.n @@ -110,21 +110,19 @@ oo::class create theSuperclass { method example {args} { puts "in the superclass, args = $args" } } - oo::class create theSubclass { superclass theSuperclass method example {args} { puts "before chaining from subclass, args = $args" \fBnext\fR a {*}$args b \fBnext\fR pureSynthesis puts "after chaining from subclass" } } - theSubclass create obj oo::objdefine obj method example args { puts "per-object method, args = $args" \fBnext\fR x {*}$args y \fBnext\fR @@ -167,11 +165,10 @@ } \fI# Compute value, insert into cache, and return it\fR return [set ValueCache($key) [\fBnext\fR {*}$args]] } - method flushCache {} { my variable ValueCache unset ValueCache \fI# Skip the caching\fR return -level 2 "" @@ -179,16 +176,14 @@ } oo::object create demo oo::objdefine demo { mixin cache - method compute {a b c} { after 3000 \fI;# Simulate deep thought\fR return [expr {$a + $b * $c}] } - method compute2 {a b c} { after 3000 \fI;# Simulate deep thought\fR return [expr {$a * $b + $c}] } } Index: doc/open.n ================================================================== --- doc/open.n +++ doc/open.n @@ -164,13 +164,12 @@ If \fIfileName\fR refers to a serial port, then the specified serial port is opened and initialized in a platform-dependent manner. Acceptable values for the \fIfileName\fR to use to open a serial port are described in the PORTABILITY ISSUES section. .PP -The \fBchan configure\fR and \fBfconfigure\fR commands can be used to query -and set additional configuration options specific to serial ports (where -supported): +The \fBfconfigure\fR command can be used to query and set additional +configuration options specific to serial ports (where supported): .TP \fB\-mode\fR \fIbaud\fB,\fIparity\fB,\fIdata\fB,\fIstop\fR . This option is a set of 4 comma-separated values: the baud rate, parity, number of data bits, and number of stop bits for this serial port. The @@ -248,79 +247,10 @@ (Windows and Unix). This option is used to query or change the software handshake characters. Normally the operating system default should be DC1 (0x11) and DC3 (0x13) representing the ASCII standard XON and XOFF characters. .TP -\fB\-closemode\fR \fIcloseMode\fR -.VS "8.7, TIP 160" -(Windows and Unix). This option is used to query or change the close mode of -the serial channel, which defines how pending output in operating system -buffers is handled when the channel is closed. The following values for -\fIcloseMode\fR are supported: -.RS -.TP -\fBdefault\fR -. -indicates that a system default operation should be used; all serial channels -default to this. -.TP -\fBdiscard\fR -. -indicates that the contents of the OS buffers should be discarded. Note that -this is \fInot recommended\fR when writing to a POSIX terminal, as it can -interact unexpectedly with handling of \fBstderr\fR. -.TP -\fBdrain\fR -. -indicates that Tcl should wait when closing the channel until all output has -been consumed. This may slow down \fBclose\fR noticeably. -.RE -.VE "8.7, TIP 160" -.TP -\fB\-inputmode\fR \fIinputMode\fR -.VS "8.7, TIP 160" -(Unix only; Windows has the equivalent option on console channels). This -option is used to query or change the input mode of the serial channel under -the assumption that it is talking to a terminal, which controls how interactive -input from users is handled. The following values for \fIinputMode\fR are -supported: -.RS -.TP -\fBnormal\fR -. -indicates that normal line-oriented input should be used, with standard -terminal editing capabilities enabled. -.TP -\fBpassword\fR -. -indicates that non-echoing input should be used, with standard terminal -editing capabilities enabled but no writing of typed characters to the -terminal (except for newlines). Some terminals may indicate this specially. -.TP -\fBraw\fR -. -indicates that all keyboard input should be given directly to Tcl with the -terminal doing no processing at all. It does not echo the keys, leaving it up -to the Tcl script to interpret what to do. -.TP -\fBreset\fR (set only) -. -indicates that the terminal should be reset to what state it was in when the -terminal was opened. -.PP -Note that setting this option (technically, anything that changes the terminal -state from its initial value \fIvia this option\fR) will cause the channel to -turn on an automatic reset of the terminal when the channel is closed. -.RE -.TP -\fB\-winsize\fR -. -(Unix only; Windows has the equivalent option on console channels). This -option is query only. It retrieves a two-element list with the the current -width and height of the terminal. -.VE "8.7, TIP 160" -.TP \fB\-pollinterval\fR \fImsec\fR . (Windows only). This option is used to set the maximum time between polling for fileevents. This affects the time interval between checking for events throughout the Tcl @@ -343,11 +273,11 @@ (Windows only). This option is query only. In case of a serial communication error, \fBread\fR or \fBputs\fR returns a general Tcl file I/O error. \fBfconfigure\fR \fB\-lasterror\fR can be called to get a list of error details. See below for an explanation of the various error codes. -.SS "SERIAL PORT SIGNALS" +.SH "SERIAL PORT SIGNALS" .PP RS-232 is the most commonly used standard electrical interface for serial communications. A negative voltage (-3V..-12V) define a mark (on=1) bit and a positive voltage (+3..+12V) define a space (off=0) bit (RS-232C). The following signals are specified for incoming and outgoing data, status @@ -384,11 +314,11 @@ TXD or RXD lines for a long period of time, usually 250 to 500 milliseconds. Normally a receive or transmit data signal stays at the mark (on=1) voltage until the next character is transferred. A BREAK is sometimes used to reset the communications line or change the operating mode of communications hardware. -.SS "ERROR CODES (Windows only)" +.SH "ERROR CODES (Windows only)" .PP A lot of different errors may occur during serial read operations or during event polling in background. The external device may have been switched off, the data lines may be noisy, system buffers may overrun or your mode settings may be wrong. That is why a reliable software should always @@ -427,11 +357,11 @@ may cause this error. .TP 10 \fBBREAK\fR . A BREAK condition has been detected by your UART (see above). -.SS "PORTABILITY ISSUES" +.SH "PORTABILITY ISSUES" .TP \fBWindows \fR . Valid values for \fIfileName\fR to open a serial port are of the form \fBcom\fIX\fB\fR, where \fIX\fR is a number, generally from 1 to 9. @@ -476,59 +406,11 @@ .RE .PP See the \fBPORTABILITY ISSUES\fR section of the \fBexec\fR command for additional information not specific to command pipelines about executing applications on the various platforms -.SH "CONSOLE CHANNELS" -.VS "8.7, TIP 160" -On Windows only, console channels (usually \fBstdin\fR or \fBstdout\fR) -support the following options: -.TP -\fB\-inputmode\fR \fIinputMode\fR -. -This option is used to query or change the input mode of the console channel, -which controls how interactive input from users is handled. The following -values for \fIinputMode\fR are supported: -.RS -.TP -\fBnormal\fR -. -indicates that normal line-oriented input should be used, with standard -console editing capabilities enabled. -.TP -\fBpassword\fR -. -indicates that non-echoing input should be used, with standard console -editing capabilitied enabled but no writing of typed characters to the -terminal (except for newlines). -.TP -\fBraw\fR -. -indicates that all keyboard input should be given directly to Tcl with the -console doing no processing at all. It does not echo the keys, leaving it up -to the Tcl script to interpret what to do. -.TP -\fBreset\fR (set only) -. -indicates that the console should be reset to what state it was in when the -console channel was opened. -.PP -Note that setting this option (technically, anything that changes the console -state from its default \fIvia this option\fR) will cause the channel to turn -on an automatic reset of the console when the channel is closed. -.RE -.TP -\fB\-winsize\fR -. -This option is query only. -It retrieves a two-element list with the the current width and height of the -console that this channel is talking to. -.PP -Note that the equivalent options exist on Unix, but are on the serial channel -type. -.VE "8.7, TIP 160" -.SH "EXAMPLES" +.SH "EXAMPLE" .PP Open a command pipeline and catch any errors: .PP .CS set fl [\fBopen\fR "| ls this_file_does_not_exist"] @@ -535,30 +417,14 @@ set data [read $fl] if {[catch {close $fl} err]} { puts "ls command failed: $err" } .CE -.PP -.VS "8.7, TIP 160" -Read a password securely from the user (assuming that the script is being run -interactively): -.PP -.CS -chan configure stdin \fB-inputmode password\fR -try { - chan puts -nonewline "Password: " - chan flush stdout - set thePassword [chan gets stdin] -} finally { - chan configure stdin \fB-inputmode reset\fR -} -.CE -.VE "8.7, TIP 160" .SH "SEE ALSO" file(n), close(n), filename(n), fconfigure(n), gets(n), read(n), puts(n), exec(n), pid(n), fopen(3) .SH KEYWORDS access mode, append, create, file, non-blocking, open, permissions, pipeline, process, serial '\"Local Variables: '\"mode: nroff '\"End: Index: doc/package.n ================================================================== --- doc/package.n +++ doc/package.n @@ -10,11 +10,10 @@ '\" Note: do not modify the .SH NAME line immediately below! .SH NAME package \- Facilities for package loading and version control .SH SYNOPSIS .nf -\fBpackage files\fR \fIpackage\fR \fBpackage forget\fR ?\fIpackage package ...\fR? \fBpackage ifneeded \fIpackage version\fR ?\fIscript\fR? \fBpackage names\fR \fBpackage present \fIpackage \fR?\fIrequirement...\fR? \fBpackage present \-exact \fIpackage version\fR @@ -42,17 +41,10 @@ primarily by system scripts that maintain the package database. .PP The behavior of the \fBpackage\fR command is determined by its first argument. The following forms are permitted: .TP -\fBpackage files\fR \fIpackage\fR -. -Lists all files forming part of \fIpackage\fR. Auto-loaded files are not -included in this list, only files which were directly sourced during package -initialization. The list order corresponds with the order in which the -files were sourced. -.TP \fBpackage forget\fR ?\fIpackage package ...\fR? . Removes all information about each specified package from this interpreter, including information provided by both \fBpackage ifneeded\fR and \fBpackage provide\fR. @@ -289,12 +281,12 @@ When passed any other value as an argument, raise an invalid argument error. .PP When an interpreter is created, its initial selection mode value is set to .QW stable -unless the environment variable \fBTCL_PKG_PREFER_LATEST\fR is set -(to any value) or the Tcl package itself is unstable. Otherwise +unless the environment variable \fBTCL_PKG_PREFER_LATEST\fR +is set. If that environment variable is defined (with any value) then the initial (and permanent) selection mode value is set to .QW latest . .RE .SH "VERSION NUMBERS" .PP Index: doc/packagens.n ================================================================== --- doc/packagens.n +++ doc/packagens.n @@ -46,9 +46,5 @@ At least one \fB\-load\fR or \fB\-source\fR parameter must be given. .SH "SEE ALSO" package(n) .SH KEYWORDS auto-load, index, package, version -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/pid.n ================================================================== --- doc/pid.n +++ doc/pid.n @@ -41,11 +41,8 @@ close $pipeline .CE .SH "SEE ALSO" exec(n), open(n) + .SH KEYWORDS file, pipeline, process identifier -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/pkgMkIndex.n ================================================================== --- doc/pkgMkIndex.n +++ doc/pkgMkIndex.n @@ -40,11 +40,11 @@ .RS .PP \fBPkg_mkIndex\fR will create a file \fBpkgIndex.tcl\fR in \fIdir\fR with package information about all the files given by the \fIpattern\fR arguments. -It does this by loading each file into a slave +It does this by loading each file into a child interpreter and seeing what packages and new commands appear (this is why it is essential to have \fBpackage provide\fR commands or \fBTcl_PkgProvide\fR calls in the files, as described above). If you have a package split among scripts and binary files, @@ -107,11 +107,11 @@ it immediately upon \fBpackage require\fR. This is not compatible with the use of \fIauto_reset\fR, and therefore its use is discouraged. .TP 15 \fB\-load \fIpkgPat\fR The index process will pre-load any packages that exist in the -current interpreter and match \fIpkgPat\fR into the slave interpreter used to +current interpreter and match \fIpkgPat\fR into the child interpreter used to generate the index. The pattern match uses string match rules, but without making case distinctions. See \fBCOMPLEX CASES\fR below. .TP 15 \fB\-verbose\fR Index: doc/platform.n ================================================================== --- doc/platform.n +++ doc/platform.n @@ -10,11 +10,11 @@ '\" Note: do not modify the .SH NAME line immediately below! .SH NAME platform \- System identification support code and utilities .SH SYNOPSIS .nf -\fBpackage require platform\fR ?\fB1.0.10\fR? +\fBpackage require platform ?1.0.10?\fR .sp \fBplatform::generic\fR \fBplatform::identify\fR \fBplatform::patterns \fIidentifier\fR .fi Index: doc/platform_shell.n ================================================================== --- doc/platform_shell.n +++ doc/platform_shell.n @@ -10,11 +10,11 @@ '\" Note: do not modify the .SH NAME line immediately below! .SH NAME platform::shell \- System identification support code and utilities .SH SYNOPSIS .nf -\fBpackage require platform::shell\fR ?\fB1.1.4\fR? +\fBpackage require platform::shell ?1.1.4?\fR .sp \fBplatform::shell::generic \fIshell\fR \fBplatform::shell::identify \fIshell\fR \fBplatform::shell::platform \fIshell\fR .fi @@ -53,9 +53,5 @@ \fBplatform::shell::platform \fIshell\fR This command returns the contents of \fBtcl_platform(platform)\fR for the specified Tcl shell. .SH KEYWORDS operating system, cpu architecture, platform, architecture -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/prefix.n ================================================================== --- doc/prefix.n +++ doc/prefix.n @@ -10,31 +10,31 @@ '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tcl::prefix \- facilities for prefix matching .SH SYNOPSIS .nf -\fB::tcl::prefix all\fR \fItable string\fR -\fB::tcl::prefix longest\fR \fItable string\fR -\fB::tcl::prefix match\fR ?\fIoption ...\fR? \fItable string\fR +\fB::tcl::prefix all\fR \fItable\fR \fIstring\fR +\fB::tcl::prefix longest\fR \fItable\fR \fIstring\fR +\fB::tcl::prefix match\fR \fI?option ...?\fR \fItable\fR \fIstring\fR .fi .BE .SH DESCRIPTION .PP This document describes commands looking up a prefix in a list of strings. The following commands are supported: .TP -\fB::tcl::prefix all\fR \fItable string\fR +\fB::tcl::prefix all\fR \fItable\fR \fIstring\fR . Returns a list of all elements in \fItable\fR that begin with the prefix \fIstring\fR. .TP -\fB::tcl::prefix longest\fR \fItable string\fR +\fB::tcl::prefix longest\fR \fItable\fR \fIstring\fR . Returns the longest common prefix of all elements in \fItable\fR that begin with the prefix \fIstring\fR. .TP -\fB::tcl::prefix match\fR ?\fIoptions\fR? \fItable string\fR +\fB::tcl::prefix match\fR ?\fIoptions\fR? \fItable\fR \fIstring\fR . If \fIstring\fR equals one element in \fItable\fR or is a prefix to exactly one element, the matched element is returned. If not, the result depends on the \fB\-error\fR option. (It is recommended that the \fItable\fR be sorted before use with this subcommand, so that the list of matches presented in the DELETED doc/process.n Index: doc/process.n ================================================================== --- doc/process.n +++ /dev/null @@ -1,150 +0,0 @@ -'\" -'\" Copyright (c) 2017 Frederic Bonnet. -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH process n 8.7 Tcl "Tcl Built-In Commands" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -tcl::process \- Subprocess management -.SH SYNOPSIS -\fB::tcl::process \fIoption \fR?\fIarg arg ...\fR? -.BE -.SH DESCRIPTION -.PP -This command provides a way to manage subprocesses created by the \fBopen\fR -and \fBexec\fR commands, as identified by the process identifiers (PIDs) of -those subprocesses. The legal \fIoptions\fR (which may be abbreviated) are: -.TP -\fB::tcl::process autopurge\fR ?\fIflag\fR? -. -Automatic purge facility. If \fIflag\fR is specified as a boolean value then -it activates or deactivate autopurge. In all cases it returns the current -status as a boolean value. When autopurge is active, -\fBTcl_ReapDetachedProcs\fR is called each time the \fBexec\fR command is -executed or a pipe channel created by \fBopen\fR is closed. When autopurge is -inactive, \fB::tcl::process\fR purge must be called explicitly. By default -autopurge is active. -.TP -\fB::tcl::process list\fR -. -Returns the list of subprocess PIDs. This includes all currently executing -subprocesses and all terminated subprocesses that have not yet had their -corresponding process table entries purged. -.TP -\fB::tcl::process purge\fR ?\fIpids\fR? -. -Cleans up all data associated with terminated subprocesses. If \fIpids\fR is -specified as a list of PIDs then the command only cleanup data for the matching -subprocesses if they exist, and raises an error otherwise. If a process listed is -still active, this command does nothing to that process. -.TP -\fB::tcl::process status\fR ?\fIswitches\fR? ?\fIpids\fR? -. -Returns a dictionary mapping subprocess PIDs to their respective status. If -\fIpids\fR is specified as a list of PIDs then the command only returns the -status of the matching subprocesses if they exist, and raises an error -otherwise. For active processes, the status is an empty value. For terminated -processes, the status is a list with the following format: -.QW "\fB{\fIcode\fR ?\fImsg errorCode\fR?\fB}\fR" , -where: -.RS -.TP -\fIcode\fR\0 -. -is a standard Tcl return code, i.e., \fB0\fR for TCL_OK and \fB1\fR -for TCL_ERROR, -.TP -\fImsg\fR\0 -. -is the human-readable error message, -.TP -\fIerrorCode\fR\0 -. -uses the same format as the \fBerrorCode\fR global variable -.PP -Note that \fBmsg\fR and \fBerrorCode\fR are only present for abnormally -terminated processes (i.e. those where the \fIcode\fR is nonzero). Under the -hood this command calls \fBTcl_WaitPid\fR with the \fBWNOHANG\fR flag set for -non-blocking behavior, unless the \fB\-wait\fR switch is set (see below). -.PP -Additionally, \fB::tcl::process status\fR accepts the following switches: -.TP -\fB\-wait\fR\0 -. -By default the command returns immediately (the underlying \fBTcl_WaitPid\fR is -called with the \fBWNOHANG\fR flag set) unless this switch is set. If \fIpids\fR -is specified as a list of PIDs then the command waits until the status of the -matching subprocesses are available. If \fIpids\fR was not specified, this -command will wait for all known subprocesses. -.TP -\fB\-\|\-\fR -. -Marks the end of switches. The argument following this one will -be treated as the first \fIarg\fR even if it starts with a \fB\-\fR. -.RE -.SH "EXAMPLES" -.PP -These show the use of \fB::tcl::process\fR. Some of the results from -\fB::tcl::process status\fR are split over multiple lines for readability. -.PP -.CS -\fB::tcl::process autopurge\fR - \fI\(-> true\fR -\fB::tcl::process autopurge\fR false - \fI\(-> false\fR - -set pid1 [exec command1 a b c | command2 d e f &] - \fI\(-> 123 456\fR -set chan [open "|command1 a b c | command2 d e f"] - \fI\(-> file123\fR -set pid2 [pid $chan] - \fI\(-> 789 1011\fR - -\fB::tcl::process list\fR - \fI\(-> 123 456 789 1011\fR - -\fB::tcl::process status\fR - \fI\(-> 123 0 - 456 {1 "child killed: write on pipe with no readers" { - CHILDKILLED 456 SIGPIPE "write on pipe with no readers"}} - 789 {1 "child suspended: background tty read" { - CHILDSUSP 789 SIGTTIN "background tty read"}} - 1011 {}\fR - -\fB::tcl::process status\fR 123 - \fI\(-> 123 0\fR - -\fB::tcl::process status\fR 1011 - \fI\(-> 1011 {}\fR - -\fB::tcl::process status\fR -wait - \fI\(-> 123 0 - 456 {1 "child killed: write on pipe with no readers" { - CHILDKILLED 456 SIGPIPE "write on pipe with no readers"}} - 789 {1 "child suspended: background tty read" { - CHILDSUSP 789 SIGTTIN "background tty read"}} - 1011 {1 "child process exited abnormally" { - CHILDSTATUS 1011 -1}}\fR - -\fB::tcl::process status\fR 1011 - \fI\(-> 1011 {1 "child process exited abnormally" { - CHILDSTATUS 1011 -1}}\fR - -\fB::tcl::process purge\fR -exec command1 1 2 3 & - \fI\(-> 1213\fR -\fB::tcl::process list\fR - \fI\(-> 1213\fR -.CE -.SH "SEE ALSO" -exec(n), open(n), pid(n), -Tcl_DetachPids(3), Tcl_WaitPid(3), Tcl_ReapDetachedProcs(3) -.SH "KEYWORDS" -background, child, detach, process, wait -'\" Local Variables: -'\" mode: nroff -'\" End: Index: doc/puts.n ================================================================== --- doc/puts.n +++ doc/puts.n @@ -94,9 +94,5 @@ .CE .SH "SEE ALSO" file(n), fileevent(n), Tcl_StandardChannels(3) .SH KEYWORDS channel, newline, output, write -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/pwd.n ================================================================== --- doc/pwd.n +++ doc/pwd.n @@ -35,9 +35,5 @@ .CE .SH "SEE ALSO" file(n), cd(n), glob(n), filename(n) .SH KEYWORDS working directory -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/re_syntax.n ================================================================== --- doc/re_syntax.n +++ doc/re_syntax.n @@ -291,16 +291,16 @@ itself. (If there are no other equivalent collating elements, the treatment is as if the enclosing delimiters were .QW \fB[.\fR \& and .QW \fB.]\fR .) -For example, if \fBo\fR and \fB\[^o]\fR are the members of an +For example, if \fBo\fR and \fB\(^o\fR are the members of an equivalence class, then .QW \fB[[=o=]]\fR , -.QW \fB[[=\[^o]=]]\fR , +.QW \fB[[=\(^o=]]\fR , and -.QW \fB[o\[^o]]\fR \& +.QW \fB[o\(^o]\fR \& are all synonymous. An equivalence class may not be an endpoint of a range. .RS .PP (\fINote:\fR Tcl implements only the Unicode locale. It does not define any equivalence classes. The examples above are just illustrations.) @@ -373,11 +373,11 @@ hexadecimal digits are reached, or an overflow would occur in the maximum value of \fBU+\fI10ffff\fR. .TP \fB\ev\fR . -vertical tab, as in C +vertical tab, as in C are all available. .TP \fB\ex\fIhh\fR . (where \fIhh\fR is one or two hexadecimal digits) the character whose hexadecimal value is \fB0x\fIhh\fR. Index: doc/regsub.n ================================================================== --- doc/regsub.n +++ doc/regsub.n @@ -66,37 +66,10 @@ and .QW \e\fIn\fR sequences are handled for each substitution using the information from the corresponding match. .TP -\fB\-command\fR -.VS 8.7 -Changes the handling of \fIsubSpec\fR so that it is not treated -as a template for a substitution string and the substrings -.QW & -and -.QW \e\fIn\fR -no longer have special meaning. Instead \fIsubSpec\fR must be a -command prefix, that is, a non-empty list. The substring of \fIstring\fR -that matches \fIexp\fR, and then each substring that matches each -capturing sub-RE within \fIexp\fR are appended as additional elements -to that list. (The items appended to the list are much like what -\fBregexp\fR \fB-inline\fR would return). The completed list is then -evaluated as a Tcl command, and the result of that command is the -substitution string. Any error or exception from command evaluation -becomes an error or exception from the \fBregsub\fR command. -.RS -.PP -If \fB\-all\fR is not also given, the command callback will be invoked at most -once (exactly when the regular expression matches). If \fB\-all\fR is given, -the command callback will be invoked for each matched location, in sequence. -The exact location indices that matched are not made available to the script. -.PP -See \fBEXAMPLES\fR below for illustrative cases. -.RE -.VE 8.7 -.TP \fB\-expanded\fR . Enables use of the expanded regular expression syntax where whitespace and comments are ignored. This is the same as specifying the \fB(?x)\fR embedded option (see the \fBre_syntax\fR manual page). @@ -208,59 +181,12 @@ # that newline is handled specially through \fBstring map\fR since # backslash-newline is a special sequence. set quoted [subst [string map {\en {\e\eu000a}} \e [\fBregsub\fR -all $RE $string $substitution]]] .CE -.PP -.VS 8.7 -The above operation can be done using \fBregsub \-command\fR instead, which is -often faster. (A full pre-computed \fBstring map\fR would be faster still, but -the cost of computing the map for a transformation as complex as this can be -quite large.) -.PP -.CS -# This RE is just a character class for everything "bad" -set RE {[][{};#\e\e\e$\es\eu0080-\euffff]} - -# This encodes what the RE described above matches -proc encodeChar {ch} { - # newline is handled specially since backslash-newline is a - # special sequence. - if {$ch eq "\en"} { - return "\e\eu000a" - } - # No point in writing this as a one-liner - scan $ch %c charNumber - format "\e\eu%04x" $charNumber -} - -set quoted [\fBregsub\fR -all -command $RE $string encodeChar] -.CE -.PP -Decoding a URL-encoded string using \fBregsub \-command\fR, a lambda term and -the \fBapply\fR command. -.PP -.CS -# Match one of the sequences in a URL-encoded string that needs -# fixing, converting + to space and %XX to the right character -# (e.g., %7e becomes ~) -set RE {(\e+)|%([0-9A-Fa-f]{2})} - -# Note that -command uses a command prefix, not a command name -set decoded [\fBregsub\fR -all -command $RE $string {apply {{- p h} { - # + is a special case; handle directly - if {$p eq "+"} { - return " " - } - # convert hex to a char - scan $h %x charNumber - format %c $charNumber -}}}] -.CE -.VE 8.7 .SH "SEE ALSO" regexp(n), re_syntax(n), subst(n), string(n) .SH KEYWORDS match, pattern, quoting, regular expression, substitution '\" Local Variables: '\" mode: nroff '\" End: Index: doc/rename.n ================================================================== --- doc/rename.n +++ doc/rename.n @@ -41,9 +41,5 @@ .CE .SH "SEE ALSO" namespace(n), proc(n) .SH KEYWORDS command, delete, namespace, rename -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/safe.n ================================================================== --- doc/safe.n +++ doc/safe.n @@ -9,21 +9,21 @@ .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME safe \- Creating and manipulating safe interpreters .SH SYNOPSIS -\fB::safe::interpCreate\fR ?\fIslave\fR? ?\fIoptions...\fR? -.sp -\fB::safe::interpInit\fR \fIslave\fR ?\fIoptions...\fR? -.sp -\fB::safe::interpConfigure\fR \fIslave\fR ?\fIoptions...\fR? -.sp -\fB::safe::interpDelete\fR \fIslave\fR -.sp -\fB::safe::interpAddToAccessPath\fR \fIslave\fR \fIdirectory\fR -.sp -\fB::safe::interpFindInAccessPath\fR \fIslave\fR \fIdirectory\fR +\fB::safe::interpCreate\fR ?\fIchild\fR? ?\fIoptions...\fR? +.sp +\fB::safe::interpInit\fR \fIchild\fR ?\fIoptions...\fR? +.sp +\fB::safe::interpConfigure\fR \fIchild\fR ?\fIoptions...\fR? +.sp +\fB::safe::interpDelete\fR \fIchild\fR +.sp +\fB::safe::interpAddToAccessPath\fR \fIchild\fR \fIdirectory\fR +.sp +\fB::safe::interpFindInAccessPath\fR \fIchild\fR \fIdirectory\fR .sp \fB::safe::setLogCmd\fR ?\fIcmd arg...\fR? .SS OPTIONS .PP ?\fB\-accessPath\fR \fIpathList\fR? @@ -42,52 +42,60 @@ scripts are prevented from corrupting the state of the hosting application or computer. Untrusted scripts are also prevented from disclosing information stored on the hosting computer or in the hosting application to any party. .PP -Safe Tcl allows a master interpreter to create safe, restricted +Safe Tcl allows a parent interpreter to create safe, restricted interpreters that contain a set of predefined aliases for the \fBsource\fR, \fBload\fR, \fBfile\fR, \fBencoding\fR, and \fBexit\fR commands and are able to use the auto-loading and package mechanisms. .PP No knowledge of the file system structure is leaked to the safe interpreter, because it has access only to a virtualized path containing tokens. When the safe interpreter requests to source a file, it uses the token in the virtual path as part of the file name to source; the -master interpreter transparently +parent interpreter transparently translates the token into a real directory name and executes the requested operation (see the section \fBSECURITY\fR below for details). Different levels of security can be selected by using the optional flags of the commands described below. .PP -All commands provided in the master interpreter by Safe Tcl reside in +All commands provided in the parent interpreter by Safe Tcl reside in the \fBsafe\fR namespace. .SH COMMANDS -The following commands are provided in the master interpreter: +The following commands are provided in the parent interpreter: .TP -\fB::safe::interpCreate\fR ?\fIslave\fR? ?\fIoptions...\fR? +\fB::safe::interpCreate\fR ?\fIchild\fR? ?\fIoptions...\fR? Creates a safe interpreter, installs the aliases described in the section \fBALIASES\fR and initializes the auto-loading and package mechanism as specified by the supplied \fIoptions\fR. See the \fBOPTIONS\fR section below for a description of the optional arguments. -If the \fIslave\fR argument is omitted, a name will be generated. +If the \fIchild\fR argument is omitted, a name will be generated. \fB::safe::interpCreate\fR always returns the interpreter name. +.sp +The interpreter name \fIchild\fR may include namespace separators, +but may not have leading or trailing namespace separators, or excess +colon characters in namespace separators. The interpreter name is +qualified relative to the global namespace ::, not the namespace in which +the \fB::safe::interpCreate\fR command is evaluated. .TP -\fB::safe::interpInit\fR \fIslave\fR ?\fIoptions...\fR? +\fB::safe::interpInit\fR \fIchild\fR ?\fIoptions...\fR? This command is similar to \fBinterpCreate\fR except it that does not -create the safe interpreter. \fIslave\fR must have been created by some -other means, like \fBinterp create\fR \fB\-safe\fR. +create the safe interpreter. \fIchild\fR must have been created by some +other means, like \fBinterp create\fR \fB\-safe\fR. The interpreter +name \fIchild\fR may include namespace separators, subject to the same +restrictions as for \fBinterpCreate\fR. .TP -\fB::safe::interpConfigure\fR \fIslave\fR ?\fIoptions...\fR? +\fB::safe::interpConfigure\fR \fIchild\fR ?\fIoptions...\fR? If no \fIoptions\fR are given, returns the settings for all options for the named safe interpreter as a list of options and their current values -for that \fIslave\fR. +for that \fIchild\fR. If a single additional argument is provided, it will return a list of 2 elements \fIname\fR and \fIvalue\fR where \fIname\fR is the full name of that option and \fIvalue\fR the current value -for that option and the \fIslave\fR. +for that option and the \fIchild\fR. If more than two additional arguments are provided, it will reconfigure the safe interpreter and change each and only the provided options. See the section on \fBOPTIONS\fR below for options description. Example of use: .RS @@ -103,41 +111,41 @@ # interp and its deleteHook (leaving the rest unchanged): safe::interpConfigure $i0 \-delete {foo bar} \-statics 0 .CE .RE .TP -\fB::safe::interpDelete\fR \fIslave\fR +\fB::safe::interpDelete\fR \fIchild\fR Deletes the safe interpreter and cleans up the corresponding -master interpreter data structures. +parent interpreter data structures. If a \fIdeleteHook\fR script was specified for this interpreter it is evaluated before the interpreter is deleted, with the name of the interpreter as an additional argument. .TP -\fB::safe::interpFindInAccessPath\fR \fIslave\fR \fIdirectory\fR +\fB::safe::interpFindInAccessPath\fR \fIchild\fR \fIdirectory\fR This command finds and returns the token for the real directory \fIdirectory\fR in the safe interpreter's current virtual access path. It generates an error if the directory is not found. Example of use: .RS .PP .CS -$slave eval [list set tk_library \e +$child eval [list set tk_library \e [::safe::interpFindInAccessPath $name $tk_library]] .CE .RE .TP -\fB::safe::interpAddToAccessPath\fR \fIslave\fR \fIdirectory\fR +\fB::safe::interpAddToAccessPath\fR \fIchild\fR \fIdirectory\fR This command adds \fIdirectory\fR to the virtual path maintained for the -safe interpreter in the master, and returns the token that can be used in +safe interpreter in the parent, and returns the token that can be used in the safe interpreter to obtain access to files in that directory. If the directory is already in the virtual path, it only returns the token without adding the directory to the virtual path again. Example of use: .RS .PP .CS -$slave eval [list set tk_library \e +$child eval [list set tk_library \e [::safe::interpAddToAccessPath $name $tk_library]] .CE .RE .TP \fB::safe::setLogCmd\fR ?\fIcmd arg...\fR? @@ -166,14 +174,14 @@ attempted to source a file not found in its virtual access path. Note that the safe interpreter only received an error message saying that the file was not found: .PP .CS -NOTICE for slave interp10 : Created -NOTICE for slave interp10 : Setting accessPath=(/foo/bar) staticsok=1 nestedok=0 deletehook=() -NOTICE for slave interp10 : auto_path in interp10 has been set to {$p(:0:)} -ERROR for slave interp10 : /foo/bar/init.tcl: no such file or directory +NOTICE for child interp10 : Created +NOTICE for child interp10 : Setting accessPath=(/foo/bar) staticsok=1 nestedok=0 deletehook=() +NOTICE for child interp10 : auto_path in interp10 has been set to {$p(:0:)} +ERROR for child interp10 : /foo/bar/init.tcl: no such file or directory .CE .RE .SS OPTIONS The following options are common to \fB::safe::interpCreate\fR, \fB::safe::interpInit\fR, @@ -185,11 +193,11 @@ \fB\-accessPath\fR \fIdirectoryList\fR This option sets the list of directories from which the safe interpreter can \fBsource\fR and \fBload\fR files. If this option is not specified, or if it is given as the empty list, the safe interpreter will use the same directories as its -master for auto-loading. +parent for auto-loading. See the section \fBSECURITY\fR below for more detail about virtual paths, tokens and access control. .TP \fB\-statics\fR \fIboolean\fR This option specifies if the safe interpreter will be allowed @@ -214,11 +222,11 @@ thus specifies the safe interpreter will be allowed to load packages into its own sub-interpreters. .TP \fB\-deleteHook\fR \fIscript\fR When this option is given a non-empty \fIscript\fR, it will be -evaluated in the master with the name of +evaluated in the parent with the name of the safe interpreter as an additional argument just before actually deleting the safe interpreter. Giving an empty value removes any currently installed deletion hook script for that safe interpreter. The default value (\fB{}\fR) is not to have any deletion call back. @@ -279,21 +287,21 @@ Because some of these commands access the local file system, there is a potential for information leakage about its directory structure. To prevent this, commands that take file names as arguments in a safe interpreter use tokens instead of the real directory names. These tokens are translated to the real directory name while a request to, -e.g., source a file is mediated by the master interpreter. -This virtual path system is maintained in the master interpreter for each safe +e.g., source a file is mediated by the parent interpreter. +This virtual path system is maintained in the parent interpreter for each safe interpreter created by \fB::safe::interpCreate\fR or initialized by \fB::safe::interpInit\fR and the path maps tokens accessible in the safe interpreter into real path names on the local file system thus preventing safe interpreters from gaining knowledge about the structure of the file system of the host on which the interpreter is executing. The only valid file names arguments -for the \fBsource\fR and \fBload\fR aliases provided to the slave +for the \fBsource\fR and \fBload\fR aliases provided to the child are path in the form of \fB[file join \fItoken filename\fB]\fR (i.e. when using the native file path formats: \fItoken\fB/\fIfilename\fR on Unix and \fItoken\fB\e\fIfilename\fR on Windows), where \fItoken\fR is representing one of the directories @@ -318,30 +326,30 @@ or be called .PQ \fBtclIndex\fR . .PP Each element of the initial access path list will be assigned a token that will be set in -the slave \fBauto_path\fR and the first element of that list will be set as -the \fBtcl_library\fR for that slave. +the child \fBauto_path\fR and the first element of that list will be set as +the \fBtcl_library\fR for that child. .PP If the access path argument is not given or is the empty list, -the default behavior is to let the slave access the same packages -as the master has access to (Or to be more precise: +the default behavior is to let the child access the same packages +as the parent has access to (Or to be more precise: only packages written in Tcl (which by definition cannot be dangerous -as they run in the slave interpreter) and C extensions that -provides a _SafeInit entry point). For that purpose, the master's -\fBauto_path\fR will be used to construct the slave access path. -In order that the slave successfully loads the Tcl library files +as they run in the child interpreter) and C extensions that +provides a _SafeInit entry point). For that purpose, the parent's +\fBauto_path\fR will be used to construct the child access path. +In order that the child successfully loads the Tcl library files (which includes the auto-loading mechanism itself) the \fBtcl_library\fR will be added or moved to the first position if necessary, in the -slave access path, so the slave -\fBtcl_library\fR will be the same as the master's (its real -path will still be invisible to the slave though). -In order that auto-loading works the same for the slave and -the master in this by default case, the first-level -sub directories of each directory in the master \fBauto_path\fR will -also be added (if not already included) to the slave access path. +child access path, so the child +\fBtcl_library\fR will be the same as the parent's (its real +path will still be invisible to the child though). +In order that auto-loading works the same for the child and +the parent in this by default case, the first-level +sub directories of each directory in the parent \fBauto_path\fR will +also be added (if not already included) to the child access path. You can always specify a more restrictive path for which sub directories will never be searched by explicitly specifying your directory list with the \fB\-accessPath\fR flag instead of relying on this default mechanism. .PP @@ -350,10 +358,10 @@ an \fBauto_reset\fR is automatically evaluated in the safe interpreter to synchronize its \fBauto_index\fR with the new token list. .SH "SEE ALSO" interp(n), library(n), load(n), package(n), source(n), unknown(n) .SH KEYWORDS -alias, auto\-loading, auto_mkindex, load, master interpreter, safe -interpreter, slave interpreter, source +alias, auto\-loading, auto_mkindex, load, parent interpreter, safe +interpreter, child interpreter, source '\" Local Variables: '\" mode: nroff '\" End: Index: doc/scan.n ================================================================== --- doc/scan.n +++ doc/scan.n @@ -222,14 +222,16 @@ .CS set string "#08D03F" \fBscan\fR $string "#%2x%2x%2x" r g b .CE .PP -Parse a \fIHH:MM\fR time string: +Parse a \fIHH:MM\fR time string, noting that this avoids problems with +octal numbers by forcing interpretation as decimals (if we did not +care, we would use the \fB%i\fR conversion instead): .PP .CS -set string "08:08" +set string "08:08" ;# *Not* octal! if {[\fBscan\fR $string "%d:%d" hours minutes] != 2} { error "not a valid time string" } # We have to understand numeric ranges ourselves... if {$minutes < 0 || $minutes > 59} { Index: doc/self.n ================================================================== --- doc/self.n +++ doc/self.n @@ -30,16 +30,11 @@ This returns a two-element list describing the method implementations used to implement the current call chain. The first element is the same as would be reported by \fBinfo object\fR \fBcall\fR for the current method (except that this also reports useful values from within constructors and destructors, whose names are reported as \fB\fR and \fB\fR -respectively, -.VS TIP500 -and for private methods, which are described as being \fBprivate\fR instead of -being a \fBmethod\fR), -.VE TIP500 -and the second element is an index into the first element's +respectively), and the second element is an index into the first element's list that indicates which actual implementation is currently executing (the first implementation to execute is always at index 0). .TP \fBself caller\fR . Index: doc/set.n ================================================================== --- doc/set.n +++ doc/set.n @@ -71,9 +71,5 @@ .CE .SH "SEE ALSO" expr(n), global(n), namespace(n), proc(n), trace(n), unset(n), upvar(n), variable(n) .SH KEYWORDS read, write, variable -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: DELETED doc/singleton.n Index: doc/singleton.n ================================================================== --- doc/singleton.n +++ /dev/null @@ -1,99 +0,0 @@ -'\" -'\" Copyright (c) 2018 Donal K. Fellows -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH singleton n 0.3 TclOO "TclOO Commands" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -oo::singleton \- a class that does only allows one instance of itself -.SH SYNOPSIS -.nf -package require TclOO - -\fBoo::singleton\fI method \fR?\fIarg ...\fR? -.fi -.SH "CLASS HIERARCHY" -.nf -\fBoo::object\fR - \(-> \fBoo::class\fR - \(-> \fBoo::singleton\fR -.fi -.BE -.SH DESCRIPTION -Singleton classes are classes that only permit at most one instance of -themselves to exist. They unexport the \fBcreate\fR and -\fBcreateWithNamespace\fR methods entirely, and override the \fBnew\fR method -so that it only makes a new instance if there is no existing instance. It is -not recommended to inherit from a singleton class; singleton-ness is \fInot\fR -inherited. It is not recommended that a singleton class's constructor take any -arguments. -.PP -Instances have their\fB destroy\fR method overridden with a method that always -returns an error in order to discourage destruction of the object, but -destruction remains possible if strictly necessary (e.g., by destroying the -class or using \fBrename\fR to delete it). They also have a (non-exported) -\fB\fR method defined on them that similarly always returns errors to -make attempts to use the singleton instance with \fBoo::copy\fR fail. -.SS CONSTRUCTOR -The \fBoo::singleton\fR class does not define an explicit constructor; this -means that it is effectively the same as the constructor of the -\fBoo::class\fR class. -.SS DESTRUCTOR -The \fBoo::singleton\fR class does not define an explicit destructor; -destroying an instance of it is just like destroying an ordinary class (and -will destroy the singleton object). -.SS "EXPORTED METHODS" -.TP -\fIcls \fBnew \fR?\fIarg ...\fR? -. -This returns the current instance of the singleton class, if one exists, and -creates a new instance only if there is no existing instance. The additional -arguments, \fIarg ...\fR, are only used if a new instance is actually -manufactured; that construction is via the \fBoo::class\fR class's \fBnew\fR -method. -.RS -.PP -This is an override of the behaviour of a superclass's method with an -identical call signature to the superclass's implementation. -.RE -.SS "NON-EXPORTED METHODS" -The \fBoo::singleton\fR class explicitly states that \fBcreate\fR and -\fBcreateWithNamespace\fR are unexported; callers should not assume that they -have control over either the name or the namespace name of the singleton instance. -.SH EXAMPLE -.PP -This example demonstrates that there is only one instance even though the -\fBnew\fR method is called three times. -.PP -.CS -\fBoo::singleton\fR create Highlander { - method say {} { - puts "there can be only one" - } -} - -set h1 [Highlander new] -set h2 [Highlander new] -if {$h1 eq $h2} { - puts "equal objects" \fI\(-> prints "equal objects"\fR -} -set h3 [Highlander new] -if {$h1 eq $h3} { - puts "equal objects" \fI\(-> prints "equal objects"\fR -} -.CE -.PP -Note that the name of the instance of the singleton is not guaranteed to be -anything in particular. -.SH "SEE ALSO" -oo::class(n) -.SH KEYWORDS -class, metaclass, object, single instance -.\" Local variables: -.\" mode: nroff -.\" fill-column: 78 -.\" End: Index: doc/socket.n ================================================================== --- doc/socket.n +++ doc/socket.n @@ -129,20 +129,10 @@ If the option is omitted then the server socket is bound to the wildcard address so that it can accept connections from any interface. If \fIaddr\fR is a domain name that resolves to multiple IP addresses that are available on the local machine, the socket will listen on all of them. -.TP -\fB\-reuseaddr\fI boolean\fR -. -Tells the kernel whether to reuse the local address if there is no socket -actively listening on it. This is the default on Windows. -.TP -\fB\-reuseport\fI boolean\fR -. -Tells the kernel whether to allow the binding of multiple sockets to the same -address and port. .PP Server channels cannot be used for input or output; their sole use is to accept new client connections. The channels created for each incoming client connection are opened for input and output. Closing the server channel shuts down the server so that no new connections will be Index: doc/source.n ================================================================== --- doc/source.n +++ doc/source.n @@ -67,9 +67,5 @@ .CE .SH "SEE ALSO" file(n), cd(n), encoding(n), info(n) .SH KEYWORDS file, script -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/string.n ================================================================== --- doc/string.n +++ doc/string.n @@ -10,19 +10,19 @@ .BS .\" Note: do not modify the .SH NAME line immediately below! .SH NAME string \- Manipulate strings .SH SYNOPSIS -\fBstring \fIoption arg \fR?\fIarg ...\fR? +\fBstring \fIoption arg \fR?\fIarg ...?\fR .BE .SH DESCRIPTION .PP Performs one of several string operations, depending on \fIoption\fR. The legal \fIoption\fRs (which may be abbreviated) are: .TP \fBstring cat\fR ?\fIstring1\fR? ?\fIstring2...\fR? -. +.VS 8.6.2 Concatenate the given \fIstring\fRs just like placing them directly next to each other and return the resulting compound string. If no \fIstring\fRs are present, the result is an empty string. .RS .PP @@ -30,10 +30,11 @@ when mixed quoting is wanted, or when the aim is to return the result of a concatenation without resorting to \fBreturn\fR \fB\-level 0\fR, and is more efficient than building a list of arguments and using \fBjoin\fR with an empty join string. .RE +.VE .TP \fBstring compare\fR ?\fB\-nocase\fR? ?\fB\-length\fI length\fR? \fIstring1 string2\fR . Perform a character-by-character comparison of strings \fIstring1\fR and \fIstring2\fR. Returns \-1, 0, or 1, depending on whether @@ -86,28 +87,10 @@ .PP If \fIcharIndex\fR is less than 0 or greater than or equal to the length of the string then this command returns an empty string. .RE .TP -\fBstring insert \fIstring index insertString\fR -.VS "TIP 504" -Returns a copy of \fIstring\fR with \fIinsertString\fR inserted at the -\fIindex\fR'th character. The \fIindex\fR may be specified as described in the -\fBSTRING INDICES\fR section. -.RS -.PP -If \fIindex\fR is start-relative, the first character inserted in the returned -string will be at the specified index. If \fIindex\fR is end-relative, the last -character inserted in the returned string will be at the specified index. -.PP -If \fIindex\fR is at or before the start of \fIstring\fR (e.g., \fIindex\fR is -\fB0\fR), \fIinsertString\fR is prepended to \fIstring\fR. If \fIindex\fR is at -or after the end of \fIstring\fR (e.g., \fIindex\fR is \fBend\fR), -\fIinsertString\fR is appended to \fIstring\fR. -.RE -.VE "TIP 504" -.TP \fBstring is \fIclass\fR ?\fB\-strict\fR? ?\fB\-failindex \fIvarname\fR? \fIstring\fR . Returns 1 if \fIstring\fR is a valid member of the specified character class, otherwise returns 0. If \fB\-strict\fR is specified, then an empty string returns 0, otherwise an empty string will return 1 on @@ -126,28 +109,21 @@ 7\-bit ascii range). .IP \fBboolean\fR 12 Any of the forms allowed to \fBTcl_GetBoolean\fR. .IP \fBcontrol\fR 12 Any Unicode control character. -.IP \fBdict\fR 12 -.VS TIP501 -Any proper dict structure, with optional surrounding whitespace. In -case of improper dict structure, 0 is returned and the \fIvarname\fR -will contain the index of the -.QW element -where the dict parsing fails, or \-1 if this cannot be determined. -.VE TIP501 .IP \fBdigit\fR 12 Any Unicode digit character. Note that this includes characters outside of the [0\-9] range. .IP \fBdouble\fR 12 Any of the forms allowed to \fBTcl_GetDoubleFromObj\fR. .IP \fBentier\fR 12 -. +.VS 8.6 Any of the valid string formats for an integer value of arbitrary size in Tcl, with optional surrounding whitespace. The formats accepted are exactly those accepted by the C routine \fBTcl_GetBignumFromObj\fR. +.VE .IP \fBfalse\fR 12 Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is false. .IP \fBgraph\fR 12 Any Unicode printing character, except space. @@ -290,32 +266,27 @@ .TP \fBstring range \fIstring first last\fR . Returns a range of consecutive characters from \fIstring\fR, starting with the character whose index is \fIfirst\fR and ending with the -character whose index is \fIlast\fR (using the forms described in -\fBSTRING INDICES\fR). An index of \fB0\fR refers to the first -character of the string; an index of \fBend\fR refers to last +character whose index is \fIlast\fR. An index of 0 refers to the first character of the string. \fIfirst\fR and \fIlast\fR may be specified as for the \fBindex\fR method. If \fIfirst\fR is less than zero then it is treated as if it were zero, and if \fIlast\fR is greater than or equal to the length of the string then it is treated as if it were \fBend\fR. If \fIfirst\fR is greater than \fIlast\fR then an empty string is returned. .TP \fBstring repeat \fIstring count\fR . -Returns a string consisting of \fIstring\fR concatenated with itself -\fIcount\fR times. If \fIcount\fR is 0, the empty string will be -returned. +Returns \fIstring\fR repeated \fIcount\fR number of times. .TP \fBstring replace \fIstring first last\fR ?\fInewstring\fR? . Removes a range of consecutive characters from \fIstring\fR, starting with the character whose index is \fIfirst\fR and ending with the -character whose index is \fIlast\fR (using the forms described in -\fBSTRING INDICES\fR). An index of 0 refers to the +character whose index is \fIlast\fR. An index of 0 refers to the first character of the string. \fIFirst\fR and \fIlast\fR may be specified as for the \fBindex\fR method. If \fInewstring\fR is specified, then it is placed in the removed character range. If \fIfirst\fR is less than zero then it is treated as if it were zero, and if \fIlast\fR is greater than or equal to the length of the string @@ -360,25 +331,25 @@ \fBstring trim \fIstring\fR ?\fIchars\fR? . Returns a value equal to \fIstring\fR except that any leading or trailing characters present in the string given by \fIchars\fR are removed. If \fIchars\fR is not specified then white space is removed (any character -for which \fBstring is space\fR returns 1, and "\0"). +for which \fBstring is space\fR returns 1, and "\e0"). .TP \fBstring trimleft \fIstring\fR ?\fIchars\fR? . Returns a value equal to \fIstring\fR except that any leading characters present in the string given by \fIchars\fR are removed. If \fIchars\fR is not specified then white space is removed (any character -for which \fBstring is space\fR returns 1, and "\0"). +for which \fBstring is space\fR returns 1, and "\e0"). .TP \fBstring trimright \fIstring\fR ?\fIchars\fR? . Returns a value equal to \fIstring\fR except that any trailing characters present in the string given by \fIchars\fR are removed. If \fIchars\fR is not specified then white space is removed (any character -for which \fBstring is space\fR returns 1, and "\0"). +for which \fBstring is space\fR returns 1, and "\e0"). .SS "OBSOLETE SUBCOMMANDS" .PP These subcommands are currently supported, but are likely to go away in a future release as their functionality is either virtually never used or highly misleading. Index: doc/tclsh.1 ================================================================== --- doc/tclsh.1 +++ doc/tclsh.1 @@ -141,18 +141,9 @@ if \fBtcl_prompt2\fR is not set then no prompt is output for incomplete commands. .SH "STANDARD CHANNELS" .PP See \fBTcl_StandardChannels\fR for more explanations. -.SH ZIPVFS -.PP -When a zipfile is concatenated to the end of a \fBtclsh\fR, on -startup the contents of the zip archive will be mounted as the -virtual file system /zvfs. If a top level directory tcl8.6 is -present in the zip archive, it will become the directory loaded -as env(TCL_LIBRARY). If a file named \fBmain.tcl\fR is present -in the top level directory of the zip archive, it will be sourced -instead of the shell's normal command line handing. .SH "SEE ALSO" auto_path(n), encoding(n), env(n), fconfigure(n) .SH KEYWORDS application, argument, interpreter, prompt, script file, shell Index: doc/tcltest.n ================================================================== --- doc/tcltest.n +++ doc/tcltest.n @@ -201,11 +201,11 @@ array. Returns an empty string. .RE .TP \fBrunAllTests\fR . -This is a master command meant to run an entire suite of tests, +This is a main command meant to run an entire suite of tests, spanning multiple files and/or directories, as governed by the configurable options of \fBtcltest\fR. See \fBRUNNING ALL TESTS\fR below for a complete description of the many variations possible with \fBrunAllTests\fR. .SS "CONFIGURATION COMMANDS" @@ -802,21 +802,21 @@ be \fBsource\fRd in the caller's context. If it is false, then a copy of \fBinterpreter\fR will be \fBexec\fR'd to evaluate each file. The multi-process operation is useful when testing can cause errors so severe that a process terminates. Although such an error may terminate a child -process evaluating one file, the master process can continue +process evaluating one file, the main process can continue with the rest of the test suite. In multi-process operation, -the configuration of \fBtcltest\fR in the master process is +the configuration of \fBtcltest\fR in the main process is passed to the child processes as command line arguments, with the exception of \fBconfigure \-outfile\fR. The \fBrunAllTests\fR command in the -master process collects all output from the child processes -and collates their results into one master report. Any +main process collects all output from the child processes +and collates their results into one main report. Any reports of individual test failures, or messages requested by a \fBconfigure \-verbose\fR setting are passed directly -on to \fBoutputChannel\fR by the master process. +on to \fBoutputChannel\fR by the main process. .PP After evaluating all selected test files, a summary of the results is printed to \fBoutputChannel\fR. The summary includes the total number of \fBtest\fRs evaluated, broken down into those skipped, those passed, and those failed. @@ -1132,11 +1132,11 @@ in a namespace that is deleted when the test file evaluation is complete. A good namespace to use is a child namespace \fBtest\fR of the namespace of the module you are testing. .PP A test file should also be able to be evaluated directly as a script, -not depending on being called by a master \fBrunAllTests\fR. This +not depending on being called by a main \fBrunAllTests\fR. This means that each test file should process command line arguments to give the tester all the configuration control that \fBtcltest\fR provides. .PP After all \fBtest\fRs in a test file, the command \fBcleanupTests\fR should be called. @@ -1143,11 +1143,11 @@ .IP [7] Here is a sketch of a sample test file illustrating those points: .RS .PP .CS -package require tcltest 2.2 +package require tcltest 2.5 eval \fB::tcltest::configure\fR $argv package require example namespace eval ::example::test { namespace import ::tcltest::* \fBtestConstraint\fR X [expr {...}] @@ -1173,16 +1173,16 @@ basic function of this script is to call \fBrunAllTests\fR after doing any necessary setup. This script is usually named \fBall.tcl\fR because that is the default name used by \fBrunAllTests\fR when combining multiple test suites into one testing run. .IP [8] -Here is a sketch of a sample test suite master script: +Here is a sketch of a sample test suite main script: .RS .PP .CS -package require Tcl 8.4 -package require tcltest 2.2 +package require Tcl 8.6 +package require tcltest 2.5 package require example \fB::tcltest::configure\fR -testdir \e [file dirname [file normalize [info script]]] eval \fB::tcltest::configure\fR $argv \fB::tcltest::runAllTests\fR Index: doc/tclvars.n ================================================================== --- doc/tclvars.n +++ doc/tclvars.n @@ -8,11 +8,11 @@ .TH tclvars n 8.0 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -argc, argv, argv0, auto_path, env, errorCode, errorInfo, tcl_interactive, tcl_library, tcl_nonwordchars, tcl_patchLevel, tcl_pkgPath, tcl_platform, tcl_rcFileName, tcl_traceCompile, tcl_traceExec, tcl_wordchars, tcl_version \- Variables used by Tcl +argc, argv, argv0, auto_path, env, errorCode, errorInfo, tcl_interactive, tcl_library, tcl_nonwordchars, tcl_patchLevel, tcl_pkgPath, tcl_platform, tcl_precision, tcl_rcFileName, tcl_traceCompile, tcl_traceExec, tcl_wordchars, tcl_version \- Variables used by Tcl .BE .SH DESCRIPTION .PP The following global variables are created and managed automatically by the Tcl library. Except where noted below, these variables should @@ -353,10 +353,74 @@ \fBwordSize\fR . This gives the size of the native-machine word in bytes (strictly, it is same as the result of evaluating \fIsizeof(long)\fR in C.) .RE +.TP +\fBtcl_precision\fR +. +This variable controls the number of digits to generate +when converting floating-point values to strings. It defaults +to 0. \fIApplications should not change this value;\fR it is +provided for compatibility with legacy code. +.PP +.RS +The default value of 0 is special, meaning that Tcl should +convert numbers using as few digits as possible while still +distinguishing any floating point number from its nearest +neighbours. It differs from using an arbitrarily high value +for \fItcl_precision\fR in that an inexact number like \fI1.4\fR +will convert as \fI1.4\fR rather than \fI1.3999999999999999\fR +even though the latter is nearer to the exact value of the +binary number. +.RE +.PP +.RS +If \fBtcl_precision\fR is not zero, then when Tcl converts a floating +point number, it creates a decimal representation of at most +\fBtcl_precision\fR significant digits; the result may be shorter if +the shorter result represents the original number exactly. If no +result of at most \fBtcl_precision\fR digits is an exact representation +of the original number, the one that is closest to the original +number is chosen. +If the original number lies precisely between two equally accurate +decimal representations, then the one with an even value for the least +significant digit is chosen; for instance, if \fBtcl_precision\fR is 3, then +0.3125 will convert to 0.312, not 0.313, while 0.6875 will convert to +0.688, not 0.687. Any string of trailing zeroes that remains is trimmed. +.RE +.PP +.RS +a \fBtcl_precision\fR value of 17 digits is +.QW perfect +for IEEE floating-point in that it allows +double-precision values to be converted to strings and back to +binary with no loss of information. For this reason, you will often +see it as a value in legacy code that must run on Tcl versions before +8.5. It is no longer recommended; as noted above, a zero value is the +preferred method. +.RE +.PP +.RS +All interpreters in a thread share a single \fBtcl_precision\fR value: +changing it in one interpreter will affect all other interpreters as +well. Safe interpreters are not allowed to modify the +variable. +.RE +.PP +.RS +Valid values for \fBtcl_precision\fR range from 0 to 17. +.RE +.TP +\fBtcl_rcFileName\fR +. +This variable is used during initialization to indicate the name of a +user-specific startup file. If it is set by application-specific +initialization, then the Tcl startup code will check for the existence +of this file and \fBsource\fR it if it exists. For example, for \fBwish\fR +the variable is set to \fB~/.wishrc\fR for Unix and \fB~/wishrc.tcl\fR +for Windows. .TP \fBtcl_traceCompile\fR . The value of this variable can be set to control how much tracing information Index: doc/tell.n ================================================================== --- doc/tell.n +++ doc/tell.n @@ -14,11 +14,11 @@ .SH SYNOPSIS \fBtell \fIchannelId\fR .BE .SH DESCRIPTION .PP -Returns an integer giving the current access position in +Returns an integer string giving the current access position in \fIchannelId\fR. This value returned is a byte offset that can be passed to \fBseek\fR in order to set the channel to a particular position. Note that this value is in terms of bytes, not characters like \fBread\fR. The value returned is -1 for channels that do not support seeking. @@ -44,9 +44,5 @@ .CE .SH "SEE ALSO" file(n), open(n), close(n), gets(n), seek(n), Tcl_StandardChannels(3) .SH KEYWORDS access position, channel, seeking -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/trace.n ================================================================== --- doc/trace.n +++ doc/trace.n @@ -18,12 +18,11 @@ .SH DESCRIPTION .PP This command causes Tcl commands to be executed whenever certain operations are invoked. The legal \fIoption\fRs (which may be abbreviated) are: .TP -\fBtrace add \fItype name ops\fR ?\fIargs\fR? -. +\fBtrace add \fItype name ops ?args?\fR Where \fItype\fR is \fBcommand\fR, \fBexecution\fR, or \fBvariable\fR. .RS .TP \fBtrace add command\fR \fIname ops commandPrefix\fR . Index: doc/unknown.n ================================================================== --- doc/unknown.n +++ doc/unknown.n @@ -87,9 +87,5 @@ .CE .SH "SEE ALSO" info(n), proc(n), interp(n), library(n), namespace(n) .SH KEYWORDS error, non-existent command, unknown -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/update.n ================================================================== --- doc/update.n +++ doc/update.n @@ -61,9 +61,5 @@ .CE .SH "SEE ALSO" after(n), interp(n) .SH KEYWORDS asynchronous I/O, event, flush, handler, idle, update -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/uplevel.n ================================================================== --- doc/uplevel.n +++ doc/uplevel.n @@ -22,13 +22,13 @@ the result of that evaluation. .PP If \fIlevel\fR is an integer then it gives a distance (up the procedure calling stack) to move before executing the command. If \fIlevel\fR consists of \fB#\fR followed by -a integer then the level gives an absolute level. If \fIlevel\fR +a number then the number gives an absolute level number. If \fIlevel\fR is omitted then it defaults to \fB1\fR. \fILevel\fR cannot be -defaulted if the first \fIcommand\fR argument is an integer or starts with \fB#\fR. +defaulted if the first \fIcommand\fR argument starts with a digit or \fB#\fR. .PP For example, suppose that procedure \fBa\fR was invoked from top-level, and that it called \fBb\fR, and that \fBb\fR called \fBc\fR. Suppose that \fBc\fR invokes the \fBuplevel\fR command. If \fIlevel\fR is \fB1\fR or \fB#2\fR or omitted, then the command will be executed Index: doc/while.n ================================================================== --- doc/while.n +++ doc/while.n @@ -61,9 +61,5 @@ .CE .SH "SEE ALSO" break(n), continue(n), for(n), foreach(n) .SH KEYWORDS boolean, loop, test, while -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: DELETED doc/zipfs.3 Index: doc/zipfs.3 ================================================================== --- doc/zipfs.3 +++ /dev/null @@ -1,120 +0,0 @@ -'\" -'\" Copyright (c) 2015 Jan Nijtmans -'\" Copyright (c) 2015 Christian Werner -'\" Copyright (c) 2017 Sean Woods -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH Tclzipfs 3 8.7 Tcl "Tcl Library Procedures" -.so man.macros -.BS -.SH NAME -TclZipfs_AppHook, Tclzipfs_Mount, TclZipfs_MountBuffer, Tclzipfs_Unmount \- handle ZIP files as Tcl virtual filesystems -.SH SYNOPSIS -.nf -int -\fBTclZipfs_AppHook(\fIargcPtr, argvPtr\fR) -.sp -int -\fBTclzipfs_Mount\fR(\fIinterp, mountpoint, zipname, password\fR) -.sp -int -\fBTclZipfs_MountBuffer\fR(\fIinterp, mountpoint, data, dataLen, copy\fR) -.sp -int -\fBTclzipfs_Unmount\fR(\fIinterp, mountpoint\fR) -.fi -.SH ARGUMENTS -.AS Tcl_Interp *mountpoint in -.AP "int" *argcPtr in -Pointer to a variable holding the number of command line arguments from -\fBmain\fR(). -.AP "char" ***argvPtr in -Pointer to an array of strings containing the command line arguments to -\fBmain\fR(). -.AP Tcl_Interp *interp in -Interpreter in which the ZIP file system is mounted. The interpreter's result is -modified to hold the result or error message from the script. -.AP "const char" *zipname in -Name of a ZIP file. Must not be NULL when either mounting or unmounting a ZIP. -.AP "const char" *mountpoint in -Name of a mount point, which must be a legal Tcl file or directory name. May -be NULL to query current mount points. -.AP "const char" *password in -An (optional) password. Use NULL if no password is wanted to read the file. -.AP "unsigned char" *data in -A data buffer to mount. The data buffer must hold the contents of a ZIP -archive, and must not be NULL. -.AP size_t dataLen in -The number of bytes in the supplied data buffer argument, \fIdata\fR. -.AP int copy in -If non-zero, the ZIP archive in the data buffer will be internally copied -before mounting, allowing the data buffer to be disposed once -\fBTclZipfs_MountBuffer\fR returns. If zero, the caller guarantees that the -buffer will be valid to read from for the duration of the mount. -.BE -.SH DESCRIPTION -\fBTclZipfs_AppHook\fR is a utility function to perform standard application -initialization procedures, taking into account available ZIP archives as -follows: -.IP [1] -If the current application has a mountable ZIP archive, that archive is -mounted under \fIZIPFS_VOLUME\fB/app\fR as a read-only Tcl virtual file -system. \fIZIPFS_VOLUME\fR is usually \fB//zipfs:\fR on all platforms, but -\fBzipfs:\fR may also be used on Windows (due to differences in the -platform's filename parsing). -.IP [2] -If a file named \fBmain.tcl\fR is located in the root directory of that file -system (i.e., at \fIZIPROOT\fB/app/main.tcl\fR after the ZIP archive is -mounted as described above) it is treated as the startup script for the -process. -.IP [3] -If the file \fIZIPROOT\fB/app/tcl_library/init.tcl\fR is present, the -\fBtcl_library\fR global variable in the initial Tcl interpreter is set to -\fIZIPROOT\fB/app/tcl_library\fR. -.IP [4] -If the directory \fBtcl_library\fR was not found in the main application -mount, the system will then search for it as either a VFS attached to the -application dynamic library, or as a zip archive named -\fBlibtcl_\fImajor\fB_\fIminor\fB_\fIpatchlevel\fB.zip\fR either in the -present working directory or in the standard Tcl install location. (For -example, the Tcl 8.7.2 release would be searched for in a file -\fBlibtcl_8_7_2.zip\fR.) That archive, if located, is also mounted read-only. -.PP -On Windows, \fBTclZipfs_AppHook\fR has a slightly different signature, since -it uses WCHAR in stead of char. As a result, it requires your application to -be compiled with the UNICODE preprocessor symbol defined (e.g., via the -\fB-DUNICODE\fR compiler flag). -.PP -The result of \fBTclZipfs_AppHook\fR is a Tcl result code (e.g., \fBTCL_OK\fR -when the function is successful). The function \fImay\fR modify the variables -pointed to by \fIargcPtr\fR and \fIargvPtr\fR to remove arguments; the -current implementation does not do so, but callers \fIshould not\fR assume -that this will be true in the future. -.PP -\fBTclzipfs_Mount\fR mounts the ZIP archive \fIzipname\fR on the mount point -given in \fImountpoint\fR using the optional ZIP password \fIpassword\fR. -Errors during that process are reported in the interpreter \fIinterp\fR. If -\fImountpoint\fR is a NULL pointer, information on all currently mounted ZIP -file systems is written into \fIinterp\fR's result as a sequence of mount -points and ZIP file names. The result of this call is a standard Tcl result -code. -.PP -\fBTclzipfs_MountBuffer\fR mounts the ZIP archive in the buffer pointed to by -\fIdata\fR on the mount point given in \fImountpoint\fR. The ZIP archive is -assumed to be not password protected. Errors during that process are reported -in the interpreter \fIinterp\fR. The \fIcopy\fR argument determines whether -the buffer is internally copied before mounting or not. The result of this -call is a standard Tcl result code. -.PP -\fBTclzipfs_Unmount\fR undoes the effect of \fBTclzipfs_Mount\fR, i.e., it -unmounts the mounted ZIP file system that was mounted from \fIzipname\fR (at -\fImountpoint\fR). Errors are reported in the interpreter \fIinterp\fR. The -result of this call is a standard Tcl result code. -.PP -\fBTclZipfs_AppHook\fR can not be used in stub-enabled extensions. -.SH "SEE ALSO" -zipfs(n) -.SH KEYWORDS -compress, filesystem, zip DELETED doc/zipfs.n Index: doc/zipfs.n ================================================================== --- doc/zipfs.n +++ /dev/null @@ -1,254 +0,0 @@ -'\" -'\" Copyright (c) 2015 Jan Nijtmans -'\" Copyright (c) 2015 Christian Werner -'\" Copyright (c) 2015 Sean Woods -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH zipfs n 1.0 Zipfs "zipfs Commands" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -zipfs \- Mount and work with ZIP files within Tcl -.SH SYNOPSIS -.nf -\fBpackage require zipfs \fR?\fB1.0\fR? -.sp -\fBzipfs canonical\fR ?\fImntpnt\fR? \fIfilename\fR ?\fIZIPFS\fR? -\fBzipfs exists\fR \fIfilename\fR -\fBzipfs find\fR \fIdirectoryName\fR -\fBzipfs info\fR \fIfilename\fR -\fBzipfs list\fR ?(\fB\-glob\fR|\fB\-regexp\fR)? ?\fIpattern\fR? -\fBzipfs lmkimg\fR \fIoutfile inlist\fR ?\fIpassword infile\fR? -\fBzipfs lmkzip\fR \fIoutfile inlist\fR ?\fIpassword\fR? -\fBzipfs mkimg\fR \fIoutfile indir\fR ?\fIstrip\fR? ?\fIpassword\fR? ?\fIinfile\fR? -\fBzipfs mkkey\fR \fIpassword\fR -\fBzipfs mkzip\fR \fIoutfile indir\fR ?\fIstrip\fR? ?\fIpassword\fR? -\fBzipfs mount\fR ?\fImountpoint\fR? ?\fIzipfile\fR? ?\fIpassword\fR? -\fBzipfs root\fR -\fBzipfs unmount\fR \fImountpoint\fR -.fi -'\" The following subcommand is *UNDOCUMENTED* -'\" \fBzipfs mount_data\fR ?\fImountpoint\fR? ?\fIdata\fR? -.BE -.SH DESCRIPTION -.PP -The \fBzipfs\fR command (the sole public command provided by the built-in -package with the same name) provides Tcl with the ability to mount the -contents of a ZIP archive file as a virtual file system. ZIP archives support -simple encryption, sufficient to prevent casual inspection of their contents -but not able to prevent access by even a moderately determined attacker. -.TP -\fBzipfs canonical\fR ?\fImountpoint\fR? \fIfilename\fR ?\fIinZipfs\fR? -. -This takes the name of a file, \fIfilename\fR, and produces where it would be -mapped into a zipfs mount as its result. If specified, \fImountpoint\fR says -within which mount the mapping will be done; if omitted, the main root of the -zipfs system is used. The \fIinZipfs\fR argument is a an optional boolean -which controls whether to fully canonicalise the name; it defaults to true. -.TP -\fBzipfs exists\fR \fIfilename\fR -. -Return 1 if the given filename exists in the mounted zipfs and 0 if it does not. -.TP -\fBzipfs find\fR \fIdirectoryName\fR -. -Recursively lists files including and below the directory \fIdirectoryName\fR. -The result list consists of relative path names starting from the given -directory. This command is also used by the \fBzipfs mkzip\fR and \fBzipfs -mkimg\fR commands. -.TP -\fBzipfs info\fR \fIfile\fR -. -Return information about the given \fIfile\fR in the mounted zipfs. The -information consists of: -.RS -.IP (1) -the name of the ZIP archive file that contains the file, -.IP (2) -the size of the file after decompressions, -.IP (3) -the compressed size of the file, and -.IP (4) -the offset of the compressed data in the ZIP archive file. -.PP -Note: querying the mount point gives the start of the zip data as the offset -in (4), which can be used to truncate the zip information from an executable. -.RE -.TP -\fBzipfs list\fR ?(\fB\-glob\fR|\fB\-regexp\fR)? ?\fIpattern\fR? -. -Return a list of all files in the mounted zipfs, or just those matching -\fIpattern\fR (optionally controlled by the option parameters). The order of -the names in the list is arbitrary. -.TP -\fBzipfs mount ?\fImountpoint\fR? ?\fIzipfile\fR? ?\fIpassword\fR? -. -The \fBzipfs mount\fR command mounts a ZIP archive file as a Tcl virtual -filesystem at \fImountpoint\fR. After this command executes, files contained -in \fIzipfile\fR will appear to Tcl to be regular files at the mount point. -.RS -.PP -With no \fIzipfile\fR, returns the zipfile mounted at \fImountpoint\fR. With -no \fImountpoint\fR, return all zipfile/mount pairs. If \fImountpoint\fR is -specified as an empty string, mount on file path. -.PP -\fBNB:\fR because the current working directory is a concept maintained by the -operating system, using \fBcd\fR into a mounted archive will only work in the -current process, and then not entirely consistently (e.g., if a shared library -uses direct access to the OS rather than through Tcl's filesystem API, it will -not see the current directory as being inside the mount and will not be able -to access the files inside the mount). -.RE -.TP -\fBzipfs root\fR -. -Returns a constant string which indicates the mount point for zipfs volumes -for the current platform. On Windows, this value is -.QW \fBzipfs:/\fR . -On Unix, this value is -.QW \fB//zipfs:/\fR . -.TP -\fBzipfs unmount \fImountpoint\fR -. -Unmounts a previously mounted ZIP archive mounted to \fImountpoint\fR. -.SS "ZIP CREATION COMMANDS" -This package also provides several commands to aid the creation of ZIP -archives as Tcl applications. -.TP -\fBzipfs mkzip\fR \fIoutfile indir\fR ?\fIstrip\fR? ?\fIpassword\fR? -. -Creates a ZIP archive file named \fIoutfile\fR from the contents of the input -directory \fIindir\fR (contained regular files only) with optional ZIP -password \fIpassword\fR. While processing the files below \fIindir\fR the -optional file name prefix given in \fIstrip\fR is stripped off the beginning -of the respective file name. When stripping, it is common to remove either -the whole source directory name or the name of its parent directory. -.RS -.PP -\fBCaution:\fR the choice of the \fIindir\fR parameter (less the optional -stripped prefix) determines the later root name of the archive's content. -.RE -.TP -\fBzipfs mkimg\fR \fIoutfile indir\fR ?\fIstrip\fR? ?\fIpassword\fR? ?\fIinfile\fR? -. -Creates an image (potentially a new executable file) similar to \fBzipfs -mkzip\fR; see that command for a description of most parameters to this -command, as they behave identically here. -.RS -.PP -If the \fIinfile\fR parameter is specified, this file is prepended in front of -the ZIP archive, otherwise the file returned by \fBinfo nameofexecutable\fR -(i.e., the executable file of the running process) is used. If the -\fIpassword\fR parameter is not empty, an obfuscated version of that password -(see \fBzipfs mkkey\fR) is placed between the image and ZIP chunks of the -output file and the contents of the ZIP chunk are protected with that -password. -.PP -If there is a file, \fBmain.tcl\fR, in the root directory of the resulting -archive and the image file that the archive is attached to is a \fBtclsh\fR -(or \fBwish\fR) instance (true by default, but depends on your configuration), -then the resulting image is an executable that will \fBsource\fR the script in -that \fBmain.tcl\fR after mounting the ZIP archive, and will \fBexit\fR once -that script has been executed. -.PP -\fBCaution:\fR highly experimental, not usable on Android, only partially -tested on Linux and Windows. -.RE -.TP -\fBzipfs mkkey\fR \fIpassword\fR -. -Given the clear text \fIpassword\fR argument, an obfuscated string version is -returned with the same format used in the \fBzipfs mkimg\fR command. -.TP -\fBzipfs lmkimg\fR \fIoutfile inlist\fR ?\fIpassword infile\fR? -. -This command is like \fBzipfs mkimg\fR, but instead of an input directory, -\fIinlist\fR must be a Tcl list where the odd elements are the names of files -to be copied into the archive in the image, and the even elements are their -respective names within that archive. -.TP -\fBzipfs lmkzip\fR \fIoutfile inlist\fR ?\fIpassword\fR? -. -This command is like \fBzipfs mkzip\fR, but instead of an input directory, -\fIinlist\fR must be a Tcl list where the odd elements are the names of files -to be copied into the archive, and the even elements are their respective -names within that archive. -.SH "EXAMPLES" -.PP -Mounting an ZIP archive as an application directory and running code out of it -before unmounting it again: -.PP -.CS -set zip myApp.zip -set base [file join [\fBzipfs root\fR] myApp] - -\fBzipfs mount\fR $base $zip -# $base now has the contents of myApp.zip - -source [file join $base app.tcl] -# use the contents, load libraries from it, etc... - -\fBzipfs unmount\fR $zip -.CE -.PP -Creating a ZIP archive, given that a directory exists containing the content -to put in the archive. Note that the source directory is given twice, in order -to strip the exterior directory name from each filename in the archive. -.PP -.CS -set sourceDirectory [file normalize myApp] -set targetZip myApp.zip - -\fBzipfs mkzip\fR $targetZip $sourceDirectory $sourceDirectory -.CE -.PP -Encryption can be applied to ZIP archives by providing a password when -building the ZIP and when mounting it. -.PP -.CS -set zip myApp.zip -set sourceDir [file normalize myApp] -set password "hunter2" -set base [file join [\fBzipfs root\fR] myApp] - -# Create with password -\fBzipfs mkzip\fR $targetZip $sourceDir $sourceDir $password - -# Mount with password -\fBzipfs mount\fR $base $zip $password -.CE -.PP -When creating an executable image with a password, the password is placed -within the executable in a shrouded form so that the application can read -files inside the embedded ZIP archive yet casual inspection cannot read it. -.PP -.CS -set appDir [file normalize myApp] -set img "myApp.bin" -set password "hunter2" - -# Create some simple content to define a basic application -file mkdir $appDir -set f [open $appDir/main.tcl] -puts $f { - puts "Hi. This is [info script]" -} -close $f - -# Create the executable -\fBzipfs mkimg\fR $img $appDir $appDir $password - -# Launch the executable, printing its output to stdout -exec $img >@stdout -# prints: \fIHi. This is //zipfs:/app/main.tcl\fR -.CE -.SH "SEE ALSO" -tclsh(1), file(n), zipfs(3), zlib(n) -.SH "KEYWORDS" -compress, filesystem, zip -'\" Local Variables: -'\" mode: nroff -'\" End: Index: doc/zlib.n ================================================================== --- doc/zlib.n +++ doc/zlib.n @@ -191,14 +191,22 @@ How hard to compress the data. Must be an integer from 0 (uncompressed) to 9 (maximally compressed). .TP \fB\-limit\fI readaheadLimit\fR . -The maximum number of bytes ahead to read when decompressing. This defaults to -1, which ensures that data is always decompressed correctly, but may be -increased to improve performance. This is more useful when the channel is -non-blocking. +The maximum number of bytes ahead to read when decompressing. +.RS +.PP +This option has become \fBirrelevant\fR. It was originally introduced +to prevent Tcl from reading beyond the end of a compressed stream in +multi-stream channels to ensure that the data after was left alone for +further reading, at the cost of speed. +.PP +Tcl now automatically returns any bytes it has read beyond the end of +a compressed stream back to the channel, making them appear as unread +to further readers. +.RE .PP Both compressing and decompressing channel transformations add extra configuration options that may be accessed through \fBchan configure\fR. The options are: .TP @@ -236,14 +244,12 @@ off the data stream. .TP \fB\-limit\fI readaheadLimit\fR . This read-write option is used by decompressing channels to control the -maximum number of bytes ahead to read from the underlying data source. This -defaults to 1, which ensures that data is always decompressed correctly, but -may be increased to improve performance. This is more useful when the channel -is non-blocking. +maximum number of bytes ahead to read from the underlying data source. See +above for more information. .RE .SS "STREAMING SUBCOMMAND" .TP \fBzlib stream\fI mode\fR ?\fIoptions\fR? . Index: generic/regc_lex.c ================================================================== --- generic/regc_lex.c +++ generic/regc_lex.c @@ -257,19 +257,19 @@ CHR(':'), CHR(']') }; #define PUNCT_CONN \ CHR('_'), \ - 0x203f /* UNDERTIE */, \ + 0x203F /* UNDERTIE */, \ 0x2040 /* CHARACTER TIE */,\ 0x2054 /* INVERTED UNDERTIE */,\ - 0xfe33 /* PRESENTATION FORM FOR VERTICAL LOW LINE */, \ - 0xfe34 /* PRESENTATION FORM FOR VERTICAL WAVY LOW LINE */, \ - 0xfe4d /* DASHED LOW LINE */, \ - 0xfe4e /* CENTRELINE LOW LINE */, \ - 0xfe4f /* WAVY LOW LINE */, \ - 0xff3f /* FULLWIDTH LOW LINE */ + 0xFE33 /* PRESENTATION FORM FOR VERTICAL LOW LINE */, \ + 0xFE34 /* PRESENTATION FORM FOR VERTICAL WAVY LOW LINE */, \ + 0xFE4D /* DASHED LOW LINE */, \ + 0xFE4E /* CENTRELINE LOW LINE */, \ + 0xFE4F /* WAVY LOW LINE */, \ + 0xFF3F /* FULLWIDTH LOW LINE */ static const chr backw[] = { /* \w */ CHR('['), CHR('['), CHR(':'), CHR('a'), CHR('l'), CHR('n'), CHR('u'), CHR('m'), CHR(':'), CHR(']'), PUNCT_CONN, CHR(']') @@ -455,11 +455,11 @@ } NOTE(REG_UNONPOSIX); if (ATEOS()) { FAILW(REG_EESCAPE); } - (void)lexescape(v); + (DISCARD)lexescape(v); switch (v->nexttype) { /* not all escapes okay here */ case PLAIN: return 1; break; case CCLASS: @@ -714,11 +714,11 @@ NOTE(REG_UBSALNUM); NOTE(REG_UUNSPEC); } RETV(PLAIN, *v->now++); } - (void)lexescape(v); + (DISCARD)lexescape(v); if (ISERR()) { FAILW(REG_EESCAPE); } if (v->nexttype == CCLASS) {/* fudge at lexical level */ switch (v->nextvalue) { @@ -903,22 +903,20 @@ * Oops, doesn't look like it's a backref after all... */ v->now = save; - /* - * And fall through into octal number. - */ + /* FALLTHRU */ case CHR('0'): NOTE(REG_UUNPORT); v->now--; /* put first digit back */ c = (uchr) lexdigits(v, 8, 1, 3); if (ISERR()) { FAILW(REG_EESCAPE); } - if (c > 0xff) { + if (c > 0xFF) { /* out of range, so we handled one digit too much */ v->now--; c >>= 3; } RETV(PLAIN, c); @@ -948,11 +946,11 @@ int d; const uchr ub = (uchr) base; n = 0; for (len = 0; len < maxlen && !ATEOS(); len++) { - if (n > 0x10fff) { + if (n > 0x10FFF) { /* Stop when continuing would otherwise overflow */ break; } c = *v->now++; switch (c) { @@ -1141,11 +1139,11 @@ } /* - newline - return the chr for a newline * This helps confine use of CHR to this source file. - ^ static chr newline(void); + ^ static chr newline(NOPARMS); */ static chr newline(void) { return CHR('\n'); Index: generic/regc_locale.c ================================================================== --- generic/regc_locale.c +++ generic/regc_locale.c @@ -132,153 +132,156 @@ /* * Unicode: alphabetic characters. */ static const crange alphaRangeTable[] = { - {0x41, 0x5a}, {0x61, 0x7a}, {0xc0, 0xd6}, {0xd8, 0xf6}, - {0xf8, 0x2c1}, {0x2c6, 0x2d1}, {0x2e0, 0x2e4}, {0x370, 0x374}, - {0x37a, 0x37d}, {0x388, 0x38a}, {0x38e, 0x3a1}, {0x3a3, 0x3f5}, - {0x3f7, 0x481}, {0x48a, 0x52f}, {0x531, 0x556}, {0x560, 0x588}, - {0x5d0, 0x5ea}, {0x5ef, 0x5f2}, {0x620, 0x64a}, {0x671, 0x6d3}, - {0x6fa, 0x6fc}, {0x712, 0x72f}, {0x74d, 0x7a5}, {0x7ca, 0x7ea}, - {0x800, 0x815}, {0x840, 0x858}, {0x860, 0x86a}, {0x8a0, 0x8b4}, - {0x8b6, 0x8bd}, {0x904, 0x939}, {0x958, 0x961}, {0x971, 0x980}, - {0x985, 0x98c}, {0x993, 0x9a8}, {0x9aa, 0x9b0}, {0x9b6, 0x9b9}, - {0x9df, 0x9e1}, {0xa05, 0xa0a}, {0xa13, 0xa28}, {0xa2a, 0xa30}, - {0xa59, 0xa5c}, {0xa72, 0xa74}, {0xa85, 0xa8d}, {0xa8f, 0xa91}, - {0xa93, 0xaa8}, {0xaaa, 0xab0}, {0xab5, 0xab9}, {0xb05, 0xb0c}, - {0xb13, 0xb28}, {0xb2a, 0xb30}, {0xb35, 0xb39}, {0xb5f, 0xb61}, - {0xb85, 0xb8a}, {0xb8e, 0xb90}, {0xb92, 0xb95}, {0xba8, 0xbaa}, - {0xbae, 0xbb9}, {0xc05, 0xc0c}, {0xc0e, 0xc10}, {0xc12, 0xc28}, - {0xc2a, 0xc39}, {0xc58, 0xc5a}, {0xc85, 0xc8c}, {0xc8e, 0xc90}, - {0xc92, 0xca8}, {0xcaa, 0xcb3}, {0xcb5, 0xcb9}, {0xd05, 0xd0c}, - {0xd0e, 0xd10}, {0xd12, 0xd3a}, {0xd54, 0xd56}, {0xd5f, 0xd61}, - {0xd7a, 0xd7f}, {0xd85, 0xd96}, {0xd9a, 0xdb1}, {0xdb3, 0xdbb}, - {0xdc0, 0xdc6}, {0xe01, 0xe30}, {0xe40, 0xe46}, {0xe86, 0xe8a}, - {0xe8c, 0xea3}, {0xea7, 0xeb0}, {0xec0, 0xec4}, {0xedc, 0xedf}, - {0xf40, 0xf47}, {0xf49, 0xf6c}, {0xf88, 0xf8c}, {0x1000, 0x102a}, - {0x1050, 0x1055}, {0x105a, 0x105d}, {0x106e, 0x1070}, {0x1075, 0x1081}, - {0x10a0, 0x10c5}, {0x10d0, 0x10fa}, {0x10fc, 0x1248}, {0x124a, 0x124d}, - {0x1250, 0x1256}, {0x125a, 0x125d}, {0x1260, 0x1288}, {0x128a, 0x128d}, - {0x1290, 0x12b0}, {0x12b2, 0x12b5}, {0x12b8, 0x12be}, {0x12c2, 0x12c5}, - {0x12c8, 0x12d6}, {0x12d8, 0x1310}, {0x1312, 0x1315}, {0x1318, 0x135a}, - {0x1380, 0x138f}, {0x13a0, 0x13f5}, {0x13f8, 0x13fd}, {0x1401, 0x166c}, - {0x166f, 0x167f}, {0x1681, 0x169a}, {0x16a0, 0x16ea}, {0x16f1, 0x16f8}, - {0x1700, 0x170c}, {0x170e, 0x1711}, {0x1720, 0x1731}, {0x1740, 0x1751}, - {0x1760, 0x176c}, {0x176e, 0x1770}, {0x1780, 0x17b3}, {0x1820, 0x1878}, - {0x1880, 0x1884}, {0x1887, 0x18a8}, {0x18b0, 0x18f5}, {0x1900, 0x191e}, - {0x1950, 0x196d}, {0x1970, 0x1974}, {0x1980, 0x19ab}, {0x19b0, 0x19c9}, - {0x1a00, 0x1a16}, {0x1a20, 0x1a54}, {0x1b05, 0x1b33}, {0x1b45, 0x1b4b}, - {0x1b83, 0x1ba0}, {0x1bba, 0x1be5}, {0x1c00, 0x1c23}, {0x1c4d, 0x1c4f}, - {0x1c5a, 0x1c7d}, {0x1c80, 0x1c88}, {0x1c90, 0x1cba}, {0x1cbd, 0x1cbf}, - {0x1ce9, 0x1cec}, {0x1cee, 0x1cf3}, {0x1d00, 0x1dbf}, {0x1e00, 0x1f15}, - {0x1f18, 0x1f1d}, {0x1f20, 0x1f45}, {0x1f48, 0x1f4d}, {0x1f50, 0x1f57}, - {0x1f5f, 0x1f7d}, {0x1f80, 0x1fb4}, {0x1fb6, 0x1fbc}, {0x1fc2, 0x1fc4}, - {0x1fc6, 0x1fcc}, {0x1fd0, 0x1fd3}, {0x1fd6, 0x1fdb}, {0x1fe0, 0x1fec}, - {0x1ff2, 0x1ff4}, {0x1ff6, 0x1ffc}, {0x2090, 0x209c}, {0x210a, 0x2113}, - {0x2119, 0x211d}, {0x212a, 0x212d}, {0x212f, 0x2139}, {0x213c, 0x213f}, - {0x2145, 0x2149}, {0x2c00, 0x2c2e}, {0x2c30, 0x2c5e}, {0x2c60, 0x2ce4}, - {0x2ceb, 0x2cee}, {0x2d00, 0x2d25}, {0x2d30, 0x2d67}, {0x2d80, 0x2d96}, - {0x2da0, 0x2da6}, {0x2da8, 0x2dae}, {0x2db0, 0x2db6}, {0x2db8, 0x2dbe}, - {0x2dc0, 0x2dc6}, {0x2dc8, 0x2dce}, {0x2dd0, 0x2dd6}, {0x2dd8, 0x2dde}, - {0x3031, 0x3035}, {0x3041, 0x3096}, {0x309d, 0x309f}, {0x30a1, 0x30fa}, - {0x30fc, 0x30ff}, {0x3105, 0x312f}, {0x3131, 0x318e}, {0x31a0, 0x31ba}, - {0x31f0, 0x31ff}, {0x3400, 0x4db5}, {0x4e00, 0x9fef}, {0xa000, 0xa48c}, - {0xa4d0, 0xa4fd}, {0xa500, 0xa60c}, {0xa610, 0xa61f}, {0xa640, 0xa66e}, - {0xa67f, 0xa69d}, {0xa6a0, 0xa6e5}, {0xa717, 0xa71f}, {0xa722, 0xa788}, - {0xa78b, 0xa7bf}, {0xa7c2, 0xa7c6}, {0xa7f7, 0xa801}, {0xa803, 0xa805}, - {0xa807, 0xa80a}, {0xa80c, 0xa822}, {0xa840, 0xa873}, {0xa882, 0xa8b3}, - {0xa8f2, 0xa8f7}, {0xa90a, 0xa925}, {0xa930, 0xa946}, {0xa960, 0xa97c}, - {0xa984, 0xa9b2}, {0xa9e0, 0xa9e4}, {0xa9e6, 0xa9ef}, {0xa9fa, 0xa9fe}, - {0xaa00, 0xaa28}, {0xaa40, 0xaa42}, {0xaa44, 0xaa4b}, {0xaa60, 0xaa76}, - {0xaa7e, 0xaaaf}, {0xaab9, 0xaabd}, {0xaadb, 0xaadd}, {0xaae0, 0xaaea}, - {0xaaf2, 0xaaf4}, {0xab01, 0xab06}, {0xab09, 0xab0e}, {0xab11, 0xab16}, - {0xab20, 0xab26}, {0xab28, 0xab2e}, {0xab30, 0xab5a}, {0xab5c, 0xab67}, - {0xab70, 0xabe2}, {0xac00, 0xd7a3}, {0xd7b0, 0xd7c6}, {0xd7cb, 0xd7fb}, - {0xf900, 0xfa6d}, {0xfa70, 0xfad9}, {0xfb00, 0xfb06}, {0xfb13, 0xfb17}, - {0xfb1f, 0xfb28}, {0xfb2a, 0xfb36}, {0xfb38, 0xfb3c}, {0xfb46, 0xfbb1}, - {0xfbd3, 0xfd3d}, {0xfd50, 0xfd8f}, {0xfd92, 0xfdc7}, {0xfdf0, 0xfdfb}, - {0xfe70, 0xfe74}, {0xfe76, 0xfefc}, {0xff21, 0xff3a}, {0xff41, 0xff5a}, - {0xff66, 0xffbe}, {0xffc2, 0xffc7}, {0xffca, 0xffcf}, {0xffd2, 0xffd7}, - {0xffda, 0xffdc} + {0x41, 0x5A}, {0x61, 0x7A}, {0xC0, 0xD6}, {0xD8, 0xF6}, + {0xF8, 0x2C1}, {0x2C6, 0x2D1}, {0x2E0, 0x2E4}, {0x370, 0x374}, + {0x37A, 0x37D}, {0x388, 0x38A}, {0x38E, 0x3A1}, {0x3A3, 0x3F5}, + {0x3F7, 0x481}, {0x48A, 0x52F}, {0x531, 0x556}, {0x560, 0x588}, + {0x5D0, 0x5EA}, {0x5EF, 0x5F2}, {0x620, 0x64A}, {0x671, 0x6D3}, + {0x6FA, 0x6FC}, {0x712, 0x72F}, {0x74D, 0x7A5}, {0x7CA, 0x7EA}, + {0x800, 0x815}, {0x840, 0x858}, {0x860, 0x86A}, {0x8A0, 0x8B4}, + {0x8B6, 0x8C7}, {0x904, 0x939}, {0x958, 0x961}, {0x971, 0x980}, + {0x985, 0x98C}, {0x993, 0x9A8}, {0x9AA, 0x9B0}, {0x9B6, 0x9B9}, + {0x9DF, 0x9E1}, {0xA05, 0xA0A}, {0xA13, 0xA28}, {0xA2A, 0xA30}, + {0xA59, 0xA5C}, {0xA72, 0xA74}, {0xA85, 0xA8D}, {0xA8F, 0xA91}, + {0xA93, 0xAA8}, {0xAAA, 0xAB0}, {0xAB5, 0xAB9}, {0xB05, 0xB0C}, + {0xB13, 0xB28}, {0xB2A, 0xB30}, {0xB35, 0xB39}, {0xB5F, 0xB61}, + {0xB85, 0xB8A}, {0xB8E, 0xB90}, {0xB92, 0xB95}, {0xBA8, 0xBAA}, + {0xBAE, 0xBB9}, {0xC05, 0xC0C}, {0xC0E, 0xC10}, {0xC12, 0xC28}, + {0xC2A, 0xC39}, {0xC58, 0xC5A}, {0xC85, 0xC8C}, {0xC8E, 0xC90}, + {0xC92, 0xCA8}, {0xCAA, 0xCB3}, {0xCB5, 0xCB9}, {0xD04, 0xD0C}, + {0xD0E, 0xD10}, {0xD12, 0xD3A}, {0xD54, 0xD56}, {0xD5F, 0xD61}, + {0xD7A, 0xD7F}, {0xD85, 0xD96}, {0xD9A, 0xDB1}, {0xDB3, 0xDBB}, + {0xDC0, 0xDC6}, {0xE01, 0xE30}, {0xE40, 0xE46}, {0xE86, 0xE8A}, + {0xE8C, 0xEA3}, {0xEA7, 0xEB0}, {0xEC0, 0xEC4}, {0xEDC, 0xEDF}, + {0xF40, 0xF47}, {0xF49, 0xF6C}, {0xF88, 0xF8C}, {0x1000, 0x102A}, + {0x1050, 0x1055}, {0x105A, 0x105D}, {0x106E, 0x1070}, {0x1075, 0x1081}, + {0x10A0, 0x10C5}, {0x10D0, 0x10FA}, {0x10FC, 0x1248}, {0x124A, 0x124D}, + {0x1250, 0x1256}, {0x125A, 0x125D}, {0x1260, 0x1288}, {0x128A, 0x128D}, + {0x1290, 0x12B0}, {0x12B2, 0x12B5}, {0x12B8, 0x12BE}, {0x12C2, 0x12C5}, + {0x12C8, 0x12D6}, {0x12D8, 0x1310}, {0x1312, 0x1315}, {0x1318, 0x135A}, + {0x1380, 0x138F}, {0x13A0, 0x13F5}, {0x13F8, 0x13FD}, {0x1401, 0x166C}, + {0x166F, 0x167F}, {0x1681, 0x169A}, {0x16A0, 0x16EA}, {0x16F1, 0x16F8}, + {0x1700, 0x170C}, {0x170E, 0x1711}, {0x1720, 0x1731}, {0x1740, 0x1751}, + {0x1760, 0x176C}, {0x176E, 0x1770}, {0x1780, 0x17B3}, {0x1820, 0x1878}, + {0x1880, 0x1884}, {0x1887, 0x18A8}, {0x18B0, 0x18F5}, {0x1900, 0x191E}, + {0x1950, 0x196D}, {0x1970, 0x1974}, {0x1980, 0x19AB}, {0x19B0, 0x19C9}, + {0x1A00, 0x1A16}, {0x1A20, 0x1A54}, {0x1B05, 0x1B33}, {0x1B45, 0x1B4B}, + {0x1B83, 0x1BA0}, {0x1BBA, 0x1BE5}, {0x1C00, 0x1C23}, {0x1C4D, 0x1C4F}, + {0x1C5A, 0x1C7D}, {0x1C80, 0x1C88}, {0x1C90, 0x1CBA}, {0x1CBD, 0x1CBF}, + {0x1CE9, 0x1CEC}, {0x1CEE, 0x1CF3}, {0x1D00, 0x1DBF}, {0x1E00, 0x1F15}, + {0x1F18, 0x1F1D}, {0x1F20, 0x1F45}, {0x1F48, 0x1F4D}, {0x1F50, 0x1F57}, + {0x1F5F, 0x1F7D}, {0x1F80, 0x1FB4}, {0x1FB6, 0x1FBC}, {0x1FC2, 0x1FC4}, + {0x1FC6, 0x1FCC}, {0x1FD0, 0x1FD3}, {0x1FD6, 0x1FDB}, {0x1FE0, 0x1FEC}, + {0x1FF2, 0x1FF4}, {0x1FF6, 0x1FFC}, {0x2090, 0x209C}, {0x210A, 0x2113}, + {0x2119, 0x211D}, {0x212A, 0x212D}, {0x212F, 0x2139}, {0x213C, 0x213F}, + {0x2145, 0x2149}, {0x2C00, 0x2C2E}, {0x2C30, 0x2C5E}, {0x2C60, 0x2CE4}, + {0x2CEB, 0x2CEE}, {0x2D00, 0x2D25}, {0x2D30, 0x2D67}, {0x2D80, 0x2D96}, + {0x2DA0, 0x2DA6}, {0x2DA8, 0x2DAE}, {0x2DB0, 0x2DB6}, {0x2DB8, 0x2DBE}, + {0x2DC0, 0x2DC6}, {0x2DC8, 0x2DCE}, {0x2DD0, 0x2DD6}, {0x2DD8, 0x2DDE}, + {0x3031, 0x3035}, {0x3041, 0x3096}, {0x309D, 0x309F}, {0x30A1, 0x30FA}, + {0x30FC, 0x30FF}, {0x3105, 0x312F}, {0x3131, 0x318E}, {0x31A0, 0x31BF}, + {0x31F0, 0x31FF}, {0x3400, 0x4DBF}, {0x4E00, 0x9FFC}, {0xA000, 0xA48C}, + {0xA4D0, 0xA4FD}, {0xA500, 0xA60C}, {0xA610, 0xA61F}, {0xA640, 0xA66E}, + {0xA67F, 0xA69D}, {0xA6A0, 0xA6E5}, {0xA717, 0xA71F}, {0xA722, 0xA788}, + {0xA78B, 0xA7BF}, {0xA7C2, 0xA7CA}, {0xA7F5, 0xA801}, {0xA803, 0xA805}, + {0xA807, 0xA80A}, {0xA80C, 0xA822}, {0xA840, 0xA873}, {0xA882, 0xA8B3}, + {0xA8F2, 0xA8F7}, {0xA90A, 0xA925}, {0xA930, 0xA946}, {0xA960, 0xA97C}, + {0xA984, 0xA9B2}, {0xA9E0, 0xA9E4}, {0xA9E6, 0xA9EF}, {0xA9FA, 0xA9FE}, + {0xAA00, 0xAA28}, {0xAA40, 0xAA42}, {0xAA44, 0xAA4B}, {0xAA60, 0xAA76}, + {0xAA7E, 0xAAAF}, {0xAAB9, 0xAABD}, {0xAADB, 0xAADD}, {0xAAE0, 0xAAEA}, + {0xAAF2, 0xAAF4}, {0xAB01, 0xAB06}, {0xAB09, 0xAB0E}, {0xAB11, 0xAB16}, + {0xAB20, 0xAB26}, {0xAB28, 0xAB2E}, {0xAB30, 0xAB5A}, {0xAB5C, 0xAB69}, + {0xAB70, 0xABE2}, {0xAC00, 0xD7A3}, {0xD7B0, 0xD7C6}, {0xD7CB, 0xD7FB}, + {0xF900, 0xFA6D}, {0xFA70, 0xFAD9}, {0xFB00, 0xFB06}, {0xFB13, 0xFB17}, + {0xFB1F, 0xFB28}, {0xFB2A, 0xFB36}, {0xFB38, 0xFB3C}, {0xFB46, 0xFBB1}, + {0xFBD3, 0xFD3D}, {0xFD50, 0xFD8F}, {0xFD92, 0xFDC7}, {0xFDF0, 0xFDFB}, + {0xFE70, 0xFE74}, {0xFE76, 0xFEFC}, {0xFF21, 0xFF3A}, {0xFF41, 0xFF5A}, + {0xFF66, 0xFFBE}, {0xFFC2, 0xFFC7}, {0xFFCA, 0xFFCF}, {0xFFD2, 0xFFD7}, + {0xFFDA, 0xFFDC} #if CHRBITS > 16 - ,{0x10000, 0x1000b}, {0x1000d, 0x10026}, {0x10028, 0x1003a}, {0x1003f, 0x1004d}, - {0x10050, 0x1005d}, {0x10080, 0x100fa}, {0x10280, 0x1029c}, {0x102a0, 0x102d0}, - {0x10300, 0x1031f}, {0x1032d, 0x10340}, {0x10342, 0x10349}, {0x10350, 0x10375}, - {0x10380, 0x1039d}, {0x103a0, 0x103c3}, {0x103c8, 0x103cf}, {0x10400, 0x1049d}, - {0x104b0, 0x104d3}, {0x104d8, 0x104fb}, {0x10500, 0x10527}, {0x10530, 0x10563}, + ,{0x10000, 0x1000B}, {0x1000D, 0x10026}, {0x10028, 0x1003A}, {0x1003F, 0x1004D}, + {0x10050, 0x1005D}, {0x10080, 0x100FA}, {0x10280, 0x1029C}, {0x102A0, 0x102D0}, + {0x10300, 0x1031F}, {0x1032D, 0x10340}, {0x10342, 0x10349}, {0x10350, 0x10375}, + {0x10380, 0x1039D}, {0x103A0, 0x103C3}, {0x103C8, 0x103CF}, {0x10400, 0x1049D}, + {0x104B0, 0x104D3}, {0x104D8, 0x104FB}, {0x10500, 0x10527}, {0x10530, 0x10563}, {0x10600, 0x10736}, {0x10740, 0x10755}, {0x10760, 0x10767}, {0x10800, 0x10805}, - {0x1080a, 0x10835}, {0x1083f, 0x10855}, {0x10860, 0x10876}, {0x10880, 0x1089e}, - {0x108e0, 0x108f2}, {0x10900, 0x10915}, {0x10920, 0x10939}, {0x10980, 0x109b7}, - {0x10a10, 0x10a13}, {0x10a15, 0x10a17}, {0x10a19, 0x10a35}, {0x10a60, 0x10a7c}, - {0x10a80, 0x10a9c}, {0x10ac0, 0x10ac7}, {0x10ac9, 0x10ae4}, {0x10b00, 0x10b35}, - {0x10b40, 0x10b55}, {0x10b60, 0x10b72}, {0x10b80, 0x10b91}, {0x10c00, 0x10c48}, - {0x10c80, 0x10cb2}, {0x10cc0, 0x10cf2}, {0x10d00, 0x10d23}, {0x10f00, 0x10f1c}, - {0x10f30, 0x10f45}, {0x10fe0, 0x10ff6}, {0x11003, 0x11037}, {0x11083, 0x110af}, - {0x110d0, 0x110e8}, {0x11103, 0x11126}, {0x11150, 0x11172}, {0x11183, 0x111b2}, - {0x111c1, 0x111c4}, {0x11200, 0x11211}, {0x11213, 0x1122b}, {0x11280, 0x11286}, - {0x1128a, 0x1128d}, {0x1128f, 0x1129d}, {0x1129f, 0x112a8}, {0x112b0, 0x112de}, - {0x11305, 0x1130c}, {0x11313, 0x11328}, {0x1132a, 0x11330}, {0x11335, 0x11339}, - {0x1135d, 0x11361}, {0x11400, 0x11434}, {0x11447, 0x1144a}, {0x11480, 0x114af}, - {0x11580, 0x115ae}, {0x115d8, 0x115db}, {0x11600, 0x1162f}, {0x11680, 0x116aa}, - {0x11700, 0x1171a}, {0x11800, 0x1182b}, {0x118a0, 0x118df}, {0x119a0, 0x119a7}, - {0x119aa, 0x119d0}, {0x11a0b, 0x11a32}, {0x11a5c, 0x11a89}, {0x11ac0, 0x11af8}, - {0x11c00, 0x11c08}, {0x11c0a, 0x11c2e}, {0x11c72, 0x11c8f}, {0x11d00, 0x11d06}, - {0x11d0b, 0x11d30}, {0x11d60, 0x11d65}, {0x11d6a, 0x11d89}, {0x11ee0, 0x11ef2}, - {0x12000, 0x12399}, {0x12480, 0x12543}, {0x13000, 0x1342e}, {0x14400, 0x14646}, - {0x16800, 0x16a38}, {0x16a40, 0x16a5e}, {0x16ad0, 0x16aed}, {0x16b00, 0x16b2f}, - {0x16b40, 0x16b43}, {0x16b63, 0x16b77}, {0x16b7d, 0x16b8f}, {0x16e40, 0x16e7f}, - {0x16f00, 0x16f4a}, {0x16f93, 0x16f9f}, {0x17000, 0x187f7}, {0x18800, 0x18af2}, - {0x1b000, 0x1b11e}, {0x1b150, 0x1b152}, {0x1b164, 0x1b167}, {0x1b170, 0x1b2fb}, - {0x1bc00, 0x1bc6a}, {0x1bc70, 0x1bc7c}, {0x1bc80, 0x1bc88}, {0x1bc90, 0x1bc99}, - {0x1d400, 0x1d454}, {0x1d456, 0x1d49c}, {0x1d4a9, 0x1d4ac}, {0x1d4ae, 0x1d4b9}, - {0x1d4bd, 0x1d4c3}, {0x1d4c5, 0x1d505}, {0x1d507, 0x1d50a}, {0x1d50d, 0x1d514}, - {0x1d516, 0x1d51c}, {0x1d51e, 0x1d539}, {0x1d53b, 0x1d53e}, {0x1d540, 0x1d544}, - {0x1d54a, 0x1d550}, {0x1d552, 0x1d6a5}, {0x1d6a8, 0x1d6c0}, {0x1d6c2, 0x1d6da}, - {0x1d6dc, 0x1d6fa}, {0x1d6fc, 0x1d714}, {0x1d716, 0x1d734}, {0x1d736, 0x1d74e}, - {0x1d750, 0x1d76e}, {0x1d770, 0x1d788}, {0x1d78a, 0x1d7a8}, {0x1d7aa, 0x1d7c2}, - {0x1d7c4, 0x1d7cb}, {0x1e100, 0x1e12c}, {0x1e137, 0x1e13d}, {0x1e2c0, 0x1e2eb}, - {0x1e800, 0x1e8c4}, {0x1e900, 0x1e943}, {0x1ee00, 0x1ee03}, {0x1ee05, 0x1ee1f}, - {0x1ee29, 0x1ee32}, {0x1ee34, 0x1ee37}, {0x1ee4d, 0x1ee4f}, {0x1ee67, 0x1ee6a}, - {0x1ee6c, 0x1ee72}, {0x1ee74, 0x1ee77}, {0x1ee79, 0x1ee7c}, {0x1ee80, 0x1ee89}, - {0x1ee8b, 0x1ee9b}, {0x1eea1, 0x1eea3}, {0x1eea5, 0x1eea9}, {0x1eeab, 0x1eebb}, - {0x20000, 0x2a6d6}, {0x2a700, 0x2b734}, {0x2b740, 0x2b81d}, {0x2b820, 0x2cea1}, - {0x2ceb0, 0x2ebe0}, {0x2f800, 0x2fa1d} + {0x1080A, 0x10835}, {0x1083F, 0x10855}, {0x10860, 0x10876}, {0x10880, 0x1089E}, + {0x108E0, 0x108F2}, {0x10900, 0x10915}, {0x10920, 0x10939}, {0x10980, 0x109B7}, + {0x10A10, 0x10A13}, {0x10A15, 0x10A17}, {0x10A19, 0x10A35}, {0x10A60, 0x10A7C}, + {0x10A80, 0x10A9C}, {0x10AC0, 0x10AC7}, {0x10AC9, 0x10AE4}, {0x10B00, 0x10B35}, + {0x10B40, 0x10B55}, {0x10B60, 0x10B72}, {0x10B80, 0x10B91}, {0x10C00, 0x10C48}, + {0x10C80, 0x10CB2}, {0x10CC0, 0x10CF2}, {0x10D00, 0x10D23}, {0x10E80, 0x10EA9}, + {0x10F00, 0x10F1C}, {0x10F30, 0x10F45}, {0x10FB0, 0x10FC4}, {0x10FE0, 0x10FF6}, + {0x11003, 0x11037}, {0x11083, 0x110AF}, {0x110D0, 0x110E8}, {0x11103, 0x11126}, + {0x11150, 0x11172}, {0x11183, 0x111B2}, {0x111C1, 0x111C4}, {0x11200, 0x11211}, + {0x11213, 0x1122B}, {0x11280, 0x11286}, {0x1128A, 0x1128D}, {0x1128F, 0x1129D}, + {0x1129F, 0x112A8}, {0x112B0, 0x112DE}, {0x11305, 0x1130C}, {0x11313, 0x11328}, + {0x1132A, 0x11330}, {0x11335, 0x11339}, {0x1135D, 0x11361}, {0x11400, 0x11434}, + {0x11447, 0x1144A}, {0x1145F, 0x11461}, {0x11480, 0x114AF}, {0x11580, 0x115AE}, + {0x115D8, 0x115DB}, {0x11600, 0x1162F}, {0x11680, 0x116AA}, {0x11700, 0x1171A}, + {0x11800, 0x1182B}, {0x118A0, 0x118DF}, {0x118FF, 0x11906}, {0x1190C, 0x11913}, + {0x11918, 0x1192F}, {0x119A0, 0x119A7}, {0x119AA, 0x119D0}, {0x11A0B, 0x11A32}, + {0x11A5C, 0x11A89}, {0x11AC0, 0x11AF8}, {0x11C00, 0x11C08}, {0x11C0A, 0x11C2E}, + {0x11C72, 0x11C8F}, {0x11D00, 0x11D06}, {0x11D0B, 0x11D30}, {0x11D60, 0x11D65}, + {0x11D6A, 0x11D89}, {0x11EE0, 0x11EF2}, {0x12000, 0x12399}, {0x12480, 0x12543}, + {0x13000, 0x1342E}, {0x14400, 0x14646}, {0x16800, 0x16A38}, {0x16A40, 0x16A5E}, + {0x16AD0, 0x16AED}, {0x16B00, 0x16B2F}, {0x16B40, 0x16B43}, {0x16B63, 0x16B77}, + {0x16B7D, 0x16B8F}, {0x16E40, 0x16E7F}, {0x16F00, 0x16F4A}, {0x16F93, 0x16F9F}, + {0x17000, 0x187F7}, {0x18800, 0x18CD5}, {0x18D00, 0x18D08}, {0x1B000, 0x1B11E}, + {0x1B150, 0x1B152}, {0x1B164, 0x1B167}, {0x1B170, 0x1B2FB}, {0x1BC00, 0x1BC6A}, + {0x1BC70, 0x1BC7C}, {0x1BC80, 0x1BC88}, {0x1BC90, 0x1BC99}, {0x1D400, 0x1D454}, + {0x1D456, 0x1D49C}, {0x1D4A9, 0x1D4AC}, {0x1D4AE, 0x1D4B9}, {0x1D4BD, 0x1D4C3}, + {0x1D4C5, 0x1D505}, {0x1D507, 0x1D50A}, {0x1D50D, 0x1D514}, {0x1D516, 0x1D51C}, + {0x1D51E, 0x1D539}, {0x1D53B, 0x1D53E}, {0x1D540, 0x1D544}, {0x1D54A, 0x1D550}, + {0x1D552, 0x1D6A5}, {0x1D6A8, 0x1D6C0}, {0x1D6C2, 0x1D6DA}, {0x1D6DC, 0x1D6FA}, + {0x1D6FC, 0x1D714}, {0x1D716, 0x1D734}, {0x1D736, 0x1D74E}, {0x1D750, 0x1D76E}, + {0x1D770, 0x1D788}, {0x1D78A, 0x1D7A8}, {0x1D7AA, 0x1D7C2}, {0x1D7C4, 0x1D7CB}, + {0x1E100, 0x1E12C}, {0x1E137, 0x1E13D}, {0x1E2C0, 0x1E2EB}, {0x1E800, 0x1E8C4}, + {0x1E900, 0x1E943}, {0x1EE00, 0x1EE03}, {0x1EE05, 0x1EE1F}, {0x1EE29, 0x1EE32}, + {0x1EE34, 0x1EE37}, {0x1EE4D, 0x1EE4F}, {0x1EE67, 0x1EE6A}, {0x1EE6C, 0x1EE72}, + {0x1EE74, 0x1EE77}, {0x1EE79, 0x1EE7C}, {0x1EE80, 0x1EE89}, {0x1EE8B, 0x1EE9B}, + {0x1EEA1, 0x1EEA3}, {0x1EEA5, 0x1EEA9}, {0x1EEAB, 0x1EEBB}, {0x20000, 0x2A6DD}, + {0x2A700, 0x2B734}, {0x2B740, 0x2B81D}, {0x2B820, 0x2CEA1}, {0x2CEB0, 0x2EBE0}, + {0x2F800, 0x2FA1D}, {0x30000, 0x3134A} #endif }; #define NUM_ALPHA_RANGE (sizeof(alphaRangeTable)/sizeof(crange)) static const chr alphaCharTable[] = { - 0xaa, 0xb5, 0xba, 0x2ec, 0x2ee, 0x376, 0x377, 0x37f, 0x386, - 0x38c, 0x559, 0x66e, 0x66f, 0x6d5, 0x6e5, 0x6e6, 0x6ee, 0x6ef, - 0x6ff, 0x710, 0x7b1, 0x7f4, 0x7f5, 0x7fa, 0x81a, 0x824, 0x828, - 0x93d, 0x950, 0x98f, 0x990, 0x9b2, 0x9bd, 0x9ce, 0x9dc, 0x9dd, - 0x9f0, 0x9f1, 0x9fc, 0xa0f, 0xa10, 0xa32, 0xa33, 0xa35, 0xa36, - 0xa38, 0xa39, 0xa5e, 0xab2, 0xab3, 0xabd, 0xad0, 0xae0, 0xae1, - 0xaf9, 0xb0f, 0xb10, 0xb32, 0xb33, 0xb3d, 0xb5c, 0xb5d, 0xb71, - 0xb83, 0xb99, 0xb9a, 0xb9c, 0xb9e, 0xb9f, 0xba3, 0xba4, 0xbd0, - 0xc3d, 0xc60, 0xc61, 0xc80, 0xcbd, 0xcde, 0xce0, 0xce1, 0xcf1, - 0xcf2, 0xd3d, 0xd4e, 0xdbd, 0xe32, 0xe33, 0xe81, 0xe82, 0xe84, - 0xea5, 0xeb2, 0xeb3, 0xebd, 0xec6, 0xf00, 0x103f, 0x1061, 0x1065, - 0x1066, 0x108e, 0x10c7, 0x10cd, 0x1258, 0x12c0, 0x17d7, 0x17dc, 0x18aa, - 0x1aa7, 0x1bae, 0x1baf, 0x1cf5, 0x1cf6, 0x1cfa, 0x1f59, 0x1f5b, 0x1f5d, - 0x1fbe, 0x2071, 0x207f, 0x2102, 0x2107, 0x2115, 0x2124, 0x2126, 0x2128, - 0x214e, 0x2183, 0x2184, 0x2cf2, 0x2cf3, 0x2d27, 0x2d2d, 0x2d6f, 0x2e2f, - 0x3005, 0x3006, 0x303b, 0x303c, 0xa62a, 0xa62b, 0xa8fb, 0xa8fd, 0xa8fe, - 0xa9cf, 0xaa7a, 0xaab1, 0xaab5, 0xaab6, 0xaac0, 0xaac2, 0xfb1d, 0xfb3e, - 0xfb40, 0xfb41, 0xfb43, 0xfb44 + 0xAA, 0xB5, 0xBA, 0x2EC, 0x2EE, 0x376, 0x377, 0x37F, 0x386, + 0x38C, 0x559, 0x66E, 0x66F, 0x6D5, 0x6E5, 0x6E6, 0x6EE, 0x6EF, + 0x6FF, 0x710, 0x7B1, 0x7F4, 0x7F5, 0x7FA, 0x81A, 0x824, 0x828, + 0x93D, 0x950, 0x98F, 0x990, 0x9B2, 0x9BD, 0x9CE, 0x9DC, 0x9DD, + 0x9F0, 0x9F1, 0x9FC, 0xA0F, 0xA10, 0xA32, 0xA33, 0xA35, 0xA36, + 0xA38, 0xA39, 0xA5E, 0xAB2, 0xAB3, 0xABD, 0xAD0, 0xAE0, 0xAE1, + 0xAF9, 0xB0F, 0xB10, 0xB32, 0xB33, 0xB3D, 0xB5C, 0xB5D, 0xB71, + 0xB83, 0xB99, 0xB9A, 0xB9C, 0xB9E, 0xB9F, 0xBA3, 0xBA4, 0xBD0, + 0xC3D, 0xC60, 0xC61, 0xC80, 0xCBD, 0xCDE, 0xCE0, 0xCE1, 0xCF1, + 0xCF2, 0xD3D, 0xD4E, 0xDBD, 0xE32, 0xE33, 0xE81, 0xE82, 0xE84, + 0xEA5, 0xEB2, 0xEB3, 0xEBD, 0xEC6, 0xF00, 0x103F, 0x1061, 0x1065, + 0x1066, 0x108E, 0x10C7, 0x10CD, 0x1258, 0x12C0, 0x17D7, 0x17DC, 0x18AA, + 0x1AA7, 0x1BAE, 0x1BAF, 0x1CF5, 0x1CF6, 0x1CFA, 0x1F59, 0x1F5B, 0x1F5D, + 0x1FBE, 0x2071, 0x207F, 0x2102, 0x2107, 0x2115, 0x2124, 0x2126, 0x2128, + 0x214E, 0x2183, 0x2184, 0x2CF2, 0x2CF3, 0x2D27, 0x2D2D, 0x2D6F, 0x2E2F, + 0x3005, 0x3006, 0x303B, 0x303C, 0xA62A, 0xA62B, 0xA8FB, 0xA8FD, 0xA8FE, + 0xA9CF, 0xAA7A, 0xAAB1, 0xAAB5, 0xAAB6, 0xAAC0, 0xAAC2, 0xFB1D, 0xFB3E, + 0xFB40, 0xFB41, 0xFB43, 0xFB44 #if CHRBITS > 16 - ,0x1003c, 0x1003d, 0x10808, 0x10837, 0x10838, 0x1083c, 0x108f4, 0x108f5, 0x109be, - 0x109bf, 0x10a00, 0x10f27, 0x11144, 0x11176, 0x111da, 0x111dc, 0x11288, 0x1130f, - 0x11310, 0x11332, 0x11333, 0x1133d, 0x11350, 0x1145f, 0x114c4, 0x114c5, 0x114c7, - 0x11644, 0x116b8, 0x118ff, 0x119e1, 0x119e3, 0x11a00, 0x11a3a, 0x11a50, 0x11a9d, - 0x11c40, 0x11d08, 0x11d09, 0x11d46, 0x11d67, 0x11d68, 0x11d98, 0x16f50, 0x16fe0, - 0x16fe1, 0x16fe3, 0x1d49e, 0x1d49f, 0x1d4a2, 0x1d4a5, 0x1d4a6, 0x1d4bb, 0x1d546, - 0x1e14e, 0x1e94b, 0x1ee21, 0x1ee22, 0x1ee24, 0x1ee27, 0x1ee39, 0x1ee3b, 0x1ee42, - 0x1ee47, 0x1ee49, 0x1ee4b, 0x1ee51, 0x1ee52, 0x1ee54, 0x1ee57, 0x1ee59, 0x1ee5b, - 0x1ee5d, 0x1ee5f, 0x1ee61, 0x1ee62, 0x1ee64, 0x1ee7e + ,0x1003C, 0x1003D, 0x10808, 0x10837, 0x10838, 0x1083C, 0x108F4, 0x108F5, 0x109BE, + 0x109BF, 0x10A00, 0x10EB0, 0x10EB1, 0x10F27, 0x11144, 0x11147, 0x11176, 0x111DA, + 0x111DC, 0x11288, 0x1130F, 0x11310, 0x11332, 0x11333, 0x1133D, 0x11350, 0x114C4, + 0x114C5, 0x114C7, 0x11644, 0x116B8, 0x11909, 0x11915, 0x11916, 0x1193F, 0x11941, + 0x119E1, 0x119E3, 0x11A00, 0x11A3A, 0x11A50, 0x11A9D, 0x11C40, 0x11D08, 0x11D09, + 0x11D46, 0x11D67, 0x11D68, 0x11D98, 0x11FB0, 0x16F50, 0x16FE0, 0x16FE1, 0x16FE3, + 0x1D49E, 0x1D49F, 0x1D4A2, 0x1D4A5, 0x1D4A6, 0x1D4BB, 0x1D546, 0x1E14E, 0x1E94B, + 0x1EE21, 0x1EE22, 0x1EE24, 0x1EE27, 0x1EE39, 0x1EE3B, 0x1EE42, 0x1EE47, 0x1EE49, + 0x1EE4B, 0x1EE51, 0x1EE52, 0x1EE54, 0x1EE57, 0x1EE59, 0x1EE5B, 0x1EE5D, 0x1EE5F, + 0x1EE61, 0x1EE62, 0x1EE64, 0x1EE7E #endif }; #define NUM_ALPHA_CHAR (sizeof(alphaCharTable)/sizeof(chr)) @@ -285,25 +288,25 @@ /* * Unicode: control characters. */ static const crange controlRangeTable[] = { - {0x0, 0x1f}, {0x7f, 0x9f}, {0x600, 0x605}, {0x200b, 0x200f}, - {0x202a, 0x202e}, {0x2060, 0x2064}, {0x2066, 0x206f}, {0xe000, 0xf8ff}, - {0xfff9, 0xfffb} + {0x0, 0x1F}, {0x7F, 0x9F}, {0x600, 0x605}, {0x200B, 0x200F}, + {0x202A, 0x202E}, {0x2060, 0x2064}, {0x2066, 0x206F}, {0xE000, 0xF8FF}, + {0xFFF9, 0xFFFB} #if CHRBITS > 16 - ,{0x13430, 0x13438}, {0x1bca0, 0x1bca3}, {0x1d173, 0x1d17a}, {0xe0020, 0xe007f}, - {0xf0000, 0xffffd}, {0x100000, 0x10fffd} + ,{0x13430, 0x13438}, {0x1BCA0, 0x1BCA3}, {0x1D173, 0x1D17A}, {0xE0020, 0xE007F}, + {0xF0000, 0xFFFFD}, {0x100000, 0x10FFFD} #endif }; #define NUM_CONTROL_RANGE (sizeof(controlRangeTable)/sizeof(crange)) static const chr controlCharTable[] = { - 0xad, 0x61c, 0x6dd, 0x70f, 0x8e2, 0x180e, 0xfeff + 0xAD, 0x61C, 0x6DD, 0x70F, 0x8E2, 0x180E, 0xFEFF #if CHRBITS > 16 - ,0x110bd, 0x110cd, 0xe0001 + ,0x110BD, 0x110CD, 0xE0001 #endif }; #define NUM_CONTROL_CHAR (sizeof(controlCharTable)/sizeof(chr)) @@ -310,27 +313,27 @@ /* * Unicode: decimal digit characters. */ static const crange digitRangeTable[] = { - {0x30, 0x39}, {0x660, 0x669}, {0x6f0, 0x6f9}, {0x7c0, 0x7c9}, - {0x966, 0x96f}, {0x9e6, 0x9ef}, {0xa66, 0xa6f}, {0xae6, 0xaef}, - {0xb66, 0xb6f}, {0xbe6, 0xbef}, {0xc66, 0xc6f}, {0xce6, 0xcef}, - {0xd66, 0xd6f}, {0xde6, 0xdef}, {0xe50, 0xe59}, {0xed0, 0xed9}, - {0xf20, 0xf29}, {0x1040, 0x1049}, {0x1090, 0x1099}, {0x17e0, 0x17e9}, - {0x1810, 0x1819}, {0x1946, 0x194f}, {0x19d0, 0x19d9}, {0x1a80, 0x1a89}, - {0x1a90, 0x1a99}, {0x1b50, 0x1b59}, {0x1bb0, 0x1bb9}, {0x1c40, 0x1c49}, - {0x1c50, 0x1c59}, {0xa620, 0xa629}, {0xa8d0, 0xa8d9}, {0xa900, 0xa909}, - {0xa9d0, 0xa9d9}, {0xa9f0, 0xa9f9}, {0xaa50, 0xaa59}, {0xabf0, 0xabf9}, - {0xff10, 0xff19} + {0x30, 0x39}, {0x660, 0x669}, {0x6F0, 0x6F9}, {0x7C0, 0x7C9}, + {0x966, 0x96F}, {0x9E6, 0x9EF}, {0xA66, 0xA6F}, {0xAE6, 0xAEF}, + {0xB66, 0xB6F}, {0xBE6, 0xBEF}, {0xC66, 0xC6F}, {0xCE6, 0xCEF}, + {0xD66, 0xD6F}, {0xDE6, 0xDEF}, {0xE50, 0xE59}, {0xED0, 0xED9}, + {0xF20, 0xF29}, {0x1040, 0x1049}, {0x1090, 0x1099}, {0x17E0, 0x17E9}, + {0x1810, 0x1819}, {0x1946, 0x194F}, {0x19D0, 0x19D9}, {0x1A80, 0x1A89}, + {0x1A90, 0x1A99}, {0x1B50, 0x1B59}, {0x1BB0, 0x1BB9}, {0x1C40, 0x1C49}, + {0x1C50, 0x1C59}, {0xA620, 0xA629}, {0xA8D0, 0xA8D9}, {0xA900, 0xA909}, + {0xA9D0, 0xA9D9}, {0xA9F0, 0xA9F9}, {0xAA50, 0xAA59}, {0xABF0, 0xABF9}, + {0xFF10, 0xFF19} #if CHRBITS > 16 - ,{0x104a0, 0x104a9}, {0x10d30, 0x10d39}, {0x11066, 0x1106f}, {0x110f0, 0x110f9}, - {0x11136, 0x1113f}, {0x111d0, 0x111d9}, {0x112f0, 0x112f9}, {0x11450, 0x11459}, - {0x114d0, 0x114d9}, {0x11650, 0x11659}, {0x116c0, 0x116c9}, {0x11730, 0x11739}, - {0x118e0, 0x118e9}, {0x11c50, 0x11c59}, {0x11d50, 0x11d59}, {0x11da0, 0x11da9}, - {0x16a60, 0x16a69}, {0x16b50, 0x16b59}, {0x1d7ce, 0x1d7ff}, {0x1e140, 0x1e149}, - {0x1e2f0, 0x1e2f9}, {0x1e950, 0x1e959} + ,{0x104A0, 0x104A9}, {0x10D30, 0x10D39}, {0x11066, 0x1106F}, {0x110F0, 0x110F9}, + {0x11136, 0x1113F}, {0x111D0, 0x111D9}, {0x112F0, 0x112F9}, {0x11450, 0x11459}, + {0x114D0, 0x114D9}, {0x11650, 0x11659}, {0x116C0, 0x116C9}, {0x11730, 0x11739}, + {0x118E0, 0x118E9}, {0x11950, 0x11959}, {0x11C50, 0x11C59}, {0x11D50, 0x11D59}, + {0x11DA0, 0x11DA9}, {0x16A60, 0x16A69}, {0x16B50, 0x16B59}, {0x1D7CE, 0x1D7FF}, + {0x1E140, 0x1E149}, {0x1E2F0, 0x1E2F9}, {0x1E950, 0x1E959}, {0x1FBF0, 0x1FBF9} #endif }; #define NUM_DIGIT_RANGE (sizeof(digitRangeTable)/sizeof(crange)) @@ -341,56 +344,56 @@ /* * Unicode: punctuation characters. */ static const crange punctRangeTable[] = { - {0x21, 0x23}, {0x25, 0x2a}, {0x2c, 0x2f}, {0x5b, 0x5d}, - {0x55a, 0x55f}, {0x66a, 0x66d}, {0x700, 0x70d}, {0x7f7, 0x7f9}, - {0x830, 0x83e}, {0xf04, 0xf12}, {0xf3a, 0xf3d}, {0xfd0, 0xfd4}, - {0x104a, 0x104f}, {0x1360, 0x1368}, {0x16eb, 0x16ed}, {0x17d4, 0x17d6}, - {0x17d8, 0x17da}, {0x1800, 0x180a}, {0x1aa0, 0x1aa6}, {0x1aa8, 0x1aad}, - {0x1b5a, 0x1b60}, {0x1bfc, 0x1bff}, {0x1c3b, 0x1c3f}, {0x1cc0, 0x1cc7}, - {0x2010, 0x2027}, {0x2030, 0x2043}, {0x2045, 0x2051}, {0x2053, 0x205e}, - {0x2308, 0x230b}, {0x2768, 0x2775}, {0x27e6, 0x27ef}, {0x2983, 0x2998}, - {0x29d8, 0x29db}, {0x2cf9, 0x2cfc}, {0x2e00, 0x2e2e}, {0x2e30, 0x2e4f}, - {0x3001, 0x3003}, {0x3008, 0x3011}, {0x3014, 0x301f}, {0xa60d, 0xa60f}, - {0xa6f2, 0xa6f7}, {0xa874, 0xa877}, {0xa8f8, 0xa8fa}, {0xa9c1, 0xa9cd}, - {0xaa5c, 0xaa5f}, {0xfe10, 0xfe19}, {0xfe30, 0xfe52}, {0xfe54, 0xfe61}, - {0xff01, 0xff03}, {0xff05, 0xff0a}, {0xff0c, 0xff0f}, {0xff3b, 0xff3d}, - {0xff5f, 0xff65} + {0x21, 0x23}, {0x25, 0x2A}, {0x2C, 0x2F}, {0x5B, 0x5D}, + {0x55A, 0x55F}, {0x66A, 0x66D}, {0x700, 0x70D}, {0x7F7, 0x7F9}, + {0x830, 0x83E}, {0xF04, 0xF12}, {0xF3A, 0xF3D}, {0xFD0, 0xFD4}, + {0x104A, 0x104F}, {0x1360, 0x1368}, {0x16EB, 0x16ED}, {0x17D4, 0x17D6}, + {0x17D8, 0x17DA}, {0x1800, 0x180A}, {0x1AA0, 0x1AA6}, {0x1AA8, 0x1AAD}, + {0x1B5A, 0x1B60}, {0x1BFC, 0x1BFF}, {0x1C3B, 0x1C3F}, {0x1CC0, 0x1CC7}, + {0x2010, 0x2027}, {0x2030, 0x2043}, {0x2045, 0x2051}, {0x2053, 0x205E}, + {0x2308, 0x230B}, {0x2768, 0x2775}, {0x27E6, 0x27EF}, {0x2983, 0x2998}, + {0x29D8, 0x29DB}, {0x2CF9, 0x2CFC}, {0x2E00, 0x2E2E}, {0x2E30, 0x2E4F}, + {0x3001, 0x3003}, {0x3008, 0x3011}, {0x3014, 0x301F}, {0xA60D, 0xA60F}, + {0xA6F2, 0xA6F7}, {0xA874, 0xA877}, {0xA8F8, 0xA8FA}, {0xA9C1, 0xA9CD}, + {0xAA5C, 0xAA5F}, {0xFE10, 0xFE19}, {0xFE30, 0xFE52}, {0xFE54, 0xFE61}, + {0xFF01, 0xFF03}, {0xFF05, 0xFF0A}, {0xFF0C, 0xFF0F}, {0xFF3B, 0xFF3D}, + {0xFF5F, 0xFF65} #if CHRBITS > 16 - ,{0x10100, 0x10102}, {0x10a50, 0x10a58}, {0x10af0, 0x10af6}, {0x10b39, 0x10b3f}, - {0x10b99, 0x10b9c}, {0x10f55, 0x10f59}, {0x11047, 0x1104d}, {0x110be, 0x110c1}, - {0x11140, 0x11143}, {0x111c5, 0x111c8}, {0x111dd, 0x111df}, {0x11238, 0x1123d}, - {0x1144b, 0x1144f}, {0x115c1, 0x115d7}, {0x11641, 0x11643}, {0x11660, 0x1166c}, - {0x1173c, 0x1173e}, {0x11a3f, 0x11a46}, {0x11a9a, 0x11a9c}, {0x11a9e, 0x11aa2}, - {0x11c41, 0x11c45}, {0x12470, 0x12474}, {0x16b37, 0x16b3b}, {0x16e97, 0x16e9a}, - {0x1da87, 0x1da8b} + ,{0x10100, 0x10102}, {0x10A50, 0x10A58}, {0x10AF0, 0x10AF6}, {0x10B39, 0x10B3F}, + {0x10B99, 0x10B9C}, {0x10F55, 0x10F59}, {0x11047, 0x1104D}, {0x110BE, 0x110C1}, + {0x11140, 0x11143}, {0x111C5, 0x111C8}, {0x111DD, 0x111DF}, {0x11238, 0x1123D}, + {0x1144B, 0x1144F}, {0x115C1, 0x115D7}, {0x11641, 0x11643}, {0x11660, 0x1166C}, + {0x1173C, 0x1173E}, {0x11944, 0x11946}, {0x11A3F, 0x11A46}, {0x11A9A, 0x11A9C}, + {0x11A9E, 0x11AA2}, {0x11C41, 0x11C45}, {0x12470, 0x12474}, {0x16B37, 0x16B3B}, + {0x16E97, 0x16E9A}, {0x1DA87, 0x1DA8B} #endif }; #define NUM_PUNCT_RANGE (sizeof(punctRangeTable)/sizeof(crange)) static const chr punctCharTable[] = { - 0x3a, 0x3b, 0x3f, 0x40, 0x5f, 0x7b, 0x7d, 0xa1, 0xa7, - 0xab, 0xb6, 0xb7, 0xbb, 0xbf, 0x37e, 0x387, 0x589, 0x58a, - 0x5be, 0x5c0, 0x5c3, 0x5c6, 0x5f3, 0x5f4, 0x609, 0x60a, 0x60c, - 0x60d, 0x61b, 0x61e, 0x61f, 0x6d4, 0x85e, 0x964, 0x965, 0x970, - 0x9fd, 0xa76, 0xaf0, 0xc77, 0xc84, 0xdf4, 0xe4f, 0xe5a, 0xe5b, - 0xf14, 0xf85, 0xfd9, 0xfda, 0x10fb, 0x1400, 0x166e, 0x169b, 0x169c, - 0x1735, 0x1736, 0x1944, 0x1945, 0x1a1e, 0x1a1f, 0x1c7e, 0x1c7f, 0x1cd3, - 0x207d, 0x207e, 0x208d, 0x208e, 0x2329, 0x232a, 0x27c5, 0x27c6, 0x29fc, - 0x29fd, 0x2cfe, 0x2cff, 0x2d70, 0x3030, 0x303d, 0x30a0, 0x30fb, 0xa4fe, - 0xa4ff, 0xa673, 0xa67e, 0xa8ce, 0xa8cf, 0xa8fc, 0xa92e, 0xa92f, 0xa95f, - 0xa9de, 0xa9df, 0xaade, 0xaadf, 0xaaf0, 0xaaf1, 0xabeb, 0xfd3e, 0xfd3f, - 0xfe63, 0xfe68, 0xfe6a, 0xfe6b, 0xff1a, 0xff1b, 0xff1f, 0xff20, 0xff3f, - 0xff5b, 0xff5d + 0x3A, 0x3B, 0x3F, 0x40, 0x5F, 0x7B, 0x7D, 0xA1, 0xA7, + 0xAB, 0xB6, 0xB7, 0xBB, 0xBF, 0x37E, 0x387, 0x589, 0x58A, + 0x5BE, 0x5C0, 0x5C3, 0x5C6, 0x5F3, 0x5F4, 0x609, 0x60A, 0x60C, + 0x60D, 0x61B, 0x61E, 0x61F, 0x6D4, 0x85E, 0x964, 0x965, 0x970, + 0x9FD, 0xA76, 0xAF0, 0xC77, 0xC84, 0xDF4, 0xE4F, 0xE5A, 0xE5B, + 0xF14, 0xF85, 0xFD9, 0xFDA, 0x10FB, 0x1400, 0x166E, 0x169B, 0x169C, + 0x1735, 0x1736, 0x1944, 0x1945, 0x1A1E, 0x1A1F, 0x1C7E, 0x1C7F, 0x1CD3, + 0x207D, 0x207E, 0x208D, 0x208E, 0x2329, 0x232A, 0x27C5, 0x27C6, 0x29FC, + 0x29FD, 0x2CFE, 0x2CFF, 0x2D70, 0x2E52, 0x3030, 0x303D, 0x30A0, 0x30FB, + 0xA4FE, 0xA4FF, 0xA673, 0xA67E, 0xA8CE, 0xA8CF, 0xA8FC, 0xA92E, 0xA92F, + 0xA95F, 0xA9DE, 0xA9DF, 0xAADE, 0xAADF, 0xAAF0, 0xAAF1, 0xABEB, 0xFD3E, + 0xFD3F, 0xFE63, 0xFE68, 0xFE6A, 0xFE6B, 0xFF1A, 0xFF1B, 0xFF1F, 0xFF20, + 0xFF3F, 0xFF5B, 0xFF5D #if CHRBITS > 16 - ,0x1039f, 0x103d0, 0x1056f, 0x10857, 0x1091f, 0x1093f, 0x10a7f, 0x110bb, 0x110bc, - 0x11174, 0x11175, 0x111cd, 0x111db, 0x112a9, 0x1145b, 0x1145d, 0x114c6, 0x1183b, - 0x119e2, 0x11c70, 0x11c71, 0x11ef7, 0x11ef8, 0x11fff, 0x16a6e, 0x16a6f, 0x16af5, - 0x16b44, 0x16fe2, 0x1bc9f, 0x1e95e, 0x1e95f + ,0x1039F, 0x103D0, 0x1056F, 0x10857, 0x1091F, 0x1093F, 0x10A7F, 0x10EAD, 0x110BB, + 0x110BC, 0x11174, 0x11175, 0x111CD, 0x111DB, 0x112A9, 0x1145A, 0x1145B, 0x1145D, + 0x114C6, 0x1183B, 0x119E2, 0x11C70, 0x11C71, 0x11EF7, 0x11EF8, 0x11FFF, 0x16A6E, + 0x16A6F, 0x16AF5, 0x16B44, 0x16FE2, 0x1BC9F, 0x1E95E, 0x1E95F #endif }; #define NUM_PUNCT_CHAR (sizeof(punctCharTable)/sizeof(chr)) @@ -397,121 +400,122 @@ /* * Unicode: white space characters. */ static const crange spaceRangeTable[] = { - {0x9, 0xd}, {0x2000, 0x200b} + {0x9, 0xD}, {0x2000, 0x200B} }; #define NUM_SPACE_RANGE (sizeof(spaceRangeTable)/sizeof(crange)) static const chr spaceCharTable[] = { - 0x20, 0x85, 0xa0, 0x1680, 0x180e, 0x2028, 0x2029, 0x202f, 0x205f, - 0x2060, 0x3000, 0xfeff + 0x20, 0x85, 0xA0, 0x1680, 0x180E, 0x2028, 0x2029, 0x202F, 0x205F, + 0x2060, 0x3000, 0xFEFF }; #define NUM_SPACE_CHAR (sizeof(spaceCharTable)/sizeof(chr)) /* * Unicode: lowercase characters. */ static const crange lowerRangeTable[] = { - {0x61, 0x7a}, {0xdf, 0xf6}, {0xf8, 0xff}, {0x17e, 0x180}, - {0x199, 0x19b}, {0x1bd, 0x1bf}, {0x233, 0x239}, {0x24f, 0x293}, - {0x295, 0x2af}, {0x37b, 0x37d}, {0x3ac, 0x3ce}, {0x3d5, 0x3d7}, - {0x3ef, 0x3f3}, {0x430, 0x45f}, {0x560, 0x588}, {0x10d0, 0x10fa}, - {0x10fd, 0x10ff}, {0x13f8, 0x13fd}, {0x1c80, 0x1c88}, {0x1d00, 0x1d2b}, - {0x1d6b, 0x1d77}, {0x1d79, 0x1d9a}, {0x1e95, 0x1e9d}, {0x1eff, 0x1f07}, - {0x1f10, 0x1f15}, {0x1f20, 0x1f27}, {0x1f30, 0x1f37}, {0x1f40, 0x1f45}, - {0x1f50, 0x1f57}, {0x1f60, 0x1f67}, {0x1f70, 0x1f7d}, {0x1f80, 0x1f87}, - {0x1f90, 0x1f97}, {0x1fa0, 0x1fa7}, {0x1fb0, 0x1fb4}, {0x1fc2, 0x1fc4}, - {0x1fd0, 0x1fd3}, {0x1fe0, 0x1fe7}, {0x1ff2, 0x1ff4}, {0x2146, 0x2149}, - {0x2c30, 0x2c5e}, {0x2c76, 0x2c7b}, {0x2d00, 0x2d25}, {0xa72f, 0xa731}, - {0xa771, 0xa778}, {0xa793, 0xa795}, {0xab30, 0xab5a}, {0xab60, 0xab67}, - {0xab70, 0xabbf}, {0xfb00, 0xfb06}, {0xfb13, 0xfb17}, {0xff41, 0xff5a} + {0x61, 0x7A}, {0xDF, 0xF6}, {0xF8, 0xFF}, {0x17E, 0x180}, + {0x199, 0x19B}, {0x1BD, 0x1BF}, {0x233, 0x239}, {0x24F, 0x293}, + {0x295, 0x2AF}, {0x37B, 0x37D}, {0x3AC, 0x3CE}, {0x3D5, 0x3D7}, + {0x3EF, 0x3F3}, {0x430, 0x45F}, {0x560, 0x588}, {0x10D0, 0x10FA}, + {0x10FD, 0x10FF}, {0x13F8, 0x13FD}, {0x1C80, 0x1C88}, {0x1D00, 0x1D2B}, + {0x1D6B, 0x1D77}, {0x1D79, 0x1D9A}, {0x1E95, 0x1E9D}, {0x1EFF, 0x1F07}, + {0x1F10, 0x1F15}, {0x1F20, 0x1F27}, {0x1F30, 0x1F37}, {0x1F40, 0x1F45}, + {0x1F50, 0x1F57}, {0x1F60, 0x1F67}, {0x1F70, 0x1F7D}, {0x1F80, 0x1F87}, + {0x1F90, 0x1F97}, {0x1FA0, 0x1FA7}, {0x1FB0, 0x1FB4}, {0x1FC2, 0x1FC4}, + {0x1FD0, 0x1FD3}, {0x1FE0, 0x1FE7}, {0x1FF2, 0x1FF4}, {0x2146, 0x2149}, + {0x2C30, 0x2C5E}, {0x2C76, 0x2C7B}, {0x2D00, 0x2D25}, {0xA72F, 0xA731}, + {0xA771, 0xA778}, {0xA793, 0xA795}, {0xAB30, 0xAB5A}, {0xAB60, 0xAB68}, + {0xAB70, 0xABBF}, {0xFB00, 0xFB06}, {0xFB13, 0xFB17}, {0xFF41, 0xFF5A} #if CHRBITS > 16 - ,{0x10428, 0x1044f}, {0x104d8, 0x104fb}, {0x10cc0, 0x10cf2}, {0x118c0, 0x118df}, - {0x16e60, 0x16e7f}, {0x1d41a, 0x1d433}, {0x1d44e, 0x1d454}, {0x1d456, 0x1d467}, - {0x1d482, 0x1d49b}, {0x1d4b6, 0x1d4b9}, {0x1d4bd, 0x1d4c3}, {0x1d4c5, 0x1d4cf}, - {0x1d4ea, 0x1d503}, {0x1d51e, 0x1d537}, {0x1d552, 0x1d56b}, {0x1d586, 0x1d59f}, - {0x1d5ba, 0x1d5d3}, {0x1d5ee, 0x1d607}, {0x1d622, 0x1d63b}, {0x1d656, 0x1d66f}, - {0x1d68a, 0x1d6a5}, {0x1d6c2, 0x1d6da}, {0x1d6dc, 0x1d6e1}, {0x1d6fc, 0x1d714}, - {0x1d716, 0x1d71b}, {0x1d736, 0x1d74e}, {0x1d750, 0x1d755}, {0x1d770, 0x1d788}, - {0x1d78a, 0x1d78f}, {0x1d7aa, 0x1d7c2}, {0x1d7c4, 0x1d7c9}, {0x1e922, 0x1e943} + ,{0x10428, 0x1044F}, {0x104D8, 0x104FB}, {0x10CC0, 0x10CF2}, {0x118C0, 0x118DF}, + {0x16E60, 0x16E7F}, {0x1D41A, 0x1D433}, {0x1D44E, 0x1D454}, {0x1D456, 0x1D467}, + {0x1D482, 0x1D49B}, {0x1D4B6, 0x1D4B9}, {0x1D4BD, 0x1D4C3}, {0x1D4C5, 0x1D4CF}, + {0x1D4EA, 0x1D503}, {0x1D51E, 0x1D537}, {0x1D552, 0x1D56B}, {0x1D586, 0x1D59F}, + {0x1D5BA, 0x1D5D3}, {0x1D5EE, 0x1D607}, {0x1D622, 0x1D63B}, {0x1D656, 0x1D66F}, + {0x1D68A, 0x1D6A5}, {0x1D6C2, 0x1D6DA}, {0x1D6DC, 0x1D6E1}, {0x1D6FC, 0x1D714}, + {0x1D716, 0x1D71B}, {0x1D736, 0x1D74E}, {0x1D750, 0x1D755}, {0x1D770, 0x1D788}, + {0x1D78A, 0x1D78F}, {0x1D7AA, 0x1D7C2}, {0x1D7C4, 0x1D7C9}, {0x1E922, 0x1E943} #endif }; #define NUM_LOWER_RANGE (sizeof(lowerRangeTable)/sizeof(crange)) static const chr lowerCharTable[] = { - 0xb5, 0x101, 0x103, 0x105, 0x107, 0x109, 0x10b, 0x10d, 0x10f, - 0x111, 0x113, 0x115, 0x117, 0x119, 0x11b, 0x11d, 0x11f, 0x121, - 0x123, 0x125, 0x127, 0x129, 0x12b, 0x12d, 0x12f, 0x131, 0x133, - 0x135, 0x137, 0x138, 0x13a, 0x13c, 0x13e, 0x140, 0x142, 0x144, - 0x146, 0x148, 0x149, 0x14b, 0x14d, 0x14f, 0x151, 0x153, 0x155, - 0x157, 0x159, 0x15b, 0x15d, 0x15f, 0x161, 0x163, 0x165, 0x167, - 0x169, 0x16b, 0x16d, 0x16f, 0x171, 0x173, 0x175, 0x177, 0x17a, - 0x17c, 0x183, 0x185, 0x188, 0x18c, 0x18d, 0x192, 0x195, 0x19e, - 0x1a1, 0x1a3, 0x1a5, 0x1a8, 0x1aa, 0x1ab, 0x1ad, 0x1b0, 0x1b4, - 0x1b6, 0x1b9, 0x1ba, 0x1c6, 0x1c9, 0x1cc, 0x1ce, 0x1d0, 0x1d2, - 0x1d4, 0x1d6, 0x1d8, 0x1da, 0x1dc, 0x1dd, 0x1df, 0x1e1, 0x1e3, - 0x1e5, 0x1e7, 0x1e9, 0x1eb, 0x1ed, 0x1ef, 0x1f0, 0x1f3, 0x1f5, - 0x1f9, 0x1fb, 0x1fd, 0x1ff, 0x201, 0x203, 0x205, 0x207, 0x209, - 0x20b, 0x20d, 0x20f, 0x211, 0x213, 0x215, 0x217, 0x219, 0x21b, - 0x21d, 0x21f, 0x221, 0x223, 0x225, 0x227, 0x229, 0x22b, 0x22d, - 0x22f, 0x231, 0x23c, 0x23f, 0x240, 0x242, 0x247, 0x249, 0x24b, - 0x24d, 0x371, 0x373, 0x377, 0x390, 0x3d0, 0x3d1, 0x3d9, 0x3db, - 0x3dd, 0x3df, 0x3e1, 0x3e3, 0x3e5, 0x3e7, 0x3e9, 0x3eb, 0x3ed, - 0x3f5, 0x3f8, 0x3fb, 0x3fc, 0x461, 0x463, 0x465, 0x467, 0x469, - 0x46b, 0x46d, 0x46f, 0x471, 0x473, 0x475, 0x477, 0x479, 0x47b, - 0x47d, 0x47f, 0x481, 0x48b, 0x48d, 0x48f, 0x491, 0x493, 0x495, - 0x497, 0x499, 0x49b, 0x49d, 0x49f, 0x4a1, 0x4a3, 0x4a5, 0x4a7, - 0x4a9, 0x4ab, 0x4ad, 0x4af, 0x4b1, 0x4b3, 0x4b5, 0x4b7, 0x4b9, - 0x4bb, 0x4bd, 0x4bf, 0x4c2, 0x4c4, 0x4c6, 0x4c8, 0x4ca, 0x4cc, - 0x4ce, 0x4cf, 0x4d1, 0x4d3, 0x4d5, 0x4d7, 0x4d9, 0x4db, 0x4dd, - 0x4df, 0x4e1, 0x4e3, 0x4e5, 0x4e7, 0x4e9, 0x4eb, 0x4ed, 0x4ef, - 0x4f1, 0x4f3, 0x4f5, 0x4f7, 0x4f9, 0x4fb, 0x4fd, 0x4ff, 0x501, - 0x503, 0x505, 0x507, 0x509, 0x50b, 0x50d, 0x50f, 0x511, 0x513, - 0x515, 0x517, 0x519, 0x51b, 0x51d, 0x51f, 0x521, 0x523, 0x525, - 0x527, 0x529, 0x52b, 0x52d, 0x52f, 0x1e01, 0x1e03, 0x1e05, 0x1e07, - 0x1e09, 0x1e0b, 0x1e0d, 0x1e0f, 0x1e11, 0x1e13, 0x1e15, 0x1e17, 0x1e19, - 0x1e1b, 0x1e1d, 0x1e1f, 0x1e21, 0x1e23, 0x1e25, 0x1e27, 0x1e29, 0x1e2b, - 0x1e2d, 0x1e2f, 0x1e31, 0x1e33, 0x1e35, 0x1e37, 0x1e39, 0x1e3b, 0x1e3d, - 0x1e3f, 0x1e41, 0x1e43, 0x1e45, 0x1e47, 0x1e49, 0x1e4b, 0x1e4d, 0x1e4f, - 0x1e51, 0x1e53, 0x1e55, 0x1e57, 0x1e59, 0x1e5b, 0x1e5d, 0x1e5f, 0x1e61, - 0x1e63, 0x1e65, 0x1e67, 0x1e69, 0x1e6b, 0x1e6d, 0x1e6f, 0x1e71, 0x1e73, - 0x1e75, 0x1e77, 0x1e79, 0x1e7b, 0x1e7d, 0x1e7f, 0x1e81, 0x1e83, 0x1e85, - 0x1e87, 0x1e89, 0x1e8b, 0x1e8d, 0x1e8f, 0x1e91, 0x1e93, 0x1e9f, 0x1ea1, - 0x1ea3, 0x1ea5, 0x1ea7, 0x1ea9, 0x1eab, 0x1ead, 0x1eaf, 0x1eb1, 0x1eb3, - 0x1eb5, 0x1eb7, 0x1eb9, 0x1ebb, 0x1ebd, 0x1ebf, 0x1ec1, 0x1ec3, 0x1ec5, - 0x1ec7, 0x1ec9, 0x1ecb, 0x1ecd, 0x1ecf, 0x1ed1, 0x1ed3, 0x1ed5, 0x1ed7, - 0x1ed9, 0x1edb, 0x1edd, 0x1edf, 0x1ee1, 0x1ee3, 0x1ee5, 0x1ee7, 0x1ee9, - 0x1eeb, 0x1eed, 0x1eef, 0x1ef1, 0x1ef3, 0x1ef5, 0x1ef7, 0x1ef9, 0x1efb, - 0x1efd, 0x1fb6, 0x1fb7, 0x1fbe, 0x1fc6, 0x1fc7, 0x1fd6, 0x1fd7, 0x1ff6, - 0x1ff7, 0x210a, 0x210e, 0x210f, 0x2113, 0x212f, 0x2134, 0x2139, 0x213c, - 0x213d, 0x214e, 0x2184, 0x2c61, 0x2c65, 0x2c66, 0x2c68, 0x2c6a, 0x2c6c, - 0x2c71, 0x2c73, 0x2c74, 0x2c81, 0x2c83, 0x2c85, 0x2c87, 0x2c89, 0x2c8b, - 0x2c8d, 0x2c8f, 0x2c91, 0x2c93, 0x2c95, 0x2c97, 0x2c99, 0x2c9b, 0x2c9d, - 0x2c9f, 0x2ca1, 0x2ca3, 0x2ca5, 0x2ca7, 0x2ca9, 0x2cab, 0x2cad, 0x2caf, - 0x2cb1, 0x2cb3, 0x2cb5, 0x2cb7, 0x2cb9, 0x2cbb, 0x2cbd, 0x2cbf, 0x2cc1, - 0x2cc3, 0x2cc5, 0x2cc7, 0x2cc9, 0x2ccb, 0x2ccd, 0x2ccf, 0x2cd1, 0x2cd3, - 0x2cd5, 0x2cd7, 0x2cd9, 0x2cdb, 0x2cdd, 0x2cdf, 0x2ce1, 0x2ce3, 0x2ce4, - 0x2cec, 0x2cee, 0x2cf3, 0x2d27, 0x2d2d, 0xa641, 0xa643, 0xa645, 0xa647, - 0xa649, 0xa64b, 0xa64d, 0xa64f, 0xa651, 0xa653, 0xa655, 0xa657, 0xa659, - 0xa65b, 0xa65d, 0xa65f, 0xa661, 0xa663, 0xa665, 0xa667, 0xa669, 0xa66b, - 0xa66d, 0xa681, 0xa683, 0xa685, 0xa687, 0xa689, 0xa68b, 0xa68d, 0xa68f, - 0xa691, 0xa693, 0xa695, 0xa697, 0xa699, 0xa69b, 0xa723, 0xa725, 0xa727, - 0xa729, 0xa72b, 0xa72d, 0xa733, 0xa735, 0xa737, 0xa739, 0xa73b, 0xa73d, - 0xa73f, 0xa741, 0xa743, 0xa745, 0xa747, 0xa749, 0xa74b, 0xa74d, 0xa74f, - 0xa751, 0xa753, 0xa755, 0xa757, 0xa759, 0xa75b, 0xa75d, 0xa75f, 0xa761, - 0xa763, 0xa765, 0xa767, 0xa769, 0xa76b, 0xa76d, 0xa76f, 0xa77a, 0xa77c, - 0xa77f, 0xa781, 0xa783, 0xa785, 0xa787, 0xa78c, 0xa78e, 0xa791, 0xa797, - 0xa799, 0xa79b, 0xa79d, 0xa79f, 0xa7a1, 0xa7a3, 0xa7a5, 0xa7a7, 0xa7a9, - 0xa7af, 0xa7b5, 0xa7b7, 0xa7b9, 0xa7bb, 0xa7bd, 0xa7bf, 0xa7c3, 0xa7fa + 0xB5, 0x101, 0x103, 0x105, 0x107, 0x109, 0x10B, 0x10D, 0x10F, + 0x111, 0x113, 0x115, 0x117, 0x119, 0x11B, 0x11D, 0x11F, 0x121, + 0x123, 0x125, 0x127, 0x129, 0x12B, 0x12D, 0x12F, 0x131, 0x133, + 0x135, 0x137, 0x138, 0x13A, 0x13C, 0x13E, 0x140, 0x142, 0x144, + 0x146, 0x148, 0x149, 0x14B, 0x14D, 0x14F, 0x151, 0x153, 0x155, + 0x157, 0x159, 0x15B, 0x15D, 0x15F, 0x161, 0x163, 0x165, 0x167, + 0x169, 0x16B, 0x16D, 0x16F, 0x171, 0x173, 0x175, 0x177, 0x17A, + 0x17C, 0x183, 0x185, 0x188, 0x18C, 0x18D, 0x192, 0x195, 0x19E, + 0x1A1, 0x1A3, 0x1A5, 0x1A8, 0x1AA, 0x1AB, 0x1AD, 0x1B0, 0x1B4, + 0x1B6, 0x1B9, 0x1BA, 0x1C6, 0x1C9, 0x1CC, 0x1CE, 0x1D0, 0x1D2, + 0x1D4, 0x1D6, 0x1D8, 0x1DA, 0x1DC, 0x1DD, 0x1DF, 0x1E1, 0x1E3, + 0x1E5, 0x1E7, 0x1E9, 0x1EB, 0x1ED, 0x1EF, 0x1F0, 0x1F3, 0x1F5, + 0x1F9, 0x1FB, 0x1FD, 0x1FF, 0x201, 0x203, 0x205, 0x207, 0x209, + 0x20B, 0x20D, 0x20F, 0x211, 0x213, 0x215, 0x217, 0x219, 0x21B, + 0x21D, 0x21F, 0x221, 0x223, 0x225, 0x227, 0x229, 0x22B, 0x22D, + 0x22F, 0x231, 0x23C, 0x23F, 0x240, 0x242, 0x247, 0x249, 0x24B, + 0x24D, 0x371, 0x373, 0x377, 0x390, 0x3D0, 0x3D1, 0x3D9, 0x3DB, + 0x3DD, 0x3DF, 0x3E1, 0x3E3, 0x3E5, 0x3E7, 0x3E9, 0x3EB, 0x3ED, + 0x3F5, 0x3F8, 0x3FB, 0x3FC, 0x461, 0x463, 0x465, 0x467, 0x469, + 0x46B, 0x46D, 0x46F, 0x471, 0x473, 0x475, 0x477, 0x479, 0x47B, + 0x47D, 0x47F, 0x481, 0x48B, 0x48D, 0x48F, 0x491, 0x493, 0x495, + 0x497, 0x499, 0x49B, 0x49D, 0x49F, 0x4A1, 0x4A3, 0x4A5, 0x4A7, + 0x4A9, 0x4AB, 0x4AD, 0x4AF, 0x4B1, 0x4B3, 0x4B5, 0x4B7, 0x4B9, + 0x4BB, 0x4BD, 0x4BF, 0x4C2, 0x4C4, 0x4C6, 0x4C8, 0x4CA, 0x4CC, + 0x4CE, 0x4CF, 0x4D1, 0x4D3, 0x4D5, 0x4D7, 0x4D9, 0x4DB, 0x4DD, + 0x4DF, 0x4E1, 0x4E3, 0x4E5, 0x4E7, 0x4E9, 0x4EB, 0x4ED, 0x4EF, + 0x4F1, 0x4F3, 0x4F5, 0x4F7, 0x4F9, 0x4FB, 0x4FD, 0x4FF, 0x501, + 0x503, 0x505, 0x507, 0x509, 0x50B, 0x50D, 0x50F, 0x511, 0x513, + 0x515, 0x517, 0x519, 0x51B, 0x51D, 0x51F, 0x521, 0x523, 0x525, + 0x527, 0x529, 0x52B, 0x52D, 0x52F, 0x1E01, 0x1E03, 0x1E05, 0x1E07, + 0x1E09, 0x1E0B, 0x1E0D, 0x1E0F, 0x1E11, 0x1E13, 0x1E15, 0x1E17, 0x1E19, + 0x1E1B, 0x1E1D, 0x1E1F, 0x1E21, 0x1E23, 0x1E25, 0x1E27, 0x1E29, 0x1E2B, + 0x1E2D, 0x1E2F, 0x1E31, 0x1E33, 0x1E35, 0x1E37, 0x1E39, 0x1E3B, 0x1E3D, + 0x1E3F, 0x1E41, 0x1E43, 0x1E45, 0x1E47, 0x1E49, 0x1E4B, 0x1E4D, 0x1E4F, + 0x1E51, 0x1E53, 0x1E55, 0x1E57, 0x1E59, 0x1E5B, 0x1E5D, 0x1E5F, 0x1E61, + 0x1E63, 0x1E65, 0x1E67, 0x1E69, 0x1E6B, 0x1E6D, 0x1E6F, 0x1E71, 0x1E73, + 0x1E75, 0x1E77, 0x1E79, 0x1E7B, 0x1E7D, 0x1E7F, 0x1E81, 0x1E83, 0x1E85, + 0x1E87, 0x1E89, 0x1E8B, 0x1E8D, 0x1E8F, 0x1E91, 0x1E93, 0x1E9F, 0x1EA1, + 0x1EA3, 0x1EA5, 0x1EA7, 0x1EA9, 0x1EAB, 0x1EAD, 0x1EAF, 0x1EB1, 0x1EB3, + 0x1EB5, 0x1EB7, 0x1EB9, 0x1EBB, 0x1EBD, 0x1EBF, 0x1EC1, 0x1EC3, 0x1EC5, + 0x1EC7, 0x1EC9, 0x1ECB, 0x1ECD, 0x1ECF, 0x1ED1, 0x1ED3, 0x1ED5, 0x1ED7, + 0x1ED9, 0x1EDB, 0x1EDD, 0x1EDF, 0x1EE1, 0x1EE3, 0x1EE5, 0x1EE7, 0x1EE9, + 0x1EEB, 0x1EED, 0x1EEF, 0x1EF1, 0x1EF3, 0x1EF5, 0x1EF7, 0x1EF9, 0x1EFB, + 0x1EFD, 0x1FB6, 0x1FB7, 0x1FBE, 0x1FC6, 0x1FC7, 0x1FD6, 0x1FD7, 0x1FF6, + 0x1FF7, 0x210A, 0x210E, 0x210F, 0x2113, 0x212F, 0x2134, 0x2139, 0x213C, + 0x213D, 0x214E, 0x2184, 0x2C61, 0x2C65, 0x2C66, 0x2C68, 0x2C6A, 0x2C6C, + 0x2C71, 0x2C73, 0x2C74, 0x2C81, 0x2C83, 0x2C85, 0x2C87, 0x2C89, 0x2C8B, + 0x2C8D, 0x2C8F, 0x2C91, 0x2C93, 0x2C95, 0x2C97, 0x2C99, 0x2C9B, 0x2C9D, + 0x2C9F, 0x2CA1, 0x2CA3, 0x2CA5, 0x2CA7, 0x2CA9, 0x2CAB, 0x2CAD, 0x2CAF, + 0x2CB1, 0x2CB3, 0x2CB5, 0x2CB7, 0x2CB9, 0x2CBB, 0x2CBD, 0x2CBF, 0x2CC1, + 0x2CC3, 0x2CC5, 0x2CC7, 0x2CC9, 0x2CCB, 0x2CCD, 0x2CCF, 0x2CD1, 0x2CD3, + 0x2CD5, 0x2CD7, 0x2CD9, 0x2CDB, 0x2CDD, 0x2CDF, 0x2CE1, 0x2CE3, 0x2CE4, + 0x2CEC, 0x2CEE, 0x2CF3, 0x2D27, 0x2D2D, 0xA641, 0xA643, 0xA645, 0xA647, + 0xA649, 0xA64B, 0xA64D, 0xA64F, 0xA651, 0xA653, 0xA655, 0xA657, 0xA659, + 0xA65B, 0xA65D, 0xA65F, 0xA661, 0xA663, 0xA665, 0xA667, 0xA669, 0xA66B, + 0xA66D, 0xA681, 0xA683, 0xA685, 0xA687, 0xA689, 0xA68B, 0xA68D, 0xA68F, + 0xA691, 0xA693, 0xA695, 0xA697, 0xA699, 0xA69B, 0xA723, 0xA725, 0xA727, + 0xA729, 0xA72B, 0xA72D, 0xA733, 0xA735, 0xA737, 0xA739, 0xA73B, 0xA73D, + 0xA73F, 0xA741, 0xA743, 0xA745, 0xA747, 0xA749, 0xA74B, 0xA74D, 0xA74F, + 0xA751, 0xA753, 0xA755, 0xA757, 0xA759, 0xA75B, 0xA75D, 0xA75F, 0xA761, + 0xA763, 0xA765, 0xA767, 0xA769, 0xA76B, 0xA76D, 0xA76F, 0xA77A, 0xA77C, + 0xA77F, 0xA781, 0xA783, 0xA785, 0xA787, 0xA78C, 0xA78E, 0xA791, 0xA797, + 0xA799, 0xA79B, 0xA79D, 0xA79F, 0xA7A1, 0xA7A3, 0xA7A5, 0xA7A7, 0xA7A9, + 0xA7AF, 0xA7B5, 0xA7B7, 0xA7B9, 0xA7BB, 0xA7BD, 0xA7BF, 0xA7C3, 0xA7C8, + 0xA7CA, 0xA7F6, 0xA7FA #if CHRBITS > 16 - ,0x1d4bb, 0x1d7cb + ,0x1D4BB, 0x1D7CB #endif }; #define NUM_LOWER_CHAR (sizeof(lowerCharTable)/sizeof(chr)) @@ -518,103 +522,103 @@ /* * Unicode: uppercase characters. */ static const crange upperRangeTable[] = { - {0x41, 0x5a}, {0xc0, 0xd6}, {0xd8, 0xde}, {0x189, 0x18b}, - {0x18e, 0x191}, {0x196, 0x198}, {0x1b1, 0x1b3}, {0x1f6, 0x1f8}, - {0x243, 0x246}, {0x388, 0x38a}, {0x391, 0x3a1}, {0x3a3, 0x3ab}, - {0x3d2, 0x3d4}, {0x3fd, 0x42f}, {0x531, 0x556}, {0x10a0, 0x10c5}, - {0x13a0, 0x13f5}, {0x1c90, 0x1cba}, {0x1cbd, 0x1cbf}, {0x1f08, 0x1f0f}, - {0x1f18, 0x1f1d}, {0x1f28, 0x1f2f}, {0x1f38, 0x1f3f}, {0x1f48, 0x1f4d}, - {0x1f68, 0x1f6f}, {0x1fb8, 0x1fbb}, {0x1fc8, 0x1fcb}, {0x1fd8, 0x1fdb}, - {0x1fe8, 0x1fec}, {0x1ff8, 0x1ffb}, {0x210b, 0x210d}, {0x2110, 0x2112}, - {0x2119, 0x211d}, {0x212a, 0x212d}, {0x2130, 0x2133}, {0x2c00, 0x2c2e}, - {0x2c62, 0x2c64}, {0x2c6d, 0x2c70}, {0x2c7e, 0x2c80}, {0xa7aa, 0xa7ae}, - {0xa7b0, 0xa7b4}, {0xa7c4, 0xa7c6}, {0xff21, 0xff3a} + {0x41, 0x5A}, {0xC0, 0xD6}, {0xD8, 0xDE}, {0x189, 0x18B}, + {0x18E, 0x191}, {0x196, 0x198}, {0x1B1, 0x1B3}, {0x1F6, 0x1F8}, + {0x243, 0x246}, {0x388, 0x38A}, {0x391, 0x3A1}, {0x3A3, 0x3AB}, + {0x3D2, 0x3D4}, {0x3FD, 0x42F}, {0x531, 0x556}, {0x10A0, 0x10C5}, + {0x13A0, 0x13F5}, {0x1C90, 0x1CBA}, {0x1CBD, 0x1CBF}, {0x1F08, 0x1F0F}, + {0x1F18, 0x1F1D}, {0x1F28, 0x1F2F}, {0x1F38, 0x1F3F}, {0x1F48, 0x1F4D}, + {0x1F68, 0x1F6F}, {0x1FB8, 0x1FBB}, {0x1FC8, 0x1FCB}, {0x1FD8, 0x1FDB}, + {0x1FE8, 0x1FEC}, {0x1FF8, 0x1FFB}, {0x210B, 0x210D}, {0x2110, 0x2112}, + {0x2119, 0x211D}, {0x212A, 0x212D}, {0x2130, 0x2133}, {0x2C00, 0x2C2E}, + {0x2C62, 0x2C64}, {0x2C6D, 0x2C70}, {0x2C7E, 0x2C80}, {0xA7AA, 0xA7AE}, + {0xA7B0, 0xA7B4}, {0xA7C4, 0xA7C7}, {0xFF21, 0xFF3A} #if CHRBITS > 16 - ,{0x10400, 0x10427}, {0x104b0, 0x104d3}, {0x10c80, 0x10cb2}, {0x118a0, 0x118bf}, - {0x16e40, 0x16e5f}, {0x1d400, 0x1d419}, {0x1d434, 0x1d44d}, {0x1d468, 0x1d481}, - {0x1d4a9, 0x1d4ac}, {0x1d4ae, 0x1d4b5}, {0x1d4d0, 0x1d4e9}, {0x1d507, 0x1d50a}, - {0x1d50d, 0x1d514}, {0x1d516, 0x1d51c}, {0x1d53b, 0x1d53e}, {0x1d540, 0x1d544}, - {0x1d54a, 0x1d550}, {0x1d56c, 0x1d585}, {0x1d5a0, 0x1d5b9}, {0x1d5d4, 0x1d5ed}, - {0x1d608, 0x1d621}, {0x1d63c, 0x1d655}, {0x1d670, 0x1d689}, {0x1d6a8, 0x1d6c0}, - {0x1d6e2, 0x1d6fa}, {0x1d71c, 0x1d734}, {0x1d756, 0x1d76e}, {0x1d790, 0x1d7a8}, - {0x1e900, 0x1e921} + ,{0x10400, 0x10427}, {0x104B0, 0x104D3}, {0x10C80, 0x10CB2}, {0x118A0, 0x118BF}, + {0x16E40, 0x16E5F}, {0x1D400, 0x1D419}, {0x1D434, 0x1D44D}, {0x1D468, 0x1D481}, + {0x1D4A9, 0x1D4AC}, {0x1D4AE, 0x1D4B5}, {0x1D4D0, 0x1D4E9}, {0x1D507, 0x1D50A}, + {0x1D50D, 0x1D514}, {0x1D516, 0x1D51C}, {0x1D53B, 0x1D53E}, {0x1D540, 0x1D544}, + {0x1D54A, 0x1D550}, {0x1D56C, 0x1D585}, {0x1D5A0, 0x1D5B9}, {0x1D5D4, 0x1D5ED}, + {0x1D608, 0x1D621}, {0x1D63C, 0x1D655}, {0x1D670, 0x1D689}, {0x1D6A8, 0x1D6C0}, + {0x1D6E2, 0x1D6FA}, {0x1D71C, 0x1D734}, {0x1D756, 0x1D76E}, {0x1D790, 0x1D7A8}, + {0x1E900, 0x1E921} #endif }; #define NUM_UPPER_RANGE (sizeof(upperRangeTable)/sizeof(crange)) static const chr upperCharTable[] = { - 0x100, 0x102, 0x104, 0x106, 0x108, 0x10a, 0x10c, 0x10e, 0x110, - 0x112, 0x114, 0x116, 0x118, 0x11a, 0x11c, 0x11e, 0x120, 0x122, - 0x124, 0x126, 0x128, 0x12a, 0x12c, 0x12e, 0x130, 0x132, 0x134, - 0x136, 0x139, 0x13b, 0x13d, 0x13f, 0x141, 0x143, 0x145, 0x147, - 0x14a, 0x14c, 0x14e, 0x150, 0x152, 0x154, 0x156, 0x158, 0x15a, - 0x15c, 0x15e, 0x160, 0x162, 0x164, 0x166, 0x168, 0x16a, 0x16c, - 0x16e, 0x170, 0x172, 0x174, 0x176, 0x178, 0x179, 0x17b, 0x17d, - 0x181, 0x182, 0x184, 0x186, 0x187, 0x193, 0x194, 0x19c, 0x19d, - 0x19f, 0x1a0, 0x1a2, 0x1a4, 0x1a6, 0x1a7, 0x1a9, 0x1ac, 0x1ae, - 0x1af, 0x1b5, 0x1b7, 0x1b8, 0x1bc, 0x1c4, 0x1c7, 0x1ca, 0x1cd, - 0x1cf, 0x1d1, 0x1d3, 0x1d5, 0x1d7, 0x1d9, 0x1db, 0x1de, 0x1e0, - 0x1e2, 0x1e4, 0x1e6, 0x1e8, 0x1ea, 0x1ec, 0x1ee, 0x1f1, 0x1f4, - 0x1fa, 0x1fc, 0x1fe, 0x200, 0x202, 0x204, 0x206, 0x208, 0x20a, - 0x20c, 0x20e, 0x210, 0x212, 0x214, 0x216, 0x218, 0x21a, 0x21c, - 0x21e, 0x220, 0x222, 0x224, 0x226, 0x228, 0x22a, 0x22c, 0x22e, - 0x230, 0x232, 0x23a, 0x23b, 0x23d, 0x23e, 0x241, 0x248, 0x24a, - 0x24c, 0x24e, 0x370, 0x372, 0x376, 0x37f, 0x386, 0x38c, 0x38e, - 0x38f, 0x3cf, 0x3d8, 0x3da, 0x3dc, 0x3de, 0x3e0, 0x3e2, 0x3e4, - 0x3e6, 0x3e8, 0x3ea, 0x3ec, 0x3ee, 0x3f4, 0x3f7, 0x3f9, 0x3fa, - 0x460, 0x462, 0x464, 0x466, 0x468, 0x46a, 0x46c, 0x46e, 0x470, - 0x472, 0x474, 0x476, 0x478, 0x47a, 0x47c, 0x47e, 0x480, 0x48a, - 0x48c, 0x48e, 0x490, 0x492, 0x494, 0x496, 0x498, 0x49a, 0x49c, - 0x49e, 0x4a0, 0x4a2, 0x4a4, 0x4a6, 0x4a8, 0x4aa, 0x4ac, 0x4ae, - 0x4b0, 0x4b2, 0x4b4, 0x4b6, 0x4b8, 0x4ba, 0x4bc, 0x4be, 0x4c0, - 0x4c1, 0x4c3, 0x4c5, 0x4c7, 0x4c9, 0x4cb, 0x4cd, 0x4d0, 0x4d2, - 0x4d4, 0x4d6, 0x4d8, 0x4da, 0x4dc, 0x4de, 0x4e0, 0x4e2, 0x4e4, - 0x4e6, 0x4e8, 0x4ea, 0x4ec, 0x4ee, 0x4f0, 0x4f2, 0x4f4, 0x4f6, - 0x4f8, 0x4fa, 0x4fc, 0x4fe, 0x500, 0x502, 0x504, 0x506, 0x508, - 0x50a, 0x50c, 0x50e, 0x510, 0x512, 0x514, 0x516, 0x518, 0x51a, - 0x51c, 0x51e, 0x520, 0x522, 0x524, 0x526, 0x528, 0x52a, 0x52c, - 0x52e, 0x10c7, 0x10cd, 0x1e00, 0x1e02, 0x1e04, 0x1e06, 0x1e08, 0x1e0a, - 0x1e0c, 0x1e0e, 0x1e10, 0x1e12, 0x1e14, 0x1e16, 0x1e18, 0x1e1a, 0x1e1c, - 0x1e1e, 0x1e20, 0x1e22, 0x1e24, 0x1e26, 0x1e28, 0x1e2a, 0x1e2c, 0x1e2e, - 0x1e30, 0x1e32, 0x1e34, 0x1e36, 0x1e38, 0x1e3a, 0x1e3c, 0x1e3e, 0x1e40, - 0x1e42, 0x1e44, 0x1e46, 0x1e48, 0x1e4a, 0x1e4c, 0x1e4e, 0x1e50, 0x1e52, - 0x1e54, 0x1e56, 0x1e58, 0x1e5a, 0x1e5c, 0x1e5e, 0x1e60, 0x1e62, 0x1e64, - 0x1e66, 0x1e68, 0x1e6a, 0x1e6c, 0x1e6e, 0x1e70, 0x1e72, 0x1e74, 0x1e76, - 0x1e78, 0x1e7a, 0x1e7c, 0x1e7e, 0x1e80, 0x1e82, 0x1e84, 0x1e86, 0x1e88, - 0x1e8a, 0x1e8c, 0x1e8e, 0x1e90, 0x1e92, 0x1e94, 0x1e9e, 0x1ea0, 0x1ea2, - 0x1ea4, 0x1ea6, 0x1ea8, 0x1eaa, 0x1eac, 0x1eae, 0x1eb0, 0x1eb2, 0x1eb4, - 0x1eb6, 0x1eb8, 0x1eba, 0x1ebc, 0x1ebe, 0x1ec0, 0x1ec2, 0x1ec4, 0x1ec6, - 0x1ec8, 0x1eca, 0x1ecc, 0x1ece, 0x1ed0, 0x1ed2, 0x1ed4, 0x1ed6, 0x1ed8, - 0x1eda, 0x1edc, 0x1ede, 0x1ee0, 0x1ee2, 0x1ee4, 0x1ee6, 0x1ee8, 0x1eea, - 0x1eec, 0x1eee, 0x1ef0, 0x1ef2, 0x1ef4, 0x1ef6, 0x1ef8, 0x1efa, 0x1efc, - 0x1efe, 0x1f59, 0x1f5b, 0x1f5d, 0x1f5f, 0x2102, 0x2107, 0x2115, 0x2124, - 0x2126, 0x2128, 0x213e, 0x213f, 0x2145, 0x2183, 0x2c60, 0x2c67, 0x2c69, - 0x2c6b, 0x2c72, 0x2c75, 0x2c82, 0x2c84, 0x2c86, 0x2c88, 0x2c8a, 0x2c8c, - 0x2c8e, 0x2c90, 0x2c92, 0x2c94, 0x2c96, 0x2c98, 0x2c9a, 0x2c9c, 0x2c9e, - 0x2ca0, 0x2ca2, 0x2ca4, 0x2ca6, 0x2ca8, 0x2caa, 0x2cac, 0x2cae, 0x2cb0, - 0x2cb2, 0x2cb4, 0x2cb6, 0x2cb8, 0x2cba, 0x2cbc, 0x2cbe, 0x2cc0, 0x2cc2, - 0x2cc4, 0x2cc6, 0x2cc8, 0x2cca, 0x2ccc, 0x2cce, 0x2cd0, 0x2cd2, 0x2cd4, - 0x2cd6, 0x2cd8, 0x2cda, 0x2cdc, 0x2cde, 0x2ce0, 0x2ce2, 0x2ceb, 0x2ced, - 0x2cf2, 0xa640, 0xa642, 0xa644, 0xa646, 0xa648, 0xa64a, 0xa64c, 0xa64e, - 0xa650, 0xa652, 0xa654, 0xa656, 0xa658, 0xa65a, 0xa65c, 0xa65e, 0xa660, - 0xa662, 0xa664, 0xa666, 0xa668, 0xa66a, 0xa66c, 0xa680, 0xa682, 0xa684, - 0xa686, 0xa688, 0xa68a, 0xa68c, 0xa68e, 0xa690, 0xa692, 0xa694, 0xa696, - 0xa698, 0xa69a, 0xa722, 0xa724, 0xa726, 0xa728, 0xa72a, 0xa72c, 0xa72e, - 0xa732, 0xa734, 0xa736, 0xa738, 0xa73a, 0xa73c, 0xa73e, 0xa740, 0xa742, - 0xa744, 0xa746, 0xa748, 0xa74a, 0xa74c, 0xa74e, 0xa750, 0xa752, 0xa754, - 0xa756, 0xa758, 0xa75a, 0xa75c, 0xa75e, 0xa760, 0xa762, 0xa764, 0xa766, - 0xa768, 0xa76a, 0xa76c, 0xa76e, 0xa779, 0xa77b, 0xa77d, 0xa77e, 0xa780, - 0xa782, 0xa784, 0xa786, 0xa78b, 0xa78d, 0xa790, 0xa792, 0xa796, 0xa798, - 0xa79a, 0xa79c, 0xa79e, 0xa7a0, 0xa7a2, 0xa7a4, 0xa7a6, 0xa7a8, 0xa7b6, - 0xa7b8, 0xa7ba, 0xa7bc, 0xa7be, 0xa7c2 + 0x100, 0x102, 0x104, 0x106, 0x108, 0x10A, 0x10C, 0x10E, 0x110, + 0x112, 0x114, 0x116, 0x118, 0x11A, 0x11C, 0x11E, 0x120, 0x122, + 0x124, 0x126, 0x128, 0x12A, 0x12C, 0x12E, 0x130, 0x132, 0x134, + 0x136, 0x139, 0x13B, 0x13D, 0x13F, 0x141, 0x143, 0x145, 0x147, + 0x14A, 0x14C, 0x14E, 0x150, 0x152, 0x154, 0x156, 0x158, 0x15A, + 0x15C, 0x15E, 0x160, 0x162, 0x164, 0x166, 0x168, 0x16A, 0x16C, + 0x16E, 0x170, 0x172, 0x174, 0x176, 0x178, 0x179, 0x17B, 0x17D, + 0x181, 0x182, 0x184, 0x186, 0x187, 0x193, 0x194, 0x19C, 0x19D, + 0x19F, 0x1A0, 0x1A2, 0x1A4, 0x1A6, 0x1A7, 0x1A9, 0x1AC, 0x1AE, + 0x1AF, 0x1B5, 0x1B7, 0x1B8, 0x1BC, 0x1C4, 0x1C7, 0x1CA, 0x1CD, + 0x1CF, 0x1D1, 0x1D3, 0x1D5, 0x1D7, 0x1D9, 0x1DB, 0x1DE, 0x1E0, + 0x1E2, 0x1E4, 0x1E6, 0x1E8, 0x1EA, 0x1EC, 0x1EE, 0x1F1, 0x1F4, + 0x1FA, 0x1FC, 0x1FE, 0x200, 0x202, 0x204, 0x206, 0x208, 0x20A, + 0x20C, 0x20E, 0x210, 0x212, 0x214, 0x216, 0x218, 0x21A, 0x21C, + 0x21E, 0x220, 0x222, 0x224, 0x226, 0x228, 0x22A, 0x22C, 0x22E, + 0x230, 0x232, 0x23A, 0x23B, 0x23D, 0x23E, 0x241, 0x248, 0x24A, + 0x24C, 0x24E, 0x370, 0x372, 0x376, 0x37F, 0x386, 0x38C, 0x38E, + 0x38F, 0x3CF, 0x3D8, 0x3DA, 0x3DC, 0x3DE, 0x3E0, 0x3E2, 0x3E4, + 0x3E6, 0x3E8, 0x3EA, 0x3EC, 0x3EE, 0x3F4, 0x3F7, 0x3F9, 0x3FA, + 0x460, 0x462, 0x464, 0x466, 0x468, 0x46A, 0x46C, 0x46E, 0x470, + 0x472, 0x474, 0x476, 0x478, 0x47A, 0x47C, 0x47E, 0x480, 0x48A, + 0x48C, 0x48E, 0x490, 0x492, 0x494, 0x496, 0x498, 0x49A, 0x49C, + 0x49E, 0x4A0, 0x4A2, 0x4A4, 0x4A6, 0x4A8, 0x4AA, 0x4AC, 0x4AE, + 0x4B0, 0x4B2, 0x4B4, 0x4B6, 0x4B8, 0x4BA, 0x4BC, 0x4BE, 0x4C0, + 0x4C1, 0x4C3, 0x4C5, 0x4C7, 0x4C9, 0x4CB, 0x4CD, 0x4D0, 0x4D2, + 0x4D4, 0x4D6, 0x4D8, 0x4DA, 0x4DC, 0x4DE, 0x4E0, 0x4E2, 0x4E4, + 0x4E6, 0x4E8, 0x4EA, 0x4EC, 0x4EE, 0x4F0, 0x4F2, 0x4F4, 0x4F6, + 0x4F8, 0x4FA, 0x4FC, 0x4FE, 0x500, 0x502, 0x504, 0x506, 0x508, + 0x50A, 0x50C, 0x50E, 0x510, 0x512, 0x514, 0x516, 0x518, 0x51A, + 0x51C, 0x51E, 0x520, 0x522, 0x524, 0x526, 0x528, 0x52A, 0x52C, + 0x52E, 0x10C7, 0x10CD, 0x1E00, 0x1E02, 0x1E04, 0x1E06, 0x1E08, 0x1E0A, + 0x1E0C, 0x1E0E, 0x1E10, 0x1E12, 0x1E14, 0x1E16, 0x1E18, 0x1E1A, 0x1E1C, + 0x1E1E, 0x1E20, 0x1E22, 0x1E24, 0x1E26, 0x1E28, 0x1E2A, 0x1E2C, 0x1E2E, + 0x1E30, 0x1E32, 0x1E34, 0x1E36, 0x1E38, 0x1E3A, 0x1E3C, 0x1E3E, 0x1E40, + 0x1E42, 0x1E44, 0x1E46, 0x1E48, 0x1E4A, 0x1E4C, 0x1E4E, 0x1E50, 0x1E52, + 0x1E54, 0x1E56, 0x1E58, 0x1E5A, 0x1E5C, 0x1E5E, 0x1E60, 0x1E62, 0x1E64, + 0x1E66, 0x1E68, 0x1E6A, 0x1E6C, 0x1E6E, 0x1E70, 0x1E72, 0x1E74, 0x1E76, + 0x1E78, 0x1E7A, 0x1E7C, 0x1E7E, 0x1E80, 0x1E82, 0x1E84, 0x1E86, 0x1E88, + 0x1E8A, 0x1E8C, 0x1E8E, 0x1E90, 0x1E92, 0x1E94, 0x1E9E, 0x1EA0, 0x1EA2, + 0x1EA4, 0x1EA6, 0x1EA8, 0x1EAA, 0x1EAC, 0x1EAE, 0x1EB0, 0x1EB2, 0x1EB4, + 0x1EB6, 0x1EB8, 0x1EBA, 0x1EBC, 0x1EBE, 0x1EC0, 0x1EC2, 0x1EC4, 0x1EC6, + 0x1EC8, 0x1ECA, 0x1ECC, 0x1ECE, 0x1ED0, 0x1ED2, 0x1ED4, 0x1ED6, 0x1ED8, + 0x1EDA, 0x1EDC, 0x1EDE, 0x1EE0, 0x1EE2, 0x1EE4, 0x1EE6, 0x1EE8, 0x1EEA, + 0x1EEC, 0x1EEE, 0x1EF0, 0x1EF2, 0x1EF4, 0x1EF6, 0x1EF8, 0x1EFA, 0x1EFC, + 0x1EFE, 0x1F59, 0x1F5B, 0x1F5D, 0x1F5F, 0x2102, 0x2107, 0x2115, 0x2124, + 0x2126, 0x2128, 0x213E, 0x213F, 0x2145, 0x2183, 0x2C60, 0x2C67, 0x2C69, + 0x2C6B, 0x2C72, 0x2C75, 0x2C82, 0x2C84, 0x2C86, 0x2C88, 0x2C8A, 0x2C8C, + 0x2C8E, 0x2C90, 0x2C92, 0x2C94, 0x2C96, 0x2C98, 0x2C9A, 0x2C9C, 0x2C9E, + 0x2CA0, 0x2CA2, 0x2CA4, 0x2CA6, 0x2CA8, 0x2CAA, 0x2CAC, 0x2CAE, 0x2CB0, + 0x2CB2, 0x2CB4, 0x2CB6, 0x2CB8, 0x2CBA, 0x2CBC, 0x2CBE, 0x2CC0, 0x2CC2, + 0x2CC4, 0x2CC6, 0x2CC8, 0x2CCA, 0x2CCC, 0x2CCE, 0x2CD0, 0x2CD2, 0x2CD4, + 0x2CD6, 0x2CD8, 0x2CDA, 0x2CDC, 0x2CDE, 0x2CE0, 0x2CE2, 0x2CEB, 0x2CED, + 0x2CF2, 0xA640, 0xA642, 0xA644, 0xA646, 0xA648, 0xA64A, 0xA64C, 0xA64E, + 0xA650, 0xA652, 0xA654, 0xA656, 0xA658, 0xA65A, 0xA65C, 0xA65E, 0xA660, + 0xA662, 0xA664, 0xA666, 0xA668, 0xA66A, 0xA66C, 0xA680, 0xA682, 0xA684, + 0xA686, 0xA688, 0xA68A, 0xA68C, 0xA68E, 0xA690, 0xA692, 0xA694, 0xA696, + 0xA698, 0xA69A, 0xA722, 0xA724, 0xA726, 0xA728, 0xA72A, 0xA72C, 0xA72E, + 0xA732, 0xA734, 0xA736, 0xA738, 0xA73A, 0xA73C, 0xA73E, 0xA740, 0xA742, + 0xA744, 0xA746, 0xA748, 0xA74A, 0xA74C, 0xA74E, 0xA750, 0xA752, 0xA754, + 0xA756, 0xA758, 0xA75A, 0xA75C, 0xA75E, 0xA760, 0xA762, 0xA764, 0xA766, + 0xA768, 0xA76A, 0xA76C, 0xA76E, 0xA779, 0xA77B, 0xA77D, 0xA77E, 0xA780, + 0xA782, 0xA784, 0xA786, 0xA78B, 0xA78D, 0xA790, 0xA792, 0xA796, 0xA798, + 0xA79A, 0xA79C, 0xA79E, 0xA7A0, 0xA7A2, 0xA7A4, 0xA7A6, 0xA7A8, 0xA7B6, + 0xA7B8, 0xA7BA, 0xA7BC, 0xA7BE, 0xA7C2, 0xA7C9, 0xA7F5 #if CHRBITS > 16 - ,0x1d49c, 0x1d49e, 0x1d49f, 0x1d4a2, 0x1d4a5, 0x1d4a6, 0x1d504, 0x1d505, 0x1d538, - 0x1d539, 0x1d546, 0x1d7ca + ,0x1D49C, 0x1D49E, 0x1D49F, 0x1D4A2, 0x1D4A5, 0x1D4A6, 0x1D504, 0x1D505, 0x1D538, + 0x1D539, 0x1D546, 0x1D7CA #endif }; #define NUM_UPPER_CHAR (sizeof(upperCharTable)/sizeof(chr)) @@ -621,185 +625,190 @@ /* * Unicode: unicode print characters excluding space. */ static const crange graphRangeTable[] = { - {0x21, 0x7e}, {0xa1, 0xac}, {0xae, 0x377}, {0x37a, 0x37f}, - {0x384, 0x38a}, {0x38e, 0x3a1}, {0x3a3, 0x52f}, {0x531, 0x556}, - {0x559, 0x58a}, {0x58d, 0x58f}, {0x591, 0x5c7}, {0x5d0, 0x5ea}, - {0x5ef, 0x5f4}, {0x606, 0x61b}, {0x61e, 0x6dc}, {0x6de, 0x70d}, - {0x710, 0x74a}, {0x74d, 0x7b1}, {0x7c0, 0x7fa}, {0x7fd, 0x82d}, - {0x830, 0x83e}, {0x840, 0x85b}, {0x860, 0x86a}, {0x8a0, 0x8b4}, - {0x8b6, 0x8bd}, {0x8d3, 0x8e1}, {0x8e3, 0x983}, {0x985, 0x98c}, - {0x993, 0x9a8}, {0x9aa, 0x9b0}, {0x9b6, 0x9b9}, {0x9bc, 0x9c4}, - {0x9cb, 0x9ce}, {0x9df, 0x9e3}, {0x9e6, 0x9fe}, {0xa01, 0xa03}, - {0xa05, 0xa0a}, {0xa13, 0xa28}, {0xa2a, 0xa30}, {0xa3e, 0xa42}, - {0xa4b, 0xa4d}, {0xa59, 0xa5c}, {0xa66, 0xa76}, {0xa81, 0xa83}, - {0xa85, 0xa8d}, {0xa8f, 0xa91}, {0xa93, 0xaa8}, {0xaaa, 0xab0}, - {0xab5, 0xab9}, {0xabc, 0xac5}, {0xac7, 0xac9}, {0xacb, 0xacd}, - {0xae0, 0xae3}, {0xae6, 0xaf1}, {0xaf9, 0xaff}, {0xb01, 0xb03}, - {0xb05, 0xb0c}, {0xb13, 0xb28}, {0xb2a, 0xb30}, {0xb35, 0xb39}, - {0xb3c, 0xb44}, {0xb4b, 0xb4d}, {0xb5f, 0xb63}, {0xb66, 0xb77}, - {0xb85, 0xb8a}, {0xb8e, 0xb90}, {0xb92, 0xb95}, {0xba8, 0xbaa}, - {0xbae, 0xbb9}, {0xbbe, 0xbc2}, {0xbc6, 0xbc8}, {0xbca, 0xbcd}, - {0xbe6, 0xbfa}, {0xc00, 0xc0c}, {0xc0e, 0xc10}, {0xc12, 0xc28}, - {0xc2a, 0xc39}, {0xc3d, 0xc44}, {0xc46, 0xc48}, {0xc4a, 0xc4d}, - {0xc58, 0xc5a}, {0xc60, 0xc63}, {0xc66, 0xc6f}, {0xc77, 0xc8c}, - {0xc8e, 0xc90}, {0xc92, 0xca8}, {0xcaa, 0xcb3}, {0xcb5, 0xcb9}, - {0xcbc, 0xcc4}, {0xcc6, 0xcc8}, {0xcca, 0xccd}, {0xce0, 0xce3}, - {0xce6, 0xcef}, {0xd00, 0xd03}, {0xd05, 0xd0c}, {0xd0e, 0xd10}, - {0xd12, 0xd44}, {0xd46, 0xd48}, {0xd4a, 0xd4f}, {0xd54, 0xd63}, - {0xd66, 0xd7f}, {0xd85, 0xd96}, {0xd9a, 0xdb1}, {0xdb3, 0xdbb}, - {0xdc0, 0xdc6}, {0xdcf, 0xdd4}, {0xdd8, 0xddf}, {0xde6, 0xdef}, - {0xdf2, 0xdf4}, {0xe01, 0xe3a}, {0xe3f, 0xe5b}, {0xe86, 0xe8a}, - {0xe8c, 0xea3}, {0xea7, 0xebd}, {0xec0, 0xec4}, {0xec8, 0xecd}, - {0xed0, 0xed9}, {0xedc, 0xedf}, {0xf00, 0xf47}, {0xf49, 0xf6c}, - {0xf71, 0xf97}, {0xf99, 0xfbc}, {0xfbe, 0xfcc}, {0xfce, 0xfda}, - {0x1000, 0x10c5}, {0x10d0, 0x1248}, {0x124a, 0x124d}, {0x1250, 0x1256}, - {0x125a, 0x125d}, {0x1260, 0x1288}, {0x128a, 0x128d}, {0x1290, 0x12b0}, - {0x12b2, 0x12b5}, {0x12b8, 0x12be}, {0x12c2, 0x12c5}, {0x12c8, 0x12d6}, - {0x12d8, 0x1310}, {0x1312, 0x1315}, {0x1318, 0x135a}, {0x135d, 0x137c}, - {0x1380, 0x1399}, {0x13a0, 0x13f5}, {0x13f8, 0x13fd}, {0x1400, 0x167f}, - {0x1681, 0x169c}, {0x16a0, 0x16f8}, {0x1700, 0x170c}, {0x170e, 0x1714}, - {0x1720, 0x1736}, {0x1740, 0x1753}, {0x1760, 0x176c}, {0x176e, 0x1770}, - {0x1780, 0x17dd}, {0x17e0, 0x17e9}, {0x17f0, 0x17f9}, {0x1800, 0x180d}, - {0x1810, 0x1819}, {0x1820, 0x1878}, {0x1880, 0x18aa}, {0x18b0, 0x18f5}, - {0x1900, 0x191e}, {0x1920, 0x192b}, {0x1930, 0x193b}, {0x1944, 0x196d}, - {0x1970, 0x1974}, {0x1980, 0x19ab}, {0x19b0, 0x19c9}, {0x19d0, 0x19da}, - {0x19de, 0x1a1b}, {0x1a1e, 0x1a5e}, {0x1a60, 0x1a7c}, {0x1a7f, 0x1a89}, - {0x1a90, 0x1a99}, {0x1aa0, 0x1aad}, {0x1ab0, 0x1abe}, {0x1b00, 0x1b4b}, - {0x1b50, 0x1b7c}, {0x1b80, 0x1bf3}, {0x1bfc, 0x1c37}, {0x1c3b, 0x1c49}, - {0x1c4d, 0x1c88}, {0x1c90, 0x1cba}, {0x1cbd, 0x1cc7}, {0x1cd0, 0x1cfa}, - {0x1d00, 0x1df9}, {0x1dfb, 0x1f15}, {0x1f18, 0x1f1d}, {0x1f20, 0x1f45}, - {0x1f48, 0x1f4d}, {0x1f50, 0x1f57}, {0x1f5f, 0x1f7d}, {0x1f80, 0x1fb4}, - {0x1fb6, 0x1fc4}, {0x1fc6, 0x1fd3}, {0x1fd6, 0x1fdb}, {0x1fdd, 0x1fef}, - {0x1ff2, 0x1ff4}, {0x1ff6, 0x1ffe}, {0x2010, 0x2027}, {0x2030, 0x205e}, - {0x2074, 0x208e}, {0x2090, 0x209c}, {0x20a0, 0x20bf}, {0x20d0, 0x20f0}, - {0x2100, 0x218b}, {0x2190, 0x2426}, {0x2440, 0x244a}, {0x2460, 0x2b73}, - {0x2b76, 0x2b95}, {0x2b98, 0x2c2e}, {0x2c30, 0x2c5e}, {0x2c60, 0x2cf3}, - {0x2cf9, 0x2d25}, {0x2d30, 0x2d67}, {0x2d7f, 0x2d96}, {0x2da0, 0x2da6}, - {0x2da8, 0x2dae}, {0x2db0, 0x2db6}, {0x2db8, 0x2dbe}, {0x2dc0, 0x2dc6}, - {0x2dc8, 0x2dce}, {0x2dd0, 0x2dd6}, {0x2dd8, 0x2dde}, {0x2de0, 0x2e4f}, - {0x2e80, 0x2e99}, {0x2e9b, 0x2ef3}, {0x2f00, 0x2fd5}, {0x2ff0, 0x2ffb}, - {0x3001, 0x303f}, {0x3041, 0x3096}, {0x3099, 0x30ff}, {0x3105, 0x312f}, - {0x3131, 0x318e}, {0x3190, 0x31ba}, {0x31c0, 0x31e3}, {0x31f0, 0x321e}, - {0x3220, 0x4db5}, {0x4dc0, 0x9fef}, {0xa000, 0xa48c}, {0xa490, 0xa4c6}, - {0xa4d0, 0xa62b}, {0xa640, 0xa6f7}, {0xa700, 0xa7bf}, {0xa7c2, 0xa7c6}, - {0xa7f7, 0xa82b}, {0xa830, 0xa839}, {0xa840, 0xa877}, {0xa880, 0xa8c5}, - {0xa8ce, 0xa8d9}, {0xa8e0, 0xa953}, {0xa95f, 0xa97c}, {0xa980, 0xa9cd}, - {0xa9cf, 0xa9d9}, {0xa9de, 0xa9fe}, {0xaa00, 0xaa36}, {0xaa40, 0xaa4d}, - {0xaa50, 0xaa59}, {0xaa5c, 0xaac2}, {0xaadb, 0xaaf6}, {0xab01, 0xab06}, - {0xab09, 0xab0e}, {0xab11, 0xab16}, {0xab20, 0xab26}, {0xab28, 0xab2e}, - {0xab30, 0xab67}, {0xab70, 0xabed}, {0xabf0, 0xabf9}, {0xac00, 0xd7a3}, - {0xd7b0, 0xd7c6}, {0xd7cb, 0xd7fb}, {0xf900, 0xfa6d}, {0xfa70, 0xfad9}, - {0xfb00, 0xfb06}, {0xfb13, 0xfb17}, {0xfb1d, 0xfb36}, {0xfb38, 0xfb3c}, - {0xfb46, 0xfbc1}, {0xfbd3, 0xfd3f}, {0xfd50, 0xfd8f}, {0xfd92, 0xfdc7}, - {0xfdf0, 0xfdfd}, {0xfe00, 0xfe19}, {0xfe20, 0xfe52}, {0xfe54, 0xfe66}, - {0xfe68, 0xfe6b}, {0xfe70, 0xfe74}, {0xfe76, 0xfefc}, {0xff01, 0xffbe}, - {0xffc2, 0xffc7}, {0xffca, 0xffcf}, {0xffd2, 0xffd7}, {0xffda, 0xffdc}, - {0xffe0, 0xffe6}, {0xffe8, 0xffee} + {0x21, 0x7E}, {0xA1, 0xAC}, {0xAE, 0x377}, {0x37A, 0x37F}, + {0x384, 0x38A}, {0x38E, 0x3A1}, {0x3A3, 0x52F}, {0x531, 0x556}, + {0x559, 0x58A}, {0x58D, 0x58F}, {0x591, 0x5C7}, {0x5D0, 0x5EA}, + {0x5EF, 0x5F4}, {0x606, 0x61B}, {0x61E, 0x6DC}, {0x6DE, 0x70D}, + {0x710, 0x74A}, {0x74D, 0x7B1}, {0x7C0, 0x7FA}, {0x7FD, 0x82D}, + {0x830, 0x83E}, {0x840, 0x85B}, {0x860, 0x86A}, {0x8A0, 0x8B4}, + {0x8B6, 0x8C7}, {0x8D3, 0x8E1}, {0x8E3, 0x983}, {0x985, 0x98C}, + {0x993, 0x9A8}, {0x9AA, 0x9B0}, {0x9B6, 0x9B9}, {0x9BC, 0x9C4}, + {0x9CB, 0x9CE}, {0x9DF, 0x9E3}, {0x9E6, 0x9FE}, {0xA01, 0xA03}, + {0xA05, 0xA0A}, {0xA13, 0xA28}, {0xA2A, 0xA30}, {0xA3E, 0xA42}, + {0xA4B, 0xA4D}, {0xA59, 0xA5C}, {0xA66, 0xA76}, {0xA81, 0xA83}, + {0xA85, 0xA8D}, {0xA8F, 0xA91}, {0xA93, 0xAA8}, {0xAAA, 0xAB0}, + {0xAB5, 0xAB9}, {0xABC, 0xAC5}, {0xAC7, 0xAC9}, {0xACB, 0xACD}, + {0xAE0, 0xAE3}, {0xAE6, 0xAF1}, {0xAF9, 0xAFF}, {0xB01, 0xB03}, + {0xB05, 0xB0C}, {0xB13, 0xB28}, {0xB2A, 0xB30}, {0xB35, 0xB39}, + {0xB3C, 0xB44}, {0xB4B, 0xB4D}, {0xB55, 0xB57}, {0xB5F, 0xB63}, + {0xB66, 0xB77}, {0xB85, 0xB8A}, {0xB8E, 0xB90}, {0xB92, 0xB95}, + {0xBA8, 0xBAA}, {0xBAE, 0xBB9}, {0xBBE, 0xBC2}, {0xBC6, 0xBC8}, + {0xBCA, 0xBCD}, {0xBE6, 0xBFA}, {0xC00, 0xC0C}, {0xC0E, 0xC10}, + {0xC12, 0xC28}, {0xC2A, 0xC39}, {0xC3D, 0xC44}, {0xC46, 0xC48}, + {0xC4A, 0xC4D}, {0xC58, 0xC5A}, {0xC60, 0xC63}, {0xC66, 0xC6F}, + {0xC77, 0xC8C}, {0xC8E, 0xC90}, {0xC92, 0xCA8}, {0xCAA, 0xCB3}, + {0xCB5, 0xCB9}, {0xCBC, 0xCC4}, {0xCC6, 0xCC8}, {0xCCA, 0xCCD}, + {0xCE0, 0xCE3}, {0xCE6, 0xCEF}, {0xD00, 0xD0C}, {0xD0E, 0xD10}, + {0xD12, 0xD44}, {0xD46, 0xD48}, {0xD4A, 0xD4F}, {0xD54, 0xD63}, + {0xD66, 0xD7F}, {0xD81, 0xD83}, {0xD85, 0xD96}, {0xD9A, 0xDB1}, + {0xDB3, 0xDBB}, {0xDC0, 0xDC6}, {0xDCF, 0xDD4}, {0xDD8, 0xDDF}, + {0xDE6, 0xDEF}, {0xDF2, 0xDF4}, {0xE01, 0xE3A}, {0xE3F, 0xE5B}, + {0xE86, 0xE8A}, {0xE8C, 0xEA3}, {0xEA7, 0xEBD}, {0xEC0, 0xEC4}, + {0xEC8, 0xECD}, {0xED0, 0xED9}, {0xEDC, 0xEDF}, {0xF00, 0xF47}, + {0xF49, 0xF6C}, {0xF71, 0xF97}, {0xF99, 0xFBC}, {0xFBE, 0xFCC}, + {0xFCE, 0xFDA}, {0x1000, 0x10C5}, {0x10D0, 0x1248}, {0x124A, 0x124D}, + {0x1250, 0x1256}, {0x125A, 0x125D}, {0x1260, 0x1288}, {0x128A, 0x128D}, + {0x1290, 0x12B0}, {0x12B2, 0x12B5}, {0x12B8, 0x12BE}, {0x12C2, 0x12C5}, + {0x12C8, 0x12D6}, {0x12D8, 0x1310}, {0x1312, 0x1315}, {0x1318, 0x135A}, + {0x135D, 0x137C}, {0x1380, 0x1399}, {0x13A0, 0x13F5}, {0x13F8, 0x13FD}, + {0x1400, 0x167F}, {0x1681, 0x169C}, {0x16A0, 0x16F8}, {0x1700, 0x170C}, + {0x170E, 0x1714}, {0x1720, 0x1736}, {0x1740, 0x1753}, {0x1760, 0x176C}, + {0x176E, 0x1770}, {0x1780, 0x17DD}, {0x17E0, 0x17E9}, {0x17F0, 0x17F9}, + {0x1800, 0x180D}, {0x1810, 0x1819}, {0x1820, 0x1878}, {0x1880, 0x18AA}, + {0x18B0, 0x18F5}, {0x1900, 0x191E}, {0x1920, 0x192B}, {0x1930, 0x193B}, + {0x1944, 0x196D}, {0x1970, 0x1974}, {0x1980, 0x19AB}, {0x19B0, 0x19C9}, + {0x19D0, 0x19DA}, {0x19DE, 0x1A1B}, {0x1A1E, 0x1A5E}, {0x1A60, 0x1A7C}, + {0x1A7F, 0x1A89}, {0x1A90, 0x1A99}, {0x1AA0, 0x1AAD}, {0x1AB0, 0x1AC0}, + {0x1B00, 0x1B4B}, {0x1B50, 0x1B7C}, {0x1B80, 0x1BF3}, {0x1BFC, 0x1C37}, + {0x1C3B, 0x1C49}, {0x1C4D, 0x1C88}, {0x1C90, 0x1CBA}, {0x1CBD, 0x1CC7}, + {0x1CD0, 0x1CFA}, {0x1D00, 0x1DF9}, {0x1DFB, 0x1F15}, {0x1F18, 0x1F1D}, + {0x1F20, 0x1F45}, {0x1F48, 0x1F4D}, {0x1F50, 0x1F57}, {0x1F5F, 0x1F7D}, + {0x1F80, 0x1FB4}, {0x1FB6, 0x1FC4}, {0x1FC6, 0x1FD3}, {0x1FD6, 0x1FDB}, + {0x1FDD, 0x1FEF}, {0x1FF2, 0x1FF4}, {0x1FF6, 0x1FFE}, {0x2010, 0x2027}, + {0x2030, 0x205E}, {0x2074, 0x208E}, {0x2090, 0x209C}, {0x20A0, 0x20BF}, + {0x20D0, 0x20F0}, {0x2100, 0x218B}, {0x2190, 0x2426}, {0x2440, 0x244A}, + {0x2460, 0x2B73}, {0x2B76, 0x2B95}, {0x2B97, 0x2C2E}, {0x2C30, 0x2C5E}, + {0x2C60, 0x2CF3}, {0x2CF9, 0x2D25}, {0x2D30, 0x2D67}, {0x2D7F, 0x2D96}, + {0x2DA0, 0x2DA6}, {0x2DA8, 0x2DAE}, {0x2DB0, 0x2DB6}, {0x2DB8, 0x2DBE}, + {0x2DC0, 0x2DC6}, {0x2DC8, 0x2DCE}, {0x2DD0, 0x2DD6}, {0x2DD8, 0x2DDE}, + {0x2DE0, 0x2E52}, {0x2E80, 0x2E99}, {0x2E9B, 0x2EF3}, {0x2F00, 0x2FD5}, + {0x2FF0, 0x2FFB}, {0x3001, 0x303F}, {0x3041, 0x3096}, {0x3099, 0x30FF}, + {0x3105, 0x312F}, {0x3131, 0x318E}, {0x3190, 0x31E3}, {0x31F0, 0x321E}, + {0x3220, 0x9FFC}, {0xA000, 0xA48C}, {0xA490, 0xA4C6}, {0xA4D0, 0xA62B}, + {0xA640, 0xA6F7}, {0xA700, 0xA7BF}, {0xA7C2, 0xA7CA}, {0xA7F5, 0xA82C}, + {0xA830, 0xA839}, {0xA840, 0xA877}, {0xA880, 0xA8C5}, {0xA8CE, 0xA8D9}, + {0xA8E0, 0xA953}, {0xA95F, 0xA97C}, {0xA980, 0xA9CD}, {0xA9CF, 0xA9D9}, + {0xA9DE, 0xA9FE}, {0xAA00, 0xAA36}, {0xAA40, 0xAA4D}, {0xAA50, 0xAA59}, + {0xAA5C, 0xAAC2}, {0xAADB, 0xAAF6}, {0xAB01, 0xAB06}, {0xAB09, 0xAB0E}, + {0xAB11, 0xAB16}, {0xAB20, 0xAB26}, {0xAB28, 0xAB2E}, {0xAB30, 0xAB6B}, + {0xAB70, 0xABED}, {0xABF0, 0xABF9}, {0xAC00, 0xD7A3}, {0xD7B0, 0xD7C6}, + {0xD7CB, 0xD7FB}, {0xF900, 0xFA6D}, {0xFA70, 0xFAD9}, {0xFB00, 0xFB06}, + {0xFB13, 0xFB17}, {0xFB1D, 0xFB36}, {0xFB38, 0xFB3C}, {0xFB46, 0xFBC1}, + {0xFBD3, 0xFD3F}, {0xFD50, 0xFD8F}, {0xFD92, 0xFDC7}, {0xFDF0, 0xFDFD}, + {0xFE00, 0xFE19}, {0xFE20, 0xFE52}, {0xFE54, 0xFE66}, {0xFE68, 0xFE6B}, + {0xFE70, 0xFE74}, {0xFE76, 0xFEFC}, {0xFF01, 0xFFBE}, {0xFFC2, 0xFFC7}, + {0xFFCA, 0xFFCF}, {0xFFD2, 0xFFD7}, {0xFFDA, 0xFFDC}, {0xFFE0, 0xFFE6}, + {0xFFE8, 0xFFEE} #if CHRBITS > 16 - ,{0x10000, 0x1000b}, {0x1000d, 0x10026}, {0x10028, 0x1003a}, {0x1003f, 0x1004d}, - {0x10050, 0x1005d}, {0x10080, 0x100fa}, {0x10100, 0x10102}, {0x10107, 0x10133}, - {0x10137, 0x1018e}, {0x10190, 0x1019b}, {0x101d0, 0x101fd}, {0x10280, 0x1029c}, - {0x102a0, 0x102d0}, {0x102e0, 0x102fb}, {0x10300, 0x10323}, {0x1032d, 0x1034a}, - {0x10350, 0x1037a}, {0x10380, 0x1039d}, {0x1039f, 0x103c3}, {0x103c8, 0x103d5}, - {0x10400, 0x1049d}, {0x104a0, 0x104a9}, {0x104b0, 0x104d3}, {0x104d8, 0x104fb}, + ,{0x10000, 0x1000B}, {0x1000D, 0x10026}, {0x10028, 0x1003A}, {0x1003F, 0x1004D}, + {0x10050, 0x1005D}, {0x10080, 0x100FA}, {0x10100, 0x10102}, {0x10107, 0x10133}, + {0x10137, 0x1018E}, {0x10190, 0x1019C}, {0x101D0, 0x101FD}, {0x10280, 0x1029C}, + {0x102A0, 0x102D0}, {0x102E0, 0x102FB}, {0x10300, 0x10323}, {0x1032D, 0x1034A}, + {0x10350, 0x1037A}, {0x10380, 0x1039D}, {0x1039F, 0x103C3}, {0x103C8, 0x103D5}, + {0x10400, 0x1049D}, {0x104A0, 0x104A9}, {0x104B0, 0x104D3}, {0x104D8, 0x104FB}, {0x10500, 0x10527}, {0x10530, 0x10563}, {0x10600, 0x10736}, {0x10740, 0x10755}, - {0x10760, 0x10767}, {0x10800, 0x10805}, {0x1080a, 0x10835}, {0x1083f, 0x10855}, - {0x10857, 0x1089e}, {0x108a7, 0x108af}, {0x108e0, 0x108f2}, {0x108fb, 0x1091b}, - {0x1091f, 0x10939}, {0x10980, 0x109b7}, {0x109bc, 0x109cf}, {0x109d2, 0x10a03}, - {0x10a0c, 0x10a13}, {0x10a15, 0x10a17}, {0x10a19, 0x10a35}, {0x10a38, 0x10a3a}, - {0x10a3f, 0x10a48}, {0x10a50, 0x10a58}, {0x10a60, 0x10a9f}, {0x10ac0, 0x10ae6}, - {0x10aeb, 0x10af6}, {0x10b00, 0x10b35}, {0x10b39, 0x10b55}, {0x10b58, 0x10b72}, - {0x10b78, 0x10b91}, {0x10b99, 0x10b9c}, {0x10ba9, 0x10baf}, {0x10c00, 0x10c48}, - {0x10c80, 0x10cb2}, {0x10cc0, 0x10cf2}, {0x10cfa, 0x10d27}, {0x10d30, 0x10d39}, - {0x10e60, 0x10e7e}, {0x10f00, 0x10f27}, {0x10f30, 0x10f59}, {0x10fe0, 0x10ff6}, - {0x11000, 0x1104d}, {0x11052, 0x1106f}, {0x1107f, 0x110bc}, {0x110be, 0x110c1}, - {0x110d0, 0x110e8}, {0x110f0, 0x110f9}, {0x11100, 0x11134}, {0x11136, 0x11146}, - {0x11150, 0x11176}, {0x11180, 0x111cd}, {0x111d0, 0x111df}, {0x111e1, 0x111f4}, - {0x11200, 0x11211}, {0x11213, 0x1123e}, {0x11280, 0x11286}, {0x1128a, 0x1128d}, - {0x1128f, 0x1129d}, {0x1129f, 0x112a9}, {0x112b0, 0x112ea}, {0x112f0, 0x112f9}, - {0x11300, 0x11303}, {0x11305, 0x1130c}, {0x11313, 0x11328}, {0x1132a, 0x11330}, - {0x11335, 0x11339}, {0x1133b, 0x11344}, {0x1134b, 0x1134d}, {0x1135d, 0x11363}, - {0x11366, 0x1136c}, {0x11370, 0x11374}, {0x11400, 0x11459}, {0x1145d, 0x1145f}, - {0x11480, 0x114c7}, {0x114d0, 0x114d9}, {0x11580, 0x115b5}, {0x115b8, 0x115dd}, - {0x11600, 0x11644}, {0x11650, 0x11659}, {0x11660, 0x1166c}, {0x11680, 0x116b8}, - {0x116c0, 0x116c9}, {0x11700, 0x1171a}, {0x1171d, 0x1172b}, {0x11730, 0x1173f}, - {0x11800, 0x1183b}, {0x118a0, 0x118f2}, {0x119a0, 0x119a7}, {0x119aa, 0x119d7}, - {0x119da, 0x119e4}, {0x11a00, 0x11a47}, {0x11a50, 0x11aa2}, {0x11ac0, 0x11af8}, - {0x11c00, 0x11c08}, {0x11c0a, 0x11c36}, {0x11c38, 0x11c45}, {0x11c50, 0x11c6c}, - {0x11c70, 0x11c8f}, {0x11c92, 0x11ca7}, {0x11ca9, 0x11cb6}, {0x11d00, 0x11d06}, - {0x11d0b, 0x11d36}, {0x11d3f, 0x11d47}, {0x11d50, 0x11d59}, {0x11d60, 0x11d65}, - {0x11d6a, 0x11d8e}, {0x11d93, 0x11d98}, {0x11da0, 0x11da9}, {0x11ee0, 0x11ef8}, - {0x11fc0, 0x11ff1}, {0x11fff, 0x12399}, {0x12400, 0x1246e}, {0x12470, 0x12474}, - {0x12480, 0x12543}, {0x13000, 0x1342e}, {0x14400, 0x14646}, {0x16800, 0x16a38}, - {0x16a40, 0x16a5e}, {0x16a60, 0x16a69}, {0x16ad0, 0x16aed}, {0x16af0, 0x16af5}, - {0x16b00, 0x16b45}, {0x16b50, 0x16b59}, {0x16b5b, 0x16b61}, {0x16b63, 0x16b77}, - {0x16b7d, 0x16b8f}, {0x16e40, 0x16e9a}, {0x16f00, 0x16f4a}, {0x16f4f, 0x16f87}, - {0x16f8f, 0x16f9f}, {0x16fe0, 0x16fe3}, {0x17000, 0x187f7}, {0x18800, 0x18af2}, - {0x1b000, 0x1b11e}, {0x1b150, 0x1b152}, {0x1b164, 0x1b167}, {0x1b170, 0x1b2fb}, - {0x1bc00, 0x1bc6a}, {0x1bc70, 0x1bc7c}, {0x1bc80, 0x1bc88}, {0x1bc90, 0x1bc99}, - {0x1bc9c, 0x1bc9f}, {0x1d000, 0x1d0f5}, {0x1d100, 0x1d126}, {0x1d129, 0x1d172}, - {0x1d17b, 0x1d1e8}, {0x1d200, 0x1d245}, {0x1d2e0, 0x1d2f3}, {0x1d300, 0x1d356}, - {0x1d360, 0x1d378}, {0x1d400, 0x1d454}, {0x1d456, 0x1d49c}, {0x1d4a9, 0x1d4ac}, - {0x1d4ae, 0x1d4b9}, {0x1d4bd, 0x1d4c3}, {0x1d4c5, 0x1d505}, {0x1d507, 0x1d50a}, - {0x1d50d, 0x1d514}, {0x1d516, 0x1d51c}, {0x1d51e, 0x1d539}, {0x1d53b, 0x1d53e}, - {0x1d540, 0x1d544}, {0x1d54a, 0x1d550}, {0x1d552, 0x1d6a5}, {0x1d6a8, 0x1d7cb}, - {0x1d7ce, 0x1da8b}, {0x1da9b, 0x1da9f}, {0x1daa1, 0x1daaf}, {0x1e000, 0x1e006}, - {0x1e008, 0x1e018}, {0x1e01b, 0x1e021}, {0x1e026, 0x1e02a}, {0x1e100, 0x1e12c}, - {0x1e130, 0x1e13d}, {0x1e140, 0x1e149}, {0x1e2c0, 0x1e2f9}, {0x1e800, 0x1e8c4}, - {0x1e8c7, 0x1e8d6}, {0x1e900, 0x1e94b}, {0x1e950, 0x1e959}, {0x1ec71, 0x1ecb4}, - {0x1ed01, 0x1ed3d}, {0x1ee00, 0x1ee03}, {0x1ee05, 0x1ee1f}, {0x1ee29, 0x1ee32}, - {0x1ee34, 0x1ee37}, {0x1ee4d, 0x1ee4f}, {0x1ee67, 0x1ee6a}, {0x1ee6c, 0x1ee72}, - {0x1ee74, 0x1ee77}, {0x1ee79, 0x1ee7c}, {0x1ee80, 0x1ee89}, {0x1ee8b, 0x1ee9b}, - {0x1eea1, 0x1eea3}, {0x1eea5, 0x1eea9}, {0x1eeab, 0x1eebb}, {0x1f000, 0x1f02b}, - {0x1f030, 0x1f093}, {0x1f0a0, 0x1f0ae}, {0x1f0b1, 0x1f0bf}, {0x1f0c1, 0x1f0cf}, - {0x1f0d1, 0x1f0f5}, {0x1f100, 0x1f10c}, {0x1f110, 0x1f16c}, {0x1f170, 0x1f1ac}, - {0x1f1e6, 0x1f202}, {0x1f210, 0x1f23b}, {0x1f240, 0x1f248}, {0x1f260, 0x1f265}, - {0x1f300, 0x1f6d5}, {0x1f6e0, 0x1f6ec}, {0x1f6f0, 0x1f6fa}, {0x1f700, 0x1f773}, - {0x1f780, 0x1f7d8}, {0x1f7e0, 0x1f7eb}, {0x1f800, 0x1f80b}, {0x1f810, 0x1f847}, - {0x1f850, 0x1f859}, {0x1f860, 0x1f887}, {0x1f890, 0x1f8ad}, {0x1f900, 0x1f90b}, - {0x1f90d, 0x1f971}, {0x1f973, 0x1f976}, {0x1f97a, 0x1f9a2}, {0x1f9a5, 0x1f9aa}, - {0x1f9ae, 0x1f9ca}, {0x1f9cd, 0x1fa53}, {0x1fa60, 0x1fa6d}, {0x1fa70, 0x1fa73}, - {0x1fa78, 0x1fa7a}, {0x1fa80, 0x1fa82}, {0x1fa90, 0x1fa95}, {0x20000, 0x2a6d6}, - {0x2a700, 0x2b734}, {0x2b740, 0x2b81d}, {0x2b820, 0x2cea1}, {0x2ceb0, 0x2ebe0}, - {0x2f800, 0x2fa1d}, {0xe0100, 0xe01ef} + {0x10760, 0x10767}, {0x10800, 0x10805}, {0x1080A, 0x10835}, {0x1083F, 0x10855}, + {0x10857, 0x1089E}, {0x108A7, 0x108AF}, {0x108E0, 0x108F2}, {0x108FB, 0x1091B}, + {0x1091F, 0x10939}, {0x10980, 0x109B7}, {0x109BC, 0x109CF}, {0x109D2, 0x10A03}, + {0x10A0C, 0x10A13}, {0x10A15, 0x10A17}, {0x10A19, 0x10A35}, {0x10A38, 0x10A3A}, + {0x10A3F, 0x10A48}, {0x10A50, 0x10A58}, {0x10A60, 0x10A9F}, {0x10AC0, 0x10AE6}, + {0x10AEB, 0x10AF6}, {0x10B00, 0x10B35}, {0x10B39, 0x10B55}, {0x10B58, 0x10B72}, + {0x10B78, 0x10B91}, {0x10B99, 0x10B9C}, {0x10BA9, 0x10BAF}, {0x10C00, 0x10C48}, + {0x10C80, 0x10CB2}, {0x10CC0, 0x10CF2}, {0x10CFA, 0x10D27}, {0x10D30, 0x10D39}, + {0x10E60, 0x10E7E}, {0x10E80, 0x10EA9}, {0x10EAB, 0x10EAD}, {0x10F00, 0x10F27}, + {0x10F30, 0x10F59}, {0x10FB0, 0x10FCB}, {0x10FE0, 0x10FF6}, {0x11000, 0x1104D}, + {0x11052, 0x1106F}, {0x1107F, 0x110BC}, {0x110BE, 0x110C1}, {0x110D0, 0x110E8}, + {0x110F0, 0x110F9}, {0x11100, 0x11134}, {0x11136, 0x11147}, {0x11150, 0x11176}, + {0x11180, 0x111DF}, {0x111E1, 0x111F4}, {0x11200, 0x11211}, {0x11213, 0x1123E}, + {0x11280, 0x11286}, {0x1128A, 0x1128D}, {0x1128F, 0x1129D}, {0x1129F, 0x112A9}, + {0x112B0, 0x112EA}, {0x112F0, 0x112F9}, {0x11300, 0x11303}, {0x11305, 0x1130C}, + {0x11313, 0x11328}, {0x1132A, 0x11330}, {0x11335, 0x11339}, {0x1133B, 0x11344}, + {0x1134B, 0x1134D}, {0x1135D, 0x11363}, {0x11366, 0x1136C}, {0x11370, 0x11374}, + {0x11400, 0x1145B}, {0x1145D, 0x11461}, {0x11480, 0x114C7}, {0x114D0, 0x114D9}, + {0x11580, 0x115B5}, {0x115B8, 0x115DD}, {0x11600, 0x11644}, {0x11650, 0x11659}, + {0x11660, 0x1166C}, {0x11680, 0x116B8}, {0x116C0, 0x116C9}, {0x11700, 0x1171A}, + {0x1171D, 0x1172B}, {0x11730, 0x1173F}, {0x11800, 0x1183B}, {0x118A0, 0x118F2}, + {0x118FF, 0x11906}, {0x1190C, 0x11913}, {0x11918, 0x11935}, {0x1193B, 0x11946}, + {0x11950, 0x11959}, {0x119A0, 0x119A7}, {0x119AA, 0x119D7}, {0x119DA, 0x119E4}, + {0x11A00, 0x11A47}, {0x11A50, 0x11AA2}, {0x11AC0, 0x11AF8}, {0x11C00, 0x11C08}, + {0x11C0A, 0x11C36}, {0x11C38, 0x11C45}, {0x11C50, 0x11C6C}, {0x11C70, 0x11C8F}, + {0x11C92, 0x11CA7}, {0x11CA9, 0x11CB6}, {0x11D00, 0x11D06}, {0x11D0B, 0x11D36}, + {0x11D3F, 0x11D47}, {0x11D50, 0x11D59}, {0x11D60, 0x11D65}, {0x11D6A, 0x11D8E}, + {0x11D93, 0x11D98}, {0x11DA0, 0x11DA9}, {0x11EE0, 0x11EF8}, {0x11FC0, 0x11FF1}, + {0x11FFF, 0x12399}, {0x12400, 0x1246E}, {0x12470, 0x12474}, {0x12480, 0x12543}, + {0x13000, 0x1342E}, {0x14400, 0x14646}, {0x16800, 0x16A38}, {0x16A40, 0x16A5E}, + {0x16A60, 0x16A69}, {0x16AD0, 0x16AED}, {0x16AF0, 0x16AF5}, {0x16B00, 0x16B45}, + {0x16B50, 0x16B59}, {0x16B5B, 0x16B61}, {0x16B63, 0x16B77}, {0x16B7D, 0x16B8F}, + {0x16E40, 0x16E9A}, {0x16F00, 0x16F4A}, {0x16F4F, 0x16F87}, {0x16F8F, 0x16F9F}, + {0x16FE0, 0x16FE4}, {0x17000, 0x187F7}, {0x18800, 0x18CD5}, {0x18D00, 0x18D08}, + {0x1B000, 0x1B11E}, {0x1B150, 0x1B152}, {0x1B164, 0x1B167}, {0x1B170, 0x1B2FB}, + {0x1BC00, 0x1BC6A}, {0x1BC70, 0x1BC7C}, {0x1BC80, 0x1BC88}, {0x1BC90, 0x1BC99}, + {0x1BC9C, 0x1BC9F}, {0x1D000, 0x1D0F5}, {0x1D100, 0x1D126}, {0x1D129, 0x1D172}, + {0x1D17B, 0x1D1E8}, {0x1D200, 0x1D245}, {0x1D2E0, 0x1D2F3}, {0x1D300, 0x1D356}, + {0x1D360, 0x1D378}, {0x1D400, 0x1D454}, {0x1D456, 0x1D49C}, {0x1D4A9, 0x1D4AC}, + {0x1D4AE, 0x1D4B9}, {0x1D4BD, 0x1D4C3}, {0x1D4C5, 0x1D505}, {0x1D507, 0x1D50A}, + {0x1D50D, 0x1D514}, {0x1D516, 0x1D51C}, {0x1D51E, 0x1D539}, {0x1D53B, 0x1D53E}, + {0x1D540, 0x1D544}, {0x1D54A, 0x1D550}, {0x1D552, 0x1D6A5}, {0x1D6A8, 0x1D7CB}, + {0x1D7CE, 0x1DA8B}, {0x1DA9B, 0x1DA9F}, {0x1DAA1, 0x1DAAF}, {0x1E000, 0x1E006}, + {0x1E008, 0x1E018}, {0x1E01B, 0x1E021}, {0x1E026, 0x1E02A}, {0x1E100, 0x1E12C}, + {0x1E130, 0x1E13D}, {0x1E140, 0x1E149}, {0x1E2C0, 0x1E2F9}, {0x1E800, 0x1E8C4}, + {0x1E8C7, 0x1E8D6}, {0x1E900, 0x1E94B}, {0x1E950, 0x1E959}, {0x1EC71, 0x1ECB4}, + {0x1ED01, 0x1ED3D}, {0x1EE00, 0x1EE03}, {0x1EE05, 0x1EE1F}, {0x1EE29, 0x1EE32}, + {0x1EE34, 0x1EE37}, {0x1EE4D, 0x1EE4F}, {0x1EE67, 0x1EE6A}, {0x1EE6C, 0x1EE72}, + {0x1EE74, 0x1EE77}, {0x1EE79, 0x1EE7C}, {0x1EE80, 0x1EE89}, {0x1EE8B, 0x1EE9B}, + {0x1EEA1, 0x1EEA3}, {0x1EEA5, 0x1EEA9}, {0x1EEAB, 0x1EEBB}, {0x1F000, 0x1F02B}, + {0x1F030, 0x1F093}, {0x1F0A0, 0x1F0AE}, {0x1F0B1, 0x1F0BF}, {0x1F0C1, 0x1F0CF}, + {0x1F0D1, 0x1F0F5}, {0x1F100, 0x1F1AD}, {0x1F1E6, 0x1F202}, {0x1F210, 0x1F23B}, + {0x1F240, 0x1F248}, {0x1F260, 0x1F265}, {0x1F300, 0x1F6D7}, {0x1F6E0, 0x1F6EC}, + {0x1F6F0, 0x1F6FC}, {0x1F700, 0x1F773}, {0x1F780, 0x1F7D8}, {0x1F7E0, 0x1F7EB}, + {0x1F800, 0x1F80B}, {0x1F810, 0x1F847}, {0x1F850, 0x1F859}, {0x1F860, 0x1F887}, + {0x1F890, 0x1F8AD}, {0x1F900, 0x1F978}, {0x1F97A, 0x1F9CB}, {0x1F9CD, 0x1FA53}, + {0x1FA60, 0x1FA6D}, {0x1FA70, 0x1FA74}, {0x1FA78, 0x1FA7A}, {0x1FA80, 0x1FA86}, + {0x1FA90, 0x1FAA8}, {0x1FAB0, 0x1FAB6}, {0x1FAC0, 0x1FAC2}, {0x1FAD0, 0x1FAD6}, + {0x1FB00, 0x1FB92}, {0x1FB94, 0x1FBCA}, {0x1FBF0, 0x1FBF9}, {0x20000, 0x2A6DD}, + {0x2A700, 0x2B734}, {0x2B740, 0x2B81D}, {0x2B820, 0x2CEA1}, {0x2CEB0, 0x2EBE0}, + {0x2F800, 0x2FA1D}, {0x30000, 0x3134A}, {0xE0100, 0xE01EF} #endif }; #define NUM_GRAPH_RANGE (sizeof(graphRangeTable)/sizeof(crange)) static const chr graphCharTable[] = { - 0x38c, 0x85e, 0x98f, 0x990, 0x9b2, 0x9c7, 0x9c8, 0x9d7, 0x9dc, - 0x9dd, 0xa0f, 0xa10, 0xa32, 0xa33, 0xa35, 0xa36, 0xa38, 0xa39, - 0xa3c, 0xa47, 0xa48, 0xa51, 0xa5e, 0xab2, 0xab3, 0xad0, 0xb0f, - 0xb10, 0xb32, 0xb33, 0xb47, 0xb48, 0xb56, 0xb57, 0xb5c, 0xb5d, - 0xb82, 0xb83, 0xb99, 0xb9a, 0xb9c, 0xb9e, 0xb9f, 0xba3, 0xba4, - 0xbd0, 0xbd7, 0xc55, 0xc56, 0xcd5, 0xcd6, 0xcde, 0xcf1, 0xcf2, - 0xd82, 0xd83, 0xdbd, 0xdca, 0xdd6, 0xe81, 0xe82, 0xe84, 0xea5, - 0xec6, 0x10c7, 0x10cd, 0x1258, 0x12c0, 0x1772, 0x1773, 0x1940, 0x1f59, - 0x1f5b, 0x1f5d, 0x2070, 0x2071, 0x2d27, 0x2d2d, 0x2d6f, 0x2d70, 0xfb3e, - 0xfb40, 0xfb41, 0xfb43, 0xfb44, 0xfffc, 0xfffd + 0x38C, 0x85E, 0x98F, 0x990, 0x9B2, 0x9C7, 0x9C8, 0x9D7, 0x9DC, + 0x9DD, 0xA0F, 0xA10, 0xA32, 0xA33, 0xA35, 0xA36, 0xA38, 0xA39, + 0xA3C, 0xA47, 0xA48, 0xA51, 0xA5E, 0xAB2, 0xAB3, 0xAD0, 0xB0F, + 0xB10, 0xB32, 0xB33, 0xB47, 0xB48, 0xB5C, 0xB5D, 0xB82, 0xB83, + 0xB99, 0xB9A, 0xB9C, 0xB9E, 0xB9F, 0xBA3, 0xBA4, 0xBD0, 0xBD7, + 0xC55, 0xC56, 0xCD5, 0xCD6, 0xCDE, 0xCF1, 0xCF2, 0xDBD, 0xDCA, + 0xDD6, 0xE81, 0xE82, 0xE84, 0xEA5, 0xEC6, 0x10C7, 0x10CD, 0x1258, + 0x12C0, 0x1772, 0x1773, 0x1940, 0x1F59, 0x1F5B, 0x1F5D, 0x2070, 0x2071, + 0x2D27, 0x2D2D, 0x2D6F, 0x2D70, 0xFB3E, 0xFB40, 0xFB41, 0xFB43, 0xFB44, + 0xFFFC, 0xFFFD #if CHRBITS > 16 - ,0x1003c, 0x1003d, 0x101a0, 0x1056f, 0x10808, 0x10837, 0x10838, 0x1083c, 0x108f4, - 0x108f5, 0x1093f, 0x10a05, 0x10a06, 0x11288, 0x1130f, 0x11310, 0x11332, 0x11333, - 0x11347, 0x11348, 0x11350, 0x11357, 0x1145b, 0x118ff, 0x11d08, 0x11d09, 0x11d3a, - 0x11d3c, 0x11d3d, 0x11d67, 0x11d68, 0x11d90, 0x11d91, 0x16a6e, 0x16a6f, 0x1d49e, - 0x1d49f, 0x1d4a2, 0x1d4a5, 0x1d4a6, 0x1d4bb, 0x1d546, 0x1e023, 0x1e024, 0x1e14e, - 0x1e14f, 0x1e2ff, 0x1e95e, 0x1e95f, 0x1ee21, 0x1ee22, 0x1ee24, 0x1ee27, 0x1ee39, - 0x1ee3b, 0x1ee42, 0x1ee47, 0x1ee49, 0x1ee4b, 0x1ee51, 0x1ee52, 0x1ee54, 0x1ee57, - 0x1ee59, 0x1ee5b, 0x1ee5d, 0x1ee5f, 0x1ee61, 0x1ee62, 0x1ee64, 0x1ee7e, 0x1eef0, - 0x1eef1, 0x1f250, 0x1f251 + ,0x1003C, 0x1003D, 0x101A0, 0x1056F, 0x10808, 0x10837, 0x10838, 0x1083C, 0x108F4, + 0x108F5, 0x1093F, 0x10A05, 0x10A06, 0x10EB0, 0x10EB1, 0x11288, 0x1130F, 0x11310, + 0x11332, 0x11333, 0x11347, 0x11348, 0x11350, 0x11357, 0x11909, 0x11915, 0x11916, + 0x11937, 0x11938, 0x11D08, 0x11D09, 0x11D3A, 0x11D3C, 0x11D3D, 0x11D67, 0x11D68, + 0x11D90, 0x11D91, 0x11FB0, 0x16A6E, 0x16A6F, 0x16FF0, 0x16FF1, 0x1D49E, 0x1D49F, + 0x1D4A2, 0x1D4A5, 0x1D4A6, 0x1D4BB, 0x1D546, 0x1E023, 0x1E024, 0x1E14E, 0x1E14F, + 0x1E2FF, 0x1E95E, 0x1E95F, 0x1EE21, 0x1EE22, 0x1EE24, 0x1EE27, 0x1EE39, 0x1EE3B, + 0x1EE42, 0x1EE47, 0x1EE49, 0x1EE4B, 0x1EE51, 0x1EE52, 0x1EE54, 0x1EE57, 0x1EE59, + 0x1EE5B, 0x1EE5D, 0x1EE5F, 0x1EE61, 0x1EE62, 0x1EE64, 0x1EE7E, 0x1EEF0, 0x1EEF1, + 0x1F250, 0x1F251, 0x1F8B0, 0x1F8B1 #endif }; #define NUM_GRAPH_CHAR (sizeof(graphCharTable)/sizeof(chr)) /* * End of auto-generated Unicode character ranges declarations. */ + +#define CH NOCELT /* - element - map collating-element name to celt ^ static celt element(struct vars *, const chr *, const chr *); */ @@ -829,11 +838,11 @@ /* * Search table. */ Tcl_DStringInit(&ds); - np = Tcl_UniCharToUtfDString(startp, len, &ds); + np = Tcl_UniCharToUtfDString(startp, (int)len, &ds); for (cn=cnames; cn->name!=NULL; cn++) { if (strlen(cn->name)==len && strncmp(cn->name, np, len)==0) { break; /* NOTE BREAK OUT */ } } @@ -888,13 +897,13 @@ cv = getcvec(v, nchrs, 0); NOERRN(); for (c=a; c<=b; c++) { addchr(cv, c); - lc = Tcl_UniCharToLower(c); - uc = Tcl_UniCharToUpper(c); - tc = Tcl_UniCharToTitle(c); + lc = Tcl_UniCharToLower((chr)c); + uc = Tcl_UniCharToUpper((chr)c); + tc = Tcl_UniCharToTitle((chr)c); if (c != lc) { addchr(cv, lc); } if (c != uc) { addchr(cv, uc); @@ -939,15 +948,15 @@ * Crude fake equivalence class for testing. */ if ((v->cflags®_FAKE) && c == 'x') { cv = getcvec(v, 4, 0); - addchr(cv, 'x'); - addchr(cv, 'y'); + addchr(cv, (chr)'x'); + addchr(cv, (chr)'y'); if (cases) { - addchr(cv, 'X'); - addchr(cv, 'Y'); + addchr(cv, (chr)'X'); + addchr(cv, (chr)'Y'); } return cv; } /* @@ -957,11 +966,11 @@ if (cases) { return allcases(v, c); } cv = getcvec(v, 1, 0); assert(cv != NULL); - addchr(cv, c); + addchr(cv, (chr)c); return cv; } /* - cclass - supply cvec for a character class @@ -978,12 +987,11 @@ size_t len; struct cvec *cv = NULL; Tcl_DString ds; const char *np; const char *const *namePtr; - size_t i; - int index; + int i, index; /* * The following arrays define the valid character class names. */ @@ -1002,11 +1010,11 @@ * Extract the class name */ len = endp - startp; Tcl_DStringInit(&ds); - np = Tcl_UniCharToUtfDString(startp, len, &ds); + np = Tcl_UniCharToUtfDString(startp, (int)len, &ds); /* * Map the name to the corresponding enumerated value. */ @@ -1037,39 +1045,39 @@ switch((enum classes) index) { case CC_ALNUM: cv = getcvec(v, NUM_ALPHA_CHAR, NUM_DIGIT_RANGE + NUM_ALPHA_RANGE); if (cv) { - for (i=0 ; iins == NULL); } /* - copyins - copy in arcs of a state to another state - ^ static void copyins(struct nfa *, struct state *, struct state *, int); + ^ static VOID copyins(struct nfa *, struct state *, struct state *, int); */ static void copyins( struct nfa *nfa, struct state *oldState, @@ -1098,11 +1098,11 @@ assert(oldState->outs == NULL); } /* - copyouts - copy out arcs of a state to another state - ^ static void copyouts(struct nfa *, struct state *, struct state *, int); + ^ static VOID copyouts(struct nfa *, struct state *, struct state *, int); */ static void copyouts( struct nfa *nfa, struct state *oldState, @@ -2976,10 +2976,13 @@ fprintf(f, "total of %d states, %d arcs\n", nstates, narcs); if (nfa->parent == NULL) { dumpcolors(nfa->cm, f); } fflush(f); +#else + (void)nfa; + (void)f; #endif } #ifdef REG_DEBUG /* subordinates of dumpnfa */ /* @@ -3155,10 +3158,13 @@ fprintf(f, "\n"); for (st = 0; st < cnfa->nstates; st++) { dumpcstate(st, cnfa, f); } fflush(f); +#else + (void)cnfa; + (void)f; #endif } #ifdef REG_DEBUG /* subordinates of dumpcnfa */ /* Index: generic/regcomp.c ================================================================== --- generic/regcomp.c +++ generic/regcomp.c @@ -37,11 +37,11 @@ */ /* =====^!^===== begin forwards =====^!^===== */ /* automatically gathered by fwd; do not hand-edit */ /* === regcomp.c === */ int compile(regex_t *, const chr *, size_t, int); -static void moresubs(struct vars *, size_t); +static void moresubs(struct vars *, int); static int freev(struct vars *, int); static void makesearch(struct vars *, struct nfa *); static struct subre *parse(struct vars *, int, int, struct state *, struct state *); static struct subre *parsebranch(struct vars *, int, int, struct state *, struct state *, int); static void parseqatom(struct vars *, int, int, struct state *, struct state *, struct subre *); @@ -57,11 +57,10 @@ static void dovec(struct vars *, struct cvec *, struct state *, struct state *); static void wordchrs(struct vars *); static struct subre *subre(struct vars *, int, int, struct state *, struct state *); static void freesubre(struct vars *, struct subre *); static void freesrnode(struct vars *, struct subre *); -static void optst(struct vars *, struct subre *); static int numst(struct subre *, int); static void markst(struct subre *); static void cleanst(struct vars *); static long nfatree(struct vars *, struct subre *, FILE *); static long nfanode(struct vars *, struct subre *, FILE *); @@ -80,11 +79,11 @@ static int next(struct vars *); static int lexescape(struct vars *); static int lexdigits(struct vars *, int, int, int); static int brenext(struct vars *, pchr); static void skip(struct vars *); -static chr newline(void); +static chr newline(NOPARMS); static chr chrnamed(struct vars *, const chr *, const chr *, pchr); /* === regc_color.c === */ static void initcm(struct vars *, struct colormap *); static void freecm(struct colormap *); static void cmtreefree(struct colormap *, union tree *, int); @@ -204,15 +203,15 @@ const chr *savestop; int err; /* error code (0 if none) */ int cflags; /* copy of compile flags */ int lasttype; /* type of previous token */ int nexttype; /* type of next token */ - int nextvalue; /* value (if any) of next token */ + chr nextvalue; /* value (if any) of next token */ int lexcon; /* lexical context type (see lex.c) */ int nsubexp; /* subexpression count */ struct subre **subs; /* subRE pointer vector */ - int nsubs; /* length of vector */ + size_t nsubs; /* length of vector */ struct subre *sub10[10]; /* initial vector, enough for most */ struct nfa *nfa; /* the NFA */ struct colormap *cm; /* character color map */ color nlcolor; /* color of newline */ struct state *wordchrs; /* state in nfa holding word-char outarcs */ @@ -242,10 +241,11 @@ #define INSIST(c, e) do { if (!(c)) ERR(e); } while (0) /* error if c false */ #define NOTE(b) (v->re->re_info |= (b)) /* note visible condition */ #define EMPTYARC(x, y) newarc(v->nfa, EMPTY, 0, x, y) /* token type codes, some also used as NFA arc types */ +#undef DIGIT /* prevent conflict with libtommath */ #define EMPTY 'n' /* no token present */ #define EOS 'e' /* end of string */ #define PLAIN 'p' /* ordinary character */ #define DIGIT 'd' /* digit (in bound) */ #define BACKREF 'b' /* back reference */ @@ -285,11 +285,12 @@ size_t len, int flags) { AllocVars(v); struct guts *g; - int i, j; + int i; + size_t j; FILE *debug = (flags®_PROGRESS) ? stdout : NULL; #define CNOERR() { if (ISERR()) return freev(v, v->err); } /* * Sanity checks. @@ -336,18 +337,19 @@ v->lacons = NULL; v->nlacons = 0; v->spaceused = 0; re->re_magic = REMAGIC; re->re_info = 0; /* bits get set during parse */ + re->re_csize = sizeof(chr); re->re_guts = NULL; - re->re_fns = (void*)(&functions); + re->re_fns = VS(&functions); /* * More complex setup, malloced things. */ - re->re_guts = (void*)(MALLOC(sizeof(struct guts))); + re->re_guts = VS(MALLOC(sizeof(struct guts))); if (re->re_guts == NULL) { return freev(v, REG_ESPACE); } g = (struct guts *) re->re_guts; g->tree = NULL; @@ -391,11 +393,10 @@ if (debug != NULL) { fprintf(debug, "\n\n\n========= RAW ==========\n"); dumpnfa(v->nfa, debug); dumpst(v->tree, debug, 1); } - optst(v, v->tree); v->ntree = numst(v->tree, 1); markst(v->tree); cleanst(v); if (debug != NULL) { fprintf(debug, "\n\n\n========= TREE FIXED ==========\n"); @@ -430,11 +431,11 @@ /* * Can sacrifice main NFA now, so use it as work area. */ - (void) optimize(v->nfa, debug); + (DISCARD) optimize(v->nfa, debug); CNOERR(); makesearch(v, v->nfa); CNOERR(); compact(v->nfa, &g->search); CNOERR(); @@ -465,22 +466,22 @@ return freev(v, 0); } /* - moresubs - enlarge subRE vector - ^ static void moresubs(struct vars *, size_t); + ^ static void moresubs(struct vars *, int); */ static void moresubs( struct vars *v, - size_t wanted) /* want enough room for this one */ + int wanted) /* want enough room for this one */ { struct subre **p; - int n; + size_t n; - assert(wanted > 0 && wanted >= v->nsubs); - n = wanted * 3 / 2 + 1; + assert(wanted > 0 && (size_t)wanted >= v->nsubs); + n = (size_t)wanted * 3 / 2 + 1; if (v->subs == v->sub10) { p = (struct subre **) MALLOC(n * sizeof(struct subre *)); if (p != NULL) { memcpy(p, v->subs, v->nsubs * sizeof(struct subre *)); } @@ -495,11 +496,11 @@ v->subs = p; for (p = &v->subs[v->nsubs]; v->nsubs < n; p++, v->nsubs++) { *p = NULL; } assert(v->nsubs == n); - assert(wanted < v->nsubs); + assert((size_t)wanted < v->nsubs); } /* - freev - free vars struct's substructures where necessary * Optionally does error-number setting, and always returns error code (if @@ -919,11 +920,11 @@ /* * Legal in EREs due to specification botch. */ NOTE(REG_UPBOTCH); - /* fallthrough into case PLAIN */ + /* FALLTHRU */ case PLAIN: onechr(v, v->nextvalue, lp, rp); okcolors(v->nfa, v->cm); NOERR(); NEXT(); @@ -950,14 +951,14 @@ case '(': /* value flags as capturing or non */ cap = (type == LACON) ? 0 : v->nextvalue; if (cap) { v->nsubexp++; subno = v->nsubexp; - if (subno >= v->nsubs) { + if ((size_t)subno >= v->nsubs) { moresubs(v, subno); } - assert(subno < v->nsubs); + assert((size_t)subno < v->nsubs); } else { atomtype = PLAIN; /* something that's not '(' */ } NEXT(); @@ -1806,29 +1807,10 @@ v->treefree = sr; } else { FREE(sr); } } - -/* - - optst - optimize a subRE subtree - ^ static void optst(struct vars *, struct subre *); - */ -static void -optst( - struct vars *v, - struct subre *t) -{ - /* - * DGP (2007-11-13): I assume it was the programmer's intent to eventually - * come back and add code to optimize subRE trees, but the routine coded - * just spends effort traversing the tree and doing nothing. We can do - * nothing with less effort. - */ - - return; -} /* - numst - number tree nodes (assigning "id" indexes) ^ static int numst(struct subre *, int); */ @@ -1916,14 +1898,14 @@ FILE *f) /* for debug output */ { assert(t != NULL && t->begin != NULL); if (t->left != NULL) { - (void) nfatree(v, t->left, f); + (DISCARD) nfatree(v, t->left, f); } if (t->right != NULL) { - (void) nfatree(v, t->right, f); + (DISCARD) nfatree(v, t->right, f); } return nfanode(v, t, f); } @@ -2082,12 +2064,12 @@ fprintf(f, "bad guts magic number (0x%x not 0x%x)\n", g->magic, GUTSMAGIC); } fprintf(f, "\n\n\n========= DUMP ==========\n"); - fprintf(f, "nsub %" TCL_Z_MODIFIER "d, info 0%lo, ntree %d\n", - re->re_nsub, re->re_info, g->ntree); + fprintf(f, "nsub %d, info 0%lo, csize %d, ntree %d\n", + (int) re->re_nsub, re->re_info, re->re_csize, g->ntree); dumpcolors(&g->cmap, f); if (!NULLCNFA(g->search)) { fprintf(f, "\nsearch:\n"); dumpcnfa(&g->search, f); @@ -2097,10 +2079,13 @@ (g->lacons[i].subno) ? "positive" : "negative"); dumpcnfa(&g->lacons[i].cnfa, f); } fprintf(f, "\n"); dumpst(g->tree, f, 0); +#else + (void)re; + (void)f; #endif } /* - dumpst - dump a subRE tree Index: generic/regcustom.h ================================================================== --- generic/regcustom.h +++ generic/regcustom.h @@ -34,13 +34,14 @@ /* * Overrides for regguts.h definitions, if any. */ -#define MALLOC(n) Tcl_AttemptAlloc(n) -#define FREE(p) Tcl_Free(p) -#define REALLOC(p,n) Tcl_AttemptRealloc(p,n) +#define FUNCPTR(name, args) (*name)args +#define MALLOC(n) VS(attemptckalloc(n)) +#define FREE(p) ckfree(VS(p)) +#define REALLOC(p,n) VS(attemptckrealloc(VS(p),n)) /* * Do not insert extras between the "begin" and "end" lines - this chunk is * automatically extracted to be fitted into regex.h. */ @@ -54,18 +55,22 @@ #undef __REG_WIDE_COMPILE #endif #ifdef __REG_WIDE_EXEC #undef __REG_WIDE_EXEC #endif +#ifdef __REG_REGOFF_T +#undef __REG_REGOFF_T +#endif #ifdef __REG_NOFRONT #undef __REG_NOFRONT #endif #ifdef __REG_NOCHAR #undef __REG_NOCHAR #endif /* Interface types */ #define __REG_WIDE_T Tcl_UniChar +#define __REG_REGOFF_T long /* Not really right, but good enough... */ /* Names and declarations */ #define __REG_WIDE_COMPILE TclReComp #define __REG_WIDE_EXEC TclReExec #define __REG_NOFRONT /* Don't want regcomp() and regexec() */ #define __REG_NOCHAR /* Or the char versions */ @@ -85,15 +90,15 @@ #define CHR(c) (UCHAR(c)) /* Turn char literal into chr literal */ #define DIGITVAL(c) ((c)-'0') /* Turn chr digit into its value */ #if TCL_UTF_MAX > 4 #define CHRBITS 32 /* Bits in a chr; must not use sizeof */ #define CHR_MIN 0x00000000 /* Smallest and largest chr; the value */ -#define CHR_MAX 0x10ffff /* CHR_MAX-CHR_MIN+1 should fit in uchr */ +#define CHR_MAX 0xFFFFFFFF /* CHR_MAX-CHR_MIN+1 should fit in uchr */ #else #define CHRBITS 16 /* Bits in a chr; must not use sizeof */ #define CHR_MIN 0x0000 /* Smallest and largest chr; the value */ -#define CHR_MAX 0xffff /* CHR_MAX-CHR_MIN+1 should fit in uchr */ +#define CHR_MAX 0xFFFF /* CHR_MAX-CHR_MIN+1 should fit in uchr */ #endif /* * Functions operating on chr. */ @@ -125,20 +130,20 @@ */ #if 1 #define AllocVars(vPtr) \ static Tcl_ThreadDataKey varsKey; \ - register struct vars *vPtr = (struct vars *) \ + struct vars *vPtr = (struct vars *) \ Tcl_GetThreadData(&varsKey, sizeof(struct vars)) #else /* * This strategy for allocating workspace is "more proper" in some sense, but * quite a bit slower. Using TSD (as above) leads to code that is quite a bit * faster in practice (measured!) */ #define AllocVars(vPtr) \ - register struct vars *vPtr = (struct vars *) MALLOC(sizeof(struct vars)) + struct vars *vPtr = (struct vars *) MALLOC(sizeof(struct vars)) #define FreeVars(vPtr) \ FREE(vPtr) #endif /* Index: generic/regerror.c ================================================================== --- generic/regerror.c +++ generic/regerror.c @@ -56,11 +56,10 @@ */ /* ARGSUSED */ size_t /* Actual space needed (including NUL) */ regerror( int code, /* Error code, or REG_ATOI or REG_ITOA */ - const regex_t *preg, /* Associated regex_t (unused at present) */ char *errbuf, /* Result buffer (unless errbuf_size==0) */ size_t errbuf_size) /* Available space in errbuf, can be 0 */ { const struct rerr *r; const char *msg; @@ -86,11 +85,11 @@ } } if (r->code >= 0) { msg = r->name; } else { /* Unknown; tell him the number */ - sprintf(convbuf, "REG_%u", icode); + sprintf(convbuf, "REG_%u", (unsigned)icode); msg = convbuf; } break; default: /* A real, normal error code */ for (r = rerrs; r->code >= 0; r++) { Index: generic/regex.h ================================================================== --- generic/regex.h +++ generic/regex.h @@ -87,18 +87,22 @@ #undef __REG_WIDE_COMPILE #endif #ifdef __REG_WIDE_EXEC #undef __REG_WIDE_EXEC #endif +#ifdef __REG_REGOFF_T +#undef __REG_REGOFF_T +#endif #ifdef __REG_NOFRONT #undef __REG_NOFRONT #endif #ifdef __REG_NOCHAR #undef __REG_NOCHAR #endif /* interface types */ #define __REG_WIDE_T Tcl_UniChar +#define __REG_REGOFF_T long /* not really right, but good enough... */ /* names and declarations */ #define __REG_WIDE_COMPILE TclReComp #define __REG_WIDE_EXEC TclReExec #define __REG_NOFRONT /* don't want regcomp() and regexec() */ #define __REG_NOCHAR /* or the char versions */ @@ -108,19 +112,30 @@ /* * interface types etc. */ +/* + * regoff_t has to be large enough to hold either off_t or ssize_t, and must + * be signed; it's only a guess that long is suitable, so we offer + * an override. + */ +#ifdef __REG_REGOFF_T +typedef __REG_REGOFF_T regoff_t; +#else +typedef long regoff_t; +#endif + /* * other interface types */ /* the biggie, a compiled RE (or rather, a front end to same) */ typedef struct { int re_magic; /* magic number */ - long re_info; /* information about RE */ size_t re_nsub; /* number of subexpressions */ + long re_info; /* information about RE */ #define REG_UBACKREF 000001 #define REG_ULOOKAHEAD 000002 #define REG_UBOUNDS 000004 #define REG_UBRACES 000010 #define REG_UBSALNUM 000020 @@ -131,20 +146,21 @@ #define REG_UUNPORT 001000 #define REG_ULOCALE 002000 #define REG_UEMPTYMATCH 004000 #define REG_UIMPOSSIBLE 010000 #define REG_USHORTEST 020000 + int re_csize; /* sizeof(character) */ char *re_endp; /* backward compatibility kludge */ /* the rest is opaque pointers to hidden innards */ char *re_guts; /* `char *' is more portable than `void *' */ char *re_fns; } regex_t; /* result reporting (may acquire more fields later) */ typedef struct { - size_t rm_so; /* start of substring */ - size_t rm_eo; /* end of substring */ + regoff_t rm_so; /* start of substring */ + regoff_t rm_eo; /* end of substring */ } regmatch_t; /* supplementary control and reporting */ typedef struct { regmatch_t rm_extend; /* see REG_EXPECT */ @@ -214,11 +230,11 @@ * * Note that there is no wide-char variant of regerror at this time; what kind * of character is used for error reports is independent of what kind is used * in matching. * - ^ extern size_t regerror(int, const regex_t *, char *, size_t); + ^ extern size_t regerror(int, char *, size_t); */ #define REG_OKAY 0 /* no errors detected */ #define REG_NOMATCH 1 /* failed to match */ #define REG_BADPAT 2 /* invalid regexp */ #define REG_ECOLLATE 3 /* invalid collating element */ @@ -265,11 +281,11 @@ #endif #ifdef __REG_WIDE_T MODULE_SCOPE int __REG_WIDE_EXEC(regex_t *, const __REG_WIDE_T *, size_t, rm_detail_t *, size_t, regmatch_t [], int); #endif MODULE_SCOPE void regfree(regex_t *); -MODULE_SCOPE size_t regerror(int, const regex_t *, char *, size_t); +MODULE_SCOPE size_t regerror(int, char *, size_t); /* automatically gathered by fwd; do not hand-edit */ /* =====^!^===== end forwards =====^!^===== */ /* * more C++ voodoo Index: generic/regexec.c ================================================================== --- generic/regexec.c +++ generic/regexec.c @@ -42,11 +42,11 @@ struct sset { /* state set */ unsigned *states; /* pointer to bitvector */ unsigned hash; /* hash of bitvector */ #define HASH(bv, nw) (((nw) == 1) ? *(bv) : hash(bv, nw)) #define HIT(h,bv,ss,nw) ((ss)->hash == (h) && ((nw) == 1 || \ - memcmp((void*)(bv), (void*)((ss)->states), (nw)*sizeof(unsigned)) == 0)) + memcmp(VS(bv), VS((ss)->states), (nw)*sizeof(unsigned)) == 0)) int flags; #define STARTER 01 /* the initial state set */ #define POSTSTATE 02 /* includes the goal state */ #define LOCKED 04 /* locked in cache */ #define NOPROGRESS 010 /* zero-progress state set */ @@ -71,11 +71,11 @@ struct colormap *cm; chr *lastpost; /* location of last cache-flushed success */ chr *lastnopr; /* location of last cache-flushed NOPROGRESS */ struct sset *search; /* replacement-search-pointer memory */ int cptsmalloced; /* were the areas individually malloced? */ - char *mallocarea; /* self, or master malloced area, or NULL */ + char *mallocarea; /* self, or malloced area, or NULL */ }; #define WORK 1 /* number of work bitvectors needed */ /* @@ -127,11 +127,11 @@ /* === regexec.c === */ int exec(regex_t *, const chr *, size_t, rm_detail_t *, size_t, regmatch_t [], int); static struct dfa *getsubdfa(struct vars *, struct subre *); static int simpleFind(struct vars *const, struct cnfa *const, struct colormap *const); static int complicatedFind(struct vars *const, struct cnfa *const, struct colormap *const); -static int complicatedFindLoop(struct vars *const, struct cnfa *const, struct colormap *const, struct dfa *const, struct dfa *const, chr **const); +static int complicatedFindLoop(struct vars *const, struct dfa *const, struct dfa *const, chr **const); static void zapallsubs(regmatch_t *const, const size_t); static void zaptreesubs(struct vars *const, struct subre *const); static void subset(struct vars *const, struct subre *const, chr *const, chr *const); static int cdissect(struct vars *, struct subre *, chr *, chr *); static int ccondissect(struct vars *, struct subre *, chr *, chr *); @@ -170,12 +170,12 @@ regmatch_t pmatch[], int flags) { AllocVars(v); int st, backref; - int n; - int i; + size_t n; + size_t i; #define LOCALMAT 20 regmatch_t mat[LOCALMAT]; #define LOCALDFAS 40 struct dfa *subdfas[LOCALDFAS]; @@ -184,10 +184,14 @@ */ if (re == NULL || string == NULL || re->re_magic != REMAGIC) { FreeVars(v); return REG_INVARG; + } + if (re->re_csize != sizeof(chr)) { + FreeVars(v); + return REG_MIXED; } /* * Setup. */ @@ -230,11 +234,11 @@ v->details = details; v->start = (chr *)string; v->stop = (chr *)string + len; v->err = 0; assert(v->g->ntree >= 0); - n = v->g->ntree; + n = (size_t) v->g->ntree; if (n <= LOCALDFAS) v->subdfas = subdfas; else v->subdfas = (struct dfa **) MALLOC(n * sizeof(struct dfa *)); if (v->subdfas == NULL) { @@ -262,21 +266,21 @@ */ if (st == REG_OKAY && v->pmatch != pmatch && nmatch > 0) { zapallsubs(pmatch, nmatch); n = (nmatch < v->nmatch) ? nmatch : v->nmatch; - memcpy((void*)(pmatch), (void*)(v->pmatch), n*sizeof(regmatch_t)); + memcpy(VS(pmatch), VS(v->pmatch), n*sizeof(regmatch_t)); } /* * Clean up. */ if (v->pmatch != pmatch && v->pmatch != mat) { FREE(v->pmatch); } - n = v->g->ntree; + n = (size_t) v->g->ntree; for (i = 0; i < n; i++) { if (v->subdfas[i] != NULL) freeDFA(v->subdfas[i]); } if (v->subdfas != subdfas) @@ -428,11 +432,11 @@ assert(d == NULL); freeDFA(s); return v->err; } - ret = complicatedFindLoop(v, cnfa, cm, d, s, &cold); + ret = complicatedFindLoop(v, d, s, &cold); freeDFA(d); freeDFA(s); NOERR(); if (v->g->cflags®_EXPECT) { @@ -447,18 +451,16 @@ return ret; } /* - complicatedFindLoop - the heart of complicatedFind - ^ static int complicatedFindLoop(struct vars *, struct cnfa *, struct colormap *, + ^ static int complicatedFindLoop(struct vars *, ^ struct dfa *, struct dfa *, chr **); */ static int complicatedFindLoop( struct vars *const v, - struct cnfa *const cnfa, - struct colormap *const cm, struct dfa *const d, struct dfa *const s, chr **const coldp) /* where to put coldstart pointer */ { chr *begin, *end; @@ -883,11 +885,11 @@ assert((size_t)n < v->nmatch); MDEBUG(("cbackref n%d %d{%d-%d}\n", t->id, n, min, max)); /* get the backreferenced string */ - if (v->pmatch[n].rm_so == TCL_INDEX_NONE) { + if (v->pmatch[n].rm_so == -1) { return REG_NOMATCH; } brstring = v->start + v->pmatch[n].rm_so; brlen = v->pmatch[n].rm_eo - v->pmatch[n].rm_so; Index: generic/regguts.h ================================================================== --- generic/regguts.h +++ generic/regguts.h @@ -46,20 +46,46 @@ #define NDEBUG /* no assertions */ #endif #endif /* !REG_DEBUG */ #include #endif + +/* voids */ +#ifndef VOID +#define VOID void /* for function return values */ +#endif +#ifndef DISCARD +#define DISCARD void /* for throwing values away */ +#endif +#ifndef PVOID +#define PVOID void * /* generic pointer */ +#endif +#ifndef VS +#define VS(x) ((void*)(x)) /* cast something to generic ptr */ +#endif +#ifndef NOPARMS +#define NOPARMS void /* for empty parm lists */ +#endif + +/* function-pointer declarator */ +#ifndef FUNCPTR +#if __STDC__ >= 1 +#define FUNCPTR(name, args) (*name)args +#else +#define FUNCPTR(name, args) (*name)() +#endif +#endif /* memory allocation */ #ifndef MALLOC #define MALLOC(n) malloc(n) #endif #ifndef REALLOC -#define REALLOC(p, n) realloc(p, n) +#define REALLOC(p, n) realloc(VS(p), n) #endif #ifndef FREE -#define FREE(p) free(p) +#define FREE(p) free(VS(p)) #endif /* want size of a char in bits, and max value in bounded quantifiers */ #ifndef _POSIX2_RE_DUP_MAX #define _POSIX2_RE_DUP_MAX 255 /* normally from */ @@ -68,15 +94,16 @@ /* * misc */ #define NOTREACHED 0 +#define xxx 1 #define DUPMAX _POSIX2_RE_DUP_MAX #define DUPINF (DUPMAX+1) -#define REMAGIC 0xfed7 /* magic number for main struct */ +#define REMAGIC 0xFED7 /* magic number for main struct */ /* * debugging facilities */ #ifdef REG_DEBUG @@ -379,28 +406,28 @@ * table of function pointers for generic manipulation functions. A regex_t's * re_fns points to one of these. */ struct fns { - void (*free) (regex_t *); + void FUNCPTR(free, (regex_t *)); }; /* * the insides of a regex_t, hidden behind a void * */ struct guts { int magic; -#define GUTSMAGIC 0xfed9 +#define GUTSMAGIC 0xFED9 int cflags; /* copy of compile flags */ long info; /* copy of re_info */ size_t nsub; /* copy of re_nsub */ struct subre *tree; struct cnfa search; /* for fast preliminary search */ int ntree; /* number of subre's, plus one */ struct colormap cmap; - int (*compare) (const chr *, const chr *, size_t); + int FUNCPTR(compare, (const chr *, const chr *, size_t)); struct subre *lacons; /* lookahead-constraint vector */ int nlacons; /* size of lacons */ }; /* @@ -409,11 +436,11 @@ */ #ifndef AllocVars #define AllocVars(vPtr) \ struct vars var; \ - register struct vars *vPtr = &var + struct vars *vPtr = &var #endif #ifndef FreeVars #define FreeVars(vPtr) ((void) 0) #endif Index: generic/tcl.decls ================================================================== --- generic/tcl.decls +++ generic/tcl.decls @@ -30,44 +30,44 @@ declare 0 { int Tcl_PkgProvideEx(Tcl_Interp *interp, const char *name, const char *version, const void *clientData) } declare 1 { - const char *Tcl_PkgRequireEx(Tcl_Interp *interp, + CONST84_RETURN char *Tcl_PkgRequireEx(Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr) } declare 2 { TCL_NORETURN void Tcl_Panic(const char *format, ...) } declare 3 { - void *Tcl_Alloc(size_t size) + char *Tcl_Alloc(unsigned int size) } declare 4 { - void Tcl_Free(void *ptr) + void Tcl_Free(char *ptr) } declare 5 { - void *Tcl_Realloc(void *ptr, size_t size) + char *Tcl_Realloc(char *ptr, unsigned int size) } declare 6 { - void *Tcl_DbCkalloc(size_t size, const char *file, int line) + char *Tcl_DbCkalloc(unsigned int size, const char *file, int line) } declare 7 { - void Tcl_DbCkfree(void *ptr, const char *file, int line) + void Tcl_DbCkfree(char *ptr, const char *file, int line) } declare 8 { - void *Tcl_DbCkrealloc(void *ptr, size_t size, + char *Tcl_DbCkrealloc(char *ptr, unsigned int 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 # compatibility reasons. declare 9 unix { void Tcl_CreateFileHandler(int fd, int mask, Tcl_FileProc *proc, - void *clientData) + ClientData clientData) } declare 10 unix { void Tcl_DeleteFileHandler(int fd) } declare 11 { @@ -84,11 +84,11 @@ } declare 15 { void Tcl_AppendStringsToObj(Tcl_Obj *objPtr, ...) } declare 16 { - void Tcl_AppendToObj(Tcl_Obj *objPtr, const char *bytes, size_t length) + void Tcl_AppendToObj(Tcl_Obj *objPtr, const char *bytes, int length) } declare 17 { Tcl_Obj *Tcl_ConcatObj(int objc, Tcl_Obj *const objv[]) } declare 18 { @@ -102,16 +102,15 @@ void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, const char *file, int line) } declare 21 { int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, int line) } -# Removed in 9.0 (changed to macro): -#declare 22 { -# Tcl_Obj *Tcl_DbNewBooleanObj(int boolValue, const char *file, int line) -#} +declare 22 { + Tcl_Obj *Tcl_DbNewBooleanObj(int boolValue, const char *file, int line) +} declare 23 { - Tcl_Obj *Tcl_DbNewByteArrayObj(const unsigned char *bytes, size_t length, + Tcl_Obj *Tcl_DbNewByteArrayObj(const unsigned char *bytes, int length, const char *file, int line) } declare 24 { Tcl_Obj *Tcl_DbNewDoubleObj(double doubleValue, const char *file, int line) @@ -118,28 +117,26 @@ } declare 25 { Tcl_Obj *Tcl_DbNewListObj(int objc, Tcl_Obj *const *objv, const char *file, int line) } -# Removed in 9.0 (changed to macro): -#declare 26 { -# Tcl_Obj *Tcl_DbNewLongObj(long longValue, const char *file, int line) -#} +declare 26 { + Tcl_Obj *Tcl_DbNewLongObj(long longValue, const char *file, int line) +} declare 27 { Tcl_Obj *Tcl_DbNewObj(const char *file, int line) } declare 28 { - Tcl_Obj *Tcl_DbNewStringObj(const char *bytes, size_t length, + Tcl_Obj *Tcl_DbNewStringObj(const char *bytes, int length, const char *file, int line) } declare 29 { Tcl_Obj *Tcl_DuplicateObj(Tcl_Obj *objPtr) } -# Removed in 9.0 -#declare 30 { -# void TclFreeObj(Tcl_Obj *objPtr) -#} +declare 30 { + void TclFreeObj(Tcl_Obj *objPtr) +} declare 31 { int Tcl_GetBoolean(Tcl_Interp *interp, const char *src, int *boolPtr) } declare 32 { int Tcl_GetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, @@ -153,15 +150,14 @@ } declare 35 { int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr) } -# Removed in 9.0, replaced by macro. -#declare 36 {deprecated {No longer in use, changed to macro}} { -# int Tcl_GetIndexFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, -# const char *const *tablePtr, const char *msg, int flags, int *indexPtr) -#} +declare 36 { + int Tcl_GetIndexFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, + CONST84 char *const *tablePtr, const char *msg, int flags, int *indexPtr) +} declare 37 { int Tcl_GetInt(Tcl_Interp *interp, const char *src, int *intPtr) } declare 38 { int Tcl_GetIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr) @@ -168,11 +164,11 @@ } declare 39 { int Tcl_GetLongFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr) } declare 40 { - const Tcl_ObjType *Tcl_GetObjType(const char *typeName) + CONST86 Tcl_ObjType *Tcl_GetObjType(const char *typeName) } declare 41 { char *Tcl_GetStringFromObj(Tcl_Obj *objPtr, int *lengthPtr) } declare 42 { @@ -200,77 +196,69 @@ } declare 48 { int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *const objv[]) } -# Removed in 9.0 (changed to macro): -#declare 49 { -# Tcl_Obj *Tcl_NewBooleanObj(int boolValue) -#} +declare 49 { + Tcl_Obj *Tcl_NewBooleanObj(int boolValue) +} declare 50 { - Tcl_Obj *Tcl_NewByteArrayObj(const unsigned char *bytes, size_t length) + Tcl_Obj *Tcl_NewByteArrayObj(const unsigned char *bytes, int length) } declare 51 { Tcl_Obj *Tcl_NewDoubleObj(double doubleValue) } -# Removed in 9.0 (changed to macro): -#declare 52 { -# Tcl_Obj *Tcl_NewIntObj(int intValue) -#} +declare 52 { + Tcl_Obj *Tcl_NewIntObj(int intValue) +} declare 53 { Tcl_Obj *Tcl_NewListObj(int objc, Tcl_Obj *const objv[]) } -# Removed in 9.0 (changed to macro): -#declare 54 { -# Tcl_Obj *Tcl_NewLongObj(long longValue) -#} +declare 54 { + Tcl_Obj *Tcl_NewLongObj(long longValue) +} declare 55 { Tcl_Obj *Tcl_NewObj(void) } declare 56 { - Tcl_Obj *Tcl_NewStringObj(const char *bytes, size_t length) + Tcl_Obj *Tcl_NewStringObj(const char *bytes, int length) } -# Removed in 9.0 (changed to macro): -#declare 57 { -# void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue) -#} +declare 57 { + void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue) +} declare 58 { - unsigned char *Tcl_SetByteArrayLength(Tcl_Obj *objPtr, size_t length) + unsigned char *Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int length) } declare 59 { void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, const unsigned char *bytes, - size_t length) + int length) } declare 60 { void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue) } -# Removed in 9.0 (changed to macro): -#declare 61 { -# void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue) -#} +declare 61 { + void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue) +} declare 62 { void Tcl_SetListObj(Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]) } -# Removed in 9.0 (changed to macro): -#declare 63 { -# void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue) -#} +declare 63 { + void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue) +} declare 64 { - void Tcl_SetObjLength(Tcl_Obj *objPtr, size_t length) + void Tcl_SetObjLength(Tcl_Obj *objPtr, int length) } declare 65 { - void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, size_t length) -} -# Removed in 9.0, replaced by macro. -#declare 66 {deprecated {No longer in use, changed to macro}} { -# void Tcl_AddErrorInfo(Tcl_Interp *interp, const char *message) -#} -# Removed in 9.0, replaced by macro. -#declare 67 {deprecated {No longer in use, changed to macro}} { -# void Tcl_AddObjErrorInfo(Tcl_Interp *interp, const char *message, -# int length) -#} + void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, int length) +} +declare 66 { + void Tcl_AddErrorInfo(Tcl_Interp *interp, const char *message) +} +declare 67 { + void Tcl_AddObjErrorInfo(Tcl_Interp *interp, const char *message, + int length) +} declare 68 { void Tcl_AllowExceptions(Tcl_Interp *interp) } declare 69 { void Tcl_AppendElement(Tcl_Interp *interp, const char *element) @@ -278,11 +266,11 @@ declare 70 { void Tcl_AppendResult(Tcl_Interp *interp, ...) } declare 71 { Tcl_AsyncHandler Tcl_AsyncCreate(Tcl_AsyncProc *proc, - void *clientData) + ClientData clientData) } declare 72 { void Tcl_AsyncDelete(Tcl_AsyncHandler async) } declare 73 { @@ -292,132 +280,129 @@ void Tcl_AsyncMark(Tcl_AsyncHandler async) } declare 75 { int Tcl_AsyncReady(void) } -# Removed in 9.0 -#declare 76 {deprecated {No longer in use, changed to macro}} { -# void Tcl_BackgroundError(Tcl_Interp *interp) -#} -# Removed in 9.0: -#declare 77 {deprecated {Use Tcl_UtfBackslash}} { -# char Tcl_Backslash(const char *src, int *readPtr) -#} +declare 76 { + void Tcl_BackgroundError(Tcl_Interp *interp) +} +declare 77 { + char Tcl_Backslash(const char *src, int *readPtr) +} declare 78 { int Tcl_BadChannelOption(Tcl_Interp *interp, const char *optionName, const char *optionList) } declare 79 { void Tcl_CallWhenDeleted(Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, - void *clientData) + ClientData clientData) } declare 80 { - void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc, void *clientData) + void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc, ClientData clientData) } declare 81 { int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan) } declare 82 { int Tcl_CommandComplete(const char *cmd) } declare 83 { - char *Tcl_Concat(int argc, const char *const *argv) + char *Tcl_Concat(int argc, CONST84 char *const *argv) } declare 84 { - size_t Tcl_ConvertElement(const char *src, char *dst, int flags) + int Tcl_ConvertElement(const char *src, char *dst, int flags) } declare 85 { - size_t Tcl_ConvertCountedElement(const char *src, size_t length, char *dst, + int Tcl_ConvertCountedElement(const char *src, int length, char *dst, int flags) } declare 86 { - int Tcl_CreateAlias(Tcl_Interp *slave, const char *slaveCmd, + int Tcl_CreateAlias(Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, int argc, - const char *const *argv) + CONST84 char *const *argv) } declare 87 { - int Tcl_CreateAliasObj(Tcl_Interp *slave, const char *slaveCmd, + int Tcl_CreateAliasObj(Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]) } declare 88 { Tcl_Channel Tcl_CreateChannel(const Tcl_ChannelType *typePtr, - const char *chanName, void *instanceData, int mask) + const char *chanName, ClientData instanceData, int mask) } declare 89 { void Tcl_CreateChannelHandler(Tcl_Channel chan, int mask, - Tcl_ChannelProc *proc, void *clientData) + Tcl_ChannelProc *proc, ClientData clientData) } declare 90 { void Tcl_CreateCloseHandler(Tcl_Channel chan, Tcl_CloseProc *proc, - void *clientData) + ClientData clientData) } declare 91 { Tcl_Command Tcl_CreateCommand(Tcl_Interp *interp, const char *cmdName, - Tcl_CmdProc *proc, void *clientData, + Tcl_CmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc) } declare 92 { void Tcl_CreateEventSource(Tcl_EventSetupProc *setupProc, - Tcl_EventCheckProc *checkProc, void *clientData) + Tcl_EventCheckProc *checkProc, ClientData clientData) } declare 93 { - void Tcl_CreateExitHandler(Tcl_ExitProc *proc, void *clientData) + void Tcl_CreateExitHandler(Tcl_ExitProc *proc, ClientData clientData) } declare 94 { Tcl_Interp *Tcl_CreateInterp(void) } -# Removed in 9.0: -#declare 95 {deprecated {}} { -# void Tcl_CreateMathFunc(Tcl_Interp *interp, const char *name, -# int numArgs, Tcl_ValueType *argTypes, -# Tcl_MathProc *proc, void *clientData) -#} +declare 95 { + void Tcl_CreateMathFunc(Tcl_Interp *interp, const char *name, + int numArgs, Tcl_ValueType *argTypes, + Tcl_MathProc *proc, ClientData clientData) +} declare 96 { Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp, const char *cmdName, - Tcl_ObjCmdProc *proc, void *clientData, + Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc) } declare 97 { - Tcl_Interp *Tcl_CreateSlave(Tcl_Interp *interp, const char *slaveName, + Tcl_Interp *Tcl_CreateSlave(Tcl_Interp *interp, const char *name, int isSafe) } declare 98 { Tcl_TimerToken Tcl_CreateTimerHandler(int milliseconds, - Tcl_TimerProc *proc, void *clientData) + Tcl_TimerProc *proc, ClientData clientData) } declare 99 { Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, int level, - Tcl_CmdTraceProc *proc, void *clientData) + Tcl_CmdTraceProc *proc, ClientData clientData) } declare 100 { void Tcl_DeleteAssocData(Tcl_Interp *interp, const char *name) } declare 101 { void Tcl_DeleteChannelHandler(Tcl_Channel chan, Tcl_ChannelProc *proc, - void *clientData) + ClientData clientData) } declare 102 { void Tcl_DeleteCloseHandler(Tcl_Channel chan, Tcl_CloseProc *proc, - void *clientData) + ClientData clientData) } declare 103 { int Tcl_DeleteCommand(Tcl_Interp *interp, const char *cmdName) } declare 104 { int Tcl_DeleteCommandFromToken(Tcl_Interp *interp, Tcl_Command command) } declare 105 { - void Tcl_DeleteEvents(Tcl_EventDeleteProc *proc, void *clientData) + void Tcl_DeleteEvents(Tcl_EventDeleteProc *proc, ClientData clientData) } declare 106 { void Tcl_DeleteEventSource(Tcl_EventSetupProc *setupProc, - Tcl_EventCheckProc *checkProc, void *clientData) + Tcl_EventCheckProc *checkProc, ClientData clientData) } declare 107 { - void Tcl_DeleteExitHandler(Tcl_ExitProc *proc, void *clientData) + void Tcl_DeleteExitHandler(Tcl_ExitProc *proc, ClientData clientData) } declare 108 { void Tcl_DeleteHashEntry(Tcl_HashEntry *entryPtr) } declare 109 { @@ -435,20 +420,20 @@ declare 113 { void Tcl_DeleteTrace(Tcl_Interp *interp, Tcl_Trace trace) } declare 114 { void Tcl_DontCallWhenDeleted(Tcl_Interp *interp, - Tcl_InterpDeleteProc *proc, void *clientData) + Tcl_InterpDeleteProc *proc, ClientData clientData) } declare 115 { int Tcl_DoOneEvent(int flags) } declare 116 { - void Tcl_DoWhenIdle(Tcl_IdleProc *proc, void *clientData) + void Tcl_DoWhenIdle(Tcl_IdleProc *proc, ClientData clientData) } declare 117 { - char *Tcl_DStringAppend(Tcl_DString *dsPtr, const char *bytes, size_t length) + char *Tcl_DStringAppend(Tcl_DString *dsPtr, const char *bytes, int length) } declare 118 { char *Tcl_DStringAppendElement(Tcl_DString *dsPtr, const char *element) } declare 119 { @@ -465,37 +450,35 @@ } declare 123 { void Tcl_DStringResult(Tcl_Interp *interp, Tcl_DString *dsPtr) } declare 124 { - void Tcl_DStringSetLength(Tcl_DString *dsPtr, size_t length) + void Tcl_DStringSetLength(Tcl_DString *dsPtr, int length) } declare 125 { void Tcl_DStringStartSublist(Tcl_DString *dsPtr) } declare 126 { int Tcl_Eof(Tcl_Channel chan) } declare 127 { - const char *Tcl_ErrnoId(void) + CONST84_RETURN char *Tcl_ErrnoId(void) } declare 128 { - const char *Tcl_ErrnoMsg(int err) + CONST84_RETURN char *Tcl_ErrnoMsg(int err) } -# Removed in 9.0, replaced by macro. -#declare 129 { -# int Tcl_Eval(Tcl_Interp *interp, const char *script) -#} +declare 129 { + int Tcl_Eval(Tcl_Interp *interp, const char *script) +} declare 130 { int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName) } -# Removed in 9.0, replaced by macro. -#declare 131 { -# int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) -#} +declare 131 { + int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) +} declare 132 { - void Tcl_EventuallyFree(void *clientData, Tcl_FreeProc *freeProc) + void Tcl_EventuallyFree(ClientData clientData, Tcl_FreeProc *freeProc) } declare 133 { TCL_NORETURN void Tcl_Exit(int status) } declare 134 { @@ -528,14 +511,13 @@ int Tcl_ExprString(Tcl_Interp *interp, const char *expr) } declare 143 { void Tcl_Finalize(void) } -# Removed in 9.0 (stub entry only) -#declare 144 { -# void Tcl_FindExecutable(const char *argv0) -#} +declare 144 { + void Tcl_FindExecutable(const char *argv0) +} declare 145 { Tcl_HashEntry *Tcl_FirstHashEntry(Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr) } declare 146 { @@ -543,21 +525,21 @@ } declare 147 { void Tcl_FreeResult(Tcl_Interp *interp) } declare 148 { - int Tcl_GetAlias(Tcl_Interp *interp, const char *slaveCmd, - Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, - int *argcPtr, const char ***argvPtr) + int Tcl_GetAlias(Tcl_Interp *interp, const char *childCmd, + Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, + int *argcPtr, CONST84 char ***argvPtr) } declare 149 { - int Tcl_GetAliasObj(Tcl_Interp *interp, const char *slaveCmd, - Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, + int Tcl_GetAliasObj(Tcl_Interp *interp, const char *childCmd, + Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv) } declare 150 { - void *Tcl_GetAssocData(Tcl_Interp *interp, const char *name, + ClientData Tcl_GetAssocData(Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr) } declare 151 { Tcl_Channel Tcl_GetChannel(Tcl_Interp *interp, const char *chanName, int *modePtr) @@ -565,44 +547,44 @@ declare 152 { int Tcl_GetChannelBufferSize(Tcl_Channel chan) } declare 153 { int Tcl_GetChannelHandle(Tcl_Channel chan, int direction, - void **handlePtr) + ClientData *handlePtr) } declare 154 { - void *Tcl_GetChannelInstanceData(Tcl_Channel chan) + ClientData Tcl_GetChannelInstanceData(Tcl_Channel chan) } declare 155 { int Tcl_GetChannelMode(Tcl_Channel chan) } declare 156 { - const char *Tcl_GetChannelName(Tcl_Channel chan) + CONST84_RETURN char *Tcl_GetChannelName(Tcl_Channel chan) } declare 157 { int Tcl_GetChannelOption(Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, Tcl_DString *dsPtr) } declare 158 { - const Tcl_ChannelType *Tcl_GetChannelType(Tcl_Channel chan) + CONST86 Tcl_ChannelType *Tcl_GetChannelType(Tcl_Channel chan) } declare 159 { int Tcl_GetCommandInfo(Tcl_Interp *interp, const char *cmdName, Tcl_CmdInfo *infoPtr) } declare 160 { - const char *Tcl_GetCommandName(Tcl_Interp *interp, + CONST84_RETURN char *Tcl_GetCommandName(Tcl_Interp *interp, Tcl_Command command) } declare 161 { int Tcl_GetErrno(void) } declare 162 { - const char *Tcl_GetHostName(void) + CONST84_RETURN char *Tcl_GetHostName(void) } declare 163 { - int Tcl_GetInterpPath(Tcl_Interp *askInterp, Tcl_Interp *slaveInterp) + int Tcl_GetInterpPath(Tcl_Interp *interp, Tcl_Interp *childInterp) } declare 164 { Tcl_Interp *Tcl_GetMaster(Tcl_Interp *interp) } declare 165 { @@ -611,57 +593,53 @@ declare 166 { Tcl_Obj *Tcl_GetObjResult(Tcl_Interp *interp) } # Tcl_GetOpenFile is only available on unix, but it is a part of the old -# generic interface, so we inlcude it here for compatibility reasons. +# generic interface, so we include it here for compatibility reasons. declare 167 unix { int Tcl_GetOpenFile(Tcl_Interp *interp, const char *chanID, int forWriting, - int checkUsage, void **filePtr) + int checkUsage, ClientData *filePtr) } # Obsolete. Should now use Tcl_FSGetPathType which is objectified # and therefore usually faster. declare 168 { Tcl_PathType Tcl_GetPathType(const char *path) } declare 169 { - size_t Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr) + int Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr) } declare 170 { - size_t Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr) + int Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr) } declare 171 { int Tcl_GetServiceMode(void) } declare 172 { - Tcl_Interp *Tcl_GetSlave(Tcl_Interp *interp, const char *slaveName) + Tcl_Interp *Tcl_GetSlave(Tcl_Interp *interp, const char *name) } declare 173 { Tcl_Channel Tcl_GetStdChannel(int type) } -# Removed in 9.0, replaced by macro. -#declare 174 { -# const char *Tcl_GetStringResult(Tcl_Interp *interp) -#} -# Removed in 9.0, replaced by macro. -#declare 175 {deprecated {No longer in use, changed to macro}} { -# const char *Tcl_GetVar(Tcl_Interp *interp, const char *varName, -# int flags) -#} +declare 174 { + CONST84_RETURN char *Tcl_GetStringResult(Tcl_Interp *interp) +} +declare 175 { + CONST84_RETURN char *Tcl_GetVar(Tcl_Interp *interp, const char *varName, + int flags) +} declare 176 { - const char *Tcl_GetVar2(Tcl_Interp *interp, const char *part1, + CONST84_RETURN char *Tcl_GetVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags) } -# Removed in 9.0, replaced by macro. -#declare 177 { -# int Tcl_GlobalEval(Tcl_Interp *interp, const char *command) -#} -# Removed in 9.0, replaced by macro. -#declare 178 { -# int Tcl_GlobalEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) -#} +declare 177 { + int Tcl_GlobalEval(Tcl_Interp *interp, const char *command) +} +declare 178 { + int Tcl_GlobalEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) +} declare 179 { int Tcl_HideCommand(Tcl_Interp *interp, const char *cmdName, const char *hiddenCmdToken) } declare 180 { @@ -682,34 +660,34 @@ declare 185 { int Tcl_IsSafe(Tcl_Interp *interp) } # Obsolete, use Tcl_FSJoinPath declare 186 { - char *Tcl_JoinPath(int argc, const char *const *argv, + char *Tcl_JoinPath(int argc, CONST84 char *const *argv, Tcl_DString *resultPtr) } declare 187 { - int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, void *addr, + int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, char *addr, int type) } # This slot is reserved for use by the plus patch: # declare 188 { # Tcl_MainLoop # } declare 189 { - Tcl_Channel Tcl_MakeFileChannel(void *handle, int mode) + Tcl_Channel Tcl_MakeFileChannel(ClientData handle, int mode) } declare 190 { int Tcl_MakeSafe(Tcl_Interp *interp) } declare 191 { - Tcl_Channel Tcl_MakeTcpClientChannel(void *tcpSocket) + Tcl_Channel Tcl_MakeTcpClientChannel(ClientData tcpSocket) } declare 192 { - char *Tcl_Merge(int argc, const char *const *argv) + char *Tcl_Merge(int argc, CONST84 char *const *argv) } declare 193 { Tcl_HashEntry *Tcl_NextHashEntry(Tcl_HashSearch *searchPtr) } declare 194 { @@ -723,11 +701,11 @@ Tcl_Obj *Tcl_ObjSetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags) } declare 197 { Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, int argc, - const char **argv, int flags) + CONST84 char **argv, int flags) } # This is obsolete, use Tcl_FSOpenFileChannel declare 198 { Tcl_Channel Tcl_OpenFileChannel(Tcl_Interp *interp, const char *fileName, const char *modeString, int permissions) @@ -737,29 +715,29 @@ const char *address, const char *myaddr, int myport, int async) } declare 200 { Tcl_Channel Tcl_OpenTcpServer(Tcl_Interp *interp, int port, const char *host, Tcl_TcpAcceptProc *acceptProc, - void *callbackData) + ClientData callbackData) } declare 201 { - void Tcl_Preserve(void *data) + void Tcl_Preserve(ClientData data) } declare 202 { void Tcl_PrintDouble(Tcl_Interp *interp, double value, char *dst) } declare 203 { int Tcl_PutEnv(const char *assignment) } declare 204 { - const char *Tcl_PosixError(Tcl_Interp *interp) + CONST84_RETURN char *Tcl_PosixError(Tcl_Interp *interp) } declare 205 { void Tcl_QueueEvent(Tcl_Event *evPtr, Tcl_QueuePosition position) } declare 206 { - size_t Tcl_Read(Tcl_Channel chan, char *bufPtr, size_t toRead) + int Tcl_Read(Tcl_Channel chan, char *bufPtr, int toRead) } declare 207 { void Tcl_ReapDetachedProcs(void) } declare 208 { @@ -784,38 +762,38 @@ declare 214 { int Tcl_RegExpMatch(Tcl_Interp *interp, const char *text, const char *pattern) } declare 215 { - void Tcl_RegExpRange(Tcl_RegExp regexp, size_t index, - const char **startPtr, const char **endPtr) + void Tcl_RegExpRange(Tcl_RegExp regexp, int index, + CONST84 char **startPtr, CONST84 char **endPtr) } declare 216 { - void Tcl_Release(void *clientData) + void Tcl_Release(ClientData clientData) } declare 217 { void Tcl_ResetResult(Tcl_Interp *interp) } declare 218 { - size_t Tcl_ScanElement(const char *src, int *flagPtr) + int Tcl_ScanElement(const char *src, int *flagPtr) } declare 219 { - size_t Tcl_ScanCountedElement(const char *src, size_t length, int *flagPtr) + int Tcl_ScanCountedElement(const char *src, int length, int *flagPtr) } -# Removed in 9.0: -#declare 220 { -# int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode) -#} +# Obsolete +declare 220 { + int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode) +} declare 221 { int Tcl_ServiceAll(void) } declare 222 { int Tcl_ServiceEvent(int flags) } declare 223 { void Tcl_SetAssocData(Tcl_Interp *interp, const char *name, - Tcl_InterpDeleteProc *proc, void *clientData) + Tcl_InterpDeleteProc *proc, ClientData clientData) } declare 224 { void Tcl_SetChannelBufferSize(Tcl_Channel chan, int sz) } declare 225 { @@ -833,22 +811,20 @@ void Tcl_SetErrorCode(Tcl_Interp *interp, ...) } declare 229 { void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr) } -# Removed in 9.0 (stub entry only) -#declare 230 { -# void Tcl_SetPanicProc(TCL_NORETURN1 Tcl_PanicProc *panicProc) -#} +declare 230 { + void Tcl_SetPanicProc(TCL_NORETURN1 Tcl_PanicProc *panicProc) +} declare 231 { int Tcl_SetRecursionLimit(Tcl_Interp *interp, int depth) } -# Removed in 9.0, replaced by macro. -#declare 232 { -# void Tcl_SetResult(Tcl_Interp *interp, char *result, -# Tcl_FreeProc *freeProc) -#} +declare 232 { + void Tcl_SetResult(Tcl_Interp *interp, char *result, + Tcl_FreeProc *freeProc) +} declare 233 { int Tcl_SetServiceMode(int mode) } declare 234 { void Tcl_SetObjErrorCode(Tcl_Interp *interp, Tcl_Obj *errorObjPtr) @@ -857,116 +833,108 @@ void Tcl_SetObjResult(Tcl_Interp *interp, Tcl_Obj *resultObjPtr) } declare 236 { void Tcl_SetStdChannel(Tcl_Channel channel, int type) } -# Removed in 9.0, replaced by macro. -#declare 237 {deprecated {No longer in use, changed to macro}} { -# const char *Tcl_SetVar(Tcl_Interp *interp, const char *varName, -# const char *newValue, int flags) -#} +declare 237 { + CONST84_RETURN char *Tcl_SetVar(Tcl_Interp *interp, const char *varName, + const char *newValue, int flags) +} declare 238 { - const char *Tcl_SetVar2(Tcl_Interp *interp, const char *part1, + CONST84_RETURN char *Tcl_SetVar2(Tcl_Interp *interp, const char *part1, const char *part2, const char *newValue, int flags) } declare 239 { - const char *Tcl_SignalId(int sig) + CONST84_RETURN char *Tcl_SignalId(int sig) } declare 240 { - const char *Tcl_SignalMsg(int sig) + CONST84_RETURN char *Tcl_SignalMsg(int sig) } declare 241 { void Tcl_SourceRCFile(Tcl_Interp *interp) } declare 242 { int Tcl_SplitList(Tcl_Interp *interp, const char *listStr, int *argcPtr, - const char ***argvPtr) + CONST84 char ***argvPtr) } # Obsolete, use Tcl_FSSplitPath declare 243 { - void Tcl_SplitPath(const char *path, int *argcPtr, const char ***argvPtr) -} -# Removed in 9.0 (stub entry only) -#declare 244 { -# void Tcl_StaticPackage(Tcl_Interp *interp, const char *pkgName, -# Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) -#} -# Removed in 9.0 (stub entry only) -#declare 245 { -# int Tcl_StringMatch(const char *str, const char *pattern) -#} -# Removed in 9.0: -#declare 246 { -# int Tcl_TellOld(Tcl_Channel chan) -#} -# Removed in 9.0, replaced by macro. -#declare 247 {deprecated {No longer in use, changed to macro}} { -# int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags, -# Tcl_VarTraceProc *proc, ClientData clientData) -#} + void Tcl_SplitPath(const char *path, int *argcPtr, CONST84 char ***argvPtr) +} +declare 244 { + void Tcl_StaticPackage(Tcl_Interp *interp, const char *pkgName, + Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) +} +declare 245 { + int Tcl_StringMatch(const char *str, const char *pattern) +} +# Obsolete +declare 246 { + int Tcl_TellOld(Tcl_Channel chan) +} +declare 247 { + int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags, + Tcl_VarTraceProc *proc, ClientData clientData) +} declare 248 { int Tcl_TraceVar2(Tcl_Interp *interp, const char *part1, const char *part2, - int flags, Tcl_VarTraceProc *proc, void *clientData) + int flags, Tcl_VarTraceProc *proc, ClientData clientData) } declare 249 { char *Tcl_TranslateFileName(Tcl_Interp *interp, const char *name, Tcl_DString *bufferPtr) } declare 250 { - size_t Tcl_Ungets(Tcl_Channel chan, const char *str, size_t len, int atHead) + int Tcl_Ungets(Tcl_Channel chan, const char *str, int len, int atHead) } declare 251 { void Tcl_UnlinkVar(Tcl_Interp *interp, const char *varName) } declare 252 { int Tcl_UnregisterChannel(Tcl_Interp *interp, Tcl_Channel chan) } -# Removed in 9.0, replaced by macro. -#declare 253 {deprecated {No longer in use, changed to macro}} { -# int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName, int flags) -#} +declare 253 { + int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName, int flags) +} declare 254 { int Tcl_UnsetVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags) } -# Removed in 9.0, replaced by macro. -#declare 255 {deprecated {No longer in use, changed to macro}} { -# void Tcl_UntraceVar(Tcl_Interp *interp, const char *varName, int flags, -# Tcl_VarTraceProc *proc, ClientData clientData) -#} +declare 255 { + void Tcl_UntraceVar(Tcl_Interp *interp, const char *varName, int flags, + Tcl_VarTraceProc *proc, ClientData clientData) +} declare 256 { void Tcl_UntraceVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, - void *clientData) + ClientData clientData) } declare 257 { void Tcl_UpdateLinkedVar(Tcl_Interp *interp, const char *varName) } -# Removed in 9.0, replaced by macro. -#declare 258 {deprecated {No longer in use, changed to macro}} { -# int Tcl_UpVar(Tcl_Interp *interp, const char *frameName, -# const char *varName, const char *localName, int flags) -#} +declare 258 { + int Tcl_UpVar(Tcl_Interp *interp, const char *frameName, + const char *varName, const char *localName, int flags) +} declare 259 { int Tcl_UpVar2(Tcl_Interp *interp, const char *frameName, const char *part1, const char *part2, const char *localName, int flags) } declare 260 { int Tcl_VarEval(Tcl_Interp *interp, ...) } -# Removed in 9.0, replaced by macro. -#declare 261 {deprecated {No longer in use, changed to macro}} { -# ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, const char *varName, -# int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData) -#} +declare 261 { + ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, const char *varName, + int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData) +} declare 262 { - void *Tcl_VarTraceInfo2(Tcl_Interp *interp, const char *part1, + ClientData Tcl_VarTraceInfo2(Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, - void *prevClientData) + ClientData prevClientData) } declare 263 { - size_t Tcl_Write(Tcl_Channel chan, const char *s, size_t slen) + int Tcl_Write(Tcl_Channel chan, const char *s, int slen) } declare 264 { void Tcl_WrongNumArgs(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], const char *message) } @@ -974,61 +942,53 @@ int Tcl_DumpActiveMemory(const char *fileName) } declare 266 { void Tcl_ValidateAllMemory(const char *file, int line) } -# Removed in 9.0: -#declare 267 { -# void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList) -#} -# Removed in 9.0: -#declare 268 { -# void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, va_list argList) -#} +declare 267 { + void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList) +} +declare 268 { + void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, va_list argList) +} declare 269 { char *Tcl_HashStats(Tcl_HashTable *tablePtr) } declare 270 { - const char *Tcl_ParseVar(Tcl_Interp *interp, const char *start, - const char **termPtr) -} -# Removed in 9.0, replaced by macro. -#declare 271 {deprecated {No longer in use, changed to macro}} { -# const char *Tcl_PkgPresent(Tcl_Interp *interp, const char *name, -# const char *version, int exact) -#} + CONST84_RETURN char *Tcl_ParseVar(Tcl_Interp *interp, const char *start, + CONST84 char **termPtr) +} +declare 271 { + CONST84_RETURN char *Tcl_PkgPresent(Tcl_Interp *interp, const char *name, + const char *version, int exact) +} declare 272 { - const char *Tcl_PkgPresentEx(Tcl_Interp *interp, + CONST84_RETURN char *Tcl_PkgPresentEx(Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr) } -# Removed in 9.0, replaced by macro. -#declare 273 {deprecated {No longer in use, changed to macro}} { -# int Tcl_PkgProvide(Tcl_Interp *interp, const char *name, -# const char *version) -#} +declare 273 { + int Tcl_PkgProvide(Tcl_Interp *interp, const char *name, + const char *version) +} # TIP #268: The internally used new Require function is in slot 573. -# Removed in 9.0, replaced by macro. -#declare 274 {deprecated {No longer in use, changed to macro}} { -# const char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name, -# const char *version, int exact) -#} -# Removed in 9.0: -#declare 275 { -# void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList) -#} -# Removed in 9.0: -#declare 276 { -# int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList) -#} +declare 274 { + CONST84_RETURN char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name, + const char *version, int exact) +} +declare 275 { + void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList) +} +declare 276 { + int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList) +} declare 277 { Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options) } -# Removed in 9.0: -#declare 278 { -# TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList) -#} +declare 278 { + TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList) +} declare 279 { void Tcl_GetVersion(int *major, int *minor, int *patchLevel, int *type) } declare 280 { void Tcl_InitMemory(Tcl_Interp *interp) @@ -1048,11 +1008,11 @@ # (patch usually has no problems to integrate the patch file for the last # version into the new one). declare 281 { Tcl_Channel Tcl_StackChannel(Tcl_Interp *interp, - const Tcl_ChannelType *typePtr, void *instanceData, + const Tcl_ChannelType *typePtr, ClientData instanceData, int mask, Tcl_Channel prevChan) } declare 282 { int Tcl_UnstackChannel(Tcl_Interp *interp, Tcl_Channel chan) } @@ -1076,21 +1036,20 @@ } declare 287 { Tcl_Encoding Tcl_CreateEncoding(const Tcl_EncodingType *typePtr) } declare 288 { - void Tcl_CreateThreadExitHandler(Tcl_ExitProc *proc, void *clientData) + void Tcl_CreateThreadExitHandler(Tcl_ExitProc *proc, ClientData clientData) } declare 289 { - void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, void *clientData) + void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, ClientData clientData) } -# Removed in 9.0, replaced by macro. -#declare 290 { -# void Tcl_DiscardResult(Tcl_SavedResult *statePtr) -#} +declare 290 { + void Tcl_DiscardResult(Tcl_SavedResult *statePtr) +} declare 291 { - int Tcl_EvalEx(Tcl_Interp *interp, const char *script, size_t numBytes, + int Tcl_EvalEx(Tcl_Interp *interp, const char *script, int numBytes, int flags) } declare 292 { int Tcl_EvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags) @@ -1097,27 +1056,27 @@ } declare 293 { int Tcl_EvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags) } declare 294 { - TCL_NORETURN void Tcl_ExitThread(int status) + void Tcl_ExitThread(int status) } declare 295 { int Tcl_ExternalToUtf(Tcl_Interp *interp, Tcl_Encoding encoding, - const char *src, size_t srcLen, int flags, - Tcl_EncodingState *statePtr, char *dst, size_t dstLen, + const char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr) } declare 296 { char *Tcl_ExternalToUtfDString(Tcl_Encoding encoding, - const char *src, size_t srcLen, Tcl_DString *dsPtr) + const char *src, int srcLen, Tcl_DString *dsPtr) } declare 297 { void Tcl_FinalizeThread(void) } declare 298 { - void Tcl_FinalizeNotifier(void *clientData) + void Tcl_FinalizeNotifier(ClientData clientData) } declare 299 { void Tcl_FreeEncoding(Tcl_Encoding encoding) } declare 300 { @@ -1125,29 +1084,29 @@ } declare 301 { Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, const char *name) } declare 302 { - const char *Tcl_GetEncodingName(Tcl_Encoding encoding) + CONST84_RETURN char *Tcl_GetEncodingName(Tcl_Encoding encoding) } declare 303 { void Tcl_GetEncodingNames(Tcl_Interp *interp) } declare 304 { int Tcl_GetIndexFromObjStruct(Tcl_Interp *interp, Tcl_Obj *objPtr, - const void *tablePtr, size_t offset, const char *msg, int flags, + const void *tablePtr, int offset, const char *msg, int flags, int *indexPtr) } declare 305 { - void *Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr, size_t size) + void *Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr, int size) } declare 306 { Tcl_Obj *Tcl_GetVar2Ex(Tcl_Interp *interp, const char *part1, const char *part2, int flags) } declare 307 { - void *Tcl_InitNotifier(void) + ClientData Tcl_InitNotifier(void) } declare 308 { void Tcl_MutexLock(Tcl_Mutex *mutexPtr) } declare 309 { @@ -1159,24 +1118,22 @@ declare 311 { void Tcl_ConditionWait(Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, const Tcl_Time *timePtr) } declare 312 { - size_t Tcl_NumUtfChars(const char *src, size_t length) + int Tcl_NumUtfChars(const char *src, int length) } declare 313 { - size_t Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, - size_t charsToRead, int appendFlag) -} -# Removed in 9.0, replaced by macro. -#declare 314 {deprecated {No longer in use, changed to macro}} { -# void Tcl_RestoreResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr) -#} -# Removed in 9.0, replaced by macro. -#declare 315 {deprecated {No longer in use, changed to macro}} { -# void Tcl_SaveResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr) -#} + int Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, int charsToRead, + int appendFlag) +} +declare 314 { + void Tcl_RestoreResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr) +} +declare 315 { + void Tcl_SaveResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr) +} declare 316 { int Tcl_SetSystemEncoding(Tcl_Interp *interp, const char *name) } declare 317 { Tcl_Obj *Tcl_SetVar2Ex(Tcl_Interp *interp, const char *part1, @@ -1188,54 +1145,54 @@ declare 319 { void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event *evPtr, Tcl_QueuePosition position) } declare 320 { - int Tcl_UniCharAtIndex(const char *src, size_t index) + Tcl_UniChar Tcl_UniCharAtIndex(const char *src, int index) } declare 321 { - int Tcl_UniCharToLower(int ch) + Tcl_UniChar Tcl_UniCharToLower(int ch) } declare 322 { - int Tcl_UniCharToTitle(int ch) + Tcl_UniChar Tcl_UniCharToTitle(int ch) } declare 323 { - int Tcl_UniCharToUpper(int ch) + Tcl_UniChar Tcl_UniCharToUpper(int ch) } declare 324 { int Tcl_UniCharToUtf(int ch, char *buf) } declare 325 { - const char *Tcl_UtfAtIndex(const char *src, size_t index) + CONST84_RETURN char *Tcl_UtfAtIndex(const char *src, int index) } declare 326 { - int Tcl_UtfCharComplete(const char *src, size_t length) + int Tcl_UtfCharComplete(const char *src, int length) } declare 327 { - size_t Tcl_UtfBackslash(const char *src, int *readPtr, char *dst) + int Tcl_UtfBackslash(const char *src, int *readPtr, char *dst) } declare 328 { - const char *Tcl_UtfFindFirst(const char *src, int ch) + CONST84_RETURN char *Tcl_UtfFindFirst(const char *src, int ch) } declare 329 { - const char *Tcl_UtfFindLast(const char *src, int ch) + CONST84_RETURN char *Tcl_UtfFindLast(const char *src, int ch) } declare 330 { - const char *Tcl_UtfNext(const char *src) + CONST84_RETURN char *Tcl_UtfNext(const char *src) } declare 331 { - const char *Tcl_UtfPrev(const char *src, const char *start) + CONST84_RETURN char *Tcl_UtfPrev(const char *src, const char *start) } declare 332 { int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding, - const char *src, size_t srcLen, int flags, - Tcl_EncodingState *statePtr, char *dst, size_t dstLen, + const char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr) } declare 333 { char *Tcl_UtfToExternalDString(Tcl_Encoding encoding, - const char *src, size_t srcLen, Tcl_DString *dsPtr) + const char *src, int srcLen, Tcl_DString *dsPtr) } declare 334 { int Tcl_UtfToLower(char *src) } declare 335 { @@ -1246,28 +1203,26 @@ } declare 337 { int Tcl_UtfToUpper(char *src) } declare 338 { - size_t Tcl_WriteChars(Tcl_Channel chan, const char *src, size_t srcLen) + int Tcl_WriteChars(Tcl_Channel chan, const char *src, int srcLen) } declare 339 { - size_t Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr) + int Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr) } declare 340 { char *Tcl_GetString(Tcl_Obj *objPtr) } -# Removed in 9.0: -#declare 341 {deprecated {Use Tcl_GetEncodingSearchPath}} { -# const char *Tcl_GetDefaultEncodingDir(void) -#} -# Removed in 9.0: -#declare 342 {deprecated {Use Tcl_SetEncodingSearchPath}} { -# void Tcl_SetDefaultEncodingDir(const char *path) -#} +declare 341 { + CONST84_RETURN char *Tcl_GetDefaultEncodingDir(void) +} +declare 342 { + void Tcl_SetDefaultEncodingDir(const char *path) +} declare 343 { - void Tcl_AlertNotifier(void *clientData) + void Tcl_AlertNotifier(ClientData clientData) } declare 344 { void Tcl_ServiceModeHook(int mode) } declare 345 { @@ -1290,61 +1245,59 @@ } declare 351 { int Tcl_UniCharIsWordChar(int ch) } declare 352 { - size_t Tcl_UniCharLen(const Tcl_UniChar *uniStr) + int Tcl_UniCharLen(const Tcl_UniChar *uniStr) } declare 353 { int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, - size_t numChars) + unsigned long numChars) } declare 354 { char *Tcl_UniCharToUtfDString(const Tcl_UniChar *uniStr, - size_t uniLength, Tcl_DString *dsPtr) + int uniLength, Tcl_DString *dsPtr) } declare 355 { Tcl_UniChar *Tcl_UtfToUniCharDString(const char *src, - size_t length, Tcl_DString *dsPtr) + int length, Tcl_DString *dsPtr) } declare 356 { Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, int flags) } -# Removed in 9.0: -#declare 357 {deprecated {Use Tcl_EvalTokensStandard}} { -# Tcl_Obj *Tcl_EvalTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, -# int count) -#} +declare 357 { + Tcl_Obj *Tcl_EvalTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, + int count) +} declare 358 { void Tcl_FreeParse(Tcl_Parse *parsePtr) } declare 359 { void Tcl_LogCommandInfo(Tcl_Interp *interp, const char *script, - const char *command, size_t length) + const char *command, int length) } declare 360 { - int Tcl_ParseBraces(Tcl_Interp *interp, const char *start, - size_t numBytes, Tcl_Parse *parsePtr, int append, - const char **termPtr) + int Tcl_ParseBraces(Tcl_Interp *interp, const char *start, int numBytes, + Tcl_Parse *parsePtr, int append, CONST84 char **termPtr) } declare 361 { - int Tcl_ParseCommand(Tcl_Interp *interp, const char *start, - size_t numBytes, int nested, Tcl_Parse *parsePtr) + int Tcl_ParseCommand(Tcl_Interp *interp, const char *start, int numBytes, + int nested, Tcl_Parse *parsePtr) } declare 362 { - int Tcl_ParseExpr(Tcl_Interp *interp, const char *start, size_t numBytes, + int Tcl_ParseExpr(Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr) } declare 363 { int Tcl_ParseQuotedString(Tcl_Interp *interp, const char *start, - size_t numBytes, Tcl_Parse *parsePtr, int append, - const char **termPtr) + int numBytes, Tcl_Parse *parsePtr, int append, + CONST84 char **termPtr) } declare 364 { - int Tcl_ParseVarName(Tcl_Interp *interp, const char *start, - size_t numBytes, Tcl_Parse *parsePtr, int append) + int Tcl_ParseVarName(Tcl_Interp *interp, const char *start, int numBytes, + Tcl_Parse *parsePtr, int append) } # These 4 functions are obsolete, use Tcl_FSGetCwd, Tcl_FSChdir, # Tcl_FSAccess and Tcl_FSStat declare 365 { char *Tcl_GetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr) @@ -1357,14 +1310,14 @@ } declare 368 { int Tcl_Stat(const char *path, struct stat *bufPtr) } declare 369 { - int Tcl_UtfNcmp(const char *s1, const char *s2, size_t n) + int Tcl_UtfNcmp(const char *s1, const char *s2, unsigned long n) } declare 370 { - int Tcl_UtfNcasecmp(const char *s1, const char *s2, size_t n) + int Tcl_UtfNcasecmp(const char *s1, const char *s2, unsigned long n) } declare 371 { int Tcl_StringCaseMatch(const char *str, const char *pattern, int nocase) } declare 372 { @@ -1379,38 +1332,37 @@ declare 375 { int Tcl_UniCharIsPunct(int ch) } declare 376 { int Tcl_RegExpExecObj(Tcl_Interp *interp, Tcl_RegExp regexp, - Tcl_Obj *textObj, size_t offset, size_t nmatches, int flags) + Tcl_Obj *textObj, int offset, int nmatches, int flags) } declare 377 { void Tcl_RegExpGetInfo(Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr) } declare 378 { - Tcl_Obj *Tcl_NewUnicodeObj(const Tcl_UniChar *unicode, size_t numChars) + Tcl_Obj *Tcl_NewUnicodeObj(const Tcl_UniChar *unicode, int numChars) } declare 379 { void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, - size_t numChars) + int numChars) } declare 380 { - size_t Tcl_GetCharLength(Tcl_Obj *objPtr) + int Tcl_GetCharLength(Tcl_Obj *objPtr) } declare 381 { - int Tcl_GetUniChar(Tcl_Obj *objPtr, size_t index) + Tcl_UniChar Tcl_GetUniChar(Tcl_Obj *objPtr, int index) } -# Removed in 9.0, replaced by macro. -#declare 382 {deprecated {No longer in use, changed to macro}} { -# Tcl_UniChar *Tcl_GetUnicode(Tcl_Obj *objPtr) -#} +declare 382 { + Tcl_UniChar *Tcl_GetUnicode(Tcl_Obj *objPtr) +} declare 383 { - Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, size_t first, size_t last) + Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, int first, int last) } declare 384 { void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, - size_t length) + int length) } declare 385 { int Tcl_RegExpMatchObj(Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj) } @@ -1425,11 +1377,11 @@ } declare 389 { int Tcl_GetChannelNamesEx(Tcl_Interp *interp, const char *pattern) } declare 390 { - int Tcl_ProcObjCmd(void *clientData, Tcl_Interp *interp, + int Tcl_ProcObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) } declare 391 { void Tcl_ConditionFinalize(Tcl_Condition *condPtr) } @@ -1436,28 +1388,28 @@ 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) + ClientData clientData, int stackSize, int flags) } # Introduced in 8.3.2 declare 394 { - size_t Tcl_ReadRaw(Tcl_Channel chan, char *dst, size_t bytesToRead) + int Tcl_ReadRaw(Tcl_Channel chan, char *dst, int bytesToRead) } declare 395 { - size_t Tcl_WriteRaw(Tcl_Channel chan, const char *src, size_t srcLen) + int Tcl_WriteRaw(Tcl_Channel chan, const char *src, int srcLen) } declare 396 { Tcl_Channel Tcl_GetTopChannel(Tcl_Channel chan) } declare 397 { int Tcl_ChannelBuffered(Tcl_Channel chan) } declare 398 { - const char *Tcl_ChannelName(const Tcl_ChannelType *chanTypePtr) + CONST84_RETURN char *Tcl_ChannelName(const Tcl_ChannelType *chanTypePtr) } declare 399 { Tcl_ChannelTypeVersion Tcl_ChannelVersion( const Tcl_ChannelType *chanTypePtr) } @@ -1532,60 +1484,58 @@ declare 418 { int Tcl_IsChannelExisting(const char *channelName) } declare 419 { int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, - size_t numChars) + unsigned long numChars) } declare 420 { int Tcl_UniCharCaseMatch(const Tcl_UniChar *uniStr, const Tcl_UniChar *uniPattern, int nocase) } -# Removed in 9.0, as it is actually a macro: -#declare 421 { -# Tcl_HashEntry *Tcl_FindHashEntry(Tcl_HashTable *tablePtr, const void *key) -#} -# Removed in 9.0, as it is actually a macro: -#declare 422 { -# Tcl_HashEntry *Tcl_CreateHashEntry(Tcl_HashTable *tablePtr, -# const void *key, int *newPtr) -#} +declare 421 { + Tcl_HashEntry *Tcl_FindHashEntry(Tcl_HashTable *tablePtr, const void *key) +} +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 { void Tcl_InitObjHashTable(Tcl_HashTable *tablePtr) } declare 425 { - void *Tcl_CommandTraceInfo(Tcl_Interp *interp, const char *varName, + ClientData Tcl_CommandTraceInfo(Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *procPtr, - void *prevClientData) + ClientData prevClientData) } declare 426 { int Tcl_TraceCommand(Tcl_Interp *interp, const char *varName, int flags, - Tcl_CommandTraceProc *proc, void *clientData) + Tcl_CommandTraceProc *proc, ClientData clientData) } declare 427 { void Tcl_UntraceCommand(Tcl_Interp *interp, const char *varName, - int flags, Tcl_CommandTraceProc *proc, void *clientData) + int flags, Tcl_CommandTraceProc *proc, ClientData clientData) } declare 428 { - void *Tcl_AttemptAlloc(size_t size) + char *Tcl_AttemptAlloc(unsigned int size) } declare 429 { - void *Tcl_AttemptDbCkalloc(size_t size, const char *file, int line) + char *Tcl_AttemptDbCkalloc(unsigned int size, const char *file, int line) } declare 430 { - void *Tcl_AttemptRealloc(void *ptr, size_t size) + char *Tcl_AttemptRealloc(char *ptr, unsigned int size) } declare 431 { - void *Tcl_AttemptDbCkrealloc(void *ptr, size_t size, + char *Tcl_AttemptDbCkrealloc(char *ptr, unsigned int size, const char *file, int line) } declare 432 { - int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, size_t length) + int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, int length) } # TIP#10 (thread-aware channels) akupries declare 433 { Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel) @@ -1595,20 +1545,18 @@ declare 434 { Tcl_UniChar *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr) } # TIP#15 (math function introspection) dkf -# Removed in 9.0: -#declare 435 {deprecated {}} { -# int Tcl_GetMathFuncInfo(Tcl_Interp *interp, const char *name, -# int *numArgsPtr, Tcl_ValueType **argTypesPtr, -# Tcl_MathProc **procPtr, void **clientDataPtr) -#} -# Removed in 9.0: -#declare 436 {deprecated {}} { -# Tcl_Obj *Tcl_ListMathFuncs(Tcl_Interp *interp, const char *pattern) -#} +declare 435 { + int Tcl_GetMathFuncInfo(Tcl_Interp *interp, const char *name, + int *numArgsPtr, Tcl_ValueType **argTypesPtr, + Tcl_MathProc **procPtr, ClientData *clientDataPtr) +} +declare 436 { + Tcl_Obj *Tcl_ListMathFuncs(Tcl_Interp *interp, const char *pattern) +} # TIP#36 (better access to 'subst') dkf declare 437 { Tcl_Obj *Tcl_SubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags) } @@ -1666,11 +1614,11 @@ declare 452 { int Tcl_FSFileAttrsSet(Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr) } declare 453 { - const char *const *Tcl_FSFileAttrStrings(Tcl_Obj *pathPtr, + const char *CONST86 *Tcl_FSFileAttrStrings(Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef) } declare 454 { int Tcl_FSStat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf) } @@ -1705,11 +1653,11 @@ declare 464 { Tcl_Obj *Tcl_FSJoinToPath(Tcl_Obj *pathPtr, int objc, Tcl_Obj *const objv[]) } declare 465 { - void *Tcl_FSGetInternalRep(Tcl_Obj *pathPtr, + ClientData Tcl_FSGetInternalRep(Tcl_Obj *pathPtr, const Tcl_Filesystem *fsPtr) } declare 466 { Tcl_Obj *Tcl_FSGetTranslatedPath(Tcl_Interp *interp, Tcl_Obj *pathPtr) } @@ -1716,11 +1664,11 @@ declare 467 { int Tcl_FSEvalFile(Tcl_Interp *interp, Tcl_Obj *fileName) } declare 468 { Tcl_Obj *Tcl_FSNewNativePath(const Tcl_Filesystem *fromFilesystem, - void *clientData) + ClientData clientData) } declare 469 { const void *Tcl_FSGetNativePath(Tcl_Obj *pathPtr) } declare 470 { @@ -1731,24 +1679,24 @@ } declare 472 { Tcl_Obj *Tcl_FSListVolumes(void) } declare 473 { - int Tcl_FSRegister(void *clientData, const Tcl_Filesystem *fsPtr) + int Tcl_FSRegister(ClientData clientData, const Tcl_Filesystem *fsPtr) } declare 474 { int Tcl_FSUnregister(const Tcl_Filesystem *fsPtr) } declare 475 { - void *Tcl_FSData(const Tcl_Filesystem *fsPtr) + ClientData Tcl_FSData(const Tcl_Filesystem *fsPtr) } declare 476 { const char *Tcl_FSGetTranslatedStringPath(Tcl_Interp *interp, Tcl_Obj *pathPtr) } declare 477 { - const Tcl_Filesystem *Tcl_FSGetFileSystemForPath(Tcl_Obj *pathPtr) + CONST86 Tcl_Filesystem *Tcl_FSGetFileSystemForPath(Tcl_Obj *pathPtr) } declare 478 { Tcl_PathType Tcl_FSGetPathType(Tcl_Obj *pathPtr) } @@ -1761,11 +1709,11 @@ } # TIP#56 (evaluate a parsed script) msofer declare 481 { int Tcl_EvalTokensStandard(Tcl_Interp *interp, Tcl_Token *tokenPtr, - size_t count) + int count) } # TIP#73 (access to current time) kbk declare 482 { void Tcl_GetTime(Tcl_Time *timeBuf) @@ -1772,11 +1720,11 @@ } # TIP#32 (object-enabled traces) kbk declare 483 { Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp, int level, int flags, - Tcl_CmdObjTraceProc *objProc, void *clientData, + Tcl_CmdObjTraceProc *objProc, ClientData clientData, Tcl_CmdObjTraceDeleteProc *delProc) } declare 484 { int Tcl_GetCommandInfoFromToken(Tcl_Command token, Tcl_CmdInfo *infoPtr) } @@ -1870,11 +1818,11 @@ # TIP #139 (partial exposure of namespace API - transferred from tclInt.decls) # dkf, API by Brent Welch? declare 506 { Tcl_Namespace *Tcl_CreateNamespace(Tcl_Interp *interp, const char *name, - void *clientData, Tcl_NamespaceDeleteProc *deleteProc) + ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc) } declare 507 { void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr) } declare 508 { @@ -1919,24 +1867,24 @@ declare 518 { int Tcl_FSEvalFileEx(Tcl_Interp *interp, Tcl_Obj *fileName, const char *encodingName) } -# Removed in 9.0 (stub entry only) -#declare 519 {nostub {Don't use this function in a stub-enabled extension}} { -# Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc) -#} +# TIP#121 (exit handler) dkf for Joe Mistachkin +declare 519 { + Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc) +} # TIP#143 (resource limits) dkf declare 520 { void Tcl_LimitAddHandler(Tcl_Interp *interp, int type, - Tcl_LimitHandlerProc *handlerProc, void *clientData, + Tcl_LimitHandlerProc *handlerProc, ClientData clientData, Tcl_LimitHandlerDeleteProc *deleteProc) } declare 521 { void Tcl_LimitRemoveHandler(Tcl_Interp *interp, int type, - Tcl_LimitHandlerProc *handlerProc, void *clientData) + Tcl_LimitHandlerProc *handlerProc, ClientData clientData) } declare 522 { int Tcl_LimitReady(Tcl_Interp *interp) } declare 523 { @@ -2045,16 +1993,16 @@ # TIP#233 (virtualized time) akupries declare 552 { void Tcl_SetTimeProc(Tcl_GetTimeProc *getProc, Tcl_ScaleTimeProc *scaleProc, - void *clientData) + ClientData clientData) } declare 553 { void Tcl_QueryTimeProc(Tcl_GetTimeProc **getProc, Tcl_ScaleTimeProc **scaleProc, - void **clientData) + ClientData *clientData) } # TIP#218 (driver thread actions) davygrvy/akupries ChannelType ver 4 declare 554 { Tcl_DriverThreadActionProc *Tcl_ChannelThreadActionProc( @@ -2141,12 +2089,12 @@ # TIP#270 (utility C routines for string formatting) dgp declare 574 { void Tcl_AppendObjToErrorInfo(Tcl_Interp *interp, Tcl_Obj *objPtr) } declare 575 { - void Tcl_AppendLimitedToObj(Tcl_Obj *objPtr, const char *bytes, - size_t length, size_t limit, const char *ellipsis) + void Tcl_AppendLimitedToObj(Tcl_Obj *objPtr, const char *bytes, int length, + int limit, const char *ellipsis) } declare 576 { Tcl_Obj *Tcl_Format(Tcl_Interp *interp, const char *format, int objc, Tcl_Obj *const objv[]) } @@ -2164,11 +2112,11 @@ # ----- BASELINE -- FOR -- 8.5.0 ----- # # TIP #285 (script cancellation support) jmistachkin declare 580 { int Tcl_CancelEval(Tcl_Interp *interp, Tcl_Obj *resultObjPtr, - void *clientData, int flags) + ClientData clientData, int flags) } declare 581 { int Tcl_Canceled(Tcl_Interp *interp, int flags) } @@ -2180,34 +2128,34 @@ # TIP #322 (NRE public interface) msofer declare 583 { Tcl_Command Tcl_NRCreateCommand(Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, - Tcl_ObjCmdProc *nreProc, void *clientData, + Tcl_ObjCmdProc *nreProc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc) } declare 584 { int Tcl_NREvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags) } declare 585 { - int Tcl_NREvalObjv(Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[], int flags) + int Tcl_NREvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], + int flags) } declare 586 { int Tcl_NRCmdSwap(Tcl_Interp *interp, Tcl_Command cmd, int objc, Tcl_Obj *const objv[], int flags) } declare 587 { void Tcl_NRAddCallback(Tcl_Interp *interp, Tcl_NRPostProc *postProcPtr, - void *data0, void *data1, void *data2, - void *data3) + ClientData data0, ClientData data1, ClientData data2, + ClientData data3) } # For use by NR extenders, to have a simple way to also provide a (required!) # classic objProc declare 588 { int Tcl_NRCallObjProc(Tcl_Interp *interp, Tcl_ObjCmdProc *objProc, - void *clientData, int objc, Tcl_Obj *const objv[]) + ClientData clientData, int objc, Tcl_Obj *const objv[]) } # TIP#316 (Tcl_StatBuf reader functions) dkf declare 589 { unsigned Tcl_GetFSDeviceFromStat(const Tcl_StatBuf *statPtr) @@ -2273,11 +2221,11 @@ void Tcl_SetErrorLine(Tcl_Interp *interp, int lineNum) } # TIP#307 (move results between interpreters) dkf declare 607 { - void Tcl_TransferResult(Tcl_Interp *sourceInterp, int result, + void Tcl_TransferResult(Tcl_Interp *sourceInterp, int code, Tcl_Interp *targetInterp) } # TIP#335 (detect if interpreter in use) jmistachkin declare 608 { @@ -2294,19 +2242,19 @@ int Tcl_ZlibDeflate(Tcl_Interp *interp, int format, Tcl_Obj *data, int level, Tcl_Obj *gzipHeaderDictObj) } declare 611 { int Tcl_ZlibInflate(Tcl_Interp *interp, int format, Tcl_Obj *data, - size_t buffersize, Tcl_Obj *gzipHeaderDictObj) + int buffersize, Tcl_Obj *gzipHeaderDictObj) } declare 612 { unsigned int Tcl_ZlibCRC32(unsigned int crc, const unsigned char *buf, - size_t len) + int len) } declare 613 { unsigned int Tcl_ZlibAdler32(unsigned int adler, const unsigned char *buf, - size_t len) + int len) } declare 614 { int Tcl_ZlibStreamInit(Tcl_Interp *interp, int mode, int format, int level, Tcl_Obj *dictObj, Tcl_ZlibStream *zshandle) } @@ -2321,12 +2269,11 @@ } declare 618 { int Tcl_ZlibStreamPut(Tcl_ZlibStream zshandle, Tcl_Obj *data, int flush) } declare 619 { - int Tcl_ZlibStreamGet(Tcl_ZlibStream zshandle, Tcl_Obj *data, - size_t count) + int Tcl_ZlibStreamGet(Tcl_ZlibStream zshandle, Tcl_Obj *data, int count) } declare 620 { int Tcl_ZlibStreamClose(Tcl_ZlibStream zshandle) } declare 621 { @@ -2376,77 +2323,13 @@ Tcl_Obj *compressionDictionaryObj) } # ----- BASELINE -- FOR -- 8.6.0 ----- # -# TIP #456 -declare 631 { - Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp, const char *service, - const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc, - void *callbackData) -} - -# TIP #430 -declare 632 { - int TclZipfs_Mount(Tcl_Interp *interp, const char *mountPoint, - const char *zipname, const char *passwd) -} -declare 633 { - int TclZipfs_Unmount(Tcl_Interp *interp, const char *mountPoint) -} -declare 634 { - Tcl_Obj *TclZipfs_TclLibrary(void) -} -declare 635 { - int TclZipfs_MountBuffer(Tcl_Interp *interp, const char *mountPoint, - unsigned char *data, size_t datalen, int copy) -} - -# TIP #445 -declare 636 { - void Tcl_FreeIntRep(Tcl_Obj *objPtr) -} -declare 637 { - char *Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes, - size_t numBytes) -} -declare 638 { - Tcl_ObjIntRep *Tcl_FetchIntRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr) -} -declare 639 { - void Tcl_StoreIntRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, - const Tcl_ObjIntRep *irPtr) -} -declare 640 { - int Tcl_HasStringRep(Tcl_Obj *objPtr) -} - -# TIP #506 -declare 641 { - void Tcl_IncrRefCount(Tcl_Obj *objPtr) -} - -declare 642 { - void Tcl_DecrRefCount(Tcl_Obj *objPtr) -} - -declare 643 { - int Tcl_IsShared(Tcl_Obj *objPtr) -} - -# TIP#312 New Tcl_LinkArray() function -declare 644 { - int Tcl_LinkArray(Tcl_Interp *interp, const char *varName, void *addr, - int type, size_t size) -} - -declare 645 { - int Tcl_GetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, - size_t endValue, size_t *indexPtr) -} - -# ----- BASELINE -- FOR -- 8.7.0 ----- # +declare 649 { + void TclUnusedStubEntry(void) +} ############################################################################## # Define the platform specific public Tcl interface. These functions are only # available on the designated platform. @@ -2461,50 +2344,40 @@ # Windows specific functions # Added in Tcl 8.1 declare 0 win { - TCHAR *Tcl_WinUtfToTChar(const char *str, size_t len, Tcl_DString *dsPtr) + TCHAR *Tcl_WinUtfToTChar(const char *str, int len, Tcl_DString *dsPtr) } declare 1 win { - char *Tcl_WinTCharToUtf(const TCHAR *str, size_t len, Tcl_DString *dsPtr) + char *Tcl_WinTCharToUtf(const TCHAR *str, int len, Tcl_DString *dsPtr) } ################################ # Mac OS X specific functions declare 0 macosx { int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp, const char *bundleName, int hasResourceFile, - size_t maxPathLen, char *libraryPath) + int maxPathLen, char *libraryPath) } declare 1 macosx { int Tcl_MacOSXOpenVersionedBundleResources(Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, - int hasResourceFile, size_t maxPathLen, char *libraryPath) + int hasResourceFile, int maxPathLen, char *libraryPath) } ############################################################################## # Public functions that are not accessible via the stubs table. export { - void Tcl_MainEx(int argc, char **argv, Tcl_AppInitProc *appInitProc, - Tcl_Interp *interp) -} -export { - void Tcl_StaticPackage(Tcl_Interp *interp, const char *pkgName, - Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) -} -export { - void Tcl_SetPanicProc(TCL_NORETURN1 Tcl_PanicProc *panicProc) -} -export { - Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc) -} -export { - void Tcl_FindExecutable(const char *argv0) + void Tcl_Main(int argc, char **argv, Tcl_AppInitProc *appInitProc) +} +export { + void Tcl_MainEx(int argc, char **argv, Tcl_AppInitProc *appInitProc, + Tcl_Interp *interp) } export { const char *Tcl_InitStubs(Tcl_Interp *interp, const char *version, int exact) } Index: generic/tcl.h ================================================================== --- generic/tcl.h +++ generic/tcl.h @@ -36,29 +36,43 @@ /* * When version numbers change here, must also go into the following files and * update the version numbers: * * library/init.tcl (1 LOC patch) - * unix/configure.ac (2 LOC Major, 2 LOC minor, 1 LOC patch) - * win/configure.ac (as above) + * unix/configure.in (2 LOC Major, 2 LOC minor, 1 LOC patch) + * win/configure.in (as above) * win/tcl.m4 (not patchlevel) * README (sections 0 and 2, with and without separator) * macosx/Tcl-Common.xcconfig (not patchlevel) 1 LOC * win/README (not patchlevel) (sections 0 and 2) * unix/tcl.spec (1 LOC patch) * tools/tcl.hpj.in (not patchlevel, for windows installer) */ -#define TCL_MAJOR_VERSION 9 -#define TCL_MINOR_VERSION 0 -#define TCL_RELEASE_LEVEL TCL_ALPHA_RELEASE -#define TCL_RELEASE_SERIAL 0 - -#define TCL_VERSION "9.0" -#define TCL_PATCH_LEVEL "9.0a0" - -#if defined(RC_INVOKED) +#define TCL_MAJOR_VERSION 8 +#define TCL_MINOR_VERSION 6 +#define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE +#define TCL_RELEASE_SERIAL 10 + +#define TCL_VERSION "8.6" +#define TCL_PATCH_LEVEL "8.6.10" + +/* + *---------------------------------------------------------------------------- + * The following definitions set up the proper options for Windows compilers. + * We use this method because there is no autoconf equivalent. + */ + +#ifdef _WIN32 +# ifndef __WIN32__ +# define __WIN32__ +# endif +# ifndef WIN32 +# define WIN32 +# endif +#endif + /* * Utility macros: STRINGIFY takes an argument and wraps it in "" (double * quotation marks), JOIN joins two arguments. */ @@ -68,11 +82,10 @@ #endif #ifndef JOIN # define JOIN(a,b) JOIN1(a,b) # define JOIN1(a,b) a##b #endif -#endif /* RC_INVOKED */ /* * A special definition used to allow this header file to be included from * windows resource files so that they can obtain version information. * RC_INVOKED is defined by default by the windows RC tool. @@ -82,14 +95,19 @@ */ #ifndef RC_INVOKED /* - * Special macro to define mutexes. + * Special macro to define mutexes, that doesn't do anything if we are not + * using threads. */ +#ifdef TCL_THREADS #define TCL_DECLARE_MUTEX(name) static Tcl_Mutex name; +#else +#define TCL_DECLARE_MUTEX(name) +#endif /* * Tcl's public routine Tcl_FSSeek() uses the values SEEK_SET, SEEK_CUR, and * SEEK_END, all #define'd by stdio.h . * @@ -99,23 +117,41 @@ * prior Tcl releases. */ #include +/* + *---------------------------------------------------------------------------- + * Support for functions with a variable number of arguments. + * + * The following TCL_VARARGS* macros are to support old extensions + * written for older versions of Tcl where the macros permitted + * support for the varargs.h system as well as stdarg.h . + * + * New code should just directly be written to use stdarg.h conventions. + */ + +#include +#ifndef TCL_NO_DEPRECATED +# define TCL_VARARGS(type, name) (type name, ...) +# define TCL_VARARGS_DEF(type, name) (type name, ...) +# define TCL_VARARGS_START(type, name, list) (va_start(list, name), name) +#endif #if defined(__GNUC__) && (__GNUC__ > 2) # define TCL_FORMAT_PRINTF(a,b) __attribute__ ((__format__ (__printf__, a, b))) # define TCL_NORETURN __attribute__ ((noreturn)) -# define TCL_NOINLINE __attribute__ ((noinline)) -# define TCL_NORETURN1 __attribute__ ((noreturn)) +# if defined(BUILD_tcl) || defined(BUILD_tk) +# define TCL_NORETURN1 __attribute__ ((noreturn)) +# else +# define TCL_NORETURN1 /* nothing */ +# endif #else # define TCL_FORMAT_PRINTF(a,b) # if defined(_MSC_VER) && (_MSC_VER >= 1310) # define TCL_NORETURN _declspec(noreturn) -# define TCL_NOINLINE __declspec(noinline) # else # define TCL_NORETURN /* nothing */ -# define TCL_NOINLINE /* nothing */ # endif # define TCL_NORETURN1 /* nothing */ #endif /* @@ -178,11 +214,11 @@ * These macros are used to control whether functions are being declared for * import or export. If a function is being declared while it is being built * to be included in a shared library, then it should have the DLLEXPORT * storage class. If is being declared for use by a module that is going to * link against the shared library, then it should have the DLLIMPORT storage - * class. If the symbol is being declared for a static build or for use from a + * class. If the symbol is beind declared for a static build or for use from a * stub library, then the storage class should be empty. * * The convention is that a macro called BUILD_xxxx, where xxxx is the name of * a library we are building, is set on the compile line for sources that are * to be placed in the library. When this macro is set, the storage class will @@ -199,12 +235,59 @@ # else # define TCL_STORAGE_CLASS DLLIMPORT # endif #endif -#if !defined(CONST86) && !defined(TCL_NO_DEPRECATED) -# define CONST86 const +/* + * The following _ANSI_ARGS_ macro is to support old extensions + * written for older versions of Tcl where it permitted support + * for compilers written in the pre-prototype era of C. + * + * New code should use prototypes. + */ + +#ifndef TCL_NO_DEPRECATED +# undef _ANSI_ARGS_ +# define _ANSI_ARGS_(x) x +#endif + +/* + * Definitions that allow this header file to be used either with or without + * ANSI C features. + */ + +#ifndef INLINE +# define INLINE +#endif + +#ifdef NO_CONST +# ifndef const +# define const +# endif +#endif +#ifndef CONST +# define CONST const +#endif + +#ifdef USE_NON_CONST +# ifdef USE_COMPAT_CONST +# error define at most one of USE_NON_CONST and USE_COMPAT_CONST +# endif +# define CONST84 +# define CONST84_RETURN +#else +# ifdef USE_COMPAT_CONST +# define CONST84 +# define CONST84_RETURN const +# else +# define CONST84 const +# define CONST84_RETURN const +# endif +#endif + +#ifndef CONST86 +# define CONST86 CONST84 #endif /* * Make sure EXTERN isn't defined elsewhere. */ @@ -217,15 +300,51 @@ # define EXTERN extern "C" TCL_STORAGE_CLASS #else # define EXTERN extern TCL_STORAGE_CLASS #endif +/* + *---------------------------------------------------------------------------- + * The following code is copied from winnt.h. If we don't replicate it here, + * then can't be included after tcl.h, since tcl.h also defines + * VOID. This block is skipped under Cygwin and Mingw. + */ + +#if defined(_WIN32) && !defined(HAVE_WINNT_IGNORE_VOID) +#ifndef VOID +#define VOID void +typedef char CHAR; +typedef short SHORT; +typedef long LONG; +#endif +#endif /* _WIN32 && !HAVE_WINNT_IGNORE_VOID */ + +/* + * Macro to use instead of "void" for arguments that must have type "void *" + * in ANSI C; maps them to type "char *" in non-ANSI systems. + */ + +#ifndef __VXWORKS__ +# ifndef NO_VOID +# define VOID void +# else +# define VOID char +# endif +#endif + /* * Miscellaneous declarations. */ -typedef void *ClientData; +#ifndef _CLIENTDATA +# ifndef NO_VOID + typedef void *ClientData; +# else + typedef int *ClientData; +# endif +# define _CLIENTDATA +#endif /* * Darwin specific configure overrides (to support fat compiles, where * configure runs only once for multiple architectures): */ @@ -263,56 +382,67 @@ * tclObj.c) depends on the function * sprintf(...,"%" TCL_LL_MODIFIER "d",...). */ #if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG) -# if defined(_WIN32) +# if defined(_WIN32) && (!defined(__USE_MINGW_ANSI_STDIO) || !__USE_MINGW_ANSI_STDIO) # define TCL_WIDE_INT_TYPE __int64 -# define TCL_LL_MODIFIER "I64" -# if defined(_WIN64) -# define TCL_Z_MODIFIER "I" -# endif +# ifdef __BORLANDC__ +# define TCL_LL_MODIFIER "L" +# else /* __BORLANDC__ */ +# define TCL_LL_MODIFIER "I64" +# endif /* __BORLANDC__ */ # elif defined(__GNUC__) -# define TCL_Z_MODIFIER "z" +# define TCL_WIDE_INT_TYPE long long +# define TCL_LL_MODIFIER "ll" # else /* ! _WIN32 && ! __GNUC__ */ /* * Don't know what platform it is and configure hasn't discovered what is * going on for us. Try to guess... */ # include -# if defined(LLONG_MAX) && (LLONG_MAX == LONG_MAX) +# if (INT_MAX < LONG_MAX) # define TCL_WIDE_INT_IS_LONG 1 +# else +# define TCL_WIDE_INT_TYPE long long # endif # endif /* _WIN32 */ #endif /* !TCL_WIDE_INT_TYPE & !TCL_WIDE_INT_IS_LONG */ - -#ifndef TCL_WIDE_INT_TYPE -# define TCL_WIDE_INT_TYPE long long -#endif /* !TCL_WIDE_INT_TYPE */ +#ifdef TCL_WIDE_INT_IS_LONG +# undef TCL_WIDE_INT_TYPE +# define TCL_WIDE_INT_TYPE long +#endif /* TCL_WIDE_INT_IS_LONG */ typedef TCL_WIDE_INT_TYPE Tcl_WideInt; typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; -#ifndef TCL_LL_MODIFIER -# define TCL_LL_MODIFIER "ll" -#endif /* !TCL_LL_MODIFIER */ -#ifndef TCL_Z_MODIFIER -# if defined(__GNUC__) && !defined(_WIN32) -# define TCL_Z_MODIFIER "z" -# else -# define TCL_Z_MODIFIER "" -# endif -#endif /* !TCL_Z_MODIFIER */ -#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))) +#ifdef TCL_WIDE_INT_IS_LONG +# define Tcl_WideAsLong(val) ((long)(val)) +# define Tcl_LongAsWide(val) ((long)(val)) +# define Tcl_WideAsDouble(val) ((double)((long)(val))) +# define Tcl_DoubleAsWide(val) ((long)((double)(val))) +# ifndef TCL_LL_MODIFIER +# define TCL_LL_MODIFIER "l" +# endif /* !TCL_LL_MODIFIER */ +#else /* TCL_WIDE_INT_IS_LONG */ +/* + * The next short section of defines are only done when not running on Windows + * or some other strange platform. + */ +# ifndef TCL_LL_MODIFIER +# define TCL_LL_MODIFIER "ll" +# endif /* !TCL_LL_MODIFIER */ +# 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))) +#endif /* TCL_WIDE_INT_IS_LONG */ #if defined(_WIN32) # ifdef __BORLANDC__ typedef struct stati64 Tcl_StatBuf; -# elif defined(_WIN64) +# elif defined(_WIN64) || defined(_USE_64BIT_TIME_T) typedef struct __stat64 Tcl_StatBuf; # elif (defined(_MSC_VER) && (_MSC_VER < 1400)) || defined(_USE_32BIT_TIME_T) typedef struct _stati64 Tcl_StatBuf; # else typedef struct _stat32i64 Tcl_StatBuf; @@ -358,11 +488,43 @@ * Note: Tcl_ObjCmdProc functions do not directly set result and freeProc. * Instead, they set a Tcl_Obj member in the "real" structure that can be * accessed with Tcl_GetObjResult() and Tcl_SetObjResult(). */ -typedef struct Tcl_Interp Tcl_Interp; +typedef struct Tcl_Interp +#ifndef TCL_NO_DEPRECATED +{ + /* TIP #330: Strongly discourage extensions from using the string + * result. */ +#ifdef USE_INTERP_RESULT + char *result TCL_DEPRECATED_API("use Tcl_GetStringResult/Tcl_SetResult"); + /* If the last command returned a string + * result, this points to it. */ + void (*freeProc) (char *blockPtr) + TCL_DEPRECATED_API("use Tcl_GetStringResult/Tcl_SetResult"); + /* Zero means the string result is statically + * allocated. TCL_DYNAMIC means it was + * allocated with ckalloc and should be freed + * with ckfree. Other values give the address + * of function to invoke to free the result. + * Tcl_Eval must free it before executing next + * command. */ +#else + char *resultDontUse; /* Don't use in extensions! */ + void (*freeProcDontUse) (char *); /* Don't use in extensions! */ +#endif +#ifdef USE_INTERP_ERRORLINE + int errorLine TCL_DEPRECATED_API("use Tcl_GetErrorLine/Tcl_SetErrorLine"); + /* When TCL_ERROR is returned, this gives the + * line number within the command where the + * error occurred (1 if first line). */ +#else + int errorLineDontUse; /* Don't use in extensions! */ +#endif +} +#endif /* TCL_NO_DEPRECATED */ +Tcl_Interp; typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler; typedef struct Tcl_Channel_ *Tcl_Channel; typedef struct Tcl_ChannelTypeVersion_ *Tcl_ChannelTypeVersion; typedef struct Tcl_Command_ *Tcl_Command; @@ -389,13 +551,13 @@ * following this definition is given to each call of 'Tcl_CreateThread' and * will be called as the main fuction of the new thread created by that call. */ #if defined _WIN32 -typedef unsigned (__stdcall Tcl_ThreadCreateProc) (void *clientData); +typedef unsigned (__stdcall Tcl_ThreadCreateProc) (ClientData clientData); #else -typedef void (Tcl_ThreadCreateProc) (void *clientData); +typedef void (Tcl_ThreadCreateProc) (ClientData clientData); #endif /* * Threading function return types used for abstracting away platform * differences when writing a Tcl_ThreadCreateProc. See the NewThread function @@ -457,22 +619,23 @@ * relative to the start of the match string, not the beginning of the entire * string. */ typedef struct Tcl_RegExpIndices { - size_t start; /* Character offset of first character in + long start; /* Character offset of first character in * match. */ - size_t end; /* Character offset of first character after + long end; /* Character offset of first character after * the match. */ } Tcl_RegExpIndices; typedef struct Tcl_RegExpInfo { - size_t nsubs; /* Number of subexpressions in the compiled + int nsubs; /* Number of subexpressions in the compiled * expression. */ Tcl_RegExpIndices *matches; /* Array of nsubs match offset pairs. */ - size_t extendStart; /* The offset at which a subsequent match + long extendStart; /* The offset at which a subsequent match * might begin. */ + long reserved; /* Reserved for later use. */ } Tcl_RegExpInfo; /* * Picky compilers complain if this typdef doesn't appear before the struct's * reference in tclDecls.h. @@ -506,10 +669,12 @@ #define TCL_ERROR 1 #define TCL_RETURN 2 #define TCL_BREAK 3 #define TCL_CONTINUE 4 +#define TCL_RESULT_SIZE 200 + /* *---------------------------------------------------------------------------- * Flags to control what substitutions are performed by Tcl_SubstObj(): */ @@ -516,10 +681,26 @@ #define TCL_SUBST_COMMANDS 001 #define TCL_SUBST_VARIABLES 002 #define TCL_SUBST_BACKSLASHES 004 #define TCL_SUBST_ALL 007 +/* + * Argument descriptors for math function callbacks in expressions: + */ + +typedef enum { + TCL_INT, TCL_DOUBLE, TCL_EITHER, TCL_WIDE_INT +} Tcl_ValueType; + +typedef struct Tcl_Value { + Tcl_ValueType type; /* Indicates intValue or doubleValue is valid, + * or both. */ + long intValue; /* Integer value. */ + double doubleValue; /* Double-precision floating value. */ + Tcl_WideInt wideValue; /* Wide (min. 64-bit) integer value. */ +} Tcl_Value; + /* * Forward declaration of Tcl_Obj to prevent an error when the forward * reference to Tcl_Obj is encountered in the function types declared below. */ @@ -529,64 +710,66 @@ *---------------------------------------------------------------------------- * Function types defined by Tcl: */ typedef int (Tcl_AppInitProc) (Tcl_Interp *interp); -typedef int (Tcl_AsyncProc) (void *clientData, Tcl_Interp *interp, +typedef int (Tcl_AsyncProc) (ClientData clientData, Tcl_Interp *interp, int code); -typedef void (Tcl_ChannelProc) (void *clientData, int mask); -typedef void (Tcl_CloseProc) (void *data); -typedef void (Tcl_CmdDeleteProc) (void *clientData); -typedef int (Tcl_CmdProc) (void *clientData, Tcl_Interp *interp, - int argc, const char *argv[]); -typedef void (Tcl_CmdTraceProc) (void *clientData, Tcl_Interp *interp, +typedef void (Tcl_ChannelProc) (ClientData clientData, int mask); +typedef void (Tcl_CloseProc) (ClientData data); +typedef void (Tcl_CmdDeleteProc) (ClientData clientData); +typedef int (Tcl_CmdProc) (ClientData clientData, Tcl_Interp *interp, + int argc, CONST84 char *argv[]); +typedef void (Tcl_CmdTraceProc) (ClientData clientData, Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *proc, - void *cmdClientData, int argc, const char *argv[]); -typedef int (Tcl_CmdObjTraceProc) (void *clientData, Tcl_Interp *interp, + ClientData cmdClientData, int argc, CONST84 char *argv[]); +typedef int (Tcl_CmdObjTraceProc) (ClientData clientData, Tcl_Interp *interp, int level, const char *command, Tcl_Command commandInfo, int objc, struct Tcl_Obj *const *objv); -typedef void (Tcl_CmdObjTraceDeleteProc) (void *clientData); +typedef void (Tcl_CmdObjTraceDeleteProc) (ClientData clientData); typedef void (Tcl_DupInternalRepProc) (struct Tcl_Obj *srcPtr, struct Tcl_Obj *dupPtr); -typedef int (Tcl_EncodingConvertProc) (void *clientData, const char *src, +typedef int (Tcl_EncodingConvertProc) (ClientData clientData, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); -#define Tcl_EncodingFreeProc Tcl_FreeProc +typedef void (Tcl_EncodingFreeProc) (ClientData clientData); typedef int (Tcl_EventProc) (Tcl_Event *evPtr, int flags); -typedef void (Tcl_EventCheckProc) (void *clientData, int flags); -typedef int (Tcl_EventDeleteProc) (Tcl_Event *evPtr, void *clientData); -typedef void (Tcl_EventSetupProc) (void *clientData, int flags); -#define Tcl_ExitProc Tcl_FreeProc -typedef void (Tcl_FileProc) (void *clientData, int mask); -#define Tcl_FileFreeProc Tcl_FreeProc +typedef void (Tcl_EventCheckProc) (ClientData clientData, int flags); +typedef int (Tcl_EventDeleteProc) (Tcl_Event *evPtr, ClientData clientData); +typedef void (Tcl_EventSetupProc) (ClientData clientData, int flags); +typedef void (Tcl_ExitProc) (ClientData clientData); +typedef void (Tcl_FileProc) (ClientData clientData, int mask); +typedef void (Tcl_FileFreeProc) (ClientData clientData); typedef void (Tcl_FreeInternalRepProc) (struct Tcl_Obj *objPtr); -typedef void (Tcl_FreeProc) (void *blockPtr); -typedef void (Tcl_IdleProc) (void *clientData); -typedef void (Tcl_InterpDeleteProc) (void *clientData, +typedef void (Tcl_FreeProc) (char *blockPtr); +typedef void (Tcl_IdleProc) (ClientData clientData); +typedef void (Tcl_InterpDeleteProc) (ClientData clientData, Tcl_Interp *interp); -typedef void (Tcl_NamespaceDeleteProc) (void *clientData); -typedef int (Tcl_ObjCmdProc) (void *clientData, Tcl_Interp *interp, +typedef int (Tcl_MathProc) (ClientData clientData, Tcl_Interp *interp, + Tcl_Value *args, Tcl_Value *resultPtr); +typedef void (Tcl_NamespaceDeleteProc) (ClientData clientData); +typedef int (Tcl_ObjCmdProc) (ClientData clientData, Tcl_Interp *interp, int objc, struct Tcl_Obj *const *objv); typedef int (Tcl_PackageInitProc) (Tcl_Interp *interp); typedef int (Tcl_PackageUnloadProc) (Tcl_Interp *interp, int flags); typedef void (Tcl_PanicProc) (const char *format, ...); -typedef void (Tcl_TcpAcceptProc) (void *callbackData, Tcl_Channel chan, +typedef void (Tcl_TcpAcceptProc) (ClientData callbackData, Tcl_Channel chan, char *address, int port); -typedef void (Tcl_TimerProc) (void *clientData); +typedef void (Tcl_TimerProc) (ClientData clientData); typedef int (Tcl_SetFromAnyProc) (Tcl_Interp *interp, struct Tcl_Obj *objPtr); typedef void (Tcl_UpdateStringProc) (struct Tcl_Obj *objPtr); -typedef char * (Tcl_VarTraceProc) (void *clientData, Tcl_Interp *interp, - const char *part1, const char *part2, int flags); -typedef void (Tcl_CommandTraceProc) (void *clientData, Tcl_Interp *interp, +typedef char * (Tcl_VarTraceProc) (ClientData clientData, Tcl_Interp *interp, + CONST84 char *part1, CONST84 char *part2, int flags); +typedef void (Tcl_CommandTraceProc) (ClientData clientData, Tcl_Interp *interp, const char *oldName, const char *newName, int flags); typedef void (Tcl_CreateFileHandlerProc) (int fd, int mask, Tcl_FileProc *proc, - void *clientData); + ClientData clientData); typedef void (Tcl_DeleteFileHandlerProc) (int fd); -typedef void (Tcl_AlertNotifierProc) (void *clientData); +typedef void (Tcl_AlertNotifierProc) (ClientData clientData); typedef void (Tcl_ServiceModeHookProc) (int mode); -typedef void *(Tcl_InitNotifierProc) (void); -typedef void (Tcl_FinalizeNotifierProc) (void *clientData); +typedef ClientData (Tcl_InitNotifierProc) (void); +typedef void (Tcl_FinalizeNotifierProc) (ClientData clientData); typedef void (Tcl_MainLoopProc) (void); /* *---------------------------------------------------------------------------- * The following structure represents a type of object, which is a particular @@ -610,69 +793,85 @@ /* Called to convert the object's internal rep * to this type. Frees the internal rep of the * old type. Returns TCL_ERROR on failure. */ } Tcl_ObjType; -/* - * The following structure stores an internal representation (intrep) for - * a Tcl value. An intrep 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 intrep. - */ - -typedef union Tcl_ObjIntRep { /* 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 */ - struct { /* - internal rep as two pointers. */ - void *ptr1; - void *ptr2; - } twoPtrValue; - struct { /* - internal rep as a pointer and a long, */ - void *ptr; /* not used internally any more. */ - unsigned long value; - } ptrAndLongRep; -} Tcl_ObjIntRep; - /* * One of the following structures exists for each object in the Tcl system. * An object stores a value as either a string, some internal representation, * or both. */ typedef struct Tcl_Obj { - size_t refCount; /* When 0 the object will be freed. */ + int refCount; /* When 0 the object will be freed. */ char *bytes; /* This points to the first byte of the * object's string representation. The array * must be followed by a null byte (i.e., at * offset length) but may also contain * embedded null characters. The array's - * storage is allocated by Tcl_Alloc. NULL means + * storage is allocated by ckalloc. NULL means * the string rep is invalid and must be * regenerated from the internal rep. Clients * should use Tcl_GetStringFromObj or * Tcl_GetString to get a pointer to the byte * array as a readonly value. */ - size_t length; /* The number of bytes at *bytes, not + int length; /* The number of bytes at *bytes, not * including the terminating null. */ const Tcl_ObjType *typePtr; /* Denotes the object's type. Always * corresponds to the type of the object's * internal rep. NULL indicates the object has * no internal rep (has no type). */ - Tcl_ObjIntRep internalRep; /* The internal representation: */ + union { /* 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; /* - a long long value. */ + struct { /* - internal rep as two pointers. + * the main use of which is a bignum's + * tightly packed fields, where the alloc, + * used and signum flags are packed into + * ptr2 with everything else hung off ptr1. */ + void *ptr1; + void *ptr2; + } twoPtrValue; + struct { /* - internal rep as a pointer and a long, + not used internally any more. */ + void *ptr; + unsigned long value; + } ptrAndLongRep; + } internalRep; } Tcl_Obj; +/* + * Macros to increment and decrement a Tcl_Obj's reference count, and to test + * whether an object is shared (i.e. has reference count > 1). Note: clients + * should use Tcl_DecrRefCount() when they are finished using an object, and + * should never call TclFreeObj() directly. TclFreeObj() is only defined and + * made public in tcl.h to support Tcl_DecrRefCount's macro definition. + */ + +void Tcl_IncrRefCount(Tcl_Obj *objPtr); +void Tcl_DecrRefCount(Tcl_Obj *objPtr); +int Tcl_IsShared(Tcl_Obj *objPtr); /* *---------------------------------------------------------------------------- - * The following type contains the state needed by Tcl_SaveResult. It - * is typically allocated on the stack. + * The following structure contains the state needed by Tcl_SaveResult. No-one + * outside of Tcl should access any of these fields. This structure is + * typically allocated on the stack. */ -typedef Tcl_Obj *Tcl_SavedResult; +typedef struct Tcl_SavedResult { + char *result; + Tcl_FreeProc *freeProc; + Tcl_Obj *objResultPtr; + char *appendResult; + int appendAvl; + int appendUsed; + char resultSpace[TCL_RESULT_SIZE+1]; +} Tcl_SavedResult; /* *---------------------------------------------------------------------------- * The following definitions support Tcl's namespace facility. Note: the first * five fields must match exactly the fields in a Namespace structure (see @@ -684,11 +883,11 @@ * namespace. This contains no ::'s. The name * of the global namespace is "" although "::" * is an synonym. */ char *fullName; /* The namespace's fully qualified name. This * starts with ::. */ - void *clientData; /* Arbitrary value associated with this + ClientData clientData; /* Arbitrary value associated with this * namespace. */ Tcl_NamespaceDeleteProc *deleteProc; /* Function invoked when deleting the * namespace to, e.g., free clientData. */ struct Tcl_Namespace *parentPtr; @@ -756,17 +955,17 @@ int isNativeObjectProc; /* 1 if objProc was registered by a call to * Tcl_CreateObjCommand; 0 otherwise. * Tcl_SetCmdInfo does not modify this * field. */ Tcl_ObjCmdProc *objProc; /* Command's object-based function. */ - void *objClientData; /* ClientData for object proc. */ + ClientData objClientData; /* ClientData for object proc. */ Tcl_CmdProc *proc; /* Command's string-based function. */ - void *clientData; /* ClientData for string proc. */ + ClientData clientData; /* ClientData for string proc. */ Tcl_CmdDeleteProc *deleteProc; /* Function to call when command is * deleted. */ - void *deleteData; /* Value to pass to deleteProc (usually the + ClientData deleteData; /* Value to pass to deleteProc (usually the * same as clientData). */ Tcl_Namespace *namespacePtr;/* Points to the namespace that contains this * command. Note that Tcl_SetCmdInfo will not * change a command's namespace; use * TclRenameCommand or Tcl_Eval (of 'rename') @@ -782,26 +981,27 @@ #define TCL_DSTRING_STATIC_SIZE 200 typedef struct Tcl_DString { char *string; /* Points to beginning of string: either * staticSpace below or a malloced array. */ - size_t length; /* Number of non-NULL characters in the + int length; /* Number of non-NULL characters in the * string. */ - size_t spaceAvl; /* Total number of bytes available for the + int spaceAvl; /* Total number of bytes available for the * string and its terminating NULL char. */ char staticSpace[TCL_DSTRING_STATIC_SIZE]; /* Space to use in common case where string is * small. */ } Tcl_DString; #define Tcl_DStringLength(dsPtr) ((dsPtr)->length) #define Tcl_DStringValue(dsPtr) ((dsPtr)->string) +#define Tcl_DStringTrunc Tcl_DStringSetLength /* * Definitions for the maximum number of digits of precision that may be - * produced by Tcl_PrintDouble, and the number of bytes of buffer space - * required by Tcl_PrintDouble. + * specified in the "tcl_precision" variable, and the number of bytes of + * buffer space required by Tcl_PrintDouble. */ #define TCL_MAX_PREC 17 #define TCL_DOUBLE_SPACE (TCL_MAX_PREC+10) @@ -911,10 +1111,21 @@ #define TCL_TRACE_RENAME 0x2000 #define TCL_TRACE_DELETE 0x4000 #define TCL_ALLOW_INLINE_COMPILATION 0x20000 +/* + * The TCL_PARSE_PART1 flag is deprecated and has no effect. The part1 is now + * always parsed whenever the part2 is NULL. (This is to avoid a common error + * when converting code to use the new object based APIs and forgetting to + * give the flag) + */ + +#ifndef TCL_NO_DEPRECATED +# define TCL_PARSE_PART1 0x400 +#endif + /* * Types for linked variables: */ #define TCL_LINK_INT 1 @@ -925,53 +1136,62 @@ #define TCL_LINK_CHAR 6 #define TCL_LINK_UCHAR 7 #define TCL_LINK_SHORT 8 #define TCL_LINK_USHORT 9 #define TCL_LINK_UINT 10 -#if defined(TCL_WIDE_INT_IS_LONG) || defined(_WIN32) || defined(__CYGWIN__) -#define TCL_LINK_LONG ((sizeof(long) != sizeof(int)) ? TCL_LINK_WIDE_INT : TCL_LINK_INT) -#define TCL_LINK_ULONG ((sizeof(long) != sizeof(int)) ? TCL_LINK_WIDE_UINT : TCL_LINK_UINT) -#else #define TCL_LINK_LONG 11 #define TCL_LINK_ULONG 12 -#endif #define TCL_LINK_FLOAT 13 #define TCL_LINK_WIDE_UINT 14 -#define TCL_LINK_CHARS 15 -#define TCL_LINK_BINARY 16 #define TCL_LINK_READ_ONLY 0x80 /* *---------------------------------------------------------------------------- * Forward declarations of Tcl_HashTable and related types. */ -#ifndef TCL_HASH_TYPE -# define TCL_HASH_TYPE size_t -#endif - typedef struct Tcl_HashKeyType Tcl_HashKeyType; typedef struct Tcl_HashTable Tcl_HashTable; typedef struct Tcl_HashEntry Tcl_HashEntry; -typedef TCL_HASH_TYPE (Tcl_HashKeyProc) (Tcl_HashTable *tablePtr, void *keyPtr); +typedef unsigned (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); +/* + * This flag controls whether the hash table stores the hash of a key, or + * recalculates it. There should be no reason for turning this flag off as it + * is completely binary and source compatible unless you directly access the + * bucketPtr member of the Tcl_HashTableEntry structure. This member has been + * removed and the space used to store the hash value. + */ + +#ifndef TCL_HASH_KEY_STORE_HASH +# define TCL_HASH_KEY_STORE_HASH 1 +#endif + /* * Structure definition for an entry in a hash table. No-one outside Tcl * should access any of these fields directly; use the macros defined below. */ struct Tcl_HashEntry { Tcl_HashEntry *nextPtr; /* Pointer to next entry in this hash bucket, * or NULL for end of chain. */ Tcl_HashTable *tablePtr; /* Pointer to table containing entry. */ - size_t hash; /* Hash value. */ - void *clientData; /* Application stores something here with +#if TCL_HASH_KEY_STORE_HASH + void *hash; /* Hash value, stored as pointer to ensure + * that the offsets of the fields in this + * structure are not changed. */ +#else + Tcl_HashEntry **bucketPtr; /* Pointer to bucket that points to first + * entry in this entry's chain: used for + * deleting the entry. */ +#endif + ClientData clientData; /* Application stores something here with * Tcl_SetHashValue. */ union { /* Key has one of these forms: */ char *oneWordValue; /* One-word value for key. */ Tcl_Obj *objPtr; /* Tcl_Obj * key value. */ int words[1]; /* Multiple integer words for key. The actual @@ -1055,20 +1275,20 @@ * points to first entry in bucket's hash * chain, or NULL. */ Tcl_HashEntry *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 + int numBuckets; /* Total number of buckets allocated at * **bucketPtr. */ - size_t numEntries; /* Total number of entries present in + int numEntries; /* Total number of entries present in * table. */ - size_t rebuildSize; /* Enlarge table when numEntries gets to be + int rebuildSize; /* Enlarge table when numEntries gets to be * this large. */ - size_t mask; /* Mask value used in hashing function. */ int downShift; /* Shift count used in hashing function. * Designed to use high-order bits of * randomized keys. */ + int mask; /* Mask value used in hashing function. */ 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. */ @@ -1085,11 +1305,11 @@ * hash tables: */ typedef struct Tcl_HashSearch { Tcl_HashTable *tablePtr; /* Table being searched. */ - size_t nextIndex; /* Index of next bucket to be enumerated after + int nextIndex; /* Index of next bucket to be enumerated after * present one. */ Tcl_HashEntry *nextEntryPtr;/* Next entry to be enumerated in the current * bucket. */ } Tcl_HashSearch; @@ -1126,12 +1346,12 @@ */ typedef struct { void *next; /* Search position for underlying hash * table. */ - size_t epoch; /* Epoch marker for dictionary being searched, - * or 0 if search has terminated. */ + int epoch; /* Epoch marker for dictionary being searched, + * or -1 if search has terminated. */ Tcl_Dict dictionaryPtr; /* Reference to dictionary being searched. */ } Tcl_DictSearch; /* *---------------------------------------------------------------------------- @@ -1185,19 +1405,19 @@ typedef struct Tcl_Time { long sec; /* Seconds. */ long usec; /* Microseconds. */ } Tcl_Time; -typedef void (Tcl_SetTimerProc) (const Tcl_Time *timePtr); -typedef int (Tcl_WaitForEventProc) (const Tcl_Time *timePtr); +typedef void (Tcl_SetTimerProc) (CONST86 Tcl_Time *timePtr); +typedef int (Tcl_WaitForEventProc) (CONST86 Tcl_Time *timePtr); /* * TIP #233 (Virtualized Time) */ -typedef void (Tcl_GetTimeProc) (Tcl_Time *timebuf, void *clientData); -typedef void (Tcl_ScaleTimeProc) (Tcl_Time *timebuf, void *clientData); +typedef void (Tcl_GetTimeProc) (Tcl_Time *timebuf, ClientData clientData); +typedef void (Tcl_ScaleTimeProc) (Tcl_Time *timebuf, ClientData clientData); /* *---------------------------------------------------------------------------- * Bits to pass to Tcl_CreateFileHandler and Tcl_CreateChannelHandler to * indicate what sorts of events are of interest: @@ -1252,44 +1472,44 @@ /* * Typedefs for the various operations in a channel type: */ -typedef int (Tcl_DriverBlockModeProc) (void *instanceData, int mode); -typedef int (Tcl_DriverCloseProc) (void *instanceData, +typedef int (Tcl_DriverBlockModeProc) (ClientData instanceData, int mode); +typedef int (Tcl_DriverCloseProc) (ClientData instanceData, Tcl_Interp *interp); -typedef int (Tcl_DriverClose2Proc) (void *instanceData, +typedef int (Tcl_DriverClose2Proc) (ClientData instanceData, Tcl_Interp *interp, int flags); -typedef int (Tcl_DriverInputProc) (void *instanceData, char *buf, +typedef int (Tcl_DriverInputProc) (ClientData instanceData, char *buf, int toRead, int *errorCodePtr); -typedef int (Tcl_DriverOutputProc) (void *instanceData, - const char *buf, int toWrite, int *errorCodePtr); -typedef int (Tcl_DriverSeekProc) (void *instanceData, long offset, +typedef int (Tcl_DriverOutputProc) (ClientData instanceData, + CONST84 char *buf, int toWrite, int *errorCodePtr); +typedef int (Tcl_DriverSeekProc) (ClientData instanceData, long offset, int mode, int *errorCodePtr); -typedef int (Tcl_DriverSetOptionProc) (void *instanceData, +typedef int (Tcl_DriverSetOptionProc) (ClientData instanceData, Tcl_Interp *interp, const char *optionName, const char *value); -typedef int (Tcl_DriverGetOptionProc) (void *instanceData, - Tcl_Interp *interp, const char *optionName, +typedef int (Tcl_DriverGetOptionProc) (ClientData instanceData, + Tcl_Interp *interp, CONST84 char *optionName, Tcl_DString *dsPtr); -typedef void (Tcl_DriverWatchProc) (void *instanceData, int mask); -typedef int (Tcl_DriverGetHandleProc) (void *instanceData, - int direction, void **handlePtr); -typedef int (Tcl_DriverFlushProc) (void *instanceData); -typedef int (Tcl_DriverHandlerProc) (void *instanceData, +typedef void (Tcl_DriverWatchProc) (ClientData instanceData, int mask); +typedef int (Tcl_DriverGetHandleProc) (ClientData instanceData, + int direction, ClientData *handlePtr); +typedef int (Tcl_DriverFlushProc) (ClientData instanceData); +typedef int (Tcl_DriverHandlerProc) (ClientData instanceData, int interestMask); -typedef Tcl_WideInt (Tcl_DriverWideSeekProc) (void *instanceData, +typedef Tcl_WideInt (Tcl_DriverWideSeekProc) (ClientData instanceData, Tcl_WideInt offset, int mode, int *errorCodePtr); /* * TIP #218, Channel Thread Actions */ -typedef void (Tcl_DriverThreadActionProc) (void *instanceData, +typedef void (Tcl_DriverThreadActionProc) (ClientData instanceData, int action); /* * TIP #208, File Truncation (etc.) */ -typedef int (Tcl_DriverTruncateProc) (void *instanceData, +typedef int (Tcl_DriverTruncateProc) (ClientData instanceData, Tcl_WideInt length); /* * struct Tcl_ChannelType: * @@ -1458,26 +1678,26 @@ typedef int (Tcl_FSUtimeProc) (Tcl_Obj *pathPtr, struct utimbuf *tval); typedef int (Tcl_FSNormalizePathProc) (Tcl_Interp *interp, Tcl_Obj *pathPtr, int nextCheckpoint); typedef int (Tcl_FSFileAttrsGetProc) (Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); -typedef const char *const * (Tcl_FSFileAttrStringsProc) (Tcl_Obj *pathPtr, +typedef const char *CONST86 * (Tcl_FSFileAttrStringsProc) (Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); typedef int (Tcl_FSFileAttrsSetProc) (Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr); typedef Tcl_Obj * (Tcl_FSLinkProc) (Tcl_Obj *pathPtr, Tcl_Obj *toPtr, int linkType); typedef int (Tcl_FSLoadFileProc) (Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr); typedef int (Tcl_FSPathInFilesystemProc) (Tcl_Obj *pathPtr, - void **clientDataPtr); + ClientData *clientDataPtr); typedef Tcl_Obj * (Tcl_FSFilesystemPathTypeProc) (Tcl_Obj *pathPtr); typedef Tcl_Obj * (Tcl_FSFilesystemSeparatorProc) (Tcl_Obj *pathPtr); -#define Tcl_FSFreeInternalRepProc Tcl_FreeProc -typedef void *(Tcl_FSDupInternalRepProc) (void *clientData); -typedef Tcl_Obj * (Tcl_FSInternalToNormalizedProc) (void *clientData); -typedef void *(Tcl_FSCreateInternalRepProc) (Tcl_Obj *pathPtr); +typedef void (Tcl_FSFreeInternalRepProc) (ClientData clientData); +typedef ClientData (Tcl_FSDupInternalRepProc) (ClientData clientData); +typedef Tcl_Obj * (Tcl_FSInternalToNormalizedProc) (ClientData clientData); +typedef ClientData (Tcl_FSCreateInternalRepProc) (Tcl_Obj *pathPtr); typedef struct Tcl_FSVersion_ *Tcl_FSVersion; /* *---------------------------------------------------------------------------- @@ -1503,11 +1723,11 @@ * explanations in the structure show the importance of each function. */ typedef struct Tcl_Filesystem { const char *typeName; /* The name of the filesystem. */ - size_t structureLength; /* Length of this structure, so future binary + int structureLength; /* Length of this structure, so future binary * compatibility can be assured. */ Tcl_FSVersion version; /* Version of the filesystem type. */ Tcl_FSPathInFilesystemProc *pathInFilesystemProc; /* Function to check whether a path is in this * filesystem. This is the most important @@ -1693,12 +1913,12 @@ typedef struct Tcl_Token { int type; /* Type of token, such as TCL_TOKEN_WORD; see * below for valid types. */ const char *start; /* First character in token. */ - size_t size; /* Number of bytes in token. */ - size_t numComponents; /* If this token is composed of other tokens, + int size; /* Number of bytes in token. */ + int numComponents; /* If this token is composed of other tokens, * this field tells how many of them there are * (including components of components, etc.). * The component tokens immediately follow * this one. */ } Tcl_Token; @@ -1760,11 +1980,11 @@ * the operator, then TCL_TOKEN_SUB_EXPR tokens * for the left then the right operands. * TCL_TOKEN_OPERATOR - The token describes one expression operator. * An operator might be the name of a math * function such as "abs". A TCL_TOKEN_OPERATOR - * token is always preceeded by one + * token is always preceded by one * TCL_TOKEN_SUB_EXPR token for the operator's * subexpression, and is followed by zero or more * TCL_TOKEN_SUB_EXPR tokens for the operator's * operands. NumComponents is always 0. * TCL_TOKEN_EXPAND_WORD - This token is just like TCL_TOKEN_WORD except @@ -1808,11 +2028,11 @@ #define NUM_STATIC_TOKENS 20 typedef struct Tcl_Parse { const char *commentStart; /* Pointer to # that begins the first of one * or more comments preceding the command. */ - size_t commentSize; /* Number of bytes in comments (up through + int commentSize; /* Number of bytes in comments (up through * newline character that terminates the last * comment). If there were no comments, this * field is 0. */ const char *commandStart; /* First character in first word of * command. */ @@ -1876,14 +2096,14 @@ /* Function to convert from external encoding * into UTF-8. */ Tcl_EncodingConvertProc *fromUtfProc; /* Function to convert from UTF-8 into * external encoding. */ - Tcl_FreeProc *freeProc; + Tcl_EncodingFreeProc *freeProc; /* If non-NULL, function to call when this * encoding is deleted. */ - void *clientData; /* Arbitrary value associated with encoding + ClientData clientData; /* Arbitrary value associated with encoding * type. Passed to conversion functions. */ int nullSize; /* Number of zero bytes that signify * end-of-string in this encoding. This number * is used to determine the source string * length when the srcLen argument is @@ -1974,20 +2194,20 @@ #define TCL_CONVERT_UNKNOWN (-3) #define TCL_CONVERT_NOSPACE (-4) /* * The maximum number of bytes that are necessary to represent a single - * Unicode character in UTF-8. The valid values are 4 and 6 - * (or perhaps 1 if we want to support a non-unicode enabled core). If 4, - * then Tcl_UniChar must be 2-bytes in size (UCS-2) (the default). If 6, + * Unicode character in UTF-8. The valid values should be 3, 4 or 6 + * (or perhaps 1 if we want to support a non-unicode enabled core). If 3 or + * 4, then Tcl_UniChar must be 2-bytes in size (UCS-2) (the default). If 6, * then Tcl_UniChar must be 4-bytes in size (UCS-4). At this time UCS-2 mode * is the default and recommended mode. UCS-4 is experimental and not * recommended. It works for the core, but most extensions expect UCS-2. */ #ifndef TCL_UTF_MAX -#define TCL_UTF_MAX 4 +#define TCL_UTF_MAX 3 #endif /* * This represents a Unicode character. Any changes to this should also be * reflected in regcustom.h. @@ -2033,12 +2253,12 @@ /* * 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); -typedef void (Tcl_LimitHandlerDeleteProc) (void *clientData); +typedef void (Tcl_LimitHandlerProc) (ClientData clientData, Tcl_Interp *interp); +typedef void (Tcl_LimitHandlerDeleteProc) (ClientData clientData); /* *---------------------------------------------------------------------------- * Override definitions for libtommath. */ @@ -2045,12 +2265,10 @@ typedef struct mp_int mp_int; #define MP_INT_DECLARED typedef unsigned int mp_digit; #define MP_DIGIT_DECLARED -typedef unsigned TCL_WIDE_INT_TYPE mp_word; -#define MP_WORD_DECLARED /* *---------------------------------------------------------------------------- * Definitions needed for Tcl_ParseArgvObj routines. * Based on tkArgv.c. @@ -2065,11 +2283,11 @@ * depends on type.*/ void *dstPtr; /* Address of value to be modified; usage * depends on type.*/ const char *helpStr; /* Documentation message describing this * option. */ - void *clientData; /* Word to pass to function callbacks. */ + ClientData clientData; /* Word to pass to function callbacks. */ } Tcl_ArgvInfo; /* * Legal values for the type field of a Tcl_ArgInfo: see the user * documentation for details. @@ -2088,13 +2306,13 @@ /* * Types of callback functions for the TCL_ARGV_FUNC and TCL_ARGV_GENFUNC * argument types: */ -typedef int (Tcl_ArgvFuncProc)(void *clientData, Tcl_Obj *objPtr, +typedef int (Tcl_ArgvFuncProc)(ClientData clientData, Tcl_Obj *objPtr, void *dstPtr); -typedef int (Tcl_ArgvGenFuncProc)(void *clientData, Tcl_Interp *interp, +typedef int (Tcl_ArgvGenFuncProc)(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv, void *dstPtr); /* * Shorthand for commonly used argTable entries. */ @@ -2155,105 +2373,66 @@ */ #define TCL_LOAD_GLOBAL 1 #define TCL_LOAD_LAZY 2 -/* - *---------------------------------------------------------------------------- - * Definitions needed for the Tcl_OpenTcpServerEx function. [TIP #456] - */ -#define TCL_TCPSERVER_REUSEADDR (1<<0) -#define TCL_TCPSERVER_REUSEPORT (1<<1) - -/* - * Constants for special size_t-typed values, see TIP #494 - */ - -#define TCL_IO_FAILURE ((size_t)-1) -#define TCL_AUTO_LENGTH ((size_t)-1) -#define TCL_INDEX_NONE ((size_t)-1) - /* *---------------------------------------------------------------------------- * Single public declaration for NRE. */ -typedef int (Tcl_NRPostProc) (void *data[], Tcl_Interp *interp, +typedef int (Tcl_NRPostProc) (ClientData data[], Tcl_Interp *interp, int result); /* *---------------------------------------------------------------------------- * The following constant is used to test for older versions of Tcl in the - * stubs tables. If TCL_UTF_MAX>4 use a different value. + * stubs tables. + * + * Jan Nijtman's plus patch uses 0xFCA1BACF, so we need to pick a different + * value since the stubs tables don't match. */ -#define TCL_STUB_MAGIC ((int) 0xFCA3BACB + (int) sizeof(void *) + (TCL_UTF_MAX>4)) +#define TCL_STUB_MAGIC ((int) 0xFCA3BACF) /* * 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 * main library in case an extension is statically linked into an application. */ const char * Tcl_InitStubs(Tcl_Interp *interp, const char *version, - int exact, int magic); -const char * TclTomMathInitializeStubs(Tcl_Interp *interp, - const char *version, int epoch, int revision); -#if defined(_WIN32) - TCL_NORETURN1 void Tcl_ConsolePanic(const char *format, ...); -#else -# define Tcl_ConsolePanic NULL -#endif - -#ifdef USE_TCL_STUBS -#if TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE -# define Tcl_InitStubs(interp, version, exact) \ - (Tcl_InitStubs)(interp, version, \ - (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \ - TCL_STUB_MAGIC) -#else -# define Tcl_InitStubs(interp, version, exact) \ - (Tcl_InitStubs)(interp, TCL_PATCH_LEVEL, \ - 1|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \ - TCL_STUB_MAGIC) -#endif -#else -#if TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE -# define Tcl_InitStubs(interp, version, exact) \ - Tcl_PkgInitStubsCheck(interp, version, \ - (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16)) -#else -# define Tcl_InitStubs(interp, version, exact) \ - Tcl_PkgInitStubsCheck(interp, TCL_PATCH_LEVEL, \ - 1|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16)) -#endif -#endif + int exact); +const char * TclTomMathInitializeStubs(Tcl_Interp *interp, + const char *version, int epoch, int revision); + +/* + * When not using stubs, make it a macro. + */ + +#ifndef USE_TCL_STUBS +#define Tcl_InitStubs(interp, version, exact) \ + Tcl_PkgInitStubsCheck(interp, version, exact) +#endif + +/* + * TODO - tommath stubs export goes here! + */ /* * Public functions that are not accessible via the stubs table. * Tcl_GetMemoryInfo is needed for AOLserver. [Bug 1868171] */ #define Tcl_Main(argc, argv, proc) Tcl_MainEx(argc, argv, proc, \ - ((Tcl_SetPanicProc(Tcl_ConsolePanic), Tcl_CreateInterp)())) -EXTERN TCL_NORETURN void Tcl_MainEx(int argc, char **argv, + ((Tcl_CreateInterp)())) +EXTERN void Tcl_MainEx(int argc, char **argv, Tcl_AppInitProc *appInitProc, Tcl_Interp *interp); EXTERN const char * Tcl_PkgInitStubsCheck(Tcl_Interp *interp, const char *version, int exact); EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); -EXTERN void Tcl_FindExecutable(const char *argv0); -EXTERN void Tcl_SetPanicProc( - TCL_NORETURN1 Tcl_PanicProc *panicProc); -EXTERN void Tcl_StaticPackage(Tcl_Interp *interp, - const char *pkgName, - Tcl_PackageInitProc *initProc, - Tcl_PackageInitProc *safeInitProc); -EXTERN Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc); -#ifndef _WIN32 -EXTERN int TclZipfs_AppHook(int *argc, char ***argv); -#endif /* *---------------------------------------------------------------------------- * Include the public function declarations that are accessible via the stubs * table. @@ -2274,28 +2453,46 @@ #include "tclPlatDecls.h" /* *---------------------------------------------------------------------------- - * The following declarations map ckalloc and ckfree to Tcl_Alloc and - * Tcl_Free. + * The following declarations either map ckalloc and ckfree to malloc and + * free, or they map them to functions with all sorts of debugging hooks + * defined in tclCkalloc.c. */ -#define ckalloc Tcl_Alloc -#define ckfree Tcl_Free -#define ckrealloc Tcl_Realloc -#define attemptckalloc Tcl_AttemptAlloc -#define attemptckrealloc Tcl_AttemptRealloc +#ifdef TCL_MEM_DEBUG + +# define ckalloc(x) \ + ((void *) Tcl_DbCkalloc((unsigned)(x), __FILE__, __LINE__)) +# define ckfree(x) \ + Tcl_DbCkfree((char *)(x), __FILE__, __LINE__) +# define ckrealloc(x,y) \ + ((void *) Tcl_DbCkrealloc((char *)(x), (unsigned)(y), __FILE__, __LINE__)) +# define attemptckalloc(x) \ + ((void *) Tcl_AttemptDbCkalloc((unsigned)(x), __FILE__, __LINE__)) +# define attemptckrealloc(x,y) \ + ((void *) Tcl_AttemptDbCkrealloc((char *)(x), (unsigned)(y), __FILE__, __LINE__)) -#ifndef TCL_MEM_DEBUG +#else /* !TCL_MEM_DEBUG */ /* * If we are not using the debugging allocator, we should call the Tcl_Alloc, * et al. routines in order to guarantee that every module is using the same * memory allocator both inside and outside of the Tcl library. */ +# define ckalloc(x) \ + ((void *) Tcl_Alloc((unsigned)(x))) +# define ckfree(x) \ + Tcl_Free((char *)(x)) +# define ckrealloc(x,y) \ + ((void *) Tcl_Realloc((char *)(x), (unsigned)(y))) +# define attemptckalloc(x) \ + ((void *) Tcl_AttemptAlloc((unsigned)(x))) +# define attemptckrealloc(x,y) \ + ((void *) Tcl_AttemptRealloc((char *)(x), (unsigned)(y))) # undef Tcl_InitMemory # define Tcl_InitMemory(x) # undef Tcl_DumpActiveMemory # define Tcl_DumpActiveMemory(x) # undef Tcl_ValidateAllMemory @@ -2302,19 +2499,32 @@ # define Tcl_ValidateAllMemory(x,y) #endif /* !TCL_MEM_DEBUG */ #ifdef TCL_MEM_DEBUG -# undef Tcl_IncrRefCount # define Tcl_IncrRefCount(objPtr) \ Tcl_DbIncrRefCount(objPtr, __FILE__, __LINE__) -# undef Tcl_DecrRefCount # define Tcl_DecrRefCount(objPtr) \ Tcl_DbDecrRefCount(objPtr, __FILE__, __LINE__) -# undef Tcl_IsShared # define Tcl_IsShared(objPtr) \ Tcl_DbIsShared(objPtr, __FILE__, __LINE__) +#else +# define Tcl_IncrRefCount(objPtr) \ + ++(objPtr)->refCount + /* + * Use do/while0 idiom for optimum correctness without compiler warnings. + * http://c2.com/cgi/wiki?TrivialDoWhileLoop + */ +# define Tcl_DecrRefCount(objPtr) \ + do { \ + Tcl_Obj *_objPtr = (objPtr); \ + if (_objPtr->refCount-- <= 1) { \ + TclFreeObj(_objPtr); \ + } \ + } while(0) +# define Tcl_IsShared(objPtr) \ + ((objPtr)->refCount > 1) #endif /* * Macros and definitions that help to debug the use of Tcl objects. When * TCL_MEM_DEBUG is defined, the Tcl_New declarations are overridden to call @@ -2325,20 +2535,26 @@ # undef Tcl_NewBignumObj # define Tcl_NewBignumObj(val) \ Tcl_DbNewBignumObj(val, __FILE__, __LINE__) # undef Tcl_NewBooleanObj # define Tcl_NewBooleanObj(val) \ - Tcl_DbNewWideIntObj((val)!=0, __FILE__, __LINE__) + Tcl_DbNewBooleanObj(val, __FILE__, __LINE__) # undef Tcl_NewByteArrayObj # define Tcl_NewByteArrayObj(bytes, len) \ Tcl_DbNewByteArrayObj(bytes, len, __FILE__, __LINE__) # undef Tcl_NewDoubleObj # define Tcl_NewDoubleObj(val) \ Tcl_DbNewDoubleObj(val, __FILE__, __LINE__) +# undef Tcl_NewIntObj +# define Tcl_NewIntObj(val) \ + Tcl_DbNewLongObj(val, __FILE__, __LINE__) # undef Tcl_NewListObj # define Tcl_NewListObj(objc, objv) \ Tcl_DbNewListObj(objc, objv, __FILE__, __LINE__) +# undef Tcl_NewLongObj +# define Tcl_NewLongObj(val) \ + Tcl_DbNewLongObj(val, __FILE__, __LINE__) # undef Tcl_NewObj # define Tcl_NewObj() \ Tcl_DbNewObj(__FILE__, __LINE__) # undef Tcl_NewStringObj # define Tcl_NewStringObj(bytes, len) \ @@ -2352,11 +2568,11 @@ *---------------------------------------------------------------------------- * Macros for clients to use to access fields of hash entries: */ #define Tcl_GetHashValue(h) ((h)->clientData) -#define Tcl_SetHashValue(h, value) ((h)->clientData = (void *) (value)) +#define Tcl_SetHashValue(h, value) ((h)->clientData = (ClientData) (value)) #define Tcl_GetHashKey(tablePtr, h) \ ((void *) (((tablePtr)->keyType == TCL_ONE_WORD_KEYS || \ (tablePtr)->keyType == TCL_CUSTOM_PTR_KEYS) \ ? (h)->key.oneWordValue \ : (h)->key.string)) @@ -2364,15 +2580,69 @@ /* * Macros to use for clients to use to invoke find and create functions for * hash tables: */ +#undef Tcl_FindHashEntry #define Tcl_FindHashEntry(tablePtr, key) \ (*((tablePtr)->findProc))(tablePtr, (const char *)(key)) +#undef Tcl_CreateHashEntry #define Tcl_CreateHashEntry(tablePtr, key, newPtr) \ (*((tablePtr)->createProc))(tablePtr, (const char *)(key), newPtr) +/* + *---------------------------------------------------------------------------- + * Macros that eliminate the overhead of the thread synchronization functions + * when compiling without thread support. + */ + +#ifndef TCL_THREADS +#undef Tcl_MutexLock +#define Tcl_MutexLock(mutexPtr) +#undef Tcl_MutexUnlock +#define Tcl_MutexUnlock(mutexPtr) +#undef Tcl_MutexFinalize +#define Tcl_MutexFinalize(mutexPtr) +#undef Tcl_ConditionNotify +#define Tcl_ConditionNotify(condPtr) +#undef Tcl_ConditionWait +#define Tcl_ConditionWait(condPtr, mutexPtr, timePtr) +#undef Tcl_ConditionFinalize +#define Tcl_ConditionFinalize(condPtr) +#endif /* TCL_THREADS */ + +/* + *---------------------------------------------------------------------------- + * Deprecated Tcl functions: + */ + +#ifndef TCL_NO_DEPRECATED +/* + * These function have been renamed. The old names are deprecated, but we + * define these macros for backwards compatibility. + */ + +# define Tcl_Ckalloc Tcl_Alloc +# define Tcl_Ckfree Tcl_Free +# define Tcl_Ckrealloc Tcl_Realloc +# define Tcl_Return Tcl_SetResult +# define Tcl_TildeSubst Tcl_TranslateFileName +#if !defined(__APPLE__) /* On OSX, there is a conflict with "mach/mach.h" */ +# define panic Tcl_Panic +#endif +# define panicVA Tcl_PanicVA +#endif /* !TCL_NO_DEPRECATED */ + +/* + *---------------------------------------------------------------------------- + * Convenience declaration of Tcl_AppInit for backwards compatibility. This + * function is not *implemented* by the tcl library, so the storage class is + * neither DLLEXPORT nor DLLIMPORT. + */ + +extern Tcl_AppInitProc Tcl_AppInit; + #endif /* RC_INVOKED */ /* * end block for C++ */ Index: generic/tclAlloc.c ================================================================== --- generic/tclAlloc.c +++ generic/tclAlloc.c @@ -20,21 +20,21 @@ * Windows and Unix use an alternative allocator when building with threads * that has significantly reduced lock contention. */ #include "tclInt.h" -#if !TCL_THREADS || !defined(USE_THREAD_ALLOC) +#if !defined(TCL_THREADS) || !defined(USE_THREAD_ALLOC) -#if USE_TCLALLOC +#if defined(USE_TCLALLOC) && USE_TCLALLOC /* * We should really make use of AC_CHECK_TYPE(caddr_t) here, but it can wait * until Tcl uses config.h properly. */ #if defined(_MSC_VER) || defined(__MSVCRT__) || defined(__BORLANDC__) -typedef size_t caddr_t; +typedef unsigned long caddr_t; #endif /* * The overhead on a block is at least 8 bytes. When free, this space contains * a pointer to the next free block, and the bottom two bits must be zero. @@ -54,11 +54,11 @@ unsigned char index; /* bucket # */ unsigned char unused; /* unused */ unsigned char magic1; /* other magic number */ #ifndef NDEBUG unsigned short rmagic; /* range magic number */ - size_t size; /* actual block size */ + unsigned long size; /* actual block size */ unsigned short unused2; /* padding to 8-byte align */ #endif } ovu; #define overMagic0 ovu.magic0 #define overMagic1 ovu.magic1 @@ -66,11 +66,11 @@ #define rangeCheckMagic ovu.rmagic #define realBlockSize ovu.size }; -#define MAGIC 0xef /* magic # on accounting info */ +#define MAGIC 0xEF /* magic # on accounting info */ #define RMAGIC 0x5555 /* magic # on range info */ #ifndef NDEBUG #define RSLOP sizeof(unsigned short) #else @@ -119,11 +119,11 @@ * initialized. Futhermore, because Tcl_Alloc may be used before anything else * in Tcl, we make this module self-initializing after all with the allocInit * variable. */ -#if TCL_THREADS +#ifdef TCL_THREADS static Tcl_Mutex *allocMutexPtr; #endif static int allocInit = 0; #ifdef MSTATS @@ -131,11 +131,11 @@ /* * numMallocs[i] is the difference between the number of mallocs and frees for * a given block size. */ -static size_t numMallocs[NBUCKETS+1]; +static unsigned int numMallocs[NBUCKETS+1]; #endif #if !defined(NDEBUG) #define ASSERT(p) if (!(p)) Tcl_Panic(# p) #define RANGE_ASSERT(p) if (!(p)) Tcl_Panic(# p) @@ -146,11 +146,11 @@ /* * Prototypes for functions used only in this file. */ -static void MoreCore(size_t bucket); +static void MoreCore(int bucket); /* *------------------------------------------------------------------------- * * TclInitAlloc -- @@ -169,11 +169,11 @@ void TclInitAlloc(void) { if (!allocInit) { allocInit = 1; -#if TCL_THREADS +#ifdef TCL_THREADS allocMutexPtr = Tcl_GetAllocMutex(); #endif } } @@ -247,17 +247,17 @@ * None. * *---------------------------------------------------------------------- */ -void * +char * TclpAlloc( - size_t numBytes) /* Number of bytes to allocate. */ + unsigned int numBytes) /* Number of bytes to allocate. */ { - register union overhead *overPtr; - register size_t bucket; - register size_t amount; + union overhead *overPtr; + long bucket; + unsigned amount; struct block *bigBlockPtr = NULL; if (!allocInit) { /* * We have to make the "self initializing" because Tcl_Alloc may be @@ -272,12 +272,12 @@ * First the simple case: we simple allocate big blocks directly. */ if (numBytes >= MAXMALLOC - OVERHEAD) { if (numBytes <= UINT_MAX - OVERHEAD -sizeof(struct block)) { - bigBlockPtr = TclpSysAlloc( - sizeof(struct block) + OVERHEAD + numBytes); + bigBlockPtr = (struct block *) TclpSysAlloc( + (sizeof(struct block) + OVERHEAD + numBytes), 0); } if (bigBlockPtr == NULL) { Tcl_MutexUnlock(allocMutexPtr); return NULL; } @@ -286,11 +286,11 @@ bigBlockPtr->prevPtr = &bigBlocks; bigBlockPtr->nextPtr->prevPtr = bigBlockPtr; overPtr = (union overhead *) (bigBlockPtr + 1); overPtr->overMagic0 = overPtr->overMagic1 = MAGIC; - overPtr->bucketIndex = 0xff; + overPtr->bucketIndex = 0xFF; #ifdef MSTATS numMallocs[NBUCKETS]++; #endif #ifndef NDEBUG @@ -343,11 +343,11 @@ * Remove from linked list */ nextf[bucket] = overPtr->next; overPtr->overMagic0 = overPtr->overMagic1 = MAGIC; - overPtr->bucketIndex = (unsigned char) bucket; + overPtr->bucketIndex = UCHAR(bucket); #ifdef MSTATS numMallocs[bucket]++; #endif @@ -383,31 +383,32 @@ *---------------------------------------------------------------------- */ static void MoreCore( - size_t bucket) /* What bucket to allocate to. */ + int bucket) /* What bucket to allocat to. */ { - register union overhead *overPtr; - register size_t size; /* size of desired block */ - size_t amount; /* amount to allocate */ - size_t numBlocks; /* how many blocks we get */ + union overhead *overPtr; + long size; /* size of desired block */ + long amount; /* amount to allocate */ + int numBlocks; /* how many blocks we get */ struct block *blockPtr; /* * sbrk_size <= 0 only for big, FLUFFY, requests (about 2^30 bytes on a * VAX, I think) or for a negative arg. */ - size = ((size_t)1) << (bucket + 3); + size = 1 << (bucket + 3); ASSERT(size > 0); amount = MAXMALLOC; numBlocks = amount / size; ASSERT(numBlocks*size == amount); - blockPtr = TclpSysAlloc(sizeof(struct block) + amount); + blockPtr = (struct block *) TclpSysAlloc( + (sizeof(struct block) + amount), 1); /* no more room! */ if (blockPtr == NULL) { return; } blockPtr->nextPtr = blockList; @@ -443,14 +444,14 @@ *---------------------------------------------------------------------- */ void TclpFree( - void *oldPtr) /* Pointer to memory to free. */ + char *oldPtr) /* Pointer to memory to free. */ { - register size_t size; - register union overhead *overPtr; + long size; + union overhead *overPtr; struct block *bigBlockPtr; if (oldPtr == NULL) { return; } @@ -466,11 +467,11 @@ } RANGE_ASSERT(overPtr->rangeCheckMagic == RMAGIC); RANGE_ASSERT(BLOCK_END(overPtr) == RMAGIC); size = overPtr->bucketIndex; - if (size == 0xff) { + if (size == 0xFF) { #ifdef MSTATS numMallocs[NBUCKETS]--; #endif bigBlockPtr = (struct block *) overPtr - 1; @@ -506,20 +507,20 @@ * None. * *---------------------------------------------------------------------- */ -void * +char * TclpRealloc( - void *oldPtr, /* Pointer to alloced block. */ - size_t numBytes) /* New size of memory. */ + char *oldPtr, /* Pointer to alloced block. */ + unsigned int numBytes) /* New size of memory. */ { int i; union overhead *overPtr; struct block *bigBlockPtr; int expensive; - size_t maxSize; + unsigned long maxSize; if (oldPtr == NULL) { return TclpAlloc(numBytes); } @@ -540,11 +541,11 @@ /* * If the block isn't in a bin, just realloc it. */ - if (i == 0xff) { + if (i == 0xFF) { struct block *prevPtr, *nextPtr; bigBlockPtr = (struct block *) overPtr - 1; prevPtr = bigBlockPtr->prevPtr; nextPtr = bigBlockPtr->nextPtr; bigBlockPtr = (struct block *) TclpSysRealloc(bigBlockPtr, @@ -642,33 +643,33 @@ #ifdef MSTATS void mstats( char *s) /* Where to write info. */ { - register unsigned int i, j; - register union overhead *overPtr; - size_t totalFree = 0, totalUsed = 0; + int i, j; + union overhead *overPtr; + int totalFree = 0, totalUsed = 0; Tcl_MutexLock(allocMutexPtr); fprintf(stderr, "Memory allocation statistics %s\nTclpFree:\t", s); for (i = 0; i < NBUCKETS; i++) { for (j=0, overPtr=nextf[i]; overPtr; overPtr=overPtr->next, j++) { - fprintf(stderr, " %u", j); + fprintf(stderr, " %d", j); } - totalFree += ((size_t)j) * (1 << (i + 3)); + totalFree += j * (1 << (i + 3)); } fprintf(stderr, "\nused:\t"); for (i = 0; i < NBUCKETS; i++) { - fprintf(stderr, " %" TCL_Z_MODIFIER "u", numMallocs[i]); + fprintf(stderr, " %d", numMallocs[i]); totalUsed += numMallocs[i] * (1 << (i + 3)); } - fprintf(stderr, "\n\tTotal small in use: %" TCL_Z_MODIFIER "u, total free: %" TCL_Z_MODIFIER "u\n", - totalUsed, totalFree); - fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %" TCL_Z_MODIFIER "u\n", + fprintf(stderr, "\n\tTotal small in use: %d, total free: %d\n", + totalUsed, totalFree); + fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %d\n", MAXMALLOC, numMallocs[NBUCKETS]); Tcl_MutexUnlock(allocMutexPtr); } #endif @@ -689,16 +690,15 @@ * None. * *---------------------------------------------------------------------- */ -#undef TclpAlloc -void * +char * TclpAlloc( - size_t numBytes) /* Number of bytes to allocate. */ + unsigned int numBytes) /* Number of bytes to allocate. */ { - return malloc(numBytes); + return (char *) malloc(numBytes); } /* *---------------------------------------------------------------------- * @@ -713,14 +713,13 @@ * None. * *---------------------------------------------------------------------- */ -#undef TclpFree void TclpFree( - void *oldPtr) /* Pointer to memory to free. */ + char *oldPtr) /* Pointer to memory to free. */ { free(oldPtr); return; } @@ -738,16 +737,16 @@ * None. * *---------------------------------------------------------------------- */ -void * +char * TclpRealloc( - void *oldPtr, /* Pointer to alloced block. */ - size_t numBytes) /* New size of memory. */ + char *oldPtr, /* Pointer to alloced block. */ + unsigned int numBytes) /* New size of memory. */ { - return realloc(oldPtr, numBytes); + return (char *) realloc(oldPtr, numBytes); } #endif /* !USE_TCLALLOC */ #endif /* !TCL_THREADS */ Index: generic/tclAssembly.c ================================================================== --- generic/tclAssembly.c +++ generic/tclAssembly.c @@ -30,11 +30,10 @@ */ #include "tclInt.h" #include "tclCompile.h" #include "tclOOInt.h" -#include /* * Structure that represents a range of instructions in the bytecode. */ @@ -143,12 +142,10 @@ ASSEM_CONCAT1, /* 1-byte unsigned-integer operand count, must * be strictly positive, consumes N, produces * 1 */ ASSEM_DICT_GET, /* 'dict get' and related - consumes N+1 * operands, produces 1, N > 0 */ - ASSEM_DICT_GET_DEF, /* 'dict getwithdefault' - consumes N+2 - * operands, produces 1, N > 0 */ ASSEM_DICT_SET, /* specifies key count and LVT index, consumes * N+1 operands, produces 1, N > 0 */ ASSEM_DICT_UNSET, /* specifies key count and LVT index, consumes * N operands, produces 1, N > 0 */ ASSEM_END_CATCH, /* End catch. No args. Exception range popped @@ -272,25 +269,27 @@ Tcl_Obj *objPtr); static void CompileEmbeddedScript(AssemblyEnv*, Tcl_Token*, const TalInstDesc*); static int DefineLabel(AssemblyEnv* envPtr, const char* label); static void DeleteMirrorJumpTable(JumptableInfo* jtPtr); +static void DupAssembleCodeInternalRep(Tcl_Obj* src, + Tcl_Obj* dest); static void FillInJumpOffsets(AssemblyEnv*); static int CreateMirrorJumpTable(AssemblyEnv* assemEnvPtr, Tcl_Obj* jumpTable); static int FindLocalVar(AssemblyEnv* envPtr, Tcl_Token** tokenPtrPtr); static int FinishAssembly(AssemblyEnv*); +static void FreeAssembleCodeInternalRep(Tcl_Obj *objPtr); static void FreeAssemblyEnv(AssemblyEnv*); static int GetBooleanOperand(AssemblyEnv*, Tcl_Token**, int*); static int GetListIndexOperand(AssemblyEnv*, Tcl_Token**, int*); static int GetIntegerOperand(AssemblyEnv*, Tcl_Token**, int*); static int GetNextOperand(AssemblyEnv*, Tcl_Token**, Tcl_Obj**); static void LookForFreshCatches(BasicBlock*, BasicBlock**); static void MoveCodeForJumps(AssemblyEnv*, int); -static void MoveExceptionRangesToBasicBlock(AssemblyEnv*, int, - int); +static void MoveExceptionRangesToBasicBlock(AssemblyEnv*, int); static AssemblyEnv* NewAssemblyEnv(CompileEnv*, int); static int ProcessCatches(AssemblyEnv*); static int ProcessCatchesInBasicBlock(AssemblyEnv*, BasicBlock*, BasicBlock*, enum BasicBlockCatchState, int); static void ResetVisitedBasicBlocks(AssemblyEnv*); @@ -316,13 +315,10 @@ /* * Tcl_ObjType that describes bytecode emitted by the assembler. */ -static Tcl_FreeInternalRepProc FreeAssembleCodeInternalRep; -static Tcl_DupInternalRepProc DupAssembleCodeInternalRep; - static const Tcl_ObjType assembleCodeType = { "assemblecode", FreeAssembleCodeInternalRep, /* freeIntRepProc */ DupAssembleCodeInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ @@ -362,11 +358,10 @@ {"currentNamespace",ASSEM_1BYTE, INST_NS_CURRENT, 0, 1}, {"dictAppend", ASSEM_LVT4, INST_DICT_APPEND, 2, 1}, {"dictExists", ASSEM_DICT_GET, INST_DICT_EXISTS, INT_MIN,1}, {"dictExpand", ASSEM_1BYTE, INST_DICT_EXPAND, 3, 1}, {"dictGet", ASSEM_DICT_GET, INST_DICT_GET, INT_MIN,1}, - {"dictGetDef", ASSEM_DICT_GET_DEF, INST_DICT_GET_DEF, INT_MIN,1}, {"dictIncrImm", ASSEM_SINT4_LVT4, INST_DICT_INCR_IMM, 1, 1}, {"dictLappend", ASSEM_LVT4, INST_DICT_LAPPEND, 2, 1}, {"dictRecombineStk",ASSEM_1BYTE, INST_DICT_RECOMBINE_STK,3, 0}, {"dictRecombineImm",ASSEM_LVT4, INST_DICT_RECOMBINE_IMM,2, 0}, @@ -408,10 +403,11 @@ {"jumpFalse4", ASSEM_JUMP4, INST_JUMP_FALSE4, 1, 0}, {"jumpTable", ASSEM_JUMPTABLE,INST_JUMP_TABLE, 1, 0}, {"jumpTrue", ASSEM_JUMP, INST_JUMP_TRUE1, 1, 0}, {"jumpTrue4", ASSEM_JUMP4, INST_JUMP_TRUE4, 1, 0}, {"label", ASSEM_LABEL, 0, 0, 0}, + {"land", ASSEM_1BYTE, INST_LAND, 2, 1}, {"lappend", ASSEM_LVT, (INST_LAPPEND_SCALAR1<<8 | INST_LAPPEND_SCALAR4), 1, 1}, {"lappendArray", ASSEM_LVT, (INST_LAPPEND_ARRAY1<<8 | INST_LAPPEND_ARRAY4),2, 1}, @@ -435,10 +431,11 @@ | INST_LOAD_SCALAR4), 0, 1}, {"loadArray", ASSEM_LVT, (INST_LOAD_ARRAY1<<8 | INST_LOAD_ARRAY4), 1, 1}, {"loadArrayStk", ASSEM_1BYTE, INST_LOAD_ARRAY_STK, 2, 1}, {"loadStk", ASSEM_1BYTE, INST_LOAD_STK, 1, 1}, + {"lor", ASSEM_1BYTE, INST_LOR, 2, 1}, {"lsetFlat", ASSEM_LSET_FLAT,INST_LSET_FLAT, INT_MIN,1}, {"lsetList", ASSEM_1BYTE, INST_LSET_LIST, 3, 1}, {"lshift", ASSEM_1BYTE, INST_LSHIFT, 2, 1}, {"lt", ASSEM_1BYTE, INST_LT, 2, 1}, {"mod", ASSEM_1BYTE, INST_MOD, 2, 1}, @@ -470,16 +467,12 @@ {"strcaseUpper", ASSEM_1BYTE, INST_STR_UPPER, 1, 1}, {"strcmp", ASSEM_1BYTE, INST_STR_CMP, 2, 1}, {"strcat", ASSEM_CONCAT1, INST_STR_CONCAT1, INT_MIN,1}, {"streq", ASSEM_1BYTE, INST_STR_EQ, 2, 1}, {"strfind", ASSEM_1BYTE, INST_STR_FIND, 2, 1}, - {"strge", ASSEM_1BYTE, INST_STR_GE, 2, 1}, - {"strgt", ASSEM_1BYTE, INST_STR_GT, 2, 1}, {"strindex", ASSEM_1BYTE, INST_STR_INDEX, 2, 1}, - {"strle", ASSEM_1BYTE, INST_STR_LE, 2, 1}, {"strlen", ASSEM_1BYTE, INST_STR_LEN, 1, 1}, - {"strlt", ASSEM_1BYTE, INST_STR_LT, 2, 1}, {"strmap", ASSEM_1BYTE, INST_STR_MAP, 3, 1}, {"strmatch", ASSEM_BOOL, INST_STR_MATCH, 2, 1}, {"strneq", ASSEM_1BYTE, INST_STR_NEQ, 2, 1}, {"strrange", ASSEM_1BYTE, INST_STR_RANGE, 3, 1}, {"strreplace", ASSEM_1BYTE, INST_STR_REPLACE, 4, 1}, @@ -532,12 +525,11 @@ INST_INFO_LEVEL_NUM, /* 152 */ INST_RESOLVE_COMMAND, /* 154 */ INST_STR_TRIM, INST_STR_TRIM_LEFT, INST_STR_TRIM_RIGHT, /* 166-168 */ INST_CONCAT_STK, /* 169 */ INST_STR_UPPER, INST_STR_LOWER, INST_STR_TITLE, /* 170-172 */ - INST_NUM_TYPE, /* 180 */ - INST_STR_LT, INST_STR_GT, INST_STR_LE, INST_STR_GE /* 191-194 */ + INST_NUM_TYPE /* 180 */ }; /* * Helper macros. */ @@ -624,18 +616,14 @@ int consumed = TalInstructionTable[tblIdx].operandsConsumed; int produced = TalInstructionTable[tblIdx].operandsProduced; if (consumed == INT_MIN) { /* - * The instruction is variadic; it consumes 'count' operands, or - * 'count+1' for ASSEM_DICT_GET_DEF. + * The instruction is variadic; it consumes 'count' operands. */ consumed = count; - if (TalInstructionTable[tblIdx].instType == ASSEM_DICT_GET_DEF) { - consumed++; - } } if (produced < 0) { /* * The instruction leaves some of its variadic operands on the stack, * with net stack effect of '-1-produced' @@ -673,11 +661,11 @@ { CompileEnv* envPtr = assemEnvPtr->envPtr; /* Compilation environment */ BasicBlock* bbPtr = assemEnvPtr->curr_bb; /* Current basic block */ - int op = TalInstructionTable[tblIdx].tclInstCode & 0xff; + int op = TalInstructionTable[tblIdx].tclInstCode & 0xFF; /* * If this is the first instruction in a basic block, record its line * number. */ @@ -735,17 +723,17 @@ /* Compilation environment */ BasicBlock* bbPtr = assemEnvPtr->curr_bb; /* Current basic block */ int op = TalInstructionTable[tblIdx].tclInstCode; - if (param <= 0xff) { + if (param <= 0xFF) { op >>= 8; } else { - op &= 0xff; + op &= 0xFF; } TclEmitInt1(op, envPtr); - if (param <= 0xff) { + if (param <= 0xFF) { TclEmitInt1(param, envPtr); } else { TclEmitInt4(param, envPtr); } TclUpdateAtCmdStart(op, envPtr); @@ -793,10 +781,11 @@ { ByteCode *codePtr; /* Pointer to the bytecode to execute */ Tcl_Obj* backtrace; /* Object where extra error information is * constructed. */ + (void)dummy; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "bytecodeList"); return TCL_ERROR; } @@ -812,11 +801,11 @@ if (codePtr == NULL) { Tcl_AddErrorInfo(interp, "\n (\""); Tcl_AppendObjToErrorInfo(interp, objv[0]); Tcl_AddErrorInfo(interp, "\" body, line "); - backtrace = Tcl_NewWideIntObj(Tcl_GetErrorLine(interp)); + TclNewIntObj(backtrace, Tcl_GetErrorLine(interp)); Tcl_AppendObjToErrorInfo(interp, backtrace); Tcl_AddErrorInfo(interp, ")"); return TCL_ERROR; } @@ -855,21 +844,21 @@ /* Bytecode resulting from the assembly */ Namespace* namespacePtr; /* Namespace in which variable and command * names in the bytecode resolve */ int status; /* Status return from Tcl_AssembleCode */ const char* source; /* String representation of the source code */ - size_t sourceLen; /* Length of the source code in bytes */ + int sourceLen; /* Length of the source code in bytes */ + /* * Get the expression ByteCode from the object. If it exists, make sure it * is valid in the current context. */ - ByteCodeGetIntRep(objPtr, &assembleCodeType, codePtr); - - if (codePtr) { + if (objPtr->typePtr == &assembleCodeType) { namespacePtr = iPtr->varFramePtr->nsPtr; + codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle == iPtr) && (codePtr->compileEpoch == iPtr->compileEpoch) && (codePtr->nsPtr == namespacePtr) && (codePtr->nsEpoch == namespacePtr->resolverEpoch) && (codePtr->localCachePtr @@ -879,11 +868,11 @@ /* * Not valid, so free it and regenerate. */ - Tcl_StoreIntRep(objPtr, &assembleCodeType, NULL); + FreeAssembleCodeInternalRep(objPtr); } /* * Set up the compilation environment, and assemble the code. */ @@ -904,17 +893,19 @@ * into a ByteCode object. Ownership of the literal objects and aux data * items is given to the ByteCode object. */ TclEmitOpcode(INST_DONE, &compEnv); - codePtr = TclInitByteCodeObj(objPtr, &assembleCodeType, &compEnv); + TclInitByteCodeObj(objPtr, &compEnv); + objPtr->typePtr = &assembleCodeType; TclFreeCompileEnv(&compEnv); /* * Record the local variable context to which the bytecode pertains */ + codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; } @@ -966,11 +957,11 @@ Tcl_Token *tokenPtr; /* Token in the input script */ int numCommands = envPtr->numCommands; int offset = envPtr->codeNext - envPtr->codeStart; int depth = envPtr->currStackDepth; - + (void)cmdPtr; /* * Make sure that the command has a single arg that is a simple word. */ if (parsePtr->numWords != 2) { @@ -989,11 +980,11 @@ if (TCL_ERROR == TclAssembleCode(envPtr, tokenPtr[1].start, tokenPtr[1].size, TCL_EVAL_DIRECT)) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (\"%.*s\" body, line %d)", - (int)parsePtr->tokenPtr->size, parsePtr->tokenPtr->start, + parsePtr->tokenPtr->size, parsePtr->tokenPtr->start, Tcl_GetErrorLine(interp))); envPtr->numCommands = numCommands; envPtr->codeNext = envPtr->codeStart + offset; envPtr->currStackDepth = depth; TclCompileSyntaxError(interp, envPtr); @@ -1076,11 +1067,11 @@ /* * Process the line of code. */ if (parsePtr->numWords > 0) { - size_t instLen = parsePtr->commandSize; + int instLen = parsePtr->commandSize; /* Length in bytes of the current command */ if (parsePtr->term == parsePtr->commandStart + instLen - 1) { --instLen; } @@ -1089,12 +1080,12 @@ * If tracing, show each line assembled as it happens. */ #ifdef TCL_COMPILE_DEBUG if ((tclTraceCompile >= 2) && (envPtr->procPtr == NULL)) { - printf(" %4" TCL_Z_MODIFIER "d Assembling: ", - envPtr->codeNext - envPtr->codeStart); + printf(" %4ld Assembling: ", + (long)(envPtr->codeNext - envPtr->codeStart)); TclPrintSource(stdout, parsePtr->commandStart, TclMin(instLen, 55)); printf("\n"); } #endif @@ -1216,18 +1207,18 @@ for (thisBB = assemEnvPtr->head_bb; thisBB != NULL; thisBB = nextBB) { if (thisBB->jumpTarget != NULL) { Tcl_DecrRefCount(thisBB->jumpTarget); } if (thisBB->foreignExceptions != NULL) { - Tcl_Free(thisBB->foreignExceptions); + ckfree(thisBB->foreignExceptions); } nextBB = thisBB->successor1; if (thisBB->jtPtr != NULL) { DeleteMirrorJumpTable(thisBB->jtPtr); thisBB->jtPtr = NULL; } - Tcl_Free(thisBB); + ckfree(thisBB); } /* * Dispose what's left. */ @@ -1269,11 +1260,11 @@ * instruction */ enum TalInstType instType; /* Type of the instruction */ Tcl_Obj* operand1Obj = NULL; /* First operand to the instruction */ const char* operand1; /* String rep of the operand */ - size_t operand1Len; /* String length of the operand */ + int operand1Len; /* String length of the operand */ int opnd; /* Integer representation of an operand */ int litIndex; /* Literal pool index of a constant */ int localVar; /* LVT index of a local variable */ int flags; /* Flags for a basic block */ JumptableInfo* jtPtr; /* Pointer to a jumptable */ @@ -1312,12 +1303,12 @@ goto cleanup; } if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { goto cleanup; } - operand1 = TclGetStringFromObj(operand1Obj, &operand1Len); - litIndex = TclRegisterLiteral(envPtr, operand1, operand1Len, 0); + operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len); + litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len); BBEmitInst1or4(assemEnvPtr, tblIdx, litIndex, 0); break; case ASSEM_1BYTE: if (parsePtr->numWords != 1) { @@ -1405,11 +1396,10 @@ } BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, opnd); break; case ASSEM_DICT_GET: - case ASSEM_DICT_GET_DEF: if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); goto cleanup; } if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK @@ -1479,12 +1469,12 @@ TalInstructionTable+tblIdx); } else if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { goto cleanup; } else { - operand1 = TclGetStringFromObj(operand1Obj, &operand1Len); - litIndex = TclRegisterLiteral(envPtr, operand1, operand1Len, 0); + operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len); + litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len); /* * Assumes that PUSH is the first slot! */ @@ -1542,11 +1532,11 @@ } if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { goto cleanup; } - jtPtr = Tcl_Alloc(sizeof(JumptableInfo)); + jtPtr = ckalloc(sizeof(JumptableInfo)); Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS); assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine; assemEnvPtr->curr_bb->jumpOffset = envPtr->codeNext-envPtr->codeStart; DEBUG_PRINT("bb %p jumpLine %d jumpOffset %d\n", @@ -1574,11 +1564,11 @@ /* * Add the (label_name, address) pair to the hash table. */ - if (DefineLabel(assemEnvPtr, TclGetString(operand1Obj)) != TCL_OK) { + if (DefineLabel(assemEnvPtr, Tcl_GetString(operand1Obj)) != TCL_OK) { goto cleanup; } break; case ASSEM_LINDEX_MULTI: @@ -1705,13 +1695,11 @@ } if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { goto cleanup; } { - int flags = TCL_REG_ADVANCED | (opnd ? TCL_REG_NOCASE : 0); - - BBEmitInstInt1(assemEnvPtr, tblIdx, flags, 0); + BBEmitInstInt1(assemEnvPtr, tblIdx, TCL_REG_ADVANCED | (opnd ? TCL_REG_NOCASE : 0), 0); } break; case ASSEM_REVERSE: if (parsePtr->numWords != 2) { @@ -1753,11 +1741,11 @@ TclEmitInt4(localVar, envPtr); break; default: Tcl_Panic("Instruction \"%s\" could not be found, can't happen\n", - TclGetString(instNameObj)); + Tcl_GetString(instNameObj)); } status = TCL_OK; cleanup: Tcl_DecrRefCount(instNameObj); @@ -1816,11 +1804,10 @@ * code. */ int savedStackDepth = envPtr->currStackDepth; int savedMaxStackDepth = envPtr->maxStackDepth; - int savedCodeIndex = envPtr->codeNext - envPtr->codeStart; int savedExceptArrayNext = envPtr->exceptArrayNext; envPtr->currStackDepth = 0; envPtr->maxStackDepth = 0; @@ -1849,12 +1836,11 @@ /* * Save any exception ranges that were pushed by the compiler; they will * need to be fixed up once the stack depth is known. */ - MoveExceptionRangesToBasicBlock(assemEnvPtr, savedCodeIndex, - savedExceptArrayNext); + MoveExceptionRangesToBasicBlock(assemEnvPtr, savedExceptArrayNext); /* * Flush the current basic block. */ @@ -1909,11 +1895,10 @@ */ static void MoveExceptionRangesToBasicBlock( AssemblyEnv* assemEnvPtr, /* Assembly environment */ - int savedCodeIndex, /* Start of the embedded code */ int savedExceptArrayNext) /* Saved index of the end of the exception * range array */ { CompileEnv* envPtr = assemEnvPtr->envPtr; /* Compilation environment */ @@ -1941,11 +1926,11 @@ DEBUG_PRINT("basic block %p has %d exceptions starting at %d\n", curr_bb, exceptionCount, savedExceptArrayNext); curr_bb->foreignExceptionBase = savedExceptArrayNext; curr_bb->foreignExceptionCount = exceptionCount; curr_bb->foreignExceptions = - Tcl_Alloc(exceptionCount * sizeof(ExceptionRange)); + ckalloc(exceptionCount * sizeof(ExceptionRange)); memcpy(curr_bb->foreignExceptions, envPtr->exceptArrayPtr + savedExceptArrayNext, exceptionCount * sizeof(ExceptionRange)); for (i = 0; i < exceptionCount; ++i) { curr_bb->foreignExceptions[i].nestingLevel -= envPtr->exceptDepth; @@ -2006,29 +1991,29 @@ /* * Allocate the jumptable. */ - jtPtr = Tcl_Alloc(sizeof(JumptableInfo)); + jtPtr = ckalloc(sizeof(JumptableInfo)); jtHashPtr = &jtPtr->hashTable; Tcl_InitHashTable(jtHashPtr, TCL_STRING_KEYS); /* * Fill the keys and labels into the table. */ DEBUG_PRINT("jump table {\n"); for (i = 0; i < objc; i+=2) { - DEBUG_PRINT(" %s -> %s\n", TclGetString(objv[i]), - TclGetString(objv[i+1])); - hashEntry = Tcl_CreateHashEntry(jtHashPtr, TclGetString(objv[i]), + DEBUG_PRINT(" %s -> %s\n", Tcl_GetString(objv[i]), + Tcl_GetString(objv[i+1])); + hashEntry = Tcl_CreateHashEntry(jtHashPtr, Tcl_GetString(objv[i]), &isNew); if (!isNew) { if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "duplicate entry in jump table for \"%s\"", - TclGetString(objv[i]))); + Tcl_GetString(objv[i]))); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPJUMPTABLEENTRY"); DeleteMirrorJumpTable(jtPtr); return TCL_ERROR; } } @@ -2071,11 +2056,11 @@ label = Tcl_GetHashValue(entry); Tcl_DecrRefCount(label); Tcl_SetHashValue(entry, NULL); } Tcl_DeleteHashTable(jtHashPtr); - Tcl_Free(jtPtr); + ckfree(jtPtr); } /* *----------------------------------------------------------------------------- * @@ -2102,12 +2087,13 @@ * the operand */ Tcl_Obj** operandObjPtr) /* OUTPUT: Tcl object holding the operand text * with \-substitutions done. */ { Tcl_Interp* interp = (Tcl_Interp*) assemEnvPtr->envPtr->iPtr; - Tcl_Obj* operandObj = Tcl_NewObj(); + Tcl_Obj* operandObj; + TclNewObj(operandObj); if (!TclWordKnownAtCompileTime(*tokenPtrPtr, operandObj)) { Tcl_DecrRefCount(operandObj); if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "assembly code may not contain substitutions", -1)); @@ -2237,11 +2223,11 @@ * Results: * Returns a standard Tcl result: TCL_OK if the parse is successful and * TCL_ERROR (with an appropriate error message) if the parse fails. * * Side effects: - * Stores the list index at '*index'. Values between -1 and 0x7fffffff + * Stores the list index at '*index'. Values between -1 and 0x7FFFFFFF * have their natural meaning; values between -2 and -0x80000000 * represent 'end-2-N'. * *----------------------------------------------------------------------------- */ @@ -2272,11 +2258,11 @@ * NOTE: Indexing a list with an index before it yields the * same result as indexing after it, and might be more easily portable * when list size limits grow. */ status = TclIndexEncode(interp, value, - TCL_INDEX_NONE,TCL_INDEX_NONE, result); + TCL_INDEX_BEFORE,TCL_INDEX_BEFORE, result); Tcl_DecrRefCount(value); *tokenPtrPtr = TokenAfter(tokenPtr); return status; } @@ -2314,17 +2300,17 @@ Tcl_Token* tokenPtr = *tokenPtrPtr; /* INOUT: Pointer to the next token in the * source code. */ Tcl_Obj* varNameObj; /* Name of the variable */ const char* varNameStr; - size_t varNameLen; + int varNameLen; int localVar; /* Index of the variable in the LVT */ if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &varNameObj) != TCL_OK) { return -1; } - varNameStr = TclGetStringFromObj(varNameObj, &varNameLen); + varNameStr = Tcl_GetStringFromObj(varNameObj, &varNameLen); if (CheckNamespaceQualifiers(interp, varNameStr, varNameLen)) { Tcl_DecrRefCount(varNameObj); return -1; } localVar = TclFindCompiledLocal(varNameStr, varNameLen, 1, envPtr); @@ -2400,11 +2386,11 @@ Tcl_Interp* interp, /* Tcl interpreter for error reporting */ int value) /* Value to check */ { Tcl_Obj* result; /* Error message */ - if (value < 0 || value > 0xff) { + if (value < 0 || value > 0xFF) { result = Tcl_NewStringObj("operand does not fit in one byte", -1); Tcl_SetObjResult(interp, result); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", NULL); return TCL_ERROR; } @@ -2435,11 +2421,11 @@ Tcl_Interp* interp, /* Tcl interpreter for error reporting */ int value) /* Value to check */ { Tcl_Obj* result; /* Error message */ - if (value > 0x7f || value < -0x80) { + if (value > 0x7F || value < -0x80) { result = Tcl_NewStringObj("operand does not fit in one byte", -1); Tcl_SetObjResult(interp, result); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", NULL); return TCL_ERROR; } @@ -2654,11 +2640,11 @@ static BasicBlock * AllocBB( AssemblyEnv* assemEnvPtr) /* Assembly environment */ { CompileEnv* envPtr = assemEnvPtr->envPtr; - BasicBlock *bb = Tcl_Alloc(sizeof(BasicBlock)); + BasicBlock *bb = ckalloc(sizeof(BasicBlock)); bb->originalStartOffset = bb->startOffset = envPtr->codeNext - envPtr->codeStart; bb->startLine = assemEnvPtr->cmdLine + 1; bb->jumpOffset = -1; @@ -2833,11 +2819,11 @@ * label is missing. */ if (bbPtr->jumpTarget != NULL) { entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - TclGetString(bbPtr->jumpTarget)); + Tcl_GetString(bbPtr->jumpTarget)); if (entry == NULL) { ReportUndefinedLabel(assemEnvPtr, bbPtr, bbPtr->jumpTarget); return TCL_ERROR; } @@ -2849,11 +2835,11 @@ jumpTarget = Tcl_GetHashValue(entry); if (bbPtr->flags & BB_JUMP1) { offset = jumpTarget->startOffset - (bbPtr->jumpOffset + motion); - if (offset < -0x80 || offset > 0x7f) { + if (offset < -0x80 || offset > 0x7F) { opcode = TclGetUInt1AtPtr(envPtr->codeStart + bbPtr->jumpOffset); ++opcode; TclStoreInt1AtPtr(opcode, envPtr->codeStart + bbPtr->jumpOffset); @@ -2914,14 +2900,14 @@ for (symEntryPtr = Tcl_FirstHashEntry(symHash, &search); symEntryPtr != NULL; symEntryPtr = Tcl_NextHashEntry(&search)) { symbolObj = Tcl_GetHashValue(symEntryPtr); valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - TclGetString(symbolObj)); + Tcl_GetString(symbolObj)); DEBUG_PRINT(" %s -> %s (%d)\n", (char*) Tcl_GetHashKey(symHash, symEntryPtr), - TclGetString(symbolObj), (valEntryPtr != NULL)); + Tcl_GetString(symbolObj), (valEntryPtr != NULL)); if (valEntryPtr == NULL) { ReportUndefinedLabel(assemEnvPtr, bbPtr, symbolObj); return TCL_ERROR; } } @@ -2955,13 +2941,13 @@ Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; /* Tcl interpreter */ if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "undefined label \"%s\"", TclGetString(jumpTarget))); + "undefined label \"%s\"", Tcl_GetString(jumpTarget))); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOLABEL", - TclGetString(jumpTarget), NULL); + Tcl_GetString(jumpTarget), NULL); Tcl_SetErrorLine(interp, bbPtr->jumpLine); } } /* @@ -3040,11 +3026,11 @@ for (bbPtr = assemEnvPtr->head_bb; bbPtr != NULL; bbPtr = bbPtr->successor1) { if (bbPtr->jumpTarget != NULL) { entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - TclGetString(bbPtr->jumpTarget)); + Tcl_GetString(bbPtr->jumpTarget)); jumpTarget = Tcl_GetHashValue(entry); fromOffset = bbPtr->jumpOffset; targetOffset = jumpTarget->startOffset; if (bbPtr->flags & BB_JUMP1) { TclStoreInt1AtPtr(targetOffset - fromOffset, @@ -3112,21 +3098,21 @@ DEBUG_PRINT("resolve jump table {\n"); for (symEntryPtr = Tcl_FirstHashEntry(symHash, &search); symEntryPtr != NULL; symEntryPtr = Tcl_NextHashEntry(&search)) { symbolObj = Tcl_GetHashValue(symEntryPtr); - DEBUG_PRINT(" symbol %s\n", TclGetString(symbolObj)); + DEBUG_PRINT(" symbol %s\n", Tcl_GetString(symbolObj)); valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - TclGetString(symbolObj)); + Tcl_GetString(symbolObj)); jumpTargetBBPtr = Tcl_GetHashValue(valEntryPtr); realJumpEntryPtr = Tcl_CreateHashEntry(realJumpHashPtr, Tcl_GetHashKey(symHash, symEntryPtr), &junk); DEBUG_PRINT(" %s -> %s -> bb %p (pc %d) hash entry %p\n", (char*) Tcl_GetHashKey(symHash, symEntryPtr), - TclGetString(symbolObj), jumpTargetBBPtr, + Tcl_GetString(symbolObj), jumpTargetBBPtr, jumpTargetBBPtr->startOffset, realJumpEntryPtr); Tcl_SetHashValue(realJumpEntryPtr, INT2PTR(jumpTargetBBPtr->startOffset - bbPtr->jumpOffset)); } @@ -3494,11 +3480,11 @@ blockPtr, stackDepth); } if (result == TCL_OK && blockPtr->jumpTarget != NULL) { entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - TclGetString(blockPtr->jumpTarget)); + Tcl_GetString(blockPtr->jumpTarget)); jumpTarget = Tcl_GetHashValue(entry); result = StackCheckBasicBlock(assemEnvPtr, jumpTarget, blockPtr, stackDepth); } @@ -3511,11 +3497,11 @@ &jtSearch); result == TCL_OK && jtEntry != NULL; jtEntry = Tcl_NextHashEntry(&jtSearch)) { targetLabel = Tcl_GetHashValue(jtEntry); entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - TclGetString(targetLabel)); + Tcl_GetString(targetLabel)); jumpTarget = Tcl_GetHashValue(entry); result = StackCheckBasicBlock(assemEnvPtr, jumpTarget, blockPtr, stackDepth); } } @@ -3573,11 +3559,11 @@ if (depth == 0) { /* * Emit a 'push' of the empty literal. */ - litIndex = TclRegisterLiteral(envPtr, "", 0, 0); + litIndex = TclRegisterNewLiteral(envPtr, "", 0); /* * Assumes that 'push' is at slot 0 in TalInstructionTable. */ @@ -3816,11 +3802,11 @@ result = ProcessCatchesInBasicBlock(assemEnvPtr, bbPtr->successor1, fallThruEnclosing, fallThruState, catchDepth); } if (result == TCL_OK && bbPtr->jumpTarget != NULL) { entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - TclGetString(bbPtr->jumpTarget)); + Tcl_GetString(bbPtr->jumpTarget)); jumpTarget = Tcl_GetHashValue(entry); result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget, jumpEnclosing, jumpState, catchDepth); } @@ -3832,11 +3818,11 @@ for (jtEntry = Tcl_FirstHashEntry(&bbPtr->jtPtr->hashTable,&jtSearch); result == TCL_OK && jtEntry != NULL; jtEntry = Tcl_NextHashEntry(&jtSearch)) { targetLabel = Tcl_GetHashValue(jtEntry); entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - TclGetString(targetLabel)); + Tcl_GetString(targetLabel)); jumpTarget = Tcl_GetHashValue(entry); result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget, jumpEnclosing, jumpState, catchDepth); } } @@ -3932,12 +3918,12 @@ /* * Allocate memory for a stack of active catches. */ - catches = Tcl_Alloc(maxCatchDepth * sizeof(BasicBlock*)); - catchIndices = Tcl_Alloc(maxCatchDepth * sizeof(int)); + catches = ckalloc(maxCatchDepth * sizeof(BasicBlock*)); + catchIndices = ckalloc(maxCatchDepth * sizeof(int)); for (i = 0; i < maxCatchDepth; ++i) { catches[i] = NULL; catchIndices[i] = -1; } @@ -3972,12 +3958,12 @@ "tclAssembly.c:BuildExceptionRanges, can't happen"); } /* Free temp storage */ - Tcl_Free(catchIndices); - Tcl_Free(catches); + ckfree(catchIndices); + ckfree(catches); return TCL_OK; } /* @@ -4136,11 +4122,11 @@ envPtr->maxExceptDepth = TclMax(range->nestingLevel + 1, envPtr->maxExceptDepth); range->codeOffset = bbPtr->startOffset; entryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - TclGetString(catch->jumpTarget)); + Tcl_GetString(catch->jumpTarget)); if (entryPtr == NULL) { Tcl_Panic("undefined label in tclAssembly.c:" "BuildExceptionRanges, can't happen"); } @@ -4273,16 +4259,16 @@ Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; /* Tcl interpreter */ Tcl_Obj* lineNo; /* Line number in the source */ Tcl_AddErrorInfo(interp, "\n in assembly code between lines "); - lineNo = Tcl_NewWideIntObj(bbPtr->startLine); + TclNewIntObj(lineNo, bbPtr->startLine); Tcl_IncrRefCount(lineNo); Tcl_AppendObjToErrorInfo(interp, lineNo); Tcl_AddErrorInfo(interp, " and "); if (bbPtr->successor1 != NULL) { - TclSetIntObj(lineNo, bbPtr->successor1->startLine); + Tcl_SetIntObj(lineNo, bbPtr->successor1->startLine); Tcl_AppendObjToErrorInfo(interp, lineNo); } else { Tcl_AddErrorInfo(interp, "end of assembly code"); } Tcl_DecrRefCount(lineNo); @@ -4318,10 +4304,12 @@ static void DupAssembleCodeInternalRep( Tcl_Obj *srcPtr, Tcl_Obj *copyPtr) { + (void)srcPtr; + (void)copyPtr; return; } /* *----------------------------------------------------------------------------- @@ -4343,20 +4331,21 @@ static void FreeAssembleCodeInternalRep( Tcl_Obj *objPtr) { - ByteCode *codePtr; + ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; - ByteCodeGetIntRep(objPtr, &assembleCodeType, codePtr); - assert(codePtr != NULL); - - TclReleaseByteCode(codePtr); + codePtr->refCount--; + if (codePtr->refCount <= 0) { + TclCleanupByteCode(codePtr); + } + objPtr->typePtr = NULL; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: generic/tclAsync.c ================================================================== --- generic/tclAsync.c +++ generic/tclAsync.c @@ -116,11 +116,11 @@ ClientData clientData) /* Argument to pass to handler. */ { AsyncHandler *asyncPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - asyncPtr = Tcl_Alloc(sizeof(AsyncHandler)); + asyncPtr = ckalloc(sizeof(AsyncHandler)); asyncPtr->ready = 0; asyncPtr->nextPtr = NULL; asyncPtr->proc = proc; asyncPtr->clientData = clientData; asyncPtr->originTsd = tsdPtr; @@ -308,11 +308,11 @@ if (asyncPtr == tsdPtr->lastHandler) { tsdPtr->lastHandler = prevPtr; } } Tcl_MutexUnlock(&tsdPtr->asyncMutex); - Tcl_Free(asyncPtr); + ckfree(asyncPtr); } /* *---------------------------------------------------------------------- * Index: generic/tclBasic.c ================================================================== --- generic/tclBasic.c +++ generic/tclBasic.c @@ -21,37 +21,10 @@ #include "tclOOInt.h" #include "tclCompile.h" #include "tommath.h" #include #include - -/* - * TCL_FPCLASSIFY_MODE: - * 0 - fpclassify - * 1 - _fpclass - * 2 - simulate - * 3 - __builtin_fpclassify - */ - -#ifndef TCL_FPCLASSIFY_MODE -/* - * MINGW x86 (tested up to gcc 8.1) seems to have a bug in fpclassify, - * [fpclassify 1e-314], x86 => normal, x64 => subnormal, so switch to _fpclass - */ -# if ( defined(__MINGW32__) && defined(_X86_) ) /* mingw 32-bit */ -# define TCL_FPCLASSIFY_MODE 1 -# elif defined(fpclassify) /* fpclassify */ -# include -# define TCL_FPCLASSIFY_MODE 0 -# elif defined(_FPCLASS_NN) /* _fpclass */ -# define TCL_FPCLASSIFY_MODE 1 -# else /* !fpclassify && !_fpclass (older MSVC), simulate */ -# define TCL_FPCLASSIFY_MODE 2 -# endif /* !fpclassify */ -/* actually there is no fallback to builtin fpclassify */ -#endif /* !TCL_FPCLASSIFY_MODE */ - #define INTERP_STACK_INITIAL_SIZE 2000 #define CORO_STACK_INITIAL_SIZE 200 /* @@ -62,10 +35,22 @@ # define IEEE_FLOATING_POINT /* Largest odd integer that can be represented exactly in a double */ # define MAX_EXACT 9007199254740991.0 #endif +/* + * The following structure defines the client data for a math function + * registered with Tcl_CreateMathFunc + */ + +typedef struct OldMathFuncData { + Tcl_MathProc *proc; /* Handler function */ + int numArgs; /* Number of args expected */ + Tcl_ValueType *argTypes; /* Types of the args */ + ClientData clientData; /* Client data for the handler function */ +} OldMathFuncData; + /* * This is the script cancellation struct and hash table. The hash table is * used to keep track of the information necessary to process script * cancellation requests, including the original interp, asynchronous handler * tokens (created by Tcl_AsyncCreate), and the clientData and flags arguments @@ -78,28 +63,17 @@ Tcl_Interp *interp; /* Interp this struct belongs to. */ Tcl_AsyncHandler async; /* Async handler token for script * cancellation. */ char *result; /* The script cancellation result or NULL for * a default result. */ - size_t length; /* Length of the above error message. */ + int length; /* Length of the above error message. */ ClientData clientData; /* Ignored */ int flags; /* Additional flags */ } CancelInfo; static Tcl_HashTable cancelTable; static int cancelTableInitialized = 0; /* 0 means not yet initialized. */ -TCL_DECLARE_MUTEX(cancelLock); - -/* - * Table used to map command implementation functions to a human-readable type - * name, for [info type]. The keys in the table are function addresses, and - * the values in the table are static char* containing strings in Tcl's - * internal encoding (almost UTF-8). - */ - -static Tcl_HashTable commandTypeTable; -static int commandTypeInit = 0; -TCL_DECLARE_MUTEX(commandTypeLock); +TCL_DECLARE_MUTEX(cancelLock) /* * Declarations for managing contexts for non-recursive coroutines. Contexts * are used to save the evaluation state between NR calls to each coro. */ @@ -118,11 +92,10 @@ /* * Static functions in this file: */ -static Tcl_ObjCmdProc BadEnsembleSubcommand; static char * CallCommandTraces(Interp *iPtr, Command *cmdPtr, const char *oldName, const char *newName, int flags); static int CancelEvalProc(ClientData clientData, Tcl_Interp *interp, int code); @@ -139,34 +112,28 @@ static Tcl_ObjCmdProc ExprAbsFunc; static Tcl_ObjCmdProc ExprBinaryFunc; static Tcl_ObjCmdProc ExprBoolFunc; static Tcl_ObjCmdProc ExprCeilFunc; static Tcl_ObjCmdProc ExprDoubleFunc; +static Tcl_ObjCmdProc ExprEntierFunc; static Tcl_ObjCmdProc ExprFloorFunc; static Tcl_ObjCmdProc ExprIntFunc; static Tcl_ObjCmdProc ExprIsqrtFunc; -static Tcl_ObjCmdProc ExprIsFiniteFunc; -static Tcl_ObjCmdProc ExprIsInfinityFunc; -static Tcl_ObjCmdProc ExprIsNaNFunc; -static Tcl_ObjCmdProc ExprIsNormalFunc; -static Tcl_ObjCmdProc ExprIsSubnormalFunc; -static Tcl_ObjCmdProc ExprIsUnorderedFunc; -static Tcl_ObjCmdProc ExprMaxFunc; -static Tcl_ObjCmdProc ExprMinFunc; static Tcl_ObjCmdProc ExprRandFunc; static Tcl_ObjCmdProc ExprRoundFunc; 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, int expected, int actual, Tcl_Obj *const *objv); static Tcl_NRPostProc NRCoroutineCallerCallback; static Tcl_NRPostProc NRCoroutineExitCallback; static Tcl_NRPostProc NRCommand; +static Tcl_ObjCmdProc OldMathFuncProc; +static void OldMathFuncDeleteProc(ClientData clientData); static void ProcessUnexpectedResult(Tcl_Interp *interp, int returnCode); static int RewindCoroutine(CoroutineData *corPtr, int result); static void TEOV_SwitchVarFrame(Tcl_Interp *interp); static void TEOV_PushExceptionHandlers(Tcl_Interp *interp, @@ -187,17 +154,13 @@ static Tcl_NRPostProc TEOV_RestoreVarFrame; static Tcl_NRPostProc TEOV_RunLeaveTraces; static Tcl_NRPostProc EvalObjvCore; static Tcl_NRPostProc Dispatch; -static Tcl_ObjCmdProc NRInjectObjCmd; +static Tcl_ObjCmdProc NRCoroInjectObjCmd; static Tcl_NRPostProc NRPostInvoke; static Tcl_ObjCmdProc CoroTypeObjCmd; -static Tcl_ObjCmdProc TclNRCoroInjectObjCmd; -static Tcl_ObjCmdProc TclNRCoroProbeObjCmd; -static Tcl_NRPostProc InjectHandler; -static Tcl_NRPostProc InjectHandlerPostCall; MODULE_SCOPE const TclStubs tclStubs; /* * Magical counts for the number of arguments accepted by a coroutine command @@ -227,28 +190,10 @@ * interpreter. */ /* CMD_COMPILES_EXPANDED - Whether the compiler for this command can handle * expansion for itself rather than needing the generic layer to take care of * it for it. Defined in tclInt.h. */ -/* - * The following struct states that the command it talks about (a subcommand - * of one of Tcl's built-in ensembles) is unsafe and must be hidden when an - * interpreter is made safe. (TclHideUnsafeCommands accesses an array of these - * structs.) Alas, we can't sensibly just store the information directly in - * the commands. - */ - -typedef struct { - const char *ensembleNsName; /* The ensemble's name within ::tcl. NULL for - * the end of the list of commands to hide. */ - const char *commandName; /* The name of the command within the - * ensemble. If this is NULL, we want to also - * make the overall command be hidden, an ugly - * hack because it is expected by security - * policies in the wild. */ -} UnsafeEnsembleInfo; - /* * The built-in commands, and the functions that implement them: */ static const CmdInfo builtInCmds[] = { @@ -257,23 +202,23 @@ */ {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, CMD_IS_SAFE}, {"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, CMD_IS_SAFE}, {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, CMD_IS_SAFE}, +#ifndef EXCLUDE_OBSOLETE_COMMANDS + {"case", Tcl_CaseObjCmd, NULL, NULL, CMD_IS_SAFE}, +#endif {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, CMD_IS_SAFE}, {"concat", Tcl_ConcatObjCmd, TclCompileConcatCmd, NULL, CMD_IS_SAFE}, {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, CMD_IS_SAFE}, - {"coroinject", NULL, NULL, TclNRCoroInjectObjCmd, CMD_IS_SAFE}, - {"coroprobe", NULL, NULL, TclNRCoroProbeObjCmd, CMD_IS_SAFE}, {"coroutine", NULL, NULL, TclNRCoroutineObjCmd, CMD_IS_SAFE}, {"error", Tcl_ErrorObjCmd, TclCompileErrorCmd, NULL, CMD_IS_SAFE}, {"eval", Tcl_EvalObjCmd, NULL, TclNREvalObjCmd, CMD_IS_SAFE}, {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, TclNRExprObjCmd, CMD_IS_SAFE}, {"for", Tcl_ForObjCmd, TclCompileForCmd, TclNRForObjCmd, CMD_IS_SAFE}, {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, TclNRForeachCmd, CMD_IS_SAFE}, {"format", Tcl_FormatObjCmd, TclCompileFormatCmd, NULL, CMD_IS_SAFE}, - {"fpclassify", FloatClassifyObjCmd, NULL, NULL, CMD_IS_SAFE}, {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, NULL, CMD_IS_SAFE}, {"if", Tcl_IfObjCmd, TclCompileIfCmd, TclNRIfObjCmd, CMD_IS_SAFE}, {"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, NULL, CMD_IS_SAFE}, {"join", Tcl_JoinObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, NULL, CMD_IS_SAFE}, @@ -281,13 +226,11 @@ {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, CMD_IS_SAFE}, {"linsert", Tcl_LinsertObjCmd, TclCompileLinsertCmd, NULL, CMD_IS_SAFE}, {"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, CMD_IS_SAFE|CMD_COMPILES_EXPANDED}, {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, CMD_IS_SAFE}, {"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, CMD_IS_SAFE}, - {"lpop", Tcl_LpopObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, CMD_IS_SAFE}, - {"lremove", Tcl_LremoveObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, CMD_IS_SAFE}, {"lreverse", Tcl_LreverseObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lsearch", Tcl_LsearchObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, CMD_IS_SAFE}, @@ -341,80 +284,19 @@ {"seek", Tcl_SeekObjCmd, NULL, NULL, CMD_IS_SAFE}, {"socket", Tcl_SocketObjCmd, NULL, NULL, 0}, {"source", Tcl_SourceObjCmd, NULL, TclNRSourceObjCmd, 0}, {"tell", Tcl_TellObjCmd, NULL, NULL, CMD_IS_SAFE}, {"time", Tcl_TimeObjCmd, NULL, NULL, CMD_IS_SAFE}, +#ifdef TCL_TIMERATE {"timerate", Tcl_TimeRateObjCmd, NULL, NULL, CMD_IS_SAFE}, +#endif {"unload", Tcl_UnloadObjCmd, NULL, NULL, 0}, {"update", Tcl_UpdateObjCmd, NULL, NULL, CMD_IS_SAFE}, {"vwait", Tcl_VwaitObjCmd, NULL, NULL, CMD_IS_SAFE}, {NULL, NULL, NULL, NULL, 0} }; -/* - * Information about which pieces of ensembles to hide when making an - * interpreter safe: - */ - -static const UnsafeEnsembleInfo unsafeEnsembleCommands[] = { - /* [encoding] has two unsafe commands. Assumed by older security policies - * to be overall unsafe; it isn't but... */ - {"encoding", NULL}, - {"encoding", "dirs"}, - {"encoding", "system"}, - /* [file] has MANY unsafe commands! Assumed by older security policies to - * be overall unsafe; it isn't but... */ - {"file", NULL}, - {"file", "atime"}, - {"file", "attributes"}, - {"file", "copy"}, - {"file", "delete"}, - {"file", "dirname"}, - {"file", "executable"}, - {"file", "exists"}, - {"file", "extension"}, - {"file", "isdirectory"}, - {"file", "isfile"}, - {"file", "link"}, - {"file", "lstat"}, - {"file", "mtime"}, - {"file", "mkdir"}, - {"file", "nativename"}, - {"file", "normalize"}, - {"file", "owned"}, - {"file", "readable"}, - {"file", "readlink"}, - {"file", "rename"}, - {"file", "rootname"}, - {"file", "size"}, - {"file", "stat"}, - {"file", "tail"}, - {"file", "tempdir"}, - {"file", "tempfile"}, - {"file", "type"}, - {"file", "volumes"}, - {"file", "writable"}, - /* [info] has two unsafe commands */ - {"info", "cmdtype"}, - {"info", "nameofexecutable"}, - /* [tcl::process] has ONLY unsafe commands! */ - {"process", "list"}, - {"process", "status"}, - {"process", "purge"}, - {"process", "autopurge"}, - /* [zipfs] has MANY unsafe commands! */ - {"zipfs", "lmkimg"}, - {"zipfs", "lmkzip"}, - {"zipfs", "mkimg"}, - {"zipfs", "mkkey"}, - {"zipfs", "mkzip"}, - {"zipfs", "mount"}, - {"zipfs", "mount_data"}, - {"zipfs", "unmount"}, - {NULL, NULL} -}; - /* * Math functions. All are safe. */ typedef struct { @@ -432,27 +314,19 @@ { "bool", ExprBoolFunc, NULL }, { "ceil", ExprCeilFunc, NULL }, { "cos", ExprUnaryFunc, (ClientData) cos }, { "cosh", ExprUnaryFunc, (ClientData) cosh }, { "double", ExprDoubleFunc, NULL }, - { "entier", ExprIntFunc, NULL }, + { "entier", ExprEntierFunc, NULL }, { "exp", ExprUnaryFunc, (ClientData) exp }, { "floor", ExprFloorFunc, NULL }, { "fmod", ExprBinaryFunc, (ClientData) fmod }, { "hypot", ExprBinaryFunc, (ClientData) hypot }, { "int", ExprIntFunc, NULL }, - { "isfinite", ExprIsFiniteFunc, NULL }, - { "isinf", ExprIsInfinityFunc, NULL }, - { "isnan", ExprIsNaNFunc, NULL }, - { "isnormal", ExprIsNormalFunc, NULL }, { "isqrt", ExprIsqrtFunc, NULL }, - { "issubnormal", ExprIsSubnormalFunc, NULL, }, - { "isunordered", ExprIsUnorderedFunc, NULL, }, { "log", ExprUnaryFunc, (ClientData) log }, { "log10", ExprUnaryFunc, (ClientData) log10 }, - { "max", ExprMaxFunc, NULL }, - { "min", ExprMinFunc, NULL }, { "pow", ExprBinaryFunc, (ClientData) pow }, { "rand", ExprRandFunc, NULL }, { "round", ExprRoundFunc, NULL }, { "sin", ExprUnaryFunc, (ClientData) sin }, { "sinh", ExprUnaryFunc, (ClientData) sinh }, @@ -524,18 +398,10 @@ /* unused */ {0}, NULL}, { "==", TclSortingOpCmd, TclCompileEqOpCmd, /* unused */ {0}, NULL}, { "eq", TclSortingOpCmd, TclCompileStreqOpCmd, /* unused */ {0}, NULL}, - { "lt", TclSortingOpCmd, TclCompileStrLtOpCmd, - /* unused */ {0}, NULL}, - { "le", TclSortingOpCmd, TclCompileStrLeOpCmd, - /* unused */ {0}, NULL}, - { "gt", TclSortingOpCmd, TclCompileStrGtOpCmd, - /* unused */ {0}, NULL}, - { "ge", TclSortingOpCmd, TclCompileStrGeOpCmd, - /* unused */ {0}, NULL}, { NULL, NULL, NULL, {0}, NULL} }; /* @@ -561,17 +427,10 @@ if (cancelTableInitialized == 1) { Tcl_DeleteHashTable(&cancelTable); cancelTableInitialized = 0; } Tcl_MutexUnlock(&cancelLock); - - Tcl_MutexLock(&commandTypeLock); - if (commandTypeInit) { - Tcl_DeleteHashTable(&commandTypeTable); - commandTypeInit = 0; - } - Tcl_MutexUnlock(&commandTypeLock); } /* *---------------------------------------------------------------------- * @@ -623,17 +482,19 @@ if (sizeof(Tcl_CallFrame) < sizeof(CallFrame)) { /*NOTREACHED*/ Tcl_Panic("Tcl_CallFrame must not be smaller than CallFrame"); } -#if defined(_WIN32) && !defined(_WIN64) - if (sizeof(time_t) != 4) { - /*NOTREACHED*/ - Tcl_Panic(" is not compatible with MSVC"); - } - if ((offsetof(Tcl_StatBuf,st_atime) != 32) - || (offsetof(Tcl_StatBuf,st_ctime) != 40)) { +#if defined(_WIN32) && !defined(_WIN64) && !defined(_USE_64BIT_TIME_T) + /* If Tcl is compiled on Win32 using -D_USE_64BIT_TIME_T + * the result is a binary incompatible with the 'standard' build of + * Tcl: All extensions using Tcl_StatBuf need to be recompiled in + * the same way. Therefore, this is not officially supported. + * In stead, it is recommended to use Win64 or Tcl 9.0 (not released yet) + */ + if ((TclOffset(Tcl_StatBuf,st_atime) != 32) + || (TclOffset(Tcl_StatBuf,st_ctime) != 40)) { /*NOTREACHED*/ Tcl_Panic(" is not compatible with MSVC"); } #endif @@ -641,50 +502,34 @@ Tcl_MutexLock(&cancelLock); if (cancelTableInitialized == 0) { Tcl_InitHashTable(&cancelTable, TCL_ONE_WORD_KEYS); cancelTableInitialized = 1; } - Tcl_MutexUnlock(&cancelLock); } - if (commandTypeInit == 0) { - TclRegisterCommandTypeName(TclObjInterpProc, "proc"); - TclRegisterCommandTypeName(TclEnsembleImplementationCmd, "ensemble"); - TclRegisterCommandTypeName(TclAliasObjCmd, "alias"); - TclRegisterCommandTypeName(TclLocalAliasObjCmd, "alias"); - TclRegisterCommandTypeName(TclSlaveObjCmd, "slave"); - TclRegisterCommandTypeName(TclInvokeImportedCmd, "import"); - TclRegisterCommandTypeName(TclOOPublicObjectCmd, "object"); - TclRegisterCommandTypeName(TclOOPrivateObjectCmd, "privateObject"); - TclRegisterCommandTypeName(TclOOMyClassObjCmd, "privateClass"); - TclRegisterCommandTypeName(TclNRInterpCoroutine, "coroutine"); - } - /* * Initialize support for namespaces and create the global namespace * (whose name is ""; an alias is "::"). This also initializes the Tcl * object type table and other object management code. */ - iPtr = Tcl_Alloc(sizeof(Interp)); + iPtr = ckalloc(sizeof(Interp)); interp = (Tcl_Interp *) iPtr; - iPtr->legacyResult = NULL; - /* Special invalid value: Any attempt to free the legacy result - * will cause a crash. */ - iPtr->legacyFreeProc = (void (*) (void))-1; + iPtr->result = iPtr->resultSpace; + iPtr->freeProc = NULL; iPtr->errorLine = 0; - iPtr->stubTable = &tclStubs; iPtr->objResultPtr = Tcl_NewObj(); Tcl_IncrRefCount(iPtr->objResultPtr); iPtr->handle = TclHandleCreate(iPtr); iPtr->globalNsPtr = NULL; iPtr->hiddenCmdTablePtr = NULL; iPtr->interpInfo = NULL; - iPtr->optimizer = TclOptimizeBytecode; + TCL_CT_ASSERT(sizeof(iPtr->extra) <= sizeof(Tcl_HashTable)); + iPtr->extra.optimizer = TclOptimizeBytecode; iPtr->numLevels = 0; iPtr->maxNestingDepth = MAX_NESTING_DEPTH; iPtr->framePtr = NULL; /* Initialise as soon as :: is available */ iPtr->varFramePtr = NULL; /* Initialise as soon as :: is available */ @@ -693,14 +538,14 @@ * TIP #280 - Initialize the arrays used to extend the ByteCode and Proc * structures. */ iPtr->cmdFramePtr = NULL; - iPtr->linePBodyPtr = Tcl_Alloc(sizeof(Tcl_HashTable)); - iPtr->lineBCPtr = Tcl_Alloc(sizeof(Tcl_HashTable)); - iPtr->lineLAPtr = Tcl_Alloc(sizeof(Tcl_HashTable)); - iPtr->lineLABCPtr = Tcl_Alloc(sizeof(Tcl_HashTable)); + iPtr->linePBodyPtr = ckalloc(sizeof(Tcl_HashTable)); + iPtr->lineBCPtr = ckalloc(sizeof(Tcl_HashTable)); + iPtr->lineLAPtr = ckalloc(sizeof(Tcl_HashTable)); + iPtr->lineLABCPtr = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(iPtr->linePBodyPtr, TCL_ONE_WORD_KEYS); Tcl_InitHashTable(iPtr->lineBCPtr, TCL_ONE_WORD_KEYS); Tcl_InitHashTable(iPtr->lineLAPtr, TCL_ONE_WORD_KEYS); Tcl_InitHashTable(iPtr->lineLABCPtr, TCL_ONE_WORD_KEYS); iPtr->scriptCLLocPtr = NULL; @@ -728,25 +573,28 @@ iPtr->returnLevel = 1; iPtr->returnCode = TCL_OK; iPtr->rootFramePtr = NULL; /* Initialise as soon as :: is available */ iPtr->lookupNsPtr = NULL; + + iPtr->appendResult = NULL; + iPtr->appendAvl = 0; + iPtr->appendUsed = 0; Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS); iPtr->packageUnknown = NULL; /* TIP #268 */ -#if (TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE) if (getenv("TCL_PKG_PREFER_LATEST") == NULL) { iPtr->packagePrefer = PKG_PREFER_STABLE; - } else -#endif + } else { iPtr->packagePrefer = PKG_PREFER_LATEST; + } iPtr->cmdCount = 0; TclInitLiteralTable(&iPtr->literalTable); - iPtr->compileEpoch = 1; + iPtr->compileEpoch = 0; iPtr->compiledProcPtr = NULL; iPtr->resolverPtr = NULL; iPtr->evalFlags = 0; iPtr->scriptFile = NULL; iPtr->flags = 0; @@ -757,10 +605,11 @@ iPtr->assocData = NULL; iPtr->execEnvPtr = NULL; /* Set after namespaces initialized. */ iPtr->emptyObjPtr = Tcl_NewObj(); /* Another empty object. */ Tcl_IncrRefCount(iPtr->emptyObjPtr); + iPtr->resultSpace[0] = 0; iPtr->threadId = Tcl_GetCurrentThread(); /* TIP #378 */ #ifdef TCL_INTERP_DEBUG_FRAME iPtr->flags |= INTERP_DEBUG_FRAME; @@ -790,11 +639,11 @@ * Initialise the rootCallframe. It cannot be allocated on the stack, as * it has to be in place before TclCreateExecEnv tries to use a variable. */ /* This is needed to satisfy GCC 3.3's strict aliasing rules */ - framePtr = Tcl_Alloc(sizeof(CallFrame)); + framePtr = ckalloc(sizeof(CallFrame)); (void) Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr, (Tcl_Namespace *) iPtr->globalNsPtr, /*isProcCallFrame*/ 0); framePtr->objc = 0; iPtr->framePtr = framePtr; @@ -820,11 +669,11 @@ * TIP #285, Script cancellation support. */ iPtr->asyncCancelMsg = Tcl_NewObj(); - cancelInfo = Tcl_Alloc(sizeof(CancelInfo)); + cancelInfo = ckalloc(sizeof(CancelInfo)); cancelInfo->interp = interp; iPtr->asyncCancel = Tcl_AsyncCreate(CancelEvalProc, cancelInfo); cancelInfo->async = iPtr->asyncCancel; cancelInfo->result = NULL; @@ -866,10 +715,16 @@ statsPtr->totalLitStringBytes = 0.0; statsPtr->currentLitStringBytes = 0.0; memset(statsPtr->literalCount, 0, sizeof(statsPtr->literalCount)); #endif /* TCL_COMPILE_STATS */ + /* + * Initialise the stub table pointer. + */ + + iPtr->stubTable = &tclStubs; + /* * Initialize the ensemble error message rewriting support. */ TclResetRewriteEnsemble(interp, 1); @@ -883,11 +738,11 @@ /* * Initialise the thread-specific data ekeko. Note that the thread's alloc * cache was already initialised by the call to alloc the interp struct. */ -#if TCL_THREADS && defined(USE_THREAD_ALLOC) +#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) iPtr->allocCache = TclpGetAllocCache(); #else iPtr->allocCache = NULL; #endif iPtr->pendingObjDataPtr = NULL; @@ -913,11 +768,11 @@ } hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable, cmdInfoPtr->name, &isNew); if (isNew) { - cmdPtr = Tcl_Alloc(sizeof(Command)); + cmdPtr = ckalloc(sizeof(Command)); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = iPtr->globalNsPtr; cmdPtr->refCount = 1; cmdPtr->cmdEpoch = 0; cmdPtr->compileProc = cmdInfoPtr->compileProc; @@ -953,11 +808,10 @@ TclInitFileCmd(interp); TclInitInfoCmd(interp); TclInitNamespaceCmd(interp); TclInitStringCmd(interp); TclInitPrefixCmd(interp); - TclInitProcessCmd(interp); /* * Register "clock" subcommands. These *do* go through * Tcl_CreateObjCommand, since they aren't in the global namespace and * involve ensembles. @@ -994,13 +848,17 @@ TclNRAssembleObjCmd, NULL, NULL); cmdPtr->compileProc = &TclCompileAssembleCmd; /* Coroutine monkeybusiness */ Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL, - NRInjectObjCmd, NULL, NULL); + NRCoroInjectObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "::tcl::unsupported::corotype", CoroTypeObjCmd, NULL, NULL); + + /* Create an unsupported command for timerate */ + Tcl_CreateObjCommand(interp, "::tcl::unsupported::timerate", + Tcl_TimeRateObjCmd, NULL, NULL); /* Export unsupported commands */ nsPtr = Tcl_FindNamespace(interp, "::tcl::unsupported", NULL, 0); if (nsPtr) { Tcl_Export(interp, nsPtr, "*", 1); @@ -1043,11 +901,11 @@ } Tcl_Export(interp, nsPtr, "*", 1); #define MATH_OP_PREFIX_LEN 15 /* == strlen("::tcl::mathop::") */ memcpy(mathFuncName, "::tcl::mathop::", MATH_OP_PREFIX_LEN); for (opcmdInfoPtr=mathOpCmds ; opcmdInfoPtr->name!=NULL ; opcmdInfoPtr++){ - TclOpCmdClientData *occdPtr = Tcl_Alloc(sizeof(TclOpCmdClientData)); + TclOpCmdClientData *occdPtr = ckalloc(sizeof(TclOpCmdClientData)); occdPtr->op = opcmdInfoPtr->name; occdPtr->i.numArgs = opcmdInfoPtr->i.numArgs; occdPtr->expected = opcmdInfoPtr->expected; strcpy(mathFuncName + MATH_OP_PREFIX_LEN, opcmdInfoPtr->name); @@ -1089,25 +947,28 @@ Tcl_SetVar2(interp, "tcl_platform", "byteOrder", ((order.c[0] == 1) ? "littleEndian" : "bigEndian"), TCL_GLOBAL_ONLY); Tcl_SetVar2Ex(interp, "tcl_platform", "wordSize", - Tcl_NewWideIntObj(sizeof(long)), TCL_GLOBAL_ONLY); + Tcl_NewLongObj((long) sizeof(long)), TCL_GLOBAL_ONLY); /* TIP #291 */ Tcl_SetVar2Ex(interp, "tcl_platform", "pointerSize", - Tcl_NewWideIntObj(sizeof(void *)), TCL_GLOBAL_ONLY); + Tcl_NewLongObj((long) sizeof(void *)), TCL_GLOBAL_ONLY); /* * Set up other variables such as tcl_version and tcl_library */ - Tcl_SetVar2(interp, "tcl_patchLevel", NULL, TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY); - Tcl_SetVar2(interp, "tcl_version", NULL, TCL_VERSION, TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "tcl_patchLevel", TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "tcl_version", TCL_VERSION, TCL_GLOBAL_ONLY); + Tcl_TraceVar2(interp, "tcl_precision", NULL, + TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + TclPrecTraceProc, NULL); TclpSetVariables(interp); -#if TCL_THREADS +#ifdef TCL_THREADS /* * The existence of the "threaded" element of the tcl_platform array * indicates that this particular Tcl shell has been compiled with threads * turned on. Using "info exists tcl_platform(threaded)" a Tcl script can * introspect on the interpreter level of thread safety. @@ -1122,28 +983,25 @@ */ Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs); if (TclTommath_Init(interp) != TCL_OK) { - Tcl_Panic("%s", Tcl_GetStringResult(interp)); + Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); } if (TclOOInit(interp) != TCL_OK) { - Tcl_Panic("%s", Tcl_GetStringResult(interp)); + Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); } /* * Only build in zlib support if we've successfully detected a library to * compile and link against. */ #ifdef HAVE_ZLIB if (TclZlibInit(interp) != TCL_OK) { - Tcl_Panic("%s", Tcl_GetStringResult(interp)); - } - if (TclZipfs_Init(interp) != TCL_OK) { - Tcl_Panic("%s", Tcl_GetStringResult(interp)); + Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); } #endif TOP_CB(iPtr) = NULL; return interp; @@ -1153,76 +1011,11 @@ DeleteOpCmdClientData( ClientData clientData) { TclOpCmdClientData *occdPtr = clientData; - Tcl_Free(occdPtr); -} - -/* - * --------------------------------------------------------------------- - * - * TclRegisterCommandTypeName, TclGetCommandTypeName -- - * - * Command type registration and lookup mechanism. Everything is keyed by - * the Tcl_ObjCmdProc for the command, and that is used as the *key* into - * the hash table that maps to constant strings that are names. (It is - * recommended that those names be ASCII.) - * - * --------------------------------------------------------------------- - */ - -void -TclRegisterCommandTypeName( - Tcl_ObjCmdProc *implementationProc, - const char *nameStr) -{ - Tcl_HashEntry *hPtr; - - Tcl_MutexLock(&commandTypeLock); - if (commandTypeInit == 0) { - Tcl_InitHashTable(&commandTypeTable, TCL_ONE_WORD_KEYS); - commandTypeInit = 1; - } - if (nameStr != NULL) { - int isNew; - - hPtr = Tcl_CreateHashEntry(&commandTypeTable, - (void *) implementationProc, &isNew); - Tcl_SetHashValue(hPtr, (void *) nameStr); - } else { - hPtr = Tcl_FindHashEntry(&commandTypeTable, - (void *) implementationProc); - if (hPtr != NULL) { - Tcl_DeleteHashEntry(hPtr); - } - } - Tcl_MutexUnlock(&commandTypeLock); -} - -const char * -TclGetCommandTypeName( - Tcl_Command command) -{ - Command *cmdPtr = (Command *) command; - void *procPtr = cmdPtr->objProc; - const char *name = "native"; - - if (procPtr == NULL) { - procPtr = cmdPtr->nreProc; - } - Tcl_MutexLock(&commandTypeLock); - if (commandTypeInit) { - Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&commandTypeTable, procPtr); - - if (hPtr && Tcl_GetHashValue(hPtr)) { - name = (const char *) Tcl_GetHashValue(hPtr); - } - } - Tcl_MutexUnlock(&commandTypeLock); - - return name; + ckfree(occdPtr); } /* *---------------------------------------------------------------------- * @@ -1241,96 +1034,24 @@ int TclHideUnsafeCommands( Tcl_Interp *interp) /* Hide commands in this interpreter. */ { - register const CmdInfo *cmdInfoPtr; - register const UnsafeEnsembleInfo *unsafePtr; + const CmdInfo *cmdInfoPtr; if (interp == NULL) { return TCL_ERROR; } for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) { if (!(cmdInfoPtr->flags & CMD_IS_SAFE)) { Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name); } } - - for (unsafePtr = unsafeEnsembleCommands; - unsafePtr->ensembleNsName; unsafePtr++) { - if (unsafePtr->commandName) { - /* - * Hide an ensemble subcommand. - */ - - Tcl_Obj *cmdName = Tcl_ObjPrintf("::tcl::%s::%s", - unsafePtr->ensembleNsName, unsafePtr->commandName); - Tcl_Obj *hideName = Tcl_ObjPrintf("tcl:%s:%s", - unsafePtr->ensembleNsName, unsafePtr->commandName); - - if (TclRenameCommand(interp, TclGetString(cmdName), - "___tmp") != TCL_OK - || Tcl_HideCommand(interp, "___tmp", - TclGetString(hideName)) != TCL_OK) { - Tcl_Panic("problem making '%s %s' safe: %s", - unsafePtr->ensembleNsName, unsafePtr->commandName, - Tcl_GetStringResult(interp)); - } - Tcl_CreateObjCommand(interp, TclGetString(cmdName), - BadEnsembleSubcommand, (ClientData) unsafePtr, NULL); - TclDecrRefCount(cmdName); - TclDecrRefCount(hideName); - } else { - /* - * Hide an ensemble main command (for compatibility). - */ - - if (Tcl_HideCommand(interp, unsafePtr->ensembleNsName, - unsafePtr->ensembleNsName) != TCL_OK) { - Tcl_Panic("problem making '%s' safe: %s", - unsafePtr->ensembleNsName, - Tcl_GetStringResult(interp)); - } - } - } - + TclMakeEncodingCommandSafe(interp); /* Ugh! */ + TclMakeFileCommandSafe(interp); /* Ugh! */ return TCL_OK; } - -/* - *---------------------------------------------------------------------- - * - * BadEnsembleSubcommand -- - * - * Command used to act as a backstop implementation when subcommands of - * ensembles are unsafe (the real implementations of the subcommands are - * hidden). The clientData is description of what was hidden. - * - * Results: - * A standard Tcl result (always a TCL_ERROR). - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -BadEnsembleSubcommand( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - const UnsafeEnsembleInfo *infoPtr = clientData; - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "not allowed to invoke subcommand %s of %s", - infoPtr->commandName, infoPtr->ensembleNsName)); - Tcl_SetErrorCode(interp, "TCL", "SAFE", "SUBCOMMAND", NULL); - return TCL_ERROR; -} /* *-------------------------------------------------------------- * * Tcl_CallWhenDeleted -- @@ -1359,21 +1080,21 @@ ClientData clientData) /* One-word value to pass to proc. */ { Interp *iPtr = (Interp *) interp; static Tcl_ThreadDataKey assocDataCounterKey; int *assocDataCounterPtr = - Tcl_GetThreadData(&assocDataCounterKey, sizeof(int)); + Tcl_GetThreadData(&assocDataCounterKey, (int)sizeof(int)); int isNew; char buffer[32 + TCL_INTEGER_SPACE]; - AssocData *dPtr = Tcl_Alloc(sizeof(AssocData)); + AssocData *dPtr = ckalloc(sizeof(AssocData)); Tcl_HashEntry *hPtr; sprintf(buffer, "Assoc Data Key #%d", *assocDataCounterPtr); (*assocDataCounterPtr)++; if (iPtr->assocData == NULL) { - iPtr->assocData = Tcl_Alloc(sizeof(Tcl_HashTable)); + iPtr->assocData = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); } hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &isNew); dPtr->proc = proc; dPtr->clientData = clientData; @@ -1418,11 +1139,11 @@ } for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { dPtr = Tcl_GetHashValue(hPtr); if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) { - Tcl_Free(dPtr); + ckfree(dPtr); Tcl_DeleteHashEntry(hPtr); return; } } } @@ -1458,18 +1179,18 @@ AssocData *dPtr; Tcl_HashEntry *hPtr; int isNew; if (iPtr->assocData == NULL) { - iPtr->assocData = Tcl_Alloc(sizeof(Tcl_HashTable)); + iPtr->assocData = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); } hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &isNew); if (isNew == 0) { dPtr = Tcl_GetHashValue(hPtr); } else { - dPtr = Tcl_Alloc(sizeof(AssocData)); + dPtr = ckalloc(sizeof(AssocData)); } dPtr->proc = proc; dPtr->clientData = clientData; Tcl_SetHashValue(hPtr, dPtr); @@ -1510,11 +1231,11 @@ } dPtr = Tcl_GetHashValue(hPtr); if (dPtr->proc != NULL) { dPtr->proc(dPtr->clientData, interp); } - Tcl_Free(dPtr); + ckfree(dPtr); Tcl_DeleteHashEntry(hPtr); } /* *---------------------------------------------------------------------- @@ -1706,13 +1427,13 @@ if (hPtr != NULL) { CancelInfo *cancelInfo = Tcl_GetHashValue(hPtr); if (cancelInfo != NULL) { if (cancelInfo->result != NULL) { - Tcl_Free(cancelInfo->result); + ckfree(cancelInfo->result); } - Tcl_Free(cancelInfo); + ckfree(cancelInfo); } Tcl_DeleteHashEntry(hPtr); } @@ -1763,11 +1484,11 @@ hPtr = Tcl_FirstHashEntry(hTablePtr, &search); for (; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { Tcl_DeleteCommandFromToken(interp, Tcl_GetHashValue(hPtr)); } Tcl_DeleteHashTable(hTablePtr); - Tcl_Free(hTablePtr); + ckfree(hTablePtr); } /* * Invoke deletion callbacks; note that a callback can create new * callbacks, so we iterate. @@ -1784,14 +1505,14 @@ dPtr = Tcl_GetHashValue(hPtr); Tcl_DeleteHashEntry(hPtr); if (dPtr->proc != NULL) { dPtr->proc(dPtr->clientData, interp); } - Tcl_Free(dPtr); + ckfree(dPtr); } Tcl_DeleteHashTable(hTablePtr); - Tcl_Free(hTablePtr); + ckfree(hTablePtr); } /* * Pop the root frame pointer and finish deleting the global * namespace. The order is important [Bug 1658572]. @@ -1799,20 +1520,21 @@ if ((iPtr->framePtr != iPtr->rootFramePtr) && !TclInExit()) { Tcl_Panic("DeleteInterpProc: popping rootCallFrame with other frames on top"); } Tcl_PopCallFrame(interp); - Tcl_Free(iPtr->rootFramePtr); + ckfree(iPtr->rootFramePtr); iPtr->rootFramePtr = NULL; Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr); /* * Free up the result *after* deleting variables, since variable deletion * could have transferred ownership of the result string to Tcl. */ Tcl_FreeResult(interp); + iPtr->result = NULL; Tcl_DecrRefCount(iPtr->objResultPtr); iPtr->objResultPtr = NULL; Tcl_DecrRefCount(iPtr->ecVar); if (iPtr->errorCode) { Tcl_DecrRefCount(iPtr->errorCode); @@ -1829,10 +1551,14 @@ Tcl_DecrRefCount(iPtr->callLiteral); Tcl_DecrRefCount(iPtr->innerLiteral); Tcl_DecrRefCount(iPtr->innerContext); if (iPtr->returnOpts) { Tcl_DecrRefCount(iPtr->returnOpts); + } + if (iPtr->appendResult != NULL) { + ckfree(iPtr->appendResult); + iPtr->appendResult = NULL; } TclFreePackageInfo(iPtr); while (iPtr->tracePtr != NULL) { Tcl_DeleteTrace((Tcl_Interp *) iPtr, (Tcl_Trace) iPtr->tracePtr); } @@ -1847,12 +1573,12 @@ iPtr->emptyObjPtr = NULL; resPtr = iPtr->resolverPtr; while (resPtr) { nextResPtr = resPtr->nextPtr; - Tcl_Free(resPtr->name); - Tcl_Free(resPtr); + ckfree(resPtr->name); + ckfree(resPtr); resPtr = nextResPtr; } /* * Free up literal objects created for scripts compiled by the @@ -1875,17 +1601,17 @@ procPtr->iPtr = NULL; if (cfPtr) { if (cfPtr->type == TCL_LOCATION_SOURCE) { Tcl_DecrRefCount(cfPtr->data.eval.path); } - Tcl_Free(cfPtr->line); - Tcl_Free(cfPtr); + ckfree(cfPtr->line); + ckfree(cfPtr); } Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(iPtr->linePBodyPtr); - Tcl_Free(iPtr->linePBodyPtr); + ckfree(iPtr->linePBodyPtr); iPtr->linePBodyPtr = NULL; /* * See also tclCompile.c, TclCleanupByteCode */ @@ -1897,22 +1623,22 @@ if (eclPtr->type == TCL_LOCATION_SOURCE) { Tcl_DecrRefCount(eclPtr->path); } for (i=0; i< eclPtr->nuloc; i++) { - Tcl_Free(eclPtr->loc[i].line); + ckfree(eclPtr->loc[i].line); } if (eclPtr->loc != NULL) { - Tcl_Free(eclPtr->loc); + ckfree(eclPtr->loc); } - Tcl_Free(eclPtr); + ckfree(eclPtr); Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(iPtr->lineBCPtr); - Tcl_Free(iPtr->lineBCPtr); + ckfree(iPtr->lineBCPtr); iPtr->lineBCPtr = NULL; /* * Location stack for uplevel/eval/... scripts which were passed through * proc arguments. Actually we track all arguments as we do not and cannot @@ -1927,11 +1653,11 @@ Tcl_Panic("Argument location tracking table not empty"); } Tcl_DeleteHashTable(iPtr->lineLAPtr); - Tcl_Free(iPtr->lineLAPtr); + ckfree((char *) iPtr->lineLAPtr); iPtr->lineLAPtr = NULL; if (iPtr->lineLABCPtr->numEntries && !TclInExit()) { /* * When the interp goes away we have nothing on the stack, so there @@ -1940,11 +1666,11 @@ Tcl_Panic("Argument location tracking table not empty"); } Tcl_DeleteHashTable(iPtr->lineLABCPtr); - Tcl_Free(iPtr->lineLABCPtr); + ckfree(iPtr->lineLABCPtr); iPtr->lineLABCPtr = NULL; /* * Squelch the tables of traces on variables and searches over arrays in * the in the interpreter. @@ -1951,11 +1677,11 @@ */ Tcl_DeleteHashTable(&iPtr->varTraces); Tcl_DeleteHashTable(&iPtr->varSearches); - Tcl_Free(iPtr); + ckfree(iPtr); } /* *--------------------------------------------------------------------------- * @@ -2055,11 +1781,11 @@ * Initialize the hidden command table if necessary. */ hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr; if (hiddenCmdTablePtr == NULL) { - hiddenCmdTablePtr = Tcl_Alloc(sizeof(Tcl_HashTable)); + hiddenCmdTablePtr = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS); iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr; } /* @@ -2421,11 +2147,11 @@ * If the deletion callback recreated the command, just throw away the * new command (if we try to delete it again, we could get stuck in an * infinite loop). */ - Tcl_Free(Tcl_GetHashValue(hPtr)); + ckfree(Tcl_GetHashValue(hPtr)); } if (!deleted) { /* * Command resolvers (per-interp, per-namespace) might have resolved @@ -2446,11 +2172,11 @@ */ TclInvalidateNsCmdLookup(nsPtr); TclInvalidateNsPath(nsPtr); } - cmdPtr = Tcl_Alloc(sizeof(Command)); + cmdPtr = ckalloc(sizeof(Command)); Tcl_SetHashValue(hPtr, cmdPtr); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = nsPtr; cmdPtr->refCount = 1; cmdPtr->cmdEpoch = 0; @@ -2504,10 +2230,11 @@ * future calls to Tcl_GetCommandName. * * Side effects: * If a command named "cmdName" already exists for interp, it is * first deleted. Then the new command is created from the arguments. + * [***] (See below for exception). * * In the future, during bytecode evaluation when "cmdName" is seen as * the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based * Tcl_ObjCmdProc proc will be called. When the command is deleted from * the table, deleteProc will be called. See the manual entry for details @@ -2567,37 +2294,34 @@ return TclCreateObjCommandInNs(interp, tail, (Tcl_Namespace *) nsPtr, proc, clientData, deleteProc); } Tcl_Command -TclCreateObjCommandInNs( +TclCreateObjCommandInNs ( Tcl_Interp *interp, - const char *cmdName, /* Name of command, without any namespace - * components. */ + const char *cmdName, /* Name of command, without any namespace components */ Tcl_Namespace *namespace, /* The namespace to create the command in */ Tcl_ObjCmdProc *proc, /* Object-based function to associate with * name. */ ClientData clientData, /* Arbitrary value to pass to object * function. */ - Tcl_CmdDeleteProc *deleteProc) + Tcl_CmdDeleteProc *deleteProc /* If not NULL, gives a function to call when * this command is deleted. */ -{ +) { int deleted = 0, isNew = 0; Command *cmdPtr; ImportRef *oldRefPtr = NULL; ImportedCmdData *dataPtr; Tcl_HashEntry *hPtr; Namespace *nsPtr = (Namespace *) namespace; - /* - * If the command name we seek to create already exists, we need to delete - * that first. That can be tricky in the presence of traces. Loop until we - * no longer find an existing command in the way, or until we've deleted - * one command and that didn't finish the job. + * If the command name we seek to create already exists, we need to + * delete that first. That can be tricky in the presence of traces. + * Loop until we no longer find an existing command in the way, or + * until we've deleted one command and that didn't finish the job. */ - while (1) { hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &isNew); if (isNew || deleted) { /* @@ -2612,11 +2336,28 @@ */ cmdPtr = Tcl_GetHashValue(hPtr); /* - * Command already exists; delete it. Be careful to preserve any + * [***] This is wrong. See Tcl Bug a16752c252. + * However, this buggy behavior is kept under particular circumstances + * to accommodate deployed binaries of the "tclcompiler" program + * that crash if the bug is + * fixed. + */ + + if (cmdPtr->objProc == TclInvokeStringCommand + && cmdPtr->clientData == clientData + && cmdPtr->deleteData == clientData + && cmdPtr->deleteProc == deleteProc) { + cmdPtr->objProc = proc; + cmdPtr->objClientData = clientData; + return (Tcl_Command) cmdPtr; + } + + /* + * Otherwise, we delete the old command. Be careful to preserve any * existing import links so we can restore them down below. That way, * you can redefine a command and its import status will remain * intact. */ @@ -2631,11 +2372,11 @@ cmdPtr->nsPtr->refCount++; Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); nsPtr = (Namespace *) TclEnsureNamespace(interp, - (Tcl_Namespace *) cmdPtr->nsPtr); + (Tcl_Namespace *)cmdPtr->nsPtr); TclNsDecrRefCount(cmdPtr->nsPtr); if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) { oldRefPtr = cmdPtr->importRefPtr; cmdPtr->importRefPtr = NULL; @@ -2643,16 +2384,16 @@ TclCleanupCommandMacro(cmdPtr); deleted = 1; } if (!isNew) { /* - * If the deletion callback recreated the command, just throw away the - * new command (if we try to delete it again, we could get stuck in an - * infinite loop). + * If the deletion callback recreated the command, just throw away + * the new command (if we try to delete it again, we could get + * stuck in an infinite loop). */ - Tcl_Free(Tcl_GetHashValue(hPtr)); + ckfree(Tcl_GetHashValue(hPtr)); } if (!deleted) { /* * Command resolvers (per-interp, per-namespace) might have resolved @@ -2673,11 +2414,11 @@ */ TclInvalidateNsCmdLookup(nsPtr); TclInvalidateNsPath(nsPtr); } - cmdPtr = Tcl_Alloc(sizeof(Command)); + cmdPtr = ckalloc(sizeof(Command)); Tcl_SetHashValue(hPtr, cmdPtr); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = nsPtr; cmdPtr->refCount = 1; cmdPtr->cmdEpoch = 0; @@ -2700,11 +2441,10 @@ if (oldRefPtr != NULL) { cmdPtr->importRefPtr = oldRefPtr; while (oldRefPtr != NULL) { Command *refCmdPtr = oldRefPtr->importedCmdPtr; - dataPtr = refCmdPtr->objClientData; dataPtr->realCmdPtr = cmdPtr; oldRefPtr = oldRefPtr->nextPtr; } } @@ -2743,20 +2483,20 @@ int TclInvokeStringCommand( ClientData clientData, /* Points to command's Command structure. */ Tcl_Interp *interp, /* Current interpreter. */ - register int objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Command *cmdPtr = clientData; int i, result; const char **argv = - TclStackAlloc(interp, (objc + 1) * sizeof(char *)); + TclStackAlloc(interp, (unsigned)(objc + 1) * sizeof(char *)); for (i = 0; i < objc; i++) { - argv[i] = TclGetString(objv[i]); + argv[i] = Tcl_GetString(objv[i]); } argv[objc] = 0; /* * Invoke the command's string-based Tcl_CmdProc. @@ -2778,11 +2518,11 @@ * pointer to this function is stored as the Tcl_CmdProc in a Command * structure. It simply turns around and calls the object Tcl_ObjCmdProc * in the Command structure. * * Results: - * A standard Tcl result value. + * A standard Tcl string result value. * * Side effects: * Besides those side effects of the called Tcl_ObjCmdProc, * TclInvokeObjectCommand allocates and frees storage. * @@ -2792,17 +2532,17 @@ int TclInvokeObjectCommand( ClientData clientData, /* Points to command's Command structure. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ - register const char **argv) /* Argument strings. */ + const char **argv) /* Argument strings. */ { Command *cmdPtr = clientData; Tcl_Obj *objPtr; int i, length, result; Tcl_Obj **objv = - TclStackAlloc(interp, (argc * sizeof(Tcl_Obj *))); + TclStackAlloc(interp, (unsigned)(argc * sizeof(Tcl_Obj *))); for (i = 0; i < argc; i++) { length = strlen(argv[i]); TclNewStringObj(objPtr, argv[i], length); Tcl_IncrRefCount(objPtr); @@ -2818,10 +2558,17 @@ } else { result = Tcl_NRCallObjProc(interp, cmdPtr->nreProc, cmdPtr->objClientData, argc, objv); } + /* + * Move the interpreter's object result to the string result, then reset + * the object result. + */ + + (void) Tcl_GetStringResult(interp); + /* * Decrement the ref counts for the argument objects created above, then * free the objv array if malloc'ed storage was used. */ @@ -2999,11 +2746,11 @@ if (newNsPtr != iPtr->globalNsPtr) { TclDStringAppendLiteral(&newFullName, "::"); } Tcl_DStringAppend(&newFullName, newTail, -1); cmdPtr->refCount++; - CallCommandTraces(iPtr, cmdPtr, TclGetString(oldFullName), + CallCommandTraces(iPtr, cmdPtr, Tcl_GetString(oldFullName), Tcl_DStringValue(&newFullName), TCL_TRACE_RENAME); Tcl_DStringFree(&newFullName); /* * The new command name is okay, so remove the command from its current @@ -3276,11 +3023,11 @@ Tcl_Obj *objPtr) /* Points to the object onto which the * command's full name is appended. */ { Interp *iPtr = (Interp *) interp; - register Command *cmdPtr = (Command *) command; + Command *cmdPtr = (Command *) command; char *name; /* * Add the full name of the containing namespace, followed by the "::" * separator, and the command name. @@ -3365,10 +3112,17 @@ Interp *iPtr = (Interp *) interp; Command *cmdPtr = (Command *) cmd; ImportRef *refPtr, *nextRefPtr; Tcl_Command importCmd; + /* + * Bump the command epoch counter. This will invalidate all cached + * references that point to this command. + */ + + cmdPtr->cmdEpoch++; + /* * The code here is tricky. We can't delete the hash table entry before * invoking the deletion callback because there are cases where the * deletion callback needs to invoke the command (e.g. object systems such * as OTcl). However, this means that the callback could try to delete or @@ -3387,18 +3141,10 @@ if (cmdPtr->hPtr != NULL) { Tcl_DeleteHashEntry(cmdPtr->hPtr); cmdPtr->hPtr = NULL; } - - /* - * Bump the command epoch counter. This will invalidate all cached - * references that point to this command. - */ - - cmdPtr->cmdEpoch++; - return 0; } /* * We must delete this command, even though both traces and delete procs @@ -3428,11 +3174,11 @@ tracePtr = cmdPtr->tracePtr; while (tracePtr != NULL) { CommandTrace *nextPtr = tracePtr->nextPtr; if (tracePtr->refCount-- <= 1) { - Tcl_Free(tracePtr); + ckfree(tracePtr); } tracePtr = nextPtr; } cmdPtr->tracePtr = NULL; } @@ -3467,14 +3213,14 @@ * the "real" command that this imported command refers to. * * If you are getting a crash during the call to deleteProc and * cmdPtr->deleteProc is a pointer to the function free(), the most * likely cause is that your extension allocated memory for the - * clientData argument to Tcl_CreateObjCommand with the Tcl_Alloc() + * clientData argument to Tcl_CreateObjCommand with the ckalloc() * macro and you are now trying to deallocate this memory with free() - * instead of Tcl_Free(). You should pass a pointer to your own method - * that calls Tcl_Free(). + * instead of ckfree(). You should pass a pointer to your own method + * that calls ckfree(). */ cmdPtr->deleteProc(cmdPtr->deleteData); } @@ -3500,17 +3246,10 @@ */ if (cmdPtr->hPtr != NULL) { Tcl_DeleteHashEntry(cmdPtr->hPtr); cmdPtr->hPtr = NULL; - - /* - * Bump the command epoch counter. This will invalidate all cached - * references that point to this command. - */ - - cmdPtr->cmdEpoch++; } /* * A number of tests for particular kinds of commands are done by checking * whether the objProc field holds a known value. Set the field to NULL so @@ -3527,10 +3266,11 @@ * ByteCode is freed) or replaced by a new reference (when a cached * CmdName Command reference is found to be invalid and * TclNRExecuteByteCode looks up the command in the command hashtable). */ + cmdPtr->flags |= CMD_DEAD; TclCleanupCommandMacro(cmdPtr); return 0; } /* @@ -3560,11 +3300,11 @@ * is not being renamed */ int flags) /* Flags indicating the type of traces to * trigger, either TCL_TRACE_DELETE or * TCL_TRACE_RENAME. */ { - register CommandTrace *tracePtr; + CommandTrace *tracePtr; ActiveCommandTrace active; char *result; Tcl_Obj *oldNamePtr = NULL; Tcl_InterpState state = NULL; @@ -3622,11 +3362,11 @@ } tracePtr->traceProc(tracePtr->clientData, (Tcl_Interp *) iPtr, oldName, newName, flags); cmdPtr->flags &= ~tracePtr->flags; if (tracePtr->refCount-- <= 1) { - Tcl_Free(tracePtr); + ckfree(tracePtr); } } if (state) { Tcl_RestoreInterpState((Tcl_Interp *) iPtr, state); @@ -3702,15 +3442,15 @@ */ TclSetCancelFlags(iPtr, cancelInfo->flags | CANCELED); /* - * Now, we must set the script cancellation flags on all the slave + * Now, we must set the script cancellation flags on all the child * interpreters belonging to this one. */ - TclSetSlaveCancelFlags((Tcl_Interp *) iPtr, + TclSetChildCancelFlags((Tcl_Interp *) iPtr, cancelInfo->flags | CANCELED, 0); /* * Create the result object now so that Tcl_Canceled can avoid * locking the cancelLock mutex. @@ -3750,17 +3490,372 @@ *---------------------------------------------------------------------- */ void TclCleanupCommand( - register Command *cmdPtr) /* Points to the Command structure to + Command *cmdPtr) /* Points to the Command structure to * be freed. */ { - if (cmdPtr->refCount-- <= 1) { - Tcl_Free(cmdPtr); + cmdPtr->refCount--; + if (cmdPtr->refCount <= 0) { + ckfree(cmdPtr); } } + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateMathFunc -- + * + * Creates a new math function for expressions in a given interpreter. + * + * Results: + * None. + * + * Side effects: + * The Tcl function defined by "name" is created or redefined. If the + * function already exists then its definition is replaced; this includes + * the builtin functions. Redefining a builtin function forces all + * existing code to be invalidated since that code may be compiled using + * an instruction specific to the replaced function. In addition, + * redefioning a non-builtin function will force existing code to be + * invalidated if the number of arguments has changed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_CreateMathFunc( + Tcl_Interp *interp, /* Interpreter in which function is to be + * available. */ + const char *name, /* Name of function (e.g. "sin"). */ + int numArgs, /* Nnumber of arguments required by + * function. */ + Tcl_ValueType *argTypes, /* Array of types acceptable for each + * argument. */ + Tcl_MathProc *proc, /* C function that implements the math + * function. */ + ClientData clientData) /* Additional value to pass to the + * function. */ +{ + Tcl_DString bigName; + OldMathFuncData *data = ckalloc(sizeof(OldMathFuncData)); + + data->proc = proc; + data->numArgs = numArgs; + data->argTypes = ckalloc(numArgs * sizeof(Tcl_ValueType)); + memcpy(data->argTypes, argTypes, numArgs * sizeof(Tcl_ValueType)); + data->clientData = clientData; + + Tcl_DStringInit(&bigName); + TclDStringAppendLiteral(&bigName, "::tcl::mathfunc::"); + Tcl_DStringAppend(&bigName, name, -1); + + Tcl_CreateObjCommand(interp, Tcl_DStringValue(&bigName), + OldMathFuncProc, data, OldMathFuncDeleteProc); + Tcl_DStringFree(&bigName); +} + +/* + *---------------------------------------------------------------------- + * + * OldMathFuncProc -- + * + * Dispatch to a math function created with Tcl_CreateMathFunc + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Whatever the math function does. + * + *---------------------------------------------------------------------- + */ + +static int +OldMathFuncProc( + ClientData clientData, /* Ponter to OldMathFuncData describing the + * function being called */ + Tcl_Interp *interp, /* Tcl interpreter */ + int objc, /* Actual parameter count */ + Tcl_Obj *const *objv) /* Parameter vector */ +{ + Tcl_Obj *valuePtr; + OldMathFuncData *dataPtr = clientData; + Tcl_Value funcResult, *args; + int result; + int j, k; + double d; + + /* + * Check argument count. + */ + + if (objc != dataPtr->numArgs + 1) { + MathFuncWrongNumArgs(interp, dataPtr->numArgs+1, objc, objv); + return TCL_ERROR; + } + + /* + * Convert arguments from Tcl_Obj's to Tcl_Value's. + */ + + args = ckalloc(dataPtr->numArgs * sizeof(Tcl_Value)); + for (j = 1, k = 0; j < objc; ++j, ++k) { + /* TODO: Convert to TclGetNumberFromObj? */ + valuePtr = objv[j]; + result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d); +#ifdef ACCEPT_NAN + if ((result != TCL_OK) && (valuePtr->typePtr == &tclDoubleType)) { + d = valuePtr->internalRep.doubleValue; + result = TCL_OK; + } +#endif + if (result != TCL_OK) { + /* + * We have a non-numeric argument. + */ + + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "argument to math function didn't have numeric value", + -1)); + TclCheckBadOctal(interp, Tcl_GetString(valuePtr)); + ckfree(args); + return TCL_ERROR; + } + + /* + * Copy the object's numeric value to the argument record, converting + * it if necessary. + * + * NOTE: no bignum support; use the new mathfunc interface for that. + */ + + args[k].type = dataPtr->argTypes[k]; + switch (args[k].type) { + case TCL_EITHER: + if (Tcl_GetLongFromObj(NULL, valuePtr, &args[k].intValue) + == TCL_OK) { + args[k].type = TCL_INT; + break; + } + if (TclGetWideIntFromObj(interp, valuePtr, &args[k].wideValue) + == TCL_OK) { + args[k].type = TCL_WIDE_INT; + break; + } + args[k].type = TCL_DOUBLE; + /* FALLTHROUGH */ + + case TCL_DOUBLE: + args[k].doubleValue = d; + break; + case TCL_INT: + if (ExprIntFunc(NULL, interp, 2, &objv[j-1]) != TCL_OK) { + ckfree(args); + return TCL_ERROR; + } + valuePtr = Tcl_GetObjResult(interp); + Tcl_GetLongFromObj(NULL, valuePtr, &args[k].intValue); + Tcl_ResetResult(interp); + break; + case TCL_WIDE_INT: + if (ExprWideFunc(NULL, interp, 2, &objv[j-1]) != TCL_OK) { + ckfree(args); + return TCL_ERROR; + } + valuePtr = Tcl_GetObjResult(interp); + TclGetWideIntFromObj(NULL, valuePtr, &args[k].wideValue); + Tcl_ResetResult(interp); + break; + } + } + + /* + * Call the function. + */ + + errno = 0; + result = dataPtr->proc(dataPtr->clientData, interp, args, &funcResult); + ckfree(args); + if (result != TCL_OK) { + return result; + } + + /* + * Return the result of the call. + */ + + if (funcResult.type == TCL_INT) { + TclNewLongObj(valuePtr, funcResult.intValue); + } else if (funcResult.type == TCL_WIDE_INT) { + valuePtr = Tcl_NewWideIntObj(funcResult.wideValue); + } else { + return CheckDoubleResult(interp, funcResult.doubleValue); + } + Tcl_SetObjResult(interp, valuePtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * OldMathFuncDeleteProc -- + * + * Cleans up after deleting a math function registered with + * Tcl_CreateMathFunc + * + * Results: + * None. + * + * Side effects: + * Frees allocated memory. + * + *---------------------------------------------------------------------- + */ + +static void +OldMathFuncDeleteProc( + ClientData clientData) +{ + OldMathFuncData *dataPtr = clientData; + + ckfree(dataPtr->argTypes); + ckfree(dataPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetMathFuncInfo -- + * + * Discovers how a particular math function was created in a given + * interpreter. + * + * Results: + * TCL_OK if it succeeds, TCL_ERROR else (leaving an error message in the + * interpreter result if that happens.) + * + * Side effects: + * If this function succeeds, the variables pointed to by the numArgsPtr + * and argTypePtr arguments will be updated to detail the arguments + * allowed by the function. The variable pointed to by the procPtr + * argument will be set to NULL if the function is a builtin function, + * and will be set to the address of the C function used to implement the + * math function otherwise (in which case the variable pointed to by the + * clientDataPtr argument will also be updated.) + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetMathFuncInfo( + Tcl_Interp *interp, + const char *name, + int *numArgsPtr, + Tcl_ValueType **argTypesPtr, + Tcl_MathProc **procPtr, + ClientData *clientDataPtr) +{ + Tcl_Obj *cmdNameObj; + Command *cmdPtr; + + /* + * Get the command that implements the math function. + */ + + TclNewLiteralStringObj(cmdNameObj, "tcl::mathfunc::"); + Tcl_AppendToObj(cmdNameObj, name, -1); + Tcl_IncrRefCount(cmdNameObj); + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdNameObj); + Tcl_DecrRefCount(cmdNameObj); + + /* + * Report unknown functions. + */ + + if (cmdPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown math function \"%s\"", name)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "MATHFUNC", name, NULL); + *numArgsPtr = -1; + *argTypesPtr = NULL; + *procPtr = NULL; + *clientDataPtr = NULL; + return TCL_ERROR; + } + + /* + * Retrieve function info for user defined functions; return dummy + * information for builtins. + */ + + if (cmdPtr->objProc == &OldMathFuncProc) { + OldMathFuncData *dataPtr = cmdPtr->clientData; + + *procPtr = dataPtr->proc; + *numArgsPtr = dataPtr->numArgs; + *argTypesPtr = dataPtr->argTypes; + *clientDataPtr = dataPtr->clientData; + } else { + *procPtr = NULL; + *numArgsPtr = -1; + *argTypesPtr = NULL; + *procPtr = NULL; + *clientDataPtr = NULL; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ListMathFuncs -- + * + * Produces a list of all the math functions defined in a given + * interpreter. + * + * Results: + * A pointer to a Tcl_Obj structure with a reference count of zero, or + * NULL in the case of an error (in which case a suitable error message + * will be left in the interpreter result.) + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +Tcl_ListMathFuncs( + Tcl_Interp *interp, + const char *pattern) +{ + Tcl_Obj *script = Tcl_NewStringObj("::info functions ", -1); + Tcl_Obj *result; + Tcl_InterpState state; + + if (pattern) { + Tcl_Obj *patternObj = Tcl_NewStringObj(pattern, -1); + Tcl_Obj *arg = Tcl_NewListObj(1, &patternObj); + + Tcl_AppendObjToObj(script, arg); + Tcl_DecrRefCount(arg); /* Should tear down patternObj too */ + } + + state = Tcl_SaveInterpState(interp, TCL_OK); + Tcl_IncrRefCount(script); + if (TCL_OK == Tcl_EvalObjEx(interp, script, 0)) { + result = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); + } else { + result = Tcl_NewObj(); + } + Tcl_DecrRefCount(script); + Tcl_RestoreInterpState(interp, state); + + return result; +} /* *---------------------------------------------------------------------- * * TclInterpReady -- @@ -3771,24 +3866,24 @@ * Results: * The return value is TCL_OK if it the interpreter is ready, TCL_ERROR * otherwise. * * Side effects: - * The interpreter's result is cleared. + * The interpreters object and string results are cleared. * *---------------------------------------------------------------------- */ int TclInterpReady( Tcl_Interp *interp) { - register Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *) interp; /* - * Reset the interpreter's result and clear out any previous error - * information. + * Reset both the interpreter's string and object results and clear out + * any previous error information. */ Tcl_ResetResult(interp); /* @@ -3852,11 +3947,11 @@ int TclResetCancellation( Tcl_Interp *interp, int force) { - register Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *) interp; if (iPtr == NULL) { return TCL_ERROR; } @@ -3870,11 +3965,11 @@ *---------------------------------------------------------------------- * * Tcl_Canceled -- * * Check if the script in progress has been canceled, i.e., - * Tcl_CancelEval was called for this interpreter or any of its master + * Tcl_CancelEval was called for this interpreter or any of its parent * interpreters. * * Results: * The return value is TCL_OK if the script evaluation has not been * canceled, TCL_ERROR otherwise. @@ -3894,11 +3989,11 @@ int Tcl_Canceled( Tcl_Interp *interp, int flags) { - register Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *) interp; /* * Has the current script in progress for this interpreter been canceled * or is the stack being unwound due to the previous script cancellation? */ @@ -3933,19 +4028,19 @@ * interp's result; otherwise, we leave it alone. */ if (flags & TCL_LEAVE_ERR_MSG) { const char *id, *message = NULL; - size_t length; + int length; /* * Setup errorCode variables so that we can differentiate between * being canceled and unwound. */ if (iPtr->asyncCancelMsg != NULL) { - message = TclGetStringFromObj(iPtr->asyncCancelMsg, &length); + message = Tcl_GetStringFromObj(iPtr->asyncCancelMsg, &length); } else { length = 0; } if (iPtr->flags & TCL_CANCEL_UNWIND) { @@ -4040,12 +4135,12 @@ * allowed to catch the script cancellation because the evaluation stack * for the interp is completely unwound. */ if (resultObjPtr != NULL) { - result = TclGetStringFromObj(resultObjPtr, &cancelInfo->length); - cancelInfo->result = Tcl_Realloc(cancelInfo->result,cancelInfo->length); + result = Tcl_GetStringFromObj(resultObjPtr, &cancelInfo->length); + cancelInfo->result = ckrealloc(cancelInfo->result,cancelInfo->length); memcpy(cancelInfo->result, result, cancelInfo->length); TclDecrRefCount(resultObjPtr); /* Discard their result object. */ } else { cancelInfo->result = NULL; cancelInfo->length = 0; @@ -4235,11 +4330,11 @@ if (preCmdPtr) { /* * Caller gave it to us. */ - if (!(preCmdPtr->flags & CMD_IS_DELETED)) { + if (!(preCmdPtr->flags & CMD_DEAD)) { /* * So long as it exists, use it. */ cmdPtr = preCmdPtr; @@ -4368,10 +4463,30 @@ int result, struct NRE_callback *rootPtr) /* All callbacks down to rootPtr not inclusive * are to be run. */ { + Interp *iPtr = (Interp *) interp; + + /* + * If the interpreter has a non-empty string result, the result object is + * either empty or stale because some function set interp->result + * directly. If so, move the string result to the result object, then + * reset the string result. + * + * This only needs to be done for the first item in the list: all other + * are for NR function calls, and those are Tcl_Obj based. + */ + + if (*(iPtr->result) != 0) { + (void) Tcl_GetObjResult(interp); + } + + /* + * This is the trampoline. + */ + while (TOP_CB(interp) != rootPtr) { NRE_callback *callbackPtr = TOP_CB(interp); Tcl_NRPostProc *procPtr = callbackPtr->procPtr; TOP_CB(interp) = callbackPtr->nextPtr; @@ -4527,23 +4642,23 @@ int result) { Interp *iPtr = (Interp *) interp; Tcl_Obj *listPtr; const char *cmdString; - size_t cmdLen; + int cmdLen; int objc = PTR2INT(data[0]); Tcl_Obj **objv = data[1]; - if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { + if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)){ /* * If there was an error, a command string will be needed for the * error log: get it out of the itemPtr. The details depend on the * type. */ listPtr = Tcl_NewListObj(objc, objv); - cmdString = TclGetStringFromObj(listPtr, &cmdLen); + cmdString = Tcl_GetStringFromObj(listPtr, &cmdLen); Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen); Tcl_DecrRefCount(listPtr); } iPtr->flags &= ~ERR_ALREADY_LOGGED; return result; @@ -4591,11 +4706,11 @@ */ Tcl_ListObjGetElements(NULL, currNsPtr->unknownHandlerPtr, &handlerObjc, &handlerObjv); newObjc = objc + handlerObjc; - newObjv = TclStackAlloc(interp, sizeof(Tcl_Obj *) * newObjc); + newObjv = TclStackAlloc(interp, (int) sizeof(Tcl_Obj *) * newObjc); /* * Copy command prefix from unknown handler and add on the real command's * full argument list. Note that we only use memcpy() once because we have * to increment the reference count of all the handler arguments anyway. @@ -4683,13 +4798,13 @@ int objc, Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *) interp; Command *cmdPtr = *cmdPtrPtr; - size_t length, newEpoch, cmdEpoch = cmdPtr->cmdEpoch; - int traceCode = TCL_OK; - const char *command = TclGetStringFromObj(commandPtr, &length); + int newEpoch, cmdEpoch = cmdPtr->cmdEpoch; + int length, traceCode = TCL_OK; + const char *command = Tcl_GetStringFromObj(commandPtr, &length); /* * Call trace functions. * Execute any command or execution traces. Note that we bump up the * command's reference count for the duration of the calling of the @@ -4736,15 +4851,15 @@ int traceCode = TCL_OK; int objc = PTR2INT(data[0]); Tcl_Obj *commandPtr = data[1]; Command *cmdPtr = data[2]; Tcl_Obj **objv = data[3]; - size_t length; - const char *command = TclGetStringFromObj(commandPtr, &length); + int length; + const char *command = Tcl_GetStringFromObj(commandPtr, &length); if (!(cmdPtr->flags & CMD_IS_DELETED)) { - if (cmdPtr->flags & CMD_HAS_EXEC_TRACES) { + if (cmdPtr->flags & CMD_HAS_EXEC_TRACES){ traceCode = TclCheckExecutionTraces(interp, command, length, cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv); } if (iPtr->tracePtr != NULL && traceCode == TCL_OK) { traceCode = TclCheckInterpTraces(interp, command, length, @@ -4819,16 +4934,64 @@ Tcl_Interp *interp, /* Interpreter in which to lookup variables, * execute nested commands, and report * errors. */ Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to * evaluate and concatenate. */ - size_t count) /* Number of tokens to consider at tokenPtr. + int count) /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ { return TclSubstTokens(interp, tokenPtr, count, /* numLeftPtr */ NULL, 1, NULL, NULL); } + +/* + *---------------------------------------------------------------------- + * + * Tcl_EvalTokens -- + * + * Given an array of tokens parsed from a Tcl command (e.g., the tokens + * that make up a word or the index for an array variable) this function + * evaluates the tokens and concatenates their values to form a single + * result value. + * + * Results: + * The return value is a pointer to a newly allocated Tcl_Obj containing + * the value of the array of tokens. The reference count of the returned + * object has been incremented. If an error occurs in evaluating the + * tokens then a NULL value is returned and an error message is left in + * interp's result. + * + * Side effects: + * A new object is allocated to hold the result. + * + *---------------------------------------------------------------------- + * + * This uses a non-standard return convention; its use is now deprecated. It + * is a wrapper for the new function Tcl_EvalTokensStandard, and is not used + * in the core any longer. It is only kept for backward compatibility. + */ + +Tcl_Obj * +Tcl_EvalTokens( + Tcl_Interp *interp, /* Interpreter in which to lookup variables, + * execute nested commands, and report + * errors. */ + Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to + * evaluate and concatenate. */ + int count) /* Number of tokens to consider at tokenPtr. + * Must be at least 1. */ +{ + Tcl_Obj *resPtr; + + if (Tcl_EvalTokensStandard(interp, tokenPtr, count) != TCL_OK) { + return NULL; + } + resPtr = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(resPtr); + Tcl_ResetResult(interp); + return resPtr; +} /* *---------------------------------------------------------------------- * * Tcl_EvalEx, TclEvalEx -- @@ -4852,11 +5015,11 @@ int Tcl_EvalEx( Tcl_Interp *interp, /* Interpreter in which to evaluate the * script. Also used for error reporting. */ const char *script, /* First character of script to evaluate. */ - size_t numBytes, /* Number of bytes in script. If -1, the + int numBytes, /* Number of bytes in script. If < 0, the * script consists of all bytes up to the * first null character. */ int flags) /* Collection of OR-ed bits that control the * evaluation of the script. Only * TCL_EVAL_GLOBAL is currently supported. */ @@ -4867,11 +5030,11 @@ int TclEvalEx( Tcl_Interp *interp, /* Interpreter in which to evaluate the * script. Also used for error reporting. */ const char *script, /* First character of script to evaluate. */ - size_t numBytes, /* Number of bytes in script. If -1, the + int numBytes, /* Number of bytes in script. If < 0, the * script consists of all bytes up to the * first NUL character. */ int flags, /* Collection of OR-ed bits that control the * evaluation of the script. Only * TCL_EVAL_GLOBAL is currently supported. */ @@ -4882,11 +5045,11 @@ * [...]-nested commands. The 'outerScript' * refers to the most-outer script containing * the embedded command, which is refered to * by 'script'. The 'clNextOuter' refers to * the current entry in the table of - * continuation lines in this "master script", + * continuation lines in this "main script", * and the character offsets are relative to * the 'outerScript' as well. * * If outerScript == script, then this call is * for the outer-most script/command. See @@ -4898,12 +5061,11 @@ const char *p, *next; const unsigned int minObjs = 20; Tcl_Obj **objv, **objvSpace; int *expand, *lines, *lineSpace; Tcl_Token *tokenPtr; - int bytesLeft, expandRequested, code = TCL_OK; - size_t commandLength; + int commandLength, bytesLeft, expandRequested, code = TCL_OK; CallFrame *savedVarFramePtr;/* Saves old copy of iPtr->varFramePtr in case * TCL_EVAL_GLOBAL was set. */ int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); int gotParse = 0; unsigned int i, objectsUsed = 0; @@ -4933,11 +5095,11 @@ } else { clNext = &iPtr->scriptCLLocPtr->loc[0]; } } - if (numBytes == TCL_AUTO_LENGTH) { + if (numBytes < 0) { numBytes = strlen(script); } Tcl_ResetResult(interp); savedVarFramePtr = iPtr->varFramePtr; @@ -5050,13 +5212,13 @@ /* * Generate an array of objects for the words of the command. */ if (numWords > minObjs) { - expand = Tcl_Alloc(numWords * sizeof(int)); - objvSpace = Tcl_Alloc(numWords * sizeof(Tcl_Obj *)); - lineSpace = Tcl_Alloc(numWords * sizeof(int)); + expand = ckalloc(numWords * sizeof(int)); + objvSpace = ckalloc(numWords * sizeof(Tcl_Obj *)); + lineSpace = ckalloc(numWords * sizeof(int)); } expandRequested = 0; objv = objvSpace; lines = lineSpace; @@ -5138,12 +5300,12 @@ int wordIdx = numWords; int objIdx = objectsNeeded - 1; if ((numWords > minObjs) || (objectsNeeded > minObjs)) { objv = objvSpace = - Tcl_Alloc(objectsNeeded * sizeof(Tcl_Obj *)); - lines = lineSpace = Tcl_Alloc(objectsNeeded * sizeof(int)); + ckalloc(objectsNeeded * sizeof(Tcl_Obj *)); + lines = lineSpace = ckalloc(objectsNeeded * sizeof(int)); } objectsUsed = 0; while (wordIdx--) { if (expand[wordIdx]) { @@ -5166,14 +5328,14 @@ } } objv += objIdx+1; if (copy != stackObjArray) { - Tcl_Free(copy); + ckfree(copy); } if (lcopy != linesStack) { - Tcl_Free(lcopy); + ckfree(lcopy); } } /* * Execute the command and free the objects for its words. @@ -5214,23 +5376,23 @@ for (i = 0; i < objectsUsed; i++) { Tcl_DecrRefCount(objv[i]); } objectsUsed = 0; if (objvSpace != stackObjArray) { - Tcl_Free(objvSpace); + ckfree(objvSpace); objvSpace = stackObjArray; - Tcl_Free(lineSpace); + ckfree(lineSpace); lineSpace = linesStack; } /* * Free expand separately since objvSpace could have been * reallocated above. */ if (expand != expandStack) { - Tcl_Free(expand); + ckfree(expand); expand = expandStack; } } /* @@ -5292,15 +5454,15 @@ } if (gotParse) { Tcl_FreeParse(parsePtr); } if (objvSpace != stackObjArray) { - Tcl_Free(objvSpace); - Tcl_Free(lineSpace); + ckfree(objvSpace); + ckfree(lineSpace); } if (expand != expandStack) { - Tcl_Free(expand); + ckfree(expand); } iPtr->varFramePtr = savedVarFramePtr; cleanup_return: /* @@ -5342,11 +5504,11 @@ TclAdvanceLines( int *line, const char *start, const char *end) { - register const char *p; + const char *p; for (p = start; p < end; p++) { if (*p == '\n') { (*line)++; } @@ -5460,11 +5622,11 @@ /* * The word is not on the stack yet, remember the current location * and initialize references. */ - cfwPtr = Tcl_Alloc(sizeof(CFWord)); + cfwPtr = ckalloc(sizeof(CFWord)); cfwPtr->framePtr = cfPtr; cfwPtr->word = i; cfwPtr->refCount = 1; Tcl_SetHashValue(hPtr, cfwPtr); } else { @@ -5516,15 +5678,16 @@ if (!hPtr) { continue; } cfwPtr = Tcl_GetHashValue(hPtr); - if (cfwPtr->refCount-- > 1) { + cfwPtr->refCount--; + if (cfwPtr->refCount > 0) { continue; } - Tcl_Free(cfwPtr); + ckfree(cfwPtr); Tcl_DeleteHashEntry(hPtr); } } /* @@ -5553,11 +5716,11 @@ Tcl_Obj *objv[], int objc, void *codePtr, CmdFrame *cfPtr, int cmd, - size_t pc) + int pc) { ExtCmdLoc *eclPtr; int word; ECL *ePtr; CFWordBC *lastPtr = NULL; @@ -5602,11 +5765,11 @@ for (word = 1; word < objc; word++) { if (ePtr->line[word] >= 0) { int isnew; Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(iPtr->lineLABCPtr, objv[word], &isnew); - CFWordBC *cfwPtr = Tcl_Alloc(sizeof(CFWordBC)); + CFWordBC *cfwPtr = ckalloc(sizeof(CFWordBC)); cfwPtr->framePtr = cfPtr; cfwPtr->obj = objv[word]; cfwPtr->pc = pc; cfwPtr->word = word; @@ -5680,11 +5843,11 @@ Tcl_SetHashValue(hPtr, cfwPtr->prevPtr); } else { Tcl_DeleteHashEntry(hPtr); } - Tcl_Free(cfwPtr); + ckfree(cfwPtr); cfwPtr = nextPtr; } cfPtr->litarg = NULL; } @@ -5723,11 +5886,11 @@ * guaranteed to have been generated dynamically: bail out, this cannot * have a usable absolute location. _Do not touch_ the information the set * up by the caller. It knows better than us. */ - if (!TclHasStringRep(obj) || TclListObjIsCanonical(obj)) { + if ((obj->bytes == NULL) || TclListObjIsCanonical(obj)) { return; } /* * First look for location information recorded in the argument @@ -5762,10 +5925,85 @@ } /* *---------------------------------------------------------------------- * + * Tcl_Eval -- + * + * Execute a Tcl command in a string. This function executes the script + * directly, rather than compiling it to bytecodes. Before the arrival of + * the bytecode compiler in Tcl 8.0 Tcl_Eval was the main function used + * for executing Tcl commands, but nowadays it isn't used much. + * + * Results: + * The return value is one of the return codes defined in tcl.h (such as + * TCL_OK), and interp's result contains a value to supplement the return + * code. The value of the result will persist only until the next call to + * Tcl_Eval or Tcl_EvalObj: you must copy it or lose it! + * + * Side effects: + * Can be almost arbitrary, depending on the commands in the script. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_Eval +int +Tcl_Eval( + Tcl_Interp *interp, /* Token for command interpreter (returned by + * previous call to Tcl_CreateInterp). */ + const char *script) /* Pointer to TCL command to execute. */ +{ + int code = Tcl_EvalEx(interp, script, -1, 0); + + /* + * For backwards compatibility with old C code that predates the object + * system in Tcl 8.0, we have to mirror the object result back into the + * string result (some callers may expect it there). + */ + + (void) Tcl_GetStringResult(interp); + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_EvalObj, Tcl_GlobalEvalObj -- + * + * These functions are deprecated but we keep them around for backwards + * compatibility reasons. + * + * Results: + * See the functions they call. + * + * Side effects: + * See the functions they call. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_EvalObj +int +Tcl_EvalObj( + Tcl_Interp *interp, + Tcl_Obj *objPtr) +{ + return Tcl_EvalObjEx(interp, objPtr, 0); +} +#undef Tcl_GlobalEvalObj +int +Tcl_GlobalEvalObj( + Tcl_Interp *interp, + Tcl_Obj *objPtr) +{ + return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_EvalObjEx, TclEvalObjEx -- * * Execute Tcl commands stored in a Tcl object. These commands are * compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT is * specified. @@ -5791,11 +6029,11 @@ int Tcl_EvalObjEx( Tcl_Interp *interp, /* Token for command interpreter (returned by * a previous call to Tcl_CreateInterp). */ - register Tcl_Obj *objPtr, /* Pointer to object containing commands to + Tcl_Obj *objPtr, /* Pointer to object containing commands to * execute. */ int flags) /* Collection of OR-ed bits that control the * evaluation of the script. Supported values * are TCL_EVAL_GLOBAL and TCL_EVAL_DIRECT. */ { @@ -5804,11 +6042,11 @@ int TclEvalObjEx( Tcl_Interp *interp, /* Token for command interpreter (returned by * a previous call to Tcl_CreateInterp). */ - register Tcl_Obj *objPtr, /* Pointer to object containing commands to + Tcl_Obj *objPtr, /* Pointer to object containing commands to * execute. */ int flags, /* Collection of OR-ed bits that control the * evaluation of the script. Supported values * are TCL_EVAL_GLOBAL and TCL_EVAL_DIRECT. */ const CmdFrame *invoker, /* Frame of the command doing the eval. */ @@ -5823,11 +6061,11 @@ int TclNREvalObjEx( Tcl_Interp *interp, /* Token for command interpreter (returned by * a previous call to Tcl_CreateInterp). */ - register Tcl_Obj *objPtr, /* Pointer to object containing commands to + Tcl_Obj *objPtr, /* Pointer to object containing commands to * execute. */ int flags, /* Collection of OR-ed bits that control the * evaluation of the script. Supported values * are TCL_EVAL_GLOBAL and TCL_EVAL_DIRECT. */ const CmdFrame *invoker, /* Frame of the command doing the eval. */ @@ -5911,11 +6149,11 @@ TclMarkTailcall(interp); TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr, objPtr, NULL); - TclListObjGetElements(NULL, listPtr, &objc, &objv); + ListObjGetElements(listPtr, objc, objv); return TclNREvalObjv(interp, objc, objv, flags, NULL); } if (!(flags & TCL_EVAL_DIRECT)) { /* @@ -5952,11 +6190,11 @@ * interpreter. Let Tcl_EvalEx evaluate the command directly (and * probably more slowly). */ const char *script; - size_t numSrcBytes; + int numSrcBytes; /* * Now we check if we have data about invisible continuation lines for * the script, and make it available to the direct script parser and * evaluator we are about to call, if so. @@ -5979,11 +6217,11 @@ iPtr->scriptCLLocPtr = TclContinuationsGet(objPtr); Tcl_IncrRefCount(objPtr); - script = TclGetStringFromObj(objPtr, &numSrcBytes); + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); result = Tcl_EvalEx(interp, script, numSrcBytes, flags); TclDecrRefCount(objPtr); iPtr->scriptCLLocPtr = saveCLLocPtr; @@ -6006,15 +6244,15 @@ if (result == TCL_RETURN) { result = TclUpdateReturnInfo(iPtr); } if ((result != TCL_OK) && (result != TCL_ERROR) && !allowExceptions) { const char *script; - size_t numSrcBytes; + int numSrcBytes; ProcessUnexpectedResult(interp, result); result = TCL_ERROR; - script = TclGetStringFromObj(objPtr, &numSrcBytes); + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); Tcl_LogCommandInfo(interp, script, script, numSrcBytes); } /* * We are returning to level 0, so should call TclResetCancellation. @@ -6131,11 +6369,11 @@ Tcl_Interp *interp, /* Context in which to evaluate the * expression. */ const char *exprstring, /* Expression to evaluate. */ long *ptr) /* Where to store result. */ { - register Tcl_Obj *exprPtr; + Tcl_Obj *exprPtr; int result = TCL_OK; if (*exprstring == '\0') { /* * Legacy compatibility - return 0 for the zero-length string. */ @@ -6144,10 +6382,13 @@ } else { exprPtr = Tcl_NewStringObj(exprstring, -1); Tcl_IncrRefCount(exprPtr); result = Tcl_ExprLongObj(interp, exprPtr, ptr); Tcl_DecrRefCount(exprPtr); + if (result != TCL_OK) { + (void) Tcl_GetStringResult(interp); + } } return result; } int @@ -6155,11 +6396,11 @@ Tcl_Interp *interp, /* Context in which to evaluate the * expression. */ const char *exprstring, /* Expression to evaluate. */ double *ptr) /* Where to store result. */ { - register Tcl_Obj *exprPtr; + Tcl_Obj *exprPtr; int result = TCL_OK; if (*exprstring == '\0') { /* * Legacy compatibility - return 0 for the zero-length string. @@ -6170,10 +6411,13 @@ exprPtr = Tcl_NewStringObj(exprstring, -1); Tcl_IncrRefCount(exprPtr); result = Tcl_ExprDoubleObj(interp, exprPtr, ptr); Tcl_DecrRefCount(exprPtr); /* Discard the expression object. */ + if (result != TCL_OK) { + (void) Tcl_GetStringResult(interp); + } } return result; } int @@ -6195,10 +6439,18 @@ Tcl_Obj *exprPtr = Tcl_NewStringObj(exprstring, -1); Tcl_IncrRefCount(exprPtr); result = Tcl_ExprBooleanObj(interp, exprPtr, ptr); Tcl_DecrRefCount(exprPtr); + if (result != TCL_OK) { + /* + * Move the interpreter's object result to the string result, then + * reset the object result. + */ + + (void) Tcl_GetStringResult(interp); + } return result; } } /* @@ -6224,11 +6476,11 @@ int Tcl_ExprLongObj( Tcl_Interp *interp, /* Context in which to evaluate the * expression. */ - register Tcl_Obj *objPtr, /* Expression to evaluate. */ + Tcl_Obj *objPtr, /* Expression to evaluate. */ long *ptr) /* Where to store long result. */ { Tcl_Obj *resultPtr; int result, type; double d; @@ -6251,13 +6503,14 @@ Tcl_DecrRefCount(resultPtr); if (Tcl_InitBignumFromDouble(interp, d, &big) != TCL_OK) { return TCL_ERROR; } resultPtr = Tcl_NewBignumObj(&big); - /* FALLTHROUGH */ } - case TCL_NUMBER_INT: + /* FALLTHRU */ + case TCL_NUMBER_LONG: + case TCL_NUMBER_WIDE: case TCL_NUMBER_BIG: result = TclGetLongFromObj(interp, resultPtr, ptr); break; case TCL_NUMBER_NAN: @@ -6271,11 +6524,11 @@ int Tcl_ExprDoubleObj( Tcl_Interp *interp, /* Context in which to evaluate the * expression. */ - register Tcl_Obj *objPtr, /* Expression to evaluate. */ + Tcl_Obj *objPtr, /* Expression to evaluate. */ double *ptr) /* Where to store double result. */ { Tcl_Obj *resultPtr; int result, type; ClientData internalPtr; @@ -6307,11 +6560,11 @@ int Tcl_ExprBooleanObj( Tcl_Interp *interp, /* Context in which to evaluate the * expression. */ - register Tcl_Obj *objPtr, /* Expression to evaluate. */ + Tcl_Obj *objPtr, /* Expression to evaluate. */ int *ptr) /* Where to store 0/1 result. */ { Tcl_Obj *resultPtr; int result; @@ -6419,11 +6672,11 @@ ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - register Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *) interp; Tcl_HashTable *hTblPtr; /* Table of hidden commands. */ const char *cmdName; /* Name of the command from objv[0]. */ Tcl_HashEntry *hPtr = NULL; Command *cmdPtr; @@ -6499,11 +6752,11 @@ if (expr[0] == '\0') { /* * An empty string. Just set the interpreter's result to 0. */ - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); } else { Tcl_Obj *resultPtr, *exprObj = Tcl_NewStringObj(expr, -1); Tcl_IncrRefCount(exprObj); code = Tcl_ExprObj(interp, exprObj, &resultPtr); @@ -6511,10 +6764,16 @@ if (code == TCL_OK) { Tcl_SetObjResult(interp, resultPtr); Tcl_DecrRefCount(resultPtr); } } + + /* + * Force the string rep of the interp result. + */ + + (void) Tcl_GetStringResult(interp); return code; } /* *---------------------------------------------------------------------- @@ -6533,30 +6792,106 @@ * message in the interpreter's result. * *---------------------------------------------------------------------- */ +#undef Tcl_AddObjErrorInfo void Tcl_AppendObjToErrorInfo( Tcl_Interp *interp, /* Interpreter to which error information * pertains. */ Tcl_Obj *objPtr) /* Message to record. */ { - size_t length; + int length; const char *message = TclGetStringFromObj(objPtr, &length); - register Interp *iPtr = (Interp *) interp; Tcl_IncrRefCount(objPtr); + Tcl_AddObjErrorInfo(interp, message, length); + Tcl_DecrRefCount(objPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AddErrorInfo -- + * + * Add information to the errorInfo field that describes the current + * error. + * + * Results: + * None. + * + * Side effects: + * The contents of message are appended to the errorInfo field. If we are + * just starting to log an error, errorInfo is initialized from the error + * message in the interpreter's result. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_AddErrorInfo +void +Tcl_AddErrorInfo( + Tcl_Interp *interp, /* Interpreter to which error information + * pertains. */ + const char *message) /* Message to record. */ +{ + Tcl_AddObjErrorInfo(interp, message, -1); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AddObjErrorInfo -- + * + * Add information to the errorInfo field that describes the current + * error. This routine differs from Tcl_AddErrorInfo by taking a byte + * pointer and length. + * + * Results: + * None. + * + * Side effects: + * "length" bytes from "message" are appended to the errorInfo field. If + * "length" is negative, use bytes up to the first NULL byte. If we are + * just starting to log an error, errorInfo is initialized from the error + * message in the interpreter's result. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AddObjErrorInfo( + Tcl_Interp *interp, /* Interpreter to which error information + * pertains. */ + const char *message, /* Points to the first byte of an array of + * bytes of the message. */ + int length) /* The number of bytes in the message. If < 0, + * then append all bytes up to a NULL byte. */ +{ + Interp *iPtr = (Interp *) interp; /* * If we are just starting to log an error, errorInfo is initialized from * the error message in the interpreter's result. */ iPtr->flags |= ERR_LEGACY_COPY; if (iPtr->errorInfo == NULL) { - iPtr->errorInfo = iPtr->objResultPtr; + if (iPtr->result[0] != 0) { + /* + * The interp's string result is set, apparently by some extension + * making a deprecated direct write to it. That extension may + * expect interp->result to continue to be set, so we'll take + * special pains to avoid clearing it, until we drop support for + * interp->result completely. + */ + + iPtr->errorInfo = Tcl_NewStringObj(iPtr->result, -1); + } else { + iPtr->errorInfo = iPtr->objResultPtr; + } Tcl_IncrRefCount(iPtr->errorInfo); if (!iPtr->errorCode) { Tcl_SetErrorCode(interp, "NONE", NULL); } } @@ -6571,11 +6906,57 @@ iPtr->errorInfo = Tcl_DuplicateObj(iPtr->errorInfo); Tcl_IncrRefCount(iPtr->errorInfo); } Tcl_AppendToObj(iPtr->errorInfo, message, length); } - Tcl_DecrRefCount(objPtr); +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_VarEvalVA -- + * + * Given a variable number of string arguments, concatenate them all + * together and execute the result as a Tcl command. + * + * Results: + * A standard Tcl return result. An error message or other result may be + * left in the interp's result. + * + * Side effects: + * Depends on what was done by the command. + * + *--------------------------------------------------------------------------- + */ + +int +Tcl_VarEvalVA( + Tcl_Interp *interp, /* Interpreter in which to evaluate command */ + va_list argList) /* Variable argument list. */ +{ + Tcl_DString buf; + char *string; + int result; + + /* + * Copy the strings one after the other into a single larger string. Use + * stack-allocated space for small commands, but if the command gets too + * large than call ckalloc to create the space. + */ + + Tcl_DStringInit(&buf); + while (1) { + string = va_arg(argList, char *); + if (string == NULL) { + break; + } + Tcl_DStringAppend(&buf, string, -1); + } + + result = Tcl_Eval(interp, Tcl_DStringValue(&buf)); + Tcl_DStringFree(&buf); + return result; } /* *---------------------------------------------------------------------- * @@ -6584,11 +6965,11 @@ * Given a variable number of string arguments, concatenate them all * together and execute the result as a Tcl command. * * Results: * A standard Tcl return result. An error message or other result may be - * left in the interp. + * left in interp->result. * * Side effects: * Depends on what was done by the command. * *---------------------------------------------------------------------- @@ -6599,31 +6980,52 @@ Tcl_Interp *interp, ...) { va_list argList; int result; - Tcl_DString buf; - char *string; va_start(argList, interp); - /* - * Copy the strings one after the other into a single larger string. Use - * stack-allocated space for small commands, but if the command gets too - * large than call Tcl_Alloc to create the space. - */ - - Tcl_DStringInit(&buf); - while (1) { - string = va_arg(argList, char *); - if (string == NULL) { - break; - } - Tcl_DStringAppend(&buf, string, -1); - } - - result = Tcl_EvalEx(interp, Tcl_DStringValue(&buf), -1, 0); - Tcl_DStringFree(&buf); + result = Tcl_VarEvalVA(interp, argList); + va_end(argList); + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GlobalEval -- + * + * Evaluate a command at global level in an interpreter. + * + * Results: + * A standard Tcl result is returned, and the interp's result is modified + * accordingly. + * + * Side effects: + * The command string is executed in interp, and the execution is carried + * out in the variable context of global level (no functions active), + * just as if an "uplevel #0" command were being executed. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_GlobalEval +int +Tcl_GlobalEval( + Tcl_Interp *interp, /* Interpreter in which to evaluate + * command. */ + const char *command) /* Command to evaluate. */ +{ + Interp *iPtr = (Interp *) interp; + int result; + CallFrame *savedVarFramePtr; + + savedVarFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = iPtr->rootFramePtr; + result = Tcl_Eval(interp, command); + iPtr->varFramePtr = savedVarFramePtr; return result; } /* *---------------------------------------------------------------------- @@ -6759,17 +7161,13 @@ MathFuncWrongNumArgs(interp, 2, objc, objv); return TCL_ERROR; } code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN - if (code != TCL_OK) { - const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objv[1], &tclDoubleType); - - if (irPtr) { - Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; - } + if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; } #endif if (code != TCL_OK) { return TCL_ERROR; } @@ -6799,17 +7197,13 @@ MathFuncWrongNumArgs(interp, 2, objc, objv); return TCL_ERROR; } code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN - if (code != TCL_OK) { - const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objv[1], &tclDoubleType); - - if (irPtr) { - Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; - } + if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; } #endif if (code != TCL_OK) { return TCL_ERROR; } @@ -6877,11 +7271,11 @@ break; case TCL_NUMBER_BIG: if (Tcl_GetBignumFromObj(interp, objv[1], &big) != TCL_OK) { return TCL_ERROR; } - if (big.sign != MP_ZPOS) { + if (big.sign) { mp_clear(&big); goto negarg; } break; default: @@ -6939,17 +7333,13 @@ MathFuncWrongNumArgs(interp, 2, objc, objv); return TCL_ERROR; } code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN - if (code != TCL_OK) { - const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objv[1], &tclDoubleType); - - if (irPtr) { - Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; - } + if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; } #endif if (code != TCL_OK) { return TCL_ERROR; } @@ -6986,18 +7376,14 @@ MathFuncWrongNumArgs(interp, 2, objc, objv); return TCL_ERROR; } code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN - if (code != TCL_OK) { - const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objv[1], &tclDoubleType); - - if (irPtr) { - d = irPtr->doubleValue; - Tcl_ResetResult(interp); - code = TCL_OK; - } + if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { + d = objv[1]->internalRep.doubleValue; + Tcl_ResetResult(interp); + code = TCL_OK; } #endif if (code != TCL_OK) { return TCL_ERROR; } @@ -7050,33 +7436,25 @@ MathFuncWrongNumArgs(interp, 3, objc, objv); return TCL_ERROR; } code = Tcl_GetDoubleFromObj(interp, objv[1], &d1); #ifdef ACCEPT_NAN - if (code != TCL_OK) { - const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objv[1], &tclDoubleType); - - if (irPtr) { - d1 = irPtr->doubleValue; - Tcl_ResetResult(interp); - code = TCL_OK; - } + if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { + d1 = objv[1]->internalRep.doubleValue; + Tcl_ResetResult(interp); + code = TCL_OK; } #endif if (code != TCL_OK) { return TCL_ERROR; } code = Tcl_GetDoubleFromObj(interp, objv[2], &d2); #ifdef ACCEPT_NAN - if (code != TCL_OK) { - const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objv[1], &tclDoubleType); - - if (irPtr) { - d2 = irPtr->doubleValue; - Tcl_ResetResult(interp); - code = TCL_OK; - } + if ((code != TCL_OK) && (objv[2]->typePtr == &tclDoubleType)) { + d2 = objv[2]->internalRep.doubleValue; + Tcl_ResetResult(interp); + code = TCL_OK; } #endif if (code != TCL_OK) { return TCL_ERROR; } @@ -7103,34 +7481,32 @@ if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { return TCL_ERROR; } - if (type == TCL_NUMBER_INT) { - Tcl_WideInt l = *((const Tcl_WideInt *) ptr); - - if (l > 0) { - goto unChanged; - } else if (l == 0) { - if (TclHasStringRep(objv[1])) { - size_t numBytes; - const char *bytes = TclGetStringFromObj(objv[1], &numBytes); - - while (numBytes) { - if (*bytes == '-') { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0)); - return TCL_OK; - } - bytes++; numBytes--; - } - } - goto unChanged; - } else if (l == WIDE_MIN) { - TclInitBignumFromWideInt(&big, l); - goto tooLarge; - } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-l)); + if (type == TCL_NUMBER_LONG) { + long l = *((const long *) ptr); + + if (l > (long)0) { + goto unChanged; + } else if (l == (long)0) { + const char *string = objv[1]->bytes; + if (string) { + while (*string != '0') { + if (*string == '-') { + Tcl_SetObjResult(interp, Tcl_NewLongObj(0)); + return TCL_OK; + } + string++; + } + } + goto unChanged; + } else if (l == LONG_MIN) { + TclBNInitBignumFromLong(&big, l); + goto tooLarge; + } + Tcl_SetObjResult(interp, Tcl_NewLongObj(-l)); return TCL_OK; } if (type == TCL_NUMBER_DOUBLE) { double d = *((const double *) ptr); @@ -7149,16 +7525,32 @@ goto unChanged; } Tcl_SetObjResult(interp, Tcl_NewDoubleObj(-d)); return TCL_OK; } + +#ifndef TCL_WIDE_INT_IS_LONG + if (type == TCL_NUMBER_WIDE) { + Tcl_WideInt w = *((const Tcl_WideInt *) ptr); + + if (w >= (Tcl_WideInt)0) { + goto unChanged; + } + if (w == LLONG_MIN) { + TclBNInitBignumFromWideInt(&big, w); + goto tooLarge; + } + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-w)); + return TCL_OK; + } +#endif if (type == TCL_NUMBER_BIG) { - if (((const mp_int *) ptr)->sign != MP_ZPOS) { + if (mp_cmp_d((const mp_int *) ptr, 0) == MP_LT) { Tcl_GetBignumFromObj(NULL, objv[1], &big); tooLarge: - mp_neg(&big, &big); + (void)mp_neg(&big, &big); Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); } else { unChanged: Tcl_SetObjResult(interp, objv[1]); } @@ -7214,11 +7606,11 @@ MathFuncWrongNumArgs(interp, 2, objc, objv); return TCL_ERROR; } if (Tcl_GetDoubleFromObj(interp, objv[1], &dResult) != TCL_OK) { #ifdef ACCEPT_NAN - if (TclHasIntRep(objv[1], &tclDoubleType)) { + if (objv[1]->typePtr == &tclDoubleType) { Tcl_SetObjResult(interp, objv[1]); return TCL_OK; } #endif return TCL_ERROR; @@ -7226,11 +7618,11 @@ Tcl_SetObjResult(interp, Tcl_NewDoubleObj(dResult)); return TCL_OK; } static int -ExprIntFunc( +ExprEntierFunc( ClientData clientData, /* Ignored. */ Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ Tcl_Obj *const *objv) /* Actual parameter vector. */ @@ -7247,24 +7639,31 @@ return TCL_ERROR; } if (type == TCL_NUMBER_DOUBLE) { d = *((const double *) ptr); - if ((d >= (double)WIDE_MAX) || (d <= (double)WIDE_MIN)) { + if ((d < (double)LONG_MAX) && (d > (double)LONG_MIN)) { + long result = (long) d; + + Tcl_SetObjResult(interp, Tcl_NewLongObj(result)); + return TCL_OK; +#ifndef TCL_WIDE_INT_IS_LONG + } else if ((d < (double)LLONG_MAX) && (d > (double)LLONG_MIN)) { + Tcl_WideInt result = (Tcl_WideInt) d; + + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result)); + return TCL_OK; +#endif + } else { mp_int big; if (Tcl_InitBignumFromDouble(interp, d, &big) != TCL_OK) { /* Infinity */ return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); return TCL_OK; - } else { - Tcl_WideInt result = (Tcl_WideInt) d; - - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result)); - return TCL_OK; } } if (type != TCL_NUMBER_NAN) { /* @@ -7280,10 +7679,42 @@ */ Tcl_GetDoubleFromObj(interp, objv[1], &d); return TCL_ERROR; } + +static int +ExprIntFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter vector. */ +{ + long iResult; + Tcl_Obj *objPtr; + if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) { + return TCL_ERROR; + } + objPtr = Tcl_GetObjResult(interp); + if (TclGetLongFromObj(NULL, objPtr, &iResult) != TCL_OK) { + /* + * Truncate the bignum; keep only bits in long range. + */ + + mp_int big; + + Tcl_GetBignumFromObj(NULL, objPtr, &big); + mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big); + objPtr = Tcl_NewBignumObj(&big); + Tcl_IncrRefCount(objPtr); + TclGetLongFromObj(NULL, objPtr, &iResult); + Tcl_DecrRefCount(objPtr); + } + Tcl_SetObjResult(interp, Tcl_NewLongObj(iResult)); + return TCL_OK; +} static int ExprWideFunc( ClientData clientData, /* Ignored. */ Tcl_Interp *interp, /* The interpreter in which to execute the @@ -7290,84 +7721,34 @@ * function. */ int objc, /* Actual parameter count. */ Tcl_Obj *const *objv) /* Actual parameter vector. */ { Tcl_WideInt wResult; + Tcl_Obj *objPtr; - if (ExprIntFunc(NULL, interp, objc, objv) != TCL_OK) { + if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) { return TCL_ERROR; } - TclGetWideBitsFromObj(NULL, Tcl_GetObjResult(interp), &wResult); + objPtr = Tcl_GetObjResult(interp); + if (TclGetWideIntFromObj(NULL, objPtr, &wResult) != TCL_OK) { + /* + * Truncate the bignum; keep only bits in wide int range. + */ + + mp_int big; + + Tcl_GetBignumFromObj(NULL, objPtr, &big); + mp_mod_2d(&big, (int) CHAR_BIT * sizeof(Tcl_WideInt), &big); + objPtr = Tcl_NewBignumObj(&big); + Tcl_IncrRefCount(objPtr); + TclGetWideIntFromObj(NULL, objPtr, &wResult); + Tcl_DecrRefCount(objPtr); + } Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wResult)); return TCL_OK; } -/* - * Common implmentation of max() and min(). - */ -static int -ExprMaxMinFunc( - ClientData clientData, /* Ignored. */ - Tcl_Interp *interp, /* The interpreter in which to execute the - * function. */ - int objc, /* Actual parameter count. */ - Tcl_Obj *const *objv, /* Actual parameter vector. */ - int op) /* Comparison direction */ -{ - Tcl_Obj *res; - double d; - int type, i; - ClientData ptr; - - if (objc < 2) { - MathFuncWrongNumArgs(interp, 2, objc, objv); - return TCL_ERROR; - } - res = objv[1]; - for (i = 1; i < objc; i++) { - if (TclGetNumberFromObj(interp, objv[i], &ptr, &type) != TCL_OK) { - return TCL_ERROR; - } - if (type == TCL_NUMBER_NAN) { - /* - * Get the error message for NaN. - */ - - Tcl_GetDoubleFromObj(interp, objv[i], &d); - return TCL_ERROR; - } - if (TclCompareTwoNumbers(objv[i], res) == op) { - res = objv[i]; - } - } - - Tcl_SetObjResult(interp, res); - return TCL_OK; -} - -static int -ExprMaxFunc( - ClientData clientData, /* Ignored. */ - Tcl_Interp *interp, /* The interpreter in which to execute the - * function. */ - int objc, /* Actual parameter count. */ - Tcl_Obj *const *objv) /* Actual parameter vector. */ -{ - return ExprMaxMinFunc(clientData, interp, objc, objv, MP_GT); -} - -static int -ExprMinFunc( - ClientData clientData, /* Ignored. */ - Tcl_Interp *interp, /* The interpreter in which to execute the - * function. */ - int objc, /* Actual parameter count. */ - Tcl_Obj *const *objv) /* Actual parameter vector. */ -{ - return ExprMaxMinFunc(clientData, interp, objc, objv, MP_LT); -} - static int ExprRandFunc( ClientData clientData, /* Ignored. */ Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ @@ -7397,12 +7778,12 @@ /* * Make sure 1 <= randSeed <= (2^31) - 2. See below. */ - iPtr->randSeed &= 0x7fffffff; - if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) { + iPtr->randSeed &= (unsigned long) 0x7FFFFFFF; + if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7FFFFFFF)) { iPtr->randSeed ^= 123459876; } } /* @@ -7480,11 +7861,11 @@ return TCL_ERROR; } if (type == TCL_NUMBER_DOUBLE) { double fractPart, intPart; - Tcl_WideInt max = WIDE_MAX, min = WIDE_MIN; + long max = LONG_MAX, min = LONG_MIN; fractPart = modf(*((const double *) ptr), &intPart); if (fractPart <= -0.5) { min++; } else if (fractPart >= 0.5) { @@ -7503,18 +7884,18 @@ mp_add_d(&big, 1, &big); } Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); return TCL_OK; } else { - Tcl_WideInt result = (Tcl_WideInt)intPart; + long result = (long)intPart; if (fractPart <= -0.5) { result--; } else if (fractPart >= 0.5) { result++; } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(result)); return TCL_OK; } } if (type != TCL_NUMBER_NAN) { @@ -7541,11 +7922,11 @@ * function. */ int objc, /* Actual parameter count. */ Tcl_Obj *const *objv) /* Parameter vector. */ { Interp *iPtr = (Interp *) interp; - Tcl_WideInt w = 0; /* Initialized to avoid compiler warning. */ + long i = 0; /* Initialized to avoid compiler warning. */ /* * Convert argument and use it to reset the seed. */ @@ -7552,22 +7933,35 @@ if (objc != 2) { MathFuncWrongNumArgs(interp, 2, objc, objv); return TCL_ERROR; } - if (TclGetWideBitsFromObj(NULL, objv[1], &w) != TCL_OK) { - return TCL_ERROR; + if (TclGetLongFromObj(NULL, objv[1], &i) != TCL_OK) { + Tcl_Obj *objPtr; + mp_int big; + + if (Tcl_GetBignumFromObj(interp, objv[1], &big) != TCL_OK) { + /* TODO: more ::errorInfo here? or in caller? */ + return TCL_ERROR; + } + + mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big); + objPtr = Tcl_NewBignumObj(&big); + Tcl_IncrRefCount(objPtr); + TclGetLongFromObj(NULL, objPtr, &i); + Tcl_DecrRefCount(objPtr); } /* * Reset the seed. Make sure 1 <= randSeed <= 2^31 - 2. See comments in * ExprRandFunc for more details. */ iPtr->flags |= RAND_SEED_INITIALIZED; - iPtr->randSeed = (long) w & 0x7fffffff; - if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) { + iPtr->randSeed = i; + iPtr->randSeed &= (unsigned long) 0x7FFFFFFF; + if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7FFFFFFF)) { iPtr->randSeed ^= 123459876; } /* * To avoid duplicating the random number generation code we simply clean @@ -7575,398 +7969,10 @@ * will always succeed. */ return ExprRandFunc(clientData, interp, 1, objv); } - -/* - *---------------------------------------------------------------------- - * - * Double Classification Functions -- - * - * This page contains the functions that implement all of the built-in - * math functions for classifying IEEE doubles. - * - * These have to be a little bit careful while Tcl_GetDoubleFromObj() - * rejects NaN values, which these functions *explicitly* accept. - * - * Results: - * Each function returns TCL_OK if it succeeds and pushes an Tcl object - * holding the result. If it fails it returns TCL_ERROR and leaves an - * error message in the interpreter's result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - * - * Older MSVC is supported by Tcl, but doesn't have fpclassify(). Of course. - * But it does sometimes have _fpclass() which does almost the same job; if - * even that is absent, we grobble around directly in the platform's binary - * representation of double. - * - * The ClassifyDouble() function makes all that conform to a common API - * (effectively the C99 standard API renamed), and just delegates to the - * standard macro on platforms that do it correctly. - */ - -static inline int -ClassifyDouble( - double d) -{ -#if TCL_FPCLASSIFY_MODE == 0 - return fpclassify(d); -#else /* !fpclassify */ - /* - * If we don't have fpclassify(), we also don't have the values it returns. - * Hence we define those here. - */ -# ifndef FP_NAN -# define FP_NAN 1 /* Value is NaN */ -# define FP_INFINITE 2 /* Value is an infinity */ -# define FP_ZERO 3 /* Value is a zero */ -# define FP_NORMAL 4 /* Value is a normal float */ -# define FP_SUBNORMAL 5 /* Value has lost accuracy */ -#endif - -# if TCL_FPCLASSIFY_MODE == 3 - return __builtin_fpclassify(FP_NAN, FP_INFINITE, FP_NORMAL, FP_SUBNORMAL, FP_ZERO, d); -# elif TCL_FPCLASSIFY_MODE == 2 - /* - * We assume this hack is only needed on little-endian systems. - * Specifically, x86 running Windows. It's fairly easy to enable for - * others if they need it (because their libc/libm is broken) but we'll - * jump that hurdle when requred. We can solve the word ordering then. - */ - - union { - double d; /* Interpret as double */ - struct { - unsigned int low; /* Lower 32 bits */ - unsigned int high; /* Upper 32 bits */ - } w; /* Interpret as unsigned integer words */ - } doubleMeaning; /* So we can look at the representation of a - * double directly. Platform (i.e., processor) - * specific; this is for x86 (and most other - * little-endian processors, but those are - * untested). */ - unsigned int exponent, mantissaLow, mantissaHigh; - /* The pieces extracted from the double. */ - int zeroMantissa; /* Was the mantissa zero? That's special. */ - - /* - * Shifts and masks to use with the doubleMeaning variable above. - */ - -# define EXPONENT_MASK 0x7ff /* 11 bits (after shifting) */ -# define EXPONENT_SHIFT 20 /* Moves exponent to bottom of word */ -# define MANTISSA_MASK 0xfffff /* 20 bits (plus 32 from other word) */ - - /* - * Extract the exponent (11 bits) and mantissa (52 bits). Note that we - * totally ignore the sign bit. - */ - - doubleMeaning.d = d; - exponent = (doubleMeaning.w.high >> EXPONENT_SHIFT) & EXPONENT_MASK; - mantissaLow = doubleMeaning.w.low; - mantissaHigh = doubleMeaning.w.high & MANTISSA_MASK; - zeroMantissa = (mantissaHigh == 0 && mantissaLow == 0); - - /* - * Look for the special cases of exponent. - */ - - switch (exponent) { - case 0: - /* - * When the exponent is all zeros, it's a ZERO or a SUBNORMAL. - */ - - return zeroMantissa ? FP_ZERO : FP_SUBNORMAL; - case EXPONENT_MASK: - /* - * When the exponent is all ones, it's an INF or a NAN. - */ - - return zeroMantissa ? FP_INFINITE : FP_NAN; - default: - /* - * Everything else is a NORMAL double precision float. - */ - - return FP_NORMAL; - } -# elif TCL_FPCLASSIFY_MODE == 1 - switch (_fpclass(d)) { - case _FPCLASS_NZ: - case _FPCLASS_PZ: - return FP_ZERO; - case _FPCLASS_NN: - case _FPCLASS_PN: - return FP_NORMAL; - case _FPCLASS_ND: - case _FPCLASS_PD: - return FP_SUBNORMAL; - case _FPCLASS_NINF: - case _FPCLASS_PINF: - return FP_INFINITE; - default: - Tcl_Panic("result of _fpclass() outside documented range!"); - case _FPCLASS_QNAN: - case _FPCLASS_SNAN: - return FP_NAN; - } -# else /* unknown TCL_FPCLASSIFY_MODE */ -# error "unknown or unexpected TCL_FPCLASSIFY_MODE" -# endif /* TCL_FPCLASSIFY_MODE */ -#endif /* !fpclassify */ -} - -static int -ExprIsFiniteFunc( - ClientData ignored, - Tcl_Interp *interp, /* The interpreter in which to execute the - * function. */ - int objc, /* Actual parameter count */ - Tcl_Obj *const *objv) /* Actual parameter list */ -{ - double d; - ClientData ptr; - int type, result = 0; - - if (objc != 2) { - MathFuncWrongNumArgs(interp, 2, objc, objv); - return TCL_ERROR; - } - - if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { - return TCL_ERROR; - } - if (type != TCL_NUMBER_NAN) { - if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) { - return TCL_ERROR; - } - type = ClassifyDouble(d); - result = (type != FP_INFINITE && type != FP_NAN); - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); - return TCL_OK; -} - -static int -ExprIsInfinityFunc( - ClientData ignored, - Tcl_Interp *interp, /* The interpreter in which to execute the - * function. */ - int objc, /* Actual parameter count */ - Tcl_Obj *const *objv) /* Actual parameter list */ -{ - double d; - ClientData ptr; - int type, result = 0; - - if (objc != 2) { - MathFuncWrongNumArgs(interp, 2, objc, objv); - return TCL_ERROR; - } - - if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { - return TCL_ERROR; - } - if (type != TCL_NUMBER_NAN) { - if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) { - return TCL_ERROR; - } - result = (ClassifyDouble(d) == FP_INFINITE); - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); - return TCL_OK; -} - -static int -ExprIsNaNFunc( - ClientData ignored, - Tcl_Interp *interp, /* The interpreter in which to execute the - * function. */ - int objc, /* Actual parameter count */ - Tcl_Obj *const *objv) /* Actual parameter list */ -{ - double d; - ClientData ptr; - int type, result = 1; - - if (objc != 2) { - MathFuncWrongNumArgs(interp, 2, objc, objv); - return TCL_ERROR; - } - - if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { - return TCL_ERROR; - } - if (type != TCL_NUMBER_NAN) { - if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) { - return TCL_ERROR; - } - result = (ClassifyDouble(d) == FP_NAN); - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); - return TCL_OK; -} - -static int -ExprIsNormalFunc( - ClientData ignored, - Tcl_Interp *interp, /* The interpreter in which to execute the - * function. */ - int objc, /* Actual parameter count */ - Tcl_Obj *const *objv) /* Actual parameter list */ -{ - double d; - ClientData ptr; - int type, result = 0; - - if (objc != 2) { - MathFuncWrongNumArgs(interp, 2, objc, objv); - return TCL_ERROR; - } - - if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { - return TCL_ERROR; - } - if (type != TCL_NUMBER_NAN) { - if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) { - return TCL_ERROR; - } - result = (ClassifyDouble(d) == FP_NORMAL); - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); - return TCL_OK; -} - -static int -ExprIsSubnormalFunc( - ClientData ignored, - Tcl_Interp *interp, /* The interpreter in which to execute the - * function. */ - int objc, /* Actual parameter count */ - Tcl_Obj *const *objv) /* Actual parameter list */ -{ - double d; - ClientData ptr; - int type, result = 0; - - if (objc != 2) { - MathFuncWrongNumArgs(interp, 2, objc, objv); - return TCL_ERROR; - } - - if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { - return TCL_ERROR; - } - if (type != TCL_NUMBER_NAN) { - if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) { - return TCL_ERROR; - } - result = (ClassifyDouble(d) == FP_SUBNORMAL); - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); - return TCL_OK; -} - -static int -ExprIsUnorderedFunc( - ClientData ignored, - Tcl_Interp *interp, /* The interpreter in which to execute the - * function. */ - int objc, /* Actual parameter count */ - Tcl_Obj *const *objv) /* Actual parameter list */ -{ - double d; - ClientData ptr; - int type, result = 0; - - if (objc != 3) { - MathFuncWrongNumArgs(interp, 3, objc, objv); - return TCL_ERROR; - } - - if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { - return TCL_ERROR; - } - if (type == TCL_NUMBER_NAN) { - result = 1; - } else { - d = *((const double *) ptr); - result = (ClassifyDouble(d) == FP_NAN); - } - - if (TclGetNumberFromObj(interp, objv[2], &ptr, &type) != TCL_OK) { - return TCL_ERROR; - } - if (type == TCL_NUMBER_NAN) { - result |= 1; - } else { - d = *((const double *) ptr); - result |= (ClassifyDouble(d) == FP_NAN); - } - - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); - return TCL_OK; -} - -static int -FloatClassifyObjCmd( - ClientData ignored, - Tcl_Interp *interp, /* The interpreter in which to execute the - * function. */ - int objc, /* Actual parameter count */ - Tcl_Obj *const *objv) /* Actual parameter list */ -{ - double d; - Tcl_Obj *objPtr; - ClientData ptr; - int type; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "floatValue"); - return TCL_ERROR; - } - - if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { - return TCL_ERROR; - } - if (type == TCL_NUMBER_NAN) { - goto gotNaN; - } else if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) { - return TCL_ERROR; - } - switch (ClassifyDouble(d)) { - case FP_INFINITE: - TclNewLiteralStringObj(objPtr, "infinite"); - break; - case FP_NAN: - gotNaN: - TclNewLiteralStringObj(objPtr, "nan"); - break; - case FP_NORMAL: - TclNewLiteralStringObj(objPtr, "normal"); - break; - case FP_SUBNORMAL: - TclNewLiteralStringObj(objPtr, "subnormal"); - break; - case FP_ZERO: - TclNewLiteralStringObj(objPtr, "zero"); - break; - default: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unable to classify number: %f", d)); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, objPtr); - return TCL_OK; -} /* *---------------------------------------------------------------------- * * MathFuncWrongNumArgs -- @@ -7988,11 +7994,11 @@ Tcl_Interp *interp, /* Tcl interpreter */ 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 *name = Tcl_GetString(objv[0]); const char *tail = name + strlen(name); while (tail > name+1) { tail--; if (*tail == ':' && tail[-1] == ':') { @@ -7999,12 +8005,12 @@ name = tail+1; break; } } Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "too %s arguments for math function \"%s\"", - (found < expected ? "few" : "many"), name)); + "%s arguments for math function \"%s\"", + (found < expected ? "not enough" : "too many"), name)); Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); } #ifdef USE_DTRACE /* @@ -8230,30 +8236,27 @@ Tcl_CmdDeleteProc *deleteProc) /* If not NULL, gives a function to call when * this command is deleted. */ { Command *cmdPtr = (Command *) - Tcl_CreateObjCommand(interp, cmdName, proc, clientData, - deleteProc); + Tcl_CreateObjCommand(interp,cmdName,proc,clientData,deleteProc); cmdPtr->nreProc = nreProc; return (Tcl_Command) cmdPtr; } Tcl_Command -TclNRCreateCommandInNs( +TclNRCreateCommandInNs ( Tcl_Interp *interp, const char *cmdName, Tcl_Namespace *nsPtr, Tcl_ObjCmdProc *proc, Tcl_ObjCmdProc *nreProc, ClientData clientData, - Tcl_CmdDeleteProc *deleteProc) -{ + Tcl_CmdDeleteProc *deleteProc) { Command *cmdPtr = (Command *) - TclCreateObjCommandInNs(interp, cmdName, nsPtr, proc, clientData, - deleteProc); + TclCreateObjCommandInNs(interp,cmdName,nsPtr,proc,clientData,deleteProc); cmdPtr->nreProc = nreProc; return (Tcl_Command) cmdPtr; } @@ -8353,10 +8356,11 @@ Tcl_Interp *interp) { TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL); ((Interp *) interp)->numLevels++; } + /* *---------------------------------------------------------------------- * * TclSetTailcall -- @@ -8388,10 +8392,11 @@ if (!runPtr) { Tcl_Panic("tailcall cannot find the right splicing spot: should not happen!"); } runPtr->data[1] = listPtr; } + /* *---------------------------------------------------------------------- * * TclNRTailcallObjCmd -- @@ -8459,10 +8464,11 @@ iPtr->varFramePtr->tailcallPtr = listPtr; } return TCL_RETURN; } + /* *---------------------------------------------------------------------- * * TclNRTailcallEval -- @@ -8526,10 +8532,11 @@ } i++; } return result; } + void Tcl_NRAddCallback( Tcl_Interp *interp, Tcl_NRPostProc *postProcPtr, @@ -8714,11 +8721,11 @@ */ NRE_ASSERT(iPtr->varFramePtr == corPtr->caller.varFramePtr); NRE_ASSERT(iPtr->framePtr == corPtr->caller.framePtr); NRE_ASSERT(iPtr->cmdFramePtr == corPtr->caller.cmdFramePtr); - Tcl_Free(corPtr); + ckfree(corPtr); return result; } NRE_ASSERT(COR_IS_SUSPENDED(corPtr)); SAVE_CONTEXT(corPtr->running); @@ -8773,11 +8780,11 @@ * Drop the coroutine-owned copy of the lineLABCPtr hashtable for literal * command arguments in bytecode. */ Tcl_DeleteHashTable(corPtr->lineLABCPtr); - Tcl_Free(corPtr->lineLABCPtr); + ckfree(corPtr->lineLABCPtr); corPtr->lineLABCPtr = NULL; RESTORE_CONTEXT(corPtr->caller); iPtr->execEnvPtr = corPtr->callerEEPtr; iPtr->numLevels++; @@ -8969,283 +8976,25 @@ } /* *---------------------------------------------------------------------- * - * TclNRCoroInjectObjCmd, TclNRCoroProbeObjCmd -- - * - * Implementation of [coroinject] and [coroprobe] commands. - * - *---------------------------------------------------------------------- - */ - -static inline CoroutineData * -GetCoroutineFromObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr, - const char *errMsg) -{ - /* - * How to get a coroutine from its handle. - */ - - Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objPtr); - - if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE", - TclGetString(objPtr), NULL); - return NULL; - } - return cmdPtr->objClientData; -} - -static int -TclNRCoroInjectObjCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - CoroutineData *corPtr; - ExecEnv *savedEEPtr = iPtr->execEnvPtr; - - /* - * Usage more or less like tailcall: - * coroinject coroName cmd ?arg1 arg2 ...? - */ - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?"); - return TCL_ERROR; - } - - corPtr = GetCoroutineFromObj(interp, objv[1], - "can only inject a command into a coroutine"); - if (!corPtr) { - return TCL_ERROR; - } - if (!COR_IS_SUSPENDED(corPtr)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can only inject a command into a suspended coroutine", -1)); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL); - return TCL_ERROR; - } - - /* - * Add the callback to the coro's execEnv, so that it is the first thing - * to happen when the coro is resumed. - */ - - iPtr->execEnvPtr = corPtr->eePtr; - TclNRAddCallback(interp, InjectHandler, corPtr, - Tcl_NewListObj(objc - 2, objv + 2), INT2PTR(corPtr->nargs), NULL); - iPtr->execEnvPtr = savedEEPtr; - - return TCL_OK; -} - -static int -TclNRCoroProbeObjCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - CoroutineData *corPtr; - ExecEnv *savedEEPtr = iPtr->execEnvPtr; - int numLevels, unused; - int *stackLevel = &unused; - - /* - * Usage more or less like tailcall: - * coroprobe coroName cmd ?arg1 arg2 ...? - */ - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?"); - return TCL_ERROR; - } - - corPtr = GetCoroutineFromObj(interp, objv[1], - "can only inject a probe command into a coroutine"); - if (!corPtr) { - return TCL_ERROR; - } - if (!COR_IS_SUSPENDED(corPtr)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can only inject a probe command into a suspended coroutine", - -1)); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL); - return TCL_ERROR; - } - - /* - * Add the callback to the coro's execEnv, so that it is the first thing - * to happen when the coro is resumed. - */ - - iPtr->execEnvPtr = corPtr->eePtr; - TclNRAddCallback(interp, InjectHandler, corPtr, - Tcl_NewListObj(objc - 2, objv + 2), INT2PTR(corPtr->nargs), corPtr); - iPtr->execEnvPtr = savedEEPtr; - - /* - * Now we immediately transfer control to the coroutine to run our probe. - * TRICKY STUFF copied from the [yield] implementation. - * - * Push the callback to restore the caller's context on yield back. - */ - - TclNRAddCallback(interp, NRCoroutineCallerCallback, corPtr, - NULL, NULL, NULL); - - /* - * Record the stackLevel at which the resume is happening, then swap - * the interp's environment to make it suitable to run this coroutine. - */ - - corPtr->stackLevel = stackLevel; - numLevels = corPtr->auxNumLevels; - corPtr->auxNumLevels = iPtr->numLevels; - - /* - * Do the actual stack swap. - */ - - SAVE_CONTEXT(corPtr->caller); - corPtr->callerEEPtr = iPtr->execEnvPtr; - RESTORE_CONTEXT(corPtr->running); - iPtr->execEnvPtr = corPtr->eePtr; - iPtr->numLevels += numLevels; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * InjectHandler, InjectHandlerPostProc -- - * - * Part of the implementation of [coroinject] and [coroprobe]. These are - * run inside the context of the coroutine being injected/probed into. - * - * InjectHandler runs a script (possibly adding arguments) in the context - * of the coroutine. The script is specified as a one-shot list (with - * reference count equal to 1) in data[1]. This function also arranges - * for InjectHandlerPostProc to be the part that runs after the script - * completes. - * - * InjectHandlerPostProc cleans up after InjectHandler (deleting the - * list) and, for the [coroprobe] command *only*, yields back to the - * caller context (i.e., where [coroprobe] was run). - *s - *---------------------------------------------------------------------- - */ - -static int -InjectHandler( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - CoroutineData *corPtr = data[0]; - Tcl_Obj *listPtr = data[1]; - int nargs = PTR2INT(data[2]); - ClientData isProbe = data[3]; - int objc; - Tcl_Obj **objv; - - if (!isProbe) { - /* - * If this is [coroinject], add the extra arguments now. - */ - - if (nargs == COROUTINE_ARGUMENTS_SINGLE_OPTIONAL) { - Tcl_ListObjAppendElement(NULL, listPtr, - Tcl_NewStringObj("yield", -1)); - } else if (nargs == COROUTINE_ARGUMENTS_ARBITRARY) { - Tcl_ListObjAppendElement(NULL, listPtr, - Tcl_NewStringObj("yieldto", -1)); - } else { - /* - * I don't think this is reachable... - */ - - Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewIntObj(nargs)); - } - Tcl_ListObjAppendElement(NULL, listPtr, Tcl_GetObjResult(interp)); - } - - /* - * Call the user's script; we're in the right place. - */ - - Tcl_IncrRefCount(listPtr); - TclMarkTailcall(interp); - TclNRAddCallback(interp, InjectHandlerPostCall, corPtr, listPtr, - INT2PTR(nargs), isProbe); - TclListObjGetElements(NULL, listPtr, &objc, &objv); - return TclNREvalObjv(interp, objc, objv, 0, NULL); -} - -static int -InjectHandlerPostCall( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - CoroutineData *corPtr = data[0]; - Tcl_Obj *listPtr = data[1]; - int nargs = PTR2INT(data[2]); - ClientData isProbe = data[3]; - int numLevels; - - /* - * Delete the command words for what we just executed. - */ - - Tcl_DecrRefCount(listPtr); - - /* - * If we were doing a probe, splice ourselves back out of the stack - * cleanly here. General injection should instead just look after itself. - * - * Code from guts of [yield] implementation. - */ - - if (isProbe) { - if (result == TCL_ERROR) { - Tcl_AddErrorInfo(interp, - "\n (injected coroutine probe command)"); - } - corPtr->nargs = nargs; - corPtr->stackLevel = NULL; - numLevels = iPtr->numLevels; - iPtr->numLevels = corPtr->auxNumLevels; - corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels; - iPtr->execEnvPtr = corPtr->callerEEPtr; - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * NRInjectObjCmd -- + * NRCoroInjectObjCmd -- * * Implementation of [::tcl::unsupported::inject] command. * *---------------------------------------------------------------------- */ static int -NRInjectObjCmd( +NRCoroInjectObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { + Command *cmdPtr; CoroutineData *corPtr; ExecEnv *savedEEPtr = iPtr->execEnvPtr; /* * Usage more or less like tailcall: @@ -9255,15 +9004,20 @@ if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?"); return TCL_ERROR; } - corPtr = GetCoroutineFromObj(interp, objv[1], - "can only inject a command into a coroutine"); - if (!corPtr) { + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]); + if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can only inject a command into a coroutine", -1)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE", + TclGetString(objv[1]), NULL); return TCL_ERROR; } + + corPtr = cmdPtr->objClientData; if (!COR_IS_SUSPENDED(corPtr)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "can only inject a command into a suspended coroutine", -1)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL); return TCL_ERROR; @@ -9292,11 +9046,11 @@ CoroutineData *corPtr = clientData; if (!COR_IS_SUSPENDED(corPtr)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "coroutine \"%s\" is already running", - TclGetString(objv[0]))); + Tcl_GetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BUSY", NULL); return TCL_ERROR; } /* @@ -9387,11 +9141,11 @@ /* * We ARE creating the coroutine command: allocate the corresponding * struct and create the corresponding command. */ - corPtr = Tcl_Alloc(sizeof(CoroutineData)); + corPtr = ckalloc(sizeof(CoroutineData)); cmdPtr = (Command *) TclNRCreateCommandInNs(interp, simpleName, (Tcl_Namespace *)nsPtr, /*objProc*/ NULL, TclNRInterpCoroutine, corPtr, DeleteCoroutine); @@ -9409,11 +9163,11 @@ { Tcl_HashSearch hSearch; Tcl_HashEntry *hePtr; - corPtr->lineLABCPtr = Tcl_Alloc(sizeof(Tcl_HashTable)); + corPtr->lineLABCPtr = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(corPtr->lineLABCPtr, TCL_ONE_WORD_KEYS); for (hePtr = Tcl_FirstHashEntry(iPtr->lineLABCPtr,&hSearch); hePtr; hePtr = Tcl_NextHashEntry(&hSearch)) { int isNew; Index: generic/tclBinary.c ================================================================== --- generic/tclBinary.c +++ generic/tclBinary.c @@ -13,19 +13,18 @@ #include "tclInt.h" #include "tommath.h" #include -#include /* * The following constants are used by GetFormatSpec to indicate various * special conditions in the parsing of a format specifier. */ -#define BINARY_ALL ((size_t)-1) /* Use all elements in the argument. */ -#define BINARY_NOCOUNT ((size_t)-2) /* No count was specified in format. */ +#define BINARY_ALL -1 /* Use all elements in the argument. */ +#define BINARY_NOCOUNT -2 /* No count was specified in format. */ /* * The following flags may be ORed together and returned by GetFormatSpec */ @@ -55,27 +54,24 @@ * Prototypes for local procedures defined in this file: */ static void DupByteArrayInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); -static void DupProperByteArrayInternalRep(Tcl_Obj *srcPtr, - Tcl_Obj *copyPtr); static int FormatNumber(Tcl_Interp *interp, int type, Tcl_Obj *src, unsigned char **cursorPtr); static void FreeByteArrayInternalRep(Tcl_Obj *objPtr); -static void FreeProperByteArrayInternalRep(Tcl_Obj *objPtr); static int GetFormatSpec(const char **formatPtr, char *cmdPtr, - size_t *countPtr, int *flagsPtr); + int *countPtr, int *flagsPtr); static Tcl_Obj * ScanNumber(unsigned char *buffer, int type, int flags, Tcl_HashTable **numberCachePtr); static int SetByteArrayFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfByteArray(Tcl_Obj *listPtr); static void DeleteScanNumberCache(Tcl_HashTable *numberCachePtr); static int NeedReversing(int format); static void CopyNumber(const void *from, void *to, - size_t length, int type); + unsigned length, int type); /* Binary ensemble commands */ static int BinaryFormatCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int BinaryScanCmd(ClientData clientData, @@ -157,107 +153,39 @@ { "base64", BinaryDecode64, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 }, { NULL, NULL, NULL, NULL, NULL, 0 } }; /* - * The following object types represent an array of bytes. The intent is to - * allow arbitrary binary data to pass through Tcl as a Tcl value without loss - * or damage. Such values are useful for things like encoded strings or Tk - * images to name just two. - * - * It's strange to have two Tcl_ObjTypes in place for this task when one would - * do, so a bit of detail and history how we got to this point and where we - * might go from here. - * - * A bytearray is an ordered sequence of bytes. Each byte is an integer value - * in the range [0-255]. To be a Tcl value type, we need a way to encode each - * value in the value set as a Tcl string. The simplest encoding is to - * represent each byte value as the same codepoint value. A bytearray of N - * bytes is encoded into a Tcl string of N characters where the codepoint of - * each character is the value of corresponding byte. This approach creates a - * one-to-one map between all bytearray values and a subset of Tcl string - * values. - * - * When converting a Tcl string value to the bytearray internal rep, the - * question arises what to do with strings outside that subset? That is, - * those Tcl strings containing at least one codepoint greater than 255? The - * obviously correct answer is to raise an error! That string value does not - * represent any valid bytearray value. Full Stop. The setFromAnyProc - * signature has a completion code return value for just this reason, to - * reject invalid inputs. - * - * Unfortunately this was not the path taken by the authors of the original - * tclByteArrayType. They chose to accept all Tcl string values as acceptable - * string encodings of the bytearray values that result from masking away the - * high bits of any codepoint value at all. This meant that every bytearray - * value had multiple accepted string representations. - * - * The implications of this choice are truly ugly. When a Tcl value has a - * string representation, we are required to accept that as the true value. - * Bytearray values that possess a string representation cannot be processed - * as bytearrays because we cannot know which true value that bytearray - * represents. The consequence is that we drag around an internal rep that we - * cannot make any use of. This painful price is extracted at any point after - * a string rep happens to be generated for the value. This happens even when - * the troublesome codepoints outside the byte range never show up. This - * happens rather routinely in normal Tcl operations unless we burden the - * script writer with the cognitive burden of avoiding it. The price is also - * paid by callers of the C interface. The routine - * - * unsigned char *Tcl_GetByteArrayFromObj(objPtr, lenPtr) - * - * has a guarantee to always return a non-NULL value, but that value points to - * a byte sequence that cannot be used by the caller to process the Tcl value - * absent some sideband testing that objPtr is "pure". Tcl offers no public - * interface to perform this test, so callers either break encapsulation or - * are unavoidably buggy. Tcl has defined a public interface that cannot be - * used correctly. The Tcl source code itself suffers the same problem, and - * has been buggy, but progressively less so as more and more portions of the - * code have been retrofitted with the required "purity testing". The set of - * values able to pass the purity test can be increased via the introduction - * of a "canonical" flag marker, but the only way the broken interface itself - * can be discarded is to start over and define the Tcl_ObjType properly. - * Bytearrays should simply be usable as bytearrays without a kabuki dance of - * testing. - * - * The Tcl_ObjType "properByteArrayType" is (nearly) a correct implementation - * of bytearrays. Any Tcl value with the type properByteArrayType can have - * its bytearray value fetched and used with confidence that acting on that - * value is equivalent to acting on the true Tcl string value. This still - * implies a side testing burden -- past mistakes will not let us avoid that - * immediately, but it is at least a conventional test of type, and can be - * implemented entirely by examining the objPtr fields, with no need to query - * the intrep, as a canonical flag would require. - * - * Until Tcl_GetByteArrayFromObj() and Tcl_SetByteArrayLength() can be revised - * to admit the possibility of returning NULL when the true value is not a - * valid bytearray, we need a mechanism to retain compatibility with the - * deployed callers of the broken interface. That's what the retained - * "tclByteArrayType" provides. In those unusual circumstances where we - * convert an invalid bytearray value to a bytearray type, it is to this - * legacy type. Essentially any time this legacy type gets used, it's a - * signal of a bug being ignored. A TIP should be drafted to remove this - * connection to the broken past so that Tcl 9 will no longer have any trace - * of it. Prescribing a migration path will be the key element of that work. - * The internal changes now in place are the limit of what can be done short - * of interface repair. They provide a great expansion of the histories over - * which bytearray values can be useful in the meanwhile. - */ - -static const Tcl_ObjType properByteArrayType = { - "bytearray", - FreeProperByteArrayInternalRep, - DupProperByteArrayInternalRep, - UpdateStringOfByteArray, - NULL -}; + * The following object type represents an array of bytes. An array of bytes + * is not equivalent to an internationalized string. Conceptually, a string is + * an array of 16-bit quantities organized as a sequence of properly formed + * UTF-8 characters, while a ByteArray is an array of 8-bit quantities. + * Accessor functions are provided to convert a ByteArray to a String or a + * String to a ByteArray. Two or more consecutive bytes in an array of bytes + * may look like a single UTF-8 character if the array is casually treated as + * a string. But obtaining the String from a ByteArray is guaranteed to + * produced properly formed UTF-8 sequences so that there is a one-to-one map + * between bytes and characters. + * + * Converting a ByteArray to a String proceeds by casting each byte in the + * array to a 16-bit quantity, treating that number as a Unicode character, + * and storing the UTF-8 version of that Unicode character in the String. For + * ByteArrays consisting entirely of values 1..127, the corresponding String + * representation is the same as the ByteArray representation. + * + * Converting a String to a ByteArray proceeds by getting the Unicode + * representation of each character in the String, casting it to a byte by + * truncating the upper 8 bits, and then storing the byte in the ByteArray. + * Converting from ByteArray to String and back to ByteArray is not lossy, but + * converting an arbitrary String to a ByteArray may be. + */ const Tcl_ObjType tclByteArrayType = { "bytearray", FreeByteArrayInternalRep, DupByteArrayInternalRep, - NULL, + UpdateStringOfByteArray, SetByteArrayFromAny }; /* * The following structure is the internal rep for a ByteArray object. Keeps @@ -264,32 +192,27 @@ * track of how much memory has been used and how much has been allocated for * the byte array to enable growing and shrinking of the ByteArray object with * fewer mallocs. */ -typedef struct { - size_t used; /* The number of bytes used in the byte +typedef struct ByteArray { + int used; /* The number of bytes used in the byte * array. */ - size_t allocated; /* The amount of space actually allocated + int allocated; /* The amount of space actually allocated * minus 1 byte. */ - unsigned char bytes[1]; /* The array of bytes. The actual size of this + unsigned char bytes[TCLFLEXARRAY]; /* The array of bytes. The actual size of this * field depends on the 'allocated' field * above. */ } ByteArray; #define BYTEARRAY_SIZE(len) \ - (offsetof(ByteArray, bytes) + (len)) -#define GET_BYTEARRAY(irPtr) ((ByteArray *) (irPtr)->twoPtrValue.ptr1) -#define SET_BYTEARRAY(irPtr, baPtr) \ - (irPtr)->twoPtrValue.ptr1 = (baPtr) - -int -TclIsPureByteArray( - Tcl_Obj * objPtr) -{ - return TclHasIntRep(objPtr, &properByteArrayType); -} + ((unsigned) (TclOffset(ByteArray, bytes) + (len))) +#define GET_BYTEARRAY(objPtr) \ + ((ByteArray *) (objPtr)->internalRep.twoPtrValue.ptr1) +#define SET_BYTEARRAY(objPtr, baPtr) \ + (objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (baPtr) + /* *---------------------------------------------------------------------- * * Tcl_NewByteArrayObj -- @@ -311,11 +234,12 @@ Tcl_Obj * Tcl_NewByteArrayObj( const unsigned char *bytes, /* The array of bytes used to initialize the * new object. */ - size_t length) /* Length of the array of bytes */ + int length) /* Length of the array of bytes, which must be + * >= 0. */ { #ifdef TCL_MEM_DEBUG return Tcl_DbNewByteArrayObj(bytes, length, "unknown", 0); #else /* if not TCL_MEM_DEBUG */ Tcl_Obj *objPtr; @@ -353,11 +277,12 @@ Tcl_Obj * Tcl_DbNewByteArrayObj( const unsigned char *bytes, /* The array of bytes used to initialize the * new object. */ - size_t length, /* Length of the array of bytes. */ + int length, /* Length of the array of bytes, which must be + * >= 0. */ const char *file, /* The name of the source file calling this * procedure; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ { @@ -393,31 +318,33 @@ void Tcl_SetByteArrayObj( Tcl_Obj *objPtr, /* Object to initialize as a ByteArray. */ const unsigned char *bytes, /* The array of bytes to use as the new value. * May be NULL even if length > 0. */ - size_t length) /* Length of the array of bytes, which must + int length) /* Length of the array of bytes, which must * be >= 0. */ { ByteArray *byteArrayPtr; - Tcl_ObjIntRep ir; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayObj"); } + TclFreeIntRep(objPtr); TclInvalidateStringRep(objPtr); - byteArrayPtr = Tcl_Alloc(BYTEARRAY_SIZE(length)); + if (length < 0) { + length = 0; + } + byteArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length)); byteArrayPtr->used = length; byteArrayPtr->allocated = length; if ((bytes != NULL) && (length > 0)) { memcpy(byteArrayPtr->bytes, bytes, length); } - SET_BYTEARRAY(&ir, byteArrayPtr); - - Tcl_StoreIntRep(objPtr, &properByteArrayType, &ir); + objPtr->typePtr = &tclByteArrayType; + SET_BYTEARRAY(objPtr, byteArrayPtr); } /* *---------------------------------------------------------------------- * @@ -441,28 +368,20 @@ Tcl_Obj *objPtr, /* The ByteArray object. */ int *lengthPtr) /* If non-NULL, filled with length of the * array of bytes in the ByteArray object. */ { ByteArray *baPtr; - const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &properByteArrayType); - - if (irPtr == NULL) { - irPtr = TclFetchIntRep(objPtr, &tclByteArrayType); - if (irPtr == NULL) { - SetByteArrayFromAny(NULL, objPtr); - irPtr = TclFetchIntRep(objPtr, &properByteArrayType); - if (irPtr == NULL) { - irPtr = TclFetchIntRep(objPtr, &tclByteArrayType); - } - } - } - baPtr = GET_BYTEARRAY(irPtr); + + if (objPtr->typePtr != &tclByteArrayType) { + SetByteArrayFromAny(NULL, objPtr); + } + baPtr = GET_BYTEARRAY(objPtr); if (lengthPtr != NULL) { *lengthPtr = baPtr->used; } - return baPtr->bytes; + return (unsigned char *) baPtr->bytes; } /* *---------------------------------------------------------------------- * @@ -486,36 +405,26 @@ */ unsigned char * Tcl_SetByteArrayLength( Tcl_Obj *objPtr, /* The ByteArray object. */ - size_t length) /* New length for internal byte array. */ + int length) /* New length for internal byte array. */ { ByteArray *byteArrayPtr; - Tcl_ObjIntRep *irPtr; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayLength"); } - - irPtr = TclFetchIntRep(objPtr, &properByteArrayType); - if (irPtr == NULL) { - irPtr = TclFetchIntRep(objPtr, &tclByteArrayType); - if (irPtr == NULL) { - SetByteArrayFromAny(NULL, objPtr); - irPtr = TclFetchIntRep(objPtr, &properByteArrayType); - if (irPtr == NULL) { - irPtr = TclFetchIntRep(objPtr, &tclByteArrayType); - } - } + if (objPtr->typePtr != &tclByteArrayType) { + SetByteArrayFromAny(NULL, objPtr); } - byteArrayPtr = GET_BYTEARRAY(irPtr); + byteArrayPtr = GET_BYTEARRAY(objPtr); if (length > byteArrayPtr->allocated) { - byteArrayPtr = Tcl_Realloc(byteArrayPtr, BYTEARRAY_SIZE(length)); + byteArrayPtr = ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(length)); byteArrayPtr->allocated = length; - SET_BYTEARRAY(irPtr, byteArrayPtr); + SET_BYTEARRAY(objPtr, byteArrayPtr); } TclInvalidateStringRep(objPtr); byteArrayPtr->used = length; return byteArrayPtr->bytes; } @@ -539,41 +448,33 @@ static int SetByteArrayFromAny( Tcl_Interp *interp, /* Not used. */ Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */ { - size_t length; - int improper = 0; + int length; const char *src, *srcEnd; unsigned char *dst; - Tcl_UniChar ch = 0; ByteArray *byteArrayPtr; - Tcl_ObjIntRep ir; - - if (TclHasIntRep(objPtr, &properByteArrayType)) { - return TCL_OK; - } - if (TclHasIntRep(objPtr, &tclByteArrayType)) { - return TCL_OK; - } - - src = TclGetStringFromObj(objPtr, &length); - srcEnd = src + length; - - byteArrayPtr = Tcl_Alloc(BYTEARRAY_SIZE(length)); - for (dst = byteArrayPtr->bytes; src < srcEnd; ) { - src += TclUtfToUniChar(src, &ch); - improper = improper || (ch > 255); - *dst++ = UCHAR(ch); - } - - byteArrayPtr->used = dst - byteArrayPtr->bytes; - byteArrayPtr->allocated = length; - - SET_BYTEARRAY(&ir, byteArrayPtr); - Tcl_StoreIntRep(objPtr, - improper ? &tclByteArrayType : &properByteArrayType, &ir); + Tcl_UniChar ch = 0; + + if (objPtr->typePtr != &tclByteArrayType) { + src = TclGetStringFromObj(objPtr, &length); + srcEnd = src + length; + + byteArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length)); + for (dst = byteArrayPtr->bytes; src < srcEnd; ) { + src += TclUtfToUniChar(src, &ch); + *dst++ = UCHAR(ch); + } + + byteArrayPtr->used = dst - byteArrayPtr->bytes; + byteArrayPtr->allocated = length; + + TclFreeIntRep(objPtr); + objPtr->typePtr = &tclByteArrayType; + SET_BYTEARRAY(objPtr, byteArrayPtr); + } return TCL_OK; } /* *---------------------------------------------------------------------- @@ -594,18 +495,12 @@ static void FreeByteArrayInternalRep( Tcl_Obj *objPtr) /* Object with internal rep to free. */ { - Tcl_Free(GET_BYTEARRAY(TclFetchIntRep(objPtr, &tclByteArrayType))); -} - -static void -FreeProperByteArrayInternalRep( - Tcl_Obj *objPtr) /* Object with internal rep to free. */ -{ - Tcl_Free(GET_BYTEARRAY(TclFetchIntRep(objPtr, &properByteArrayType))); + ckfree(GET_BYTEARRAY(objPtr)); + objPtr->typePtr = NULL; } /* *---------------------------------------------------------------------- * @@ -626,97 +521,87 @@ static void DupByteArrayInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - size_t length; - ByteArray *srcArrayPtr, *copyArrayPtr; - Tcl_ObjIntRep ir; - - srcArrayPtr = GET_BYTEARRAY(TclFetchIntRep(srcPtr, &tclByteArrayType)); - length = srcArrayPtr->used; - - copyArrayPtr = Tcl_Alloc(BYTEARRAY_SIZE(length)); - copyArrayPtr->used = length; - copyArrayPtr->allocated = length; - memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, length); - - SET_BYTEARRAY(&ir, copyArrayPtr); - Tcl_StoreIntRep(copyPtr, &tclByteArrayType, &ir); -} - -static void -DupProperByteArrayInternalRep( - Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ - Tcl_Obj *copyPtr) /* Object with internal rep to set. */ -{ - unsigned int length; - ByteArray *srcArrayPtr, *copyArrayPtr; - Tcl_ObjIntRep ir; - - srcArrayPtr = GET_BYTEARRAY(TclFetchIntRep(srcPtr, &properByteArrayType)); - length = srcArrayPtr->used; - - copyArrayPtr = Tcl_Alloc(BYTEARRAY_SIZE(length)); - copyArrayPtr->used = length; - copyArrayPtr->allocated = length; - memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, length); - - SET_BYTEARRAY(&ir, copyArrayPtr); - Tcl_StoreIntRep(copyPtr, &properByteArrayType, &ir); + int length; + ByteArray *srcArrayPtr, *copyArrayPtr; + + srcArrayPtr = GET_BYTEARRAY(srcPtr); + length = srcArrayPtr->used; + + copyArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length)); + copyArrayPtr->used = length; + copyArrayPtr->allocated = length; + memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, length); + SET_BYTEARRAY(copyPtr, copyArrayPtr); + + copyPtr->typePtr = &tclByteArrayType; } /* *---------------------------------------------------------------------- * * UpdateStringOfByteArray -- * - * Update the string representation for a ByteArray data object. + * Update the string representation for a ByteArray data object. Note: + * This procedure does not invalidate an existing old string rep so + * storage will be lost if this has not already been done. * * Results: * None. * * Side effects: * The object's string is set to a valid string that results from the * ByteArray-to-string conversion. + * + * The object becomes a string object -- the internal rep is discarded + * and the typePtr becomes NULL. * *---------------------------------------------------------------------- */ static void UpdateStringOfByteArray( Tcl_Obj *objPtr) /* ByteArray object whose string rep to * update. */ { - const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &properByteArrayType); - ByteArray *byteArrayPtr = GET_BYTEARRAY(irPtr); - unsigned char *src = byteArrayPtr->bytes; - size_t i, length = byteArrayPtr->used; - size_t size = length; + int i, length, size; + unsigned char *src; + char *dst; + ByteArray *byteArrayPtr; + + byteArrayPtr = GET_BYTEARRAY(objPtr); + src = byteArrayPtr->bytes; + length = byteArrayPtr->used; /* * How much space will string rep need? */ - for (i = 0; i < length; i++) { + size = length; + for (i = 0; i < length && size >= 0; i++) { if ((src[i] == 0) || (src[i] > 127)) { size++; } } + if (size < 0) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } + + dst = (char *)ckalloc(size + 1); + objPtr->bytes = dst; + objPtr->length = size; if (size == length) { - char *dst = Tcl_InitStringRep(objPtr, (char *)src, size); - - TclOOM(dst, size); + memcpy(dst, src, size); + dst[size] = '\0'; } else { - char *dst = Tcl_InitStringRep(objPtr, NULL, size); - - TclOOM(dst, size); for (i = 0; i < length; i++) { dst += Tcl_UniCharToUtf(src[i], dst); } - (void) Tcl_InitStringRep(objPtr, NULL, size); + *dst = '\0'; } } /* *---------------------------------------------------------------------- @@ -739,20 +624,19 @@ void TclAppendBytesToByteArray( Tcl_Obj *objPtr, const unsigned char *bytes, - size_t len) + int len) { ByteArray *byteArrayPtr; - size_t needed; - Tcl_ObjIntRep *irPtr; + int needed; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object","TclAppendBytesToByteArray"); } - if (len == TCL_AUTO_LENGTH) { + if (len < 0) { Tcl_Panic("%s must be called with definite number of bytes to append", "TclAppendBytesToByteArray"); } if (len == 0) { /* @@ -759,68 +643,59 @@ * Append zero bytes is a no-op. */ return; } - - irPtr = TclFetchIntRep(objPtr, &properByteArrayType); - if (irPtr == NULL) { - irPtr = TclFetchIntRep(objPtr, &tclByteArrayType); - if (irPtr == NULL) { - SetByteArrayFromAny(NULL, objPtr); - irPtr = TclFetchIntRep(objPtr, &properByteArrayType); - if (irPtr == NULL) { - irPtr = TclFetchIntRep(objPtr, &tclByteArrayType); - } - } - } - byteArrayPtr = GET_BYTEARRAY(irPtr); - - if (len > UINT_MAX - byteArrayPtr->used) { - Tcl_Panic("max size for a Tcl value (%u bytes) exceeded", UINT_MAX); + if (objPtr->typePtr != &tclByteArrayType) { + SetByteArrayFromAny(NULL, objPtr); + } + byteArrayPtr = GET_BYTEARRAY(objPtr); + + if (len > INT_MAX - byteArrayPtr->used) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } needed = byteArrayPtr->used + len; /* * If we need to, resize the allocated space in the byte array. */ if (needed > byteArrayPtr->allocated) { ByteArray *ptr = NULL; - size_t attempt; + int attempt; if (needed <= INT_MAX/2) { /* * Try to allocate double the total space that is needed. */ attempt = 2 * needed; - ptr = Tcl_AttemptRealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); + ptr = attemptckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); } if (ptr == NULL) { /* * Try to allocate double the increment that is needed (plus). */ - size_t limit = UINT_MAX - needed; - size_t extra = len + TCL_MIN_GROWTH; - size_t growth = (extra > limit) ? limit : extra; + unsigned int limit = INT_MAX - needed; + unsigned int extra = len + TCL_MIN_GROWTH; + int growth = (int) ((extra > limit) ? limit : extra); attempt = needed + growth; - ptr = Tcl_AttemptRealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); + ptr = attemptckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); } if (ptr == NULL) { /* * Last chance: Try to allocate exactly what is needed. */ attempt = needed; - ptr = Tcl_Realloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); + ptr = ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); } byteArrayPtr = ptr; byteArrayPtr->allocated = attempt; - SET_BYTEARRAY(irPtr, byteArrayPtr); + SET_BYTEARRAY(objPtr, byteArrayPtr); } if (bytes) { memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, len); } @@ -882,11 +757,11 @@ { int arg; /* Index of next argument to consume. */ int value = 0; /* Current integer value to be packed. * Initialized to avoid compiler warning. */ char cmd; /* Current format character. */ - size_t count; /* Count associated with current format + int count; /* Count associated with current format * character. */ int flags; /* Format field flags */ const char *format; /* Pointer to current position in format * string. */ Tcl_Obj *resultPtr = NULL; /* Object holding result buffer. */ @@ -894,12 +769,11 @@ unsigned char *cursor; /* Current position within result buffer. */ unsigned char *maxPos; /* Greatest position within result buffer that * cursor has visited.*/ const char *errorString; const char *errorValue, *str; - int offset, size; - size_t length; + int offset, size, length; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "formatString ?arg ...?"); return TCL_ERROR; } @@ -934,11 +808,11 @@ if (arg >= objc) { goto badIndex; } if (count == BINARY_ALL) { - (void)TclGetByteArrayFromObj(objv[arg], &count); + Tcl_GetByteArrayFromObj(objv[arg], &count); } else if (count == BINARY_NOCOUNT) { count = 1; } arg++; if (cmd == 'a' || cmd == 'A') { @@ -1006,11 +880,11 @@ } arg++; if (count == BINARY_ALL) { count = listc; - } else if (count > (size_t)listc) { + } else if (count > listc) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "number of elements in list does not match count", -1)); return TCL_ERROR; } @@ -1030,20 +904,20 @@ break; case 'X': if (count == BINARY_NOCOUNT) { count = 1; } - if ((count > (size_t)offset) || (count == BINARY_ALL)) { + if ((count > offset) || (count == BINARY_ALL)) { count = offset; } - if (offset > (int)length) { + if (offset > length) { length = offset; } offset -= count; break; case '@': - if (offset > (int)length) { + if (offset > length) { length = offset; } if (count == BINARY_ALL) { offset = length; } else if (count == BINARY_NOCOUNT) { @@ -1055,11 +929,11 @@ default: errorString = str; goto badField; } } - if (offset > (int)length) { + if (offset > length) { length = offset; } if (length == 0) { return TCL_OK; } @@ -1098,12 +972,12 @@ case 'a': case 'A': { char pad = (char) (cmd == 'a' ? '\0' : ' '); unsigned char *bytes; - bytes = TclGetByteArrayFromObj(objv[arg], &length); - arg++; + bytes = Tcl_GetByteArrayFromObj(objv[arg++], &length); + if (count == BINARY_ALL) { count = length; } else if (count == BINARY_NOCOUNT) { count = 1; } @@ -1132,11 +1006,11 @@ count = length; } value = 0; errorString = "binary"; if (cmd == 'B') { - for (offset = 0; (size_t)offset < count; offset++) { + for (offset = 0; offset < count; offset++) { value <<= 1; if (str[offset] == '1') { value |= 1; } else if (str[offset] != '0') { errorValue = str; @@ -1147,11 +1021,11 @@ *cursor++ = UCHAR(value); value = 0; } } } else { - for (offset = 0; (size_t)offset < count; offset++) { + for (offset = 0; offset < count; offset++) { value >>= 1; if (str[offset] == '1') { value |= 128; } else if (str[offset] != '0') { errorValue = str; @@ -1194,11 +1068,11 @@ count = length; } value = 0; errorString = "hexadecimal"; if (cmd == 'H') { - for (offset = 0; (size_t)offset < count; offset++) { + for (offset = 0; offset < count; offset++) { value <<= 4; if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */ errorValue = str; Tcl_DecrRefCount(resultPtr); goto badValue; @@ -1208,18 +1082,18 @@ c += ('0' - 'A') + 10; } if (c > 16) { c += ('A' - 'a'); } - value |= (c & 0xf); + value |= (c & 0xF); if (offset % 2) { *cursor++ = (char) value; value = 0; } } } else { - for (offset = 0; (size_t)offset < count; offset++) { + for (offset = 0; offset < count; offset++) { value >>= 4; if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */ errorValue = str; Tcl_DecrRefCount(resultPtr); @@ -1230,13 +1104,13 @@ c += ('0' - 'A') + 10; } if (c > 16) { c += ('A' - 'a'); } - value |= ((c << 4) & 0xf0); + value |= ((c << 4) & 0xF0); if (offset % 2) { - *cursor++ = UCHAR(value & 0xff); + *cursor++ = UCHAR(value & 0xFF); value = 0; } } } if (offset % 2) { @@ -1286,11 +1160,11 @@ if (count == BINARY_ALL) { count = listc; } } arg++; - for (i = 0; (size_t)i < count; i++) { + for (i = 0; i < count; i++) { if (FormatNumber(interp, cmd, listv[i], &cursor) != TCL_OK) { Tcl_DecrRefCount(resultPtr); return TCL_ERROR; } } @@ -1308,11 +1182,11 @@ maxPos = cursor; } if (count == BINARY_NOCOUNT) { count = 1; } - if ((count == BINARY_ALL) || (count > (size_t)(cursor - buffer))) { + if ((count == BINARY_ALL) || (count > (cursor - buffer))) { cursor = buffer; } else { cursor -= count; } break; @@ -1346,15 +1220,15 @@ errorString = "not enough arguments for all format specifiers"; goto error; badField: { - Tcl_UniChar ch = 0; - char buf[TCL_UTF_MAX + 1] = ""; + int ch; + char buf[8] = ""; - TclUtfToUniChar(errorString, &ch); - buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; + TclUtfToUCS4(errorString, &ch); + buf[TclUCS4ToUtf(ch, buf)] = '\0'; Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad field specifier \"%s\"", buf)); return TCL_ERROR; } @@ -1388,21 +1262,20 @@ { int arg; /* Index of next argument to consume. */ int value = 0; /* Current integer value to be packed. * Initialized to avoid compiler warning. */ char cmd; /* Current format character. */ - size_t count; /* Count associated with current format + int count; /* Count associated with current format * character. */ int flags; /* Format field flags */ const char *format; /* Pointer to current position in format * string. */ Tcl_Obj *resultPtr = NULL; /* Object holding result buffer. */ unsigned char *buffer; /* Start of result buffer. */ const char *errorString; const char *str; - int offset, size; - size_t length = 0; + int offset, size, length; int i; Tcl_Obj *valuePtr, *elementPtr; Tcl_HashTable numberCacheHash; Tcl_HashTable *numberCachePtr; @@ -1412,11 +1285,11 @@ "value formatString ?varName ...?"); return TCL_ERROR; } numberCachePtr = &numberCacheHash; Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS); - buffer = TclGetByteArrayFromObj(objv[1], &length); + buffer = Tcl_GetByteArrayFromObj(objv[1], &length); format = TclGetString(objv[2]); arg = 3; offset = 0; while (*format != '\0') { str = format; @@ -1437,11 +1310,11 @@ count = length - offset; } else { if (count == BINARY_NOCOUNT) { count = 1; } - if (count > length - offset) { + if (count > (length - offset)) { goto done; } } src = buffer + offset; @@ -1496,30 +1369,30 @@ count = (length - offset) * 8; } else { if (count == BINARY_NOCOUNT) { count = 1; } - if (count > (size_t)(length - offset) * 8) { + if (count > (length - offset) * 8) { goto done; } } src = buffer + offset; valuePtr = Tcl_NewObj(); Tcl_SetObjLength(valuePtr, count); dest = TclGetString(valuePtr); if (cmd == 'b') { - for (i = 0; (size_t)i < count; i++) { + for (i = 0; i < count; i++) { if (i % 8) { value >>= 1; } else { value = *src++; } *dest++ = (char) ((value & 1) ? '1' : '0'); } } else { - for (i = 0; (size_t)i < count; i++) { + for (i = 0; i < count; i++) { if (i % 8) { value <<= 1; } else { value = *src++; } @@ -1561,26 +1434,26 @@ valuePtr = Tcl_NewObj(); Tcl_SetObjLength(valuePtr, count); dest = TclGetString(valuePtr); if (cmd == 'h') { - for (i = 0; (size_t)i < count; i++) { + for (i = 0; i < count; i++) { if (i % 2) { value >>= 4; } else { value = *src++; } - *dest++ = hexdigit[value & 0xf]; + *dest++ = hexdigit[value & 0xF]; } } else { - for (i = 0; (size_t)i < count; i++) { + for (i = 0; i < count; i++) { if (i % 2) { value <<= 4; } else { value = *src++; } - *dest++ = hexdigit[(value >> 4) & 0xf]; + *dest++ = hexdigit[(value >> 4) & 0xF]; } } resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr, TCL_LEAVE_ERR_MSG); @@ -1627,11 +1500,11 @@ if (arg >= objc) { DeleteScanNumberCache(numberCachePtr); goto badIndex; } if (count == BINARY_NOCOUNT) { - if ((length - offset) < (size_t)size) { + if ((length - offset) < size) { goto done; } valuePtr = ScanNumber(buffer+offset, cmd, flags, &numberCachePtr); offset += size; @@ -1642,11 +1515,11 @@ if ((length - offset) < (count * size)) { goto done; } valuePtr = Tcl_NewObj(); src = buffer + offset; - for (i = 0; (size_t)i < count; i++) { + for (i = 0; i < count; i++) { elementPtr = ScanNumber(src, cmd, flags, &numberCachePtr); src += size; Tcl_ListObjAppendElement(NULL, valuePtr, elementPtr); } offset += count * size; @@ -1663,21 +1536,21 @@ } case 'x': if (count == BINARY_NOCOUNT) { count = 1; } - if ((count == BINARY_ALL) || (count > length - offset)) { + if ((count == BINARY_ALL) || (count > (length - offset))) { offset = length; } else { offset += count; } break; case 'X': if (count == BINARY_NOCOUNT) { count = 1; } - if ((count == BINARY_ALL) || (count > (size_t)offset)) { + if ((count == BINARY_ALL) || (count > offset)) { offset = 0; } else { offset -= count; } break; @@ -1702,11 +1575,11 @@ /* * Set the result to the last position of the cursor. */ done: - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(arg - 3)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(arg - 3)); DeleteScanNumberCache(numberCachePtr); return TCL_OK; badCount: @@ -1717,15 +1590,15 @@ errorString = "not enough arguments for all format specifiers"; goto error; badField: { - Tcl_UniChar ch = 0; - char buf[TCL_UTF_MAX + 1] = ""; + int ch; + char buf[8] = ""; - TclUtfToUniChar(errorString, &ch); - buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; + TclUtfToUCS4(errorString, &ch); + buf[TclUCS4ToUtf(ch, buf)] = '\0'; Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad field specifier \"%s\"", buf)); return TCL_ERROR; } @@ -1757,11 +1630,11 @@ static int GetFormatSpec( const char **formatPtr, /* Pointer to format string. */ char *cmdPtr, /* Pointer to location of command char. */ - size_t *countPtr, /* Pointer to repeat count value. */ + int *countPtr, /* Pointer to repeat count value. */ int *flagsPtr) /* Pointer to field flags */ { /* * Skip any leading blanks. */ @@ -1923,11 +1796,11 @@ static void CopyNumber( const void *from, /* source */ void *to, /* destination */ - size_t length, /* Number of bytes to copy */ + unsigned length, /* Number of bytes to copy */ int type) /* What type of thing are we copying? */ { switch (NeedReversing(type)) { case 0: memcpy(to, from, length); @@ -2010,10 +1883,11 @@ * errors. */ int type, /* Type of number to format. */ Tcl_Obj *src, /* Number to format. */ unsigned char **cursorPtr) /* Pointer to index into destination buffer. */ { + long value; double dvalue; Tcl_WideInt wvalue; float fvalue; switch (type) { @@ -2025,15 +1899,14 @@ * returns TCL_ERROR for NaN, but we can check by comparing the * object's type pointer. */ if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) { - const Tcl_ObjIntRep *irPtr = TclFetchIntRep(src, &tclDoubleType); - if (irPtr == NULL) { + if (src->typePtr != &tclDoubleType) { return TCL_ERROR; } - dvalue = irPtr->doubleValue; + dvalue = src->internalRep.doubleValue; } CopyNumber(&dvalue, *cursorPtr, sizeof(double), type); *cursorPtr += sizeof(double); return TCL_OK; @@ -2045,16 +1918,14 @@ * returns TCL_ERROR for NaN, but we can check by comparing the * object's type pointer. */ if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) { - const Tcl_ObjIntRep *irPtr = TclFetchIntRep(src, &tclDoubleType); - - if (irPtr == NULL) { + if (src->typePtr != &tclDoubleType) { return TCL_ERROR; } - dvalue = irPtr->doubleValue; + dvalue = src->internalRep.doubleValue; } /* * Because some compilers will generate floating point exceptions on * an overflow cast (e.g. Borland), we restrict the values to the @@ -2074,11 +1945,11 @@ * 64-bit integer values. */ case 'w': case 'W': case 'm': - if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, src, &wvalue) != TCL_OK) { return TCL_ERROR; } if (NeedReversing(type)) { *(*cursorPtr)++ = UCHAR(wvalue); *(*cursorPtr)++ = UCHAR(wvalue >> 8); @@ -2104,52 +1975,52 @@ * 32-bit integer values. */ case 'i': case 'I': case 'n': - if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) { + if (TclGetLongFromObj(interp, src, &value) != TCL_OK) { return TCL_ERROR; } if (NeedReversing(type)) { - *(*cursorPtr)++ = UCHAR(wvalue); - *(*cursorPtr)++ = UCHAR(wvalue >> 8); - *(*cursorPtr)++ = UCHAR(wvalue >> 16); - *(*cursorPtr)++ = UCHAR(wvalue >> 24); + *(*cursorPtr)++ = UCHAR(value); + *(*cursorPtr)++ = UCHAR(value >> 8); + *(*cursorPtr)++ = UCHAR(value >> 16); + *(*cursorPtr)++ = UCHAR(value >> 24); } else { - *(*cursorPtr)++ = UCHAR(wvalue >> 24); - *(*cursorPtr)++ = UCHAR(wvalue >> 16); - *(*cursorPtr)++ = UCHAR(wvalue >> 8); - *(*cursorPtr)++ = UCHAR(wvalue); + *(*cursorPtr)++ = UCHAR(value >> 24); + *(*cursorPtr)++ = UCHAR(value >> 16); + *(*cursorPtr)++ = UCHAR(value >> 8); + *(*cursorPtr)++ = UCHAR(value); } return TCL_OK; /* * 16-bit integer values. */ case 's': case 'S': case 't': - if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) { + if (TclGetLongFromObj(interp, src, &value) != TCL_OK) { return TCL_ERROR; } if (NeedReversing(type)) { - *(*cursorPtr)++ = UCHAR(wvalue); - *(*cursorPtr)++ = UCHAR(wvalue >> 8); + *(*cursorPtr)++ = UCHAR(value); + *(*cursorPtr)++ = UCHAR(value >> 8); } else { - *(*cursorPtr)++ = UCHAR(wvalue >> 8); - *(*cursorPtr)++ = UCHAR(wvalue); + *(*cursorPtr)++ = UCHAR(value >> 8); + *(*cursorPtr)++ = UCHAR(value); } return TCL_OK; /* * 8-bit integer values. */ case 'c': - if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) { + if (TclGetLongFromObj(interp, src, &value) != TCL_OK) { return TCL_ERROR; } - *(*cursorPtr)++ = UCHAR(wvalue); + *(*cursorPtr)++ = UCHAR(value); return TCL_OK; default: Tcl_Panic("unexpected fallthrough"); return TCL_ERROR; @@ -2271,11 +2142,11 @@ value -= (((unsigned) 1) << 31); } returnNumericObject: if (*numberCachePtrPtr == NULL) { - return Tcl_NewWideIntObj(value); + return Tcl_NewLongObj(value); } else { register Tcl_HashTable *tablePtr = *numberCachePtrPtr; register Tcl_HashEntry *hPtr; int isNew; @@ -2282,11 +2153,11 @@ hPtr = Tcl_CreateHashEntry(tablePtr, INT2PTR(value), &isNew); if (!isNew) { return Tcl_GetHashValue(hPtr); } if (tablePtr->numEntries <= BINARY_SCAN_MAX_CACHE) { - register Tcl_Obj *objPtr = Tcl_NewWideIntObj(value); + register Tcl_Obj *objPtr = Tcl_NewLongObj(value); Tcl_IncrRefCount(objPtr); Tcl_SetHashValue(hPtr, objPtr); return objPtr; } @@ -2300,11 +2171,11 @@ * cannot trigger this. */ DeleteScanNumberCache(tablePtr); *numberCachePtrPtr = NULL; - return Tcl_NewWideIntObj(value); + return Tcl_NewLongObj(value); } /* * Do not cache wide (64-bit) values; they are already too large to * use as keys. @@ -2334,11 +2205,11 @@ } if (flags & BINARY_UNSIGNED) { Tcl_Obj *bigObj = NULL; mp_int big; - TclInitBignumFromWideUInt(&big, uwvalue); + TclBNInitBignumFromWideUInt(&big, uwvalue); bigObj = Tcl_NewBignumObj(&big); return bigObj; } return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue); @@ -2455,23 +2326,23 @@ Tcl_Obj *const objv[]) { Tcl_Obj *resultObj = NULL; unsigned char *data = NULL; unsigned char *cursor = NULL; - size_t offset = 0, count = 0; + int offset = 0, count = 0; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "data"); return TCL_ERROR; } TclNewObj(resultObj); - data = TclGetByteArrayFromObj(objv[1], &count); + data = Tcl_GetByteArrayFromObj(objv[1], &count); cursor = Tcl_SetByteArrayLength(resultObj, count * 2); for (offset = 0; offset < count; ++offset) { - *cursor++ = HexDigits[(data[offset] >> 4) & 0x0f]; - *cursor++ = HexDigits[data[offset] & 0x0f]; + *cursor++ = HexDigits[(data[offset] >> 4) & 0x0F]; + *cursor++ = HexDigits[data[offset] & 0x0F]; } Tcl_SetObjResult(interp, resultObj); return TCL_OK; } @@ -2499,12 +2370,12 @@ Tcl_Obj *const objv[]) { Tcl_Obj *resultObj = NULL; unsigned char *data, *datastart, *dataend; unsigned char *begin, *cursor, c; - int i, index, value, size, cut = 0, strict = 0; - size_t count = 0; + int i, index, value, size, pure, count = 0, cut = 0, strict = 0; + Tcl_UniChar ch = 0; enum {OPT_STRICT }; static const char *const optStrings[] = { "-strict", NULL }; if (objc < 2 || objc > 3) { Tcl_WrongNumArgs(interp, 1, objv, "?options? data"); @@ -2521,12 +2392,13 @@ break; } } TclNewObj(resultObj); - datastart = data = (unsigned char *) - TclGetStringFromObj(objv[objc - 1], &count); + pure = TclIsPureByteArray(objv[objc - 1]); + datastart = data = pure ? Tcl_GetByteArrayFromObj(objv[objc - 1], &count) + : (unsigned char *) TclGetStringFromObj(objv[objc - 1], &count); dataend = data + count; size = (count + 1) / 2; begin = cursor = Tcl_SetByteArrayLength(resultObj, size); while (data < dataend) { value = 0; @@ -2535,11 +2407,11 @@ value <<= 4; break; } c = *data++; - if (!isxdigit(UCHAR(c))) { + if (!isxdigit((int) c)) { if (strict || !TclIsSpaceProc(c)) { goto badChar; } i--; continue; @@ -2551,11 +2423,11 @@ c += ('0' - 'A') + 10; } if (c > 16) { c += ('A' - 'a'); } - value |= c & 0xf; + value |= c & 0xF; } if (i < 2) { cut++; } *cursor++ = UCHAR(value); @@ -2567,32 +2439,32 @@ Tcl_SetByteArrayLength(resultObj, cursor - begin - cut); Tcl_SetObjResult(interp, resultObj); return TCL_OK; badChar: + if (pure) { + ch = c; + } else { + TclUtfToUniChar((const char *)(data - 1), &ch); + } TclDecrRefCount(resultObj); Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invalid hexadecimal digit \"%c\" at position %" TCL_Z_MODIFIER "u", - c, data - datastart - 1)); + "invalid hexadecimal digit \"%c\" at position %d", + ch, (int) (data - datastart - 1))); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * BinaryEncode64 -- * - * This implements a generic 6 bit binary encoding. Input is broken into - * 6 bit chunks and a lookup table passed in via clientData is used to - * turn these values into output characters. This is used to implement - * base64 binary encodings. + * This procedure implements the "binary encode base64" Tcl command. * * Results: - * Interp result set to an encoded byte array object - * - * Side effects: - * None + * The base64 encoded value prescribed by the input arguments. * *---------------------------------------------------------------------- */ #define OUTPUT(c) \ @@ -2617,16 +2489,15 @@ Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Tcl_Obj *resultObj; - unsigned char *data, *cursor, *limit; + unsigned char *data, *limit; int maxlen = 0; const char *wrapchar = "\n"; - size_t wrapcharlen = 1; - int i, index, size, outindex = 0; - size_t offset, count = 0; + int wrapcharlen = 1; + int offset, i, index, size, outindex = 0, count = 0, purewrap = 1; enum { OPT_MAXLEN, OPT_WRAPCHAR }; static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL }; if (objc < 2 || objc % 2 != 0) { Tcl_WrongNumArgs(interp, 1, objv, @@ -2650,31 +2521,48 @@ "LINE_LENGTH", NULL); return TCL_ERROR; } break; case OPT_WRAPCHAR: - wrapchar = TclGetStringFromObj(objv[i + 1], &wrapcharlen); - if (wrapcharlen == 0) { - maxlen = 0; + purewrap = TclIsPureByteArray(objv[i + 1]); + if (purewrap) { + wrapchar = (const char *) Tcl_GetByteArrayFromObj( + objv[i + 1], &wrapcharlen); + } else { + wrapchar = Tcl_GetStringFromObj(objv[i + 1], &wrapcharlen); } break; } } + if (wrapcharlen == 0) { + maxlen = 0; + } resultObj = Tcl_NewObj(); - data = TclGetByteArrayFromObj(objv[objc - 1], &count); + data = Tcl_GetByteArrayFromObj(objv[objc - 1], &count); if (count > 0) { + unsigned char *cursor = NULL; + size = (((count * 4) / 3) + 3) & ~3; /* ensure 4 byte chunks */ if (maxlen > 0 && size > maxlen) { int adjusted = size + (wrapcharlen * (size / maxlen)); if (size % maxlen == 0) { adjusted -= wrapcharlen; } size = adjusted; + + if (purewrap == 0) { + /* Wrapchar is (possibly) non-byte, so build result as + * general string, not bytearray */ + Tcl_SetObjLength(resultObj, size); + cursor = (unsigned char *) TclGetString(resultObj); + } } - cursor = Tcl_SetByteArrayLength(resultObj, size); + if (cursor == NULL) { + cursor = Tcl_SetByteArrayLength(resultObj, size); + } limit = cursor + size; for (offset = 0; offset < count; offset += 3) { unsigned char d[3] = {0, 0, 0}; for (i = 0; i < 3 && offset + i < count; ++i) { @@ -2681,16 +2569,16 @@ d[i] = data[offset + i]; } OUTPUT(B64Digits[d[0] >> 2]); OUTPUT(B64Digits[((d[0] & 0x03) << 4) | (d[1] >> 4)]); if (offset + 1 < count) { - OUTPUT(B64Digits[((d[1] & 0x0f) << 2) | (d[2] >> 6)]); + OUTPUT(B64Digits[((d[1] & 0x0F) << 2) | (d[2] >> 6)]); } else { OUTPUT(B64Digits[64]); } if (offset+2 < count) { - OUTPUT(B64Digits[d[2] & 0x3f]); + OUTPUT(B64Digits[d[2] & 0x3F]); } else { OUTPUT(B64Digits[64]); } } } @@ -2725,15 +2613,15 @@ int objc, Tcl_Obj *const objv[]) { Tcl_Obj *resultObj; unsigned char *data, *start, *cursor; - int rawLength, n, i, bits, index; + int offset, count, rawLength, n, i, j, bits, index; int lineLength = 61; - const unsigned char SingleNewline[] = { (unsigned char) '\n' }; + const unsigned char SingleNewline[] = { UCHAR('\n') }; const unsigned char *wrapchar = SingleNewline; - size_t j, offset, count = 0, wrapcharlen = sizeof(SingleNewline); + int wrapcharlen = sizeof(SingleNewline); enum { OPT_MAXLEN, OPT_WRAPCHAR }; static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL }; if (objc < 2 || objc % 2 != 0) { Tcl_WrongNumArgs(interp, 1, objv, @@ -2749,20 +2637,51 @@ case OPT_MAXLEN: if (Tcl_GetIntFromObj(interp, objv[i + 1], &lineLength) != TCL_OK) { return TCL_ERROR; } - if (lineLength < 3 || lineLength > 85) { + if (lineLength < 5 || lineLength > 85) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "line length out of range", -1)); Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", "LINE_LENGTH", NULL); return TCL_ERROR; } + lineLength = ((lineLength - 1) & -4) + 1; /* 5, 9, 13 ... */ break; case OPT_WRAPCHAR: - wrapchar = TclGetByteArrayFromObj(objv[i + 1], &wrapcharlen); + wrapchar = (const unsigned char *) TclGetStringFromObj( + objv[i + 1], &wrapcharlen); + { + const unsigned char *p = wrapchar; + int 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", NULL); + return TCL_ERROR; + } + } + if (numBytes) { + goto badwrap; + } + } break; } } /* @@ -2770,11 +2689,11 @@ * enough". */ resultObj = Tcl_NewObj(); offset = 0; - data = TclGetByteArrayFromObj(objv[objc - 1], &count); + data = Tcl_GetByteArrayFromObj(objv[objc - 1], &count); rawLength = (lineLength - 1) * 3 / 4; start = cursor = Tcl_SetByteArrayLength(resultObj, (lineLength + wrapcharlen) * ((count + (rawLength - 1)) / rawLength)); n = bits = 0; @@ -2795,16 +2714,16 @@ *cursor++ = UueDigits[lineLen]; for (i = 0 ; i < lineLen ; i++) { n <<= 8; n |= data[offset++]; for (bits += 8; bits > 6 ; bits -= 6) { - *cursor++ = UueDigits[(n >> (bits - 6)) & 0x3f]; + *cursor++ = UueDigits[(n >> (bits - 6)) & 0x3F]; } } if (bits > 0) { n <<= 8; - *cursor++ = UueDigits[(n >> (bits + 2)) & 0x3f]; + *cursor++ = UueDigits[(n >> (bits + 2)) & 0x3F]; bits = 0; } for (j = 0 ; j < wrapcharlen ; ++j) { *cursor++ = wrapchar[j]; } @@ -2843,13 +2762,13 @@ Tcl_Obj *const objv[]) { Tcl_Obj *resultObj = NULL; unsigned char *data, *datastart, *dataend; unsigned char *begin, *cursor; - int i, index, size, strict = 0, lineLen; - size_t count = 0; + int i, index, size, pure, count = 0, strict = 0, lineLen; unsigned char c; + Tcl_UniChar ch = 0; enum { OPT_STRICT }; static const char *const optStrings[] = { "-strict", NULL }; if (objc < 2 || objc > 3) { Tcl_WrongNumArgs(interp, 1, objv, "?options? data"); @@ -2866,12 +2785,13 @@ break; } } TclNewObj(resultObj); - datastart = data = (unsigned char *) - TclGetStringFromObj(objv[objc - 1], &count); + pure = TclIsPureByteArray(objv[objc - 1]); + datastart = data = pure ? Tcl_GetByteArrayFromObj(objv[objc - 1], &count) + : (unsigned char *) TclGetStringFromObj(objv[objc - 1], &count); dataend = data + count; size = ((count + 3) & ~3) * 3 / 4; begin = cursor = Tcl_SetByteArrayLength(resultObj, size); lineLen = -1; @@ -2892,11 +2812,11 @@ goto badUu; } i--; continue; } - lineLen = (c - 32) & 0x3f; + lineLen = (c - 32) & 0x3F; } /* * Now we read a four-character grouping. */ @@ -2921,18 +2841,18 @@ /* * Translate that grouping into (up to) three binary bytes output. */ if (lineLen > 0) { - *cursor++ = (((d[0] - 0x20) & 0x3f) << 2) - | (((d[1] - 0x20) & 0x3f) >> 4); - if (--lineLen > 0) { - *cursor++ = (((d[1] - 0x20) & 0x3f) << 4) - | (((d[2] - 0x20) & 0x3f) >> 2); - if (--lineLen > 0) { - *cursor++ = (((d[2] - 0x20) & 0x3f) << 6) - | (((d[3] - 0x20) & 0x3f)); + *cursor++ = (((d[0] - 0x20) & 0x3F) << 2) + | (((d[1] - 0x20) & 0x3F) >> 4); + if (--lineLen > 0) { + *cursor++ = (((d[1] - 0x20) & 0x3F) << 4) + | (((d[2] - 0x20) & 0x3F) >> 2); + if (--lineLen > 0) { + *cursor++ = (((d[2] - 0x20) & 0x3F) << 6) + | (((d[3] - 0x20) & 0x3F)); lineLen--; } } } @@ -2973,13 +2893,18 @@ Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "SHORT", NULL); TclDecrRefCount(resultObj); return TCL_ERROR; badUu: + if (pure) { + ch = c; + } else { + TclUtfToUniChar((const char *)(data - 1), &ch); + } Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invalid uuencode character \"%c\" at position %" TCL_Z_MODIFIER "u", - c, data - datastart - 1)); + "invalid uuencode character \"%c\" at position %d", + ch, (int) (data - datastart - 1))); Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL); TclDecrRefCount(resultObj); return TCL_ERROR; } @@ -3008,13 +2933,13 @@ { Tcl_Obj *resultObj = NULL; unsigned char *data, *datastart, *dataend, c = '\0'; unsigned char *begin = NULL; unsigned char *cursor = NULL; - int strict = 0; - int i, index, size, cut = 0; - size_t count = 0; + int pure, strict = 0; + int i, index, size, cut = 0, count = 0; + Tcl_UniChar ch = 0; enum { OPT_STRICT }; static const char *const optStrings[] = { "-strict", NULL }; if (objc < 2 || objc > 3) { Tcl_WrongNumArgs(interp, 1, objv, "?options? data"); @@ -3031,12 +2956,13 @@ break; } } TclNewObj(resultObj); - datastart = data = (unsigned char *) - TclGetStringFromObj(objv[objc - 1], &count); + pure = TclIsPureByteArray(objv[objc - 1]); + datastart = data = pure ? Tcl_GetByteArrayFromObj(objv[objc - 1], &count) + : (unsigned char *) TclGetStringFromObj(objv[objc - 1], &count); dataend = data + count; size = ((count + 3) & ~3) * 3 / 4; begin = cursor = Tcl_SetByteArrayLength(resultObj, size); while (data < dataend) { unsigned long value = 0; @@ -3082,43 +3008,43 @@ if (cut) { if (c == '=' && i > 1) { value <<= 6; cut++; - } else if (!strict && TclIsSpaceProc(c)) { + } else if (!strict) { i--; } else { goto bad64; } } else if (c >= 'A' && c <= 'Z') { - value = (value << 6) | ((c - 'A') & 0x3f); + value = (value << 6) | ((c - 'A') & 0x3F); } else if (c >= 'a' && c <= 'z') { - value = (value << 6) | ((c - 'a' + 26) & 0x3f); + value = (value << 6) | ((c - 'a' + 26) & 0x3F); } else if (c >= '0' && c <= '9') { - value = (value << 6) | ((c - '0' + 52) & 0x3f); + value = (value << 6) | ((c - '0' + 52) & 0x3F); } else if (c == '+') { - value = (value << 6) | 0x3e; + value = (value << 6) | 0x3E; } else if (c == '/') { - value = (value << 6) | 0x3f; + value = (value << 6) | 0x3F; } else if (c == '=' && (!strict || i > 1)) { /* * "=" and "a=" is rather bad64 error case in strict mode. */ value <<= 6; if (i) { cut++; } - } else if (strict || !TclIsSpaceProc(c)) { + } else if (strict) { goto bad64; } else { i--; } } - *cursor++ = UCHAR((value >> 16) & 0xff); - *cursor++ = UCHAR((value >> 8) & 0xff); - *cursor++ = UCHAR(value & 0xff); + *cursor++ = UCHAR((value >> 16) & 0xFF); + *cursor++ = UCHAR((value >> 8) & 0xFF); + *cursor++ = UCHAR(value & 0xFF); /* * Since = is only valid within the final block, if it was encountered * but there are still more input characters, confirm that strict mode * is off and all subsequent characters are whitespace. @@ -3125,26 +3051,33 @@ */ if (cut && data < dataend) { if (strict) { goto bad64; - } - for (; data < dataend; data++) { - if (!TclIsSpaceProc(*data)) { - goto bad64; - } } } } Tcl_SetByteArrayLength(resultObj, cursor - begin - cut); Tcl_SetObjResult(interp, resultObj); return TCL_OK; bad64: + if (pure) { + ch = c; + } else { + /* The decoder is byte-oriented. If we saw a byte that's not a + * valid member of the base64 alphabet, it could be the lead byte + * of a multi-byte character. */ + + /* Safe because we know data is NUL-terminated */ + TclUtfToUniChar((const char *)(data - 1), &ch); + } + Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invalid base64 character \"%c\" at position %" TCL_Z_MODIFIER "u", - (char) c, data - datastart - 1)); + "invalid base64 character \"%c\" at position %d", ch, + (int) (data - datastart - 1))); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL); TclDecrRefCount(resultObj); return TCL_ERROR; } /* Index: generic/tclCkalloc.c ================================================================== --- generic/tclCkalloc.c +++ generic/tclCkalloc.c @@ -18,11 +18,13 @@ #include "tclInt.h" #define FALSE 0 #define TRUE 1 +#undef Tcl_Alloc #undef Tcl_Free +#undef Tcl_Realloc #undef Tcl_AttemptAlloc #undef Tcl_AttemptRealloc #ifdef TCL_MEM_DEBUG @@ -29,19 +31,19 @@ /* * One of the following structures is allocated each time the * "memory tag" command is invoked, to hold the current tag. */ -typedef struct { - size_t refCount; /* Number of mem_headers referencing this +typedef struct MemTag { + int refCount; /* Number of mem_headers referencing this * tag. */ char string[1]; /* Actual size of string will be as large as * needed for actual tag. This must be the * last field in the structure. */ } MemTag; -#define TAG_SIZE(bytesInString) ((offsetof(MemTag, string) + 1) + bytesInString) +#define TAG_SIZE(bytesInString) ((unsigned) ((TclOffset(MemTag, string) + 1) + bytesInString)) static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers (set * by "memory tag" command). */ /* @@ -48,18 +50,18 @@ * One of the following structures is allocated just before each dynamically * allocated chunk of memory, both to record information about the chunk and * to help detect chunk under-runs. */ -#define LOW_GUARD_SIZE (8 + (32 - (sizeof(size_t) + sizeof(int)))%8) +#define LOW_GUARD_SIZE (8 + (32 - (sizeof(long) + sizeof(int)))%8) struct mem_header { struct mem_header *flink; struct mem_header *blink; MemTag *tagPtr; /* Tag from "memory tag" command; may be * NULL. */ const char *file; - size_t length; + long length; int line; unsigned char low_guard[LOW_GUARD_SIZE]; /* Aligns body on 8-byte boundary, plus * provides at least 8 additional guard bytes * to detect underruns. */ @@ -85,18 +87,18 @@ */ #define BODY_OFFSET \ ((size_t) (&((struct mem_header *) 0)->body)) -static unsigned int total_mallocs = 0; -static unsigned int total_frees = 0; +static int total_mallocs = 0; +static int total_frees = 0; static size_t current_bytes_malloced = 0; static size_t maximum_bytes_malloced = 0; -static unsigned int current_malloc_packets = 0; -static unsigned int maximum_malloc_packets = 0; -static unsigned int break_on_malloc = 0; -static unsigned int trace_on_at_malloc = 0; +static int current_malloc_packets = 0; +static int maximum_malloc_packets = 0; +static int break_on_malloc = 0; +static int trace_on_at_malloc = 0; static int alloc_tracing = FALSE; static int init_malloced_bodies = TRUE; #ifdef MEM_VALIDATE static int validate_memory = TRUE; #else @@ -117,11 +119,11 @@ * information. */ /* * Mutex to serialize allocations. This is a low-level mutex that must be * explicitly initialized. This is necessary because the self initializing - * mutexes use Tcl_Alloc... + * mutexes use ckalloc... */ static Tcl_Mutex *ckallocMutexPtr; static int ckallocInit = 0; @@ -152,11 +154,11 @@ TclInitDbCkalloc(void) { if (!ckallocInit) { ckallocInit = 1; ckallocMutexPtr = Tcl_GetAllocMutex(); -#if !TCL_THREADS +#ifndef TCL_THREADS /* Silence compiler warning */ (void)ckallocMutexPtr; #endif } } @@ -180,22 +182,22 @@ if (clientData == NULL) { return 0; } sprintf(buf, - "total mallocs %10u\n" - "total frees %10u\n" - "current packets allocated %10u\n" - "current bytes allocated %10" TCL_Z_MODIFIER "u\n" - "maximum packets allocated %10u\n" - "maximum bytes allocated %10" TCL_Z_MODIFIER "u\n", + "total mallocs %10d\n" + "total frees %10d\n" + "current packets allocated %10d\n" + "current bytes allocated %10lu\n" + "maximum packets allocated %10d\n" + "maximum bytes allocated %10lu\n", total_mallocs, total_frees, current_malloc_packets, - current_bytes_malloced, + (unsigned long)current_bytes_malloced, maximum_malloc_packets, - maximum_bytes_malloced); + (unsigned long)maximum_bytes_malloced); if (flags == 0) { fprintf((FILE *)clientData, "%s", buf); } else { /* Assume objPtr to append to */ Tcl_AppendToObj((Tcl_Obj *) clientData, buf, -1); @@ -240,21 +242,21 @@ for (idx = 0; idx < LOW_GUARD_SIZE; idx++) { byte = *(memHeaderP->low_guard + idx); if (byte != GUARD_VALUE) { guard_failed = TRUE; fflush(stdout); - byte &= 0xff; - fprintf(stderr, "low guard byte %" TCL_Z_MODIFIER "u is 0x%x \t%c\n", idx, byte, + byte &= 0xFF; + fprintf(stderr, "low guard byte %d is 0x%x \t%c\n", (int)idx, byte, (isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */ } } if (guard_failed) { - TclDumpMemoryInfo(stderr, 0); - fprintf(stderr, "low guard failed at %p, %s %d\n", - memHeaderP->body, file, line); + TclDumpMemoryInfo((ClientData) stderr, 0); + fprintf(stderr, "low guard failed at %lx, %s %d\n", + (long unsigned) memHeaderP->body, file, line); fflush(stderr); /* In case name pointer is bad. */ - fprintf(stderr, "%" TCL_Z_MODIFIER "u bytes allocated at (%s %d)\n", memHeaderP->length, + fprintf(stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length, memHeaderP->file, memHeaderP->line); Tcl_Panic("Memory validation failure"); } hiPtr = (unsigned char *)memHeaderP->body + memHeaderP->length; @@ -261,22 +263,22 @@ for (idx = 0; idx < HIGH_GUARD_SIZE; idx++) { byte = *(hiPtr + idx); if (byte != GUARD_VALUE) { guard_failed = TRUE; fflush(stdout); - byte &= 0xff; - fprintf(stderr, "hi guard byte %" TCL_Z_MODIFIER "u is 0x%x \t%c\n", idx, byte, + byte &= 0xFF; + fprintf(stderr, "hi guard byte %d is 0x%x \t%c\n", (int)idx, byte, (isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */ } } if (guard_failed) { - TclDumpMemoryInfo(stderr, 0); - fprintf(stderr, "high guard failed at %p, %s %d\n", - memHeaderP->body, file, line); + TclDumpMemoryInfo((ClientData) stderr, 0); + fprintf(stderr, "high guard failed at %lx, %s %d\n", + (long unsigned) memHeaderP->body, file, line); fflush(stderr); /* In case name pointer is bad. */ - fprintf(stderr, "%" TCL_Z_MODIFIER "u bytes allocated at (%s %d)\n", + fprintf(stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length, memHeaderP->file, memHeaderP->line); Tcl_Panic("Memory validation failure"); } @@ -355,12 +357,13 @@ } Tcl_MutexLock(ckallocMutexPtr); for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) { address = &memScanP->body[0]; - fprintf(fileP, "%p - %p %" TCL_Z_MODIFIER "u @ %s %d %s", - address, address + memScanP->length - 1, + fprintf(fileP, "%8lx - %8lx %7ld @ %s %d %s", + (long unsigned) address, + (long unsigned) address + memScanP->length - 1, memScanP->length, memScanP->file, memScanP->line, (memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string); (void) fputc('\n', fileP); } Tcl_MutexUnlock(ckallocMutexPtr); @@ -372,28 +375,28 @@ } /* *---------------------------------------------------------------------- * - * Tcl_DbCkalloc - debugging Tcl_Alloc + * Tcl_DbCkalloc - debugging ckalloc * * Allocate the requested amount of space plus some extra for guard bands * at both ends of the request, plus a size, panicing if there isn't * enough space, then write in the guard bands and return the address of * the space in the middle that the user asked for. * * The second and third arguments are file and line, these contain the * filename and line number corresponding to the caller. These are sent - * by the Tcl_Alloc macro; it uses the preprocessor autodefines __FILE__ + * by the ckalloc macro; it uses the preprocessor autodefines __FILE__ * and __LINE__. * *---------------------------------------------------------------------- */ -void * +char * Tcl_DbCkalloc( - size_t size, + unsigned int size, const char *file, int line) { struct mem_header *result = NULL; @@ -406,12 +409,12 @@ result = (struct mem_header *) TclpAlloc(size + sizeof(struct mem_header) + HIGH_GUARD_SIZE); } if (result == NULL) { fflush(stdout); - TclDumpMemoryInfo(stderr, 0); - Tcl_Panic("unable to alloc %" TCL_Z_MODIFIER "u bytes, %s line %d", size, file, line); + TclDumpMemoryInfo((ClientData) stderr, 0); + Tcl_Panic("unable to alloc %u bytes, %s line %d", size, file, line); } /* * Fill in guard zones and size. Also initialize the contents of the block * with bogus bytes to detect uses of initialized data. Link into @@ -445,26 +448,26 @@ allocHead = result; total_mallocs++; if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) { (void) fflush(stdout); - fprintf(stderr, "reached malloc trace enable point (%u)\n", + fprintf(stderr, "reached malloc trace enable point (%d)\n", total_mallocs); fflush(stderr); alloc_tracing = TRUE; trace_on_at_malloc = 0; } if (alloc_tracing) { - fprintf(stderr,"Tcl_Alloc %p %" TCL_Z_MODIFIER "u %s %d\n", - result->body, size, file, line); + fprintf(stderr,"ckalloc %lx %u %s %d\n", + (long unsigned int) result->body, size, file, line); } if (break_on_malloc && (total_mallocs >= break_on_malloc)) { break_on_malloc = 0; (void) fflush(stdout); - Tcl_Panic("reached malloc break limit (%u)", total_mallocs); + Tcl_Panic("reached malloc break limit (%d)", total_mallocs); } current_malloc_packets++; if (current_malloc_packets > maximum_malloc_packets) { maximum_malloc_packets = current_malloc_packets; @@ -477,13 +480,13 @@ Tcl_MutexUnlock(ckallocMutexPtr); return result->body; } -void * +char * Tcl_AttemptDbCkalloc( - size_t size, + unsigned int size, const char *file, int line) { struct mem_header *result = NULL; @@ -496,11 +499,11 @@ result = (struct mem_header *) TclpAlloc(size + sizeof(struct mem_header) + HIGH_GUARD_SIZE); } if (result == NULL) { fflush(stdout); - TclDumpMemoryInfo(stderr, 0); + TclDumpMemoryInfo((ClientData) stderr, 0); return NULL; } /* * Fill in guard zones and size. Also initialize the contents of the block @@ -542,12 +545,12 @@ alloc_tracing = TRUE; trace_on_at_malloc = 0; } if (alloc_tracing) { - fprintf(stderr,"Tcl_Alloc %p %" TCL_Z_MODIFIER "u %s %d\n", - result->body, size, file, line); + fprintf(stderr,"ckalloc %lx %u %s %d\n", + (long unsigned int) result->body, size, file, line); } if (break_on_malloc && (total_mallocs >= break_on_malloc)) { break_on_malloc = 0; (void) fflush(stdout); @@ -569,28 +572,28 @@ } /* *---------------------------------------------------------------------- * - * Tcl_DbCkfree - debugging Tcl_Free + * Tcl_DbCkfree - debugging ckfree * * Verify that the low and high guards are intact, and if so then free * the buffer else Tcl_Panic. * * The guards are erased after being checked to catch duplicate frees. * * The second and third arguments are file and line, these contain the * filename and line number corresponding to the caller. These are sent - * by the Tcl_Free macro; it uses the preprocessor autodefines __FILE__ and + * by the ckfree macro; it uses the preprocessor autodefines __FILE__ and * __LINE__. * *---------------------------------------------------------------------- */ void Tcl_DbCkfree( - void *ptr, + char *ptr, const char *file, int line) { struct mem_header *memp; @@ -607,12 +610,12 @@ */ memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET); if (alloc_tracing) { - fprintf(stderr, "Tcl_Free %p %" TCL_Z_MODIFIER "u %s %d\n", - memp->body, memp->length, file, line); + fprintf(stderr, "ckfree %lx %ld %s %d\n", + (long unsigned int) memp->body, memp->length, file, line); } if (validate_memory) { Tcl_ValidateAllMemory(file, line); } @@ -626,11 +629,12 @@ total_frees++; current_malloc_packets--; current_bytes_malloced -= memp->length; if (memp->tagPtr != NULL) { - if ((memp->tagPtr->refCount-- <= 1) && (curTagPtr != memp->tagPtr)) { + memp->tagPtr->refCount--; + if ((memp->tagPtr->refCount == 0) && (curTagPtr != memp->tagPtr)) { TclpFree((char *) memp->tagPtr); } } /* @@ -651,29 +655,29 @@ } /* *-------------------------------------------------------------------- * - * Tcl_DbCkrealloc - debugging Tcl_Realloc + * Tcl_DbCkrealloc - debugging ckrealloc * * Reallocate a chunk of memory by allocating a new one of the right * size, copying the old data to the new location, and then freeing the * old memory space, using all the memory checking features of this * package. * *-------------------------------------------------------------------- */ -void * +char * Tcl_DbCkrealloc( - void *ptr, - size_t size, + char *ptr, + unsigned int size, const char *file, int line) { char *newPtr; - size_t copySize; + unsigned int copySize; struct mem_header *memp; if (ptr == NULL) { return Tcl_DbCkalloc(size, file, line); } @@ -683,28 +687,28 @@ */ memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET); copySize = size; - if (copySize > memp->length) { + if (copySize > (unsigned int) memp->length) { copySize = memp->length; } newPtr = Tcl_DbCkalloc(size, file, line); memcpy(newPtr, ptr, copySize); Tcl_DbCkfree(ptr, file, line); return newPtr; } -void * +char * Tcl_AttemptDbCkrealloc( - void *ptr, - size_t size, + char *ptr, + unsigned int size, const char *file, int line) { char *newPtr; - size_t copySize; + unsigned int copySize; struct mem_header *memp; if (ptr == NULL) { return Tcl_AttemptDbCkalloc(size, file, line); } @@ -714,11 +718,11 @@ */ memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET); copySize = size; - if (copySize > memp->length) { + if (copySize > (unsigned int) memp->length) { copySize = memp->length; } newPtr = Tcl_AttemptDbCkalloc(size, file, line); if (newPtr == NULL) { return NULL; @@ -726,10 +730,63 @@ memcpy(newPtr, ptr, copySize); Tcl_DbCkfree(ptr, file, line); return newPtr; } + +/* + *---------------------------------------------------------------------- + * + * Tcl_Alloc, et al. -- + * + * These functions are defined in terms of the debugging versions when + * TCL_MEM_DEBUG is set. + * + * Results: + * Same as the debug versions. + * + * Side effects: + * Same as the debug versions. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_Alloc( + unsigned int size) +{ + return Tcl_DbCkalloc(size, "unknown", 0); +} + +char * +Tcl_AttemptAlloc( + unsigned int size) +{ + return Tcl_AttemptDbCkalloc(size, "unknown", 0); +} + +void +Tcl_Free( + char *ptr) +{ + Tcl_DbCkfree(ptr, "unknown", 0); +} + +char * +Tcl_Realloc( + char *ptr, + unsigned int size) +{ + return Tcl_DbCkrealloc(ptr, size, "unknown", 0); +} +char * +Tcl_AttemptRealloc( + char *ptr, + unsigned int size) +{ + return Tcl_AttemptDbCkrealloc(ptr, size, "unknown", 0); +} /* *---------------------------------------------------------------------- * * MemoryCmd -- @@ -790,28 +847,26 @@ return TCL_ERROR; } return TCL_OK; } if (strcmp(argv[1],"break_on_malloc") == 0) { - int value; if (argc != 3) { goto argError; } - if (Tcl_GetInt(interp, argv[2], &value) != TCL_OK) { + if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) { return TCL_ERROR; } - break_on_malloc = (unsigned int) value; return TCL_OK; } if (strcmp(argv[1],"info") == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%-25s %10u\n%-25s %10u\n%-25s %10u\n%-25s %10" TCL_Z_MODIFIER"u\n%-25s %10u\n%-25s %10" TCL_Z_MODIFIER "u\n", + "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10lu\n%-25s %10d\n%-25s %10lu\n", "total mallocs", total_mallocs, "total frees", total_frees, "current packets allocated", current_malloc_packets, - "current bytes allocated", current_bytes_malloced, + "current bytes allocated", (unsigned long)current_bytes_malloced, "maximum packets allocated", maximum_malloc_packets, - "maximum bytes allocated", maximum_bytes_malloced)); + "maximum bytes allocated", (unsigned long)maximum_bytes_malloced)); return TCL_OK; } if (strcmp(argv[1], "init") == 0) { if (argc != 3) { goto bad_suboption; @@ -878,18 +933,16 @@ alloc_tracing = (strcmp(argv[2],"on") == 0); return TCL_OK; } if (strcmp(argv[1],"trace_on_at_malloc") == 0) { - int value; if (argc != 3) { goto argError; } - if (Tcl_GetInt(interp, argv[2], &value) != TCL_OK) { + if (Tcl_GetInt(interp, argv[2], &trace_on_at_malloc) != TCL_OK) { return TCL_ERROR; } - trace_on_at_malloc = value; return TCL_OK; } if (strcmp(argv[1],"validate") == 0) { if (argc != 3) { goto bad_suboption; @@ -995,16 +1048,15 @@ * that memory was actually allocated. * *---------------------------------------------------------------------- */ -#undef Tcl_Alloc -void * +char * Tcl_Alloc( - size_t size) + unsigned int size) { - void *result; + char *result; result = TclpAlloc(size); /* * Most systems will not alloc(0), instead bumping it to one so that NULL @@ -1015,29 +1067,28 @@ * The ANSI spec actually says that systems either return NULL *or* a * special pointer on failure, but we only check for NULL */ if ((result == NULL) && size) { - Tcl_Panic("unable to alloc %" TCL_Z_MODIFIER "u bytes", size); + Tcl_Panic("unable to alloc %u bytes", size); } return result; } -void * +char * Tcl_DbCkalloc( - size_t size, + unsigned int size, const char *file, int line) { - void *result; + char *result; - result = TclpAlloc(size); + result = (char *) TclpAlloc(size); if ((result == NULL) && size) { fflush(stdout); - Tcl_Panic("unable to alloc %" TCL_Z_MODIFIER "u bytes, %s line %d", - size, file, line); + Tcl_Panic("unable to alloc %u bytes, %s line %d", size, file, line); } return result; } /* @@ -1049,29 +1100,31 @@ * check that memory was actually allocated. * *---------------------------------------------------------------------- */ -void * +char * Tcl_AttemptAlloc( - size_t size) + unsigned int size) { - void *result; + char *result; result = TclpAlloc(size); return result; } -void * +char * Tcl_AttemptDbCkalloc( - size_t size, + unsigned int size, const char *file, int line) { - void *result; + char *result; + (void)file; + (void)line; - result = TclpAlloc(size); + result = (char *) TclpAlloc(size); return result; } /* *---------------------------------------------------------------------- @@ -1082,41 +1135,39 @@ * that memory was actually allocated. * *---------------------------------------------------------------------- */ -#undef Tcl_Realloc -void * +char * Tcl_Realloc( - void *ptr, - size_t size) + char *ptr, + unsigned int size) { char *result; result = TclpRealloc(ptr, size); if ((result == NULL) && size) { - Tcl_Panic("unable to realloc %" TCL_Z_MODIFIER "u bytes", size); + Tcl_Panic("unable to realloc %u bytes", size); } return result; } -void * +char * Tcl_DbCkrealloc( - void *ptr, - size_t size, + char *ptr, + unsigned int size, const char *file, int line) { - void *result; + char *result; - result = TclpRealloc(ptr, size); + result = (char *) TclpRealloc(ptr, size); if ((result == NULL) && size) { fflush(stdout); - Tcl_Panic("unable to realloc %" TCL_Z_MODIFIER "u bytes, %s line %d", - size, file, line); + Tcl_Panic("unable to realloc %u bytes, %s line %d", size, file, line); } return result; } /* @@ -1128,31 +1179,33 @@ * check that memory was actually allocated. * *---------------------------------------------------------------------- */ -void * +char * Tcl_AttemptRealloc( - void *ptr, - size_t size) + char *ptr, + unsigned int size) { - void *result; + char *result; result = TclpRealloc(ptr, size); return result; } -void * +char * Tcl_AttemptDbCkrealloc( - void *ptr, - size_t size, + char *ptr, + unsigned int size, const char *file, int line) { - void *result; + char *result; + (void)file; + (void)line; - result = TclpRealloc(ptr, size); + result = (char *) TclpRealloc(ptr, size); return result; } /* *---------------------------------------------------------------------- @@ -1164,24 +1217,25 @@ * TCL_MEM_DEBUG enabled and some with it disabled. * *---------------------------------------------------------------------- */ -#undef Tcl_Free void Tcl_Free( - void *ptr) + char *ptr) { TclpFree(ptr); } void Tcl_DbCkfree( - void *ptr, + char *ptr, const char *file, int line) { + (void)file; + (void)line; TclpFree(ptr); } /* *---------------------------------------------------------------------- @@ -1196,31 +1250,37 @@ /* ARGSUSED */ void Tcl_InitMemory( Tcl_Interp *interp) { + (void)interp; } int Tcl_DumpActiveMemory( const char *fileName) { + (void)fileName; return TCL_OK; } void Tcl_ValidateAllMemory( const char *file, int line) { + (void)file; + (void)line; } int TclDumpMemoryInfo( ClientData clientData, int flags) { + (void)clientData; + (void)flags; return 1; } #endif /* TCL_MEM_DEBUG */ @@ -1262,11 +1322,11 @@ allocHead = NULL; Tcl_MutexUnlock(ckallocMutexPtr); #endif -#if USE_TCLALLOC +#if defined(USE_TCLALLOC) && USE_TCLALLOC TclFinalizeAllocSubsystem(); #endif } /* Index: generic/tclClock.c ================================================================== --- generic/tclClock.c +++ generic/tclClock.c @@ -98,11 +98,11 @@ /* * Structure containing the fields used in [clock format] and [clock scan] */ -typedef struct { +typedef struct TclDateFields { Tcl_WideInt seconds; /* Time expressed in seconds from the Posix * epoch */ Tcl_WideInt localSeconds; /* Local time expressed in nominal seconds * from the Posix epoch */ int tzOffset; /* Time zone offset in seconds east of @@ -261,11 +261,11 @@ {"seconds", ClockSecondsObjCmd, TclCompileClockReadingCmd, NULL, INT2PTR(3), 0}, {NULL, NULL, NULL, NULL, NULL, 0} }; /* - * Safe interps get [::clock] as alias to a master, so do not need their + * Safe interps get [::clock] as alias to a parent, so do not need their * own copies of the support routines. */ if (Tcl_IsSafe(interp)) { return; @@ -273,13 +273,13 @@ /* * Create the client data, which is a refcounted literal pool. */ - data = Tcl_Alloc(sizeof(ClockClientData)); + data = ckalloc(sizeof(ClockClientData)); data->refCount = 0; - data->literals = Tcl_Alloc(LIT__END * sizeof(Tcl_Obj*)); + data->literals = ckalloc(LIT__END * sizeof(Tcl_Obj*)); for (i = 0; i < LIT__END; ++i) { data->literals[i] = Tcl_NewStringObj(literals[i], -1); Tcl_IncrRefCount(data->literals[i]); } @@ -335,11 +335,11 @@ Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj *const *objv) /* Parameter vector */ { ClockClientData *data = clientData; - Tcl_Obj *const *literals = data->literals; + Tcl_Obj *const *lit = data->literals; Tcl_Obj *secondsObj; Tcl_Obj *dict; int changeover; TclDateFields fields; int created = 0; @@ -352,11 +352,11 @@ if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "dict tzdata changeover"); return TCL_ERROR; } dict = objv[1]; - if (Tcl_DictObjGet(interp, dict, literals[LIT_LOCALSECONDS], + if (Tcl_DictObjGet(interp, dict, lit[LIT_LOCALSECONDS], &secondsObj)!= TCL_OK) { return TCL_ERROR; } if (secondsObj == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("key \"localseconds\" not " @@ -378,11 +378,11 @@ if (Tcl_IsShared(dict)) { dict = Tcl_DuplicateObj(dict); created = 1; Tcl_IncrRefCount(dict); } - status = Tcl_DictObjPut(interp, dict, literals[LIT_SECONDS], + status = Tcl_DictObjPut(interp, dict, lit[LIT_SECONDS], Tcl_NewWideIntObj(fields.seconds)); if (status == TCL_OK) { Tcl_SetObjResult(interp, dict); } if (created) { @@ -429,11 +429,11 @@ Tcl_Obj *const *objv) /* Parameter vector */ { TclDateFields fields; Tcl_Obj *dict; ClockClientData *data = clientData; - Tcl_Obj *const *literals = data->literals; + Tcl_Obj *const *lit = data->literals; int changeover; /* * Check params. */ @@ -450,12 +450,12 @@ /* * fields.seconds could be an unsigned number that overflowed. Make sure * that it isn't. */ - if (TclHasIntRep(objv[1], &tclBignumType)) { - Tcl_SetObjResult(interp, literals[LIT_INTEGER_VALUE_TOO_LARGE]); + if (objv[1]->typePtr == &tclBignumType) { + Tcl_SetObjResult(interp, lit[LIT_INTEGER_VALUE_TOO_LARGE]); return TCL_ERROR; } /* * Convert UTC time to local. @@ -479,38 +479,38 @@ GetGregorianEraYearDay(&fields, changeover); GetMonthDay(&fields); GetYearWeekDay(&fields, changeover); dict = Tcl_NewDictObj(); - Tcl_DictObjPut(NULL, dict, literals[LIT_LOCALSECONDS], + Tcl_DictObjPut(NULL, dict, lit[LIT_LOCALSECONDS], Tcl_NewWideIntObj(fields.localSeconds)); - Tcl_DictObjPut(NULL, dict, literals[LIT_SECONDS], + Tcl_DictObjPut(NULL, dict, lit[LIT_SECONDS], Tcl_NewWideIntObj(fields.seconds)); - Tcl_DictObjPut(NULL, dict, literals[LIT_TZNAME], fields.tzName); + Tcl_DictObjPut(NULL, dict, lit[LIT_TZNAME], fields.tzName); Tcl_DecrRefCount(fields.tzName); - Tcl_DictObjPut(NULL, dict, literals[LIT_TZOFFSET], - Tcl_NewWideIntObj(fields.tzOffset)); - Tcl_DictObjPut(NULL, dict, literals[LIT_JULIANDAY], - Tcl_NewWideIntObj(fields.julianDay)); - Tcl_DictObjPut(NULL, dict, literals[LIT_GREGORIAN], - Tcl_NewWideIntObj(fields.gregorian)); - Tcl_DictObjPut(NULL, dict, literals[LIT_ERA], - literals[fields.era ? LIT_BCE : LIT_CE]); - Tcl_DictObjPut(NULL, dict, literals[LIT_YEAR], - Tcl_NewWideIntObj(fields.year)); - Tcl_DictObjPut(NULL, dict, literals[LIT_DAYOFYEAR], - Tcl_NewWideIntObj(fields.dayOfYear)); - Tcl_DictObjPut(NULL, dict, literals[LIT_MONTH], - Tcl_NewWideIntObj(fields.month)); - Tcl_DictObjPut(NULL, dict, literals[LIT_DAYOFMONTH], - Tcl_NewWideIntObj(fields.dayOfMonth)); - Tcl_DictObjPut(NULL, dict, literals[LIT_ISO8601YEAR], - Tcl_NewWideIntObj(fields.iso8601Year)); - Tcl_DictObjPut(NULL, dict, literals[LIT_ISO8601WEEK], - Tcl_NewWideIntObj(fields.iso8601Week)); - Tcl_DictObjPut(NULL, dict, literals[LIT_DAYOFWEEK], - Tcl_NewWideIntObj(fields.dayOfWeek)); + Tcl_DictObjPut(NULL, dict, lit[LIT_TZOFFSET], + Tcl_NewIntObj(fields.tzOffset)); + Tcl_DictObjPut(NULL, dict, lit[LIT_JULIANDAY], + Tcl_NewIntObj(fields.julianDay)); + Tcl_DictObjPut(NULL, dict, lit[LIT_GREGORIAN], + Tcl_NewIntObj(fields.gregorian)); + Tcl_DictObjPut(NULL, dict, lit[LIT_ERA], + lit[fields.era ? LIT_BCE : LIT_CE]); + Tcl_DictObjPut(NULL, dict, lit[LIT_YEAR], + Tcl_NewIntObj(fields.year)); + Tcl_DictObjPut(NULL, dict, lit[LIT_DAYOFYEAR], + Tcl_NewIntObj(fields.dayOfYear)); + Tcl_DictObjPut(NULL, dict, lit[LIT_MONTH], + Tcl_NewIntObj(fields.month)); + Tcl_DictObjPut(NULL, dict, lit[LIT_DAYOFMONTH], + Tcl_NewIntObj(fields.dayOfMonth)); + Tcl_DictObjPut(NULL, dict, lit[LIT_ISO8601YEAR], + Tcl_NewIntObj(fields.iso8601Year)); + Tcl_DictObjPut(NULL, dict, lit[LIT_ISO8601WEEK], + Tcl_NewIntObj(fields.iso8601Week)); + Tcl_DictObjPut(NULL, dict, lit[LIT_DAYOFWEEK], + Tcl_NewIntObj(fields.dayOfWeek)); Tcl_SetObjResult(interp, dict); return TCL_OK; } @@ -583,11 +583,11 @@ Tcl_Obj *const *objv) /* Parameter vector */ { TclDateFields fields; Tcl_Obj *dict; ClockClientData *data = clientData; - Tcl_Obj *const *literals = data->literals; + Tcl_Obj *const *lit = data->literals; int changeover; int copied = 0; int status; int era = 0; @@ -598,16 +598,16 @@ if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "dict changeover"); return TCL_ERROR; } dict = objv[1]; - if (FetchEraField(interp, dict, literals[LIT_ERA], &era) != TCL_OK - || FetchIntField(interp, dict, literals[LIT_YEAR], &fields.year) + if (FetchEraField(interp, dict, lit[LIT_ERA], &era) != TCL_OK + || FetchIntField(interp, dict, lit[LIT_YEAR], &fields.year) != TCL_OK - || FetchIntField(interp, dict, literals[LIT_MONTH], &fields.month) + || FetchIntField(interp, dict, lit[LIT_MONTH], &fields.month) != TCL_OK - || FetchIntField(interp, dict, literals[LIT_DAYOFMONTH], + || FetchIntField(interp, dict, lit[LIT_DAYOFMONTH], &fields.dayOfMonth) != TCL_OK || TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) { return TCL_ERROR; } fields.era = era; @@ -625,12 +625,12 @@ if (Tcl_IsShared(dict)) { dict = Tcl_DuplicateObj(dict); Tcl_IncrRefCount(dict); copied = 1; } - status = Tcl_DictObjPut(interp, dict, literals[LIT_JULIANDAY], - Tcl_NewWideIntObj(fields.julianDay)); + status = Tcl_DictObjPut(interp, dict, lit[LIT_JULIANDAY], + Tcl_NewIntObj(fields.julianDay)); if (status == TCL_OK) { Tcl_SetObjResult(interp, dict); } if (copied) { Tcl_DecrRefCount(dict); @@ -667,11 +667,11 @@ Tcl_Obj *const *objv) /* Parameter vector */ { TclDateFields fields; Tcl_Obj *dict; ClockClientData *data = clientData; - Tcl_Obj *const *literals = data->literals; + Tcl_Obj *const *lit = data->literals; int changeover; int copied = 0; int status; int era = 0; @@ -682,16 +682,16 @@ if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "dict changeover"); return TCL_ERROR; } dict = objv[1]; - if (FetchEraField(interp, dict, literals[LIT_ERA], &era) != TCL_OK - || FetchIntField(interp, dict, literals[LIT_ISO8601YEAR], + if (FetchEraField(interp, dict, lit[LIT_ERA], &era) != TCL_OK + || FetchIntField(interp, dict, lit[LIT_ISO8601YEAR], &fields.iso8601Year) != TCL_OK - || FetchIntField(interp, dict, literals[LIT_ISO8601WEEK], + || FetchIntField(interp, dict, lit[LIT_ISO8601WEEK], &fields.iso8601Week) != TCL_OK - || FetchIntField(interp, dict, literals[LIT_DAYOFWEEK], + || FetchIntField(interp, dict, lit[LIT_DAYOFWEEK], &fields.dayOfWeek) != TCL_OK || TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) { return TCL_ERROR; } fields.era = era; @@ -709,12 +709,12 @@ if (Tcl_IsShared(dict)) { dict = Tcl_DuplicateObj(dict); Tcl_IncrRefCount(dict); copied = 1; } - status = Tcl_DictObjPut(interp, dict, literals[LIT_JULIANDAY], - Tcl_NewWideIntObj(fields.julianDay)); + status = Tcl_DictObjPut(interp, dict, lit[LIT_JULIANDAY], + Tcl_NewIntObj(fields.julianDay)); if (status == TCL_OK) { Tcl_SetObjResult(interp, dict); } if (copied) { Tcl_DecrRefCount(dict); @@ -1050,11 +1050,11 @@ int changeover) /* Julian Day of the Gregorian transition */ { time_t tock; struct tm *timeVal; /* Time after conversion */ int diff; /* Time zone diff local-Greenwich */ - char buffer[8]; /* Buffer for time zone name */ + char buffer[16]; /* Buffer for time zone name */ /* * Use 'localtime' to determine local year, month, day, time of day. */ @@ -1511,11 +1511,11 @@ /* * Try an initial conversion in the Gregorian calendar. */ -#if 0 /* BUG http://core.tcl.tk/tcl/tktview?name=da340d4f32 */ +#if 0 /* BUG https://core.tcl-lang.org/tcl/tktview?name=da340d4f32 */ ym1o4 = ym1 / 4; #else /* * Have to make sure quotient is truncated towards 0 when negative. * See above bug for details. The casts are necessary. @@ -1650,10 +1650,11 @@ int objc, Tcl_Obj *const objv[]) { const char *varName; const char *varValue; + (void)clientData; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "name"); return TCL_ERROR; } @@ -1742,10 +1743,11 @@ CLICKS_MILLIS, CLICKS_MICROS, CLICKS_NATIVE }; int index = CLICKS_NATIVE; Tcl_Time now; Tcl_WideInt clicks = 0; + (void)clientData; switch (objc) { case 1: break; case 2: @@ -1804,10 +1806,11 @@ Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj *const *objv) /* Parameter values */ { Tcl_Time now; + (void)clientData; if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } @@ -1840,10 +1843,11 @@ ClientData clientData, /* Client data is unused */ Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj *const *objv) /* Parameter values */ { + (void)clientData; if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewWideIntObj(TclpGetMicroseconds())); @@ -1915,11 +1919,11 @@ timezoneObj = litPtr[LIT__NIL]; for (i = 2; i < objc; i+=2) { if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &optionIndex) != TCL_OK) { Tcl_SetErrorCode(interp, "CLOCK", "badOption", - TclGetString(objv[i]), NULL); + Tcl_GetString(objv[i]), NULL); return TCL_ERROR; } switch (optionIndex) { case CLOCK_FORMAT_FORMAT: formatObj = objv[i+1]; @@ -1992,10 +1996,11 @@ Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj *const *objv) /* Parameter values */ { Tcl_Time now; + (void)clientData; if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } @@ -2032,17 +2037,17 @@ tzIsNow = getenv("TZ"); if (tzIsNow != NULL && (tzWas == NULL || tzWas == INT2PTR(-1) || strcmp(tzIsNow, tzWas) != 0)) { tzset(); if (tzWas != NULL && tzWas != INT2PTR(-1)) { - Tcl_Free(tzWas); + ckfree(tzWas); } - tzWas = Tcl_Alloc(strlen(tzIsNow) + 1); + tzWas = ckalloc(strlen(tzIsNow) + 1); strcpy(tzWas, tzIsNow); } else if (tzIsNow == NULL && tzWas != NULL) { tzset(); - if (tzWas != INT2PTR(-1)) Tcl_Free(tzWas); + if (tzWas != INT2PTR(-1)) ckfree(tzWas); tzWas = NULL; } Tcl_MutexUnlock(&clockMutex); } @@ -2069,12 +2074,12 @@ if (data->refCount-- <= 1) { for (i = 0; i < LIT__END; ++i) { Tcl_DecrRefCount(data->literals[i]); } - Tcl_Free(data->literals); - Tcl_Free(data); + ckfree(data->literals); + ckfree(data); } } /* * Local Variables: Index: generic/tclCmdAH.c ================================================================== --- generic/tclCmdAH.c +++ generic/tclCmdAH.c @@ -44,10 +44,13 @@ * Prototypes for local procedures defined in this file: */ static int CheckAccess(Tcl_Interp *interp, Tcl_Obj *pathPtr, int mode); +static int BadEncodingSubcommand(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); static int EncodingConvertfromObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int EncodingConverttoObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, @@ -79,10 +82,11 @@ static Tcl_NRPostProc ForNextCallback; static Tcl_NRPostProc ForPostNextCallback; static Tcl_NRPostProc ForeachLoopStep; static Tcl_NRPostProc EvalCmdErrMsg; +static Tcl_ObjCmdProc BadFileSubcommand; static Tcl_ObjCmdProc FileAttrAccessTimeCmd; static Tcl_ObjCmdProc FileAttrIsDirectoryCmd; static Tcl_ObjCmdProc FileAttrIsExecutableCmd; static Tcl_ObjCmdProc FileAttrIsExistingCmd; static Tcl_ObjCmdProc FileAttrIsFileCmd; @@ -140,10 +144,146 @@ Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } return TCL_BREAK; } + +/* + *---------------------------------------------------------------------- + * + * Tcl_CaseObjCmd -- + * + * This procedure is invoked to process the "case" Tcl command. See the + * user documentation for details on what it does. THIS COMMAND IS + * OBSOLETE AND DEPRECATED. SLATED FOR REMOVAL IN TCL 9.0. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_CaseObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + register int i; + int body, result, caseObjc; + const char *stringPtr, *arg; + Tcl_Obj *const *caseObjv; + Tcl_Obj *armPtr; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, + "string ?in? ?pattern body ...? ?default body?"); + return TCL_ERROR; + } + + stringPtr = TclGetString(objv[1]); + body = -1; + + arg = TclGetString(objv[2]); + if (strcmp(arg, "in") == 0) { + i = 3; + } else { + i = 2; + } + caseObjc = objc - i; + caseObjv = objv + i; + + /* + * If all of the pattern/command pairs are lumped into a single argument, + * split them out again. + */ + + if (caseObjc == 1) { + Tcl_Obj **newObjv; + + TclListObjGetElements(interp, caseObjv[0], &caseObjc, &newObjv); + caseObjv = newObjv; + } + + for (i = 0; i < caseObjc; i += 2) { + int patObjc, j; + const char **patObjv; + const char *pat, *p; + + if (i == caseObjc-1) { + Tcl_ResetResult(interp); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "extra case pattern with no body", -1)); + return TCL_ERROR; + } + + /* + * Check for special case of single pattern (no list) with no + * backslash sequences. + */ + + pat = TclGetString(caseObjv[i]); + for (p = pat; *p != '\0'; p++) { + if (TclIsSpaceProcM(*p) || (*p == '\\')) { + break; + } + } + if (*p == '\0') { + if ((*pat == 'd') && (strcmp(pat, "default") == 0)) { + body = i + 1; + } + if (Tcl_StringMatch(stringPtr, pat)) { + body = i + 1; + goto match; + } + continue; + } + + /* + * Break up pattern lists, then check each of the patterns in the + * list. + */ + + result = Tcl_SplitList(interp, pat, &patObjc, &patObjv); + if (result != TCL_OK) { + return result; + } + for (j = 0; j < patObjc; j++) { + if (Tcl_StringMatch(stringPtr, patObjv[j])) { + body = i + 1; + break; + } + } + ckfree(patObjv); + if (j < patObjc) { + break; + } + } + + match: + if (body != -1) { + armPtr = caseObjv[body - 1]; + result = Tcl_EvalObjEx(interp, caseObjv[body], 0); + if (result == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"%.50s\" arm line %d)", + TclGetString(armPtr), Tcl_GetErrorLine(interp))); + } + return result; + } + + /* + * Nothing matched: return nothing. + */ + + return TCL_OK; +} /* *---------------------------------------------------------------------- * * Tcl_CatchObjCmd -- @@ -243,11 +383,11 @@ return TCL_ERROR; } } Tcl_ResetResult(interp); - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(result)); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -393,18 +533,125 @@ Tcl_Interp* interp) /* Tcl interpreter */ { static const EnsembleImplMap encodingImplMap[] = { {"convertfrom", EncodingConvertfromObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {"convertto", EncodingConverttoObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"dirs", EncodingDirsObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, + {"dirs", EncodingDirsObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"names", EncodingNamesObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, - {"system", EncodingSystemObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, + {"system", EncodingSystemObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} }; return TclMakeEnsemble(interp, "encoding", encodingImplMap); } + +/* + *----------------------------------------------------------------------------- + * + * TclMakeEncodingCommandSafe -- + * + * This function hides the unsafe 'dirs' and 'system' subcommands of + * the "encoding" Tcl command ensemble. It must be called only from + * TclHideUnsafeCommands. + * + * Results: + * A standard Tcl result + * + * Side effects: + * Adds commands to the table of hidden commands. + * + *----------------------------------------------------------------------------- + */ + +int +TclMakeEncodingCommandSafe( + Tcl_Interp* interp) /* Tcl interpreter */ +{ + static const struct { + const char *cmdName; + int unsafe; + } unsafeInfo[] = { + {"convertfrom", 0}, + {"convertto", 0}, + {"dirs", 1}, + {"names", 0}, + {"system", 0}, + {NULL, 0} + }; + + int i; + Tcl_DString oldBuf, newBuf; + + Tcl_DStringInit(&oldBuf); + TclDStringAppendLiteral(&oldBuf, "::tcl::encoding::"); + Tcl_DStringInit(&newBuf); + TclDStringAppendLiteral(&newBuf, "tcl:encoding:"); + for (i=0 ; unsafeInfo[i].cmdName != NULL ; i++) { + if (unsafeInfo[i].unsafe) { + const char *oldName, *newName; + + Tcl_DStringSetLength(&oldBuf, 17); + oldName = Tcl_DStringAppend(&oldBuf, unsafeInfo[i].cmdName, -1); + Tcl_DStringSetLength(&newBuf, 13); + newName = Tcl_DStringAppend(&newBuf, unsafeInfo[i].cmdName, -1); + if (TclRenameCommand(interp, oldName, "___tmp") != TCL_OK + || Tcl_HideCommand(interp, "___tmp", newName) != TCL_OK) { + Tcl_Panic("problem making 'encoding %s' safe: %s", + unsafeInfo[i].cmdName, + Tcl_GetString(Tcl_GetObjResult(interp))); + } + Tcl_CreateObjCommand(interp, oldName, BadEncodingSubcommand, + (ClientData) unsafeInfo[i].cmdName, NULL); + } + } + Tcl_DStringFree(&oldBuf); + Tcl_DStringFree(&newBuf); + + /* + * Ugh. The [encoding] command is now actually safe, but it is assumed by + * scripts that it is not, which messes up security policies. + */ + + if (Tcl_HideCommand(interp, "encoding", "encoding") != TCL_OK) { + Tcl_Panic("problem making 'encoding' safe: %s", + Tcl_GetString(Tcl_GetObjResult(interp))); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * BadEncodingSubcommand -- + * + * Command used to act as a backstop implementation when subcommands of + * "encoding" are unsafe (the real implementations of the subcommands are + * hidden). The clientData is always the full official subcommand name. + * + * Results: + * A standard Tcl result (always a TCL_ERROR). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +BadEncodingSubcommand( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + const char *subcommandName = (const char *) clientData; + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "not allowed to invoke subcommand %s of encoding", subcommandName)); + Tcl_SetErrorCode(interp, "TCL", "SAFE", "SUBCOMMAND", NULL); + return TCL_ERROR; +} /* *---------------------------------------------------------------------- * * EncodingConvertfromObjCmd -- @@ -426,11 +673,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 */ - size_t length = 0; /* Length of the byte array being converted */ + int length; /* Length of the byte array being converted */ const char *bytesPtr; /* Pointer to the first byte of the array */ if (objc == 2) { encoding = Tcl_GetEncoding(interp, NULL); data = objv[1]; @@ -445,11 +692,11 @@ } /* * Convert the string into a byte array in 'ds' */ - bytesPtr = (char *) TclGetByteArrayFromObj(data, &length); + bytesPtr = (char *) Tcl_GetByteArrayFromObj(data, &length); Tcl_ExternalToUtfDString(encoding, bytesPtr, length, &ds); /* * Note that we cannot use Tcl_DStringResult here because it will * truncate the string at the first null byte. @@ -488,11 +735,11 @@ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Obj *data; /* String to convert */ Tcl_DString ds; /* Buffer to hold the byte array */ Tcl_Encoding encoding; /* Encoding to use */ - size_t length; /* Length of the string being converted */ + int length; /* Length of the string being converted */ const char *stringPtr; /* Pointer to the first byte of the string */ /* TODO - ADJUST OBJ INDICES WHEN ENSEMBLIFYING THIS */ if (objc == 2) { @@ -793,23 +1040,23 @@ ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_WideInt value; + int value; if ((objc != 1) && (objc != 2)) { Tcl_WrongNumArgs(interp, 1, objv, "?returnCode?"); return TCL_ERROR; } if (objc == 1) { value = 0; - } else if (TclGetWideBitsFromObj(interp, objv[1], &value) != TCL_OK) { + } else if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) { return TCL_ERROR; } - Tcl_Exit((int)value); + Tcl_Exit(value); /*NOTREACHED*/ return TCL_OK; /* Better not ever reach this! */ } /* @@ -924,49 +1171,183 @@ * the native filesystem or because they reveal information about the * native filesystem. */ static const EnsembleImplMap initMap[] = { - {"atime", FileAttrAccessTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 1}, - {"attributes", TclFileAttrsCmd, NULL, NULL, NULL, 1}, + {"atime", FileAttrAccessTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, + {"attributes", TclFileAttrsCmd, NULL, NULL, NULL, 0}, {"channels", TclChannelNamesCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, - {"copy", TclFileCopyCmd, NULL, NULL, NULL, 1}, - {"delete", TclFileDeleteCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1}, - {"dirname", PathDirNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, - {"executable", FileAttrIsExecutableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, - {"exists", FileAttrIsExistingCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, - {"extension", PathExtensionCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, - {"isdirectory", FileAttrIsDirectoryCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, - {"isfile", FileAttrIsFileCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, + {"copy", TclFileCopyCmd, NULL, NULL, NULL, 0}, + {"delete", TclFileDeleteCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, + {"dirname", PathDirNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"executable", FileAttrIsExecutableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"exists", FileAttrIsExistingCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"extension", PathExtensionCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"isdirectory", FileAttrIsDirectoryCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"isfile", FileAttrIsFileCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"join", PathJoinCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, - {"link", TclFileLinkCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 1}, - {"lstat", FileAttrLinkStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 1}, - {"mtime", FileAttrModifyTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 1}, - {"mkdir", TclFileMakeDirsCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1}, - {"nativename", PathNativeNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, - {"normalize", PathNormalizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, - {"owned", FileAttrIsOwnedCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, + {"link", TclFileLinkCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, + {"lstat", FileAttrLinkStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {"mtime", FileAttrModifyTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, + {"mkdir", TclFileMakeDirsCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, + {"nativename", PathNativeNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"normalize", PathNormalizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"owned", FileAttrIsOwnedCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"pathtype", PathTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"readable", FileAttrIsReadableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, - {"readlink", TclFileReadLinkCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, - {"rename", TclFileRenameCmd, NULL, NULL, NULL, 1}, - {"rootname", PathRootNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, + {"readable", FileAttrIsReadableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"readlink", TclFileReadLinkCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"rename", TclFileRenameCmd, NULL, NULL, NULL, 0}, + {"rootname", PathRootNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"separator", FilesystemSeparatorCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, - {"size", FileAttrSizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, + {"size", FileAttrSizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"split", PathSplitCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"stat", FileAttrStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 1}, + {"stat", FileAttrStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"system", PathFilesystemCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, - {"tail", PathTailCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, - {"tempdir", TclFileTempDirCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, - {"tempfile", TclFileTemporaryCmd, TclCompileBasic0To2ArgCmd, NULL, NULL, 1}, - {"type", FileAttrTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, - {"volumes", FilesystemVolumesCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1}, - {"writable", FileAttrIsWritableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, + {"tail", PathTailCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"tempfile", TclFileTemporaryCmd, TclCompileBasic0To2ArgCmd, NULL, NULL, 0}, + {"type", FileAttrTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"volumes", FilesystemVolumesCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, + {"writable", FileAttrIsWritableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} }; return TclMakeEnsemble(interp, "file", initMap); } + +/* + *---------------------------------------------------------------------- + * + * TclMakeFileCommandSafe -- + * + * This function hides the unsafe subcommands of the "file" Tcl command + * ensemble. It must only be called from TclHideUnsafeCommands. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Adds commands to the table of hidden commands. + * + *---------------------------------------------------------------------- + */ + +int +TclMakeFileCommandSafe( + Tcl_Interp *interp) +{ + static const struct { + const char *cmdName; + int unsafe; + } unsafeInfo[] = { + {"atime", 1}, + {"attributes", 1}, + {"channels", 0}, + {"copy", 1}, + {"delete", 1}, + {"dirname", 1}, + {"executable", 1}, + {"exists", 1}, + {"extension", 1}, + {"isdirectory", 1}, + {"isfile", 1}, + {"join", 0}, + {"link", 1}, + {"lstat", 1}, + {"mtime", 1}, + {"mkdir", 1}, + {"nativename", 1}, + {"normalize", 1}, + {"owned", 1}, + {"pathtype", 0}, + {"readable", 1}, + {"readlink", 1}, + {"rename", 1}, + {"rootname", 1}, + {"separator", 0}, + {"size", 1}, + {"split", 0}, + {"stat", 1}, + {"system", 0}, + {"tail", 1}, + {"tempfile", 1}, + {"type", 1}, + {"volumes", 1}, + {"writable", 1}, + {NULL, 0} + }; + int i; + Tcl_DString oldBuf, newBuf; + + Tcl_DStringInit(&oldBuf); + TclDStringAppendLiteral(&oldBuf, "::tcl::file::"); + Tcl_DStringInit(&newBuf); + TclDStringAppendLiteral(&newBuf, "tcl:file:"); + for (i=0 ; unsafeInfo[i].cmdName != NULL ; i++) { + if (unsafeInfo[i].unsafe) { + const char *oldName, *newName; + + Tcl_DStringSetLength(&oldBuf, 13); + oldName = Tcl_DStringAppend(&oldBuf, unsafeInfo[i].cmdName, -1); + Tcl_DStringSetLength(&newBuf, 9); + newName = Tcl_DStringAppend(&newBuf, unsafeInfo[i].cmdName, -1); + if (TclRenameCommand(interp, oldName, "___tmp") != TCL_OK + || Tcl_HideCommand(interp, "___tmp", newName) != TCL_OK) { + Tcl_Panic("problem making 'file %s' safe: %s", + unsafeInfo[i].cmdName, + Tcl_GetString(Tcl_GetObjResult(interp))); + } + Tcl_CreateObjCommand(interp, oldName, BadFileSubcommand, + (ClientData) unsafeInfo[i].cmdName, NULL); + } + } + Tcl_DStringFree(&oldBuf); + Tcl_DStringFree(&newBuf); + + /* + * Ugh. The [file] command is now actually safe, but it is assumed by + * scripts that it is not, which messes up security policies. [Bug + * 3211758] + */ + + if (Tcl_HideCommand(interp, "file", "file") != TCL_OK) { + Tcl_Panic("problem making 'file' safe: %s", + Tcl_GetString(Tcl_GetObjResult(interp))); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * BadFileSubcommand -- + * + * Command used to act as a backstop implementation when subcommands of + * "file" are unsafe (the real implementations of the subcommands are + * hidden). The clientData is always the full official subcommand name. + * + * Results: + * A standard Tcl result (always a TCL_ERROR). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +BadFileSubcommand( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + const char *subcommandName = (const char *) clientData; + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "not allowed to invoke subcommand %s of file", subcommandName)); + Tcl_SetErrorCode(interp, "TCL", "SAFE", "SUBCOMMAND", NULL); + return TCL_ERROR; +} /* *---------------------------------------------------------------------- * * FileAttrAccessTimeCmd -- @@ -1000,32 +1381,27 @@ if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } #if defined(_WIN32) /* We use a value of 0 to indicate the access time not available */ - if (buf.st_atime == 0) { + if (Tcl_GetAccessTimeFromStat(&buf) == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "could not get access time for file \"%s\"", TclGetString(objv[1]))); return TCL_ERROR; } #endif if (objc == 3) { - /* - * Need separate variable for reading longs from an object on 64-bit - * platforms. [Bug 698146] - */ - Tcl_WideInt newTime; - if (TclGetWideIntFromObj(interp, objv[2], &newTime) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[2], &newTime) != TCL_OK) { return TCL_ERROR; } tval.actime = newTime; - tval.modtime = buf.st_mtime; + tval.modtime = Tcl_GetModificationTimeFromStat(&buf); if (Tcl_FSUtime(objv[1], &tval) != 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "could not set access time for file \"%s\": %s", TclGetString(objv[1]), Tcl_PosixError(interp))); @@ -1041,11 +1417,11 @@ if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj((long) buf.st_atime)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_GetAccessTimeFromStat(&buf))); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -1082,11 +1458,11 @@ if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } #if defined(_WIN32) /* We use a value of 0 to indicate the modification time not available */ - if (buf.st_mtime == 0) { + if (Tcl_GetModificationTimeFromStat(&buf) == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "could not get modification time for file \"%s\"", TclGetString(objv[1]))); return TCL_ERROR; } @@ -1097,15 +1473,15 @@ * platforms. [Bug 698146] */ Tcl_WideInt newTime; - if (TclGetWideIntFromObj(interp, objv[2], &newTime) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[2], &newTime) != TCL_OK) { return TCL_ERROR; } - tval.actime = buf.st_atime; + tval.actime = Tcl_GetAccessTimeFromStat(&buf); tval.modtime = newTime; if (Tcl_FSUtime(objv[1], &tval) != 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "could not set modification time for file \"%s\": %s", @@ -1121,11 +1497,11 @@ if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj((long) buf.st_mtime)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_GetModificationTimeFromStat(&buf))); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -1709,11 +2085,11 @@ } fsInfo = Tcl_FSFileSystemInfo(objv[1]); if (fsInfo == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("unrecognised path", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "FILESYSTEM", - TclGetString(objv[1]), NULL); + Tcl_GetString(objv[1]), NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, fsInfo); return TCL_OK; } @@ -1961,11 +2337,11 @@ if (separatorObj == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "unrecognised path", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "FILESYSTEM", - TclGetString(objv[1]), NULL); + Tcl_GetString(objv[1]), NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, separatorObj); } return TCL_OK; @@ -2140,27 +2516,27 @@ /* * Watch out porters; the inode is meant to be an *unsigned* value, so the * cast might fail when there isn't a real arithmetic 'long long' type... */ - STORE_ARY("dev", Tcl_NewWideIntObj((long)statPtr->st_dev)); + STORE_ARY("dev", Tcl_NewLongObj((long)statPtr->st_dev)); STORE_ARY("ino", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino)); - STORE_ARY("nlink", Tcl_NewWideIntObj((long)statPtr->st_nlink)); - STORE_ARY("uid", Tcl_NewWideIntObj((long)statPtr->st_uid)); - STORE_ARY("gid", Tcl_NewWideIntObj((long)statPtr->st_gid)); + STORE_ARY("nlink", Tcl_NewLongObj((long)statPtr->st_nlink)); + STORE_ARY("uid", Tcl_NewLongObj((long)statPtr->st_uid)); + STORE_ARY("gid", Tcl_NewLongObj((long)statPtr->st_gid)); STORE_ARY("size", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size)); #ifdef HAVE_STRUCT_STAT_ST_BLOCKS STORE_ARY("blocks", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_blocks)); #endif #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE - STORE_ARY("blksize", Tcl_NewWideIntObj((long)statPtr->st_blksize)); + STORE_ARY("blksize", Tcl_NewLongObj((long)statPtr->st_blksize)); #endif - STORE_ARY("atime", Tcl_NewWideIntObj((long)statPtr->st_atime)); - STORE_ARY("mtime", Tcl_NewWideIntObj((long)statPtr->st_mtime)); - STORE_ARY("ctime", Tcl_NewWideIntObj((long)statPtr->st_ctime)); + STORE_ARY("atime", Tcl_NewWideIntObj(Tcl_GetAccessTimeFromStat(statPtr))); + STORE_ARY("mtime", Tcl_NewWideIntObj(Tcl_GetModificationTimeFromStat(statPtr))); + STORE_ARY("ctime", Tcl_NewWideIntObj(Tcl_GetChangeTimeFromStat(statPtr))); mode = (unsigned short) statPtr->st_mode; - STORE_ARY("mode", Tcl_NewWideIntObj(mode)); + STORE_ARY("mode", Tcl_NewIntObj(mode)); STORE_ARY("type", Tcl_NewStringObj(GetTypeFromMode(mode), -1)); #undef STORE_ARY return TCL_OK; } Index: generic/tclCmdIL.c ================================================================== --- generic/tclCmdIL.c +++ generic/tclCmdIL.c @@ -33,11 +33,11 @@ double doubleValue; Tcl_Obj *objValuePtr; } collationKey; union { /* Object being sorted, or its index. */ Tcl_Obj *objPtr; - size_t index; + int index; } payload; struct SortElement *nextPtr;/* Next element in the list, or NULL for end * of list. */ } SortElement; @@ -54,11 +54,11 @@ * that compares two list elements, and the comparison function needs to pass * success or failure information back up to the top-level "lsort" command. * The following structure is used to pass this information. */ -typedef struct { +typedef struct SortInfo { int isIncreasing; /* Nonzero means sort in increasing order. */ int sortMode; /* The sort mode. One of SORTMODE_* values * defined below. */ Tcl_Obj *compareCmdPtr; /* The Tcl comparison command when sortMode is * SORTMODE_COMMAND. Pre-initialized to hold @@ -136,12 +136,10 @@ int objc, Tcl_Obj *const objv[]); static int InfoScriptCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int InfoSharedlibCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int InfoCmdTypeCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); static int InfoTclVersionCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static SortElement * MergeLists(SortElement *leftPtr, SortElement *rightPtr, SortInfo *infoPtr); static int SortCompare(SortElement *firstPtr, SortElement *second, @@ -156,11 +154,10 @@ static const EnsembleImplMap defaultInfoMap[] = { {"args", InfoArgsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"body", InfoBodyCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"cmdcount", InfoCmdCountCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, - {"cmdtype", InfoCmdTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"commands", InfoCommandsCmd, TclCompileInfoCommandsCmd, NULL, NULL, 0}, {"complete", InfoCompleteCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"coroutine", TclInfoCoroutineCmd, TclCompileInfoCoroutineCmd, NULL, NULL, 0}, {"default", InfoDefaultCmd, TclCompileBasic3ArgCmd, NULL, NULL, 0}, {"errorstack", InfoErrorStackCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, @@ -171,11 +168,11 @@ {"hostname", InfoHostnameCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, {"level", InfoLevelCmd, TclCompileInfoLevelCmd, NULL, NULL, 0}, {"library", InfoLibraryCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, {"loaded", InfoLoadedCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"locals", TclInfoLocalsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, - {"nameofexecutable", InfoNameOfExecutableCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1}, + {"nameofexecutable", InfoNameOfExecutableCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, {"patchlevel", InfoPatchLevelCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, {"procs", InfoProcsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"script", InfoScriptCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"sharedlibextension", InfoSharedlibCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, {"tclversion", InfoTclVersionCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, @@ -402,11 +399,11 @@ } if (objc == 3) { incrPtr = objv[2]; } else { - incrPtr = Tcl_NewWideIntObj(1); + TclNewIntObj(incrPtr, 1); } Tcl_IncrRefCount(incrPtr); newValuePtr = TclIncrObjVar2(interp, objv[1], NULL, incrPtr, TCL_LEAVE_ERR_MSG); Tcl_DecrRefCount(incrPtr); @@ -537,13 +534,13 @@ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register Interp *iPtr = (Interp *) interp; - const char *name, *bytes; + const char *name; Proc *procPtr; - size_t numBytes; + Tcl_Obj *bodyPtr, *resultPtr; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "procname"); return TCL_ERROR; } @@ -564,12 +561,22 @@ * compiler/engine subsystem, we now always return a copy of the string * rep. It is important to return a copy so that later manipulations of * the object do not invalidate the internal rep. */ - bytes = TclGetStringFromObj(procPtr->bodyPtr, &numBytes); - Tcl_SetObjResult(interp, Tcl_NewStringObj(bytes, numBytes)); + bodyPtr = procPtr->bodyPtr; + if (bodyPtr->bytes == NULL) { + /* + * The string rep might not be valid if the procedure has never been + * run before. [Bug #545644] + */ + + TclGetString(bodyPtr); + } + resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length); + + Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -604,11 +611,11 @@ if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(iPtr->cmdCount)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(iPtr->cmdCount)); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -649,11 +656,11 @@ Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); Tcl_Obj *listPtr, *elemObjPtr; int specificNsInPattern = 0;/* Init. to avoid compiler warning. */ Tcl_Command cmd; - size_t i; + int i; /* * Get the pattern and find the "effective namespace" in which to list * commands. */ @@ -710,11 +717,11 @@ entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern); if (entryPtr != NULL) { if (specificNsInPattern) { cmd = Tcl_GetHashValue(entryPtr); - elemObjPtr = Tcl_NewObj(); + TclNewObj(elemObjPtr); Tcl_GetCommandFullName(interp, cmd, elemObjPtr); } else { cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); elemObjPtr = Tcl_NewStringObj(cmdName, -1); } @@ -761,11 +768,11 @@ cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); if ((simplePattern == NULL) || Tcl_StringMatch(cmdName, simplePattern)) { if (specificNsInPattern) { cmd = Tcl_GetHashValue(entryPtr); - elemObjPtr = Tcl_NewObj(); + TclNewObj(elemObjPtr); Tcl_GetCommandFullName(interp, cmd, elemObjPtr); } else { elemObjPtr = Tcl_NewStringObj(cmdName, -1); } Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); @@ -986,20 +993,21 @@ valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL, localPtr->defValuePtr, TCL_LEAVE_ERR_MSG); if (valueObjPtr == NULL) { return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(1)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); } else { - Tcl_Obj *nullObjPtr = Tcl_NewObj(); + Tcl_Obj *nullObjPtr; + TclNewObj(nullObjPtr); valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL, nullObjPtr, TCL_LEAVE_ERR_MSG); if (valueObjPtr == NULL) { return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); } return TCL_OK; } } @@ -1045,11 +1053,11 @@ return TCL_ERROR; } target = interp; if (objc == 2) { - target = Tcl_GetSlave(interp, TclGetString(objv[1])); + target = Tcl_GetChild(interp, Tcl_GetString(objv[1])); if (target == NULL) { return TCL_ERROR; } } @@ -1169,11 +1177,11 @@ if (objc == 1) { /* * Just "info frame". */ - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(topLevel)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(topLevel)); goto done; } /* * We've got "info frame level" and must parse the level first. @@ -1291,13 +1299,13 @@ * str. */ ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1)); if (framePtr->line) { - ADD_PAIR("line", Tcl_NewWideIntObj(framePtr->line[0])); + ADD_PAIR("line", Tcl_NewIntObj(framePtr->line[0])); } else { - ADD_PAIR("line", Tcl_NewWideIntObj(1)); + ADD_PAIR("line", Tcl_NewIntObj(1)); } ADD_PAIR("cmd", TclGetSourceFromFrame(framePtr, 0, NULL)); break; case TCL_LOCATION_PREBC: @@ -1330,11 +1338,11 @@ * Possibly modified: type, path! */ ADD_PAIR("type", Tcl_NewStringObj(typeString[fPtr->type], -1)); if (fPtr->line) { - ADD_PAIR("line", Tcl_NewWideIntObj(fPtr->line[0])); + ADD_PAIR("line", Tcl_NewIntObj(fPtr->line[0])); } if (fPtr->type == TCL_LOCATION_SOURCE) { ADD_PAIR("file", fPtr->data.eval.path); @@ -1357,11 +1365,11 @@ /* * Evaluation of a script file. */ ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1)); - ADD_PAIR("line", Tcl_NewWideIntObj(framePtr->line[0])); + ADD_PAIR("line", Tcl_NewIntObj(framePtr->line[0])); ADD_PAIR("file", framePtr->data.eval.path); /* * Refcount framePtr->data.eval.path goes up when lv is converted into * the result list object. @@ -1394,11 +1402,11 @@ Tcl_GetCommandFullName(interp, (Tcl_Command) procPtr->cmdPtr, procNameObj); ADD_PAIR("proc", procNameObj); } else if (procPtr->cmdPtr->clientData) { ExtraFrameInfo *efiPtr = procPtr->cmdPtr->clientData; - size_t i; + int i; /* * This is a non-standard command. Luckily, it's told us how to * render extra information about its frame. */ @@ -1428,11 +1436,11 @@ for (idx=top ; idx!=NULL ; idx=idx->callerVarPtr) { if (idx == current) { int c = framePtr->framePtr->level; int t = iPtr->varFramePtr->level; - ADD_PAIR("level", Tcl_NewWideIntObj(t - c)); + ADD_PAIR("level", Tcl_NewIntObj(t - c)); break; } } } @@ -1583,11 +1591,11 @@ Tcl_Obj *const objv[]) /* Argument objects. */ { Interp *iPtr = (Interp *) interp; if (objc == 1) { /* Just "info level" */ - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(iPtr->varFramePtr->level)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(iPtr->varFramePtr->level)); return TCL_OK; } if (objc == 2) { int level; @@ -1661,11 +1669,11 @@ if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } - libDirName = Tcl_GetVar2(interp, "tcl_library", NULL, TCL_GLOBAL_ONLY); + libDirName = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY); if (libDirName != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj(libDirName, -1)); return TCL_OK; } @@ -1701,28 +1709,23 @@ ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - const char *interpName, *packageName; + const char *interpName; - if (objc > 3) { - Tcl_WrongNumArgs(interp, 1, objv, "?interp? ?packageName?"); + if ((objc != 1) && (objc != 2)) { + Tcl_WrongNumArgs(interp, 1, objv, "?interp?"); return TCL_ERROR; } - if (objc < 2) { /* Get loaded pkgs in all interpreters. */ + if (objc == 1) { /* Get loaded pkgs in all interpreters. */ interpName = NULL; } else { /* Get pkgs just in specified interp. */ interpName = TclGetString(objv[1]); } - if (objc < 3) { /* Get loaded files in all packages. */ - packageName = NULL; - } else { /* Get pkgs just in specified interp. */ - packageName = TclGetString(objv[2]); - } - return TclGetLoadedPackagesEx(interp, interpName, packageName); + return TclGetLoadedPackages(interp, interpName); } /* *---------------------------------------------------------------------- * @@ -1792,11 +1795,11 @@ if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } - patchlevel = Tcl_GetVar2(interp, "tcl_patchLevel", NULL, + patchlevel = Tcl_GetVar(interp, "tcl_patchLevel", (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); if (patchlevel != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj(patchlevel, -1)); return TCL_OK; } @@ -1904,11 +1907,11 @@ goto simpleProcOK; } } else { simpleProcOK: if (specificNsInPattern) { - elemObjPtr = Tcl_NewObj(); + TclNewObj(elemObjPtr); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, elemObjPtr); } else { elemObjPtr = Tcl_NewStringObj(simplePattern, -1); } @@ -1932,11 +1935,11 @@ goto procOK; } } else { procOK: if (specificNsInPattern) { - elemObjPtr = Tcl_NewObj(); + TclNewObj(elemObjPtr); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, elemObjPtr); } else { elemObjPtr = Tcl_NewStringObj(cmdName, -1); } @@ -1956,11 +1959,11 @@ #ifdef INFO_PROCS_SEARCH_GLOBAL_NS /* * If "info procs" worked like "info commands", returning the commands * also seen in the global namespace, then you would include this - * code. As this could break backwards compatibilty with 8.0-8.2, we + * code. As this could break backwards compatibility with 8.0-8.2, we * decided not to "fix" it in 8.3, leaving the behavior slightly * different. */ if ((nsPtr != globalNsPtr) && !specificNsInPattern) { @@ -2123,64 +2126,10 @@ } /* *---------------------------------------------------------------------- * - * InfoCmdTypeCmd -- - * - * Called to implement the "info cmdtype" command that returns the type - * of a given command. Handles the following syntax: - * - * info cmdtype cmdName - * - * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. - * - * Side effects: - * Returns a type name. If there is an error, the result is an error - * message. - * - *---------------------------------------------------------------------- - */ - -static int -InfoCmdTypeCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Command command; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "commandName"); - return TCL_ERROR; - } - command = Tcl_FindCommand(interp, TclGetString(objv[1]), NULL, - TCL_LEAVE_ERR_MSG); - if (command == NULL) { - return TCL_ERROR; - } - - /* - * There's one special case: safe slave interpreters can't see aliases as - * aliases as they're part of the security mechanisms. - */ - - if (Tcl_IsSafe(interp) - && (((Command *) command)->objProc == TclAliasObjCmd)) { - Tcl_AppendResult(interp, "native", NULL); - } else { - Tcl_SetObjResult(interp, - Tcl_NewStringObj(TclGetCommandTypeName(command), -1)); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * * Tcl_JoinObjCmd -- * * This procedure is invoked to process the "join" Tcl command. See the * user documentation for details on what it does. * @@ -2198,13 +2147,12 @@ ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { - size_t length; - int listLen; - Tcl_Obj *resObjPtr = NULL, *joinObjPtr, **elemPtrs; + int listLen, i; + Tcl_Obj *resObjPtr, *joinObjPtr, **elemPtrs; if ((objc < 2) || (objc > 3)) { Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?"); return TCL_ERROR; } @@ -2217,51 +2165,31 @@ if (TclListObjGetElements(interp, objv[1], &listLen, &elemPtrs) != TCL_OK) { return TCL_ERROR; } - if (listLen == 0) { - /* No elements to join; default empty result is correct. */ - return TCL_OK; - } - if (listLen == 1) { - /* One element; return it */ - Tcl_SetObjResult(interp, elemPtrs[0]); - return TCL_OK; - } - joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2]; Tcl_IncrRefCount(joinObjPtr); - (void) TclGetStringFromObj(joinObjPtr, &length); - if (length == 0) { - resObjPtr = TclStringCat(interp, listLen, elemPtrs, 0); - } else { - int i; - - resObjPtr = Tcl_NewObj(); - for (i = 0; i < listLen; i++) { - if (i > 0) { - - /* - * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT** - * to shimmer joinObjPtr. If it did, then the case where - * objv[1] and objv[2] are the same value would not be safe. - * Accessing elemPtrs would crash. - */ - - Tcl_AppendObjToObj(resObjPtr, joinObjPtr); - } - Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]); - } + TclNewObj(resObjPtr); + for (i = 0; i < listLen; i++) { + if (i > 0) { + + /* + * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT** + * to shimmer joinObjPtr. If it did, then the case where + * objv[1] and objv[2] are the same value would not be safe. + * Accessing elemPtrs would crash. + */ + + Tcl_AppendObjToObj(resObjPtr, joinObjPtr); + } + Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]); } Tcl_DecrRefCount(joinObjPtr); - if (resObjPtr) { - Tcl_SetObjResult(interp, resObjPtr); - return TCL_OK; - } - return TCL_ERROR; + Tcl_SetObjResult(interp, resObjPtr); + return TCL_OK; } /* *---------------------------------------------------------------------- * @@ -2418,12 +2346,11 @@ Tcl_Interp *interp, /* Current interpreter. */ register int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Obj *listPtr; - size_t index; - int len, result; + int index, len, result; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "list index ?element ...?"); return TCL_ERROR; } @@ -2441,11 +2368,11 @@ result = TclGetIntForIndexM(interp, objv[2], /*end*/ len, &index); if (result != TCL_OK) { return result; } - if (index + 1 > (size_t)len + 1) { + if (index > len) { index = len; } /* * If the list object is unshared we can modify it directly. Otherwise we @@ -2455,11 +2382,11 @@ listPtr = objv[1]; if (Tcl_IsShared(listPtr)) { listPtr = TclListObjCopy(NULL, listPtr); } - if ((objc == 4) && (index == (size_t)len)) { + if ((objc == 4) && (index == len)) { /* * Special case: insert one element at the end of the list. */ Tcl_ListObjAppendElement(NULL, listPtr, objv[3]); @@ -2554,104 +2481,11 @@ /* * Set the interpreter's object result to an integer object holding the * length. */ - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(listLen)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_LpopObjCmd -- - * - * This procedure is invoked to process the "lpop" Tcl command. See the - * user documentation for details on what it does. - * - * Results: - * A standard Tcl object result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_LpopObjCmd( - ClientData notUsed, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - register Tcl_Obj *const objv[]) - /* Argument objects. */ -{ - int listLen, result; - Tcl_Obj *elemPtr, *stored; - Tcl_Obj *listPtr, **elemPtrs; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "listvar ?index?"); - return TCL_ERROR; - } - - listPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); - if (listPtr == NULL) { - return TCL_ERROR; - } - - result = TclListObjGetElements(interp, listPtr, &listLen, &elemPtrs); - if (result != TCL_OK) { - return result; - } - - /* - * First, extract the element to be returned. - * TclLindexFlat adds a ref count which is handled. - */ - - if (objc == 2) { - elemPtr = elemPtrs[listLen - 1]; - Tcl_IncrRefCount(elemPtr); - } else { - elemPtr = TclLindexFlat(interp, listPtr, objc-2, objv+2); - - if (elemPtr == NULL) { - return TCL_ERROR; - } - } - Tcl_SetObjResult(interp, elemPtr); - Tcl_DecrRefCount(elemPtr); - - /* - * Second, remove the element. - * TclLsetFlat adds a ref count which is handled. - */ - - if (objc == 2) { - if (Tcl_IsShared(listPtr)) { - listPtr = TclListObjCopy(NULL, listPtr); - } - result = Tcl_ListObjReplace(interp, listPtr, listLen - 1, 1, 0, NULL); - if (result != TCL_OK) { - return result; - } - Tcl_IncrRefCount(listPtr); - } else { - listPtr = TclLsetFlat(interp, listPtr, objc-2, objv+2, NULL); - - if (listPtr == NULL) { - return TCL_ERROR; - } - } - - stored = Tcl_ObjSetVar2(interp, objv[1], NULL, listPtr, TCL_LEAVE_ERR_MSG); - Tcl_DecrRefCount(listPtr); - if (stored == NULL) { - return TCL_ERROR; - } - + Tcl_SetObjResult(interp, Tcl_NewIntObj(listLen)); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -2676,12 +2510,12 @@ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ register Tcl_Obj *const objv[]) /* Argument objects. */ { - int listLen, result; - size_t first, last; + Tcl_Obj **elemPtrs; + int listLen, first, last, result; if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "list first last"); return TCL_ERROR; } @@ -2694,152 +2528,59 @@ result = TclGetIntForIndexM(interp, objv[2], /*endValue*/ listLen - 1, &first); if (result != TCL_OK) { return result; } + if (first < 0) { + first = 0; + } result = TclGetIntForIndexM(interp, objv[3], /*endValue*/ listLen - 1, &last); if (result != TCL_OK) { return result; } - - Tcl_SetObjResult(interp, TclListObjRange(objv[1], first, last)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_LremoveObjCmd -- - * - * This procedure is invoked to process the "lremove" Tcl command. See the - * user documentation for details on what it does. - * - * Results: - * A standard Tcl object result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -static int -LremoveIndexCompare( - const void *el1Ptr, - const void *el2Ptr) -{ - size_t idx1 = *((const size_t *) el1Ptr); - size_t idx2 = *((const size_t *) el2Ptr); - - /* - * This will put the larger element first. - */ - - return (idx1 < idx2) ? 1 : (idx1 > idx2) ? -1 : 0; -} - -int -Tcl_LremoveObjCmd( - ClientData notUsed, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - int i, idxc, listLen, prevIdx, first, num; - size_t *idxv; - Tcl_Obj *listObj; - - /* - * Parse the arguments. - */ - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "list ?index ...?"); - return TCL_ERROR; - } - - listObj = objv[1]; - if (TclListObjLength(interp, listObj, &listLen) != TCL_OK) { - return TCL_ERROR; - } - - idxc = objc - 2; - if (idxc == 0) { - Tcl_SetObjResult(interp, listObj); - return TCL_OK; - } - idxv = Tcl_Alloc((objc - 2) * sizeof(size_t)); - for (i = 2; i < objc; i++) { - if (TclGetIntForIndexM(interp, objv[i], /*endValue*/ listLen - 1, - &idxv[i - 2]) != TCL_OK) { - Tcl_Free(idxv); - return TCL_ERROR; - } - } - - /* - * Sort the indices, large to small so that when we remove an index we - * don't change the indices still to be processed. - */ - - if (idxc > 1) { - qsort(idxv, idxc, sizeof(size_t), LremoveIndexCompare); - } - - /* - * Make our working copy, then do the actual removes piecemeal. - */ - - if (Tcl_IsShared(listObj)) { - listObj = TclListObjCopy(NULL, listObj); - } - num = 0; - first = listLen; - for (i = 0, prevIdx = -1 ; i < idxc ; i++) { - int idx = idxv[i]; - - /* - * Repeated index and sanity check. - */ - - if (idx == prevIdx) { - continue; - } - prevIdx = idx; - if (idx < 0 || idx >= listLen) { - continue; - } - - /* - * Coalesce adjacent removes to reduce the number of copies. - */ - - if (num == 0) { - num = 1; - first = idx; - } else if (idx + 1 == first) { - num++; - first = idx; - } else { - /* - * Note that this operation can't fail now; we know we have a list - * and we're only ever contracting that list. - */ - - (void) Tcl_ListObjReplace(interp, listObj, first, num, 0, NULL); - listLen -= num; - num = 1; - first = idx; - } - } - if (num != 0) { - (void) Tcl_ListObjReplace(interp, listObj, first, num, 0, NULL); - } - Tcl_Free(idxv); - Tcl_SetObjResult(interp, listObj); + if (last >= listLen) { + last = listLen - 1; + } + + if (first > last) { + /* + * Returning an empty list is easy. + */ + + return TCL_OK; + } + + result = TclListObjGetElements(interp, objv[1], &listLen, &elemPtrs); + if (result != TCL_OK) { + return result; + } + + if (Tcl_IsShared(objv[1]) || + ((ListRepPtr(objv[1])->refCount > 1))) { + Tcl_SetObjResult(interp, Tcl_NewListObj(last - first + 1, + &elemPtrs[first])); + } else { + /* + * In-place is possible. + */ + + if (last < (listLen - 1)) { + Tcl_ListObjReplace(interp, objv[1], last + 1, listLen - 1 - last, + 0, NULL); + } + + /* + * This one is not conditioned on (first > 0) in order to preserve the + * string-canonizing effect of [lrange 0 end]. + */ + + Tcl_ListObjReplace(interp, objv[1], 0, first, 0, NULL); + Tcl_SetObjResult(interp, objv[1]); + } + return TCL_OK; } /* *---------------------------------------------------------------------- @@ -2973,12 +2714,11 @@ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register Tcl_Obj *listPtr; - size_t first, last; - int listLen, numToDelete, result; + int first, last, listLen, numToDelete, result; if (objc < 4) { Tcl_WrongNumArgs(interp, 1, objv, "list first last ?element ...?"); return TCL_ERROR; @@ -3003,20 +2743,21 @@ result = TclGetIntForIndexM(interp, objv[3], /*end*/ listLen-1, &last); if (result != TCL_OK) { return result; } - if (first == TCL_INDEX_NONE) { + if (first < 0) { first = 0; - } else if (first > (size_t)listLen) { + } + if (first > listLen) { first = listLen; } - if (last + 1 > (size_t)listLen) { + if (last >= listLen) { last = listLen - 1; } - if (first + 1 <= last + 1) { + if (first <= last) { numToDelete = last - first + 1; } else { numToDelete = 0; } @@ -3153,34 +2894,32 @@ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument values. */ { const char *bytes, *patternBytes; - int i, match, index, result=TCL_OK, listc, bisect; - size_t length = 0, elemLen, start, groupSize, groupOffset, lower, upper; - int allocatedIndexVector = 0; - int dataType, isIncreasing; - Tcl_WideInt patWide, objWide, wide; + int i, match, index, result=TCL_OK, listc, length, elemLen, bisect; + int dataType, isIncreasing, lower, upper, offset; + Tcl_WideInt patWide, objWide; int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase; double patDouble, objDouble; SortInfo sortInfo; Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr; - SortStrCmpFn_t strCmpFn = TclUtfCmp; + SortStrCmpFn_t strCmpFn = strcmp; Tcl_RegExp regexp = NULL; static const char *const options[] = { "-all", "-ascii", "-bisect", "-decreasing", "-dictionary", "-exact", "-glob", "-increasing", "-index", "-inline", "-integer", "-nocase", "-not", - "-real", "-regexp", "-sorted", "-start", "-stride", + "-real", "-regexp", "-sorted", "-start", "-subindices", NULL }; enum options { LSEARCH_ALL, LSEARCH_ASCII, LSEARCH_BISECT, LSEARCH_DECREASING, LSEARCH_DICTIONARY, LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_INCREASING, LSEARCH_INDEX, LSEARCH_INLINE, LSEARCH_INTEGER, LSEARCH_NOCASE, LSEARCH_NOT, LSEARCH_REAL, LSEARCH_REGEXP, LSEARCH_SORTED, - LSEARCH_START, LSEARCH_STRIDE, LSEARCH_SUBINDICES + LSEARCH_START, LSEARCH_SUBINDICES }; enum datatypes { ASCII, DICTIONARY, INTEGER, REAL }; enum modes { @@ -3196,13 +2935,11 @@ returnSubindices = 0; negatedMatch = 0; bisect = 0; listPtr = NULL; startPtr = NULL; - groupSize = 1; - groupOffset = 0; - start = 0; + offset = 0; noCase = 0; sortInfo.compareCmdPtr = NULL; sortInfo.isIncreasing = 1; sortInfo.sortMode = 0; sortInfo.interp = interp; @@ -3216,10 +2953,13 @@ } for (i = 1; i < objc-2; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) != TCL_OK) { + if (startPtr != NULL) { + Tcl_DecrRefCount(startPtr); + } result = TCL_ERROR; goto done; } switch ((enum options) index) { case LSEARCH_ALL: /* -all */ @@ -3280,11 +3020,10 @@ * because it will either be replaced or there will be an error. */ if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); - startPtr = NULL; } if (i > objc-4) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing starting index", -1)); Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); @@ -3301,52 +3040,29 @@ */ startPtr = Tcl_DuplicateObj(objv[i]); } else { startPtr = objv[i]; - } - Tcl_IncrRefCount(startPtr); - break; - case LSEARCH_STRIDE: /* -stride */ - if (i > objc-4) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "\"-stride\" option must be " - "followed by stride length", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); - result = TCL_ERROR; - goto done; - } - if (Tcl_GetWideIntFromObj(interp, objv[i+1], &wide) != TCL_OK) { - result = TCL_ERROR; - goto done; - } - if (wide < 1) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "stride length must be at least 1", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", - "BADSTRIDE", NULL); - result = TCL_ERROR; - goto done; - } - groupSize = wide; - i++; + Tcl_IncrRefCount(startPtr); + } break; case LSEARCH_INDEX: { /* -index */ Tcl_Obj **indices; int j; - if (allocatedIndexVector) { + if (sortInfo.indexc > 1) { TclStackFree(interp, sortInfo.indexv); - allocatedIndexVector = 0; } if (i > objc-4) { + if (startPtr != NULL) { + Tcl_DecrRefCount(startPtr); + } Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-index\" option must be followed by list index", -1)); Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); - result = TCL_ERROR; - goto done; + return TCL_ERROR; } /* * Store the extracted indices for processing by sublist * extraction. Note that we don't do this using objects because @@ -3354,12 +3070,14 @@ */ i++; if (TclListObjGetElements(interp, objv[i], &sortInfo.indexc, &indices) != TCL_OK) { - result = TCL_ERROR; - goto done; + if (startPtr != NULL) { + Tcl_DecrRefCount(startPtr); + } + return TCL_ERROR; } switch (sortInfo.indexc) { case 0: sortInfo.indexv = NULL; break; @@ -3367,12 +3085,10 @@ sortInfo.indexv = &sortInfo.singleIndex; break; default: sortInfo.indexv = TclStackAlloc(interp, sizeof(int) * sortInfo.indexc); - allocatedIndexVector = 1; /* Cannot use indexc field, as it - * might be decreased by 1 later. */ } /* * Fill the array by parsing each index. We don't know whether * their scale is sensible yet, but we at least perform the @@ -3379,18 +3095,19 @@ * syntactic check here. */ for (j=0 ; j 1) { - if (listc % groupSize) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "list size must be a multiple of the stride length", - -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", "BADSTRIDE", - NULL); - result = TCL_ERROR; - goto done; - } - if (sortInfo.indexc > 0) { - /* - * Use the first value in the list supplied to -index as the - * offset of the element within each group by which to sort. - */ - - groupOffset = TclIndexDecode(sortInfo.indexv[0], groupSize - 1); - if (groupOffset >= groupSize) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "when used with \"-stride\", the leading \"-index\"" - " value must be within the group", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", - "BADINDEX", NULL); - result = TCL_ERROR; - goto done; - } - if (sortInfo.indexc == 1) { - sortInfo.indexc = 0; - sortInfo.indexv = NULL; - } else { - sortInfo.indexc--; - - for (i = 0; i < sortInfo.indexc; i++) { - sortInfo.indexv[i] = sortInfo.indexv[i+1]; - } - } - } + if (startPtr != NULL) { + Tcl_DecrRefCount(startPtr); + } + goto done; } /* * Get the user-specified start offset. */ if (startPtr) { - result = TclGetIntForIndexM(interp, startPtr, listc-1, &start); + result = TclGetIntForIndexM(interp, startPtr, listc-1, &offset); + Tcl_DecrRefCount(startPtr); if (result != TCL_OK) { goto done; } - if (start == TCL_INDEX_NONE) { - start = TCL_INDEX_START; + if (offset < 0) { + offset = 0; } /* * If the search started past the end of the list, we just return a * "did not match anything at all" result straight away. [Bug 1374778] */ - if (start >= (size_t)listc) { + if (offset > listc-1) { + if (sortInfo.indexc > 1) { + TclStackFree(interp, sortInfo.indexv); + } if (allMatches || inlineReturn) { Tcl_ResetResult(interp); } else { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-1)); - } - goto done; - } - - /* - * If start points within a group, it points to the start of the group. - */ - - if (groupSize > 1) { - start -= (start % groupSize); + Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); + } + return TCL_OK; } } patObj = objv[objc - 1]; patternBytes = NULL; @@ -3598,27 +3274,22 @@ * that there is no point in being smart when -all was specified; in * that case, we have to look at all items anyway, and there is no * sense in doing this when the match sense is inverted. */ - /* - * With -stride, lower, upper and i are kept as multiples of groupSize. - */ - - lower = start - groupSize; + lower = offset - 1; upper = listc; - while (lower + groupSize != upper && sortInfo.resultCode == TCL_OK) { + while (lower + 1 != upper && sortInfo.resultCode == TCL_OK) { i = (lower + upper)/2; - i -= i % groupSize; if (sortInfo.indexc != 0) { - itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo); + itemPtr = SelectObjFromSublist(listv[i], &sortInfo); if (sortInfo.resultCode != TCL_OK) { result = sortInfo.resultCode; goto done; } } else { - itemPtr = listv[i+groupOffset]; + itemPtr = listv[i]; } switch ((enum datatypes) dataType) { case ASCII: bytes = TclGetString(itemPtr); match = strCmpFn(patternBytes, bytes); @@ -3656,15 +3327,15 @@ } if (match == 0) { /* * Normally, binary search is written to stop when it finds a * match. If there are duplicates of an element in the list, - * our first match might not be the first occurance. + * our first match might not be the first occurrence. * Consider: 0 0 0 1 1 1 2 2 2 * * To maintain consistancy with standard lsearch semantics, we - * must find the leftmost occurance of the pattern in the + * must find the leftmost occurrence of the pattern in the * list. Thus we don't just stop searching here. This * variation means that a search always makes log n * comparisons (normal binary search might "get lucky" with an * early comparison). * @@ -3703,23 +3374,23 @@ */ if (allMatches) { listPtr = Tcl_NewListObj(0, NULL); } - for (i = start; i < listc; i += groupSize) { + for (i = offset; i < listc; i++) { match = 0; if (sortInfo.indexc != 0) { - itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo); + itemPtr = SelectObjFromSublist(listv[i], &sortInfo); if (sortInfo.resultCode != TCL_OK) { if (listPtr != NULL) { Tcl_DecrRefCount(listPtr); } result = sortInfo.resultCode; goto done; } } else { - itemPtr = listv[i+groupOffset]; + itemPtr = listv[i]; } switch (mode) { case SORTED: case EXACT: @@ -3733,11 +3404,12 @@ */ if (noCase) { match = (TclUtfCasecmp(bytes, patternBytes) == 0); } else { - match = (memcmp(bytes, patternBytes, length) == 0); + match = (memcmp(bytes, patternBytes, + (size_t) length) == 0); } } break; case DICTIONARY: @@ -3804,31 +3476,26 @@ /* * Note that these appends are not expected to fail. */ if (returnSubindices && (sortInfo.indexc != 0)) { - itemPtr = SelectObjFromSublist(listv[i+groupOffset], - &sortInfo); - Tcl_ListObjAppendElement(interp, listPtr, itemPtr); - } else if (groupSize > 1) { - Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0, - groupSize, &listv[i]); + itemPtr = SelectObjFromSublist(listv[i], &sortInfo); } else { itemPtr = listv[i]; - Tcl_ListObjAppendElement(interp, listPtr, itemPtr); } + Tcl_ListObjAppendElement(interp, listPtr, itemPtr); } else if (returnSubindices) { int j; - itemPtr = TclNewWideIntObjFromSize(i+groupOffset); + TclNewIntObj(itemPtr, i); for (j=0 ; j 1) { - Tcl_SetObjResult(interp, Tcl_NewListObj(groupSize, &listv[index])); - } else { - Tcl_SetObjResult(interp, listv[index]); - } + Tcl_SetObjResult(interp, listv[index]); } result = TCL_OK; /* * Cleanup the index list array. */ done: - if (startPtr != NULL) { - Tcl_DecrRefCount(startPtr); - } - if (allocatedIndexVector) { + if (sortInfo.indexc > 1) { TclStackFree(interp, sortInfo.indexv); } return result; } @@ -3990,19 +3647,19 @@ ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument values. */ { - int i, index, indices, length, nocase = 0, indexc; + int i, j, index, indices, length, nocase = 0, indexc; int sortMode = SORTMODE_ASCII; - int group, allocatedIndexVector = 0; - size_t j, idx, groupSize, groupOffset; - Tcl_WideInt wide; + int group, groupSize, groupOffset, idx, allocatedIndexVector = 0; Tcl_Obj *resultPtr, *cmdPtr, **listObjPtrs, *listObj, *indexPtr; + size_t elmArrSize; SortElement *elementArray = NULL, *elementPtr; SortInfo sortInfo; /* Information about this sort that needs to * be passed to the comparison function. */ +# define MAXCALLOC 1024000 # define NUM_LISTS 30 SortElement *subList[NUM_LISTS+1]; /* This array holds pointers to temporary * lists built during the merge sort. Element * i of the array holds a list of length @@ -4071,11 +3728,11 @@ break; case LSORT_INCREASING: sortInfo.isIncreasing = 1; break; case LSORT_INDEX: { - int indexc; + int sortindex; Tcl_Obj **indexv; if (i == objc-2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-index\" option must be followed by list index", @@ -4082,11 +3739,11 @@ -1)); Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); sortInfo.resultCode = TCL_ERROR; goto done; } - if (TclListObjGetElements(interp, objv[i+1], &indexc, + if (TclListObjGetElements(interp, objv[i+1], &sortindex, &indexv) != TCL_OK) { sortInfo.resultCode = TCL_ERROR; goto done; } @@ -4096,26 +3753,27 @@ * know if this is the only -index option yet and so we can't * allocate any space; that happens after the scan through all the * options is done. */ - for (j=0 ; j<(size_t)indexc ; j++) { + for (j=0 ; j= groupSize) { + if (groupOffset < 0 || groupOffset >= groupSize) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "when used with \"-stride\", the leading \"-index\"" " value must be within the group", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", "BADINDEX", NULL); @@ -4322,13 +3978,25 @@ /* * The following loop creates a SortElement for each list element and * begins sorting it into the sublists as it appears. */ - elementArray = Tcl_Alloc(length * sizeof(SortElement)); + elmArrSize = length * sizeof(SortElement); + if (elmArrSize <= MAXCALLOC) { + elementArray = ckalloc(elmArrSize); + } else { + elementArray = malloc(elmArrSize); + } + if (!elementArray) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "no enough memory to proccess sort of %d items", length)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + sortInfo.resultCode = TCL_ERROR; + goto done; + } - for (i=0; i < length; i++) { + for (i=0; i < length; i++){ idx = groupSize * i + groupOffset; if (indexc) { /* * If this is an indexed sort, retrieve the corresponding element */ @@ -4418,11 +4086,11 @@ if (group) { for (i=0; elementPtr!=NULL ; elementPtr=elementPtr->nextPtr) { idx = elementPtr->payload.index; for (j = 0; j < groupSize; j++) { if (indices) { - objPtr = TclNewWideIntObjFromSize(idx + j - groupOffset); + TclNewIntObj(objPtr, idx + j - groupOffset); newArray[i++] = objPtr; Tcl_IncrRefCount(objPtr); } else { objPtr = listObjPtrs[idx + j - groupOffset]; newArray[i++] = objPtr; @@ -4430,11 +4098,11 @@ } } } } else if (indices) { for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) { - objPtr = TclNewWideIntObjFromSize(elementPtr->payload.index); + TclNewIntObj(objPtr, elementPtr->payload.index); newArray[i++] = objPtr; Tcl_IncrRefCount(objPtr); } } else { for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) { @@ -4455,11 +4123,15 @@ } if (allocatedIndexVector) { TclStackFree(interp, sortInfo.indexv); } if (elementArray) { - Tcl_Free(elementArray); + if (elmArrSize <= MAXCALLOC) { + ckfree((char *)elementArray); + } else { + free((char *)elementArray); + } } return sortInfo.resultCode; } /* @@ -4590,11 +4262,11 @@ * "lsort" command. */ { int order = 0; if (infoPtr->sortMode == SORTMODE_ASCII) { - order = TclUtfCmp(elemPtr1->collationKey.strValuePtr, + order = strcmp(elemPtr1->collationKey.strValuePtr, elemPtr2->collationKey.strValuePtr); } else if (infoPtr->sortMode == SORTMODE_ASCII_NC) { order = TclUtfCasecmp(elemPtr1->collationKey.strValuePtr, elemPtr2->collationKey.strValuePtr); } else if (infoPtr->sortMode == SORTMODE_DICTIONARY) { @@ -4697,11 +4369,11 @@ static int DictionaryCompare( const char *left, const char *right) /* The strings to compare. */ { - Tcl_UniChar uniLeft = 0, uniRight = 0, uniLeftLower, uniRightLower; + int uniLeft = 0, uniRight = 0, uniLeftLower, uniRightLower; int diff, zeros; int secondaryDiff = 0; while (1) { if (isdigit(UCHAR(*right)) /* INTL: digit */ @@ -4766,22 +4438,22 @@ * string is at the terminating null, do a byte-wise comparison and * bail out immediately. */ if ((*left != '\0') && (*right != '\0')) { - left += TclUtfToUniChar(left, &uniLeft); - right += TclUtfToUniChar(right, &uniRight); + left += TclUtfToUCS4(left, &uniLeft); + right += TclUtfToUCS4(right, &uniRight); /* * Convert both chars to lower for the comparison, because * dictionary sorts are case insensitve. Covert to lower, not * upper, so chars between Z and a will sort before A (where most * other interesting punctuations occur). */ - uniLeftLower = Tcl_UniCharToLower(uniLeft); - uniRightLower = Tcl_UniCharToLower(uniRight); + uniLeftLower = TclUCS4ToLower(uniLeft); + uniRightLower = TclUCS4ToLower(uniRight); } else { diff = UCHAR(*left) - UCHAR(*right); break; } @@ -4862,20 +4534,13 @@ ¤tObj) != TCL_OK) { infoPtr->resultCode = TCL_ERROR; return NULL; } if (currentObj == NULL) { - if (index == (int)TCL_INDEX_NONE) { - index = TCL_INDEX_END - infoPtr->indexv[i]; - Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf( - "element end-%d missing from sublist \"%s\"", - index, TclGetString(objPtr))); - } else { - Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf( - "element %d missing from sublist \"%s\"", - index, TclGetString(objPtr))); - } + Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf( + "element %d missing from sublist \"%s\"", + index, TclGetString(objPtr))); Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT", "INDEXFAILED", NULL); infoPtr->resultCode = TCL_ERROR; return NULL; } Index: generic/tclCmdMZ.c ================================================================== --- generic/tclCmdMZ.c +++ generic/tclCmdMZ.c @@ -125,12 +125,12 @@ ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - size_t offset, stringLength, matchLength, cflags, eflags; - int i, indices, match, about, all, doinline, numMatchesSaved; + int i, indices, match, about, offset, all, doinline, numMatchesSaved; + int cflags, eflags, stringLength, matchLength; Tcl_RegExp regExpr; Tcl_Obj *objPtr, *startIndex = NULL, *resultPtr = NULL; Tcl_RegExpInfo info; static const char *const options[] = { "-all", "-about", "-indices", "-inline", @@ -144,11 +144,11 @@ }; indices = 0; about = 0; cflags = TCL_REG_ADVANCED; - offset = TCL_INDEX_START; + offset = 0; all = 0; doinline = 0; for (i = 1; i < objc; i++) { const char *name; @@ -189,15 +189,15 @@ break; case REGEXP_LINEANCHOR: cflags |= TCL_REG_NLANCH; break; case REGEXP_START: { - size_t temp; + int temp; if (++i >= objc) { goto endOfForLoop; } - if (TclGetIntForIndexM(interp, objv[i], TCL_INDEX_START, &temp) != TCL_OK) { + if (TclGetIntForIndexM(interp, objv[i], 0, &temp) != TCL_OK) { goto optionError; } if (startIndex) { Tcl_DecrRefCount(startIndex); } @@ -257,14 +257,14 @@ objPtr = objv[1]; stringLength = Tcl_GetCharLength(objPtr); if (startIndex) { - TclGetIntForIndexM(interp, startIndex, stringLength, &offset); + TclGetIntForIndexM(NULL, startIndex, stringLength, &offset); Tcl_DecrRefCount(startIndex); - if (offset == TCL_INDEX_NONE) { - offset = TCL_INDEX_START; + if (offset < 0) { + offset = 0; } } regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); if (regExpr == NULL) { @@ -304,13 +304,13 @@ * considered the start of the line. If for example the pattern {^} is * passed and -start is positive, then the pattern will not match the * start of the string unless the previous character is a newline. */ - if (offset == TCL_INDEX_START) { + if (offset == 0) { eflags = 0; - } else if (offset + 1 > stringLength + 1) { + } else if (offset > stringLength) { eflags = TCL_REG_NOTBOL; } else if (Tcl_GetUniChar(objPtr, offset-1) == '\n') { eflags = 0; } else { eflags = TCL_REG_NOTBOL; @@ -322,11 +322,11 @@ return TCL_ERROR; } if (match == 0) { /* - * We want to set the value of the interpreter result only when + * We want to set the value of the intepreter result only when * this is the first time through the loop. */ if (all <= 1) { /* @@ -334,11 +334,11 @@ * empty list, otherwise set it to an integer object w/ value * 0. */ if (!doinline) { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); } return TCL_OK; } break; } @@ -355,53 +355,53 @@ * index 0 */ objc = info.nsubs + 1; if (all <= 1) { - resultPtr = Tcl_NewObj(); + TclNewObj(resultPtr); } } for (i = 0; i < objc; i++) { Tcl_Obj *newPtr; if (indices) { - size_t start, end; + int start, end; Tcl_Obj *objs[2]; /* * Only adjust the match area if there was a match for that * area. (Scriptics Bug 4391/SF Bug #219232) */ - if (i <= (int)info.nsubs && info.matches[i].start != TCL_INDEX_NONE) { + if (i <= info.nsubs && info.matches[i].start >= 0) { start = offset + info.matches[i].start; end = offset + info.matches[i].end; /* * Adjust index so it refers to the last character in the * match instead of the first character after the match. */ - if (end + 1 >= offset + 1) { + if (end >= offset) { end--; } } else { - start = TCL_INDEX_NONE; - end = TCL_INDEX_NONE; + start = -1; + end = -1; } - objs[0] = TclNewWideIntObjFromSize(start); - objs[1] = TclNewWideIntObjFromSize(end); + objs[0] = Tcl_NewLongObj(start); + objs[1] = Tcl_NewLongObj(end); newPtr = Tcl_NewListObj(2, objs); } else { - if (i <= (int)info.nsubs) { + if (i <= info.nsubs) { newPtr = Tcl_GetRange(objPtr, offset + info.matches[i].start, offset + info.matches[i].end - 1); } else { - newPtr = Tcl_NewObj(); + TclNewObj(newPtr); } } if (doinline) { if (Tcl_ListObjAppendElement(interp, resultPtr, newPtr) != TCL_OK) { @@ -442,11 +442,11 @@ if (matchLength == 0) { offset++; } all++; - if (offset + 1 >= stringLength + 1) { + if (offset >= stringLength) { break; } } /* @@ -456,11 +456,11 @@ */ if (doinline) { Tcl_SetObjResult(interp, resultPtr); } else { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(all ? all-1 : 1)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(all ? all-1 : 1)); } return TCL_OK; } /* @@ -485,36 +485,34 @@ ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int result, cflags, all, match, command, numParts; - size_t idx, wlen, wsublen = 0, offset, numMatches; - size_t start, end, subStart, subEnd; + int idx, result, cflags, all, wlen, wsublen, numMatches, offset; + int start, end, subStart, subEnd, match; Tcl_RegExp regExpr; Tcl_RegExpInfo info; Tcl_Obj *resultPtr, *subPtr, *objPtr, *startIndex = NULL; - Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec = 0, *wend; + Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec, *wend; static const char *const options[] = { - "-all", "-command", "-expanded", "-line", - "-linestop", "-lineanchor", "-nocase", "-start", + "-all", "-nocase", "-expanded", + "-line", "-linestop", "-lineanchor", "-start", "--", NULL }; enum options { - REGSUB_ALL, REGSUB_COMMAND, REGSUB_EXPANDED, REGSUB_LINE, - REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_NOCASE, REGSUB_START, + REGSUB_ALL, REGSUB_NOCASE, REGSUB_EXPANDED, + REGSUB_LINE, REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_START, REGSUB_LAST }; cflags = TCL_REG_ADVANCED; all = 0; - offset = TCL_INDEX_START; - command = 0; + offset = 0; resultPtr = NULL; - for (idx = 1; idx < (size_t)objc; idx++) { + for (idx = 1; idx < objc; idx++) { const char *name; int index; name = TclGetString(objv[idx]); if (name[0] != '-') { @@ -529,13 +527,10 @@ all = 1; break; case REGSUB_NOCASE: cflags |= TCL_REG_NOCASE; break; - case REGSUB_COMMAND: - command = 1; - break; case REGSUB_EXPANDED: cflags |= TCL_REG_EXPANDED; break; case REGSUB_LINE: cflags |= TCL_REG_NEWLINE; @@ -545,15 +540,15 @@ break; case REGSUB_LINEANCHOR: cflags |= TCL_REG_NLANCH; break; case REGSUB_START: { - size_t temp; - if (++idx >= (size_t)objc) { + int temp; + if (++idx >= objc) { goto endOfForLoop; } - if (TclGetIntForIndexM(interp, objv[idx], TCL_INDEX_START, &temp) != TCL_OK) { + if (TclGetIntForIndexM(interp, objv[idx], 0, &temp) != TCL_OK) { goto optionError; } if (startIndex) { Tcl_DecrRefCount(startIndex); } @@ -566,11 +561,11 @@ goto endOfForLoop; } } endOfForLoop: - if ((size_t)objc < idx + 3 || (size_t)objc > idx + 4) { + if (objc-idx < 3 || objc-idx > 4) { Tcl_WrongNumArgs(interp, 1, objv, "?-option ...? exp string subSpec ?varName?"); optionError: if (startIndex) { Tcl_DecrRefCount(startIndex); @@ -580,39 +575,38 @@ objc -= idx; objv += idx; if (startIndex) { - size_t stringLength = Tcl_GetCharLength(objv[1]); + int stringLength = Tcl_GetCharLength(objv[1]); - TclGetIntForIndexM(interp, startIndex, stringLength, &offset); + TclGetIntForIndexM(NULL, startIndex, stringLength, &offset); Tcl_DecrRefCount(startIndex); - if (offset == TCL_INDEX_NONE) { - offset = TCL_INDEX_START; + if (offset < 0) { + offset = 0; } } - if (all && (offset == TCL_INDEX_START) && (command == 0) + if (all && (offset == 0) && (strpbrk(TclGetString(objv[2]), "&\\") == NULL) && (strpbrk(TclGetString(objv[0]), "*+?{}()[].\\|^$") == NULL)) { /* * This is a simple one pair string map situation. We make use of a * slightly modified version of the one pair STR_MAP code. */ - size_t slen; - int nocase, wsrclc; - int (*strCmpFn)(const Tcl_UniChar*,const Tcl_UniChar*,size_t); - Tcl_UniChar *p; + int slen, nocase; + int (*strCmpFn)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long); + Tcl_UniChar *p, wsrclc; numMatches = 0; nocase = (cflags & TCL_REG_NOCASE); strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp; - wsrc = TclGetUnicodeFromObj(objv[0], &slen); - wstring = TclGetUnicodeFromObj(objv[1], &wlen); - wsubspec = TclGetUnicodeFromObj(objv[2], &wsublen); + wsrc = Tcl_GetUnicodeFromObj(objv[0], &slen); + wstring = Tcl_GetUnicodeFromObj(objv[1], &wlen); + wsubspec = Tcl_GetUnicodeFromObj(objv[2], &wsublen); wend = wstring + wlen - (slen ? slen - 1 : 0); result = TCL_OK; if (slen == 0) { /* @@ -633,11 +627,12 @@ } else { wsrclc = Tcl_UniCharToLower(*wsrc); for (p = wfirstChar = wstring; wstring < wend; wstring++) { if ((*wstring == *wsrc || (nocase && Tcl_UniCharToLower(*wstring)==wsrclc)) && - (slen==1 || (strCmpFn(wstring, wsrc, slen) == 0))) { + (slen==1 || (strCmpFn(wstring, wsrc, + (unsigned long) slen) == 0))) { if (numMatches == 0) { resultPtr = Tcl_NewUnicodeObj(wstring, 0); Tcl_IncrRefCount(resultPtr); } if (p != wstring) { @@ -665,32 +660,10 @@ regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); if (regExpr == NULL) { return TCL_ERROR; } - if (command) { - /* - * In command-prefix mode, we require that the third non-option - * argument be a list, so we enforce that here. Afterwards, we fetch - * the RE compilation again in case objv[0] and objv[2] are the same - * object. (If they aren't, that's cheap to do.) - */ - - if (Tcl_ListObjLength(interp, objv[2], &numParts) != TCL_OK) { - return TCL_ERROR; - } - if (numParts < 1) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "command prefix must be a list of at least one element", - -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "REGSUB", - "CMDEMPTY", NULL); - return TCL_ERROR; - } - regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); - } - /* * Make sure to avoid problems where the objects are shared. This can * cause RegExpObj <> UnicodeObj shimmering that causes data corruption. * [Bug #461322] */ @@ -698,19 +671,17 @@ if (objv[1] == objv[0]) { objPtr = Tcl_DuplicateObj(objv[1]); } else { objPtr = objv[1]; } - wstring = TclGetUnicodeFromObj(objPtr, &wlen); + wstring = Tcl_GetUnicodeFromObj(objPtr, &wlen); if (objv[2] == objv[0]) { subPtr = Tcl_DuplicateObj(objv[2]); } else { subPtr = objv[2]; } - if (!command) { - wsubspec = TclGetUnicodeFromObj(subPtr, &wsublen); - } + wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen); result = TCL_OK; /* * The following loop is to handle multiple matches within the same source @@ -743,11 +714,11 @@ break; } if (numMatches == 0) { resultPtr = Tcl_NewUnicodeObj(wstring, 0); Tcl_IncrRefCount(resultPtr); - if (offset > TCL_INDEX_START) { + if (offset > 0) { /* * Copy the initial portion of the string in if an offset was * specified. */ @@ -764,94 +735,10 @@ Tcl_RegExpGetInfo(regExpr, &info); start = info.matches[0].start; end = info.matches[0].end; Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, start); - /* - * In command-prefix mode, the substitutions are added as quoted - * arguments to the subSpec to form a command, that is then executed - * and the result used as the string to substitute in. Actually, - * everything is passed through Tcl_EvalObjv, as that's much faster. - */ - - if (command) { - Tcl_Obj **args = NULL, **parts; - int numArgs; - - Tcl_ListObjGetElements(interp, subPtr, &numParts, &parts); - numArgs = numParts + info.nsubs + 1; - args = Tcl_Alloc(sizeof(Tcl_Obj*) * numArgs); - memcpy(args, parts, sizeof(Tcl_Obj*) * numParts); - - for (idx = 0 ; idx <= info.nsubs ; idx++) { - subStart = info.matches[idx].start; - subEnd = info.matches[idx].end; - if ((subStart >= 0) && (subEnd >= 0)) { - args[idx + numParts] = Tcl_NewUnicodeObj( - wstring + offset + subStart, subEnd - subStart); - } else { - args[idx + numParts] = Tcl_NewObj(); - } - Tcl_IncrRefCount(args[idx + numParts]); - } - - /* - * At this point, we're locally holding the references to the - * argument words we added for this time round the loop, and the - * subPtr is holding the references to the words that the user - * supplied directly. None are zero-refcount, which is important - * because Tcl_EvalObjv is "hairy monster" in terms of refcount - * handling, being able to optionally add references to any of its - * argument words. We'll drop the local refs immediately - * afterwards; subPtr is handled in the main exit stanza. - */ - - result = Tcl_EvalObjv(interp, numArgs, args, 0); - for (idx = 0 ; idx <= info.nsubs ; idx++) { - TclDecrRefCount(args[idx + numParts]); - } - Tcl_Free(args); - if (result != TCL_OK) { - if (result == TCL_ERROR) { - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (%s substitution computation script)", - options[REGSUB_COMMAND])); - } - goto done; - } - - Tcl_AppendObjToObj(resultPtr, Tcl_GetObjResult(interp)); - Tcl_ResetResult(interp); - - /* - * Refetch the unicode, in case the representation was smashed by - * the user code. - */ - - wstring = TclGetUnicodeFromObj(objPtr, &wlen); - - offset += end; - if (end == 0 || start == end) { - /* - * Always consume at least one character of the input string - * in order to prevent infinite loops, even when we - * technically matched the empty string; we must not match - * again at the same spot. - */ - - if (offset < wlen) { - Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); - } - offset++; - } - if (all) { - continue; - } else { - break; - } - } - /* * Append the subSpec argument to the variable, making appropriate * substitutions. This code is a bit hairy because of the backslash * conventions and because the code saves up ranges of characters in * subSpec to reduce the number of calls to Tcl_SetVar. @@ -959,11 +846,11 @@ /* * Set the interpreter's object result to an integer object * holding the number of matches. */ - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(numMatches)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(numMatches)); } } else { /* * No varname supplied, so just return the modified string. */ @@ -1101,15 +988,12 @@ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *encodingName = NULL; Tcl_Obj *fileName; - int result; - void **pkgFiles = NULL; - void *names = NULL; - if (objc < 2 || objc > 4) { + if (objc != 2 && objc !=4) { Tcl_WrongNumArgs(interp, 1, objv, "?-encoding name? fileName"); return TCL_ERROR; } fileName = objv[objc-1]; @@ -1123,34 +1007,13 @@ if (TCL_ERROR == Tcl_GetIndexFromObj(interp, objv[1], options, "option", TCL_EXACT, &index)) { return TCL_ERROR; } encodingName = TclGetString(objv[2]); - } else if (objc == 3) { - /* Handle undocumented -nopkg option. This should only be - * used by the internal ::tcl::Pkg::source utility function. */ - static const char *const nopkgoptions[] = { - "-nopkg", NULL - }; - int index; - - if (TCL_ERROR == Tcl_GetIndexFromObj(interp, objv[1], nopkgoptions, - "option", TCL_EXACT, &index)) { - return TCL_ERROR; - } - pkgFiles = Tcl_GetAssocData(interp, "tclPkgFiles", NULL); - /* Make sure that during the following TclNREvalFile no filenames - * are recorded for inclusion in the "package files" command */ - names = *pkgFiles; - *pkgFiles = NULL; - } - result = TclNREvalFile(interp, fileName, encodingName); - if (pkgFiles) { - /* restore "tclPkgFiles" assocdata to how it was. */ - *pkgFiles = names; - } - return result; + } + + return TclNREvalFile(interp, fileName, encodingName); } /* *---------------------------------------------------------------------- * @@ -1178,11 +1041,11 @@ Tcl_UniChar ch = 0; int len; const char *splitChars; const char *stringPtr; const char *end; - size_t splitCharLen, stringLen; + int splitCharLen, stringLen; Tcl_Obj *listPtr, *objPtr; if (objc == 2) { splitChars = " \n\t\r"; splitCharLen = 4; @@ -1193,11 +1056,11 @@ return TCL_ERROR; } stringPtr = TclGetStringFromObj(objv[1], &stringLen); end = stringPtr + stringLen; - listPtr = Tcl_NewObj(); + TclNewObj(listPtr); if (stringLen == 0) { /* * Do nothing. */ @@ -1216,27 +1079,14 @@ */ Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS); for ( ; stringPtr < end; stringPtr += len) { - int fullchar; - len = TclUtfToUniChar(stringPtr, &ch); - fullchar = ch; - -#if TCL_UTF_MAX <= 4 - if ((ch >= 0xD800) && (len < 3)) { - len += TclUtfToUniChar(stringPtr + len, &ch); - fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; - } -#endif - - /* - * Assume Tcl_UniChar is an integral type... - */ - - hPtr = Tcl_CreateHashEntry(&charReuseTable, INT2PTR(fullchar), - &isNew); + int ucs4; + + len = TclUtfToUCS4(stringPtr, &ucs4); + hPtr = Tcl_CreateHashEntry(&charReuseTable, INT2PTR(ucs4), &isNew); if (isNew) { TclNewStringObj(objPtr, stringPtr, len); /* * Don't need to fiddle with refcount... @@ -1257,20 +1107,20 @@ * Handle the special case of splitting on a single character. This is * only true for the one-char ASCII case, as one unicode char is > 1 * byte in length. */ - while (*stringPtr && (p=strchr(stringPtr,*splitChars)) != NULL) { + while (*stringPtr && (p=strchr(stringPtr,(int)*splitChars)) != NULL) { objPtr = Tcl_NewStringObj(stringPtr, p - stringPtr); Tcl_ListObjAppendElement(NULL, listPtr, objPtr); stringPtr = p + 1; } TclNewStringObj(objPtr, stringPtr, end - stringPtr); Tcl_ListObjAppendElement(NULL, listPtr, objPtr); } else { const char *element, *p, *splitEnd; - size_t splitLen; + int splitLen; Tcl_UniChar splitChar = 0; /* * Normal case: split on any of a given set of characters. Discard * instances of the split characters. @@ -1321,27 +1171,95 @@ ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - size_t start = TCL_INDEX_START; + Tcl_UniChar *needleStr, *haystackStr; + int match, start, needleLen, haystackLen; if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "needleString haystackString ?startIndex?"); return TCL_ERROR; } + /* + * We are searching haystackStr for the sequence needleStr. + */ + + match = -1; + start = 0; + haystackLen = -1; + + needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen); + haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen); + if (objc == 4) { - size_t end = Tcl_GetCharLength(objv[2]) - 1; + /* + * If a startIndex is specified, we will need to fast forward to that + * point in the string before we think about a match. + */ - if (TCL_OK != TclGetIntForIndexM(interp, objv[3], end, &start)) { + if (TclGetIntForIndexM(interp, objv[3], haystackLen-1, + &start) != TCL_OK){ return TCL_ERROR; } + + /* + * Reread to prevent shimmering problems. + */ + + needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen); + haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen); + + if (start >= haystackLen) { + goto str_first_done; + } else if (start > 0) { + haystackStr += start; + haystackLen -= start; + } else if (start < 0) { + /* + * Invalid start index mapped to string start; Bug #423581 + */ + + start = 0; + } } - Tcl_SetObjResult(interp, TclNewWideIntObjFromSize(TclStringFirst(objv[1], - objv[2], start))); + + /* + * If the length of the needle is more than the length of the haystack, it + * cannot be contained in there so we can avoid searching. [Bug 2960021] + */ + + if (needleLen > 0 && needleLen <= haystackLen) { + Tcl_UniChar *p, *end; + + end = haystackStr + haystackLen - needleLen + 1; + for (p = haystackStr; p < end; p++) { + /* + * Scan forward to find the first character. + */ + + if ((*p == *needleStr) && (TclUniCharNcmp(needleStr, p, + (unsigned long) needleLen) == 0)) { + match = p - haystackStr; + break; + } + } + } + + /* + * Compute the character index of the matching string by counting the + * number of characters before the match. + */ + + if ((match != -1) && (objc == 4)) { + match += start; + } + + str_first_done: + Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -1366,27 +1284,80 @@ ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - size_t last = TCL_INDEX_END; + Tcl_UniChar *needleStr, *haystackStr, *p; + int match, start, needleLen, haystackLen; if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, - "needleString haystackString ?lastIndex?"); + "needleString haystackString ?startIndex?"); return TCL_ERROR; } + /* + * We are searching haystackString for the sequence needleString. + */ + + match = -1; + start = 0; + haystackLen = -1; + + needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen); + haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen); + if (objc == 4) { - size_t end = Tcl_GetCharLength(objv[2]) - 1; + /* + * If a startIndex is specified, we will need to restrict the string + * range to that char index in the string + */ - if (TCL_OK != TclGetIntForIndexM(interp, objv[3], end, &last)) { + if (TclGetIntForIndexM(interp, objv[3], haystackLen-1, + &start) != TCL_OK){ return TCL_ERROR; } + + /* + * Reread to prevent shimmering problems. + */ + + needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen); + haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen); + + if (start < 0) { + goto str_last_done; + } else if (start < haystackLen) { + p = haystackStr + start + 1 - needleLen; + } else { + p = haystackStr + haystackLen - needleLen; + } + } else { + p = haystackStr + haystackLen - needleLen; } - Tcl_SetObjResult(interp, TclNewWideIntObjFromSize(TclStringLast(objv[1], - objv[2], last))); + + /* + * If the length of the needle is more than the length of the haystack, it + * cannot be contained in there so we can avoid searching. [Bug 2960021] + */ + + if (needleLen > 0 && needleLen <= haystackLen) { + for (; p >= haystackStr; p--) { + /* + * Scan backwards to find the first character. + */ + + if ((*p == *needleStr) && !memcmp(needleStr, p, + sizeof(Tcl_UniChar) * (size_t)needleLen)) { + match = p - haystackStr; + break; + } + } + } + + str_last_done: + Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -1411,110 +1382,46 @@ ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - size_t index, end; + int length, index; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "string charIndex"); return TCL_ERROR; } /* - * Get the char length to calculate what 'end' means. + * Get the char length to calulate what 'end' means. */ - end = Tcl_GetCharLength(objv[1]) - 1; - if (TclGetIntForIndexM(interp, objv[2], end, &index) != TCL_OK) { + length = Tcl_GetCharLength(objv[1]); + if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK) { return TCL_ERROR; } - if ((index != TCL_INDEX_NONE) && (index + 1 <= end + 1)) { - int ch = Tcl_GetUniChar(objv[1], index); - - if (ch == -1) { - return TCL_OK; - } + if ((index >= 0) && (index < length)) { + int ch = TclGetUCS4(objv[1], index); /* * If we have a ByteArray object, we're careful to generate a new * bytearray for a result. */ if (TclIsPureByteArray(objv[1])) { - unsigned char uch = (unsigned char) ch; + unsigned char uch = UCHAR(ch); Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(&uch, 1)); } else { - char buf[4] = ""; - - end = Tcl_UniCharToUtf(ch, buf); - if ((ch >= 0xD800) && (end < 3)) { - end += Tcl_UniCharToUtf(-1, buf + end); - } - Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, end)); - } - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * StringInsertCmd -- - * - * This procedure is invoked to process the "string insert" Tcl command. - * See the user documentation for details on what it does. Note that this - * command only functions correctly on properly formed Tcl UTF strings. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -static int -StringInsertCmd( - ClientData dummy, /* Not used */ - Tcl_Interp *interp, /* Current interpreter */ - int objc, /* Number of arguments */ - Tcl_Obj *const objv[]) /* Argument objects */ -{ - size_t length; /* String length */ - size_t index; /* Insert index */ - Tcl_Obj *outObj; /* Output object */ - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 1, objv, "string index insertString"); - return TCL_ERROR; - } - - length = Tcl_GetCharLength(objv[1]); - if (TclGetIntForIndexM(interp, objv[2], length, &index) != TCL_OK) { - return TCL_ERROR; - } - - if (index == TCL_INDEX_NONE) { - index = TCL_INDEX_START; - } - if (index > length) { - index = length; - } - - outObj = TclStringReplace(interp, objv[1], index, 0, objv[3], - TCL_STRING_IN_PLACE); - - if (outObj != NULL) { - Tcl_SetObjResult(interp, outObj); - return TCL_OK; - } - - return TCL_ERROR; + char buf[8] = ""; + + length = TclUCS4ToUtf(ch, buf); + Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, length)); + } + } + return TCL_OK; } /* *---------------------------------------------------------------------- * @@ -1539,33 +1446,30 @@ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *string1, *end, *stop; - Tcl_UniChar ch = 0; int (*chcomp)(int) = NULL; /* The UniChar comparison function. */ - int i, result = 1, strict = 0, index, length3; - size_t failat = 0; - size_t length1, length2; + int i, failat = 0, result = 1, strict = 0, index, length1, length2; Tcl_Obj *objPtr, *failVarObj = NULL; Tcl_WideInt w; static const char *const isClasses[] = { "alnum", "alpha", "ascii", "control", - "boolean", "dict", "digit", "double", - "entier", "false", "graph", "integer", - "list", "lower", "print", "punct", - "space", "true", "upper", "wideinteger", - "wordchar", "xdigit", NULL + "boolean", "digit", "double", "entier", + "false", "graph", "integer", "list", + "lower", "print", "punct", "space", + "true", "upper", "wideinteger", "wordchar", + "xdigit", NULL }; enum isClasses { STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, - STR_IS_BOOL, STR_IS_DICT, STR_IS_DIGIT, STR_IS_DOUBLE, - STR_IS_ENTIER, STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, - STR_IS_LIST, STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, - STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE, - STR_IS_WORD, STR_IS_XDIGIT + STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER, + STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, STR_IS_LIST, + STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE, + STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD, + STR_IS_XDIGIT }; static const char *const isOptions[] = { "-strict", "-failindex", NULL }; enum isOptions { @@ -1630,82 +1534,38 @@ chcomp = UniCharIsAscii; break; case STR_IS_BOOL: case STR_IS_TRUE: case STR_IS_FALSE: - if (!TclHasIntRep(objPtr, &tclBooleanType) + if ((objPtr->typePtr != &tclBooleanType) && (TCL_OK != TclSetBooleanFromAny(NULL, objPtr))) { if (strict) { result = 0; } else { string1 = TclGetStringFromObj(objPtr, &length1); result = length1 == 0; } - } else if ((objPtr->internalRep.wideValue != 0) - ? (index == STR_IS_FALSE) : (index == STR_IS_TRUE)) { + } else if (((index == STR_IS_TRUE) && + objPtr->internalRep.longValue == 0) + || ((index == STR_IS_FALSE) && + objPtr->internalRep.longValue != 0)) { result = 0; } break; case STR_IS_CONTROL: chcomp = Tcl_UniCharIsControl; break; - case STR_IS_DICT: { - int dresult, dsize; - - dresult = Tcl_DictObjSize(interp, objPtr, &dsize); - Tcl_ResetResult(interp); - result = (dresult == TCL_OK) ? 1 : 0; - if (dresult != TCL_OK && failVarObj != NULL) { - /* - * Need to figure out where the list parsing failed, which is - * fairly expensive. This is adapted from the core of - * SetDictFromAny(). - */ - - const char *elemStart, *nextElem; - int lenRemain; - size_t elemSize; - register const char *p; - - string1 = TclGetStringFromObj(objPtr, &length1); - end = string1 + length1; - failat = -1; - for (p=string1, lenRemain=length1; lenRemain > 0; - p=nextElem, lenRemain=end-nextElem) { - if (TCL_ERROR == TclFindElement(NULL, p, lenRemain, - &elemStart, &nextElem, &elemSize, NULL)) { - Tcl_Obj *tmpStr; - - /* - * This is the simplest way of getting the number of - * characters parsed. Note that this is not the same as - * the number of bytes when parsing strings with non-ASCII - * characters in them. - * - * Skip leading spaces first. This is only really an issue - * if it is the first "element" that has the failure. - */ - - while (TclIsSpaceProc(*p)) { - p++; - } - TclNewStringObj(tmpStr, string1, p-string1); - failat = Tcl_GetCharLength(tmpStr); - TclDecrRefCount(tmpStr); - break; - } - } - } - break; - } case STR_IS_DIGIT: chcomp = Tcl_UniCharIsDigit; break; case STR_IS_DOUBLE: { - if (TclHasIntRep(objPtr, &tclDoubleType) || - TclHasIntRep(objPtr, &tclIntType) || - TclHasIntRep(objPtr, &tclBignumType)) { + if ((objPtr->typePtr == &tclDoubleType) || + (objPtr->typePtr == &tclIntType) || +#ifndef TCL_WIDE_INT_IS_LONG + (objPtr->typePtr == &tclWideIntType) || +#endif + (objPtr->typePtr == &tclBignumType)) { break; } string1 = TclGetStringFromObj(objPtr, &length1); if (length1 == 0) { if (strict) { @@ -1729,13 +1589,20 @@ } case STR_IS_GRAPH: chcomp = Tcl_UniCharIsGraph; break; case STR_IS_INT: + if (TCL_OK == TclGetIntFromObj(NULL, objPtr, &i)) { + break; + } + goto failedIntParse; case STR_IS_ENTIER: - if (TclHasIntRep(objPtr, &tclIntType) || - TclHasIntRep(objPtr, &tclBignumType)) { + if ((objPtr->typePtr == &tclIntType) || +#ifndef TCL_WIDE_INT_IS_LONG + (objPtr->typePtr == &tclWideIntType) || +#endif + (objPtr->typePtr == &tclBignumType)) { break; } string1 = TclGetStringFromObj(objPtr, &length1); if (length1 == 0) { if (strict) { @@ -1776,10 +1643,11 @@ case STR_IS_WIDE: if (TCL_OK == TclGetWideIntFromObj(NULL, objPtr, &w)) { break; } + failedIntParse: string1 = TclGetStringFromObj(objPtr, &length1); if (length1 == 0) { if (strict) { result = 0; } @@ -1829,11 +1697,11 @@ /* * We ignore the strictness here, since empty strings are always * well-formed lists. */ - if (TCL_OK == TclListObjLength(NULL, objPtr, &length3)) { + if (TCL_OK == TclListObjLength(NULL, objPtr, &length2)) { break; } if (failVarObj != NULL) { /* @@ -1841,13 +1709,12 @@ * fairly expensive. This is adapted from the core of * SetListFromAny(). */ const char *elemStart, *nextElem; - size_t lenRemain; - size_t elemSize; - register const char *p; + int lenRemain, elemSize; + const char *p; string1 = TclGetStringFromObj(objPtr, &length1); end = string1 + length1; failat = -1; for (p=string1, lenRemain=length1; lenRemain > 0; @@ -1864,11 +1731,11 @@ * * Skip leading spaces first. This is only really an issue * if it is the first "element" that has the failure. */ - while (TclIsSpaceProc(*p)) { + while (TclIsSpaceProcM(*p)) { p++; } TclNewStringObj(tmpStr, string1, p-string1); failat = Tcl_GetCharLength(tmpStr); TclDecrRefCount(tmpStr); @@ -1909,20 +1776,14 @@ } goto str_is_done; } end = string1 + length1; for (; string1 < end; string1 += length2, failat++) { - int fullchar; - length2 = TclUtfToUniChar(string1, &ch); - fullchar = ch; -#if TCL_UTF_MAX <= 4 - if ((ch >= 0xD800) && (length2 < 3)) { - length2 += TclUtfToUniChar(string1 + length2, &ch); - fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; - } -#endif - if (!chcomp(fullchar)) { + int ucs4; + + length2 = TclUtfToUCS4(string1, &ucs4); + if (!chcomp(ucs4)) { result = 0; break; } } } @@ -1932,11 +1793,11 @@ * valid fail index (>= 0). */ str_is_done: if ((result == 0) && (failVarObj != NULL) && - Tcl_ObjSetVar2(interp, failVarObj, NULL, TclNewWideIntObjFromSize(failat), + Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(failat), TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); return TCL_OK; @@ -1951,11 +1812,11 @@ static int UniCharIsHexDigit( int character) { - return (character >= 0) && (character < 0x80) && isxdigit(UCHAR(character)); + return (character >= 0) && (character < 0x80) && isxdigit(character); } /* *---------------------------------------------------------------------- * @@ -1979,15 +1840,15 @@ ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - size_t length1, length2, mapElemc, index; + int length1, length2, mapElemc, index; int nocase = 0, mapWithDict = 0, copySource = 0; Tcl_Obj **mapElemv, *sourceObj, *resultPtr; Tcl_UniChar *ustring1, *ustring2, *p, *end; - int (*strCmpFn)(const Tcl_UniChar*, const Tcl_UniChar*, size_t); + int (*strCmpFn)(const Tcl_UniChar*, const Tcl_UniChar*, unsigned long); if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? charMap string"); return TCL_ERROR; } @@ -2007,34 +1868,33 @@ } } /* * This test is tricky, but has to be that way or you get other strange - * inconsistencies (see test string-10.20.1 for illustration why!) + * inconsistencies (see test string-10.20 for illustration why!) */ - if (!TclHasStringRep(objv[objc-2]) - && TclHasIntRep(objv[objc-2], &tclDictType)) { + if (objv[objc-2]->typePtr == &tclDictType && objv[objc-2]->bytes == NULL){ int i, done; Tcl_DictSearch search; /* * We know the type exactly, so all dict operations will succeed for * sure. This shortens this code quite a bit. */ - Tcl_DictObjSize(interp, objv[objc-2], &i); - if (i == 0) { + Tcl_DictObjSize(interp, objv[objc-2], &mapElemc); + if (mapElemc == 0) { /* * Empty charMap, just return whatever string was given. */ Tcl_SetObjResult(interp, objv[objc-1]); return TCL_OK; } - mapElemc = 2 * i; + mapElemc *= 2; mapWithDict = 1; /* * Copy the dictionary out into an array; that's the easiest way to * adapt this code... @@ -2041,21 +1901,19 @@ */ mapElemv = TclStackAlloc(interp, sizeof(Tcl_Obj *) * mapElemc); Tcl_DictObjFirst(interp, objv[objc-2], &search, mapElemv+0, mapElemv+1, &done); - for (index=2 ; index30% faster on * larger strings. */ - size_t mapLen; - int u2lc; - Tcl_UniChar *mapString; + int mapLen; + Tcl_UniChar *mapString, u2lc; - ustring2 = TclGetUnicodeFromObj(mapElemv[0], &length2); + ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2); p = ustring1; if ((length2 > length1) || (length2 == 0)) { /* * Match string is either longer than input or empty. */ ustring1 = end; } else { - mapString = TclGetUnicodeFromObj(mapElemv[1], &mapLen); + mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen); u2lc = (nocase ? Tcl_UniCharToLower(*ustring2) : 0); for (; ustring1 < end; ustring1++) { if (((*ustring1 == *ustring2) || (nocase&&Tcl_UniCharToLower(*ustring1)==u2lc)) && (length2==1 || strCmpFn(ustring1, ustring2, - length2) == 0)) { + (unsigned long) length2) == 0)) { if (p != ustring1) { Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p); p = ustring1 + length2; } else { p += length2; @@ -2142,28 +1999,27 @@ Tcl_AppendUnicodeToObj(resultPtr, mapString, mapLen); } } } } else { - Tcl_UniChar **mapStrings; - size_t *mapLens; - int *u2lc = 0; + Tcl_UniChar **mapStrings, *u2lc = NULL; + int *mapLens; /* * Precompute pointers to the unicode string and length. This saves us * repeated function calls later, significantly speeding up the * algorithm. We only need the lowercase first char in the nocase * case. */ - mapStrings = TclStackAlloc(interp, mapElemc*sizeof(Tcl_UniChar *)*2); - mapLens = TclStackAlloc(interp, mapElemc * sizeof(size_t) * 2); + mapStrings = TclStackAlloc(interp, mapElemc*2*sizeof(Tcl_UniChar *)); + mapLens = TclStackAlloc(interp, mapElemc * 2 * sizeof(int)); if (nocase) { - u2lc = TclStackAlloc(interp, mapElemc * sizeof(int)); + u2lc = TclStackAlloc(interp, mapElemc * sizeof(Tcl_UniChar)); } for (index = 0; index < mapElemc; index++) { - mapStrings[index] = TclGetUnicodeFromObj(mapElemv[index], + mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index], mapLens+index); if (nocase && ((index % 2) == 0)) { u2lc[index/2] = Tcl_UniCharToLower(*mapStrings[index]); } } @@ -2176,11 +2032,11 @@ ustring2 = mapStrings[index]; length2 = mapLens[index]; if ((length2 > 0) && ((*ustring1 == *ustring2) || (nocase && (Tcl_UniCharToLower(*ustring1) == u2lc[index/2]))) && /* Restrict max compare length. */ - ((size_t)(end-ustring1) >= length2) && ((length2 == 1) || + (end-ustring1 >= length2) && ((length2 == 1) || !strCmpFn(ustring2, ustring1, length2))) { if (p != ustring1) { /* * Put the skipped chars onto the result first. */ @@ -2262,11 +2118,11 @@ Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? pattern string"); return TCL_ERROR; } if (objc == 4) { - size_t length; + int length; const char *string = TclGetStringFromObj(objv[1], &length); if ((length > 1) && strncmp(string, "-nocase", length) == 0) { nocase = TCL_MATCH_NOCASE; @@ -2306,11 +2162,11 @@ ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - size_t first, last, end; + int length, first, last; if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "string first last"); return TCL_ERROR; } @@ -2318,24 +2174,24 @@ /* * Get the length in actual characters; Then reduce it by one because * 'end' refers to the last character, not one past it. */ - end = Tcl_GetCharLength(objv[1]) - 1; + length = Tcl_GetCharLength(objv[1]) - 1; - if (TclGetIntForIndexM(interp, objv[2], end, &first) != TCL_OK || - TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK) { + if (TclGetIntForIndexM(interp, objv[2], length, &first) != TCL_OK || + TclGetIntForIndexM(interp, objv[3], length, &last) != TCL_OK) { return TCL_ERROR; } - if (first == TCL_INDEX_NONE) { - first = TCL_INDEX_START; + if (first < 0) { + first = 0; } - if (last + 1 >= end + 1) { - last = end; + if (last >= length) { + last = length; } - if (last + 1 >= first + 1) { + if (last >= first) { Tcl_SetObjResult(interp, Tcl_GetRange(objv[1], first, last)); } return TCL_OK; } @@ -2362,11 +2218,13 @@ ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int count; + const char *string1; + char *string2; + int count, index, length1, length2; Tcl_Obj *resultPtr; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "string count"); return TCL_ERROR; @@ -2380,21 +2238,75 @@ * Check for cases that allow us to skip copying stuff. */ if (count == 1) { Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; + goto done; } else if (count < 1) { - return TCL_OK; + goto done; + } + string1 = TclGetStringFromObj(objv[1], &length1); + if (length1 <= 0) { + goto done; } - resultPtr = TclStringRepeat(interp, objv[1], count, TCL_STRING_IN_PLACE); - if (resultPtr) { - Tcl_SetObjResult(interp, resultPtr); - return TCL_OK; + /* + * Only build up a string that has data. Instead of building it up with + * repeated appends, we just allocate the necessary space once and copy + * the string value in. + * + * We have to worry about overflow [Bugs 714106, 2561746]. + * At this point we know 1 <= length1 <= INT_MAX and 2 <= count <= INT_MAX. + * We need to keep 2 <= length2 <= INT_MAX. + */ + + if (count > INT_MAX/length1) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "result exceeds max size for a Tcl value (%d bytes)", + INT_MAX)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + return TCL_ERROR; } - return TCL_ERROR; + length2 = length1 * count; + + /* + * Include space for the NUL. + */ + + string2 = attemptckalloc(length2 + 1); + if (string2 == NULL) { + /* + * Alloc failed. Note that in this case we try to do an error message + * since this is a case that's most likely when the alloc is large and + * that's easy to do with this API. Note that if we fail allocating a + * short string, this will likely keel over too (and fatally). + */ + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "string size overflow, out of memory allocating %u bytes", + length2 + 1)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + return TCL_ERROR; + } + for (index = 0; index < count; index++) { + memcpy(string2 + (length1 * index), string1, length1); + } + string2[length2] = '\0'; + + /* + * We have to directly assign this instead of using Tcl_SetStringObj (and + * indirectly TclInitStringRep) because that makes another copy of the + * data. + */ + + TclNewObj(resultPtr); + resultPtr->bytes = string2; + resultPtr->length = length2; + Tcl_SetObjResult(interp, resultPtr); + + done: + return TCL_OK; } /* *---------------------------------------------------------------------- * @@ -2418,54 +2330,64 @@ ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - size_t first, last, end; + Tcl_UniChar *ustring; + int first, last, length, end; if (objc < 4 || objc > 5) { Tcl_WrongNumArgs(interp, 1, objv, "string first last ?string?"); return TCL_ERROR; } - end = Tcl_GetCharLength(objv[1]) - 1; + ustring = Tcl_GetUnicodeFromObj(objv[1], &length); + end = length - 1; if (TclGetIntForIndexM(interp, objv[2], end, &first) != TCL_OK || - TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK) { + TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK){ return TCL_ERROR; } /* - * The following test screens out most empty substrings as candidates for - * replacement. When they are detected, no replacement is done, and the - * result is the original string. + * The following test screens out most empty substrings as + * candidates for replacement. When they are detected, no + * replacement is done, and the result is the original string, */ + if ((last < 0) || /* Range ends before start of string */ + (first > end) || /* Range begins after end of string */ + (last < first)) { /* Range begins after it starts */ - if ((last == TCL_INDEX_NONE) || /* Range ends before start of string */ - (first + 1 > end + 1) || /* Range begins after end of string */ - (last + 1 < first + 1)) { /* Range begins after it starts */ /* * BUT!!! when (end < 0) -- an empty original string -- we can * have (first <= end < 0 <= last) and an empty string is permitted * to be replaced. */ - Tcl_SetObjResult(interp, objv[1]); } else { Tcl_Obj *resultPtr; - if (first == TCL_INDEX_NONE) { - first = TCL_INDEX_START; - } - if (last + 1 > end + 1) { - last = end; + /* + * We are re-fetching in case the string argument is same value as + * an index argument, and shimmering cost us our ustring. + */ + + ustring = Tcl_GetUnicodeFromObj(objv[1], &length); + end = length-1; + + if (first < 0) { + first = 0; } - resultPtr = TclStringReplace(interp, objv[1], first, - last + 1 - first, (objc == 5) ? objv[4] : NULL, - TCL_STRING_IN_PLACE); - + resultPtr = Tcl_NewUnicodeObj(ustring, first); + if (objc == 5) { + Tcl_AppendObjToObj(resultPtr, objv[4]); + } + if (last < end) { + Tcl_AppendUnicodeToObj(resultPtr, ustring + last + 1, + end - last); + } Tcl_SetObjResult(interp, resultPtr); } return TCL_OK; } @@ -2497,11 +2419,11 @@ if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "string"); return TCL_ERROR; } - Tcl_SetObjResult(interp, TclStringReverse(objv[1], TCL_STRING_IN_PLACE)); + Tcl_SetObjResult(interp, TclStringReverse(objv[1])); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -2529,41 +2451,51 @@ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_UniChar ch = 0; const char *p, *string; - size_t numChars, length, cur, index; + int cur, index, length, numChars; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "string index"); return TCL_ERROR; } string = TclGetStringFromObj(objv[1], &length); - numChars = Tcl_NumUtfChars(string, length) - 1; - if (TclGetIntForIndexM(interp, objv[2], numChars, &index) != TCL_OK) { + numChars = Tcl_NumUtfChars(string, length); + if (TclGetIntForIndexM(interp, objv[2], numChars-1, &index) != TCL_OK) { return TCL_ERROR; } - string = TclGetString(objv[1]); - if (index + 1 > numChars + 1) { - index = numChars; + string = TclGetStringFromObj(objv[1], &length); + if (index >= numChars) { + index = numChars - 1; } cur = 0; - if (index + 1 > 1) { + if (index > 0) { p = Tcl_UtfAtIndex(string, index); - for (cur = index; cur != TCL_INDEX_NONE; cur--) { - TclUtfToUniChar(p, &ch); + + TclUtfToUniChar(p, &ch); + for (cur = index; cur >= 0; cur--) { + int delta = 0; + const char *next; + if (!Tcl_UniCharIsWordChar(ch)) { break; } - p = Tcl_UtfPrev(p, string); + + next = TclUtfPrev(p, string); + do { + next += delta; + delta = TclUtfToUniChar(next, &ch); + } while (next + delta < p); + p = next; } if (cur != index) { cur += 1; } } - Tcl_SetObjResult(interp, TclNewWideIntObjFromSize(cur)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(cur)); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -2590,27 +2522,27 @@ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_UniChar ch = 0; const char *p, *end, *string; - size_t length, numChars, cur, index; + int cur, index, length, numChars; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "string index"); return TCL_ERROR; } string = TclGetStringFromObj(objv[1], &length); - numChars = Tcl_NumUtfChars(string, length) - 1; - if (TclGetIntForIndexM(interp, objv[2], numChars, &index) != TCL_OK) { + numChars = Tcl_NumUtfChars(string, length); + if (TclGetIntForIndexM(interp, objv[2], numChars-1, &index) != TCL_OK) { return TCL_ERROR; } string = TclGetStringFromObj(objv[1], &length); - if (index == TCL_INDEX_NONE) { - index = TCL_INDEX_START; + if (index < 0) { + index = 0; } - if (index + 1 <= numChars + 1) { + if (index < numChars) { p = Tcl_UtfAtIndex(string, index); end = string+length; for (cur = index; p < end; cur++) { p += TclUtfToUniChar(p, &ch); if (!Tcl_UniCharIsWordChar(ch)) { @@ -2619,13 +2551,13 @@ } if (cur == index) { cur++; } } else { - cur = numChars + 1; + cur = numChars; } - Tcl_SetObjResult(interp, TclNewWideIntObjFromSize(cur)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(cur)); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -2657,26 +2589,25 @@ * in tclExecute.c (INST_STR_EQ, INST_STR_NEQ and INST_STR_CMP as well as * the expr string comparison in INST_EQ/INST_NEQ/INST_LT/...). */ const char *string2; - int i, match, nocase = 0, reqlength = -1; - size_t length; + int length2, i, match, nocase = 0, reqlength = -1; if (objc < 3 || objc > 6) { str_cmp_args: Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? ?-length int? string1 string2"); return TCL_ERROR; } for (i = 1; i < objc-2; i++) { - string2 = TclGetStringFromObj(objv[i], &length); - if ((length > 1) && !strncmp(string2, "-nocase", length)) { + string2 = TclGetStringFromObj(objv[i], &length2); + if ((length2 > 1) && !strncmp(string2, "-nocase", length2)) { nocase = 1; - } else if ((length > 1) - && !strncmp(string2, "-length", length)) { + } else if ((length2 > 1) + && !strncmp(string2, "-length", length2)) { if (i+1 >= objc-2) { goto str_cmp_args; } i++; if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) { @@ -2741,24 +2672,202 @@ return status; } objv += objc-2; match = TclStringCmp(objv[0], objv[1], 0, nocase, reqlength); - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(match)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); return TCL_OK; } +/* + *---------------------------------------------------------------------- + * + * TclStringCmp -- + * + * This is the core of Tcl's string comparison. It only handles byte + * arrays, UNICODE strings and UTF-8 strings correctly. + * + * Results: + * -1 if value1Ptr is less than value2Ptr, 0 if they are equal, or 1 if + * value1Ptr is greater. + * + * Side effects: + * May cause string representations of objects to be allocated. + * + *---------------------------------------------------------------------- + */ + int -TclStringCmpOpts( +TclStringCmp( + Tcl_Obj *value1Ptr, + Tcl_Obj *value2Ptr, + int checkEq, /* comparison is only for equality */ + int nocase, /* comparison is not case sensitive */ + int reqlength) /* requested length; -1 to compare whole + * strings */ +{ + const char *s1, *s2; + int empty, length, match, s1len, s2len; + memCmpFn_t memCmpFn; + + if ((reqlength == 0) || (value1Ptr == value2Ptr)) { + /* + * Always match at 0 chars or if it is the same obj. + */ + return 0; + } + + if (!nocase && TclIsPureByteArray(value1Ptr) + && TclIsPureByteArray(value2Ptr)) { + /* + * Use binary versions of comparisons since that won't cause undue + * type conversions and it is much faster. Only do this if we're + * case-sensitive (which is all that really makes sense with byte + * arrays anyway, and we have no memcasecmp() for some reason... :^) + */ + + s1 = (char *) Tcl_GetByteArrayFromObj(value1Ptr, &s1len); + s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len); + memCmpFn = memcmp; + } else if ((value1Ptr->typePtr == &tclStringType) + && (value2Ptr->typePtr == &tclStringType)) { + /* + * Do a unicode-specific comparison if both of the args are of String + * type. If the char length == byte length, we can do a memcmp. In + * benchmark testing this proved the most efficient check between the + * unicode and string comparison operations. + */ + + if (nocase) { + s1 = (char *) Tcl_GetUnicodeFromObj(value1Ptr, &s1len); + s2 = (char *) Tcl_GetUnicodeFromObj(value2Ptr, &s2len); + memCmpFn = (memCmpFn_t)Tcl_UniCharNcasecmp; + } else { + s1len = Tcl_GetCharLength(value1Ptr); + s2len = Tcl_GetCharLength(value2Ptr); + if ((s1len == value1Ptr->length) + && (value1Ptr->bytes != NULL) + && (s2len == value2Ptr->length) + && (value2Ptr->bytes != NULL)) { + s1 = value1Ptr->bytes; + s2 = value2Ptr->bytes; + memCmpFn = memcmp; + } else { + s1 = (char *) Tcl_GetUnicode(value1Ptr); + s2 = (char *) Tcl_GetUnicode(value2Ptr); + if ( +#ifdef WORDS_BIGENDIAN + 1 +#else + checkEq +#endif /* WORDS_BIGENDIAN */ + ) { + memCmpFn = memcmp; + s1len *= sizeof(Tcl_UniChar); + s2len *= sizeof(Tcl_UniChar); + } else { + memCmpFn = (memCmpFn_t) Tcl_UniCharNcmp; + } + } + } + } else { + /* + * Get the string representations, being careful in case we have + * special empty string objects about. + */ + + empty = TclCheckEmptyString(value1Ptr); + if (empty > 0) { + switch (TclCheckEmptyString(value2Ptr)) { + case -1: + s1 = ""; + s1len = 0; + s2 = TclGetStringFromObj(value2Ptr, &s2len); + break; + case 0: + return -1; + default: /* avoid warn: `s2` may be used uninitialized */ + return 0; + } + } else if (TclCheckEmptyString(value2Ptr) > 0) { + switch (empty) { + case -1: + s2 = ""; + s2len = 0; + s1 = TclGetStringFromObj(value1Ptr, &s1len); + break; + case 0: + return 1; + default: /* avoid warn: `s1` may be used uninitialized */ + return 0; + } + } else { + s1 = TclGetStringFromObj(value1Ptr, &s1len); + s2 = TclGetStringFromObj(value2Ptr, &s2len); + } + + if (!nocase && checkEq) { + /* + * When we have equal-length we can check only for (in)equality. + * We can use memcmp() in all (n)eq cases because we don't need to + * worry about lexical LE/BE variance. + */ + memCmpFn = memcmp; + } else { + /* + * As a catch-all we will work with UTF-8. We cannot use memcmp() + * as that is unsafe with any string containing NUL (\xC0\x80 in + * Tcl's utf rep). We can use the more efficient TclpUtfNcmp2 if + * we are case-sensitive and no specific length was requested. + */ + + if ((reqlength < 0) && !nocase) { + memCmpFn = (memCmpFn_t) TclpUtfNcmp2; + } else { + s1len = Tcl_NumUtfChars(s1, s1len); + s2len = Tcl_NumUtfChars(s2, s2len); + memCmpFn = (memCmpFn_t) + (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp); + } + } + } + + length = (s1len < s2len) ? s1len : s2len; + if (reqlength > 0 && reqlength < length) { + length = reqlength; + } else if (reqlength < 0) { + /* + * The requested length is negative, so we ignore it by setting it to + * length + 1 so we correct the match var. + */ + + reqlength = length + 1; + } + + if (checkEq && (s1len != s2len)) { + match = 1; /* This will be reversed below. */ + } else { + /* + * The comparison function should compare up to the minimum byte + * length only. + */ + match = memCmpFn(s1, s2, length); + } + if ((match == 0) && (reqlength > length)) { + match = s1len - s2len; + } + return (match > 0) ? 1 : (match < 0) ? -1 : 0; +} + +int TclStringCmpOpts( Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[], /* Argument objects. */ int *nocase, int *reqlength) { - int i; - size_t length; + int i, length; const char *string; *reqlength = -1; *nocase = 0; if (objc < 3 || objc > 6) { @@ -2815,28 +2924,37 @@ ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + int i; Tcl_Obj *objResultPtr; if (objc < 2) { /* * If there are no args, the result is an empty object. * Just leave the preset empty interp result. */ return TCL_OK; } - - objResultPtr = TclStringCat(interp, objc-1, objv+1, TCL_STRING_IN_PLACE); - - if (objResultPtr) { - Tcl_SetObjResult(interp, objResultPtr); + if (objc == 2) { + /* + * Other trivial case, single arg, just return it. + */ + Tcl_SetObjResult(interp, objv[1]); return TCL_OK; } + objResultPtr = objv[1]; + if (Tcl_IsShared(objResultPtr)) { + objResultPtr = Tcl_DuplicateObj(objResultPtr); + } + for(i = 2;i < objc;i++) { + Tcl_AppendObjToObj(objResultPtr, objv[i]); + } + Tcl_SetObjResult(interp, objResultPtr); - return TCL_ERROR; + return TCL_OK; } /* *---------------------------------------------------------------------- * @@ -2861,19 +2979,19 @@ ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - size_t length; + int length; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "string"); return TCL_ERROR; } (void) TclGetStringFromObj(objv[1], &length); - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(length)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(length)); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -2903,11 +3021,11 @@ if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "string"); return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_GetCharLength(objv[1]))); + Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_GetCharLength(objv[1]))); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -2932,11 +3050,11 @@ ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - size_t length1, length2; + int length1, length2; const char *string1; char *string2; if (objc < 2 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?"); @@ -2950,32 +3068,32 @@ length1 = Tcl_UtfToLower(TclGetString(resultPtr)); Tcl_SetObjLength(resultPtr, length1); Tcl_SetObjResult(interp, resultPtr); } else { - size_t first, last; + int first, last; const char *start, *end; Tcl_Obj *resultPtr; length1 = Tcl_NumUtfChars(string1, length1) - 1; if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) { return TCL_ERROR; } - if (first == TCL_INDEX_NONE) { + if (first < 0) { first = 0; } last = first; if ((objc == 4) && (TclGetIntForIndexM(interp, objv[3], length1, &last) != TCL_OK)) { return TCL_ERROR; } - if (last + 1 >= length1 + 1) { + if (last >= length1) { last = length1; } - if (last + 1 < first + 1) { + if (last < first) { Tcl_SetObjResult(interp, objv[1]); return TCL_OK; } string1 = TclGetStringFromObj(objv[1], &length1); @@ -3017,11 +3135,11 @@ ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - size_t length1, length2; + int length1, length2; const char *string1; char *string2; if (objc < 2 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?"); @@ -3035,32 +3153,32 @@ length1 = Tcl_UtfToUpper(TclGetString(resultPtr)); Tcl_SetObjLength(resultPtr, length1); Tcl_SetObjResult(interp, resultPtr); } else { - size_t first, last; + int first, last; const char *start, *end; Tcl_Obj *resultPtr; length1 = Tcl_NumUtfChars(string1, length1) - 1; if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) { return TCL_ERROR; } - if (first == TCL_INDEX_NONE) { - first = TCL_INDEX_START; + if (first < 0) { + first = 0; } last = first; if ((objc == 4) && (TclGetIntForIndexM(interp, objv[3], length1, &last) != TCL_OK)) { return TCL_ERROR; } - if (last + 1 >= length1 + 1) { + if (last >= length1) { last = length1; } - if (last + 1 < first + 1) { + if (last < first) { Tcl_SetObjResult(interp, objv[1]); return TCL_OK; } string1 = TclGetStringFromObj(objv[1], &length1); @@ -3102,11 +3220,11 @@ ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - size_t length1, length2; + int length1, length2; const char *string1; char *string2; if (objc < 2 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?"); @@ -3120,32 +3238,32 @@ length1 = Tcl_UtfToTitle(TclGetString(resultPtr)); Tcl_SetObjLength(resultPtr, length1); Tcl_SetObjResult(interp, resultPtr); } else { - size_t first, last; + int first, last; const char *start, *end; Tcl_Obj *resultPtr; length1 = Tcl_NumUtfChars(string1, length1) - 1; if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) { return TCL_ERROR; } - if (first == TCL_INDEX_NONE) { - first = TCL_INDEX_START; + if (first < 0) { + first = 0; } last = first; if ((objc == 4) && (TclGetIntForIndexM(interp, objv[3], length1, &last) != TCL_OK)) { return TCL_ERROR; } - if (last + 1 >= length1 + 1) { + if (last >= length1) { last = length1; } - if (last + 1 < first + 1) { + if (last < first) { Tcl_SetObjResult(interp, objv[1]); return TCL_OK; } string1 = TclGetStringFromObj(objv[1], &length1); @@ -3188,11 +3306,11 @@ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *string1, *string2; - size_t triml, trimr, length1, length2; + int triml, trimr, length1, length2; if (objc == 3) { string2 = TclGetStringFromObj(objv[2], &length2); } else if (objc == 2) { string2 = tclDefaultTrimSet; @@ -3235,12 +3353,11 @@ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *string1, *string2; - int trim; - size_t length1, length2; + int trim, length1, length2; if (objc == 3) { string2 = TclGetStringFromObj(objv[2], &length2); } else if (objc == 2) { string2 = tclDefaultTrimSet; @@ -3282,12 +3399,11 @@ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *string1, *string2; - int trim; - size_t length1, length2; + int trim, length1, length2; if (objc == 3) { string2 = TclGetStringFromObj(objv[2], &length2); } else if (objc == 2) { string2 = tclDefaultTrimSet; @@ -3336,11 +3452,10 @@ {"cat", StringCatCmd, TclCompileStringCatCmd, NULL, NULL, 0}, {"compare", StringCmpCmd, TclCompileStringCmpCmd, NULL, NULL, 0}, {"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0}, {"first", StringFirstCmd, TclCompileStringFirstCmd, NULL, NULL, 0}, {"index", StringIndexCmd, TclCompileStringIndexCmd, NULL, NULL, 0}, - {"insert", StringInsertCmd, TclCompileStringInsertCmd, NULL, NULL, 0}, {"is", StringIsCmd, TclCompileStringIsCmd, NULL, NULL, 0}, {"last", StringLastCmd, TclCompileStringLastCmd, NULL, NULL, 0}, {"length", StringLenCmd, TclCompileStringLenCmd, NULL, NULL, 0}, {"map", StringMapCmd, TclCompileStringMapCmd, NULL, NULL, 0}, {"match", StringMatchCmd, TclCompileStringMatchCmd, NULL, NULL, 0}, @@ -3482,13 +3597,12 @@ ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int i, index, mode, foundmode, splitObjs, numMatchesSaved; - int noCase; - size_t patternLength, j; + int i,j, index, mode, foundmode, splitObjs, numMatchesSaved; + int noCase, patternLength; const char *pattern; Tcl_Obj *stringObj, *indexVarObj, *matchVarObj; Tcl_Obj *const *savedObjv = objv; Tcl_RegExp regExpr = NULL; Interp *iPtr = (Interp *) interp; @@ -3510,11 +3624,11 @@ enum options { OPT_EXACT, OPT_GLOB, OPT_INDEXV, OPT_MATCHV, OPT_NOCASE, OPT_REGEXP, OPT_LAST }; typedef int (*strCmpFn_t)(const char *, const char *); - strCmpFn_t strCmpFn = TclUtfCmp; + strCmpFn_t strCmpFn = strcmp; mode = OPT_EXACT; foundmode = 0; indexVarObj = NULL; matchVarObj = NULL; @@ -3634,11 +3748,11 @@ splitObjs = 0; if (objc == 1) { Tcl_Obj **listv; blist = objv[0]; - if (TclListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) { + if (TclListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK){ return TCL_ERROR; } /* * Ensure that the list is non-empty. @@ -3795,15 +3909,16 @@ for (j=0 ; j<=info.nsubs ; j++) { if (indexVarObj != NULL) { Tcl_Obj *rangeObjAry[2]; - if (info.matches[j].end + 1 > 1) { - rangeObjAry[0] = TclNewWideIntObjFromSize(info.matches[j].start); - rangeObjAry[1] = TclNewWideIntObjFromSize(info.matches[j].end-1); + if (info.matches[j].end > 0) { + rangeObjAry[0] = Tcl_NewLongObj(info.matches[j].start); + rangeObjAry[1] = Tcl_NewLongObj(info.matches[j].end-1); } else { - rangeObjAry[0] = rangeObjAry[1] = Tcl_NewWideIntObj(-1); + TclNewIntObj(rangeObjAry[1], -1); + rangeObjAry[0] = rangeObjAry[1]; } /* * Never fails; the object is always clean at this point. */ @@ -3891,11 +4006,11 @@ } if (ctxPtr->type == TCL_LOCATION_SOURCE && ctxPtr->line[bidx] >= 0) { int bline = ctxPtr->line[bidx]; - ctxPtr->line = Tcl_Alloc(objc * sizeof(int)); + ctxPtr->line = ckalloc(objc * sizeof(int)); ctxPtr->nline = objc; TclListLines(blist, bline, objc, ctxPtr->line, objv); } else { /* * This is either a dynamic code word, when all elements are @@ -3905,20 +4020,20 @@ * which triggers reversion to the old behavior. */ int k; - ctxPtr->line = Tcl_Alloc(objc * sizeof(int)); + ctxPtr->line = ckalloc(objc * sizeof(int)); ctxPtr->nline = objc; for (k=0; k < objc; k++) { ctxPtr->line[k] = -1; } } } for (j = i + 1; ; j += 2) { - if (j >= (size_t)objc) { + if (j >= objc) { /* * This shouldn't happen since we've checked that the last body is * not a continuation... */ @@ -3948,18 +4063,18 @@ int splitObjs = PTR2INT(data[0]); CmdFrame *ctxPtr = data[1]; int pc = PTR2INT(data[2]); const char *pattern = data[3]; - size_t patternLength = strlen(pattern); + int patternLength = strlen(pattern); /* * Clean up TIP 280 context information */ if (splitObjs) { - Tcl_Free(ctxPtr->line); + ckfree(ctxPtr->line); if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) { /* * Death of SrcInfo reference. */ @@ -3970,16 +4085,16 @@ /* * Generate an error message if necessary. */ if (result == TCL_ERROR) { - unsigned limit = 50; + int limit = 50; int overflow = (patternLength > limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (\"%.*s%s\" arm line %d)", - (overflow ? limit : (unsigned)patternLength), pattern, + (overflow ? limit : patternLength), pattern, (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } TclStackFree(interp, ctxPtr); return result; } @@ -4069,13 +4184,13 @@ ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - register Tcl_Obj *objPtr; + Tcl_Obj *objPtr; Tcl_Obj *objs[4]; - register int i, result; + int i, result; int count; double totalMicroSec; #ifndef TCL_WIDE_CLICKS Tcl_Time start, stop; #else @@ -4170,26 +4285,26 @@ Tcl_Obj *const objv[]) /* Argument objects. */ { static double measureOverhead = 0; /* global measure-overhead */ double overhead = -1; /* given measure-overhead */ - register Tcl_Obj *objPtr; - register int result, i; + Tcl_Obj *objPtr; + int result, i; Tcl_Obj *calibrate = NULL, *direct = NULL; - Tcl_WideUInt count = 0; /* Holds repetition count */ + TclWideMUInt count = 0; /* Holds repetition count */ Tcl_WideInt maxms = WIDE_MIN; /* Maximal running time (in milliseconds) */ - Tcl_WideUInt maxcnt = WIDE_MAX; + TclWideMUInt maxcnt = WIDE_MAX; /* Maximal count of iterations. */ - Tcl_WideUInt threshold = 1; /* Current threshold for check time (faster + TclWideMUInt threshold = 1; /* Current threshold for check time (faster * repeat count without time check) */ - Tcl_WideUInt maxIterTm = 1; /* Max time of some iteration as max + TclWideMUInt maxIterTm = 1; /* Max time of some iteration as max * threshold, additionally avoiding divide to * zero (i.e., never < 1) */ unsigned short factor = 50; /* Factor (4..50) limiting threshold to avoid * growth of execution time. */ - register Tcl_WideInt start, middle, stop; + Tcl_WideInt start, middle, stop; #ifndef TCL_WIDE_CLICKS Tcl_Time now; #endif /* !TCL_WIDE_CLICKS */ static const char *const options[] = { "-direct", "-overhead", "-calibrate", "--", NULL @@ -4197,11 +4312,10 @@ enum options { TMRT_EV_DIRECT, TMRT_OVERHEAD, TMRT_CALIBRATE, TMRT_LAST }; NRE_callback *rootPtr; ByteCode *codePtr = NULL; - int codeOptimized = 0; for (i = 1; i < objc - 1; i++) { int index; if (Tcl_GetIndexFromObj(NULL, objv[i], options, "option", TCL_EXACT, @@ -4284,11 +4398,11 @@ /* * Self-call with 100 milliseconds to warm-up, before entering the * calibration cycle. */ - TclNewIntObj(clobjv[i], 100); + TclNewLongObj(clobjv[i], 100); Tcl_IncrRefCount(clobjv[i]); result = Tcl_TimeRateObjCmd(NULL, interp, i + 1, clobjv); Tcl_DecrRefCount(clobjv[i]); if (result != TCL_OK) { return result; @@ -4309,11 +4423,11 @@ */ maxms = -1000; do { lastMeasureOverhead = measureOverhead; - TclNewIntObj(clobjv[i], (int) maxms); + TclNewLongObj(clobjv[i], (int) maxms); Tcl_IncrRefCount(clobjv[i]); result = Tcl_TimeRateObjCmd(NULL, interp, i + 1, clobjv); Tcl_DecrRefCount(clobjv[i]); if (result != TCL_OK) { return result; @@ -4382,19 +4496,10 @@ if (TclInterpReady(interp) != TCL_OK) { return TCL_ERROR; } codePtr = TclCompileObj(interp, objPtr, NULL, 0); TclPreserveByteCode(codePtr); - /* - * Replace last compiled done instruction with continue: it's a part of - * iteration, this way evaluation will be more similar to a cycle (also - * avoids extra overhead to set result to interp, etc.) - */ - if (codePtr->codeStart[codePtr->numCodeBytes-1] == INST_DONE) { - codePtr->codeStart[codePtr->numCodeBytes-1] = INST_CONTINUE; - codeOptimized = 1; - } } /* * Get start and stop time. */ @@ -4432,10 +4537,16 @@ */ count++; if (!direct) { /* precompiled */ rootPtr = TOP_CB(interp); + /* + * Use loop optimized TEBC call (TCL_EVAL_DISCARD_RESULT): it's a part of + * iteration, this way evaluation will be more similar to a cycle (also + * avoids extra overhead to set result to interp, etc.) + */ + ((Interp *)interp)->evalFlags |= TCL_EVAL_DISCARD_RESULT; result = TclNRExecuteByteCode(interp, codePtr); result = TclNRRunCallbacks(interp, result, rootPtr); } else { /* eval */ result = TclEvalObjEx(interp, objPtr, 0, NULL, 0); } @@ -4451,10 +4562,11 @@ /* * Force stop immediately. */ threshold = 1; maxcnt = 0; + /* FALLTHRU */ case TCL_CONTINUE: result = TCL_OK; break; default: goto done; @@ -4555,17 +4667,17 @@ } } { Tcl_Obj *objarr[8], **objs = objarr; - Tcl_WideUInt usec, val; + TclWideMUInt usec, val; int digits; /* * Absolute execution time in microseconds or in wide clicks. */ - usec = (Tcl_WideUInt)(middle - start); + usec = (TclWideMUInt)(middle - start); #ifdef TCL_WIDE_CLICKS /* * convert execution time (in wide clicks) to microsecs. */ @@ -4590,11 +4702,11 @@ if (overhead > 0) { /* * Estimate the time of overhead (microsecs). */ - Tcl_WideUInt curOverhead = overhead * count; + TclWideMUInt curOverhead = overhead * count; if (usec > curOverhead) { usec -= curOverhead; } else { usec = 0; @@ -4684,15 +4796,10 @@ Tcl_SetObjResult(interp, Tcl_NewListObj(8, objarr)); } done: if (codePtr != NULL) { - if ( codeOptimized - && codePtr->codeStart[codePtr->numCodeBytes-1] == INST_CONTINUE - ) { - codePtr->codeStart[codePtr->numCodeBytes-1] = INST_DONE; - } TclReleaseByteCode(codePtr); } return result; } @@ -4749,11 +4856,11 @@ Tcl_WrongNumArgs(interp, 1, objv, "body ?handler ...? ?finally script?"); return TCL_ERROR; } bodyObj = objv[1]; - handlersObj = Tcl_NewObj(); + TclNewObj(handlersObj); bodyShared = 0; haveHandlers = 0; for (i=2 ; iloc[0] : NULL); Index: generic/tclCompCmds.c ================================================================== --- generic/tclCompCmds.c +++ generic/tclCompCmds.c @@ -136,13 +136,13 @@ * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *valueTokenPtr; int isScalar, localIndex, numWords, i; - DefineLineInformation; /* TIP #280 */ /* TODO: Consider support for compiling expanded args. */ numWords = parsePtr->numWords; if (numWords == 1) { return TCL_ERROR; @@ -401,13 +401,13 @@ */ keyVar = AnonymousLocal(envPtr); valVar = AnonymousLocal(envPtr); - infoPtr = Tcl_Alloc(sizeof(ForeachInfo)); + infoPtr = ckalloc(TclOffset(ForeachInfo, varLists) + sizeof(ForeachVarList *)); infoPtr->numLists = 1; - infoPtr->varLists[0] = Tcl_Alloc(sizeof(ForeachVarList) + sizeof(int)); + infoPtr->varLists[0] = ckalloc(TclOffset(ForeachVarList, varIndexes) + 2 * sizeof(int)); infoPtr->varLists[0]->numVars = 2; infoPtr->varLists[0]->varIndexes[0] = keyVar; infoPtr->varLists[0]->varIndexes[1] = valVar; infoIndex = TclCreateAuxData(infoPtr, &newForeachInfoType, envPtr); @@ -585,14 +585,14 @@ * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + DefineLineInformation; /* TIP #280 */ JumpFixup jumpFixup; Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr; int resultIndex, optsIndex, range, dropScript = 0; - DefineLineInformation; /* TIP #280 */ int depth = TclGetStackDepth(envPtr); /* * If syntax does not match what we expect for [catch], do not compile. * Let runtime checks determine if syntax has changed. @@ -618,17 +618,15 @@ resultIndex = optsIndex = -1; cmdTokenPtr = TokenAfter(parsePtr->tokenPtr); if (parsePtr->numWords >= 3) { resultNameTokenPtr = TokenAfter(cmdTokenPtr); - /* DGP */ resultIndex = LocalScalarFromToken(resultNameTokenPtr, envPtr); if (resultIndex < 0) { return TCL_ERROR; } - /* DKF */ if (parsePtr->numWords == 4) { optsNameTokenPtr = TokenAfter(resultNameTokenPtr); optsIndex = LocalScalarFromToken(optsNameTokenPtr, envPtr); if (optsIndex < 0) { return TCL_ERROR; @@ -699,12 +697,12 @@ TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr); /* Stack at this point on both branches: result returnCode */ if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { - Tcl_Panic("TclCompileCatchCmd: bad jump distance %" TCL_Z_MODIFIER "d", - (CurrentOffset(envPtr) - jumpFixup.codeOffset)); + Tcl_Panic("TclCompileCatchCmd: bad jump distance %d", + (int)(CurrentOffset(envPtr) - jumpFixup.codeOffset)); } /* * Push the return options if the caller wants them. This needs to happen * before INST_END_CATCH @@ -906,17 +904,16 @@ } if (listObj != NULL) { Tcl_Obj **objs; const char *bytes; int len; - size_t slen; Tcl_ListObjGetElements(NULL, listObj, &len, &objs); objPtr = Tcl_ConcatObj(len, objs); Tcl_DecrRefCount(listObj); - bytes = TclGetStringFromObj(objPtr, &slen); - PushLiteral(envPtr, bytes, slen); + bytes = Tcl_GetStringFromObj(objPtr, &len); + PushLiteral(envPtr, bytes, len); Tcl_DecrRefCount(objPtr); return TCL_OK; } /* @@ -1021,14 +1018,13 @@ * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - Tcl_Token *tokenPtr; - int i, dictVarIndex; DefineLineInformation; /* TIP #280 */ - Tcl_Token *varTokenPtr; + Tcl_Token *tokenPtr, *varTokenPtr; + int i, dictVarIndex; /* * There must be at least one argument after the command. */ @@ -1095,12 +1091,11 @@ * Parse the increment amount, if present. */ if (parsePtr->numWords == 4) { const char *word; - size_t numBytes; - int code; + int numBytes, code; Tcl_Token *incrTokenPtr; Tcl_Obj *intObj; incrTokenPtr = TokenAfter(keyTokenPtr); if (incrTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { @@ -1148,13 +1143,13 @@ * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; int i; - DefineLineInformation; /* TIP #280 */ /* * There must be at least two arguments after the command (the single-arg * case is legal, but too special and magic for us to deal with here). */ @@ -1176,54 +1171,22 @@ TclEmitInstInt4(INST_DICT_GET, parsePtr->numWords-2, envPtr); TclAdjustStackDepth(-1, envPtr); return TCL_OK; } -int -TclCompileDictGetWithDefaultCmd( - Tcl_Interp *interp, /* Used for looking up stuff. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr; - int i; - DefineLineInformation; /* TIP #280 */ - - /* - * There must be at least three arguments after the command. - */ - - /* TODO: Consider support for compiling expanded args. */ - if (parsePtr->numWords < 4) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(parsePtr->tokenPtr); - - for (i=1 ; inumWords ; i++) { - CompileWord(envPtr, tokenPtr, interp, i); - tokenPtr = TokenAfter(tokenPtr); - } - TclEmitInstInt4(INST_DICT_GET_DEF, parsePtr->numWords-3, envPtr); - TclAdjustStackDepth(-2, envPtr); - return TCL_OK; -} - int TclCompileDictExistsCmd( Tcl_Interp *interp, /* Used for looking up stuff. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; int i; - DefineLineInformation; /* TIP #280 */ /* * There must be at least two arguments after the command (the single-arg * case is legal, but too special and magic for us to deal with here). */ @@ -1254,12 +1217,12 @@ * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - Tcl_Token *tokenPtr; DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; int i, dictVarIndex; /* * There must be at least one argument after the variable name for us to * compile to bytecode. @@ -1312,12 +1275,11 @@ DefineLineInformation; /* TIP #280 */ int worker; /* Temp var for building the value in. */ Tcl_Token *tokenPtr; Tcl_Obj *keyObj, *valueObj, *dictObj; const char *bytes; - int i; - size_t len; + int i, len; if ((parsePtr->numWords & 1) == 0) { return TCL_ERROR; } @@ -1353,11 +1315,11 @@ /* * We did! Excellent. The "verifyDict" is to do type forcing. */ - bytes = TclGetStringFromObj(dictObj, &len); + bytes = Tcl_GetStringFromObj(dictObj, &len); PushLiteral(envPtr, bytes, len); TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_DICT_VERIFY, envPtr); Tcl_DecrRefCount(dictObj); return TCL_OK; @@ -1596,19 +1558,19 @@ Tcl_DStringFree(&buffer); return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } Tcl_DStringFree(&buffer); if (numVars != 2) { - Tcl_Free((void *)argv); + ckfree(argv); return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } nameChars = strlen(argv[0]); keyVarIndex = LocalScalar(argv[0], nameChars, envPtr); nameChars = strlen(argv[1]); valueVarIndex = LocalScalar(argv[1], nameChars, envPtr); - Tcl_Free((void *)argv); + ckfree(argv); if ((keyVarIndex < 0) || (valueVarIndex < 0)) { return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } @@ -1812,11 +1774,11 @@ * Assemble the instruction metadata. This is complex enough that it is * represented as auxData; it holds an ordered list of variable indices * that are to be used. */ - duiPtr = Tcl_Alloc(sizeof(DictUpdateInfo) + sizeof(int) * (numVars - 1)); + duiPtr = ckalloc(TclOffset(DictUpdateInfo, varIndices) + sizeof(int) * numVars); duiPtr->length = numVars; keyTokenPtrs = TclStackAlloc(interp, sizeof(Tcl_Token *) * numVars); tokenPtr = TokenAfter(dictVarTokenPtr); for (i=0 ; ilength - 1); - dui2Ptr = Tcl_Alloc(len); + len = TclOffset(DictUpdateInfo, varIndices) + sizeof(int) * dui1Ptr->length; + dui2Ptr = ckalloc(len); memcpy(dui2Ptr, dui1Ptr, len); return dui2Ptr; } static void FreeDictUpdateInfo( ClientData clientData) { - Tcl_Free(clientData); + ckfree(clientData); } static void PrintDictUpdateInfo( ClientData clientData, @@ -2315,11 +2277,11 @@ Tcl_Obj *appendObj, ByteCode *codePtr, unsigned int pcOffset) { DictUpdateInfo *duiPtr = clientData; - size_t i; + int i; for (i=0 ; ilength ; i++) { if (i) { Tcl_AppendToObj(appendObj, ", ", -1); } @@ -2333,11 +2295,11 @@ Tcl_Obj *dictObj, ByteCode *codePtr, unsigned int pcOffset) { DictUpdateInfo *duiPtr = clientData; - size_t i; + int i; Tcl_Obj *variables = Tcl_NewObj(); for (i=0 ; ilength ; i++) { Tcl_ListObjAppendElement(NULL, variables, Tcl_NewIntObj(duiPtr->varIndices[i])); @@ -2371,17 +2333,17 @@ * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; + /* * General syntax: [error message ?errorInfo? ?errorCode?] */ - Tcl_Token *tokenPtr; - DefineLineInformation; /* TIP #280 */ - if (parsePtr->numWords < 2 || parsePtr->numWords > 4) { return TCL_ERROR; } /* @@ -2490,15 +2452,15 @@ * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + DefineLineInformation; /* TIP #280 */ Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr; JumpFixup jumpEvalCondFixup; int bodyCodeOffset, nextCodeOffset, jumpDist; int bodyRange, nextRange; - DefineLineInformation; /* TIP #280 */ if (parsePtr->numWords != 5) { return TCL_ERROR; } @@ -2703,20 +2665,20 @@ * compiled. */ CompileEnv *envPtr, /* Holds resulting instructions. */ int collect) /* Select collecting or accumulating mode * (TCL_EACH_*) */ { + DefineLineInformation; /* TIP #280 */ Proc *procPtr = envPtr->procPtr; ForeachInfo *infoPtr=NULL; /* Points to the structure describing this * foreach command. Stored in a AuxData * record in the ByteCode. */ Tcl_Token *tokenPtr, *bodyTokenPtr; int jumpBackOffset, infoIndex, range; int numWords, numLists, i, j, code = TCL_OK; Tcl_Obj *varListObj = NULL; - DefineLineInformation; /* TIP #280 */ /* * If the foreach command isn't in a procedure, don't compile it inline: * the payoff is too small. */ @@ -2748,12 +2710,12 @@ * structures describing this command. Then create a AuxData record * pointing to the ForeachInfo structure. */ numLists = (numWords - 2)/2; - infoPtr = Tcl_Alloc(sizeof(ForeachInfo) - + (numLists - 1) * sizeof(ForeachVarList *)); + infoPtr = ckalloc(TclOffset(ForeachInfo, varLists) + + numLists * sizeof(ForeachVarList *)); infoPtr->numLists = 0; /* Count this up as we go */ /* * Parse each var list into sequence of var names. Don't * compile the foreach inline if any var name needs substitutions or isn't @@ -2782,26 +2744,24 @@ numVars == 0) { code = TCL_ERROR; goto done; } - varListPtr = Tcl_Alloc(sizeof(ForeachVarList) - + (numVars - 1) * sizeof(int)); + varListPtr = ckalloc(TclOffset(ForeachVarList, varIndexes) + + numVars * sizeof(int)); varListPtr->numVars = numVars; infoPtr->varLists[i/2] = varListPtr; infoPtr->numLists++; for (j = 0; j < numVars; j++) { Tcl_Obj *varNameObj; const char *bytes; - int varIndex; - size_t length; - + int numBytes, varIndex; Tcl_ListObjIndex(NULL, varListObj, j, &varNameObj); - bytes = TclGetStringFromObj(varNameObj, &length); - varIndex = LocalScalar(bytes, length, envPtr); + bytes = Tcl_GetStringFromObj(varNameObj, &numBytes); + varIndex = LocalScalar(bytes, numBytes, envPtr); if (varIndex < 0) { code = TCL_ERROR; goto done; } varListPtr->varIndexes[j] = varIndex; @@ -2915,25 +2875,25 @@ static ClientData DupForeachInfo( ClientData clientData) /* The foreach command's compilation auxiliary * data to duplicate. */ { - register ForeachInfo *srcPtr = clientData; + ForeachInfo *srcPtr = clientData; ForeachInfo *dupPtr; - register ForeachVarList *srcListPtr, *dupListPtr; + ForeachVarList *srcListPtr, *dupListPtr; int numVars, i, j, numLists = srcPtr->numLists; - dupPtr = Tcl_Alloc(sizeof(ForeachInfo) + dupPtr = ckalloc(TclOffset(ForeachInfo, varLists) + numLists * sizeof(ForeachVarList *)); dupPtr->numLists = numLists; dupPtr->firstValueTemp = srcPtr->firstValueTemp; dupPtr->loopCtTemp = srcPtr->loopCtTemp; for (i = 0; i < numLists; i++) { srcListPtr = srcPtr->varLists[i]; numVars = srcListPtr->numVars; - dupListPtr = Tcl_Alloc(sizeof(ForeachVarList) + dupListPtr = ckalloc(TclOffset(ForeachVarList, varIndexes) + numVars * sizeof(int)); dupListPtr->numVars = numVars; for (j = 0; j < numVars; j++) { dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j]; } @@ -2964,20 +2924,20 @@ static void FreeForeachInfo( ClientData clientData) /* The foreach command's compilation auxiliary * data to free. */ { - register ForeachInfo *infoPtr = clientData; - register ForeachVarList *listPtr; + ForeachInfo *infoPtr = clientData; + ForeachVarList *listPtr; int numLists = infoPtr->numLists; - register int i; + int i; for (i = 0; i < numLists; i++) { listPtr = infoPtr->varLists[i]; - Tcl_Free(listPtr); + ckfree(listPtr); } - Tcl_Free(infoPtr); + ckfree(infoPtr); } /* *---------------------------------------------------------------------- * @@ -3000,12 +2960,12 @@ ClientData clientData, Tcl_Obj *appendObj, ByteCode *codePtr, unsigned int pcOffset) { - register ForeachInfo *infoPtr = clientData; - register ForeachVarList *varsPtr; + ForeachInfo *infoPtr = clientData; + ForeachVarList *varsPtr; int i, j; Tcl_AppendToObj(appendObj, "data=[", -1); for (i=0 ; inumLists ; i++) { @@ -3040,12 +3000,12 @@ ClientData clientData, Tcl_Obj *appendObj, ByteCode *codePtr, unsigned int pcOffset) { - register ForeachInfo *infoPtr = clientData; - register ForeachVarList *varsPtr; + ForeachInfo *infoPtr = clientData; + ForeachVarList *varsPtr; int i, j; Tcl_AppendPrintfToObj(appendObj, "jumpOffset=%+d, vars=", infoPtr->loopCtTemp); for (i=0 ; inumLists ; i++) { @@ -3070,12 +3030,12 @@ ClientData clientData, Tcl_Obj *dictObj, ByteCode *codePtr, unsigned int pcOffset) { - register ForeachInfo *infoPtr = clientData; - register ForeachVarList *varsPtr; + ForeachInfo *infoPtr = clientData; + ForeachVarList *varsPtr; int i, j; Tcl_Obj *objPtr, *innerPtr; /* * Data stores. @@ -3117,12 +3077,12 @@ ClientData clientData, Tcl_Obj *dictObj, ByteCode *codePtr, unsigned int pcOffset) { - register ForeachInfo *infoPtr = clientData; - register ForeachVarList *varsPtr; + ForeachInfo *infoPtr = clientData; + ForeachVarList *varsPtr; int i, j; Tcl_Obj *objPtr, *innerPtr; /* * Jump offset. @@ -3178,12 +3138,11 @@ { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = parsePtr->tokenPtr; Tcl_Obj **objv, *formatObj, *tmpObj; char *bytes, *start; - int i, j; - size_t len; + int i, j, len; /* * Don't handle any guaranteed-error cases. */ @@ -3202,11 +3161,11 @@ if (!TclWordKnownAtCompileTime(tokenPtr, formatObj)) { Tcl_DecrRefCount(formatObj); return TCL_ERROR; } - objv = Tcl_Alloc((parsePtr->numWords-2) * sizeof(Tcl_Obj *)); + objv = ckalloc((parsePtr->numWords-2) * sizeof(Tcl_Obj *)); for (i=0 ; i+2 < parsePtr->numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); objv[i] = Tcl_NewObj(); Tcl_IncrRefCount(objv[i]); if (!TclWordKnownAtCompileTime(tokenPtr, objv[i])) { @@ -3217,16 +3176,16 @@ /* * Everything is a literal, so the result is constant too (or an error if * the format is broken). Do the format now. */ - tmpObj = Tcl_Format(interp, TclGetString(formatObj), + tmpObj = Tcl_Format(interp, Tcl_GetString(formatObj), parsePtr->numWords-2, objv); for (; --i>=0 ;) { Tcl_DecrRefCount(objv[i]); } - Tcl_Free(objv); + ckfree(objv); Tcl_DecrRefCount(formatObj); if (tmpObj == NULL) { TclCompileSyntaxError(interp, envPtr); return TCL_OK; } @@ -3234,11 +3193,11 @@ /* * Not an error, always a constant result, so just push the result as a * literal. Job done. */ - bytes = TclGetStringFromObj(tmpObj, &len); + bytes = Tcl_GetStringFromObj(tmpObj, &len); PushLiteral(envPtr, bytes, len); Tcl_DecrRefCount(tmpObj); return TCL_OK; checkForStringConcatCase: @@ -3252,20 +3211,20 @@ */ for (; i>=0 ; i--) { Tcl_DecrRefCount(objv[i]); } - Tcl_Free(objv); + ckfree(objv); tokenPtr = TokenAfter(parsePtr->tokenPtr); tokenPtr = TokenAfter(tokenPtr); i = 0; /* * Now scan through and check for non-%s and non-%% substitutions. */ - for (bytes = TclGetString(formatObj) ; *bytes ; bytes++) { + for (bytes = Tcl_GetString(formatObj) ; *bytes ; bytes++) { if (*bytes == '%') { bytes++; if (*bytes == 's') { i++; continue; @@ -3294,11 +3253,11 @@ */ i = 0; /* The count of things to concat. */ j = 2; /* The index into the argument tokens, for * TIP#280 handling. */ - start = TclGetString(formatObj); + start = Tcl_GetString(formatObj); /* The start of the currently-scanned literal * in the format string. */ tmpObj = Tcl_NewObj(); /* The buffer used to accumulate the literal * being built. */ for (bytes = start ; *bytes ; bytes++) { @@ -3305,11 +3264,11 @@ if (*bytes == '%') { Tcl_AppendToObj(tmpObj, start, bytes - start); if (*++bytes == '%') { Tcl_AppendToObj(tmpObj, "%", 1); } else { - char *b = TclGetStringFromObj(tmpObj, &len); + char *b = Tcl_GetStringFromObj(tmpObj, &len); /* * If there is a non-empty literal from the format string, * push it and reset. */ @@ -3339,11 +3298,11 @@ /* * Handle the case of a trailing literal. */ Tcl_AppendToObj(tmpObj, start, bytes - start); - bytes = TclGetStringFromObj(tmpObj, &len); + bytes = Tcl_GetStringFromObj(tmpObj, &len); if (len > 0) { PushLiteral(envPtr, bytes, len); i++; } Tcl_DecrRefCount(tmpObj); @@ -3394,11 +3353,11 @@ } int TclLocalScalar( const char *bytes, - size_t numBytes, + int numBytes, CompileEnv *envPtr) { Tcl_Token token[2] = {{TCL_TOKEN_SIMPLE_WORD, NULL, 0, 1}, {TCL_TOKEN_TEXT, NULL, 0, 0}}; @@ -3443,16 +3402,15 @@ CompileEnv *envPtr, /* Holds resulting instructions. */ int flags, /* TCL_NO_LARGE_INDEX | TCL_NO_ELEMENT. */ int *localIndexPtr, /* Must not be NULL. */ int *isScalarPtr) /* Must not be NULL. */ { - register const char *p; + const char *p; const char *last, *name, *elName; - register size_t n; + int n; Tcl_Token *elemTokenPtr = NULL; - size_t nameLen, elNameLen; - int simpleVarName, localIndex; + int nameLen, elNameLen, simpleVarName, localIndex; int elemTokenCount = 0, allocedTokens = 0, removedParen = 0; /* * Decide if we can use a frame slot for the var/array name or if we need * to emit code to compute and push the name at runtime. We use a frame @@ -3478,14 +3436,14 @@ nameLen = varTokenPtr[1].size; if (name[nameLen-1] == ')') { /* * last char is ')' => potential array reference. */ - last = Tcl_UtfPrev(name + nameLen, name); + last = &name[nameLen-1]; if (*last == ')') { - for (p = name; p < last; p = Tcl_UtfNext(p)) { + for (p = name; p < last; p++) { if (*p == '(') { elName = p + 1; elNameLen = last - elName; nameLen = p - name; break; @@ -3509,26 +3467,25 @@ } } } else if (interp && ((n = varTokenPtr->numComponents) > 1) && (varTokenPtr[1].type == TCL_TOKEN_TEXT) && (varTokenPtr[n].type == TCL_TOKEN_TEXT) - && (*((p = varTokenPtr[n].start + varTokenPtr[n].size)-1) == ')') - && (*Tcl_UtfPrev(p, varTokenPtr[n].start) == ')')) { + && (*(varTokenPtr[n].start + varTokenPtr[n].size - 1) == ')')) { /* * Check for parentheses inside first token. */ simpleVarName = 0; for (p = varTokenPtr[1].start, - last = p + varTokenPtr[1].size; p < last; p = Tcl_UtfNext(p)) { + last = p + varTokenPtr[1].size; p < last; p++) { if (*p == '(') { simpleVarName = 1; break; } } if (simpleVarName) { - size_t remainingLen; + int remainingLen; /* * Check the last token: if it is just ')', do not count it. * Otherwise, remove the ')' and flag so that it is restored at * the end. @@ -3585,11 +3542,11 @@ * See whether name has any namespace separators (::'s). */ int hasNsQualifiers = 0; - for (p = name, last = p + nameLen-1; p < last; p = Tcl_UtfNext(p)) { + for (p = name, last = p + nameLen-1; p < last; p++) { if ((*p == ':') && (*(p+1) == ':')) { hasNsQualifiers = 1; break; } } Index: generic/tclCompCmdsGR.c ================================================================== --- generic/tclCompCmdsGR.c +++ generic/tclCompCmdsGR.c @@ -25,10 +25,11 @@ static void CompileReturnInternal(CompileEnv *envPtr, unsigned char op, int code, int level, Tcl_Obj *returnOpts); static int IndexTailVarIfKnown(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr); + /* *---------------------------------------------------------------------- * * TclGetIndexFromToken -- @@ -47,12 +48,12 @@ */ int TclGetIndexFromToken( Tcl_Token *tokenPtr, - size_t before, - size_t after, + int before, + int after, int *indexPtr) { Tcl_Obj *tmpObj = Tcl_NewObj(); int result = TCL_ERROR; @@ -88,13 +89,13 @@ * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr; int localIndex, numWords, i; - DefineLineInformation; /* TIP #280 */ /* TODO: Consider support for compiling expanded args. */ numWords = parsePtr->numWords; if (numWords < 2) { return TCL_ERROR; @@ -124,16 +125,13 @@ if (localIndex < 0) { return TCL_ERROR; } - /* - * TODO: Consider what value can pass through the - * IndexTailVarIfKnown() screen. Full CompileWord() likely does not - * apply here. Push known value instead. - */ - + /* TODO: Consider what value can pass through the + * IndexTailVarIfKnown() screen. Full CompileWord() + * likely does not apply here. Push known value instead. */ CompileWord(envPtr, varTokenPtr, interp, i); TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr); } /* @@ -170,27 +168,26 @@ * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + DefineLineInformation; /* TIP #280 */ JumpFixupArray jumpFalseFixupArray; /* Used to fix the ifFalse jump after each * test when its target PC is determined. */ JumpFixupArray jumpEndFixupArray; /* Used to fix the jump after each "then" body * to the end of the "if" when that PC is * determined. */ Tcl_Token *tokenPtr, *testTokenPtr; int jumpIndex = 0; /* Avoid compiler warning. */ - size_t numBytes; - int jumpFalseDist, numWords, wordIdx, j, code; + int jumpFalseDist, numWords, wordIdx, numBytes, j, code; const char *word; int realCond = 1; /* Set to 0 for static conditions: * "if 0 {..}" */ int boolVal; /* Value of static condition. */ int compileScripts = 1; - DefineLineInformation; /* TIP #280 */ /* * Only compile the "if" command if all arguments are simple words, in * order to insure correct substitution [Bug 219166] */ @@ -271,11 +268,11 @@ TclExpandJumpFixupArray(&jumpFalseFixupArray); } jumpIndex = jumpFalseFixupArray.next; jumpFalseFixupArray.next++; TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, - jumpFalseFixupArray.fixup + jumpIndex); + jumpFalseFixupArray.fixup+jumpIndex); } code = TCL_OK; } /* @@ -318,11 +315,11 @@ if (jumpEndFixupArray.next >= jumpEndFixupArray.end) { TclExpandJumpFixupArray(&jumpEndFixupArray); } jumpEndFixupArray.next++; TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - jumpEndFixupArray.fixup + jumpIndex); + jumpEndFixupArray.fixup+jumpIndex); /* * Fix the target of the jumpFalse after the test. Generate a 4 * byte jump if the distance is > 120 bytes. This is conservative, * and ensures that we won't have to replace this jump if we later @@ -330,11 +327,11 @@ * with a 4 byte jump. */ TclAdjustStackDepth(-1, envPtr); if (TclFixupForwardJumpToHere(envPtr, - jumpFalseFixupArray.fixup + jumpIndex, 120)) { + jumpFalseFixupArray.fixup+jumpIndex, 120)) { /* * Adjust the code offset for the proceeding jump to the end * of the "if" command. */ @@ -413,11 +410,11 @@ */ for (j = jumpEndFixupArray.next; j > 0; j--) { jumpIndex = (j - 1); /* i.e. process the closest jump first. */ if (TclFixupForwardJumpToHere(envPtr, - jumpEndFixupArray.fixup + jumpIndex, 127)) { + jumpEndFixupArray.fixup+jumpIndex, 127)) { /* * Adjust the immediately preceeding "ifFalse" jump. We moved it's * target (just after this jump) down three bytes. */ @@ -432,11 +429,11 @@ } else if (opCode == INST_JUMP_FALSE4) { jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1); jumpFalseDist += 3; TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1)); } else { - Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", opCode); + Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", (int) opCode); } } } /* @@ -474,13 +471,13 @@ * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *incrTokenPtr; int isScalar, localIndex, haveImmValue, immValue; - DefineLineInformation; /* TIP #280 */ if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) { return TCL_ERROR; } @@ -498,11 +495,11 @@ immValue = 1; if (parsePtr->numWords == 3) { incrTokenPtr = TokenAfter(varTokenPtr); if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { const char *word = incrTokenPtr[1].start; - size_t numBytes = incrTokenPtr[1].size; + int numBytes = incrTokenPtr[1].size; int code; Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes); Tcl_IncrRefCount(intObj); code = TclGetIntFromObj(NULL, intObj, &immValue); @@ -605,11 +602,11 @@ objPtr = Tcl_NewObj(); Tcl_IncrRefCount(objPtr); if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) { goto notCompilable; } - bytes = TclGetString(objPtr); + bytes = Tcl_GetString(objPtr); /* * We require that the argument start with "::" and not have any of "*\[?" * in it. (Theoretically, we should look in only the final component, but * the difference is so slight given current naming practices.) @@ -671,13 +668,13 @@ * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; int isScalar, localIndex; - DefineLineInformation; /* TIP #280 */ if (parsePtr->numWords != 2) { return TCL_ERROR; } @@ -849,13 +846,13 @@ * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *valueTokenPtr; int isScalar, localIndex, numWords, i; - DefineLineInformation; /* TIP #280 */ /* TODO: Consider support for compiling expanded args. */ numWords = parsePtr->numWords; if (numWords < 3) { return TCL_ERROR; @@ -882,11 +879,11 @@ * If we are doing an assignment, push the new value. In the no values * case, create an empty object. */ if (numWords > 2) { - Tcl_Token *valueTokenPtr = TokenAfter(varTokenPtr); + valueTokenPtr = TokenAfter(varTokenPtr); CompileWord(envPtr, valueTokenPtr, interp, 2); } /* @@ -921,11 +918,11 @@ valueTokenPtr = TokenAfter(varTokenPtr); for (i = 2 ; i < numWords ; i++) { CompileWord(envPtr, valueTokenPtr, interp, i); valueTokenPtr = TokenAfter(valueTokenPtr); } - TclEmitInstInt4( INST_LIST, numWords - 2, envPtr); + TclEmitInstInt4( INST_LIST, numWords-2, envPtr); if (isScalar) { if (localIndex < 0) { TclEmitOpcode( INST_LAPPEND_LIST_STK, envPtr); } else { TclEmitInstInt4(INST_LAPPEND_LIST, localIndex, envPtr); @@ -965,13 +962,13 @@ * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; int isScalar, localIndex, numWords, idx; - DefineLineInformation; /* TIP #280 */ numWords = parsePtr->numWords; /* * Check for command syntax error, but we'll punt that to runtime. @@ -998,11 +995,11 @@ /* * Generate the next variable name. */ PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex, - &isScalar, idx + 2); + &isScalar, idx+2); /* * Emit instructions to get the idx'th item out of the list value on * the stack and assign it to the variable. */ @@ -1037,11 +1034,11 @@ /* * Generate code to leave the rest of the list on the stack. */ TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr); - TclEmitInt4( (int)TCL_INDEX_END, envPtr); + TclEmitInt4( TCL_INDEX_END, envPtr); return TCL_OK; } /* @@ -1069,16 +1066,16 @@ * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + DefineLineInformation; /* TIP #280 */ Tcl_Token *idxTokenPtr, *valTokenPtr; int i, idx, numWords = parsePtr->numWords; - DefineLineInformation; /* TIP #280 */ /* - * Quit if too few args. + * Quit if not enough args. */ /* TODO: Consider support for compiling expanded args. */ if (numWords <= 1) { return TCL_ERROR; @@ -1088,12 +1085,12 @@ if (numWords != 3) { goto emitComplexLindex; } idxTokenPtr = TokenAfter(valTokenPtr); - if (TclGetIndexFromToken(idxTokenPtr, TCL_INDEX_NONE, - TCL_INDEX_NONE, &idx) == TCL_OK) { + if (TclGetIndexFromToken(idxTokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_BEFORE, + &idx) == TCL_OK) { /* * The idxTokenPtr parsed as a valid index value and was * encoded as expected by INST_LIST_INDEX_IMM. * * NOTE: that we rely on indexing before a list producing the @@ -1242,11 +1239,11 @@ * that might be hanging around. */ if (concat && numWords == 2) { TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); - TclEmitInt4( (int)TCL_INDEX_END, envPtr); + TclEmitInt4( TCL_INDEX_END, envPtr); } return TCL_OK; } /* @@ -1274,12 +1271,12 @@ * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - Tcl_Token *varTokenPtr; DefineLineInformation; /* TIP #280 */ + Tcl_Token *varTokenPtr; if (parsePtr->numWords != 2) { return TCL_ERROR; } varTokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1307,31 +1304,31 @@ * command. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { - Tcl_Token *tokenPtr, *listTokenPtr; DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr, *listTokenPtr; int idx1, idx2; if (parsePtr->numWords != 4) { return TCL_ERROR; } listTokenPtr = TokenAfter(parsePtr->tokenPtr); tokenPtr = TokenAfter(listTokenPtr); - if ((TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_NONE, - &idx1) != TCL_OK) || (idx1 == (int)TCL_INDEX_NONE)) { + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER, + &idx1) != TCL_OK) { return TCL_ERROR; } /* * Token was an index value, and we treat all "first" indices * before the list same as the start of the list. */ tokenPtr = TokenAfter(tokenPtr); - if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_NONE, TCL_INDEX_END, + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END, &idx2) != TCL_OK) { return TCL_ERROR; } /* * Token was an index value, and we treat all "last" indices @@ -1368,12 +1365,12 @@ * command. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { - Tcl_Token *tokenPtr, *listTokenPtr; DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr, *listTokenPtr; int idx, i; if (parsePtr->numWords < 3) { return TCL_ERROR; } @@ -1407,24 +1404,24 @@ */ CompileWord(envPtr, listTokenPtr, interp, 1); if (parsePtr->numWords == 3) { TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); - TclEmitInt4( (int)TCL_INDEX_END, envPtr); + TclEmitInt4( TCL_INDEX_END, envPtr); return TCL_OK; } for (i=3 ; inumWords ; i++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); } - TclEmitInstInt4( INST_LIST, i - 3, envPtr); + TclEmitInstInt4( INST_LIST, i-3, envPtr); - if (idx == (int)TCL_INDEX_START) { + if (idx == TCL_INDEX_START) { TclEmitInstInt4( INST_REVERSE, 2, envPtr); TclEmitOpcode( INST_LIST_CONCAT, envPtr); - } else if (idx == (int)TCL_INDEX_END) { + } else if (idx == TCL_INDEX_END) { TclEmitOpcode( INST_LIST_CONCAT, envPtr); } else { /* * Here we handle two ranges for idx. First when idx > 0, we * want the first half of the split to end at index idx-1 and @@ -1435,19 +1432,19 @@ * with a pre-adjustment of the end-N value. * The root of this is that the commands [lrange] and [linsert] * differ in their interpretation of the "end" index. */ - if (idx < (int)TCL_INDEX_END) { + if (idx < TCL_INDEX_END) { idx++; } TclEmitInstInt4( INST_OVER, 1, envPtr); TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); - TclEmitInt4( idx - 1, envPtr); + TclEmitInt4( idx-1, envPtr); TclEmitInstInt4( INST_REVERSE, 3, envPtr); TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr); - TclEmitInt4( (int)TCL_INDEX_END, envPtr); + TclEmitInt4( TCL_INDEX_END, envPtr); TclEmitOpcode( INST_LIST_CONCAT, envPtr); TclEmitOpcode( INST_LIST_CONCAT, envPtr); } return TCL_OK; @@ -1471,28 +1468,28 @@ * command. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { - Tcl_Token *tokenPtr, *listTokenPtr; DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr, *listTokenPtr; int idx1, idx2, i; int emptyPrefix=1, suffixStart = 0; if (parsePtr->numWords < 4) { return TCL_ERROR; } listTokenPtr = TokenAfter(parsePtr->tokenPtr); tokenPtr = TokenAfter(listTokenPtr); - if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_NONE, + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER, &idx1) != TCL_OK) { return TCL_ERROR; } tokenPtr = TokenAfter(tokenPtr); - if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_NONE, TCL_INDEX_END, + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END, &idx2) != TCL_OK) { return TCL_ERROR; } /* @@ -1504,18 +1501,18 @@ * The proper suffix begins with the greater of indices idx1 or * idx2 + 1. If we cannot tell at compile time which is greater, * we must defer to direct evaluation. */ - if (idx1 == (int)TCL_INDEX_NONE) { - suffixStart = (int)TCL_INDEX_NONE; - } else if (idx2 == (int)TCL_INDEX_NONE) { + if (idx1 == TCL_INDEX_AFTER) { + suffixStart = idx1; + } else if (idx2 == TCL_INDEX_BEFORE) { suffixStart = idx1; - } else if (idx2 == (int)TCL_INDEX_END) { - suffixStart = (int)TCL_INDEX_NONE; - } else if (((idx2 < (int)TCL_INDEX_END) && (idx1 <= (int)TCL_INDEX_END)) - || ((idx2 >= (int)TCL_INDEX_START) && (idx1 >= (int)TCL_INDEX_START))) { + } else if (idx2 == TCL_INDEX_END) { + suffixStart = TCL_INDEX_AFTER; + } else if (((idx2 < TCL_INDEX_END) && (idx1 <= TCL_INDEX_END)) + || ((idx2 >= TCL_INDEX_START) && (idx1 >= TCL_INDEX_START))) { suffixStart = (idx1 > idx2 + 1) ? idx1 : idx2 + 1; } else { return TCL_ERROR; } @@ -1545,15 +1542,15 @@ * This is a "no-op". Example: [lreplace {a b c} 2 0] * We still do a list operation to get list-verification * and canonicalization side effects. */ TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); - TclEmitInt4( (int)TCL_INDEX_END, envPtr); + TclEmitInt4( TCL_INDEX_END, envPtr); return TCL_OK; } - if (idx1 != (int)TCL_INDEX_START) { + if (idx1 != TCL_INDEX_START) { /* Prefix may not be empty; generate bytecode to push it */ if (emptyPrefix) { TclEmitOpcode( INST_DUP, envPtr); } else { TclEmitInstInt4( INST_OVER, 1, envPtr); @@ -1569,19 +1566,19 @@ if (!emptyPrefix) { TclEmitInstInt4( INST_REVERSE, 2, envPtr); } - if (suffixStart == (int)TCL_INDEX_NONE) { + if (suffixStart == TCL_INDEX_AFTER) { TclEmitOpcode( INST_POP, envPtr); if (emptyPrefix) { PushStringLiteral(envPtr, ""); } } else { /* Suffix may not be empty; generate bytecode to push it */ TclEmitInstInt4( INST_LIST_RANGE_IMM, suffixStart, envPtr); - TclEmitInt4( (int)TCL_INDEX_END, envPtr); + TclEmitInt4( TCL_INDEX_END, envPtr); if (!emptyPrefix) { TclEmitOpcode( INST_LIST_CONCAT, envPtr); } } @@ -1635,18 +1632,18 @@ * command. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { + DefineLineInformation; /* TIP #280 */ int tempDepth; /* Depth used for emitting one part of the * code burst. */ Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the * parse of the variable name. */ int localIndex; /* Index of var in local var table. */ int isScalar; /* Flag == 1 if scalar, 0 if array. */ int i; - DefineLineInformation; /* TIP #280 */ /* * Check argument count. */ @@ -1807,12 +1804,12 @@ * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - Tcl_Token *tokenPtr; DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; if (parsePtr->numWords != 2) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1857,12 +1854,12 @@ * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - Tcl_Token *tokenPtr; DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; if (parsePtr->numWords != 2) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1879,12 +1876,12 @@ * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); int off; if (parsePtr->numWords != 2) { return TCL_ERROR; } @@ -1915,12 +1912,12 @@ * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); JumpFixup jumpFixup; if (parsePtr->numWords != 2) { return TCL_ERROR; } @@ -1952,13 +1949,13 @@ * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; int localIndex, numWords, i; - DefineLineInformation; /* TIP #280 */ if (envPtr->procPtr == NULL) { return TCL_ERROR; } @@ -2077,16 +2074,15 @@ * command. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { + DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the * parse of the RE or string. */ - size_t len; - int i, nocase, exact, sawLast, simple; + int i, len, nocase, exact, sawLast, simple; const char *str; - DefineLineInformation; /* TIP #280 */ /* * We are only interested in compiling simple regexp cases. Currently * supported compile cases are: * regexp ?-nocase? ?--? staticString $var @@ -2121,11 +2117,11 @@ len = varTokenPtr[1].size; if ((len == 2) && (str[0] == '-') && (str[1] == '-')) { sawLast++; i++; break; - } else if ((len > 1) && (strncmp(str,"-nocase", len) == 0)) { + } else if ((len > 1) && (strncmp(str, "-nocase", len) == 0)) { nocase = 1; } else { /* * Not an option we recognize. */ @@ -2185,19 +2181,19 @@ Tcl_DStringFree(&ds); } } if (!simple) { - CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords - 2); + CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-2); } /* * Push the string arg. */ varTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords - 1); + CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-1); if (simple) { if (exact && !nocase) { TclEmitOpcode( INST_STR_EQ, envPtr); } else { @@ -2268,12 +2264,11 @@ DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr, *stringTokenPtr; Tcl_Obj *patternObj = NULL, *replacementObj = NULL; Tcl_DString pattern; const char *bytes; - int exact, quantified, result = TCL_ERROR; - size_t len; + int len, exact, quantified, result = TCL_ERROR; if (parsePtr->numWords < 5 || parsePtr->numWords > 6) { return TCL_ERROR; } @@ -2296,12 +2291,12 @@ tokenPtr = TokenAfter(tokenPtr); patternObj = Tcl_NewObj(); if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) { goto done; } - if (TclGetString(patternObj)[0] == '-') { - if (strcmp(TclGetString(patternObj), "--") != 0 + if (Tcl_GetString(patternObj)[0] == '-') { + if (strcmp(Tcl_GetString(patternObj), "--") != 0 || parsePtr->numWords == 5) { goto done; } tokenPtr = TokenAfter(tokenPtr); Tcl_DecrRefCount(patternObj); @@ -2328,11 +2323,11 @@ /* * Next, higher-level checks. Is the RE a very simple glob? Is the * replacement "simple"? */ - bytes = TclGetStringFromObj(patternObj, &len); + bytes = Tcl_GetStringFromObj(patternObj, &len); if (TclReToGlob(NULL, bytes, len, &pattern, &exact, &quantified) != TCL_OK || exact || quantified) { goto done; } bytes = Tcl_DStringValue(&pattern); @@ -2347,11 +2342,11 @@ * OK, we've proved there are no metacharacters except for the * '*' at each end. */ len = Tcl_DStringLength(&pattern) - 2; - if (len + 2 > 2) { + if (len > 0) { goto isSimpleGlob; } /* * The pattern is "**"! I believe that should be impossible, @@ -2362,11 +2357,11 @@ goto done; } bytes++; } isSimpleGlob: - for (bytes = TclGetString(replacementObj); *bytes; bytes++) { + for (bytes = Tcl_GetString(replacementObj); *bytes; bytes++) { switch (*bytes) { case '\\': case '&': goto done; } } @@ -2376,13 +2371,13 @@ */ result = TCL_OK; bytes = Tcl_DStringValue(&pattern) + 1; PushLiteral(envPtr, bytes, len); - bytes = TclGetStringFromObj(replacementObj, &len); + bytes = Tcl_GetStringFromObj(replacementObj, &len); PushLiteral(envPtr, bytes, len); - CompileWord(envPtr, stringTokenPtr, interp, parsePtr->numWords - 2); + CompileWord(envPtr, stringTokenPtr, interp, parsePtr->numWords-2); TclEmitOpcode( INST_STR_MAP, envPtr); done: Tcl_DStringFree(&pattern); if (patternObj) { @@ -2419,10 +2414,11 @@ * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + DefineLineInformation; /* TIP #280 */ /* * General syntax: [return ?-option value ...? ?result?] * An even number of words means an explicit result argument is present. */ int level, code, objc, size, status = TCL_OK; @@ -2429,11 +2425,10 @@ int numWords = parsePtr->numWords; int explicitResult = (0 == (numWords % 2)); int numOptionWords = numWords - 1 - explicitResult; Tcl_Obj *returnOpts, **objv; Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr); - DefineLineInformation; /* TIP #280 */ /* * Check for special case which can always be compiled: * return -options * Unlike the normal [return] compilation, this version does everything at @@ -2507,11 +2502,11 @@ * All options are known at compile time, so we're going to bytecompile. * Emit instructions to push the result on the stack. */ if (explicitResult) { - CompileWord(envPtr, wordTokenPtr, interp, numWords - 1); + CompileWord(envPtr, wordTokenPtr, interp, numWords-1); } else { /* * No explict result argument, so default result is empty string. */ @@ -2585,11 +2580,11 @@ /* * Push the result. */ if (explicitResult) { - CompileWord(envPtr, wordTokenPtr, interp, numWords - 1); + CompileWord(envPtr, wordTokenPtr, interp, numWords-1); } else { PushStringLiteral(envPtr, ""); } /* @@ -2634,15 +2629,15 @@ TclCompileSyntaxError( Tcl_Interp *interp, CompileEnv *envPtr) { Tcl_Obj *msg = Tcl_GetObjResult(interp); - size_t numBytes; + int numBytes; const char *bytes = TclGetStringFromObj(msg, &numBytes); TclErrorStackResetIf(interp, bytes, numBytes); - TclEmitPush(TclRegisterLiteral(envPtr, bytes, numBytes, 0), envPtr); + TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr); CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0, TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR))); Tcl_ResetResult(interp); } @@ -2671,13 +2666,13 @@ * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; int localIndex, numWords, i; - DefineLineInformation; /* TIP #280 */ Tcl_Obj *objPtr; if (envPtr->procPtr == NULL) { return TCL_ERROR; } @@ -2778,13 +2773,13 @@ * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *valueTokenPtr; int localIndex, numWords, i; - DefineLineInformation; /* TIP #280 */ numWords = parsePtr->numWords; if (numWords < 2) { return TCL_ERROR; } @@ -2816,16 +2811,16 @@ * IndexTailVarIfKnown() screen. Full CompileWord() * likely does not apply here. Push known value instead. */ CompileWord(envPtr, varTokenPtr, interp, i); TclEmitInstInt4( INST_VARIABLE, localIndex, envPtr); - if (i + 1 < numWords) { + if (i+1 < numWords) { /* * A value has been given: set the variable, pop the value */ - CompileWord(envPtr, valueTokenPtr, interp, i + 1); + CompileWord(envPtr, valueTokenPtr, interp, i+1); Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); TclEmitOpcode( INST_POP, envPtr); } } @@ -2862,12 +2857,11 @@ Tcl_Token *varTokenPtr, /* Token representing the variable name */ CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Obj *tailPtr; const char *tailName, *p; - int n = varTokenPtr->numComponents; - size_t len; + int len, n = varTokenPtr->numComponents; Tcl_Token *lastTokenPtr; int full, localIndex; /* * Determine if the tail is (a) known at compile time, and (b) not an @@ -2898,11 +2892,11 @@ } tailName = TclGetStringFromObj(tailPtr, &len); if (len) { - if (*(tailName + len - 1) == ')') { + if (*(tailName+len-1) == ')') { /* * Possible array: bail out */ Tcl_DecrRefCount(tailPtr); @@ -2912,11 +2906,11 @@ /* * Get the tail: immediately after the last '::' */ for (p = tailName + len -1; p > tailName; p--) { - if ((*p == ':') && (*(p - 1) == ':')) { + if ((*p == ':') && (*(p-1) == ':')) { p++; break; } } if (!full && (p == tailName)) { Index: generic/tclCompCmdsSZ.c ================================================================== --- generic/tclCompCmdsSZ.c +++ generic/tclCompCmdsSZ.c @@ -133,13 +133,13 @@ * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *valueTokenPtr; int isAssignment, isScalar, localIndex, numWords; - DefineLineInformation; /* TIP #280 */ numWords = parsePtr->numWords; if ((numWords != 2) && (numWords != 3)) { return TCL_ERROR; } @@ -227,14 +227,14 @@ * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + DefineLineInformation; /* TIP #280 */ int i, numWords = parsePtr->numWords, numArgs; Tcl_Token *wordTokenPtr; Tcl_Obj *obj, *folded; - DefineLineInformation; /* TIP #280 */ /* Trivial case, no arg */ if (numWords<2) { PushStringLiteral(envPtr, ""); @@ -257,12 +257,12 @@ folded = obj; } } else { Tcl_DecrRefCount(obj); if (folded) { - size_t len; - const char *bytes = TclGetStringFromObj(folded, &len); + int len; + const char *bytes = Tcl_GetStringFromObj(folded, &len); PushLiteral(envPtr, bytes, len); Tcl_DecrRefCount(folded); folded = NULL; numArgs ++; @@ -275,12 +275,12 @@ } } wordTokenPtr = TokenAfter(wordTokenPtr); } if (folded) { - size_t len; - const char *bytes = TclGetStringFromObj(folded, &len); + int len; + const char *bytes = Tcl_GetStringFromObj(folded, &len); PushLiteral(envPtr, bytes, len); Tcl_DecrRefCount(folded); folded = NULL; numArgs ++; @@ -446,67 +446,10 @@ CompileWord(envPtr, tokenPtr, interp, 2); TclEmitOpcode(INST_STR_INDEX, envPtr); return TCL_OK; } -int -TclCompileStringInsertCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr; - DefineLineInformation; /* TIP #280 */ - int idx; - - if (parsePtr->numWords != 4) { - return TCL_ERROR; - } - - /* Compute and push the string in which to insert */ - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - - /* See what can be discovered about index at compile time */ - tokenPtr = TokenAfter(tokenPtr); - if (TCL_OK != TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, - TCL_INDEX_END, &idx)) { - - /* Nothing useful knowable - cease compile; let it direct eval */ - return TCL_OK; - } - - /* Compute and push the string to be inserted */ - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 3); - - if (idx == (int)TCL_INDEX_START) { - /* Prepend the insertion string */ - OP4( REVERSE, 2); - OP1( STR_CONCAT1, 2); - } else if (idx == (int)TCL_INDEX_END) { - /* Append the insertion string */ - OP1( STR_CONCAT1, 2); - } else { - /* Prefix + insertion + suffix */ - if (idx < (int)TCL_INDEX_END) { - /* See comments in compiler for [linsert]. */ - idx++; - } - OP4( OVER, 1); - OP44( STR_RANGE_IMM, 0, idx-1); - OP4( REVERSE, 3); - OP44( STR_RANGE_IMM, idx, TCL_INDEX_END); - OP1( STR_CONCAT1, 3); - } - - return TCL_OK; -} - int TclCompileStringIsCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ @@ -516,19 +459,19 @@ { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); static const char *const isClasses[] = { "alnum", "alpha", "ascii", "control", - "boolean", "dict", "digit", "double", "entier", + "boolean", "digit", "double", "entier", "false", "graph", "integer", "list", "lower", "print", "punct", "space", "true", "upper", "wideinteger", "wordchar", "xdigit", NULL }; enum isClasses { STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, - STR_IS_BOOL, STR_IS_DICT, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER, + STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER, STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, STR_IS_LIST, STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD, STR_IS_XDIGIT }; @@ -692,10 +635,11 @@ } FIXJUMP1( over); OP( LNOT); return TCL_OK; } + break; case STR_IS_DOUBLE: { int satisfied, isEmpty; if (allowEmpty) { @@ -746,35 +690,26 @@ OP( DUP); JUMP1( JUMP_FALSE, end); } switch (t) { + case STR_IS_INT: + PUSH( "1"); + OP( EQ); + break; case STR_IS_WIDE: PUSH( "2"); OP( LE); break; - case STR_IS_INT: case STR_IS_ENTIER: PUSH( "3"); OP( LE); break; } FIXJUMP1( end); return TCL_OK; - case STR_IS_DICT: - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - OP4( BEGIN_CATCH4, range); - ExceptionRangeStarts(envPtr, range); - OP( DUP); - OP( DICT_VERIFY); - ExceptionRangeEnds(envPtr, range); - ExceptionRangeTarget(envPtr, range, catchOffset); - OP( POP); - OP( PUSH_RETURN_CODE); - OP( END_CATCH); - OP( LNOT); - return TCL_OK; + case STR_IS_LIST: range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); OP4( BEGIN_CATCH4, range); ExceptionRangeStarts(envPtr, range); OP( DUP); @@ -801,12 +736,11 @@ * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - size_t length; - int i, exactMatch = 0, nocase = 0; + int i, length, exactMatch = 0, nocase = 0; const char *str; if (parsePtr->numWords < 3 || parsePtr->numWords > 4) { return TCL_ERROR; } @@ -899,13 +833,13 @@ * something with backslashes). Just push the actual character (not * byte) length. */ char buf[TCL_INTEGER_SPACE]; - size_t len = Tcl_GetCharLength(objPtr); + int len = Tcl_GetCharLength(objPtr); - len = sprintf(buf, "%" TCL_Z_MODIFIER "d", len); + len = sprintf(buf, "%d", len); PushLiteral(envPtr, buf, len); } else { SetLineInformation(1); CompileTokens(envPtr, tokenPtr, interp); TclEmitOpcode(INST_STR_LEN, envPtr); @@ -926,11 +860,10 @@ DefineLineInformation; /* TIP #280 */ Tcl_Token *mapTokenPtr, *stringTokenPtr; Tcl_Obj *mapObj, **objv; char *bytes; int len; - size_t slen; /* * We only handle the case: * * string map {foo bar} $thing @@ -962,17 +895,17 @@ * Now issue the opcodes. Note that in the case that we know that the * first word is an empty word, we don't issue the map at all. That is the * correct semantics for mapping. */ - bytes = TclGetStringFromObj(objv[0], &slen); - if (slen == 0) { + bytes = Tcl_GetStringFromObj(objv[0], &len); + if (len == 0) { CompileWord(envPtr, stringTokenPtr, interp, 2); } else { - PushLiteral(envPtr, bytes, slen); - bytes = TclGetStringFromObj(objv[1], &slen); - PushLiteral(envPtr, bytes, slen); + PushLiteral(envPtr, bytes, len); + bytes = Tcl_GetStringFromObj(objv[1], &len); + PushLiteral(envPtr, bytes, len); CompileWord(envPtr, stringTokenPtr, interp, 2); OP(STR_MAP); } Tcl_DecrRefCount(mapObj); return TCL_OK; @@ -1003,35 +936,35 @@ /* * Parse the two indices. */ - if (TclGetIndexFromToken(fromTokenPtr, TCL_INDEX_START, TCL_INDEX_NONE, + if (TclGetIndexFromToken(fromTokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER, &idx1) != TCL_OK) { goto nonConstantIndices; } /* * Token parsed as an index expression. We treat all indices before * the string the same as the start of the string. */ - if (idx1 == (int)TCL_INDEX_NONE) { + if (idx1 == TCL_INDEX_AFTER) { /* [string range $s end+1 $last] must be empty string */ OP( POP); PUSH( ""); return TCL_OK; } - if (TclGetIndexFromToken(toTokenPtr, TCL_INDEX_NONE, TCL_INDEX_END, + if (TclGetIndexFromToken(toTokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END, &idx2) != TCL_OK) { goto nonConstantIndices; } /* * Token parsed as an index expression. We treat all indices after * the string the same as the end of the string. */ - if (idx2 == (int)TCL_INDEX_NONE) { + if (idx2 == TCL_INDEX_BEFORE) { /* [string range $s $first -1] must be empty string */ OP( POP); PUSH( ""); return TCL_OK; } @@ -1061,12 +994,12 @@ * command. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { - Tcl_Token *tokenPtr, *valueTokenPtr; DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr, *valueTokenPtr; int first, last; if (parsePtr->numWords < 4 || parsePtr->numWords > 5) { return TCL_ERROR; } @@ -1077,20 +1010,20 @@ /* * Check for first index known and useful at compile time. */ tokenPtr = TokenAfter(valueTokenPtr); - if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_NONE, + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_AFTER, &first) != TCL_OK) { goto genericReplace; } /* * Check for last index known and useful at compile time. */ tokenPtr = TokenAfter(tokenPtr); - if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_NONE, TCL_INDEX_END, + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_AFTER, &last) != TCL_OK) { goto genericReplace; } /* @@ -1105,34 +1038,37 @@ * * For some compile-time values we can detect these cases, and * compile direct to bytecode implementing the no-op. */ - if ((last == (int)TCL_INDEX_NONE) /* Know (last < 0) */ - || (first == (int)TCL_INDEX_NONE) /* Know (first > end) */ + if ((last == TCL_INDEX_BEFORE) /* Know (last < 0) */ + || (first == TCL_INDEX_AFTER) /* Know (first > end) */ /* * Tricky to determine when runtime (last < first) can be * certainly known based on the encoded values. Consider the * cases... * * (first <= TCL_INDEX_END) && + * (last == TCL_INDEX_AFTER) => cannot tell REJECT * (last <= TCL_INDEX END) && (last < first) => ACCEPT * else => cannot tell REJECT */ - || ((first <= (int)TCL_INDEX_END) && (last <= (int)TCL_INDEX_END) + || ((first <= TCL_INDEX_END) && (last <= TCL_INDEX_END) && (last < first)) /* Know (last < first) */ /* - * (first == TCL_INDEX_NONE) && + * (first == TCL_INDEX_BEFORE) && + * (last == TCL_INDEX_AFTER) => (first < last) REJECT * (last <= TCL_INDEX_END) => cannot tell REJECT * else => (first < last) REJECT * * else [[first >= TCL_INDEX_START]] && + * (last == TCL_INDEX_AFTER) => cannot tell REJECT * (last <= TCL_INDEX_END) => cannot tell REJECT * else [[last >= TCL_INDEX START]] && (last < first) => ACCEPT */ - || ((first >= (int)TCL_INDEX_START) && (last >= (int)TCL_INDEX_START) + || ((first >= TCL_INDEX_START) && (last >= TCL_INDEX_START) && (last < first))) { /* Know (last < first) */ if (parsePtr->numWords == 5) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 4); OP( POP); /* Pop newString */ @@ -1157,47 +1093,47 @@ * we need, first: * * (first <= end) * * The encoded indices (first <= TCL_INDEX END) and - * (first == TCL_INDEX_NONE) always meets this condition, but + * (first == TCL_INDEX_BEFORE) always meets this condition, but * any other encoded first index has some list for which it fails. * * We also need, second: * * (last >= 0) * - * The encoded index (last >= TCL_INDEX_START) always meet this - * condition but any other encoded last index has some list for - * which it fails. + * The encoded indices (last >= TCL_INDEX_START) and + * (last == TCL_INDEX_AFTER) always meet this condition but any + * other encoded last index has some list for which it fails. * * Finally we need, third: * * (first <= last) * * Considered in combination with the constraints we already have, - * we see that we can proceed when (first == TCL_INDEX_NONE). - * These also permit simplification of the prefix|replace|suffix - * construction. The other constraints, though, interfere with - * getting a guarantee that first <= last. + * we see that we can proceed when (first == TCL_INDEX_BEFORE) + * or (last == TCL_INDEX_AFTER). These also permit simplification + * of the prefix|replace|suffix construction. The other constraints, + * though, interfere with getting a guarantee that first <= last. */ - if ((first == (int)TCL_INDEX_START) && (last >= (int)TCL_INDEX_START)) { + if ((first == TCL_INDEX_BEFORE) && (last >= TCL_INDEX_START)) { /* empty prefix */ tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 4); OP4( REVERSE, 2); - if (last == INT_MAX) { + if (last == TCL_INDEX_AFTER) { OP( POP); /* Pop original */ } else { - OP44( STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END); + OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END); OP1( STR_CONCAT1, 2); } return TCL_OK; } - if ((last == (int)TCL_INDEX_NONE) && (first <= (int)TCL_INDEX_END)) { + if ((last == TCL_INDEX_AFTER) && (first <= TCL_INDEX_END)) { OP44( STR_RANGE_IMM, 0, first-1); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 4); OP1( STR_CONCAT1, 2); return TCL_OK; @@ -1210,31 +1146,31 @@ * When we have no replacement string to worry about, we may * have more luck, because the forbidden empty string replacements * are harmless when they are replaced by another empty string. */ - if (first == (int)TCL_INDEX_START) { + if ((first == TCL_INDEX_BEFORE) || (first == TCL_INDEX_START)) { /* empty prefix - build suffix only */ - if (last == (int)TCL_INDEX_END) { + if ((last == TCL_INDEX_END) || (last == TCL_INDEX_AFTER)) { /* empty suffix too => empty result */ OP( POP); /* Pop original */ PUSH ( ""); return TCL_OK; } - OP44( STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END); + OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END); return TCL_OK; } else { - if (last == (int)TCL_INDEX_END) { + if ((last == TCL_INDEX_END) || (last == TCL_INDEX_AFTER)) { /* empty suffix - build prefix only */ OP44( STR_RANGE_IMM, 0, first-1); return TCL_OK; } OP( DUP); OP44( STR_RANGE_IMM, 0, first-1); OP4( REVERSE, 2); - OP44( STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END); + OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END); OP1( STR_CONCAT1, 2); return TCL_OK; } } @@ -1416,11 +1352,11 @@ static int UniCharIsHexDigit( int character) { - return (character >= 0) && (character < 0x80) && isxdigit(UCHAR(character)); + return (character >= 0) && (character < 0x80) && isxdigit(character); } StringClassDesc const tclStringClassTable[] = { {"alnum", Tcl_UniCharIsAlnum}, {"alpha", Tcl_UniCharIsAlpha}, @@ -1465,17 +1401,17 @@ * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + DefineLineInformation; /* TIP #280 */ int numArgs = parsePtr->numWords - 1; int numOpts = numArgs - 1; int objc, flags = TCL_SUBST_ALL; Tcl_Obj **objv/*, *toSubst = NULL*/; Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr); int code = TCL_ERROR; - DefineLineInformation; /* TIP #280 */ if (numArgs == 0) { return TCL_ERROR; } @@ -1527,11 +1463,11 @@ void TclSubstCompile( Tcl_Interp *interp, const char *bytes, - size_t numBytes, + int numBytes, int flags, int line, CompileEnv *envPtr) { Tcl_Token *endTokenPtr, *tokenPtr; @@ -1558,29 +1494,28 @@ count++; } for (endTokenPtr = tokenPtr + parse.numTokens; tokenPtr < endTokenPtr; tokenPtr = TokenAfter(tokenPtr)) { - size_t length; - int literal, catchRange, breakJump; - char buf[4] = ""; + int length, literal, catchRange, breakJump; + char buf[TCL_UTF_MAX] = ""; JumpFixup startFixup, okFixup, returnFixup, breakFixup; JumpFixup continueFixup, otherFixup, endFixup; switch (tokenPtr->type) { case TCL_TOKEN_TEXT: - literal = TclRegisterLiteral(envPtr, - tokenPtr->start, tokenPtr->size, 0); + literal = TclRegisterNewLiteral(envPtr, + tokenPtr->start, tokenPtr->size); TclEmitPush(literal, envPtr); TclAdvanceLines(&bline, tokenPtr->start, tokenPtr->start + tokenPtr->size); count++; continue; case TCL_TOKEN_BS: length = TclParseBackslash(tokenPtr->start, tokenPtr->size, NULL, buf); - literal = TclRegisterLiteral(envPtr, buf, length, 0); + literal = TclRegisterNewLiteral(envPtr, buf, length); TclEmitPush(literal, envPtr); count++; continue; case TCL_TOKEN_VARIABLE: /* @@ -1590,12 +1525,11 @@ * code. Note that the first component of TCL_TOKEN_VARIABLE is * always TCL_TOKEN_TEXT... */ if (tokenPtr->numComponents > 1) { - size_t i; - int foundCommand = 0; + int i, foundCommand = 0; for (i=2 ; i<=tokenPtr->numComponents ; i++) { if (tokenPtr[i].type == TCL_TOKEN_COMMAND) { foundCommand = 1; break; @@ -1630,12 +1564,12 @@ breakOffset = CurrentOffset(envPtr); TclEmitInstInt4(INST_JUMP4, 0, envPtr); /* Start */ if (TclFixupForwardJumpToHere(envPtr, &startFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad start jump distance %" TCL_Z_MODIFIER "d", - CurrentOffset(envPtr) - startFixup.codeOffset); + Tcl_Panic("TclCompileSubstCmd: bad start jump distance %d", + (int) (CurrentOffset(envPtr) - startFixup.codeOffset)); } } envPtr->line = bline; catchRange = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); @@ -1689,12 +1623,12 @@ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &otherFixup); TclAdjustStackDepth(1, envPtr); /* BREAK destination */ if (TclFixupForwardJumpToHere(envPtr, &breakFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad break jump distance %" TCL_Z_MODIFIER "d", - CurrentOffset(envPtr) - breakFixup.codeOffset); + Tcl_Panic("TclCompileSubstCmd: bad break jump distance %d", + (int) (CurrentOffset(envPtr) - breakFixup.codeOffset)); } OP( POP); OP( POP); breakJump = CurrentOffset(envPtr) - breakOffset; @@ -1705,26 +1639,26 @@ } TclAdjustStackDepth(2, envPtr); /* CONTINUE destination */ if (TclFixupForwardJumpToHere(envPtr, &continueFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad continue jump distance %" TCL_Z_MODIFIER "d", - CurrentOffset(envPtr) - continueFixup.codeOffset); + Tcl_Panic("TclCompileSubstCmd: bad continue jump distance %d", + (int) (CurrentOffset(envPtr) - continueFixup.codeOffset)); } OP( POP); OP( POP); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &endFixup); TclAdjustStackDepth(2, envPtr); /* RETURN + other destination */ if (TclFixupForwardJumpToHere(envPtr, &returnFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad return jump distance %" TCL_Z_MODIFIER "d", - CurrentOffset(envPtr) - returnFixup.codeOffset); + Tcl_Panic("TclCompileSubstCmd: bad return jump distance %d", + (int) (CurrentOffset(envPtr) - returnFixup.codeOffset)); } if (TclFixupForwardJumpToHere(envPtr, &otherFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad other jump distance %" TCL_Z_MODIFIER "d", - CurrentOffset(envPtr) - otherFixup.codeOffset); + Tcl_Panic("TclCompileSubstCmd: bad other jump distance %d", + (int) (CurrentOffset(envPtr) - otherFixup.codeOffset)); } /* * Pull the result to top of stack, discard options dict. */ @@ -1732,22 +1666,22 @@ OP4( REVERSE, 2); OP( POP); /* OK destination */ if (TclFixupForwardJumpToHere(envPtr, &okFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad ok jump distance %" TCL_Z_MODIFIER "d", - CurrentOffset(envPtr) - okFixup.codeOffset); + Tcl_Panic("TclCompileSubstCmd: bad ok jump distance %d", + (int) (CurrentOffset(envPtr) - okFixup.codeOffset)); } if (count > 1) { OP1(STR_CONCAT1, count); count = 1; } /* CONTINUE jump to here */ if (TclFixupForwardJumpToHere(envPtr, &endFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad end jump distance %" TCL_Z_MODIFIER "d", - CurrentOffset(envPtr) - endFixup.codeOffset); + Tcl_Panic("TclCompileSubstCmd: bad end jump distance %d", + (int) (CurrentOffset(envPtr) - endFixup.codeOffset)); } bline = envPtr->line; } while (count > 255) { @@ -1800,10 +1734,11 @@ * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; /* Pointer to tokens in command. */ int numWords; /* Number of words in command. */ Tcl_Token *valueTokenPtr; /* Token for the value to switch on. */ enum {Switch_Exact, Switch_Glob, Switch_Regexp} mode; @@ -1816,11 +1751,10 @@ int **bodyContLines; /* Array of continuation line info. */ int noCase; /* Has the -nocase flag been given? */ int foundMode = 0; /* Have we seen a mode flag yet? */ int i, valueIndex; int result = TCL_ERROR; - DefineLineInformation; /* TIP #280 */ int *clNext = envPtr->clNext; /* * Only handle the following versions: * switch ?--? word {pattern body ...} @@ -1864,12 +1798,12 @@ * them, so we punt if we *might* encounter them as that is the easiest * way of emulating the behaviour). */ for (; numWords>=3 ; tokenPtr=TokenAfter(tokenPtr),numWords--) { - register size_t size = tokenPtr[1].size; - register const char *chrs = tokenPtr[1].start; + unsigned size = tokenPtr[1].size; + const char *chrs = tokenPtr[1].start; /* * We only process literal options, and we assume that -e, -g and -n * are unique prefixes of -exact, -glob and -nocase respectively (true * at time of writing). Note that -exact and -glob may only be given @@ -1955,11 +1889,11 @@ * available at this point, this is pretty easy. */ if (numWords == 1) { const char *bytes; - size_t maxLen, numBytes; + int maxLen, numBytes; int bline; /* TIP #280: line of the pattern/action list, * and start of list for when tracking the * location. This list comes immediately after * the value we switch on. */ @@ -1972,14 +1906,14 @@ /* Allocate enough space to work in. */ maxLen = TclMaxListLength(bytes, numBytes, NULL); if (maxLen < 2) { return TCL_ERROR; } - bodyTokenArray = Tcl_Alloc(sizeof(Tcl_Token) * maxLen); - bodyToken = Tcl_Alloc(sizeof(Tcl_Token *) * maxLen); - bodyLines = Tcl_Alloc(sizeof(int) * maxLen); - bodyContLines = Tcl_Alloc(sizeof(int*) * maxLen); + bodyTokenArray = ckalloc(sizeof(Tcl_Token) * maxLen); + bodyToken = ckalloc(sizeof(Tcl_Token *) * maxLen); + bodyLines = ckalloc(sizeof(int) * maxLen); + bodyContLines = ckalloc(sizeof(int*) * maxLen); bline = mapPtr->loc[eclIndex].line[valueIndex+1]; numWords = 0; while (numBytes > 0) { @@ -2013,14 +1947,14 @@ numBytes -= (bytes - prevBytes); numWords++; } if (numWords % 2) { abort: - Tcl_Free(bodyToken); - Tcl_Free(bodyTokenArray); - Tcl_Free(bodyLines); - Tcl_Free(bodyContLines); + ckfree((char *) bodyToken); + ckfree((char *) bodyTokenArray); + ckfree((char *) bodyLines); + ckfree((char *) bodyContLines); return TCL_ERROR; } } else if (numWords % 2 || numWords == 0) { /* * Odd number of words (>1) available, or no words at all available. @@ -2034,13 +1968,13 @@ } else { /* * Multi-word definition of patterns & actions. */ - bodyToken = Tcl_Alloc(sizeof(Tcl_Token *) * numWords); - bodyLines = Tcl_Alloc(sizeof(int) * numWords); - bodyContLines = Tcl_Alloc(sizeof(int*) * numWords); + bodyToken = ckalloc(sizeof(Tcl_Token *) * numWords); + bodyLines = ckalloc(sizeof(int) * numWords); + bodyContLines = ckalloc(sizeof(int*) * numWords); bodyTokenArray = NULL; for (i=0 ; ihashTable, TCL_STRING_KEYS); infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr); finalFixups = TclStackAlloc(interp, sizeof(int) * (numBodyTokens/2)); foundDefault = 0; mustGenerate = 1; @@ -2572,11 +2506,11 @@ static ClientData DupJumptableInfo( ClientData clientData) { JumptableInfo *jtPtr = clientData; - JumptableInfo *newJtPtr = Tcl_Alloc(sizeof(JumptableInfo)); + JumptableInfo *newJtPtr = ckalloc(sizeof(JumptableInfo)); Tcl_HashEntry *hPtr, *newHPtr; Tcl_HashSearch search; int isNew; Tcl_InitHashTable(&newJtPtr->hashTable, TCL_STRING_KEYS); @@ -2594,21 +2528,21 @@ ClientData clientData) { JumptableInfo *jtPtr = clientData; Tcl_DeleteHashTable(&jtPtr->hashTable); - Tcl_Free(jtPtr); + ckfree(jtPtr); } static void PrintJumptableInfo( ClientData clientData, Tcl_Obj *appendObj, ByteCode *codePtr, unsigned int pcOffset) { - register JumptableInfo *jtPtr = clientData; + JumptableInfo *jtPtr = clientData; Tcl_HashEntry *hPtr; Tcl_HashSearch search; const char *keyPtr; int offset, i = 0; @@ -2633,11 +2567,11 @@ ClientData clientData, Tcl_Obj *dictObj, ByteCode *codePtr, unsigned int pcOffset) { - register JumptableInfo *jtPtr = clientData; + JumptableInfo *jtPtr = clientData; Tcl_Obj *mapping = Tcl_NewObj(); Tcl_HashEntry *hPtr; Tcl_HashSearch search; const char *keyPtr; int offset; @@ -2935,12 +2869,12 @@ || (objc > 2)) { TclDecrRefCount(tmpObj); goto failedToCompile; } if (objc > 0) { - size_t len; - const char *varname = TclGetStringFromObj(objv[0], &len); + int len; + const char *varname = Tcl_GetStringFromObj(objv[0], &len); resultVarIndices[i] = LocalScalar(varname, len, envPtr); if (resultVarIndices[i] < 0) { TclDecrRefCount(tmpObj); goto failedToCompile; @@ -2947,12 +2881,12 @@ } } else { resultVarIndices[i] = -1; } if (objc == 2) { - size_t len; - const char *varname = TclGetStringFromObj(objv[1], &len); + int len; + const char *varname = Tcl_GetStringFromObj(objv[1], &len); optionVarIndices[i] = LocalScalar(varname, len, envPtr); if (optionVarIndices[i] < 0) { TclDecrRefCount(tmpObj); goto failedToCompile; @@ -3066,11 +3000,10 @@ Tcl_Token **handlerTokens) { DefineLineInformation; /* TIP #280 */ int range, resultVar, optionsVar; int i, j, len, forwardsNeedFixing = 0, trapZero = 0, afterBody = 0; - size_t slen; int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource; int *noError; char buf[TCL_INTEGER_SPACE]; resultVar = AnonymousLocal(envPtr); @@ -3152,12 +3085,12 @@ LOAD( optionsVar); PUSH( "-errorcode"); OP4( DICT_GET, 1); TclAdjustStackDepth(-1, envPtr); OP44( LIST_RANGE_IMM, 0, len-1); - p = TclGetStringFromObj(matchClauses[i], &slen); - PushLiteral(envPtr, p, slen); + p = Tcl_GetStringFromObj(matchClauses[i], &len); + PushLiteral(envPtr, p, len); OP( STR_EQ); JUMP4( JUMP_FALSE, notECJumpSource); } else { notECJumpSource = -1; /* LINT */ } @@ -3280,11 +3213,10 @@ DefineLineInformation; /* TIP #280 */ int range, resultVar, optionsVar, i, j, len, forwardsNeedFixing = 0; int trapZero = 0, afterBody = 0, finalOK, finalError, noFinalError; int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource; char buf[TCL_INTEGER_SPACE]; - size_t slen; resultVar = AnonymousLocal(envPtr); optionsVar = AnonymousLocal(envPtr); if (resultVar < 0 || optionsVar < 0) { return TCL_ERROR; @@ -3364,12 +3296,12 @@ LOAD( optionsVar); PUSH( "-errorcode"); OP4( DICT_GET, 1); TclAdjustStackDepth(-1, envPtr); OP44( LIST_RANGE_IMM, 0, len-1); - p = TclGetStringFromObj(matchClauses[i], &slen); - PushLiteral(envPtr, p, slen); + p = Tcl_GetStringFromObj(matchClauses[i], &len); + PushLiteral(envPtr, p, len); OP( STR_EQ); JUMP4( JUMP_FALSE, notECJumpSource); } else { notECJumpSource = -1; /* LINT */ } @@ -3640,13 +3572,13 @@ * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr; int isScalar, localIndex, flags = 1, i, varCount = 0, haveFlags = 0; - DefineLineInformation; /* TIP #280 */ /* TODO: Consider support for compiling expanded args. */ /* * Verify that all words - except the first non-option one - are known at @@ -3690,13 +3622,13 @@ } return TCL_ERROR; } if (varCount == 0) { const char *bytes; - size_t len; + int len; - bytes = TclGetStringFromObj(leadingWord, &len); + bytes = Tcl_GetStringFromObj(leadingWord, &len); if (i == 1 && len == 11 && !strncmp("-nocomplain", bytes, 11)) { flags = 0; haveFlags++; } else if (i == (2 - flags) && len == 2 && !strncmp("--", bytes, 2)) { haveFlags++; @@ -3778,17 +3710,17 @@ * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + DefineLineInformation; /* TIP #280 */ Tcl_Token *testTokenPtr, *bodyTokenPtr; JumpFixup jumpEvalCondFixup; int testCodeOffset, bodyCodeOffset, jumpDist, range, code, boolVal; int loopMayEnd = 1; /* This is set to 0 if it is recognized as an * infinite loop. */ Tcl_Obj *boolObj; - DefineLineInformation; /* TIP #280 */ if (parsePtr->numWords != 3) { return TCL_ERROR; } @@ -4042,12 +3974,12 @@ Tcl_Interp *interp, Tcl_Parse *parsePtr, int instruction, CompileEnv *envPtr) { - Tcl_Token *tokenPtr; DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; if (parsePtr->numWords != 2) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -4084,12 +4016,12 @@ Tcl_Parse *parsePtr, const char *identity, int instruction, CompileEnv *envPtr) { - Tcl_Token *tokenPtr = parsePtr->tokenPtr; DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = parsePtr->tokenPtr; int words; /* TODO: Consider support for compiling expanded args. */ for (words=1 ; wordsnumWords ; words++) { tokenPtr = TokenAfter(tokenPtr); @@ -4169,12 +4101,12 @@ Tcl_Interp *interp, Tcl_Parse *parsePtr, int instruction, CompileEnv *envPtr) { - Tcl_Token *tokenPtr; DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords < 3) { PUSH("1"); } else if (parsePtr->numWords == 3) { @@ -4331,19 +4263,19 @@ Tcl_Parse *parsePtr, Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) { + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = parsePtr->tokenPtr; + int words; + /* * This one has its own implementation because the ** operator is the only * one with right associativity. */ - Tcl_Token *tokenPtr = parsePtr->tokenPtr; - DefineLineInformation; /* TIP #280 */ - int words; - for (words=1 ; wordsnumWords ; words++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, words); } if (parsePtr->numWords <= 2) { @@ -4497,65 +4429,21 @@ * compiled. */ CompileEnv *envPtr) { return CompileComparisonOpCmd(interp, parsePtr, INST_STR_EQ, envPtr); } - -int -TclCompileStrLtOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileComparisonOpCmd(interp, parsePtr, INST_STR_LT, envPtr); -} - -int -TclCompileStrLeOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileComparisonOpCmd(interp, parsePtr, INST_STR_LE, envPtr); -} - -int -TclCompileStrGtOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileComparisonOpCmd(interp, parsePtr, INST_STR_GT, envPtr); -} - -int -TclCompileStrGeOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileComparisonOpCmd(interp, parsePtr, INST_STR_GE, envPtr); -} int TclCompileMinusOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) { - Tcl_Token *tokenPtr = parsePtr->tokenPtr; DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = parsePtr->tokenPtr; int words; /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords == 1) { /* @@ -4596,12 +4484,12 @@ Tcl_Parse *parsePtr, Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) { - Tcl_Token *tokenPtr = parsePtr->tokenPtr; DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = parsePtr->tokenPtr; int words; /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords == 1) { /* Index: generic/tclCompExpr.c ================================================================== --- generic/tclCompExpr.c +++ generic/tclCompExpr.c @@ -20,11 +20,11 @@ * expression in the form of a tree of operators, a list of literals, a list * of function names, and an array of Tcl_Token's within a Tcl_Parse struct. * The tree is composed of OpNodes. */ -typedef struct { +typedef struct OpNode { int left; /* "Pointer" to the left operand. */ int right; /* "Pointer" to the right operand. */ union { int parent; /* "Pointer" to the parent operand. */ int prev; /* "Pointer" joining incomplete tree stack */ @@ -279,15 +279,11 @@ * special coding in ParseExpr() make sure we * never put an actual CLOSE_PAREN node in the * parse tree. The sub-expression between * parens becomes the single argument of the * matching OPEN_PAREN unary operator. */ -#define STR_LT (BINARY | 28) -#define STR_GT (BINARY | 29) -#define STR_LEQ (BINARY | 30) -#define STR_GEQ (BINARY | 31) -#define END (BINARY | 32) +#define END (BINARY | 28) /* This lexeme represents the end of the * string being parsed. Treating it as a * binary operator follows the same logic as * the CLOSE_PAREN lexeme and END pairs with * START, in the same way that CLOSE_PAREN @@ -362,18 +358,16 @@ PREC_EQUAL, /* STRNEQ */ PREC_EXPON, /* EXPON */ PREC_EQUAL, /* IN_LIST */ PREC_EQUAL, /* NOT_IN_LIST */ PREC_CLOSE_PAREN, /* CLOSE_PAREN */ - PREC_COMPARE, /* STR_LT */ - PREC_COMPARE, /* STR_GT */ - PREC_COMPARE, /* STR_LEQ */ - PREC_COMPARE, /* STR_GEQ */ PREC_END, /* END */ /* Expansion room for more binary operators */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, /* Unary operator lexemes */ PREC_UNARY, /* UNARY_PLUS */ PREC_UNARY, /* UNARY_MINUS */ PREC_UNARY, /* FUNCTION */ PREC_START, /* START */ @@ -419,18 +413,16 @@ INST_STR_NEQ, /* STRNEQ */ INST_EXPON, /* EXPON */ INST_LIST_IN, /* IN_LIST */ INST_LIST_NOT_IN, /* NOT_IN_LIST */ 0, /* CLOSE_PAREN */ - INST_STR_LT, /* STR_LT */ - INST_STR_GT, /* STR_GT */ - INST_STR_LE, /* STR_LEQ */ - INST_STR_GE, /* STR_GEQ */ 0, /* END */ /* Expansion room for more binary operators */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, /* Unary operator lexemes */ INST_UPLUS, /* UNARY_PLUS */ INST_UMINUS, /* UNARY_MINUS */ 0, /* FUNCTION */ 0, /* START */ @@ -507,20 +499,20 @@ static void CompileExprTree(Tcl_Interp *interp, OpNode *nodes, int index, Tcl_Obj *const **litObjvPtr, Tcl_Obj *const *funcObjv, Tcl_Token *tokenPtr, CompileEnv *envPtr, int optimize); -static void ConvertTreeToTokens(const char *start, size_t numBytes, +static void ConvertTreeToTokens(const char *start, int numBytes, OpNode *nodes, Tcl_Token *tokenPtr, Tcl_Parse *parsePtr); static int ExecConstantExprTree(Tcl_Interp *interp, OpNode *nodes, int index, Tcl_Obj * const **litObjvPtr); static int ParseExpr(Tcl_Interp *interp, const char *start, - size_t numBytes, OpNode **opTreePtr, + int numBytes, OpNode **opTreePtr, Tcl_Obj *litList, Tcl_Obj *funcList, Tcl_Parse *parsePtr, int parseOnly); -static size_t ParseLexeme(const char *start, size_t numBytes, +static int ParseLexeme(const char *start, int numBytes, unsigned char *lexemePtr, Tcl_Obj **literalPtr); /* *---------------------------------------------------------------------- * @@ -542,11 +534,11 @@ * message is written to interp. * * Side effects: * Memory will be allocated. If TCL_OK is returned, the caller must clean * up the returned data structures. The (OpNode *) value written to - * opTreePtr should be passed to Tcl_Free() and the parsePtr argument + * opTreePtr should be passed to ckfree() and the parsePtr argument * should be passed to Tcl_FreeParse(). The elements appended to the * litList and funcList will automatically be freed whenever the refcount * on those lists indicates they can be freed. * *---------------------------------------------------------------------- @@ -554,11 +546,11 @@ static int ParseExpr( Tcl_Interp *interp, /* Used for error reporting. */ const char *start, /* Start of source string to parse. */ - size_t numBytes, /* Number of bytes in string. */ + int numBytes, /* Number of bytes in string. */ OpNode **opTreePtr, /* Points to space where a pointer to the * allocated OpNode tree should go. */ Tcl_Obj *litList, /* List to append literals to. */ Tcl_Obj *funcList, /* List to append function names to. */ Tcl_Parse *parsePtr, /* Structure to fill with tokens representing @@ -577,11 +569,11 @@ * cost of only about 1 kibyte, and is large * enough for most expressions to parse with * no need for array growth and * reallocation. */ unsigned int nodesUsed = 0; /* Number of OpNodes filled. */ - size_t scanned = 0; /* Capture number of byte scanned by parsing + int scanned = 0; /* Capture number of byte scanned by parsing * routines. */ int lastParsed; /* Stores info about what the lexeme parsed * the previous pass through the parsing loop * was. If it was an operator, lastParsed is * the index of the OpNode for that operator. @@ -621,19 +613,19 @@ * into the string being parsed to aid in * pinpointing the location of the syntax * error in the expression. */ int insertMark = 0; /* A boolean controlling whether the "mark" * should be inserted. */ - const unsigned limit = 25; /* Portions of the error message are + const int limit = 25; /* Portions of the error message are * constructed out of substrings of the * original expression. In order to keep the * error message readable, we impose this * limit on the substring size we extract. */ TclParseInit(interp, start, numBytes, parsePtr); - nodes = Tcl_AttemptAlloc(nodesAvailable * sizeof(OpNode)); + nodes = attemptckalloc(nodesAvailable * sizeof(OpNode)); if (nodes == NULL) { TclNewLiteralStringObj(msg, "not enough memory to parse expression"); errCode = "NOMEM"; goto error; } @@ -673,11 +665,11 @@ unsigned int size = nodesUsed * 2; OpNode *newPtr = NULL; do { if (size <= UINT_MAX/sizeof(OpNode)) { - newPtr = Tcl_AttemptRealloc(nodes, size * sizeof(OpNode)); + newPtr = attemptckrealloc(nodes, size * sizeof(OpNode)); } } while ((newPtr == NULL) && ((size -= (size - nodesUsed) / 2) > nodesUsed)); if (newPtr == NULL) { TclNewLiteralStringObj(msg, @@ -708,16 +700,16 @@ int b; switch (lexeme) { case INVALID: msg = Tcl_ObjPrintf("invalid character \"%.*s\"", - (int)scanned, start); + scanned, start); errCode = "BADCHAR"; goto error; case INCOMPLETE: msg = Tcl_ObjPrintf("incomplete operator \"%.*s\"", - (int)scanned, start); + scanned, start); errCode = "PARTOP"; goto error; case BAREWORD: /* @@ -742,20 +734,20 @@ } else if (Tcl_GetBooleanFromObj(NULL,literal,&b) == TCL_OK) { lexeme = BOOLEAN; } else { Tcl_DecrRefCount(literal); msg = Tcl_ObjPrintf("invalid bareword \"%.*s%s\"", - (scanned < limit) ? (int)scanned : (int)limit - 3, start, + (scanned < limit) ? scanned : limit - 3, start, (scanned < limit) ? "" : "..."); post = Tcl_ObjPrintf( "should be \"$%.*s%s\" or \"{%.*s%s}\"", - (scanned < limit) ? (int)scanned : (int)limit - 3, + (scanned < limit) ? scanned : limit - 3, start, (scanned < limit) ? "" : "...", - (scanned < limit) ? (int)scanned : (int)limit - 3, + (scanned < limit) ? scanned : limit - 3, start, (scanned < limit) ? "" : "..."); Tcl_AppendPrintfToObj(post, " or \"%.*s%s(...)\" or ...", - (scanned < limit) ? (int)scanned : (int)limit - 3, + (scanned < limit) ? scanned : limit - 3, start, (scanned < limit) ? "" : "..."); errCode = "BAREWORD"; if (start[0] == '0') { const char *stop; TclParseNumber(NULL, NULL, NULL, start, scanned, @@ -1383,11 +1375,11 @@ /* * Free any partial parse tree we've built. */ if (nodes != NULL) { - Tcl_Free(nodes); + ckfree(nodes); } if (interp == NULL) { /* * Nowhere to report an error message, so just free it. @@ -1412,17 +1404,17 @@ */ Tcl_AppendPrintfToObj(msg, "\nin expression \"%s%.*s%.*s%s%s%.*s%s\"", ((start - limit) < parsePtr->string) ? "" : "...", ((start - limit) < parsePtr->string) - ? (int) (start - parsePtr->string) : (int)limit - 3, + ? (int) (start - parsePtr->string) : limit - 3, ((start - limit) < parsePtr->string) ? parsePtr->string : start - limit + 3, - (scanned < limit) ? (int)scanned : (int)limit - 3, start, + (scanned < limit) ? scanned : limit - 3, start, (scanned < limit) ? "" : "...", insertMark ? mark : "", (start + scanned + limit > parsePtr->end) - ? (int) (parsePtr->end - start) - (int)scanned : (int)limit-3, + ? (int) (parsePtr->end - start) - scanned : limit-3, start + scanned, (start + scanned + limit > parsePtr->end) ? "" : "..."); /* * Next, append any postscript message. @@ -1440,11 +1432,11 @@ */ numBytes = parsePtr->end - parsePtr->string; Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (parsing expression \"%.*s%s\")", - (numBytes < limit) ? (int)numBytes : (int)limit - 3, + (numBytes < limit) ? numBytes : limit - 3, parsePtr->string, (numBytes < limit) ? "" : "...")); if (errCode) { Tcl_SetErrorCode(interp, "TCL", "PARSE", "EXPR", errCode, subErrCode, NULL); } @@ -1477,11 +1469,11 @@ */ static void ConvertTreeToTokens( const char *start, - size_t numBytes, + int numBytes, OpNode *nodes, Tcl_Token *tokenPtr, Tcl_Parse *parsePtr) { int subExprTokenIdx = 0; @@ -1566,11 +1558,11 @@ */ TclGrowParseTokenArray(parsePtr, toCopy); subExprTokenPtr = parsePtr->tokenPtr + parsePtr->numTokens; memcpy(subExprTokenPtr, tokenPtr, - toCopy * sizeof(Tcl_Token)); + (size_t) toCopy * sizeof(Tcl_Token)); subExprTokenPtr->type = TCL_TOKEN_SUB_EXPR; parsePtr->numTokens += toCopy; } else { /* * Multiple element word. Create a TCL_TOKEN_SUB_EXPR token to @@ -1583,11 +1575,11 @@ *subExprTokenPtr = *tokenPtr; subExprTokenPtr->type = TCL_TOKEN_SUB_EXPR; subExprTokenPtr->numComponents++; subExprTokenPtr++; memcpy(subExprTokenPtr, tokenPtr, - toCopy * sizeof(Tcl_Token)); + (size_t) toCopy * sizeof(Tcl_Token)); parsePtr->numTokens += toCopy + 1; } scanned = tokenPtr->start + tokenPtr->size - start; start += scanned; @@ -1765,11 +1757,11 @@ subExprTokenPtr = parsePtr->tokenPtr + subExprTokenIdx; subExprTokenPtr->size = start - subExprTokenPtr->start; /* * All the Tcl_Tokens allocated and filled belong to - * this subexpression. The first token is the leading + * this subexpresion. The first token is the leading * TCL_TOKEN_SUB_EXPR token, and all the rest (one fewer) * are its components. */ subExprTokenPtr->numComponents = @@ -1825,11 +1817,11 @@ int Tcl_ParseExpr( Tcl_Interp *interp, /* Used for error reporting. */ const char *start, /* Start of source string to parse. */ - size_t numBytes, /* Number of bytes in string. If -1, the + int numBytes, /* Number of bytes in string. If < 0, the * string consists of all bytes up to the * first null character. */ Tcl_Parse *parsePtr) /* Structure to fill with information about * the parsed expression; any previous * information in the structure is ignored. */ @@ -1839,11 +1831,11 @@ Tcl_Obj *litList = Tcl_NewObj(); /* List to hold the literals. */ Tcl_Obj *funcList = Tcl_NewObj(); /* List to hold the functon names. */ Tcl_Parse *exprParsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse)); /* Holds the Tcl_Tokens of substitutions. */ - if (numBytes == TCL_AUTO_LENGTH) { + if (numBytes < 0) { numBytes = (start ? strlen(start) : 0); } code = ParseExpr(interp, start, numBytes, &opTree, litList, funcList, exprParsePtr, 1 /* parseOnly */); @@ -1859,11 +1851,11 @@ parsePtr->errorType = exprParsePtr->errorType; } Tcl_FreeParse(exprParsePtr); TclStackFree(interp, exprParsePtr); - Tcl_Free(opTree); + ckfree(opTree); return code; } /* *---------------------------------------------------------------------- @@ -1880,20 +1872,21 @@ * Code identifying lexeme parsed is writen to *lexemePtr. * *---------------------------------------------------------------------- */ -static size_t +static int ParseLexeme( const char *start, /* Start of lexeme to parse. */ - size_t numBytes, /* Number of bytes in string. */ + int numBytes, /* Number of bytes in string. */ unsigned char *lexemePtr, /* Write code of parsed lexeme to this * storage. */ Tcl_Obj **literalPtr) /* Write corresponding literal value to this storage, if non-NULL. */ { const char *end; + int scanned; Tcl_UniChar ch = 0; Tcl_Obj *literal = NULL; unsigned char byte; if (numBytes == 0) { @@ -2006,39 +1999,10 @@ case 'i': *lexemePtr = NOT_IN_LIST; return 2; } } - break; - - case 'l': - if ((numBytes > 1) - && ((numBytes == 2) || start[2] & 0x80 || !isalpha(UCHAR(start[2])))) { - switch (start[1]) { - case 't': - *lexemePtr = STR_LT; - return 2; - case 'e': - *lexemePtr = STR_LEQ; - return 2; - } - } - break; - - case 'g': - if ((numBytes > 1) - && ((numBytes == 2) || start[2] & 0x80 || !isalpha(UCHAR(start[2])))) { - switch (start[1]) { - case 't': - *lexemePtr = STR_GT; - return 2; - case 'e': - *lexemePtr = STR_GEQ; - return 2; - } - } - break; } literal = Tcl_NewObj(); if (TclParseNumber(NULL, literal, NULL, start, numBytes, &end, TCL_PARSE_NO_WHITESPACE) == TCL_OK) { @@ -2061,11 +2025,11 @@ * (alpha, digit, underscore). Is this a number followed by * bareword syntax error? Or should we join into one bareword? * Example: Inf + luence + () becomes a valid function call. * [Bug 3401704] */ - if (TclHasIntRep(literal, &tclDoubleType)) { + if (literal->typePtr == &tclDoubleType) { const char *p = start; while (p < end) { if (!TclIsBareword(*p++)) { /* @@ -2097,15 +2061,14 @@ * Might be inspired by reserved identifier rules in C, which of course * have no direct relevance here. */ if (!TclIsBareword(*start) || *start == '_') { - size_t scanned; if (Tcl_UtfCharComplete(start, numBytes)) { scanned = TclUtfToUniChar(start, &ch); } else { - char utfBytes[4]; + char utfBytes[TCL_UTF_MAX]; memcpy(utfBytes, start, numBytes); utfBytes[numBytes] = '\0'; scanned = TclUtfToUniChar(utfBytes, &ch); } @@ -2147,11 +2110,11 @@ void TclCompileExpr( Tcl_Interp *interp, /* Used for error reporting. */ const char *script, /* The source script to compile. */ - size_t numBytes, /* Number of bytes in script. */ + int numBytes, /* Number of bytes in script. */ CompileEnv *envPtr, /* Holds resulting instructions. */ int optimize) /* 0 for one-off expressions. */ { OpNode *opTree = NULL; /* Will point to the tree of operators */ Tcl_Obj *litList = Tcl_NewObj(); /* List to hold the literals */ @@ -2185,11 +2148,11 @@ Tcl_FreeParse(parsePtr); TclStackFree(interp, parsePtr); Tcl_DecrRefCount(funcList); Tcl_DecrRefCount(litList); - Tcl_Free(opTree); + ckfree(opTree); } /* *---------------------------------------------------------------------- * @@ -2216,10 +2179,11 @@ Tcl_Obj *const **litObjvPtr) { CompileEnv *envPtr; ByteCode *byteCodePtr; int code; + Tcl_Obj *byteCodeObj = Tcl_NewObj(); NRE_callback *rootPtr = TOP_CB(interp); /* * Note we are compiling an expression with literal arguments. This means * there can be no [info frame] calls when we execute the resulting @@ -2229,16 +2193,18 @@ envPtr = TclStackAlloc(interp, sizeof(CompileEnv)); TclInitCompileEnv(interp, envPtr, NULL, 0, NULL, 0); CompileExprTree(interp, nodes, index, litObjvPtr, NULL, NULL, envPtr, 0 /* optimize */); TclEmitOpcode(INST_DONE, envPtr); - byteCodePtr = TclInitByteCode(envPtr); + Tcl_IncrRefCount(byteCodeObj); + TclInitByteCodeObj(byteCodeObj, envPtr); TclFreeCompileEnv(envPtr); TclStackFree(interp, envPtr); + byteCodePtr = byteCodeObj->internalRep.twoPtrValue.ptr1; TclNRExecuteByteCode(interp, byteCodePtr); code = TclNRRunCallbacks(interp, TCL_OK, rootPtr); - TclReleaseByteCode(byteCodePtr); + Tcl_DecrRefCount(byteCodeObj); return code; } /* *---------------------------------------------------------------------- @@ -2295,20 +2261,20 @@ switch (nodePtr->lexeme) { case FUNCTION: { Tcl_DString cmdName; const char *p; - size_t length; + int length; Tcl_DStringInit(&cmdName); TclDStringAppendLiteral(&cmdName, "tcl::mathfunc::"); p = TclGetStringFromObj(*funcObjv, &length); funcObjv++; Tcl_DStringAppend(&cmdName, p, length); - TclEmitPush(TclRegisterLiteral(envPtr, + TclEmitPush(TclRegisterNewCmdLiteral(envPtr, Tcl_DStringValue(&cmdName), - Tcl_DStringLength(&cmdName), LITERAL_CMD_NAME), envPtr); + Tcl_DStringLength(&cmdName)), envPtr); Tcl_DStringFree(&cmdName); /* * Start a count of the number of words in this function * command invocation. In case there's already a count in @@ -2411,22 +2377,22 @@ case OR: CLANG_ASSERT(jumpPtr); pc1 = CurrentOffset(envPtr); TclEmitInstInt1((nodePtr->lexeme == AND) ? INST_JUMP_FALSE1 : INST_JUMP_TRUE1, 0, envPtr); - TclEmitPush(TclRegisterLiteral(envPtr, - (nodePtr->lexeme == AND) ? "1" : "0", 1, 0), envPtr); + TclEmitPush(TclRegisterNewLiteral(envPtr, + (nodePtr->lexeme == AND) ? "1" : "0", 1), envPtr); pc2 = CurrentOffset(envPtr); TclEmitInstInt1(INST_JUMP1, 0, envPtr); TclAdjustStackDepth(-1, envPtr); TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc1, envPtr->codeStart + pc1 + 1); if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) { pc2 += 3; } - TclEmitPush(TclRegisterLiteral(envPtr, - (nodePtr->lexeme == AND) ? "0" : "1", 1, 0), envPtr); + TclEmitPush(TclRegisterNewLiteral(envPtr, + (nodePtr->lexeme == AND) ? "0" : "1", 1), envPtr); TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc2, envPtr->codeStart + pc2 + 1); convert = 0; freePtr = jumpPtr; jumpPtr = jumpPtr->next; @@ -2454,14 +2420,14 @@ case OT_LITERAL: { Tcl_Obj *const *litObjv = *litObjvPtr; Tcl_Obj *literal = *litObjv; if (optimize) { - size_t length; + int length; const char *bytes = TclGetStringFromObj(literal, &length); - int index = TclRegisterLiteral(envPtr, bytes, length, 0); - Tcl_Obj *objPtr = TclFetchLiteral(envPtr, index); + int idx = TclRegisterNewLiteral(envPtr, bytes, length); + Tcl_Obj *objPtr = TclFetchLiteral(envPtr, idx); if ((objPtr->typePtr == NULL) && (literal->typePtr != NULL)) { /* * Would like to do this: * @@ -2477,11 +2443,11 @@ objPtr->typePtr = literal->typePtr; objPtr->internalRep = literal->internalRep; literal->typePtr = NULL; } - TclEmitPush(index, envPtr); + TclEmitPush(idx, envPtr); } else { /* * When optimize==0, we know the expression is a one-off and * there's nothing to be gained from sharing literals when * they won't live long, and the copies we have already have @@ -2503,26 +2469,24 @@ if (optimize && nodes[next].constant) { Tcl_InterpState save = Tcl_SaveInterpState(interp, TCL_OK); if (ExecConstantExprTree(interp, nodes, next, litObjvPtr) == TCL_OK) { - int index; + int idx; Tcl_Obj *objPtr = Tcl_GetObjResult(interp); /* * Don't generate a string rep, but if we have one * already, then use it to share via the literal table. */ - if (TclHasStringRep(objPtr)) { + if (objPtr->bytes) { Tcl_Obj *tableValue; - size_t numBytes; - const char *bytes - = TclGetStringFromObj(objPtr, &numBytes); - index = TclRegisterLiteral(envPtr, bytes, numBytes, 0); - tableValue = TclFetchLiteral(envPtr, index); + idx = TclRegisterNewLiteral(envPtr, objPtr->bytes, + objPtr->length); + tableValue = TclFetchLiteral(envPtr, idx); if ((tableValue->typePtr == NULL) && (objPtr->typePtr != NULL)) { /* * Same intrep surgery as for OT_LITERAL. */ @@ -2530,13 +2494,13 @@ tableValue->typePtr = objPtr->typePtr; tableValue->internalRep = objPtr->internalRep; objPtr->typePtr = NULL; } } else { - index = TclAddLiteralObj(envPtr, objPtr, NULL); + idx = TclAddLiteralObj(envPtr, objPtr, NULL); } - TclEmitPush(index, envPtr); + TclEmitPush(idx, envPtr); } else { TclCompileSyntaxError(interp, envPtr); } Tcl_RestoreInterpState(interp, save); convert = 0; @@ -2603,11 +2567,11 @@ /* *---------------------------------------------------------------------- * * TclSortingOpCmd -- * Implements the commands: - * <, <=, >, >=, ==, eq, lt, le, gt, ge + * <, <=, >, >=, ==, eq * in the ::tcl::mathop namespace. These commands are defined for * arbitrary number of arguments by computing the AND of the base * operator applied to all neighbor argument pairs. * * Results: @@ -2723,11 +2687,11 @@ OpNode nodes[2]; int decrMe = 0; Tcl_Obj *const *litObjPtrPtr = litObjv; if (lexeme == EXPON) { - litObjv[1] = Tcl_NewIntObj(occdPtr->i.identity); + TclNewIntObj(litObjv[1], occdPtr->i.identity); Tcl_IncrRefCount(litObjv[1]); decrMe = 1; litObjv[0] = objv[1]; nodes[0].lexeme = START; nodes[0].mark = MARK_RIGHT; @@ -2739,11 +2703,11 @@ nodes[1].p.parent = 0; } else { if (lexeme == DIVIDE) { litObjv[0] = Tcl_NewDoubleObj(1.0); } else { - litObjv[0] = Tcl_NewIntObj(occdPtr->i.identity); + TclNewIntObj(litObjv[0], occdPtr->i.identity); } Tcl_IncrRefCount(litObjv[0]); litObjv[1] = objv[1]; nodes[0].lexeme = START; nodes[0].mark = MARK_RIGHT; Index: generic/tclCompile.c ================================================================== --- generic/tclCompile.c +++ generic/tclCompile.c @@ -127,10 +127,14 @@ {"jumpFalse1", 2, -1, 1, {OPERAND_OFFSET1}}, /* Jump relative to (pc + op1) if stktop expr object is false */ {"jumpFalse4", 5, -1, 1, {OPERAND_OFFSET4}}, /* Jump relative to (pc + op4) if stktop expr object is false */ + {"lor", 1, -1, 0, {OPERAND_NONE}}, + /* Logical or: push (stknext || stktop) */ + {"land", 1, -1, 0, {OPERAND_NONE}}, + /* Logical and: push (stknext && stktop) */ {"bitor", 1, -1, 0, {OPERAND_NONE}}, /* Bitwise or: push (stknext | stktop) */ {"bitxor", 1, -1, 0, {OPERAND_NONE}}, /* Bitwise xor push (stknext ^ stktop) */ {"bitand", 1, -1, 0, {OPERAND_NONE}}, @@ -167,18 +171,29 @@ /* Unary minus: push -stktop */ {"bitnot", 1, 0, 0, {OPERAND_NONE}}, /* Bitwise not: push ~stktop */ {"not", 1, 0, 0, {OPERAND_NONE}}, /* Logical not: push !stktop */ + {"callBuiltinFunc1", 2, 1, 1, {OPERAND_UINT1}}, + /* Call builtin math function with index op1; any args are on stk */ + {"callFunc1", 2, INT_MIN, 1, {OPERAND_UINT1}}, + /* Call non-builtin func objv[0]; = */ {"tryCvtToNumeric", 1, 0, 0, {OPERAND_NONE}}, /* Try converting stktop to first int then double if possible. */ {"break", 1, 0, 0, {OPERAND_NONE}}, /* Abort closest enclosing loop; if none, return TCL_BREAK code. */ {"continue", 1, 0, 0, {OPERAND_NONE}}, /* Skip to next iteration of closest enclosing loop; if none, return * TCL_CONTINUE code. */ + + {"foreach_start4", 5, 0, 1, {OPERAND_AUX4}}, + /* Initialize execution of a foreach loop. Operand is aux data index + * of the ForeachInfo structure for the foreach command. */ + {"foreach_step4", 5, +1, 1, {OPERAND_AUX4}}, + /* "Step" or begin next iteration of foreach loop. Push 0 if to + * terminate loop, else push 1. */ {"beginCatch4", 5, 0, 1, {OPERAND_UINT4}}, /* Record start of catch with the operand's exception index. Push the * current stack depth onto a special catch stack. */ {"endCatch", 1, 0, 0, {OPERAND_NONE}}, @@ -323,10 +338,13 @@ * managed correctly. * Stack: ... dict => ... value key doneBool */ {"dictNext", 5, +3, 1, {OPERAND_LVT4}}, /* Get the next iteration from the iterator in op4's local scalar. * Stack: ... => ... value key doneBool */ + {"dictDone", 5, 0, 1, {OPERAND_LVT4}}, + /* Terminate the iterator in op4's local scalar. Use unsetScalar + * instead (with 0 for flags). */ {"dictUpdateStart", 9, 0, 2, {OPERAND_LVT4, OPERAND_AUX4}}, /* Create the variables (described in the aux data referred to by the * second immediate argument) to mirror the state of the dictionary in * the variable referred to by the first immediate argument. The list * of keys (top of the stack, not popped) must be the same length as @@ -639,35 +657,17 @@ {"clockRead", 2, +1, 1, {OPERAND_UINT1}}, /* Read clock out to the stack. Operand is which clock to read * 0=clicks, 1=microseconds, 2=milliseconds, 3=seconds. * Stack: ... => ... time */ - {"dictGetDef", 5, INT_MIN, 1, {OPERAND_UINT4}}, - /* The top word is the default, the next op4 words (min 1) are a key - * path into the dictionary just below the keys on the stack, and all - * those values are replaced by the value read out of that key-path - * (like [dict get]) except if there is no such key, when instead the - * default is pushed instead. - * Stack: ... dict key1 ... keyN default => ... value */ - - {"strlt", 1, -1, 0, {OPERAND_NONE}}, - /* String Less: push (stknext < stktop) */ - {"strgt", 1, -1, 0, {OPERAND_NONE}}, - /* String Greater: push (stknext > stktop) */ - {"strle", 1, -1, 0, {OPERAND_NONE}}, - /* String Less or equal: push (stknext <= stktop) */ - {"strge", 1, -1, 0, {OPERAND_NONE}}, - /* String Greater or equal: push (stknext >= stktop) */ - {NULL, 0, 0, 0, {OPERAND_NONE}} }; /* * Prototypes for procedures defined later in this file: */ -static void CleanupByteCode(ByteCode *codePtr); static ByteCode * CompileSubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); static void DupByteCodeInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static unsigned char * EncodeCmdLocMap(CompileEnv *envPtr, @@ -679,11 +679,10 @@ static void FreeByteCodeInternalRep(Tcl_Obj *objPtr); static void FreeSubstCodeInternalRep(Tcl_Obj *objPtr); static int GetCmdLocEncodingSize(CompileEnv *envPtr); static int IsCompactibleCompileEnv(Tcl_Interp *interp, CompileEnv *envPtr); -static void PreventCycle(Tcl_Obj *objPtr, CompileEnv *envPtr); #ifdef TCL_COMPILE_STATS static void RecordByteCodeStats(ByteCode *codePtr); #endif /* TCL_COMPILE_STATS */ static int SetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); @@ -692,11 +691,11 @@ /* * TIP #280: Helper for building the per-word line information of all compiled * commands. */ static void EnterCmdWordData(ExtCmdLoc *eclPtr, int srcOffset, - Tcl_Token *tokenPtr, const char *cmd, + Tcl_Token *tokenPtr, const char *cmd, int len, int numWords, int line, int *clNext, int **lines, CompileEnv *envPtr); static void ReleaseCmdWordData(ExtCmdLoc *eclPtr); /* @@ -722,18 +721,17 @@ FreeSubstCodeInternalRep, /* freeIntRepProc */ DupByteCodeInternalRep, /* dupIntRepProc - shared with bytecode */ NULL, /* updateStringProc */ NULL, /* setFromAnyProc */ }; -#define SubstFlags(objPtr) (objPtr)->internalRep.twoPtrValue.ptr2 /* * Helper macros. */ #define TclIncrUInt4AtPtr(ptr, delta) \ - TclStoreInt4AtPtr(TclGetUInt4AtPtr(ptr)+(delta), (ptr)) + TclStoreInt4AtPtr(TclGetUInt4AtPtr(ptr)+(delta), (ptr)); /* *---------------------------------------------------------------------- * * TclSetByteCodeFromAny -- @@ -768,12 +766,11 @@ ClientData clientData) /* Hook procedure private data. */ { Interp *iPtr = (Interp *) interp; CompileEnv compEnv; /* Compilation environment structure allocated * in frame. */ - size_t length; - int result = TCL_OK; + int length, result = TCL_OK; const char *stringPtr; Proc *procPtr = iPtr->compiledProcPtr; ContLineLoc *clLocPtr; #ifdef TCL_COMPILE_DEBUG @@ -828,11 +825,11 @@ * Test if the generated code is free of most hazards; if so, recompile * but with generation of INST_START_CMD disabled. This produces somewhat * faster code in some cases, and more compact code in more. */ - if (Tcl_GetMaster(interp) == NULL && + if (Tcl_GetParent(interp) == NULL && !Tcl_LimitTypeEnabled(interp, TCL_LIMIT_COMMANDS|TCL_LIMIT_TIME) && IsCompactibleCompileEnv(interp, &compEnv)) { TclFreeCompileEnv(&compEnv); iPtr->compiledProcPtr = procPtr; TclInitCompileEnv(interp, &compEnv, stringPtr, length, @@ -850,12 +847,12 @@ /* * Apply some peephole optimizations that can cross specific/generic * instruction generator boundaries. */ - if (iPtr->optimizer) { - (iPtr->optimizer)(&compEnv); + if (iPtr->extra.optimizer) { + (iPtr->extra.optimizer)(&compEnv); } /* * Invoke the compilation hook procedure if one exists. */ @@ -872,11 +869,11 @@ #ifdef TCL_COMPILE_DEBUG TclVerifyLocalLiteralTable(&compEnv); #endif /*TCL_COMPILE_DEBUG*/ if (result == TCL_OK) { - (void) TclInitByteCodeObj(objPtr, &tclByteCodeType, &compEnv); + TclInitByteCodeObj(objPtr, &compEnv); #ifdef TCL_COMPILE_DEBUG if (tclTraceCompile >= 2) { TclPrintByteCodeObj(interp, objPtr); fflush(stdout); } @@ -969,24 +966,24 @@ *---------------------------------------------------------------------- */ static void FreeByteCodeInternalRep( - register Tcl_Obj *objPtr) /* Object whose internal rep to free. */ -{ - ByteCode *codePtr; - - ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr); - assert(codePtr != NULL); - - TclReleaseByteCode(codePtr); + Tcl_Obj *objPtr) /* Object whose internal rep to free. */ +{ + ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; + + objPtr->typePtr = NULL; + if (codePtr->refCount-- <= 1) { + TclCleanupByteCode(codePtr); + } } /* *---------------------------------------------------------------------- * - * TclReleaseByteCode -- + * TclCleanupByteCode -- * * This procedure does all the real work of freeing up a bytecode * object's ByteCode structure. It's called only when the structure's * reference count becomes zero. * @@ -999,38 +996,19 @@ * *---------------------------------------------------------------------- */ void -TclPreserveByteCode( - register ByteCode *codePtr) -{ - codePtr->refCount++; -} - -void -TclReleaseByteCode( - register ByteCode *codePtr) -{ - if (codePtr->refCount-- > 1) { - return; - } - - /* Just dropped to refcount==0. Clean up. */ - CleanupByteCode(codePtr); -} - -static void -CleanupByteCode( - register ByteCode *codePtr) /* Points to the ByteCode to free. */ +TclCleanupByteCode( + ByteCode *codePtr) /* Points to the ByteCode to free. */ { Tcl_Interp *interp = (Tcl_Interp *) *codePtr->interpHandle; Interp *iPtr = (Interp *) interp; int numLitObjects = codePtr->numLitObjects; int numAuxDataItems = codePtr->numAuxDataItems; - register Tcl_Obj **objArrayPtr, *objPtr; - register const AuxData *auxDataPtr; + Tcl_Obj **objArrayPtr, *objPtr; + const AuxData *auxDataPtr; int i; #ifdef TCL_COMPILE_STATS if (interp != NULL) { ByteCodeStats *statsPtr; @@ -1132,16 +1110,16 @@ ReleaseCmdWordData(Tcl_GetHashValue(hePtr)); Tcl_DeleteHashEntry(hePtr); } } - if (codePtr->localCachePtr && (codePtr->localCachePtr->refCount-- <= 1)) { + if (codePtr->localCachePtr && (--codePtr->localCachePtr->refCount == 0)) { TclFreeLocalCache(interp, codePtr->localCachePtr); } TclHandleRelease(codePtr->interpHandle); - Tcl_Free(codePtr); + ckfree(codePtr); } /* * --------------------------------------------------------------------- * @@ -1285,10 +1263,12 @@ * Compile a Tcl value into ByteCode implementing its substitution, as * governed by flags. * * Results: * A (ByteCode *) is returned pointing to the resulting ByteCode. + * The caller must manage its refCount and arrange for a call to + * TclCleanupByteCode() when the last reference disappears. * * Side effects: * The Tcl_ObjType of objPtr is changed to the "substcode" type, and the * ByteCode and governing flags value are kept in the internal rep for * faster operations the next time CompileSubstObj is called on the same @@ -1304,41 +1284,42 @@ int flags) { Interp *iPtr = (Interp *) interp; ByteCode *codePtr = NULL; - ByteCodeGetIntRep(objPtr, &substCodeType, codePtr); - - if (codePtr != NULL) { + if (objPtr->typePtr == &substCodeType) { Namespace *nsPtr = iPtr->varFramePtr->nsPtr; - if (flags != PTR2INT(SubstFlags(objPtr)) + codePtr = objPtr->internalRep.twoPtrValue.ptr1; + if (flags != PTR2INT(objPtr->internalRep.twoPtrValue.ptr2) || ((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != nsPtr) || (codePtr->nsEpoch != nsPtr->resolverEpoch) || (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) { - Tcl_StoreIntRep(objPtr, &substCodeType, NULL); - codePtr = NULL; + FreeSubstCodeInternalRep(objPtr); } } - if (codePtr == NULL) { + if (objPtr->typePtr != &substCodeType) { CompileEnv compEnv; - size_t numBytes; - const char *bytes = TclGetStringFromObj(objPtr, &numBytes); + int numBytes; + const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes); /* TODO: Check for more TIP 280 */ TclInitCompileEnv(interp, &compEnv, bytes, numBytes, NULL, 0); TclSubstCompile(interp, bytes, numBytes, flags, 1, &compEnv); TclEmitOpcode(INST_DONE, &compEnv); - codePtr = TclInitByteCodeObj(objPtr, &substCodeType, &compEnv); + TclInitByteCodeObj(objPtr, &compEnv); + objPtr->typePtr = &substCodeType; TclFreeCompileEnv(&compEnv); - SubstFlags(objPtr) = INT2PTR(flags); + codePtr = objPtr->internalRep.twoPtrValue.ptr1; + objPtr->internalRep.twoPtrValue.ptr1 = codePtr; + objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(flags); if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; } #ifdef TCL_COMPILE_DEBUG @@ -1371,18 +1352,18 @@ *---------------------------------------------------------------------- */ static void FreeSubstCodeInternalRep( - register Tcl_Obj *objPtr) /* Object whose internal rep to free. */ -{ - register ByteCode *codePtr; - - ByteCodeGetIntRep(objPtr, &substCodeType, codePtr); - assert(codePtr != NULL); - - TclReleaseByteCode(codePtr); + Tcl_Obj *objPtr) /* Object whose internal rep to free. */ +{ + ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; + + objPtr->typePtr = NULL; + if (codePtr->refCount-- <= 1) { + TclCleanupByteCode(codePtr); + } } static void ReleaseCmdWordData( ExtCmdLoc *eclPtr) @@ -1391,18 +1372,18 @@ if (eclPtr->type == TCL_LOCATION_SOURCE) { Tcl_DecrRefCount(eclPtr->path); } for (i=0 ; inuloc ; i++) { - Tcl_Free(eclPtr->loc[i].line); + ckfree((char *) eclPtr->loc[i].line); } if (eclPtr->loc != NULL) { - Tcl_Free(eclPtr->loc); + ckfree((char *) eclPtr->loc); } - Tcl_Free(eclPtr); + ckfree((char *) eclPtr); } /* *---------------------------------------------------------------------- * @@ -1422,21 +1403,21 @@ void TclInitCompileEnv( Tcl_Interp *interp, /* The interpreter for which a CompileEnv * structure is initialized. */ - register CompileEnv *envPtr,/* Points to the CompileEnv structure to + CompileEnv *envPtr,/* Points to the CompileEnv structure to * initialize. */ const char *stringPtr, /* The source string to be compiled. */ - size_t numBytes, /* Number of bytes in source string. */ + int numBytes, /* Number of bytes in source string. */ const CmdFrame *invoker, /* Location context invoking the bcc */ int word) /* Index of the word in that context getting * compiled */ { Interp *iPtr = (Interp *) interp; - assert(tclInstructionTable[LAST_INST_OPCODE].name == NULL); + assert(tclInstructionTable[LAST_INST_OPCODE+1].name == NULL); envPtr->iPtr = iPtr; envPtr->source = stringPtr; envPtr->numSrcBytes = numBytes; envPtr->procPtr = iPtr->compiledProcPtr; @@ -1477,11 +1458,11 @@ * * See also tclBasic.c, TclEvalObjEx, for the equivalent code in the * non-compiling evaluator */ - envPtr->extCmdMapPtr = Tcl_Alloc(sizeof(ExtCmdLoc)); + envPtr->extCmdMapPtr = ckalloc(sizeof(ExtCmdLoc)); envPtr->extCmdMapPtr->loc = NULL; envPtr->extCmdMapPtr->nloc = 0; envPtr->extCmdMapPtr->nuloc = 0; envPtr->extCmdMapPtr->path = NULL; @@ -1629,14 +1610,14 @@ *---------------------------------------------------------------------- */ void TclFreeCompileEnv( - register CompileEnv *envPtr)/* Points to the CompileEnv structure. */ + CompileEnv *envPtr)/* Points to the CompileEnv structure. */ { if (envPtr->localLitTable.buckets != envPtr->localLitTable.staticBuckets){ - Tcl_Free(envPtr->localLitTable.buckets); + ckfree(envPtr->localLitTable.buckets); envPtr->localLitTable.buckets = envPtr->localLitTable.staticBuckets; } if (envPtr->iPtr) { /* * We never converted to Bytecode, so free the things we would @@ -1662,24 +1643,24 @@ } auxDataPtr++; } } if (envPtr->mallocedCodeArray) { - Tcl_Free(envPtr->codeStart); + ckfree(envPtr->codeStart); } if (envPtr->mallocedLiteralArray) { - Tcl_Free(envPtr->literalArrayPtr); + ckfree(envPtr->literalArrayPtr); } if (envPtr->mallocedExceptArray) { - Tcl_Free(envPtr->exceptArrayPtr); - Tcl_Free(envPtr->exceptAuxArrayPtr); + ckfree(envPtr->exceptArrayPtr); + ckfree(envPtr->exceptAuxArrayPtr); } if (envPtr->mallocedCmdMap) { - Tcl_Free(envPtr->cmdMapPtr); + ckfree(envPtr->cmdMapPtr); } if (envPtr->mallocedAuxDataArray) { - Tcl_Free(envPtr->auxDataArrayPtr); + ckfree(envPtr->auxDataArrayPtr); } if (envPtr->extCmdMapPtr) { ReleaseCmdWordData(envPtr->extCmdMapPtr); envPtr->extCmdMapPtr = NULL; } @@ -1740,12 +1721,12 @@ } break; case TCL_TOKEN_BS: if (tempPtr != NULL) { - char utfBuf[4] = ""; - size_t length = TclParseBackslash(tokenPtr->start, + char utfBuf[TCL_UTF_MAX] = ""; + int length = TclParseBackslash(tokenPtr->start, tokenPtr->size, NULL, utfBuf); Tcl_AppendToObj(tempPtr, utfBuf, length); } break; @@ -1784,11 +1765,11 @@ */ static int ExpandRequested( Tcl_Token *tokenPtr, - size_t numWords) + int numWords) { /* Determine whether any words of the command require expansion */ while (numWords--) { if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { return 1; @@ -1802,22 +1783,22 @@ CompileCmdLiteral( Tcl_Interp *interp, Tcl_Obj *cmdObj, CompileEnv *envPtr) { + int numBytes; const char *bytes; Command *cmdPtr; int cmdLitIdx, extraLiteralFlags = LITERAL_CMD_NAME; - size_t length; cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) { extraLiteralFlags |= LITERAL_UNSHARED; } - bytes = TclGetStringFromObj(cmdObj, &length); - cmdLitIdx = TclRegisterLiteral(envPtr, bytes, length, extraLiteralFlags); + bytes = Tcl_GetStringFromObj(cmdObj, &numBytes); + cmdLitIdx = TclRegisterLiteral(envPtr, (char *)bytes, numBytes, extraLiteralFlags); if (cmdPtr) { TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr); } TclEmitPush(cmdLitIdx, envPtr); @@ -1826,16 +1807,15 @@ void TclCompileInvocation( Tcl_Interp *interp, Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, - size_t numWords, + int numWords, CompileEnv *envPtr) { - size_t wordIdx = 0; - int depth = TclGetStackDepth(envPtr); DefineLineInformation; + int wordIdx = 0, depth = TclGetStackDepth(envPtr); if (cmdObj) { CompileCmdLiteral(interp, cmdObj, envPtr); wordIdx = 1; tokenPtr = TokenAfter(tokenPtr); @@ -1849,12 +1829,12 @@ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { CompileTokens(envPtr, tokenPtr, interp); continue; } - objIdx = TclRegisterLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size, 0); + objIdx = TclRegisterNewLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size); if (envPtr->clNext) { TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), tokenPtr[1].start - envPtr->source, envPtr->clNext); } TclEmitPush(objIdx, envPtr); @@ -1874,12 +1854,12 @@ Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, int numWords, CompileEnv *envPtr) { - int wordIdx = 0; DefineLineInformation; + int wordIdx = 0; int depth = TclGetStackDepth(envPtr); StartExpanding(envPtr); if (cmdObj) { CompileCmdLiteral(interp, cmdObj, envPtr); @@ -1899,12 +1879,12 @@ envPtr->currStackDepth, envPtr); } continue; } - objIdx = TclRegisterLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size, 0); + objIdx = TclRegisterNewLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size); if (envPtr->clNext) { TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), tokenPtr[1].start - envPtr->source, envPtr->clNext); } TclEmitPush(objIdx, envPtr); @@ -1933,12 +1913,12 @@ Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, CompileEnv *envPtr) { - int unwind = 0, incrOffset = -1; DefineLineInformation; + int unwind = 0, incrOffset = -1; int depth = TclGetStackDepth(envPtr); /* * Emit of the INST_START_CMD instruction is controlled by the value of * envPtr->atCmdStart: @@ -1995,11 +1975,11 @@ * Throw out any line information generated by the failed compile attempt. */ while (mapPtr->nuloc - 1 > eclIndex) { mapPtr->nuloc--; - Tcl_Free(mapPtr->loc[mapPtr->nuloc].line); + ckfree(mapPtr->loc[mapPtr->nuloc].line); mapPtr->loc[mapPtr->nuloc].line = NULL; } /* * Reset the index of next command. Toss out any from failed nested @@ -2045,11 +2025,11 @@ * non-literal words, stored in 'wlines'. */ EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source, parsePtr->tokenPtr, parsePtr->commandStart, - parsePtr->numWords, cmdLine, + parsePtr->commandSize, parsePtr->numWords, cmdLine, clNext, &wlines, envPtr); wlineat = eclPtr->nuloc - 1; envPtr->line = eclPtr->loc[wlineat].line[0]; envPtr->clNext = eclPtr->loc[wlineat].next[0]; @@ -2113,12 +2093,12 @@ * form now */ envPtr->line = cmdLine; envPtr->clNext = clNext; - Tcl_Free(eclPtr->loc[wlineat].line); - Tcl_Free(eclPtr->loc[wlineat].next); + ckfree(eclPtr->loc[wlineat].line); + ckfree(eclPtr->loc[wlineat].next); eclPtr->loc[wlineat].line = wlines; eclPtr->loc[wlineat].next = NULL; TclCheckStackDepth(depth, envPtr); return cmdIdx; @@ -2128,11 +2108,11 @@ TclCompileScript( Tcl_Interp *interp, /* Used for error and status reporting. Also * serves as context for finding and compiling * commands. May not be NULL. */ const char *script, /* The source script to compile. */ - size_t numBytes, /* Number of bytes in script. If -1, the + int numBytes, /* Number of bytes in script. If < 0, the * script consists of all bytes up to the * first null character. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { int lastCmdIdx = -1; /* Index into envPtr->cmdMapPtr of the last @@ -2139,29 +2119,52 @@ * command this routine compiles into bytecode. * Initial value of -1 indicates this routine * has not yet generated any bytecode. */ const char *p = script; /* Where we are in our compile. */ int depth = TclGetStackDepth(envPtr); + Interp *iPtr = (Interp *) interp; if (envPtr->iPtr == NULL) { Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv"); } + /* + * Check depth to avoid overflow of the C execution stack by too many + * nested calls of TclCompileScript (considering interp recursionlimit). + * Factor 5/4 (1.25) is used to avoid too mistaken limit recognition + * during "mixed" evaluation and compilation process (nested eval+compile) + * and is good enough for default recursionlimit (1000). + */ + if (iPtr->numLevels / 5 > iPtr->maxNestingDepth / 4) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "too many nested compilations (infinite loop?)", -1)); + Tcl_SetErrorCode(interp, "TCL", "LIMIT", "STACK", NULL); + TclCompileSyntaxError(interp, envPtr); + return; + } /* Each iteration compiles one command from the script. */ - while (numBytes + 1 > 1) { - Tcl_Parse parse; + if (numBytes > 0) { + /* + * Don't use system stack (size of Tcl_Parse is ca. 400 bytes), so + * many nested compilations (body enclosed in body) can cause abnormal + * program termination with a stack overflow exception, bug [fec0c17d39]. + */ + Tcl_Parse *parsePtr = ckalloc(sizeof(Tcl_Parse)); + + do { const char *next; - if (TCL_OK != Tcl_ParseCommand(interp, p, numBytes, 0, &parse)) { + if (TCL_OK != Tcl_ParseCommand(interp, p, numBytes, 0, parsePtr)) { /* - * Compile bytecodes to report the parse error at runtime. + * Compile bytecodes to report the parsePtr error at runtime. */ - Tcl_LogCommandInfo(interp, script, parse.commandStart, - parse.term + 1 - parse.commandStart); + Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, + parsePtr->term + 1 - parsePtr->commandStart); TclCompileSyntaxError(interp, envPtr); + ckfree(parsePtr); return; } #ifdef TCL_COMPILE_DEBUG /* @@ -2168,13 +2171,13 @@ * If tracing, print a line for each top level command compiled. * TODO: Suppress when numWords == 0 ? */ if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) { - int commandLength = parse.term - parse.commandStart; + int commandLength = parsePtr->term - parsePtr->commandStart; fprintf(stdout, " Compiling: "); - TclPrintSource(stdout, parse.commandStart, + TclPrintSource(stdout, parsePtr->commandStart, TclMin(commandLength, 55)); fprintf(stdout, "\n"); } #endif @@ -2181,52 +2184,63 @@ /* * TIP #280: Count newlines before the command start. * (See test info-30.33). */ - TclAdvanceLines(&envPtr->line, p, parse.commandStart); + TclAdvanceLines(&envPtr->line, p, parsePtr->commandStart); TclAdvanceContinuations(&envPtr->line, &envPtr->clNext, - parse.commandStart - envPtr->source); + parsePtr->commandStart - envPtr->source); /* * Advance parser to the next command in the script. */ - next = parse.commandStart + parse.commandSize; + next = parsePtr->commandStart + parsePtr->commandSize; numBytes -= next - p; p = next; - if (parse.numWords == 0) { + if (parsePtr->numWords == 0) { /* * The "command" parsed has no words. In this case we can skip * the rest of the loop body. With no words, clearly * CompileCommandTokens() has nothing to do. Since the parser * aggressively sucks up leading comment and white space, - * including newlines, parse.commandStart must be pointing at + * including newlines, parsePtr->commandStart must be pointing at * either the end of script, or a command-terminating semi-colon. * In either case, the TclAdvance*() calls have nothing to do. * Finally, when no words are parsed, no tokens have been - * allocated at parse.tokenPtr so there's also nothing for + * allocated at parsePtr->tokenPtr so there's also nothing for * Tcl_FreeParse() to do. * * The advantage of this shortcut is that CompileCommandTokens() - * can be written with an assumption that parse.numWords > 0, with + * can be written with an assumption that parsePtr->numWords > 0, with * the implication the CCT() always generates bytecode. */ continue; } - lastCmdIdx = CompileCommandTokens(interp, &parse, envPtr); + /* + * Avoid stack exhaustion by too many nested calls of TclCompileScript + * (considering interp recursionlimit). + */ + iPtr->numLevels++; + + lastCmdIdx = CompileCommandTokens(interp, parsePtr, envPtr); + + iPtr->numLevels--; /* * TIP #280: Track lines in the just compiled command. */ - TclAdvanceLines(&envPtr->line, parse.commandStart, p); + TclAdvanceLines(&envPtr->line, parsePtr->commandStart, p); TclAdvanceContinuations(&envPtr->line, &envPtr->clNext, p - envPtr->source); - Tcl_FreeParse(&parse); + Tcl_FreeParse(parsePtr); + } while (numBytes > 0); + + ckfree(parsePtr); } if (lastCmdIdx == -1) { /* * Compiling the script yielded no bytecode. The script must be all @@ -2281,12 +2295,12 @@ Tcl_Interp *interp, Tcl_Token *tokenPtr, CompileEnv *envPtr) { const char *p, *name = tokenPtr[1].start; - size_t i, nameBytes = tokenPtr[1].size; - int localVar, localVarName = 1; + int nameBytes = tokenPtr[1].size; + int i, localVar, localVarName = 1; /* * Determine how the variable name should be handled: if it contains any * namespace qualifiers it is not a local variable (localVarName=-1); if * it looks like an array element and the token has a single component, it @@ -2355,13 +2369,12 @@ * Must be at least 1. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { Tcl_DString textBuffer; /* Holds concatenated chars from adjacent * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */ - char buffer[4] = ""; - int i, numObjsToConcat, adjust; - size_t length; + char buffer[TCL_UTF_MAX] = ""; + int i, numObjsToConcat, length, adjust; unsigned char *entryCodeNext = envPtr->codeNext; #define NUM_STATIC_POS 20 int isLiteral, maxNumCL, numCL; int *clPosition = NULL; int depth = TclGetStackDepth(envPtr); @@ -2392,11 +2405,11 @@ } } if (isLiteral) { maxNumCL = NUM_STATIC_POS; - clPosition = Tcl_Alloc(maxNumCL * sizeof(int)); + clPosition = ckalloc(maxNumCL * sizeof(int)); } adjust = 0; Tcl_DStringInit(&textBuffer); numObjsToConcat = 0; @@ -2433,11 +2446,11 @@ if (isLiteral) { int clPos = Tcl_DStringLength(&textBuffer); if (numCL >= maxNumCL) { maxNumCL *= 2; - clPosition = Tcl_Realloc(clPosition, + clPosition = ckrealloc(clPosition, maxNumCL * sizeof(int)); } clPosition[numCL] = clPos; numCL ++; } @@ -2491,11 +2504,11 @@ tokenPtr += tokenPtr->numComponents; break; default: Tcl_Panic("Unexpected token type in TclCompileTokens: %d; %.*s", - tokenPtr->type, (int)tokenPtr->size, tokenPtr->start); + tokenPtr->type, tokenPtr->size, tokenPtr->start); } } /* * Push any accumulated characters appearing at the end. @@ -2538,11 +2551,11 @@ * Release the temp table we used to collect the locations of continuation * lines, if any. */ if (maxNumCL) { - Tcl_Free(clPosition); + ckfree(clPosition); } TclCheckStackDepth(depth+1, envPtr); } /* @@ -2729,51 +2742,22 @@ * structure. * *---------------------------------------------------------------------- */ -static void -PreventCycle( - Tcl_Obj *objPtr, - CompileEnv *envPtr) -{ - int i; - - for (i = 0; i < envPtr->literalArrayNext; i++) { - if (objPtr == TclFetchLiteral(envPtr, i)) { - /* - * Prevent circular reference where the bytecode intrep of - * a value contains a literal which is that same value. - * If this is allowed to happen, refcount decrements may not - * reach zero, and memory may leak. Bugs 467523, 3357771 - * - * NOTE: [Bugs 3392070, 3389764] We make a copy based completely - * on the string value, and do not call Tcl_DuplicateObj() so we - * can be sure we do not have any lingering cycles hiding in - * the intrep. - */ - size_t numBytes; - const char *bytes = TclGetStringFromObj(objPtr, &numBytes); - Tcl_Obj *copyPtr = Tcl_NewStringObj(bytes, numBytes); - - Tcl_IncrRefCount(copyPtr); - TclReleaseLiteral((Tcl_Interp *)envPtr->iPtr, objPtr); - - envPtr->literalArrayPtr[i].objPtr = copyPtr; - } - } -} - -ByteCode * -TclInitByteCode( - register CompileEnv *envPtr)/* Points to the CompileEnv structure from +void +TclInitByteCodeObj( + Tcl_Obj *objPtr, /* Points object that should be initialized, + * and whose string rep contains the source + * code. */ + CompileEnv *envPtr)/* Points to the CompileEnv structure from * which to create a ByteCode structure. */ { - register ByteCode *codePtr; + ByteCode *codePtr; size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes; size_t auxDataArrayBytes, structureSize; - register unsigned char *p; + unsigned char *p; #ifdef TCL_COMPILE_DEBUG unsigned char *nextPtr; #endif int numLitObjects = envPtr->literalArrayNext; Namespace *namespacePtr; @@ -2807,18 +2791,17 @@ namespacePtr = envPtr->iPtr->varFramePtr->nsPtr; } else { namespacePtr = envPtr->iPtr->globalNsPtr; } - p = Tcl_Alloc(structureSize); + p = ckalloc(structureSize); codePtr = (ByteCode *) p; codePtr->interpHandle = TclHandlePreserve(iPtr->handle); codePtr->compileEpoch = iPtr->compileEpoch; codePtr->nsPtr = namespacePtr; codePtr->nsEpoch = namespacePtr->resolverEpoch; - codePtr->refCount = 0; - TclPreserveByteCode(codePtr); + codePtr->refCount = 1; if (namespacePtr->compiledVarResProc || iPtr->resolverPtr) { codePtr->flags = TCL_BYTECODE_RESOLVE_VARS; } else { codePtr->flags = 0; } @@ -2840,11 +2823,33 @@ memcpy(p, envPtr->codeStart, codeBytes); p += TCL_ALIGN(codeBytes); /* align object array */ codePtr->objArrayPtr = (Tcl_Obj **) p; for (i = 0; i < numLitObjects; i++) { - codePtr->objArrayPtr[i] = TclFetchLiteral(envPtr, i); + Tcl_Obj *fetched = TclFetchLiteral(envPtr, i); + + if (objPtr == fetched) { + /* + * Prevent circular reference where the bytecode intrep of + * a value contains a literal which is that same value. + * If this is allowed to happen, refcount decrements may not + * reach zero, and memory may leak. Bugs 467523, 3357771 + * + * NOTE: [Bugs 3392070, 3389764] We make a copy based completely + * on the string value, and do not call Tcl_DuplicateObj() so we + * can be sure we do not have any lingering cycles hiding in + * the intrep. + */ + int numBytes; + const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes); + + codePtr->objArrayPtr[i] = Tcl_NewStringObj(bytes, numBytes); + Tcl_IncrRefCount(codePtr->objArrayPtr[i]); + TclReleaseLiteral((Tcl_Interp *)iPtr, objPtr); + } else { + codePtr->objArrayPtr[i] = fetched; + } } p += TCL_ALIGN(objArrayBytes); /* align exception range array */ if (exceptArrayBytes > 0) { codePtr->exceptArrayPtr = (ExceptionRange *) p; @@ -2882,10 +2887,19 @@ Tcl_GetTime(&codePtr->createTime); RecordByteCodeStats(codePtr); #endif /* TCL_COMPILE_STATS */ + /* + * Free the old internal rep then convert the object to a bytecode object + * by making its internal rep point to the just compiled ByteCode. + */ + + TclFreeIntRep(objPtr); + objPtr->internalRep.twoPtrValue.ptr1 = codePtr; + objPtr->typePtr = &tclByteCodeType; + /* * TIP #280. Associate the extended per-word line information with the * byte code object (internal rep), for use with the bc compiler. */ @@ -2895,35 +2909,10 @@ /* We've used up the CompileEnv. Mark as uninitialized. */ envPtr->iPtr = NULL; codePtr->localCachePtr = NULL; - return codePtr; -} - -ByteCode * -TclInitByteCodeObj( - Tcl_Obj *objPtr, /* Points object that should be initialized, - * and whose string rep contains the source - * code. */ - const Tcl_ObjType *typePtr, - register CompileEnv *envPtr)/* Points to the CompileEnv structure from - * which to create a ByteCode structure. */ -{ - ByteCode *codePtr; - - PreventCycle(objPtr, envPtr); - - codePtr = TclInitByteCode(envPtr); - - /* - * Free the old internal rep then convert the object to a bytecode object - * by making its internal rep point to the just compiled ByteCode. - */ - - ByteCodeSetIntRep(objPtr, typePtr, codePtr); - return codePtr; } /* *---------------------------------------------------------------------- * @@ -2949,21 +2938,21 @@ *---------------------------------------------------------------------- */ int TclFindCompiledLocal( - register 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. */ - size_t nameBytes, /* Number of bytes in the name. */ + int nameBytes, /* Number of bytes in the name. */ int create, /* If 1, allocate a local frame entry for the * variable if it is new. */ CompileEnv *envPtr) /* Points to the current compile environment*/ { - register CompiledLocal *localPtr; + CompiledLocal *localPtr; int localVar = -1; - register int i; + int i; Proc *procPtr; /* * If not creating a temporary, does a local variable of the specified * name already exist? @@ -2978,20 +2967,20 @@ */ LocalCache *cachePtr = envPtr->iPtr->varFramePtr->localCachePtr; const char *localName; Tcl_Obj **varNamePtr; - size_t len; + int len; if (!cachePtr || !name) { return -1; } varNamePtr = &cachePtr->varName0; for (i=0; i < cachePtr->numVars; varNamePtr++, i++) { if (*varNamePtr) { - localName = TclGetStringFromObj(*varNamePtr, &len); + localName = Tcl_GetStringFromObj(*varNamePtr, &len); if ((len == nameBytes) && !strncmp(name, localName, len)) { return i; } } } @@ -3005,11 +2994,11 @@ for (i = 0; i < localCt; i++) { if (!TclIsVarTemporary(localPtr)) { char *localName = localPtr->name; if ((nameBytes == localPtr->nameLength) && - (strncmp(name,localName,nameBytes) == 0)) { + (strncmp(name, localName, nameBytes) == 0)) { return i; } } localPtr = localPtr->nextPtr; } @@ -3019,11 +3008,11 @@ * Create a new variable if appropriate. */ if (create || (name == NULL)) { localVar = procPtr->numCompiledLocals; - localPtr = Tcl_Alloc(offsetof(CompiledLocal, name) + nameBytes + 1); + localPtr = ckalloc(TclOffset(CompiledLocal, name) + nameBytes + 1); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } else { procPtr->lastLocalPtr->nextPtr = localPtr; procPtr->lastLocalPtr = localPtr; @@ -3083,18 +3072,18 @@ size_t currBytes = envPtr->codeNext - envPtr->codeStart; size_t newBytes = 2 * (envPtr->codeEnd - envPtr->codeStart); if (envPtr->mallocedCodeArray) { - envPtr->codeStart = Tcl_Realloc(envPtr->codeStart, newBytes); + envPtr->codeStart = ckrealloc(envPtr->codeStart, newBytes); } else { /* - * envPtr->codeStart isn't a Tcl_Alloc'd pointer, so we must code a - * Tcl_Realloc equivalent for ourselves. + * envPtr->codeStart isn't a ckalloc'd pointer, so we must code a + * ckrealloc equivalent for ourselves. */ - unsigned char *newPtr = Tcl_Alloc(newBytes); + unsigned char *newPtr = ckalloc(newBytes); memcpy(newPtr, envPtr->codeStart, currBytes); envPtr->codeStart = newPtr; envPtr->mallocedCodeArray = 1; } @@ -3150,18 +3139,18 @@ size_t newElems = 2 * currElems; size_t currBytes = currElems * sizeof(CmdLocation); size_t newBytes = newElems * sizeof(CmdLocation); if (envPtr->mallocedCmdMap) { - envPtr->cmdMapPtr = Tcl_Realloc(envPtr->cmdMapPtr, newBytes); + envPtr->cmdMapPtr = ckrealloc(envPtr->cmdMapPtr, newBytes); } else { /* - * envPtr->cmdMapPtr isn't a Tcl_Alloc'd pointer, so we must code a - * Tcl_Realloc equivalent for ourselves. + * envPtr->cmdMapPtr isn't a ckalloc'd pointer, so we must code a + * ckrealloc equivalent for ourselves. */ - CmdLocation *newPtr = Tcl_Alloc(newBytes); + CmdLocation *newPtr = ckalloc(newBytes); memcpy(newPtr, envPtr->cmdMapPtr, currBytes); envPtr->cmdMapPtr = newPtr; envPtr->mallocedCmdMap = 1; } @@ -3254,10 +3243,11 @@ * which to enter command location * information. */ int srcOffset, /* Offset of first char of the command. */ Tcl_Token *tokenPtr, const char *cmd, + int len, int numWords, int line, int *clNext, int **wlines, CompileEnv *envPtr) @@ -3275,20 +3265,20 @@ size_t currElems = eclPtr->nloc; size_t newElems = (currElems ? 2*currElems : 1); size_t newBytes = newElems * sizeof(ECL); - eclPtr->loc = Tcl_Realloc(eclPtr->loc, newBytes); + eclPtr->loc = ckrealloc(eclPtr->loc, newBytes); eclPtr->nloc = newElems; } ePtr = &eclPtr->loc[eclPtr->nuloc]; ePtr->srcOffset = srcOffset; - ePtr->line = Tcl_Alloc(numWords * sizeof(int)); - ePtr->next = Tcl_Alloc(numWords * sizeof(int *)); + ePtr->line = ckalloc(numWords * sizeof(int)); + ePtr->next = ckalloc(numWords * sizeof(int *)); ePtr->nline = numWords; - wwlines = Tcl_Alloc(numWords * sizeof(int)); + wwlines = ckalloc(numWords * sizeof(int)); last = cmd; wordLine = line; wordNext = clNext; for (wordIdx=0 ; wordIdxexceptArrayNext; if (index >= envPtr->exceptArrayEnd) { /* * Expand the ExceptionRange array. The currently allocated entries @@ -3353,21 +3343,21 @@ size_t newBytes = newElems * sizeof(ExceptionRange); size_t newBytes2 = newElems * sizeof(ExceptionAux); if (envPtr->mallocedExceptArray) { envPtr->exceptArrayPtr = - Tcl_Realloc(envPtr->exceptArrayPtr, newBytes); + ckrealloc(envPtr->exceptArrayPtr, newBytes); envPtr->exceptAuxArrayPtr = - Tcl_Realloc(envPtr->exceptAuxArrayPtr, newBytes2); + ckrealloc(envPtr->exceptAuxArrayPtr, newBytes2); } else { /* - * envPtr->exceptArrayPtr isn't a Tcl_Alloc'd pointer, so we must - * code a Tcl_Realloc equivalent for ourselves. + * envPtr->exceptArrayPtr isn't a ckalloc'd pointer, so we must + * code a ckrealloc equivalent for ourselves. */ - ExceptionRange *newPtr = Tcl_Alloc(newBytes); - ExceptionAux *newPtr2 = Tcl_Alloc(newBytes2); + ExceptionRange *newPtr = ckalloc(newBytes); + ExceptionAux *newPtr2 = ckalloc(newBytes2); memcpy(newPtr, envPtr->exceptArrayPtr, currBytes); memcpy(newPtr2, envPtr->exceptAuxArrayPtr, currBytes2); envPtr->exceptArrayPtr = newPtr; envPtr->exceptAuxArrayPtr = newPtr2; @@ -3466,15 +3456,15 @@ if (++auxPtr->numBreakTargets > auxPtr->allocBreakTargets) { auxPtr->allocBreakTargets *= 2; auxPtr->allocBreakTargets += 2; if (auxPtr->breakTargets) { - auxPtr->breakTargets = Tcl_Realloc(auxPtr->breakTargets, + auxPtr->breakTargets = ckrealloc(auxPtr->breakTargets, sizeof(int) * auxPtr->allocBreakTargets); } else { auxPtr->breakTargets = - Tcl_Alloc(sizeof(int) * auxPtr->allocBreakTargets); + ckalloc(sizeof(int) * auxPtr->allocBreakTargets); } } auxPtr->breakTargets[auxPtr->numBreakTargets - 1] = CurrentOffset(envPtr); TclEmitInstInt4(INST_JUMP4, 0, envPtr); } @@ -3492,15 +3482,15 @@ if (++auxPtr->numContinueTargets > auxPtr->allocContinueTargets) { auxPtr->allocContinueTargets *= 2; auxPtr->allocContinueTargets += 2; if (auxPtr->continueTargets) { - auxPtr->continueTargets = Tcl_Realloc(auxPtr->continueTargets, + auxPtr->continueTargets = ckrealloc(auxPtr->continueTargets, sizeof(int) * auxPtr->allocContinueTargets); } else { auxPtr->continueTargets = - Tcl_Alloc(sizeof(int) * auxPtr->allocContinueTargets); + ckalloc(sizeof(int) * auxPtr->allocContinueTargets); } } auxPtr->continueTargets[auxPtr->numContinueTargets - 1] = CurrentOffset(envPtr); TclEmitInstInt4(INST_JUMP4, 0, envPtr); @@ -3658,16 +3648,16 @@ /* * Drop the arrays we were holding the only reference to. */ if (auxPtr->breakTargets) { - Tcl_Free(auxPtr->breakTargets); + ckfree(auxPtr->breakTargets); auxPtr->breakTargets = NULL; auxPtr->numBreakTargets = 0; } if (auxPtr->continueTargets) { - Tcl_Free(auxPtr->continueTargets); + ckfree(auxPtr->continueTargets); auxPtr->continueTargets = NULL; auxPtr->numContinueTargets = 0; } } @@ -3698,15 +3688,15 @@ TclCreateAuxData( ClientData 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 */ - register 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. */ { int index; /* Index for the new AuxData structure. */ - register AuxData *auxDataPtr; + AuxData *auxDataPtr; /* Points to the new AuxData structure */ index = envPtr->auxDataArrayNext; if (index >= envPtr->auxDataArrayEnd) { /* @@ -3719,18 +3709,18 @@ int newElems = 2*envPtr->auxDataArrayEnd; size_t newBytes = newElems * sizeof(AuxData); if (envPtr->mallocedAuxDataArray) { envPtr->auxDataArrayPtr = - Tcl_Realloc(envPtr->auxDataArrayPtr, newBytes); + ckrealloc(envPtr->auxDataArrayPtr, newBytes); } else { /* - * envPtr->auxDataArrayPtr isn't a Tcl_Alloc'd pointer, so we must - * code a Tcl_Realloc equivalent for ourselves. + * envPtr->auxDataArrayPtr isn't a ckalloc'd pointer, so we must + * code a ckrealloc equivalent for ourselves. */ - AuxData *newPtr = Tcl_Alloc(newBytes); + AuxData *newPtr = ckalloc(newBytes); memcpy(newPtr, envPtr->auxDataArrayPtr, currBytes); envPtr->auxDataArrayPtr = newPtr; envPtr->mallocedAuxDataArray = 1; } @@ -3761,11 +3751,11 @@ *---------------------------------------------------------------------- */ void TclInitJumpFixupArray( - register JumpFixupArray *fixupArrayPtr) + JumpFixupArray *fixupArrayPtr) /* Points to the JumpFixupArray structure to * initialize. */ { fixupArrayPtr->fixup = fixupArrayPtr->staticFixupSpace; fixupArrayPtr->next = 0; @@ -3793,11 +3783,11 @@ *---------------------------------------------------------------------- */ void TclExpandJumpFixupArray( - register JumpFixupArray *fixupArrayPtr) + JumpFixupArray *fixupArrayPtr) /* Points to the JumpFixupArray structure to * enlarge. */ { /* * The currently allocated jump fixup entries are stored from fixup[0] up @@ -3808,18 +3798,18 @@ size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup); int newElems = 2*(fixupArrayPtr->end + 1); size_t newBytes = newElems * sizeof(JumpFixup); if (fixupArrayPtr->mallocedArray) { - fixupArrayPtr->fixup = Tcl_Realloc(fixupArrayPtr->fixup, newBytes); + fixupArrayPtr->fixup = ckrealloc(fixupArrayPtr->fixup, newBytes); } else { /* - * fixupArrayPtr->fixup isn't a Tcl_Alloc'd pointer, so we must code a - * Tcl_Realloc equivalent for ourselves. + * fixupArrayPtr->fixup isn't a ckalloc'd pointer, so we must code a + * ckrealloc equivalent for ourselves. */ - JumpFixup *newPtr = Tcl_Alloc(newBytes); + JumpFixup *newPtr = ckalloc(newBytes); memcpy(newPtr, fixupArrayPtr->fixup, currBytes); fixupArrayPtr->fixup = newPtr; fixupArrayPtr->mallocedArray = 1; } @@ -3842,16 +3832,16 @@ *---------------------------------------------------------------------- */ void TclFreeJumpFixupArray( - register JumpFixupArray *fixupArrayPtr) + JumpFixupArray *fixupArrayPtr) /* Points to the JumpFixupArray structure to * free. */ { if (fixupArrayPtr->mallocedArray) { - Tcl_Free(fixupArrayPtr->fixup); + ckfree(fixupArrayPtr->fixup); } } /* *---------------------------------------------------------------------- @@ -3947,11 +3937,11 @@ int distThreshold) /* Maximum distance before the two byte jump * is grown to five bytes. */ { unsigned char *jumpPc, *p; int firstCmd, lastCmd, firstRange, lastRange, k; - size_t numBytes; + unsigned numBytes; if (jumpDist <= distThreshold) { jumpPc = envPtr->codeStart + jumpFixupPtr->codeOffset; switch (jumpFixupPtr->jumpType) { case TCL_UNCONDITIONAL_JUMP: @@ -4289,11 +4279,11 @@ GetCmdLocEncodingSize( CompileEnv *envPtr) /* Points to compilation environment structure * containing the CmdLocation structure to * encode. */ { - register CmdLocation *mapPtr = envPtr->cmdMapPtr; + CmdLocation *mapPtr = envPtr->cmdMapPtr; int numCmds = envPtr->numCommands; int codeDelta, codeLen, srcDelta, srcLen; int codeDeltaNext, codeLengthNext, srcDeltaNext, srcLengthNext; /* The offsets in their respective byte * sequences where the next encoded offset or @@ -4373,15 +4363,15 @@ * command location information. */ unsigned char *startPtr) /* Points to the first byte in codePtr's * memory block where the location information * is to be stored. */ { - register CmdLocation *mapPtr = envPtr->cmdMapPtr; + CmdLocation *mapPtr = envPtr->cmdMapPtr; int numCmds = envPtr->numCommands; - register unsigned char *p = startPtr; + unsigned char *p = startPtr; int codeDelta, codeLen, srcDelta, srcLen, prevOffset; - register int i; + int i; /* * Encode the code offset for each command as a sequence of deltas. */ @@ -4491,11 +4481,11 @@ RecordByteCodeStats( ByteCode *codePtr) /* Points to ByteCode structure with info * to add to accumulated statistics. */ { Interp *iPtr = (Interp *) *codePtr->interpHandle; - register ByteCodeStats *statsPtr; + ByteCodeStats *statsPtr; if (iPtr == NULL) { /* Avoid segfaulting in case we're called in a deleted interp */ return; } Index: generic/tclCompile.h ================================================================== --- generic/tclCompile.h +++ generic/tclCompile.h @@ -85,11 +85,11 @@ CATCH_EXCEPTION_RANGE /* Exception's range is controlled by a catch * command. Errors in the range cause a jump * to a catch PC offset. */ } ExceptionRangeType; -typedef struct { +typedef struct ExceptionRange { ExceptionRangeType type; /* The kind of ExceptionRange. */ int nestingLevel; /* Static depth of the exception range. Used * to find the most deeply-nested range * surrounding a PC at runtime. */ int codeOffset; /* Offset of the first instruction byte of the @@ -160,11 +160,11 @@ * source's starting offset and length. Note that the code offset increases * monotonically: that is, the table is sorted in code offset order. The * source offset is not monotonic. */ -typedef struct { +typedef struct CmdLocation { int codeOffset; /* Offset of first byte of command code. */ int numCodeBytes; /* Number of bytes for command's code. */ int srcOffset; /* Offset of first char of the command. */ int numSrcBytes; /* Number of command source chars. */ } CmdLocation; @@ -178,21 +178,21 @@ * through the 'lineBCPtr' HashTable in Interp, keyed by the address of BC. * Also recorded is information coming from the context, i.e. type of the * frame and associated information, like the path of a sourced file. */ -typedef struct { - size_t srcOffset; /* Command location to find the entry. */ +typedef struct ECL { + int srcOffset; /* Command location to find the entry. */ int nline; /* Number of words in the command */ int *line; /* Line information for all words in the * command. */ int **next; /* Transient information used by the compiler * for tracking of hidden continuation * lines. */ } ECL; -typedef struct { +typedef struct ExtCmdLoc { int type; /* Context type. */ int start; /* Starting line for compiled script. Needed * for the extended recompile check in * tclCompileObj. */ Tcl_Obj *path; /* Path of the sourced file the command is @@ -215,13 +215,13 @@ * to duplicate or free this auxiliary data when the containing ByteCode * objects are duplicated and freed. Pointers to these procedures are kept in * the AuxData structure. */ -typedef void *(AuxDataDupProc) (void *clientData); -typedef void (AuxDataFreeProc) (void *clientData); -typedef void (AuxDataPrintProc)(void *clientData, +typedef ClientData (AuxDataDupProc) (ClientData clientData); +typedef void (AuxDataFreeProc) (ClientData clientData); +typedef void (AuxDataPrintProc)(ClientData clientData, Tcl_Obj *appendObj, struct ByteCode *codePtr, unsigned int pcOffset); /* * We define a separate AuxDataType struct to hold type-related information @@ -264,11 +264,11 @@ */ typedef struct AuxData { const AuxDataType *type; /* Pointer to the AuxData type associated with * this ClientData. */ - void *clientData; /* The compilation data itself. */ + ClientData clientData; /* The compilation data itself. */ } AuxData; /* * Structure defining the compilation environment. After compilation, fields * describing bytecode instructions are copied out into the more compact @@ -415,23 +415,23 @@ TclHandle interpHandle; /* Handle for interpreter containing the * compiled code. Commands and their compile * procs are specific to an interpreter so the * code emitted will depend on the * interpreter. */ - size_t compileEpoch; /* Value of iPtr->compileEpoch when this + int compileEpoch; /* Value of iPtr->compileEpoch when this * ByteCode was compiled. Used to invalidate * code when, e.g., commands with compile * procs are redefined. */ Namespace *nsPtr; /* Namespace context in which this code was * compiled. If the code is executed if a * different namespace, it must be * recompiled. */ - size_t nsEpoch; /* Value of nsPtr->resolverEpoch when this + int nsEpoch; /* Value of nsPtr->resolverEpoch when this * ByteCode was compiled. Used to invalidate * code when new namespace resolution rules * are put into effect. */ - size_t refCount; /* Reference count: set 1 when created plus 1 + int refCount; /* Reference count: set 1 when created plus 1 * for each execution of the code currently * active. This structure can be freed when * refCount becomes zero. */ unsigned int flags; /* flags describing state for the codebyte. * this variable holds ORed values from the @@ -512,324 +512,321 @@ #ifdef TCL_COMPILE_STATS Tcl_Time createTime; /* Absolute time when the ByteCode was * created. */ #endif /* TCL_COMPILE_STATS */ } ByteCode; - -#define ByteCodeSetIntRep(objPtr, typePtr, codePtr) \ - do { \ - Tcl_ObjIntRep ir; \ - ir.twoPtrValue.ptr1 = (codePtr); \ - ir.twoPtrValue.ptr2 = NULL; \ - Tcl_StoreIntRep((objPtr), (typePtr), &ir); \ - } while (0) - - - -#define ByteCodeGetIntRep(objPtr, typePtr, codePtr) \ - do { \ - const Tcl_ObjIntRep *irPtr; \ - irPtr = TclFetchIntRep((objPtr), (typePtr)); \ - (codePtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ - } while (0) /* * Opcodes for the Tcl bytecode instructions. These must correspond to the * entries in the table of instruction descriptions, tclInstructionTable, in * tclCompile.c. Also, the order and number of the expression opcodes (e.g., - * INST_BITOR) must match the entries in the array operatorStrings in + * INST_LOR) must match the entries in the array operatorStrings in * tclExecute.c. */ -enum TclInstruction { - /* Opcodes 0 to 9 */ - INST_DONE = 0, - INST_PUSH1, - INST_PUSH4, - INST_POP, - INST_DUP, - INST_STR_CONCAT1, - INST_INVOKE_STK1, - INST_INVOKE_STK4, - INST_EVAL_STK, - INST_EXPR_STK, - - /* Opcodes 10 to 23 */ - INST_LOAD_SCALAR1, - INST_LOAD_SCALAR4, - INST_LOAD_SCALAR_STK, - INST_LOAD_ARRAY1, - INST_LOAD_ARRAY4, - INST_LOAD_ARRAY_STK, - INST_LOAD_STK, - INST_STORE_SCALAR1, - INST_STORE_SCALAR4, - INST_STORE_SCALAR_STK, - INST_STORE_ARRAY1, - INST_STORE_ARRAY4, - INST_STORE_ARRAY_STK, - INST_STORE_STK, - - /* Opcodes 24 to 33 */ - INST_INCR_SCALAR1, - INST_INCR_SCALAR_STK, - INST_INCR_ARRAY1, - INST_INCR_ARRAY_STK, - INST_INCR_STK, - INST_INCR_SCALAR1_IMM, - INST_INCR_SCALAR_STK_IMM, - INST_INCR_ARRAY1_IMM, - INST_INCR_ARRAY_STK_IMM, - INST_INCR_STK_IMM, - - /* Opcodes 34 to 39 */ - INST_JUMP1, - INST_JUMP4, - INST_JUMP_TRUE1, - INST_JUMP_TRUE4, - INST_JUMP_FALSE1, - INST_JUMP_FALSE4, - - /* Opcodes 42 to 64 */ - INST_BITOR, - INST_BITXOR, - INST_BITAND, - INST_EQ, - INST_NEQ, - INST_LT, - INST_GT, - INST_LE, - INST_GE, - INST_LSHIFT, - INST_RSHIFT, - INST_ADD, - INST_SUB, - INST_MULT, - INST_DIV, - INST_MOD, - INST_UPLUS, - INST_UMINUS, - INST_BITNOT, - INST_LNOT, - INST_TRY_CVT_TO_NUMERIC, - - /* Opcodes 65 to 66 */ - INST_BREAK, - INST_CONTINUE, - - /* Opcodes 69 to 72 */ - INST_BEGIN_CATCH4, - INST_END_CATCH, - INST_PUSH_RESULT, - INST_PUSH_RETURN_CODE, - - /* Opcodes 73 to 78 */ - INST_STR_EQ, - INST_STR_NEQ, - INST_STR_CMP, - INST_STR_LEN, - INST_STR_INDEX, - INST_STR_MATCH, - - /* Opcodes 79 to 81 */ - INST_LIST, - INST_LIST_INDEX, - INST_LIST_LENGTH, - - /* Opcodes 82 to 87 */ - INST_APPEND_SCALAR1, - INST_APPEND_SCALAR4, - INST_APPEND_ARRAY1, - INST_APPEND_ARRAY4, - INST_APPEND_ARRAY_STK, - INST_APPEND_STK, - - /* Opcodes 88 to 93 */ - INST_LAPPEND_SCALAR1, - INST_LAPPEND_SCALAR4, - INST_LAPPEND_ARRAY1, - INST_LAPPEND_ARRAY4, - INST_LAPPEND_ARRAY_STK, - INST_LAPPEND_STK, - - /* TIP #22 - LINDEX operator with flat arg list */ - INST_LIST_INDEX_MULTI, - - /* - * TIP #33 - 'lset' command. Code gen also required a Forth-like - * OVER operation. - */ - INST_OVER, - INST_LSET_LIST, - INST_LSET_FLAT, - - /* TIP#90 - 'return' command. */ - INST_RETURN_IMM, - - /* TIP#123 - exponentiation operator. */ - INST_EXPON, - - /* TIP #157 - {*}... (word expansion) language syntax support. */ - INST_EXPAND_START, - INST_EXPAND_STKTOP, - INST_INVOKE_EXPANDED, - - /* - * TIP #57 - 'lassign' command. Code generation requires immediate - * LINDEX and LRANGE operators. - */ - INST_LIST_INDEX_IMM, - INST_LIST_RANGE_IMM, - INST_START_CMD, - INST_LIST_IN, - INST_LIST_NOT_IN, - INST_PUSH_RETURN_OPTIONS, - INST_RETURN_STK, - - /* - * Dictionary (TIP#111) related commands. - */ - INST_DICT_GET, - INST_DICT_SET, - INST_DICT_UNSET, - INST_DICT_INCR_IMM, - INST_DICT_APPEND, - INST_DICT_LAPPEND, - INST_DICT_FIRST, - INST_DICT_NEXT, - INST_DICT_UPDATE_START, - INST_DICT_UPDATE_END, - - /* - * Instruction to support jumps defined by tables (instead of the classic - * [switch] technique of chained comparisons). - */ - INST_JUMP_TABLE, - - /* - * Instructions to support compilation of global, variable, upvar and - * [namespace upvar]. - */ - INST_UPVAR, - INST_NSUPVAR, - INST_VARIABLE, - - /* Instruction to support compiling syntax error to bytecode */ - INST_SYNTAX, - - /* Instruction to reverse N items on top of stack */ - INST_REVERSE, - - /* regexp instruction */ - INST_REGEXP, - - /* For [info exists] compilation */ - INST_EXIST_SCALAR, - INST_EXIST_ARRAY, - INST_EXIST_ARRAY_STK, - INST_EXIST_STK, - - /* For [subst] compilation */ - INST_NOP, - INST_RETURN_CODE_BRANCH, - - /* For [unset] compilation */ - INST_UNSET_SCALAR, - INST_UNSET_ARRAY, - INST_UNSET_ARRAY_STK, - INST_UNSET_STK, - - /* For [dict with], [dict exists], [dict create] and [dict merge] */ - INST_DICT_EXPAND, - INST_DICT_RECOMBINE_STK, - INST_DICT_RECOMBINE_IMM, - INST_DICT_EXISTS, - INST_DICT_VERIFY, - - /* For [string map] and [regsub] compilation */ - INST_STR_MAP, - INST_STR_FIND, - INST_STR_FIND_LAST, - INST_STR_RANGE_IMM, - INST_STR_RANGE, - - /* For operations to do with coroutines and other NRE-manipulators */ - INST_YIELD, - INST_COROUTINE_NAME, - INST_TAILCALL, - - /* For compilation of basic information operations */ - INST_NS_CURRENT, - INST_INFO_LEVEL_NUM, - INST_INFO_LEVEL_ARGS, - INST_RESOLVE_COMMAND, - - /* For compilation relating to TclOO */ - INST_TCLOO_SELF, - INST_TCLOO_CLASS, - INST_TCLOO_NS, - INST_TCLOO_IS_OBJECT, - - /* For compilation of [array] subcommands */ - INST_ARRAY_EXISTS_STK, - INST_ARRAY_EXISTS_IMM, - INST_ARRAY_MAKE_STK, - INST_ARRAY_MAKE_IMM, - - INST_INVOKE_REPLACE, - - INST_LIST_CONCAT, - - INST_EXPAND_DROP, - - /* New foreach implementation */ - INST_FOREACH_START, - INST_FOREACH_STEP, - INST_FOREACH_END, - INST_LMAP_COLLECT, - - /* For compilation of [string trim] and related */ - INST_STR_TRIM, - INST_STR_TRIM_LEFT, - INST_STR_TRIM_RIGHT, - - INST_CONCAT_STK, - - INST_STR_UPPER, - INST_STR_LOWER, - INST_STR_TITLE, - INST_STR_REPLACE, - - INST_ORIGIN_COMMAND, - - INST_TCLOO_NEXT, - INST_TCLOO_NEXT_CLASS, - - INST_YIELD_TO_INVOKE, - - INST_NUM_TYPE, - INST_TRY_CVT_TO_BOOLEAN, - INST_STR_CLASS, - - INST_LAPPEND_LIST, - INST_LAPPEND_LIST_ARRAY, - INST_LAPPEND_LIST_ARRAY_STK, - INST_LAPPEND_LIST_STK, - - INST_CLOCK_READ, - - INST_DICT_GET_DEF, - - /* TIP 461 */ - INST_STR_LT, - INST_STR_GT, - INST_STR_LE, - INST_STR_GE, - - /* The last opcode */ - LAST_INST_OPCODE -}; +/* Opcodes 0 to 9 */ +#define INST_DONE 0 +#define INST_PUSH1 1 +#define INST_PUSH4 2 +#define INST_POP 3 +#define INST_DUP 4 +#define INST_STR_CONCAT1 5 +#define INST_INVOKE_STK1 6 +#define INST_INVOKE_STK4 7 +#define INST_EVAL_STK 8 +#define INST_EXPR_STK 9 + +/* Opcodes 10 to 23 */ +#define INST_LOAD_SCALAR1 10 +#define INST_LOAD_SCALAR4 11 +#define INST_LOAD_SCALAR_STK 12 +#define INST_LOAD_ARRAY1 13 +#define INST_LOAD_ARRAY4 14 +#define INST_LOAD_ARRAY_STK 15 +#define INST_LOAD_STK 16 +#define INST_STORE_SCALAR1 17 +#define INST_STORE_SCALAR4 18 +#define INST_STORE_SCALAR_STK 19 +#define INST_STORE_ARRAY1 20 +#define INST_STORE_ARRAY4 21 +#define INST_STORE_ARRAY_STK 22 +#define INST_STORE_STK 23 + +/* Opcodes 24 to 33 */ +#define INST_INCR_SCALAR1 24 +#define INST_INCR_SCALAR_STK 25 +#define INST_INCR_ARRAY1 26 +#define INST_INCR_ARRAY_STK 27 +#define INST_INCR_STK 28 +#define INST_INCR_SCALAR1_IMM 29 +#define INST_INCR_SCALAR_STK_IMM 30 +#define INST_INCR_ARRAY1_IMM 31 +#define INST_INCR_ARRAY_STK_IMM 32 +#define INST_INCR_STK_IMM 33 + +/* Opcodes 34 to 39 */ +#define INST_JUMP1 34 +#define INST_JUMP4 35 +#define INST_JUMP_TRUE1 36 +#define INST_JUMP_TRUE4 37 +#define INST_JUMP_FALSE1 38 +#define INST_JUMP_FALSE4 39 + +/* Opcodes 40 to 64 */ +#define INST_LOR 40 +#define INST_LAND 41 +#define INST_BITOR 42 +#define INST_BITXOR 43 +#define INST_BITAND 44 +#define INST_EQ 45 +#define INST_NEQ 46 +#define INST_LT 47 +#define INST_GT 48 +#define INST_LE 49 +#define INST_GE 50 +#define INST_LSHIFT 51 +#define INST_RSHIFT 52 +#define INST_ADD 53 +#define INST_SUB 54 +#define INST_MULT 55 +#define INST_DIV 56 +#define INST_MOD 57 +#define INST_UPLUS 58 +#define INST_UMINUS 59 +#define INST_BITNOT 60 +#define INST_LNOT 61 +#define INST_CALL_BUILTIN_FUNC1 62 +#define INST_CALL_FUNC1 63 +#define INST_TRY_CVT_TO_NUMERIC 64 + +/* Opcodes 65 to 66 */ +#define INST_BREAK 65 +#define INST_CONTINUE 66 + +/* Opcodes 67 to 68 */ +#define INST_FOREACH_START4 67 /* DEPRECATED */ +#define INST_FOREACH_STEP4 68 /* DEPRECATED */ + +/* Opcodes 69 to 72 */ +#define INST_BEGIN_CATCH4 69 +#define INST_END_CATCH 70 +#define INST_PUSH_RESULT 71 +#define INST_PUSH_RETURN_CODE 72 + +/* Opcodes 73 to 78 */ +#define INST_STR_EQ 73 +#define INST_STR_NEQ 74 +#define INST_STR_CMP 75 +#define INST_STR_LEN 76 +#define INST_STR_INDEX 77 +#define INST_STR_MATCH 78 + +/* Opcodes 78 to 81 */ +#define INST_LIST 79 +#define INST_LIST_INDEX 80 +#define INST_LIST_LENGTH 81 + +/* Opcodes 82 to 87 */ +#define INST_APPEND_SCALAR1 82 +#define INST_APPEND_SCALAR4 83 +#define INST_APPEND_ARRAY1 84 +#define INST_APPEND_ARRAY4 85 +#define INST_APPEND_ARRAY_STK 86 +#define INST_APPEND_STK 87 + +/* Opcodes 88 to 93 */ +#define INST_LAPPEND_SCALAR1 88 +#define INST_LAPPEND_SCALAR4 89 +#define INST_LAPPEND_ARRAY1 90 +#define INST_LAPPEND_ARRAY4 91 +#define INST_LAPPEND_ARRAY_STK 92 +#define INST_LAPPEND_STK 93 + +/* TIP #22 - LINDEX operator with flat arg list */ + +#define INST_LIST_INDEX_MULTI 94 + +/* + * TIP #33 - 'lset' command. Code gen also required a Forth-like + * OVER operation. + */ + +#define INST_OVER 95 +#define INST_LSET_LIST 96 +#define INST_LSET_FLAT 97 + +/* TIP#90 - 'return' command. */ + +#define INST_RETURN_IMM 98 + +/* TIP#123 - exponentiation operator. */ + +#define INST_EXPON 99 + +/* TIP #157 - {*}... (word expansion) language syntax support. */ + +#define INST_EXPAND_START 100 +#define INST_EXPAND_STKTOP 101 +#define INST_INVOKE_EXPANDED 102 + +/* + * TIP #57 - 'lassign' command. Code generation requires immediate + * LINDEX and LRANGE operators. + */ + +#define INST_LIST_INDEX_IMM 103 +#define INST_LIST_RANGE_IMM 104 + +#define INST_START_CMD 105 + +#define INST_LIST_IN 106 +#define INST_LIST_NOT_IN 107 + +#define INST_PUSH_RETURN_OPTIONS 108 +#define INST_RETURN_STK 109 + +/* + * Dictionary (TIP#111) related commands. + */ + +#define INST_DICT_GET 110 +#define INST_DICT_SET 111 +#define INST_DICT_UNSET 112 +#define INST_DICT_INCR_IMM 113 +#define INST_DICT_APPEND 114 +#define INST_DICT_LAPPEND 115 +#define INST_DICT_FIRST 116 +#define INST_DICT_NEXT 117 +#define INST_DICT_DONE 118 +#define INST_DICT_UPDATE_START 119 +#define INST_DICT_UPDATE_END 120 + +/* + * Instruction to support jumps defined by tables (instead of the classic + * [switch] technique of chained comparisons). + */ + +#define INST_JUMP_TABLE 121 + +/* + * Instructions to support compilation of global, variable, upvar and + * [namespace upvar]. + */ + +#define INST_UPVAR 122 +#define INST_NSUPVAR 123 +#define INST_VARIABLE 124 + +/* Instruction to support compiling syntax error to bytecode */ + +#define INST_SYNTAX 125 + +/* Instruction to reverse N items on top of stack */ + +#define INST_REVERSE 126 + +/* regexp instruction */ + +#define INST_REGEXP 127 + +/* For [info exists] compilation */ +#define INST_EXIST_SCALAR 128 +#define INST_EXIST_ARRAY 129 +#define INST_EXIST_ARRAY_STK 130 +#define INST_EXIST_STK 131 + +/* For [subst] compilation */ +#define INST_NOP 132 +#define INST_RETURN_CODE_BRANCH 133 + +/* For [unset] compilation */ +#define INST_UNSET_SCALAR 134 +#define INST_UNSET_ARRAY 135 +#define INST_UNSET_ARRAY_STK 136 +#define INST_UNSET_STK 137 + +/* For [dict with], [dict exists], [dict create] and [dict merge] */ +#define INST_DICT_EXPAND 138 +#define INST_DICT_RECOMBINE_STK 139 +#define INST_DICT_RECOMBINE_IMM 140 +#define INST_DICT_EXISTS 141 +#define INST_DICT_VERIFY 142 + +/* For [string map] and [regsub] compilation */ +#define INST_STR_MAP 143 +#define INST_STR_FIND 144 +#define INST_STR_FIND_LAST 145 +#define INST_STR_RANGE_IMM 146 +#define INST_STR_RANGE 147 + +/* For operations to do with coroutines and other NRE-manipulators */ +#define INST_YIELD 148 +#define INST_COROUTINE_NAME 149 +#define INST_TAILCALL 150 + +/* For compilation of basic information operations */ +#define INST_NS_CURRENT 151 +#define INST_INFO_LEVEL_NUM 152 +#define INST_INFO_LEVEL_ARGS 153 +#define INST_RESOLVE_COMMAND 154 + +/* For compilation relating to TclOO */ +#define INST_TCLOO_SELF 155 +#define INST_TCLOO_CLASS 156 +#define INST_TCLOO_NS 157 +#define INST_TCLOO_IS_OBJECT 158 + +/* For compilation of [array] subcommands */ +#define INST_ARRAY_EXISTS_STK 159 +#define INST_ARRAY_EXISTS_IMM 160 +#define INST_ARRAY_MAKE_STK 161 +#define INST_ARRAY_MAKE_IMM 162 + +#define INST_INVOKE_REPLACE 163 + +#define INST_LIST_CONCAT 164 + +#define INST_EXPAND_DROP 165 + +/* New foreach implementation */ +#define INST_FOREACH_START 166 +#define INST_FOREACH_STEP 167 +#define INST_FOREACH_END 168 +#define INST_LMAP_COLLECT 169 + +/* For compilation of [string trim] and related */ +#define INST_STR_TRIM 170 +#define INST_STR_TRIM_LEFT 171 +#define INST_STR_TRIM_RIGHT 172 + +#define INST_CONCAT_STK 173 + +#define INST_STR_UPPER 174 +#define INST_STR_LOWER 175 +#define INST_STR_TITLE 176 +#define INST_STR_REPLACE 177 + +#define INST_ORIGIN_COMMAND 178 + +#define INST_TCLOO_NEXT 179 +#define INST_TCLOO_NEXT_CLASS 180 + +#define INST_YIELD_TO_INVOKE 181 + +#define INST_NUM_TYPE 182 +#define INST_TRY_CVT_TO_BOOLEAN 183 +#define INST_STR_CLASS 184 + +#define INST_LAPPEND_LIST 185 +#define INST_LAPPEND_LIST_ARRAY 186 +#define INST_LAPPEND_LIST_ARRAY_STK 187 +#define INST_LAPPEND_LIST_STK 188 + +#define INST_CLOCK_READ 189 + +/* The last opcode */ +#define LAST_INST_OPCODE 189 /* * Table describing the Tcl bytecode instructions: their name (for displaying * code), total number of code bytes required (including operand bytes), and a * description of the type of each operand. These operand types include signed @@ -863,11 +860,11 @@ OPERAND_SCLS1 /* Index into tclStringClassTable. */ } InstOperandType; typedef struct InstructionDesc { const char *name; /* Name of instruction. */ - size_t numBytes; /* Total number of bytes for instruction. */ + int numBytes; /* Total number of bytes for instruction. */ int stackEffect; /* The worst-case balance stack effect of the * instruction, used for stack requirements * computations. The value INT_MIN signals * that the instruction's worst case effect is * (1-opnd1). */ @@ -967,11 +964,11 @@ * only scalar variables are supported for inline-compiled foreach loops. */ typedef struct ForeachVarList { int numVars; /* The number of variables in the list. */ - int varIndexes[1]; /* An array of the indexes ("slot numbers") + int varIndexes[TCLFLEXARRAY];/* An array of the indexes ("slot numbers") * for each variable in the procedure's array * of local variables. Only scalar variables * are supported. The actual size of this * field will be large enough to numVars * indexes. THIS MUST BE THE LAST FIELD IN THE @@ -991,11 +988,11 @@ * used to point to a value list. */ int loopCtTemp; /* Index of temp var in a proc frame holding * the loop's iteration count. Used to * determine next value list element to assign * each loop var. */ - ForeachVarList *varLists[1];/* An array of pointers to ForeachVarList + ForeachVarList *varLists[TCLFLEXARRAY];/* An array of pointers to ForeachVarList * structures describing each var list. The * actual size of this field will be large * enough to numVars indexes. THIS MUST BE THE * LAST FIELD IN THE STRUCTURE! */ } ForeachInfo; @@ -1021,12 +1018,12 @@ * needed during program execution. These structures are stored in CompileEnv * and ByteCode structures as auxiliary data. */ typedef struct { - size_t length; /* Size of array */ - int varIndices[1]; /* Array of variable indices to manage when + int length; /* Size of array */ + int varIndices[TCLFLEXARRAY]; /* Array of variable indices to manage when * processing the start and end of a [dict * update]. There is really more than one * entry, and the structure is allocated to * take account of this. MUST BE LAST FIELD IN * STRUCTURE. */ @@ -1070,40 +1067,41 @@ */ MODULE_SCOPE int TclAttemptCompileProc(Tcl_Interp *interp, Tcl_Parse *parsePtr, int depth, Command *cmdPtr, CompileEnv *envPtr); +MODULE_SCOPE void TclCleanupByteCode(ByteCode *codePtr); MODULE_SCOPE void TclCleanupStackForBreakContinue(CompileEnv *envPtr, ExceptionAux *auxPtr); MODULE_SCOPE void TclCompileCmdWord(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, CompileEnv *envPtr); MODULE_SCOPE void TclCompileExpr(Tcl_Interp *interp, const char *script, - size_t numBytes, CompileEnv *envPtr, int optimize); + int numBytes, CompileEnv *envPtr, int optimize); MODULE_SCOPE void TclCompileExprWords(Tcl_Interp *interp, Tcl_Token *tokenPtr, int numWords, CompileEnv *envPtr); MODULE_SCOPE void TclCompileInvocation(Tcl_Interp *interp, - Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, size_t numWords, + Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, int numWords, CompileEnv *envPtr); MODULE_SCOPE void TclCompileScript(Tcl_Interp *interp, - const char *script, size_t numBytes, + const char *script, int numBytes, CompileEnv *envPtr); MODULE_SCOPE void TclCompileSyntaxError(Tcl_Interp *interp, CompileEnv *envPtr); MODULE_SCOPE void TclCompileTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, CompileEnv *envPtr); MODULE_SCOPE void TclCompileVarSubst(Tcl_Interp *interp, Tcl_Token *tokenPtr, CompileEnv *envPtr); -MODULE_SCOPE int TclCreateAuxData(void *clientData, +MODULE_SCOPE int TclCreateAuxData(ClientData clientData, const AuxDataType *typePtr, CompileEnv *envPtr); MODULE_SCOPE int TclCreateExceptRange(ExceptionRangeType type, CompileEnv *envPtr); -MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, size_t size); -MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, const char *bytes, - size_t length, size_t hash, int *newPtr, +MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, int size); +MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, char *bytes, + int length, unsigned int hash, int *newPtr, Namespace *nsPtr, int flags, LiteralEntry **globalPtrPtr); MODULE_SCOPE void TclDeleteExecEnv(ExecEnv *eePtr); MODULE_SCOPE void TclDeleteLiteralTable(Tcl_Interp *interp, LiteralTable *tablePtr); @@ -1113,26 +1111,25 @@ MODULE_SCOPE ExceptionRange * TclGetExceptionRangeForPc(unsigned char *pc, int catchOnly, ByteCode *codePtr); MODULE_SCOPE void TclExpandJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE int TclNRExecuteByteCode(Tcl_Interp *interp, ByteCode *codePtr); -MODULE_SCOPE Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, size_t index); -MODULE_SCOPE int TclFindCompiledLocal(const char *name, size_t nameChars, +MODULE_SCOPE Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, unsigned int index); +MODULE_SCOPE int TclFindCompiledLocal(const char *name, int nameChars, int create, CompileEnv *envPtr); MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr, JumpFixup *jumpFixupPtr, int jumpDist, int distThreshold); MODULE_SCOPE void TclFreeCompileEnv(CompileEnv *envPtr); MODULE_SCOPE void TclFreeJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE int TclGetIndexFromToken(Tcl_Token *tokenPtr, - size_t before, size_t after, int *indexPtr); -MODULE_SCOPE ByteCode * TclInitByteCode(CompileEnv *envPtr); -MODULE_SCOPE ByteCode * TclInitByteCodeObj(Tcl_Obj *objPtr, - const Tcl_ObjType *typePtr, CompileEnv *envPtr); + int before, int after, int *indexPtr); +MODULE_SCOPE void TclInitByteCodeObj(Tcl_Obj *objPtr, + CompileEnv *envPtr); MODULE_SCOPE void TclInitCompileEnv(Tcl_Interp *interp, CompileEnv *envPtr, const char *string, - size_t numBytes, const CmdFrame *invoker, int word); + int numBytes, const CmdFrame *invoker, int word); MODULE_SCOPE void TclInitJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE void TclInitLiteralTable(LiteralTable *tablePtr); MODULE_SCOPE ExceptionRange *TclGetInnermostExceptionRange(CompileEnv *envPtr, int returnCode, ExceptionAux **auxPtrPtr); MODULE_SCOPE void TclAddLoopBreakFixup(CompileEnv *envPtr, @@ -1143,11 +1140,11 @@ int range); #ifdef TCL_COMPILE_STATS MODULE_SCOPE char * TclLiteralStats(LiteralTable *tablePtr); MODULE_SCOPE int TclLog2(int value); #endif -MODULE_SCOPE int TclLocalScalar(const char *bytes, size_t numBytes, +MODULE_SCOPE int TclLocalScalar(const char *bytes, int numBytes, CompileEnv *envPtr); MODULE_SCOPE int TclLocalScalarFromToken(Tcl_Token *tokenPtr, CompileEnv *envPtr); MODULE_SCOPE void TclOptimizeBytecode(void *envPtr); #ifdef TCL_COMPILE_DEBUG @@ -1155,32 +1152,49 @@ Tcl_Obj *objPtr); #endif MODULE_SCOPE int TclPrintInstruction(ByteCode *codePtr, const unsigned char *pc); MODULE_SCOPE void TclPrintObject(FILE *outFile, - Tcl_Obj *objPtr, size_t maxChars); + Tcl_Obj *objPtr, int maxChars); MODULE_SCOPE void TclPrintSource(FILE *outFile, - const char *string, size_t maxChars); + const char *string, int maxChars); MODULE_SCOPE void TclPushVarName(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags, int *localIndexPtr, int *isScalarPtr); -MODULE_SCOPE void TclPreserveByteCode(ByteCode *codePtr); -MODULE_SCOPE void TclReleaseByteCode(ByteCode *codePtr); + +static inline void +TclPreserveByteCode( + ByteCode *codePtr) +{ + codePtr->refCount++; +} + +static inline void +TclReleaseByteCode( + ByteCode *codePtr) +{ + if (codePtr->refCount-- > 1) { + return; + } + /* Just dropped to refcount==0. Clean up. */ + TclCleanupByteCode(codePtr); +} + MODULE_SCOPE void TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr); MODULE_SCOPE void TclInvalidateCmdLiteral(Tcl_Interp *interp, const char *name, Namespace *nsPtr); -MODULE_SCOPE int TclSingleOpCmd(void *clientData, +MODULE_SCOPE int TclSingleOpCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int TclSortingOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclSortingOpCmd(void *clientData, +MODULE_SCOPE int TclVariadicOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclVariadicOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int TclNoIdentOpCmd(void *clientData, +MODULE_SCOPE int TclNoIdentOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); #ifdef TCL_COMPILE_DEBUG MODULE_SCOPE void TclVerifyGlobalLiteralTable(Interp *iPtr); MODULE_SCOPE void TclVerifyLocalLiteralTable(CompileEnv *envPtr); @@ -1187,17 +1201,17 @@ #endif MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr, Tcl_Obj *valuePtr); MODULE_SCOPE void TclLogCommandInfo(Tcl_Interp *interp, const char *script, const char *command, - size_t length, const unsigned char *pc, + int length, const unsigned char *pc, Tcl_Obj **tosPtr); MODULE_SCOPE Tcl_Obj *TclGetInnerContext(Tcl_Interp *interp, const unsigned char *pc, Tcl_Obj **tosPtr); MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); -MODULE_SCOPE int TclPushProcCallFrame(void *clientData, - register Tcl_Interp *interp, int objc, +MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int isLambda); /* *---------------------------------------------------------------- @@ -1207,20 +1221,43 @@ */ /* * Simplified form to access AuxData. * - * void *TclFetchAuxData(CompileEng *envPtr, int index); + * ClientData TclFetchAuxData(CompileEng *envPtr, int index); */ #define TclFetchAuxData(envPtr, index) \ (envPtr)->auxDataArrayPtr[(index)].clientData #define LITERAL_ON_HEAP 0x01 #define LITERAL_CMD_NAME 0x02 #define LITERAL_UNSHARED 0x04 +/* + * Form of TclRegisterLiteral with flags == 0. In that case, it is safe to + * cast away constness, and it is cleanest to do that here, all in one place. + * + * int TclRegisterNewLiteral(CompileEnv *envPtr, const char *bytes, + * int length); + */ + +#define TclRegisterNewLiteral(envPtr, bytes, length) \ + TclRegisterLiteral(envPtr, (char *)(bytes), length, /*flags*/ 0) + +/* + * Form of TclRegisterLiteral with flags == LITERAL_CMD_NAME. In that case, it + * is safe to cast away constness, and it is cleanest to do that here, all in + * one place. + * + * int TclRegisterNewNSLiteral(CompileEnv *envPtr, const char *bytes, + * int length); + */ + +#define TclRegisterNewCmdLiteral(envPtr, bytes, length) \ + TclRegisterLiteral(envPtr, (char *)(bytes), length, LITERAL_CMD_NAME) + /* * Macro used to manually adjust the stack requirements; used in cases where * the stack effect cannot be computed from the opcode and its operands, but * is still known at compile time. * @@ -1381,11 +1418,11 @@ * void TclEmitPush(int objIndex, CompileEnv *envPtr); */ #define TclEmitPush(objIndex, envPtr) \ do { \ - register int _objIndexCopy = (objIndex); \ + int _objIndexCopy = (objIndex); \ if (_objIndexCopy <= 255) { \ TclEmitInstInt1(INST_PUSH1, _objIndexCopy, (envPtr)); \ } else { \ TclEmitInstInt4(INST_PUSH4, _objIndexCopy, (envPtr)); \ } \ @@ -1526,19 +1563,19 @@ /* * Convenience macros for use when pushing literals. The ANSI C "prototype" for * these macros are: * * static void PushLiteral(CompileEnv *envPtr, - * const char *string, size_t length); + * const char *string, int length); * static void PushStringLiteral(CompileEnv *envPtr, * const char *string); */ #define PushLiteral(envPtr, string, length) \ - TclEmitPush(TclRegisterLiteral(envPtr, string, length, 0), (envPtr)) + TclEmitPush(TclRegisterNewLiteral((envPtr), (string), (length)), (envPtr)) #define PushStringLiteral(envPtr, string) \ - PushLiteral(envPtr, string, sizeof(string "") - 1) + PushLiteral((envPtr), (string), (int) (sizeof(string "") - 1)) /* * Macro to advance to the next token; it is more mnemonic than the address * arithmetic that it replaces. The ANSI C "prototype" for this macro is: * @@ -1550,11 +1587,11 @@ /* * Macro to get the offset to the next instruction to be issued. The ANSI C * "prototype" for this macro is: * - * static ptrdiff_t CurrentOffset(CompileEnv *envPtr); + * static int CurrentOffset(CompileEnv *envPtr); */ #define CurrentOffset(envPtr) \ ((envPtr)->codeNext - (envPtr)->codeStart) @@ -1802,12 +1839,12 @@ int tclDTraceDebugEnabled = TCL_DTRACE_DEBUG_LOG_ENABLED; \ int tclDTraceDebugIndent = 0; \ FILE *tclDTraceDebugLog = NULL; \ void TclDTraceOpenDebugLog(void) { \ char n[35]; \ - sprintf(n, "/tmp/tclDTraceDebug-%" TCL_Z_MODIFIER "u.log", \ - (size_t) getpid()); \ + sprintf(n, "/tmp/tclDTraceDebug-%lu.log", \ + (unsigned long) getpid()); \ tclDTraceDebugLog = fopen(n, "a"); \ } #define TclDTraceDbgMsg(p, m, ...) \ do { \ Index: generic/tclConfig.c ================================================================== --- generic/tclConfig.c +++ generic/tclConfig.c @@ -29,11 +29,11 @@ * A ClientData struct for the QueryConfig command. Store the three bits * of data we need; the package name for which we store a config dict, * the (Tcl_Interp *) in which it is stored, and the encoding. */ -typedef struct { +typedef struct QCCD { Tcl_Obj *pkg; Tcl_Interp *interp; char *encoding; } QCCD; @@ -77,15 +77,15 @@ * configuration values, ASCII, thus UTF-8. */ { Tcl_Obj *pDB, *pkgDict; Tcl_DString cmdName; const Tcl_Config *cfg; - QCCD *cdPtr = Tcl_Alloc(sizeof(QCCD)); + QCCD *cdPtr = ckalloc(sizeof(QCCD)); cdPtr->interp = interp; if (valEncoding) { - cdPtr->encoding = Tcl_Alloc(strlen(valEncoding)+1); + cdPtr->encoding = ckalloc(strlen(valEncoding)+1); strcpy(cdPtr->encoding, valEncoding); } else { cdPtr->encoding = NULL; } cdPtr->pkg = Tcl_NewStringObj(pkgName, -1); @@ -200,12 +200,11 @@ struct Tcl_Obj *const *objv) { QCCD *cdPtr = clientData; Tcl_Obj *pkgName = cdPtr->pkg; Tcl_Obj *pDB, *pkgDict, *val, *listPtr; - size_t n = 0; - int index, m; + int n, index; static const char *const subcmdStrings[] = { "get", "list", NULL }; enum subcmds { CFG_GET, CFG_LIST @@ -231,11 +230,11 @@ * present. */ Tcl_SetObjResult(interp, Tcl_NewStringObj("package not known", -1)); Tcl_SetErrorCode(interp, "TCL", "FATAL", "PKGCFG_BASE", - TclGetString(pkgName), NULL); + Tcl_GetString(pkgName), NULL); return TCL_ERROR; } switch ((enum subcmds) index) { case CFG_GET: @@ -246,11 +245,11 @@ if (Tcl_DictObjGet(interp, pkgDict, objv[2], &val) != TCL_OK || val == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("key not known", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONFIG", - TclGetString(objv[2]), NULL); + Tcl_GetString(objv[2]), NULL); return TCL_ERROR; } if (cdPtr->encoding) { venc = Tcl_GetEncoding(interp, cdPtr->encoding); @@ -260,11 +259,11 @@ } /* * Value is stored as-is in a byte array, see Bug [9b2e636361], * so we have to decode it first. */ - value = (const char *) TclGetByteArrayFromObj(val, &n); + value = (const char *) Tcl_GetByteArrayFromObj(val, &n); value = Tcl_ExternalToUtfDString(venc, value, n, &conv); Tcl_SetObjResult(interp, Tcl_NewStringObj(value, Tcl_DStringLength(&conv))); Tcl_DStringFree(&conv); return TCL_OK; @@ -273,21 +272,21 @@ if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } - Tcl_DictObjSize(interp, pkgDict, &m); - listPtr = Tcl_NewListObj(m, NULL); + Tcl_DictObjSize(interp, pkgDict, &n); + listPtr = Tcl_NewListObj(n, NULL); if (!listPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "insufficient memory to create list", -1)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); return TCL_ERROR; } - if (m) { + if (n) { Tcl_DictSearch s; Tcl_Obj *key; int done; for (Tcl_DictObjFirst(interp, pkgDict, &s, &key, NULL, &done); @@ -332,13 +331,13 @@ Tcl_Obj *pDB = GetConfigDict(cdPtr->interp); Tcl_DictObjRemove(NULL, pDB, pkgName); Tcl_DecrRefCount(pkgName); if (cdPtr->encoding) { - Tcl_Free(cdPtr->encoding); + ckfree((char *)cdPtr->encoding); } - Tcl_Free(cdPtr); + ckfree((char *)cdPtr); } /* *------------------------------------------------------------------------- * Index: generic/tclDTrace.d ================================================================== --- generic/tclDTrace.d +++ generic/tclDTrace.d @@ -8,11 +8,10 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ typedef struct Tcl_Obj Tcl_Obj; -typedef const char* TclDTraceStr; /* * Tcl DTrace probes */ @@ -23,39 +22,39 @@ * triggered immediately before proc bytecode execution * arg0: proc name (string) * arg1: number of arguments (int) * arg2: array of proc argument objects (Tcl_Obj**) */ - probe proc__entry(TclDTraceStr name, int objc, struct Tcl_Obj **objv); + probe proc__entry(const char *name, int objc, struct Tcl_Obj **objv); /* * tcl*:::proc-return probe * triggered immediately after proc bytecode execution * arg0: proc name (string) * arg1: return code (int) */ - probe proc__return(TclDTraceStr name, int code); + probe proc__return(const char *name, int code); /* * tcl*:::proc-result probe * triggered after proc-return probe and result processing * arg0: proc name (string) * arg1: return code (int) * arg2: proc result (string) * arg3: proc result object (Tcl_Obj*) */ - probe proc__result(TclDTraceStr name, int code, TclDTraceStr result, + probe proc__result(const char *name, int code, const char *result, struct Tcl_Obj *resultobj); /* * tcl*:::proc-args probe * triggered before proc-entry probe, gives access to string * representation of proc arguments * arg0: proc name (string) * arg1-arg9: proc arguments or NULL (strings) */ - probe proc__args(TclDTraceStr name, TclDTraceStr arg1, TclDTraceStr arg2, - TclDTraceStr arg3, TclDTraceStr arg4, TclDTraceStr arg5, - TclDTraceStr arg6, TclDTraceStr arg7, TclDTraceStr arg8, - TclDTraceStr arg9); + probe proc__args(const char *name, const char *arg1, const char *arg2, + const char *arg3, const char *arg4, const char *arg5, + const char *arg6, const char *arg7, const char *arg8, + const char *arg9); /* * tcl*:::proc-info probe * triggered before proc-entry probe, gives access to TIP 280 * information for the proc invocation (i.e. [info frame 0]) * arg0: TIP 280 cmd (string) @@ -65,51 +64,51 @@ * arg4: TIP 280 line (int) * arg5: TIP 280 level (int) * arg6: TclOO method (string) * arg7: TclOO class/object (string) */ - probe proc__info(TclDTraceStr cmd, TclDTraceStr type, TclDTraceStr proc, - TclDTraceStr file, int line, int level, TclDTraceStr method, - TclDTraceStr class); + probe proc__info(const char *cmd, const char *type, const char *proc, + const char *file, int line, int level, const char *method, + const char *class); /***************************** cmd probes ******************************/ /* * tcl*:::cmd-entry probe * triggered immediately before commmand execution * arg0: command name (string) * arg1: number of arguments (int) * arg2: array of command argument objects (Tcl_Obj**) */ - probe cmd__entry(TclDTraceStr name, int objc, struct Tcl_Obj **objv); + probe cmd__entry(const char *name, int objc, struct Tcl_Obj **objv); /* * tcl*:::cmd-return probe * triggered immediately after commmand execution * arg0: command name (string) * arg1: return code (int) */ - probe cmd__return(TclDTraceStr name, int code); + probe cmd__return(const char *name, int code); /* * tcl*:::cmd-result probe * triggered after cmd-return probe and result processing * arg0: command name (string) * arg1: return code (int) * arg2: command result (string) * arg3: command result object (Tcl_Obj*) */ - probe cmd__result(TclDTraceStr name, int code, TclDTraceStr result, + probe cmd__result(const char *name, int code, const char *result, struct Tcl_Obj *resultobj); /* * tcl*:::cmd-args probe * triggered before cmd-entry probe, gives access to string * representation of command arguments * arg0: command name (string) * arg1-arg9: command arguments or NULL (strings) */ - probe cmd__args(TclDTraceStr name, TclDTraceStr arg1, TclDTraceStr arg2, - TclDTraceStr arg3, TclDTraceStr arg4, TclDTraceStr arg5, - TclDTraceStr arg6, TclDTraceStr arg7, TclDTraceStr arg8, - TclDTraceStr arg9); + probe cmd__args(const char *name, const char *arg1, const char *arg2, + const char *arg3, const char *arg4, const char *arg5, + const char *arg6, const char *arg7, const char *arg8, + const char *arg9); /* * tcl*:::cmd-info probe * triggered before cmd-entry probe, gives access to TIP 280 * information for the command invocation (i.e. [info frame 0]) * arg0: TIP 280 cmd (string) @@ -119,31 +118,31 @@ * arg4: TIP 280 line (int) * arg5: TIP 280 level (int) * arg6: TclOO method (string) * arg7: TclOO class/object (string) */ - probe cmd__info(TclDTraceStr cmd, TclDTraceStr type, TclDTraceStr proc, - TclDTraceStr file, int line, int level, TclDTraceStr method, - TclDTraceStr class); + probe cmd__info(const char *cmd, const char *type, const char *proc, + const char *file, int line, int level, const char *method, + const char *class); /***************************** inst probes *****************************/ /* * tcl*:::inst-start probe * triggered immediately before execution of a bytecode * arg0: bytecode name (string) * arg1: depth of stack (int) * arg2: top of stack (Tcl_Obj**) */ - probe inst__start(TclDTraceStr name, int depth, struct Tcl_Obj **stack); + probe inst__start(const char *name, int depth, struct Tcl_Obj **stack); /* * tcl*:::inst-done probe * triggered immediately after execution of a bytecode * arg0: bytecode name (string) * arg1: depth of stack (int) * arg2: top of stack (Tcl_Obj**) */ - probe inst__done(TclDTraceStr name, int depth, struct Tcl_Obj **stack); + probe inst__done(const char *name, int depth, struct Tcl_Obj **stack); /***************************** obj probes ******************************/ /* * tcl*:::obj-create probe * triggered immediately after a new Tcl_Obj has been created @@ -161,33 +160,33 @@ /* * tcl*:::tcl-probe probe * triggered when the ::tcl::dtrace command is called * arg0-arg9: command arguments (strings) */ - probe tcl__probe(TclDTraceStr arg0, TclDTraceStr arg1, TclDTraceStr arg2, - TclDTraceStr arg3, TclDTraceStr arg4, TclDTraceStr arg5, - TclDTraceStr arg6, TclDTraceStr arg7, TclDTraceStr arg8, - TclDTraceStr arg9); + probe tcl__probe(const char *arg0, const char *arg1, const char *arg2, + const char *arg3, const char *arg4, const char *arg5, + const char *arg6, const char *arg7, const char *arg8, + const char *arg9); }; /* * Tcl types and constants for use in DTrace scripts */ typedef struct Tcl_ObjType { - char *name; + const char *name; void *freeIntRepProc; void *dupIntRepProc; void *updateStringProc; void *setFromAnyProc; } Tcl_ObjType; struct Tcl_Obj { - size_t refCount; + int refCount; char *bytes; - size_t length; - Tcl_ObjType *typePtr; + int length; + const Tcl_ObjType *typePtr; union { long longValue; double doubleValue; void *otherValuePtr; int64_t wideValue; Index: generic/tclDate.c ================================================================== --- generic/tclDate.c +++ generic/tclDate.c @@ -92,10 +92,18 @@ #ifdef _MSC_VER #pragma warning( disable : 4102 ) #endif /* _MSC_VER */ +/* + * Meridian: am, pm, or 24-hour style. + */ + +typedef enum _MERIDIAN { + MERam, MERpm, MER24 +} MERIDIAN; + /* * yyparse will accept a 'struct DateInfo' as its parameter; that's where the * parsed fields will be returned. */ @@ -110,11 +118,11 @@ int dateHaveDate; time_t dateHour; time_t dateMinutes; time_t dateSeconds; - int dateMeridian; + MERIDIAN dateMeridian; int dateHaveTime; time_t dateTimezone; int dateDSTmode; int dateHaveZone; @@ -136,12 +144,12 @@ time_t *dateRelPointer; int dateDigitCount; } DateInfo; -#define YYMALLOC Tcl_Alloc -#define YYFREE(x) (Tcl_Free((void*) (x))) +#define YYMALLOC ckalloc +#define YYFREE(x) (ckfree((void*) (x))) #define yyDSTmode (info->dateDSTmode) #define yyDayOrdinal (info->dateDayOrdinal) #define yyDayNumber (info->dateDayNumber) #define yyMonthOrdinal (info->dateMonthOrdinal) @@ -197,18 +205,10 @@ typedef enum _DSTMODE { DSTon, DSToff, DSTmaybe } DSTMODE; -/* - * Meridian: am, pm, or 24-hour style. - */ - -typedef enum _MERIDIAN { - MERam, MERpm, MER24 -} MERIDIAN; - # ifndef YY_NULLPTR # if defined __cplusplus && 201103L <= __cplusplus @@ -558,20 +558,20 @@ #endif /* !YYCOPY_NEEDED */ /* YYFINAL -- State number of the termination state. */ #define YYFINAL 2 /* YYLAST -- Last index in YYTABLE. */ -#define YYLAST 79 +#define YYLAST 81 /* YYNTOKENS -- Number of terminals. */ #define YYNTOKENS 26 /* YYNNTS -- Number of nonterminals. */ #define YYNNTS 16 /* YYNRULES -- Number of rules. */ #define YYNRULES 56 /* YYNSTATES -- Number of states. */ -#define YYNSTATES 83 +#define YYNSTATES 85 /* YYTRANSLATE[YYX] -- Symbol number corresponding to YYX as returned by yylex, with out-of-bounds checking. */ #define YYUNDEFTOK 2 #define YYMAXUTOK 274 @@ -585,11 +585,11 @@ { 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 25, 22, 21, 24, 23, 2, 2, + 2, 2, 2, 25, 21, 23, 24, 22, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 20, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, @@ -616,15 +616,15 @@ #if YYDEBUG /* YYRLINE[YYN] -- Source line where rule number YYN was defined. */ static const yytype_uint16 yyrline[] = { 0, 223, 223, 224, 227, 230, 233, 236, 239, 242, - 245, 249, 254, 257, 263, 269, 277, 283, 294, 298, - 302, 308, 312, 316, 320, 324, 330, 334, 339, 344, - 349, 354, 358, 363, 367, 372, 379, 383, 389, 398, - 407, 417, 431, 436, 439, 442, 445, 448, 451, 456, - 459, 464, 468, 472, 478, 496, 499 + 245, 249, 254, 257, 263, 269, 277, 282, 287, 291, + 297, 301, 305, 309, 313, 319, 323, 328, 333, 338, + 343, 347, 352, 356, 361, 368, 372, 378, 388, 397, + 406, 416, 430, 435, 438, 441, 444, 447, 450, 455, + 458, 463, 467, 471, 477, 495, 498 }; #endif #if YYDEBUG || YYERROR_VERBOSE || 0 /* YYTNAME[SYMBOL-NUM] -- String name of the symbol SYMBOL-NUM. @@ -632,11 +632,11 @@ static const char *const yytname[] = { "$end", "error", "$undefined", "tAGO", "tDAY", "tDAYZONE", "tID", "tMERIDIAN", "tMONTH", "tMONTH_UNIT", "tSTARDATE", "tSEC_UNIT", "tSNUMBER", "tUNUMBER", "tZONE", "tEPOCH", "tDST", "tISOBASE", - "tDAY_UNIT", "tNEXT", "':'", "'-'", "','", "'/'", "'.'", "'+'", + "tDAY_UNIT", "tNEXT", "':'", "','", "'/'", "'-'", "'.'", "'+'", "$accept", "spec", "item", "time", "zone", "day", "date", "ordMonth", "iso", "trek", "relspec", "relunits", "sign", "unit", "number", "o_merid", YY_NULLPTR }; #endif @@ -646,18 +646,18 @@ (internal) symbol number NUM (which must be that of a token). */ static const yytype_uint16 yytoknum[] = { 0, 256, 257, 258, 259, 260, 261, 262, 263, 264, 265, 266, 267, 268, 269, 270, 271, 272, 273, 274, - 58, 45, 44, 47, 46, 43 + 58, 44, 47, 45, 46, 43 }; # endif -#define YYPACT_NINF -22 +#define YYPACT_NINF -18 #define yypact_value_is_default(Yystate) \ - (!!((Yystate) == (-22))) + (!!((Yystate) == (-18))) #define YYTABLE_NINF -1 #define yytable_value_is_error(Yytable_value) \ 0 @@ -664,111 +664,113 @@ /* YYPACT[STATE-NUM] -- Index in YYTABLE of the portion describing STATE-NUM. */ static const yytype_int8 yypact[] = { - -22, 2, -22, -21, -22, -4, -22, 1, -22, 22, - 18, -22, 8, -22, 40, -22, -22, -22, -22, -22, - -22, -22, -22, -22, -22, -22, 32, 28, -22, -22, - -22, 24, 26, -22, -22, 42, 47, -5, 49, -22, - -22, 15, -22, -22, -22, 48, -22, -22, 43, 50, - 51, -22, 17, 44, 46, 45, 52, -22, -22, -22, - -22, -22, -22, -22, -22, 56, 57, -22, 58, 60, - 61, 62, -3, -22, -22, -22, -22, 59, 63, -22, - 64, -22, -22 + -18, 2, -18, -17, -18, -4, -18, 10, -18, 22, + 8, -18, 18, -18, 39, -18, -18, -18, -18, -18, + -18, -18, -18, -18, -18, -18, 25, 21, -18, -18, + -18, 16, 14, -18, -18, 28, 36, 41, -5, -18, + -18, 5, -18, -18, -18, 47, -18, -18, 42, 46, + 48, -18, -6, 40, 43, 44, 49, -18, -18, -18, + -18, -18, -18, -18, -18, 50, -18, 51, 55, 57, + 58, 65, -18, -18, 59, 54, -18, 62, 63, 60, + -18, 64, 61, 66, -18 }; /* YYDEFACT[STATE-NUM] -- Default reduction number in state STATE-NUM. Performed when YYTABLE does not specify something else to do. Zero means the default is an error. */ static const yytype_uint8 yydefact[] = { - 2, 0, 1, 21, 20, 0, 53, 0, 51, 54, - 19, 34, 28, 52, 0, 49, 50, 3, 4, 5, + 2, 0, 1, 20, 18, 0, 53, 0, 51, 54, + 17, 33, 27, 52, 0, 49, 50, 3, 4, 5, 8, 6, 7, 10, 11, 9, 43, 0, 48, 12, - 22, 31, 0, 23, 13, 33, 0, 0, 0, 45, - 18, 0, 40, 25, 36, 0, 46, 42, 0, 0, - 0, 35, 55, 0, 0, 26, 0, 38, 37, 47, - 24, 44, 32, 41, 56, 0, 0, 14, 0, 0, - 0, 0, 55, 15, 29, 30, 27, 0, 0, 16, - 0, 17, 39 + 21, 30, 0, 22, 13, 32, 0, 0, 0, 45, + 16, 0, 40, 24, 35, 0, 46, 42, 19, 0, + 0, 34, 55, 25, 0, 0, 0, 38, 36, 47, + 23, 44, 31, 41, 56, 0, 14, 0, 0, 0, + 0, 55, 26, 28, 29, 0, 15, 0, 0, 0, + 39, 0, 0, 0, 37 }; /* YYPGOTO[NTERM-NUM]. */ static const yytype_int8 yypgoto[] = { - -22, -22, -22, -22, -22, -22, -22, -22, -22, -22, - -22, -22, -22, -9, -22, 6 + -18, -18, -18, -18, -18, -18, -18, -18, -18, -18, + -18, -18, -18, -9, -18, 7 }; /* YYDEFGOTO[NTERM-NUM]. */ static const yytype_int8 yydefgoto[] = { -1, 1, 17, 18, 19, 20, 21, 22, 23, 24, - 25, 26, 27, 28, 29, 67 + 25, 26, 27, 28, 29, 66 }; /* YYTABLE[YYPACT[STATE-NUM]] -- What to do in state STATE-NUM. If positive, shift that token. If negative, reduce the rule whose number is the opposite. If YYTABLE_NINF, syntax error. */ static const yytype_uint8 yytable[] = { - 39, 30, 2, 53, 64, 46, 3, 4, 54, 31, - 5, 6, 7, 8, 32, 9, 10, 11, 78, 12, - 13, 14, 41, 15, 64, 42, 33, 16, 56, 34, - 35, 6, 57, 8, 40, 47, 59, 65, 66, 61, - 13, 48, 36, 37, 43, 38, 49, 60, 44, 6, - 50, 8, 6, 45, 8, 51, 58, 6, 13, 8, - 52, 13, 55, 62, 63, 68, 13, 69, 70, 72, - 73, 74, 71, 75, 76, 77, 81, 82, 79, 80 + 39, 64, 2, 54, 30, 46, 3, 4, 55, 31, + 5, 6, 7, 8, 65, 9, 10, 11, 56, 12, + 13, 14, 57, 32, 40, 15, 33, 16, 47, 34, + 35, 6, 41, 8, 48, 42, 59, 49, 50, 61, + 13, 51, 36, 43, 37, 38, 60, 44, 6, 52, + 8, 6, 45, 8, 53, 58, 6, 13, 8, 62, + 13, 63, 67, 71, 72, 13, 68, 69, 73, 70, + 74, 75, 64, 77, 78, 79, 80, 82, 76, 84, + 81, 83 }; static const yytype_uint8 yycheck[] = { - 9, 22, 0, 8, 7, 14, 4, 5, 13, 13, - 8, 9, 10, 11, 13, 13, 14, 15, 21, 17, - 18, 19, 14, 21, 7, 17, 4, 25, 13, 7, - 8, 9, 17, 11, 16, 3, 45, 20, 21, 48, - 18, 13, 20, 21, 4, 23, 22, 4, 8, 9, - 24, 11, 9, 13, 11, 13, 8, 9, 18, 11, - 13, 18, 13, 13, 13, 21, 18, 21, 23, 13, - 13, 13, 20, 13, 13, 13, 13, 13, 72, 20 + 9, 7, 0, 8, 21, 14, 4, 5, 13, 13, + 8, 9, 10, 11, 20, 13, 14, 15, 13, 17, + 18, 19, 17, 13, 16, 23, 4, 25, 3, 7, + 8, 9, 14, 11, 13, 17, 45, 21, 24, 48, + 18, 13, 20, 4, 22, 23, 4, 8, 9, 13, + 11, 9, 13, 11, 13, 8, 9, 18, 11, 13, + 18, 13, 22, 13, 13, 18, 23, 23, 13, 20, + 13, 13, 7, 14, 20, 13, 13, 13, 71, 13, + 20, 20 }; /* YYSTOS[STATE-NUM] -- The (internal number of the) accessing symbol of state STATE-NUM. */ static const yytype_uint8 yystos[] = { 0, 27, 0, 4, 5, 8, 9, 10, 11, 13, - 14, 15, 17, 18, 19, 21, 25, 28, 29, 30, + 14, 15, 17, 18, 19, 23, 25, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, - 22, 13, 13, 4, 7, 8, 20, 21, 23, 39, - 16, 14, 17, 4, 8, 13, 39, 3, 13, 22, - 24, 13, 13, 8, 13, 13, 13, 17, 8, 39, - 4, 39, 13, 13, 7, 20, 21, 41, 21, 21, - 23, 20, 13, 13, 13, 13, 13, 13, 21, 41, - 20, 13, 13 + 21, 13, 13, 4, 7, 8, 20, 22, 23, 39, + 16, 14, 17, 4, 8, 13, 39, 3, 13, 21, + 24, 13, 13, 13, 8, 13, 13, 17, 8, 39, + 4, 39, 13, 13, 7, 20, 41, 22, 23, 23, + 20, 13, 13, 13, 13, 13, 41, 14, 20, 13, + 13, 20, 13, 20, 13 }; /* YYR1[YYN] -- Symbol number of symbol that rule YYN derives. */ static const yytype_uint8 yyr1[] = { 0, 26, 27, 27, 28, 28, 28, 28, 28, 28, - 28, 28, 28, 29, 29, 29, 29, 29, 30, 30, - 30, 31, 31, 31, 31, 31, 32, 32, 32, 32, - 32, 32, 32, 32, 32, 32, 33, 33, 34, 34, + 28, 28, 28, 29, 29, 29, 30, 30, 30, 30, + 31, 31, 31, 31, 31, 32, 32, 32, 32, 32, + 32, 32, 32, 32, 32, 33, 33, 34, 34, 34, 34, 35, 36, 36, 37, 37, 37, 37, 37, 38, 38, 39, 39, 39, 40, 41, 41 }; /* YYR2[YYN] -- Number of symbols on the right hand side of rule YYN. */ static const yytype_uint8 yyr2[] = { 0, 2, 0, 2, 1, 1, 1, 1, 1, 1, - 1, 1, 1, 2, 4, 5, 6, 7, 2, 1, - 1, 1, 2, 2, 3, 2, 3, 5, 1, 5, - 5, 2, 4, 2, 1, 3, 2, 3, 3, 7, + 1, 1, 1, 2, 4, 6, 2, 1, 1, 2, + 1, 2, 2, 3, 2, 3, 5, 1, 5, 5, + 2, 4, 2, 1, 3, 2, 3, 11, 3, 7, 2, 4, 2, 1, 3, 2, 2, 3, 1, 1, 1, 1, 1, 1, 1, 0, 1 }; @@ -1636,237 +1638,235 @@ break; case 15: - { - yyHour = (yyvsp[-4].Number); - yyMinutes = (yyvsp[-2].Number); - yyMeridian = MER24; - yyDSTmode = DSToff; - yyTimezone = ((yyvsp[0].Number) % 100 + ((yyvsp[0].Number) / 100) * 60); - ++yyHaveZone; - } - - break; - - case 16: - { yyHour = (yyvsp[-5].Number); yyMinutes = (yyvsp[-3].Number); yySeconds = (yyvsp[-1].Number); yyMeridian = (yyvsp[0].Meridian); } break; + case 16: + + { + yyTimezone = (yyvsp[-1].Number); + if (yyTimezone > HOUR( 12)) yyTimezone -= HOUR(100); + yyDSTmode = DSTon; + } + + break; + case 17: { - yyHour = (yyvsp[-6].Number); - yyMinutes = (yyvsp[-4].Number); - yySeconds = (yyvsp[-2].Number); - yyMeridian = MER24; + yyTimezone = (yyvsp[0].Number); + if (yyTimezone > HOUR( 12)) yyTimezone -= HOUR(100); yyDSTmode = DSToff; - yyTimezone = ((yyvsp[0].Number) % 100 + ((yyvsp[0].Number) / 100) * 60); - ++yyHaveZone; } break; case 18: { - yyTimezone = (yyvsp[-1].Number); + yyTimezone = (yyvsp[0].Number); yyDSTmode = DSTon; } break; case 19: { - yyTimezone = (yyvsp[0].Number); + yyTimezone = -(yyvsp[-1].Number)*((yyvsp[0].Number) % 100 + ((yyvsp[0].Number) / 100) * 60); yyDSTmode = DSToff; } break; case 20: { - yyTimezone = (yyvsp[0].Number); - yyDSTmode = DSTon; + yyDayOrdinal = 1; + yyDayNumber = (yyvsp[0].Number); } break; case 21: { yyDayOrdinal = 1; - yyDayNumber = (yyvsp[0].Number); + yyDayNumber = (yyvsp[-1].Number); } break; case 22: { - yyDayOrdinal = 1; - yyDayNumber = (yyvsp[-1].Number); + yyDayOrdinal = (yyvsp[-1].Number); + yyDayNumber = (yyvsp[0].Number); } break; case 23: { - yyDayOrdinal = (yyvsp[-1].Number); + yyDayOrdinal = (yyvsp[-2].Number) * (yyvsp[-1].Number); yyDayNumber = (yyvsp[0].Number); } break; case 24: { - yyDayOrdinal = (yyvsp[-2].Number) * (yyvsp[-1].Number); + yyDayOrdinal = 2; yyDayNumber = (yyvsp[0].Number); } break; case 25: - { - yyDayOrdinal = 2; - yyDayNumber = (yyvsp[0].Number); - } - - break; - - case 26: - { yyMonth = (yyvsp[-2].Number); yyDay = (yyvsp[0].Number); } break; - case 27: + case 26: { yyMonth = (yyvsp[-4].Number); yyDay = (yyvsp[-2].Number); yyYear = (yyvsp[0].Number); } break; - case 28: + case 27: { yyYear = (yyvsp[0].Number) / 10000; yyMonth = ((yyvsp[0].Number) % 10000)/100; yyDay = (yyvsp[0].Number) % 100; } break; - case 29: + case 28: { yyDay = (yyvsp[-4].Number); yyMonth = (yyvsp[-2].Number); yyYear = (yyvsp[0].Number); } break; - case 30: + case 29: { yyMonth = (yyvsp[-2].Number); yyDay = (yyvsp[0].Number); yyYear = (yyvsp[-4].Number); } break; - case 31: + case 30: { yyMonth = (yyvsp[-1].Number); yyDay = (yyvsp[0].Number); } break; - case 32: + case 31: { yyMonth = (yyvsp[-3].Number); yyDay = (yyvsp[-2].Number); yyYear = (yyvsp[0].Number); } break; - case 33: + case 32: { yyMonth = (yyvsp[0].Number); yyDay = (yyvsp[-1].Number); } break; - case 34: + case 33: { yyMonth = 1; yyDay = 1; yyYear = EPOCH; } break; - case 35: + case 34: { yyMonth = (yyvsp[-1].Number); yyDay = (yyvsp[-2].Number); yyYear = (yyvsp[0].Number); } break; - case 36: + case 35: { yyMonthOrdinal = 1; yyMonth = (yyvsp[0].Number); } break; - case 37: + case 36: { yyMonthOrdinal = (yyvsp[-1].Number); yyMonth = (yyvsp[0].Number); } break; + case 37: + + { + if ((yyvsp[-5].Number) != HOUR( 7) + HOUR(100)) YYABORT; + yyYear = (yyvsp[-10].Number); + yyMonth = (yyvsp[-8].Number); + yyDay = (yyvsp[-6].Number); + yyHour = (yyvsp[-4].Number); + yyMinutes = (yyvsp[-2].Number); + yySeconds = (yyvsp[0].Number); + } + + break; + case 38: { - if ((yyvsp[-1].Number) != HOUR( 7)) YYABORT; + if ((yyvsp[-1].Number) != HOUR( 7) + HOUR(100)) YYABORT; yyYear = (yyvsp[-2].Number) / 10000; yyMonth = ((yyvsp[-2].Number) % 10000)/100; yyDay = (yyvsp[-2].Number) % 100; yyHour = (yyvsp[0].Number) / 10000; yyMinutes = ((yyvsp[0].Number) % 10000)/100; @@ -1876,11 +1876,11 @@ break; case 39: { - if ((yyvsp[-5].Number) != HOUR( 7)) YYABORT; + if ((yyvsp[-5].Number) != HOUR( 7) + HOUR(100)) YYABORT; yyYear = (yyvsp[-6].Number) / 10000; yyMonth = ((yyvsp[-6].Number) % 10000)/100; yyDay = (yyvsp[-6].Number) % 100; yyHour = (yyvsp[-4].Number); yyMinutes = (yyvsp[-2].Number); @@ -2457,35 +2457,35 @@ /* * Military timezone table. */ static const TABLE MilitaryTable[] = { - { "a", tZONE, -HOUR( 1) }, - { "b", tZONE, -HOUR( 2) }, - { "c", tZONE, -HOUR( 3) }, - { "d", tZONE, -HOUR( 4) }, - { "e", tZONE, -HOUR( 5) }, - { "f", tZONE, -HOUR( 6) }, - { "g", tZONE, -HOUR( 7) }, - { "h", tZONE, -HOUR( 8) }, - { "i", tZONE, -HOUR( 9) }, - { "k", tZONE, -HOUR(10) }, - { "l", tZONE, -HOUR(11) }, - { "m", tZONE, -HOUR(12) }, - { "n", tZONE, HOUR( 1) }, - { "o", tZONE, HOUR( 2) }, - { "p", tZONE, HOUR( 3) }, - { "q", tZONE, HOUR( 4) }, - { "r", tZONE, HOUR( 5) }, - { "s", tZONE, HOUR( 6) }, - { "t", tZONE, HOUR( 7) }, - { "u", tZONE, HOUR( 8) }, - { "v", tZONE, HOUR( 9) }, - { "w", tZONE, HOUR( 10) }, - { "x", tZONE, HOUR( 11) }, - { "y", tZONE, HOUR( 12) }, - { "z", tZONE, HOUR( 0) }, + { "a", tZONE, -HOUR( 1) + HOUR(100) }, + { "b", tZONE, -HOUR( 2) + HOUR(100) }, + { "c", tZONE, -HOUR( 3) + HOUR(100) }, + { "d", tZONE, -HOUR( 4) + HOUR(100) }, + { "e", tZONE, -HOUR( 5) + HOUR(100) }, + { "f", tZONE, -HOUR( 6) + HOUR(100) }, + { "g", tZONE, -HOUR( 7) + HOUR(100) }, + { "h", tZONE, -HOUR( 8) + HOUR(100) }, + { "i", tZONE, -HOUR( 9) + HOUR(100) }, + { "k", tZONE, -HOUR(10) + HOUR(100) }, + { "l", tZONE, -HOUR(11) + HOUR(100) }, + { "m", tZONE, -HOUR(12) + HOUR(100) }, + { "n", tZONE, HOUR( 1) + HOUR(100) }, + { "o", tZONE, HOUR( 2) + HOUR(100) }, + { "p", tZONE, HOUR( 3) + HOUR(100) }, + { "q", tZONE, HOUR( 4) + HOUR(100) }, + { "r", tZONE, HOUR( 5) + HOUR(100) }, + { "s", tZONE, HOUR( 6) + HOUR(100) }, + { "t", tZONE, HOUR( 7) + HOUR(100) }, + { "u", tZONE, HOUR( 8) + HOUR(100) }, + { "v", tZONE, HOUR( 9) + HOUR(100) }, + { "w", tZONE, HOUR( 10) + HOUR(100) }, + { "x", tZONE, HOUR( 11) + HOUR(100) }, + { "y", tZONE, HOUR( 12) + HOUR(100) }, + { "z", tZONE, HOUR( 0) + HOUR(100) }, { NULL, 0, 0 } }; /* * Dump error messages in the bit bucket. @@ -2499,16 +2499,16 @@ { Tcl_Obj* t; Tcl_AppendToObj(infoPtr->messages, infoPtr->separatrix, -1); Tcl_AppendToObj(infoPtr->messages, s, -1); Tcl_AppendToObj(infoPtr->messages, " (characters ", -1); - t = Tcl_NewIntObj(location->first_column); + TclNewIntObj(t, location->first_column); Tcl_IncrRefCount(t); Tcl_AppendObjToObj(infoPtr->messages, t); Tcl_DecrRefCount(t); Tcl_AppendToObj(infoPtr->messages, "-", -1); - t = Tcl_NewIntObj(location->last_column); + TclNewIntObj(t, location->last_column); Tcl_IncrRefCount(t); Tcl_AppendObjToObj(infoPtr->messages, t); Tcl_DecrRefCount(t); Tcl_AppendToObj(infoPtr->messages, ")", -1); infoPtr->separatrix = "\n"; @@ -2547,13 +2547,13 @@ static int LookupWord( YYSTYPE* yylvalPtr, char *buff) { - register char *p; - register char *q; - register const TABLE *tp; + char *p; + char *q; + const TABLE *tp; int i, abbrev; /* * Make it lowercase. */ @@ -2672,18 +2672,18 @@ TclDatelex( YYSTYPE* yylvalPtr, YYLTYPE* location, DateInfo *info) { - register char c; - register char *p; + char c; + char *p; char buff[20]; int Count; location->first_column = yyInput - info->dateStart; for ( ; ; ) { - while (TclIsSpaceProc(UCHAR(*yyInput))) { + while (TclIsSpaceProcM(*yyInput)) { yyInput++; } if (isdigit(UCHAR(c = *yyInput))) { /* INTL: digit */ /* @@ -2742,28 +2742,29 @@ } } int TclClockOldscanObjCmd( - void *clientData, /* Unused */ + void *dummy, /* Unused */ Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Count of paraneters */ Tcl_Obj *const *objv) /* Parameters */ { Tcl_Obj *result, *resultElement; int yr, mo, da; DateInfo dateInfo; DateInfo* info = &dateInfo; int status; + (void)dummy; if (objc != 5) { Tcl_WrongNumArgs(interp, 1, objv, "stringToParse baseYear baseMonth baseDay" ); return TCL_ERROR; } - yyInput = TclGetString(objv[1]); + yyInput = Tcl_GetString( objv[1] ); dateInfo.dateStart = yyInput; yyHaveDate = 0; if (Tcl_GetIntFromObj(interp, objv[2], &yr) != TCL_OK || Tcl_GetIntFromObj(interp, objv[3], &mo) != TCL_OK @@ -2785,11 +2786,11 @@ yyDayOrdinal = 0; yyDayNumber = 0; yyHaveRel = 0; yyRelMonth = 0; yyRelDay = 0; yyRelSeconds = 0; yyRelPointer = NULL; - dateInfo.messages = Tcl_NewObj(); + TclNewObj(dateInfo.messages); dateInfo.separatrix = ""; Tcl_IncrRefCount(dateInfo.messages); status = yyparse(&dateInfo); if (status == 1) { @@ -2842,64 +2843,64 @@ Tcl_NewStringObj("more than one ordinal month in string", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } - result = Tcl_NewObj(); - resultElement = Tcl_NewObj(); + TclNewObj(result); + TclNewObj(resultElement); if (yyHaveDate) { Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyYear)); + Tcl_NewIntObj((int) yyYear)); Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyMonth)); + Tcl_NewIntObj((int) yyMonth)); Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyDay)); + Tcl_NewIntObj((int) yyDay)); } Tcl_ListObjAppendElement(interp, result, resultElement); if (yyHaveTime) { - Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj( - ToSeconds(yyHour, yyMinutes, yySeconds, yyMeridian))); + Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj((int) + ToSeconds(yyHour, yyMinutes, yySeconds, (MERIDIAN)yyMeridian))); } else { Tcl_ListObjAppendElement(interp, result, Tcl_NewObj()); } - resultElement = Tcl_NewObj(); + TclNewObj(resultElement); if (yyHaveZone) { Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(-yyTimezone)); + Tcl_NewIntObj((int) -yyTimezone)); Tcl_ListObjAppendElement(interp, resultElement, Tcl_NewIntObj(1 - yyDSTmode)); } Tcl_ListObjAppendElement(interp, result, resultElement); - resultElement = Tcl_NewObj(); - if (yyHaveRel) { - Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyRelMonth)); - Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyRelDay)); - Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyRelSeconds)); - } - Tcl_ListObjAppendElement(interp, result, resultElement); - - resultElement = Tcl_NewObj(); - if (yyHaveDay && !yyHaveDate) { - Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyDayOrdinal)); - Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyDayNumber)); - } - Tcl_ListObjAppendElement(interp, result, resultElement); - - resultElement = Tcl_NewObj(); - if (yyHaveOrdinalMonth) { - Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyMonthOrdinal)); - Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyMonth)); + TclNewObj(resultElement); + if (yyHaveRel) { + Tcl_ListObjAppendElement(interp, resultElement, + Tcl_NewIntObj((int) yyRelMonth)); + Tcl_ListObjAppendElement(interp, resultElement, + Tcl_NewIntObj((int) yyRelDay)); + Tcl_ListObjAppendElement(interp, resultElement, + Tcl_NewIntObj((int) yyRelSeconds)); + } + Tcl_ListObjAppendElement(interp, result, resultElement); + + TclNewObj(resultElement); + if (yyHaveDay && !yyHaveDate) { + Tcl_ListObjAppendElement(interp, resultElement, + Tcl_NewIntObj((int) yyDayOrdinal)); + Tcl_ListObjAppendElement(interp, resultElement, + Tcl_NewIntObj((int) yyDayNumber)); + } + Tcl_ListObjAppendElement(interp, result, resultElement); + + TclNewObj(resultElement); + if (yyHaveOrdinalMonth) { + Tcl_ListObjAppendElement(interp, resultElement, + Tcl_NewIntObj((int) yyMonthOrdinal)); + Tcl_ListObjAppendElement(interp, resultElement, + Tcl_NewIntObj((int) yyMonth)); } Tcl_ListObjAppendElement(interp, result, resultElement); Tcl_SetObjResult(interp, result); return TCL_OK; Index: generic/tclDecls.h ================================================================== --- generic/tclDecls.h +++ generic/tclDecls.h @@ -20,19 +20,10 @@ # define TCL_STORAGE_CLASS # else # define TCL_STORAGE_CLASS DLLIMPORT # endif #endif - -#if !defined(BUILD_tcl) -# define TCL_DEPRECATED(msg) EXTERN TCL_DEPRECATED_API(msg) -#elif defined(TCL_NO_DEPRECATED) -# define TCL_DEPRECATED(msg) MODULE_SCOPE -#else -# define TCL_DEPRECATED(msg) EXTERN -#endif - /* * 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/tcl.decls script. @@ -51,38 +42,38 @@ /* 0 */ EXTERN int Tcl_PkgProvideEx(Tcl_Interp *interp, const char *name, const char *version, const void *clientData); /* 1 */ -EXTERN const char * Tcl_PkgRequireEx(Tcl_Interp *interp, +EXTERN CONST84_RETURN char * Tcl_PkgRequireEx(Tcl_Interp *interp, 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 char * Tcl_Alloc(unsigned int size); /* 4 */ -EXTERN void Tcl_Free(void *ptr); +EXTERN void Tcl_Free(char *ptr); /* 5 */ -EXTERN void * Tcl_Realloc(void *ptr, size_t size); +EXTERN char * Tcl_Realloc(char *ptr, unsigned int size); /* 6 */ -EXTERN void * Tcl_DbCkalloc(size_t size, const char *file, +EXTERN char * Tcl_DbCkalloc(unsigned int size, const char *file, int line); /* 7 */ -EXTERN void Tcl_DbCkfree(void *ptr, const char *file, int line); +EXTERN void Tcl_DbCkfree(char *ptr, const char *file, int line); /* 8 */ -EXTERN void * Tcl_DbCkrealloc(void *ptr, size_t size, +EXTERN char * Tcl_DbCkrealloc(char *ptr, unsigned int size, const char *file, int line); #if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ /* 9 */ EXTERN void Tcl_CreateFileHandler(int fd, int mask, - Tcl_FileProc *proc, void *clientData); + Tcl_FileProc *proc, ClientData clientData); #endif /* UNIX */ #ifdef MAC_OSX_TCL /* MACOSX */ /* 9 */ EXTERN void Tcl_CreateFileHandler(int fd, int mask, - Tcl_FileProc *proc, void *clientData); + Tcl_FileProc *proc, ClientData clientData); #endif /* MACOSX */ #if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ /* 10 */ EXTERN void Tcl_DeleteFileHandler(int fd); #endif /* UNIX */ @@ -101,11 +92,11 @@ Tcl_Obj *objPtr); /* 15 */ EXTERN void Tcl_AppendStringsToObj(Tcl_Obj *objPtr, ...); /* 16 */ EXTERN void Tcl_AppendToObj(Tcl_Obj *objPtr, const char *bytes, - size_t length); + int length); /* 17 */ EXTERN Tcl_Obj * Tcl_ConcatObj(int objc, Tcl_Obj *const objv[]); /* 18 */ EXTERN int Tcl_ConvertToType(Tcl_Interp *interp, Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); @@ -116,29 +107,34 @@ EXTERN void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, const char *file, int line); /* 21 */ EXTERN int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, int line); -/* Slot 22 is reserved */ +/* 22 */ +EXTERN Tcl_Obj * Tcl_DbNewBooleanObj(int boolValue, const char *file, + int line); /* 23 */ EXTERN Tcl_Obj * Tcl_DbNewByteArrayObj(const unsigned char *bytes, - size_t length, const char *file, int line); + int length, const char *file, int line); /* 24 */ EXTERN Tcl_Obj * Tcl_DbNewDoubleObj(double doubleValue, const char *file, int line); /* 25 */ EXTERN Tcl_Obj * Tcl_DbNewListObj(int objc, Tcl_Obj *const *objv, const char *file, int line); -/* Slot 26 is reserved */ +/* 26 */ +EXTERN Tcl_Obj * Tcl_DbNewLongObj(long longValue, const char *file, + int line); /* 27 */ EXTERN Tcl_Obj * Tcl_DbNewObj(const char *file, int line); /* 28 */ -EXTERN Tcl_Obj * Tcl_DbNewStringObj(const char *bytes, size_t length, +EXTERN Tcl_Obj * Tcl_DbNewStringObj(const char *bytes, int length, const char *file, int line); /* 29 */ EXTERN Tcl_Obj * Tcl_DuplicateObj(Tcl_Obj *objPtr); -/* Slot 30 is reserved */ +/* 30 */ +EXTERN void TclFreeObj(Tcl_Obj *objPtr); /* 31 */ EXTERN int Tcl_GetBoolean(Tcl_Interp *interp, const char *src, int *boolPtr); /* 32 */ EXTERN int Tcl_GetBooleanFromObj(Tcl_Interp *interp, @@ -150,11 +146,15 @@ EXTERN int Tcl_GetDouble(Tcl_Interp *interp, const char *src, double *doublePtr); /* 35 */ EXTERN int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); -/* Slot 36 is reserved */ +/* 36 */ +EXTERN int Tcl_GetIndexFromObj(Tcl_Interp *interp, + Tcl_Obj *objPtr, + CONST84 char *const *tablePtr, + const char *msg, int flags, int *indexPtr); /* 37 */ EXTERN int Tcl_GetInt(Tcl_Interp *interp, const char *src, int *intPtr); /* 38 */ EXTERN int Tcl_GetIntFromObj(Tcl_Interp *interp, @@ -161,11 +161,11 @@ Tcl_Obj *objPtr, int *intPtr); /* 39 */ EXTERN int Tcl_GetLongFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr); /* 40 */ -EXTERN const Tcl_ObjType * Tcl_GetObjType(const char *typeName); +EXTERN CONST86 Tcl_ObjType * Tcl_GetObjType(const char *typeName); /* 41 */ EXTERN char * Tcl_GetStringFromObj(Tcl_Obj *objPtr, int *lengthPtr); /* 42 */ EXTERN void Tcl_InvalidateStringRep(Tcl_Obj *objPtr); /* 43 */ @@ -187,161 +187,178 @@ Tcl_Obj *listPtr, int *lengthPtr); /* 48 */ EXTERN int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *const objv[]); -/* Slot 49 is reserved */ +/* 49 */ +EXTERN Tcl_Obj * Tcl_NewBooleanObj(int boolValue); /* 50 */ EXTERN Tcl_Obj * Tcl_NewByteArrayObj(const unsigned char *bytes, - size_t length); + int length); /* 51 */ EXTERN Tcl_Obj * Tcl_NewDoubleObj(double doubleValue); -/* Slot 52 is reserved */ +/* 52 */ +EXTERN Tcl_Obj * Tcl_NewIntObj(int intValue); /* 53 */ EXTERN Tcl_Obj * Tcl_NewListObj(int objc, Tcl_Obj *const objv[]); -/* Slot 54 is reserved */ +/* 54 */ +EXTERN Tcl_Obj * Tcl_NewLongObj(long longValue); /* 55 */ EXTERN Tcl_Obj * Tcl_NewObj(void); /* 56 */ -EXTERN Tcl_Obj * Tcl_NewStringObj(const char *bytes, size_t length); -/* Slot 57 is reserved */ +EXTERN Tcl_Obj * Tcl_NewStringObj(const char *bytes, int length); +/* 57 */ +EXTERN void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue); /* 58 */ -EXTERN unsigned char * Tcl_SetByteArrayLength(Tcl_Obj *objPtr, - size_t length); +EXTERN unsigned char * Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int length); /* 59 */ EXTERN void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, - const unsigned char *bytes, size_t length); + const unsigned char *bytes, int length); /* 60 */ EXTERN void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue); -/* Slot 61 is reserved */ +/* 61 */ +EXTERN void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue); /* 62 */ EXTERN void Tcl_SetListObj(Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]); -/* Slot 63 is reserved */ +/* 63 */ +EXTERN void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue); /* 64 */ -EXTERN void Tcl_SetObjLength(Tcl_Obj *objPtr, size_t length); +EXTERN void Tcl_SetObjLength(Tcl_Obj *objPtr, int length); /* 65 */ EXTERN void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, - size_t length); -/* Slot 66 is reserved */ -/* Slot 67 is reserved */ + int length); +/* 66 */ +EXTERN void Tcl_AddErrorInfo(Tcl_Interp *interp, + const char *message); +/* 67 */ +EXTERN void Tcl_AddObjErrorInfo(Tcl_Interp *interp, + const char *message, int length); /* 68 */ EXTERN void Tcl_AllowExceptions(Tcl_Interp *interp); /* 69 */ EXTERN void Tcl_AppendElement(Tcl_Interp *interp, const char *element); /* 70 */ EXTERN void Tcl_AppendResult(Tcl_Interp *interp, ...); /* 71 */ EXTERN Tcl_AsyncHandler Tcl_AsyncCreate(Tcl_AsyncProc *proc, - void *clientData); + ClientData clientData); /* 72 */ EXTERN void Tcl_AsyncDelete(Tcl_AsyncHandler async); /* 73 */ EXTERN int Tcl_AsyncInvoke(Tcl_Interp *interp, int code); /* 74 */ EXTERN void Tcl_AsyncMark(Tcl_AsyncHandler async); /* 75 */ EXTERN int Tcl_AsyncReady(void); -/* Slot 76 is reserved */ -/* Slot 77 is reserved */ +/* 76 */ +EXTERN void Tcl_BackgroundError(Tcl_Interp *interp); +/* 77 */ +EXTERN char Tcl_Backslash(const char *src, int *readPtr); /* 78 */ EXTERN int Tcl_BadChannelOption(Tcl_Interp *interp, const char *optionName, const char *optionList); /* 79 */ EXTERN void Tcl_CallWhenDeleted(Tcl_Interp *interp, - Tcl_InterpDeleteProc *proc, void *clientData); + Tcl_InterpDeleteProc *proc, + ClientData clientData); /* 80 */ EXTERN void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc, - void *clientData); + ClientData clientData); /* 81 */ EXTERN int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan); /* 82 */ EXTERN int Tcl_CommandComplete(const char *cmd); /* 83 */ -EXTERN char * Tcl_Concat(int argc, const char *const *argv); +EXTERN char * Tcl_Concat(int argc, CONST84 char *const *argv); /* 84 */ -EXTERN size_t Tcl_ConvertElement(const char *src, char *dst, +EXTERN int Tcl_ConvertElement(const char *src, char *dst, int flags); /* 85 */ -EXTERN size_t Tcl_ConvertCountedElement(const char *src, - size_t length, char *dst, int flags); +EXTERN int Tcl_ConvertCountedElement(const char *src, + int length, char *dst, int flags); /* 86 */ -EXTERN int Tcl_CreateAlias(Tcl_Interp *slave, - const char *slaveCmd, Tcl_Interp *target, +EXTERN int Tcl_CreateAlias(Tcl_Interp *childInterp, + const char *childCmd, Tcl_Interp *target, const char *targetCmd, int argc, - const char *const *argv); + CONST84 char *const *argv); /* 87 */ -EXTERN int Tcl_CreateAliasObj(Tcl_Interp *slave, - const char *slaveCmd, Tcl_Interp *target, +EXTERN int Tcl_CreateAliasObj(Tcl_Interp *childInterp, + const char *childCmd, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]); /* 88 */ EXTERN Tcl_Channel Tcl_CreateChannel(const Tcl_ChannelType *typePtr, - const char *chanName, void *instanceData, - int mask); + const char *chanName, + ClientData instanceData, int mask); /* 89 */ EXTERN void Tcl_CreateChannelHandler(Tcl_Channel chan, int mask, - Tcl_ChannelProc *proc, void *clientData); + Tcl_ChannelProc *proc, ClientData clientData); /* 90 */ EXTERN void Tcl_CreateCloseHandler(Tcl_Channel chan, - Tcl_CloseProc *proc, void *clientData); + Tcl_CloseProc *proc, ClientData clientData); /* 91 */ EXTERN Tcl_Command Tcl_CreateCommand(Tcl_Interp *interp, const char *cmdName, Tcl_CmdProc *proc, - void *clientData, + ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 92 */ EXTERN void Tcl_CreateEventSource(Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, - void *clientData); + ClientData clientData); /* 93 */ EXTERN void Tcl_CreateExitHandler(Tcl_ExitProc *proc, - void *clientData); + ClientData clientData); /* 94 */ EXTERN Tcl_Interp * Tcl_CreateInterp(void); -/* Slot 95 is reserved */ +/* 95 */ +EXTERN void Tcl_CreateMathFunc(Tcl_Interp *interp, + const char *name, int numArgs, + Tcl_ValueType *argTypes, Tcl_MathProc *proc, + ClientData clientData); /* 96 */ EXTERN Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, - void *clientData, + ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 97 */ -EXTERN Tcl_Interp * Tcl_CreateSlave(Tcl_Interp *interp, - const char *slaveName, int isSafe); +EXTERN Tcl_Interp * Tcl_CreateSlave(Tcl_Interp *interp, const char *name, + int isSafe); /* 98 */ EXTERN Tcl_TimerToken Tcl_CreateTimerHandler(int milliseconds, - Tcl_TimerProc *proc, void *clientData); + Tcl_TimerProc *proc, ClientData clientData); /* 99 */ EXTERN Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, int level, - Tcl_CmdTraceProc *proc, void *clientData); + Tcl_CmdTraceProc *proc, + ClientData clientData); /* 100 */ EXTERN void Tcl_DeleteAssocData(Tcl_Interp *interp, const char *name); /* 101 */ EXTERN void Tcl_DeleteChannelHandler(Tcl_Channel chan, - Tcl_ChannelProc *proc, void *clientData); + Tcl_ChannelProc *proc, ClientData clientData); /* 102 */ EXTERN void Tcl_DeleteCloseHandler(Tcl_Channel chan, - Tcl_CloseProc *proc, void *clientData); + Tcl_CloseProc *proc, ClientData clientData); /* 103 */ EXTERN int Tcl_DeleteCommand(Tcl_Interp *interp, const char *cmdName); /* 104 */ EXTERN int Tcl_DeleteCommandFromToken(Tcl_Interp *interp, Tcl_Command command); /* 105 */ EXTERN void Tcl_DeleteEvents(Tcl_EventDeleteProc *proc, - void *clientData); + ClientData clientData); /* 106 */ EXTERN void Tcl_DeleteEventSource(Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, - void *clientData); + ClientData clientData); /* 107 */ EXTERN void Tcl_DeleteExitHandler(Tcl_ExitProc *proc, - void *clientData); + ClientData clientData); /* 108 */ EXTERN void Tcl_DeleteHashEntry(Tcl_HashEntry *entryPtr); /* 109 */ EXTERN void Tcl_DeleteHashTable(Tcl_HashTable *tablePtr); /* 110 */ @@ -352,18 +369,20 @@ EXTERN void Tcl_DeleteTimerHandler(Tcl_TimerToken token); /* 113 */ EXTERN void Tcl_DeleteTrace(Tcl_Interp *interp, Tcl_Trace trace); /* 114 */ EXTERN void Tcl_DontCallWhenDeleted(Tcl_Interp *interp, - Tcl_InterpDeleteProc *proc, void *clientData); + Tcl_InterpDeleteProc *proc, + ClientData clientData); /* 115 */ EXTERN int Tcl_DoOneEvent(int flags); /* 116 */ -EXTERN void Tcl_DoWhenIdle(Tcl_IdleProc *proc, void *clientData); +EXTERN void Tcl_DoWhenIdle(Tcl_IdleProc *proc, + ClientData clientData); /* 117 */ EXTERN char * Tcl_DStringAppend(Tcl_DString *dsPtr, - const char *bytes, size_t length); + const char *bytes, int length); /* 118 */ EXTERN char * Tcl_DStringAppendElement(Tcl_DString *dsPtr, const char *element); /* 119 */ EXTERN void Tcl_DStringEndSublist(Tcl_DString *dsPtr); @@ -376,27 +395,28 @@ EXTERN void Tcl_DStringInit(Tcl_DString *dsPtr); /* 123 */ EXTERN void Tcl_DStringResult(Tcl_Interp *interp, Tcl_DString *dsPtr); /* 124 */ -EXTERN void Tcl_DStringSetLength(Tcl_DString *dsPtr, - size_t length); +EXTERN void Tcl_DStringSetLength(Tcl_DString *dsPtr, int length); /* 125 */ EXTERN void Tcl_DStringStartSublist(Tcl_DString *dsPtr); /* 126 */ EXTERN int Tcl_Eof(Tcl_Channel chan); /* 127 */ -EXTERN const char * Tcl_ErrnoId(void); +EXTERN CONST84_RETURN char * Tcl_ErrnoId(void); /* 128 */ -EXTERN const char * Tcl_ErrnoMsg(int err); -/* Slot 129 is reserved */ +EXTERN CONST84_RETURN char * Tcl_ErrnoMsg(int err); +/* 129 */ +EXTERN int Tcl_Eval(Tcl_Interp *interp, const char *script); /* 130 */ EXTERN int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName); -/* Slot 131 is reserved */ +/* 131 */ +EXTERN int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 132 */ -EXTERN void Tcl_EventuallyFree(void *clientData, +EXTERN void Tcl_EventuallyFree(ClientData clientData, Tcl_FreeProc *freeProc); /* 133 */ EXTERN TCL_NORETURN void Tcl_Exit(int status); /* 134 */ EXTERN int Tcl_ExposeCommand(Tcl_Interp *interp, @@ -425,67 +445,68 @@ Tcl_Obj **resultPtrPtr); /* 142 */ EXTERN int Tcl_ExprString(Tcl_Interp *interp, const char *expr); /* 143 */ EXTERN void Tcl_Finalize(void); -/* Slot 144 is reserved */ +/* 144 */ +EXTERN void Tcl_FindExecutable(const char *argv0); /* 145 */ EXTERN Tcl_HashEntry * Tcl_FirstHashEntry(Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 146 */ EXTERN int Tcl_Flush(Tcl_Channel chan); /* 147 */ EXTERN void Tcl_FreeResult(Tcl_Interp *interp); /* 148 */ EXTERN int Tcl_GetAlias(Tcl_Interp *interp, - const char *slaveCmd, + const char *childCmd, Tcl_Interp **targetInterpPtr, - const char **targetCmdPtr, int *argcPtr, - const char ***argvPtr); + CONST84 char **targetCmdPtr, int *argcPtr, + CONST84 char ***argvPtr); /* 149 */ EXTERN int Tcl_GetAliasObj(Tcl_Interp *interp, - const char *slaveCmd, + const char *childCmd, Tcl_Interp **targetInterpPtr, - const char **targetCmdPtr, int *objcPtr, + CONST84 char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 150 */ -EXTERN void * Tcl_GetAssocData(Tcl_Interp *interp, +EXTERN ClientData Tcl_GetAssocData(Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr); /* 151 */ EXTERN Tcl_Channel Tcl_GetChannel(Tcl_Interp *interp, const char *chanName, int *modePtr); /* 152 */ EXTERN int Tcl_GetChannelBufferSize(Tcl_Channel chan); /* 153 */ EXTERN int Tcl_GetChannelHandle(Tcl_Channel chan, int direction, - void **handlePtr); + ClientData *handlePtr); /* 154 */ -EXTERN void * Tcl_GetChannelInstanceData(Tcl_Channel chan); +EXTERN ClientData Tcl_GetChannelInstanceData(Tcl_Channel chan); /* 155 */ EXTERN int Tcl_GetChannelMode(Tcl_Channel chan); /* 156 */ -EXTERN const char * Tcl_GetChannelName(Tcl_Channel chan); +EXTERN CONST84_RETURN char * Tcl_GetChannelName(Tcl_Channel chan); /* 157 */ EXTERN int Tcl_GetChannelOption(Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, Tcl_DString *dsPtr); /* 158 */ -EXTERN const Tcl_ChannelType * Tcl_GetChannelType(Tcl_Channel chan); +EXTERN CONST86 Tcl_ChannelType * Tcl_GetChannelType(Tcl_Channel chan); /* 159 */ EXTERN int Tcl_GetCommandInfo(Tcl_Interp *interp, const char *cmdName, Tcl_CmdInfo *infoPtr); /* 160 */ -EXTERN const char * Tcl_GetCommandName(Tcl_Interp *interp, +EXTERN CONST84_RETURN char * Tcl_GetCommandName(Tcl_Interp *interp, Tcl_Command command); /* 161 */ EXTERN int Tcl_GetErrno(void); /* 162 */ -EXTERN const char * Tcl_GetHostName(void); +EXTERN CONST84_RETURN char * Tcl_GetHostName(void); /* 163 */ -EXTERN int Tcl_GetInterpPath(Tcl_Interp *askInterp, - Tcl_Interp *slaveInterp); +EXTERN int Tcl_GetInterpPath(Tcl_Interp *interp, + Tcl_Interp *childInterp); /* 164 */ EXTERN Tcl_Interp * Tcl_GetMaster(Tcl_Interp *interp); /* 165 */ EXTERN const char * Tcl_GetNameOfExecutable(void); /* 166 */ @@ -492,38 +513,45 @@ EXTERN Tcl_Obj * Tcl_GetObjResult(Tcl_Interp *interp); #if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ /* 167 */ EXTERN int Tcl_GetOpenFile(Tcl_Interp *interp, const char *chanID, int forWriting, - int checkUsage, void **filePtr); + int checkUsage, ClientData *filePtr); #endif /* UNIX */ #ifdef MAC_OSX_TCL /* MACOSX */ /* 167 */ EXTERN int Tcl_GetOpenFile(Tcl_Interp *interp, const char *chanID, int forWriting, - int checkUsage, void **filePtr); + int checkUsage, ClientData *filePtr); #endif /* MACOSX */ /* 168 */ EXTERN Tcl_PathType Tcl_GetPathType(const char *path); /* 169 */ -EXTERN size_t Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr); +EXTERN int Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr); /* 170 */ -EXTERN size_t Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr); +EXTERN int Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr); /* 171 */ EXTERN int Tcl_GetServiceMode(void); /* 172 */ -EXTERN Tcl_Interp * Tcl_GetSlave(Tcl_Interp *interp, - const char *slaveName); +EXTERN Tcl_Interp * Tcl_GetSlave(Tcl_Interp *interp, const char *name); /* 173 */ EXTERN Tcl_Channel Tcl_GetStdChannel(int type); -/* Slot 174 is reserved */ -/* Slot 175 is reserved */ +/* 174 */ +EXTERN CONST84_RETURN char * Tcl_GetStringResult(Tcl_Interp *interp); +/* 175 */ +EXTERN CONST84_RETURN char * Tcl_GetVar(Tcl_Interp *interp, + const char *varName, int flags); /* 176 */ -EXTERN const char * Tcl_GetVar2(Tcl_Interp *interp, const char *part1, - const char *part2, int flags); -/* Slot 177 is reserved */ -/* Slot 178 is reserved */ +EXTERN CONST84_RETURN char * Tcl_GetVar2(Tcl_Interp *interp, + const char *part1, const char *part2, + int flags); +/* 177 */ +EXTERN int Tcl_GlobalEval(Tcl_Interp *interp, + const char *command); +/* 178 */ +EXTERN int Tcl_GlobalEvalObj(Tcl_Interp *interp, + Tcl_Obj *objPtr); /* 179 */ EXTERN int Tcl_HideCommand(Tcl_Interp *interp, const char *cmdName, const char *hiddenCmdToken); /* 180 */ @@ -538,24 +566,24 @@ /* 184 */ EXTERN int Tcl_InterpDeleted(Tcl_Interp *interp); /* 185 */ EXTERN int Tcl_IsSafe(Tcl_Interp *interp); /* 186 */ -EXTERN char * Tcl_JoinPath(int argc, const char *const *argv, +EXTERN char * Tcl_JoinPath(int argc, CONST84 char *const *argv, Tcl_DString *resultPtr); /* 187 */ EXTERN int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, - void *addr, int type); + char *addr, int type); /* Slot 188 is reserved */ /* 189 */ -EXTERN Tcl_Channel Tcl_MakeFileChannel(void *handle, int mode); +EXTERN Tcl_Channel Tcl_MakeFileChannel(ClientData handle, int mode); /* 190 */ EXTERN int Tcl_MakeSafe(Tcl_Interp *interp); /* 191 */ -EXTERN Tcl_Channel Tcl_MakeTcpClientChannel(void *tcpSocket); +EXTERN Tcl_Channel Tcl_MakeTcpClientChannel(ClientData tcpSocket); /* 192 */ -EXTERN char * Tcl_Merge(int argc, const char *const *argv); +EXTERN char * Tcl_Merge(int argc, CONST84 char *const *argv); /* 193 */ EXTERN Tcl_HashEntry * Tcl_NextHashEntry(Tcl_HashSearch *searchPtr); /* 194 */ EXTERN void Tcl_NotifyChannel(Tcl_Channel channel, int mask); /* 195 */ @@ -565,11 +593,11 @@ EXTERN Tcl_Obj * Tcl_ObjSetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags); /* 197 */ EXTERN Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, int argc, - const char **argv, int flags); + CONST84 char **argv, int flags); /* 198 */ EXTERN Tcl_Channel Tcl_OpenFileChannel(Tcl_Interp *interp, const char *fileName, const char *modeString, int permissions); /* 199 */ @@ -578,26 +606,25 @@ int myport, int async); /* 200 */ EXTERN Tcl_Channel Tcl_OpenTcpServer(Tcl_Interp *interp, int port, const char *host, Tcl_TcpAcceptProc *acceptProc, - void *callbackData); + ClientData callbackData); /* 201 */ -EXTERN void Tcl_Preserve(void *data); +EXTERN void Tcl_Preserve(ClientData data); /* 202 */ EXTERN void Tcl_PrintDouble(Tcl_Interp *interp, double value, char *dst); /* 203 */ EXTERN int Tcl_PutEnv(const char *assignment); /* 204 */ -EXTERN const char * Tcl_PosixError(Tcl_Interp *interp); +EXTERN CONST84_RETURN char * Tcl_PosixError(Tcl_Interp *interp); /* 205 */ EXTERN void Tcl_QueueEvent(Tcl_Event *evPtr, Tcl_QueuePosition position); /* 206 */ -EXTERN size_t Tcl_Read(Tcl_Channel chan, char *bufPtr, - size_t toRead); +EXTERN int Tcl_Read(Tcl_Channel chan, char *bufPtr, int toRead); /* 207 */ EXTERN void Tcl_ReapDetachedProcs(void); /* 208 */ EXTERN int Tcl_RecordAndEval(Tcl_Interp *interp, const char *cmd, int flags); @@ -617,30 +644,32 @@ const char *text, const char *start); /* 214 */ EXTERN int Tcl_RegExpMatch(Tcl_Interp *interp, const char *text, const char *pattern); /* 215 */ -EXTERN void Tcl_RegExpRange(Tcl_RegExp regexp, size_t index, - const char **startPtr, const char **endPtr); +EXTERN void Tcl_RegExpRange(Tcl_RegExp regexp, int index, + CONST84 char **startPtr, + CONST84 char **endPtr); /* 216 */ -EXTERN void Tcl_Release(void *clientData); +EXTERN void Tcl_Release(ClientData clientData); /* 217 */ EXTERN void Tcl_ResetResult(Tcl_Interp *interp); /* 218 */ -EXTERN size_t Tcl_ScanElement(const char *src, int *flagPtr); +EXTERN int Tcl_ScanElement(const char *src, int *flagPtr); /* 219 */ -EXTERN size_t Tcl_ScanCountedElement(const char *src, - size_t length, int *flagPtr); -/* Slot 220 is reserved */ +EXTERN int Tcl_ScanCountedElement(const char *src, int length, + int *flagPtr); +/* 220 */ +EXTERN int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode); /* 221 */ EXTERN int Tcl_ServiceAll(void); /* 222 */ EXTERN int Tcl_ServiceEvent(int flags); /* 223 */ EXTERN void Tcl_SetAssocData(Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc *proc, - void *clientData); + ClientData clientData); /* 224 */ EXTERN void Tcl_SetChannelBufferSize(Tcl_Channel chan, int sz); /* 225 */ EXTERN int Tcl_SetChannelOption(Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, @@ -653,14 +682,18 @@ EXTERN void Tcl_SetErrno(int err); /* 228 */ EXTERN void Tcl_SetErrorCode(Tcl_Interp *interp, ...); /* 229 */ EXTERN void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr); -/* Slot 230 is reserved */ +/* 230 */ +EXTERN void Tcl_SetPanicProc( + TCL_NORETURN1 Tcl_PanicProc *panicProc); /* 231 */ EXTERN int Tcl_SetRecursionLimit(Tcl_Interp *interp, int depth); -/* Slot 232 is reserved */ +/* 232 */ +EXTERN void Tcl_SetResult(Tcl_Interp *interp, char *result, + Tcl_FreeProc *freeProc); /* 233 */ EXTERN int Tcl_SetServiceMode(int mode); /* 234 */ EXTERN void Tcl_SetObjErrorCode(Tcl_Interp *interp, Tcl_Obj *errorObjPtr); @@ -667,112 +700,153 @@ /* 235 */ EXTERN void Tcl_SetObjResult(Tcl_Interp *interp, Tcl_Obj *resultObjPtr); /* 236 */ EXTERN void Tcl_SetStdChannel(Tcl_Channel channel, int type); -/* Slot 237 is reserved */ +/* 237 */ +EXTERN CONST84_RETURN char * Tcl_SetVar(Tcl_Interp *interp, + const char *varName, const char *newValue, + int flags); /* 238 */ -EXTERN const char * Tcl_SetVar2(Tcl_Interp *interp, const char *part1, - const char *part2, const char *newValue, - int flags); +EXTERN CONST84_RETURN char * Tcl_SetVar2(Tcl_Interp *interp, + const char *part1, const char *part2, + const char *newValue, int flags); /* 239 */ -EXTERN const char * Tcl_SignalId(int sig); +EXTERN CONST84_RETURN char * Tcl_SignalId(int sig); /* 240 */ -EXTERN const char * Tcl_SignalMsg(int sig); +EXTERN CONST84_RETURN char * Tcl_SignalMsg(int sig); /* 241 */ EXTERN void Tcl_SourceRCFile(Tcl_Interp *interp); /* 242 */ EXTERN int Tcl_SplitList(Tcl_Interp *interp, const char *listStr, int *argcPtr, - const char ***argvPtr); + CONST84 char ***argvPtr); /* 243 */ EXTERN void Tcl_SplitPath(const char *path, int *argcPtr, - const char ***argvPtr); -/* Slot 244 is reserved */ -/* Slot 245 is reserved */ -/* Slot 246 is reserved */ -/* Slot 247 is reserved */ + CONST84 char ***argvPtr); +/* 244 */ +EXTERN void Tcl_StaticPackage(Tcl_Interp *interp, + const char *pkgName, + Tcl_PackageInitProc *initProc, + Tcl_PackageInitProc *safeInitProc); +/* 245 */ +EXTERN int Tcl_StringMatch(const char *str, const char *pattern); +/* 246 */ +EXTERN int Tcl_TellOld(Tcl_Channel chan); +/* 247 */ +EXTERN int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, + int flags, Tcl_VarTraceProc *proc, + ClientData clientData); /* 248 */ EXTERN int Tcl_TraceVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags, - Tcl_VarTraceProc *proc, void *clientData); + Tcl_VarTraceProc *proc, + ClientData clientData); /* 249 */ EXTERN char * Tcl_TranslateFileName(Tcl_Interp *interp, const char *name, Tcl_DString *bufferPtr); /* 250 */ -EXTERN size_t Tcl_Ungets(Tcl_Channel chan, const char *str, - size_t len, int atHead); +EXTERN int Tcl_Ungets(Tcl_Channel chan, const char *str, + int len, int atHead); /* 251 */ EXTERN void Tcl_UnlinkVar(Tcl_Interp *interp, const char *varName); /* 252 */ EXTERN int Tcl_UnregisterChannel(Tcl_Interp *interp, Tcl_Channel chan); -/* Slot 253 is reserved */ +/* 253 */ +EXTERN int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName, + int flags); /* 254 */ EXTERN int Tcl_UnsetVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags); -/* Slot 255 is reserved */ +/* 255 */ +EXTERN void Tcl_UntraceVar(Tcl_Interp *interp, + const char *varName, int flags, + Tcl_VarTraceProc *proc, + ClientData clientData); /* 256 */ EXTERN void Tcl_UntraceVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, - void *clientData); + ClientData clientData); /* 257 */ EXTERN void Tcl_UpdateLinkedVar(Tcl_Interp *interp, const char *varName); -/* Slot 258 is reserved */ +/* 258 */ +EXTERN int Tcl_UpVar(Tcl_Interp *interp, const char *frameName, + const char *varName, const char *localName, + int flags); /* 259 */ EXTERN int Tcl_UpVar2(Tcl_Interp *interp, const char *frameName, const char *part1, const char *part2, const char *localName, int flags); /* 260 */ EXTERN int Tcl_VarEval(Tcl_Interp *interp, ...); -/* Slot 261 is reserved */ +/* 261 */ +EXTERN ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, + const char *varName, int flags, + Tcl_VarTraceProc *procPtr, + ClientData prevClientData); /* 262 */ -EXTERN void * Tcl_VarTraceInfo2(Tcl_Interp *interp, +EXTERN ClientData Tcl_VarTraceInfo2(Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, - void *prevClientData); + ClientData prevClientData); /* 263 */ -EXTERN size_t Tcl_Write(Tcl_Channel chan, const char *s, - size_t slen); +EXTERN int Tcl_Write(Tcl_Channel chan, const char *s, int slen); /* 264 */ EXTERN void Tcl_WrongNumArgs(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], const char *message); /* 265 */ EXTERN int Tcl_DumpActiveMemory(const char *fileName); /* 266 */ EXTERN void Tcl_ValidateAllMemory(const char *file, int line); -/* Slot 267 is reserved */ -/* Slot 268 is reserved */ +/* 267 */ +EXTERN void Tcl_AppendResultVA(Tcl_Interp *interp, + va_list argList); +/* 268 */ +EXTERN void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, + va_list argList); /* 269 */ EXTERN char * Tcl_HashStats(Tcl_HashTable *tablePtr); /* 270 */ -EXTERN const char * Tcl_ParseVar(Tcl_Interp *interp, const char *start, - const char **termPtr); -/* Slot 271 is reserved */ +EXTERN CONST84_RETURN char * Tcl_ParseVar(Tcl_Interp *interp, + const char *start, CONST84 char **termPtr); +/* 271 */ +EXTERN CONST84_RETURN char * Tcl_PkgPresent(Tcl_Interp *interp, + const char *name, const char *version, + int exact); /* 272 */ -EXTERN const char * Tcl_PkgPresentEx(Tcl_Interp *interp, +EXTERN CONST84_RETURN char * Tcl_PkgPresentEx(Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); -/* Slot 273 is reserved */ -/* Slot 274 is reserved */ -/* Slot 275 is reserved */ -/* Slot 276 is reserved */ +/* 273 */ +EXTERN int Tcl_PkgProvide(Tcl_Interp *interp, const char *name, + const char *version); +/* 274 */ +EXTERN CONST84_RETURN char * Tcl_PkgRequire(Tcl_Interp *interp, + const char *name, const char *version, + int exact); +/* 275 */ +EXTERN void Tcl_SetErrorCodeVA(Tcl_Interp *interp, + va_list argList); +/* 276 */ +EXTERN int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList); /* 277 */ EXTERN Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options); -/* Slot 278 is reserved */ +/* 278 */ +EXTERN TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList); /* 279 */ EXTERN void Tcl_GetVersion(int *major, int *minor, int *patchLevel, int *type); /* 280 */ EXTERN void Tcl_InitMemory(Tcl_Interp *interp); /* 281 */ EXTERN Tcl_Channel Tcl_StackChannel(Tcl_Interp *interp, const Tcl_ChannelType *typePtr, - void *instanceData, int mask, + ClientData instanceData, int mask, Tcl_Channel prevChan); /* 282 */ EXTERN int Tcl_UnstackChannel(Tcl_Interp *interp, Tcl_Channel chan); /* 283 */ @@ -785,64 +859,65 @@ Tcl_Obj *appendObjPtr); /* 287 */ EXTERN Tcl_Encoding Tcl_CreateEncoding(const Tcl_EncodingType *typePtr); /* 288 */ EXTERN void Tcl_CreateThreadExitHandler(Tcl_ExitProc *proc, - void *clientData); + ClientData clientData); /* 289 */ EXTERN void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, - void *clientData); -/* Slot 290 is reserved */ + ClientData clientData); +/* 290 */ +EXTERN void Tcl_DiscardResult(Tcl_SavedResult *statePtr); /* 291 */ EXTERN int Tcl_EvalEx(Tcl_Interp *interp, const char *script, - size_t numBytes, int flags); + int numBytes, int flags); /* 292 */ EXTERN int Tcl_EvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* 293 */ EXTERN int Tcl_EvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 294 */ -EXTERN TCL_NORETURN void Tcl_ExitThread(int status); +EXTERN void Tcl_ExitThread(int status); /* 295 */ EXTERN int Tcl_ExternalToUtf(Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, - size_t srcLen, int flags, + int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, - size_t dstLen, int *srcReadPtr, + int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 296 */ EXTERN char * Tcl_ExternalToUtfDString(Tcl_Encoding encoding, - const char *src, size_t srcLen, + const char *src, int srcLen, Tcl_DString *dsPtr); /* 297 */ EXTERN void Tcl_FinalizeThread(void); /* 298 */ -EXTERN void Tcl_FinalizeNotifier(void *clientData); +EXTERN void Tcl_FinalizeNotifier(ClientData clientData); /* 299 */ EXTERN void Tcl_FreeEncoding(Tcl_Encoding encoding); /* 300 */ EXTERN Tcl_ThreadId Tcl_GetCurrentThread(void); /* 301 */ EXTERN Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, const char *name); /* 302 */ -EXTERN const char * Tcl_GetEncodingName(Tcl_Encoding encoding); +EXTERN CONST84_RETURN char * Tcl_GetEncodingName(Tcl_Encoding encoding); /* 303 */ EXTERN void Tcl_GetEncodingNames(Tcl_Interp *interp); /* 304 */ EXTERN int Tcl_GetIndexFromObjStruct(Tcl_Interp *interp, Tcl_Obj *objPtr, const void *tablePtr, - size_t offset, const char *msg, int flags, + int offset, const char *msg, int flags, int *indexPtr); /* 305 */ EXTERN void * Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr, - size_t size); + int size); /* 306 */ EXTERN Tcl_Obj * Tcl_GetVar2Ex(Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 307 */ -EXTERN void * Tcl_InitNotifier(void); +EXTERN ClientData Tcl_InitNotifier(void); /* 308 */ EXTERN void Tcl_MutexLock(Tcl_Mutex *mutexPtr); /* 309 */ EXTERN void Tcl_MutexUnlock(Tcl_Mutex *mutexPtr); /* 310 */ @@ -849,16 +924,20 @@ EXTERN void Tcl_ConditionNotify(Tcl_Condition *condPtr); /* 311 */ EXTERN void Tcl_ConditionWait(Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, const Tcl_Time *timePtr); /* 312 */ -EXTERN size_t Tcl_NumUtfChars(const char *src, size_t length); +EXTERN int Tcl_NumUtfChars(const char *src, int length); /* 313 */ -EXTERN size_t Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, - size_t charsToRead, int appendFlag); -/* Slot 314 is reserved */ -/* Slot 315 is reserved */ +EXTERN int Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, + int charsToRead, int appendFlag); +/* 314 */ +EXTERN void Tcl_RestoreResult(Tcl_Interp *interp, + Tcl_SavedResult *statePtr); +/* 315 */ +EXTERN void Tcl_SaveResult(Tcl_Interp *interp, + Tcl_SavedResult *statePtr); /* 316 */ EXTERN int Tcl_SetSystemEncoding(Tcl_Interp *interp, const char *name); /* 317 */ EXTERN Tcl_Obj * Tcl_SetVar2Ex(Tcl_Interp *interp, const char *part1, @@ -868,44 +947,44 @@ EXTERN void Tcl_ThreadAlert(Tcl_ThreadId threadId); /* 319 */ EXTERN void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event *evPtr, Tcl_QueuePosition position); /* 320 */ -EXTERN int Tcl_UniCharAtIndex(const char *src, size_t index); +EXTERN Tcl_UniChar Tcl_UniCharAtIndex(const char *src, int index); /* 321 */ -EXTERN int Tcl_UniCharToLower(int ch); +EXTERN Tcl_UniChar Tcl_UniCharToLower(int ch); /* 322 */ -EXTERN int Tcl_UniCharToTitle(int ch); +EXTERN Tcl_UniChar Tcl_UniCharToTitle(int ch); /* 323 */ -EXTERN int Tcl_UniCharToUpper(int ch); +EXTERN Tcl_UniChar Tcl_UniCharToUpper(int ch); /* 324 */ EXTERN int Tcl_UniCharToUtf(int ch, char *buf); /* 325 */ -EXTERN const char * Tcl_UtfAtIndex(const char *src, size_t index); +EXTERN CONST84_RETURN char * Tcl_UtfAtIndex(const char *src, int index); /* 326 */ -EXTERN int Tcl_UtfCharComplete(const char *src, size_t length); +EXTERN int Tcl_UtfCharComplete(const char *src, int length); /* 327 */ -EXTERN size_t Tcl_UtfBackslash(const char *src, int *readPtr, +EXTERN int Tcl_UtfBackslash(const char *src, int *readPtr, char *dst); /* 328 */ -EXTERN const char * Tcl_UtfFindFirst(const char *src, int ch); +EXTERN CONST84_RETURN char * Tcl_UtfFindFirst(const char *src, int ch); /* 329 */ -EXTERN const char * Tcl_UtfFindLast(const char *src, int ch); +EXTERN CONST84_RETURN char * Tcl_UtfFindLast(const char *src, int ch); /* 330 */ -EXTERN const char * Tcl_UtfNext(const char *src); +EXTERN CONST84_RETURN char * Tcl_UtfNext(const char *src); /* 331 */ -EXTERN const char * Tcl_UtfPrev(const char *src, const char *start); +EXTERN CONST84_RETURN char * Tcl_UtfPrev(const char *src, const char *start); /* 332 */ EXTERN int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, - size_t srcLen, int flags, + int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, - size_t dstLen, int *srcReadPtr, + int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 333 */ EXTERN char * Tcl_UtfToExternalDString(Tcl_Encoding encoding, - const char *src, size_t srcLen, + const char *src, int srcLen, Tcl_DString *dsPtr); /* 334 */ EXTERN int Tcl_UtfToLower(char *src); /* 335 */ EXTERN int Tcl_UtfToTitle(char *src); @@ -912,20 +991,22 @@ /* 336 */ EXTERN int Tcl_UtfToUniChar(const char *src, Tcl_UniChar *chPtr); /* 337 */ EXTERN int Tcl_UtfToUpper(char *src); /* 338 */ -EXTERN size_t Tcl_WriteChars(Tcl_Channel chan, const char *src, - size_t srcLen); +EXTERN int Tcl_WriteChars(Tcl_Channel chan, const char *src, + int srcLen); /* 339 */ -EXTERN size_t Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr); +EXTERN int Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr); /* 340 */ EXTERN char * Tcl_GetString(Tcl_Obj *objPtr); -/* Slot 341 is reserved */ -/* Slot 342 is reserved */ +/* 341 */ +EXTERN CONST84_RETURN char * Tcl_GetDefaultEncodingDir(void); +/* 342 */ +EXTERN void Tcl_SetDefaultEncodingDir(const char *path); /* 343 */ -EXTERN void Tcl_AlertNotifier(void *clientData); +EXTERN void Tcl_AlertNotifier(ClientData clientData); /* 344 */ EXTERN void Tcl_ServiceModeHook(int mode); /* 345 */ EXTERN int Tcl_UniCharIsAlnum(int ch); /* 346 */ @@ -939,50 +1020,53 @@ /* 350 */ EXTERN int Tcl_UniCharIsUpper(int ch); /* 351 */ EXTERN int Tcl_UniCharIsWordChar(int ch); /* 352 */ -EXTERN size_t Tcl_UniCharLen(const Tcl_UniChar *uniStr); +EXTERN int Tcl_UniCharLen(const Tcl_UniChar *uniStr); /* 353 */ EXTERN int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, - const Tcl_UniChar *uct, size_t numChars); + const Tcl_UniChar *uct, + unsigned long numChars); /* 354 */ EXTERN char * Tcl_UniCharToUtfDString(const Tcl_UniChar *uniStr, - size_t uniLength, Tcl_DString *dsPtr); + int uniLength, Tcl_DString *dsPtr); /* 355 */ -EXTERN Tcl_UniChar * Tcl_UtfToUniCharDString(const char *src, - size_t length, Tcl_DString *dsPtr); +EXTERN Tcl_UniChar * Tcl_UtfToUniCharDString(const char *src, int length, + Tcl_DString *dsPtr); /* 356 */ EXTERN Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, int flags); -/* Slot 357 is reserved */ +/* 357 */ +EXTERN Tcl_Obj * Tcl_EvalTokens(Tcl_Interp *interp, + Tcl_Token *tokenPtr, int count); /* 358 */ EXTERN void Tcl_FreeParse(Tcl_Parse *parsePtr); /* 359 */ EXTERN void Tcl_LogCommandInfo(Tcl_Interp *interp, const char *script, const char *command, - size_t length); + int length); /* 360 */ EXTERN int Tcl_ParseBraces(Tcl_Interp *interp, - const char *start, size_t numBytes, + const char *start, int numBytes, Tcl_Parse *parsePtr, int append, - const char **termPtr); + CONST84 char **termPtr); /* 361 */ EXTERN int Tcl_ParseCommand(Tcl_Interp *interp, - const char *start, size_t numBytes, - int nested, Tcl_Parse *parsePtr); + const char *start, int numBytes, int nested, + Tcl_Parse *parsePtr); /* 362 */ EXTERN int Tcl_ParseExpr(Tcl_Interp *interp, const char *start, - size_t numBytes, Tcl_Parse *parsePtr); + int numBytes, Tcl_Parse *parsePtr); /* 363 */ EXTERN int Tcl_ParseQuotedString(Tcl_Interp *interp, - const char *start, size_t numBytes, + const char *start, int numBytes, Tcl_Parse *parsePtr, int append, - const char **termPtr); + CONST84 char **termPtr); /* 364 */ EXTERN int Tcl_ParseVarName(Tcl_Interp *interp, - const char *start, size_t numBytes, + const char *start, int numBytes, Tcl_Parse *parsePtr, int append); /* 365 */ EXTERN char * Tcl_GetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 366 */ EXTERN int Tcl_Chdir(const char *dirName); @@ -989,14 +1073,15 @@ /* 367 */ EXTERN int Tcl_Access(const char *path, int mode); /* 368 */ EXTERN int Tcl_Stat(const char *path, struct stat *bufPtr); /* 369 */ -EXTERN int Tcl_UtfNcmp(const char *s1, const char *s2, size_t n); +EXTERN int Tcl_UtfNcmp(const char *s1, const char *s2, + unsigned long n); /* 370 */ EXTERN int Tcl_UtfNcasecmp(const char *s1, const char *s2, - size_t n); + unsigned long n); /* 371 */ EXTERN int Tcl_StringCaseMatch(const char *str, const char *pattern, int nocase); /* 372 */ EXTERN int Tcl_UniCharIsControl(int ch); @@ -1007,31 +1092,31 @@ /* 375 */ EXTERN int Tcl_UniCharIsPunct(int ch); /* 376 */ EXTERN int Tcl_RegExpExecObj(Tcl_Interp *interp, Tcl_RegExp regexp, Tcl_Obj *textObj, - size_t offset, size_t nmatches, int flags); + int offset, int nmatches, int flags); /* 377 */ EXTERN void Tcl_RegExpGetInfo(Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr); /* 378 */ EXTERN Tcl_Obj * Tcl_NewUnicodeObj(const Tcl_UniChar *unicode, - size_t numChars); + int numChars); /* 379 */ EXTERN void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, - const Tcl_UniChar *unicode, size_t numChars); + const Tcl_UniChar *unicode, int numChars); /* 380 */ -EXTERN size_t Tcl_GetCharLength(Tcl_Obj *objPtr); +EXTERN int Tcl_GetCharLength(Tcl_Obj *objPtr); /* 381 */ -EXTERN int Tcl_GetUniChar(Tcl_Obj *objPtr, size_t index); -/* Slot 382 is reserved */ +EXTERN Tcl_UniChar Tcl_GetUniChar(Tcl_Obj *objPtr, int index); +/* 382 */ +EXTERN Tcl_UniChar * Tcl_GetUnicode(Tcl_Obj *objPtr); /* 383 */ -EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, size_t first, - size_t last); +EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, int first, int last); /* 384 */ EXTERN void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, - const Tcl_UniChar *unicode, size_t length); + const Tcl_UniChar *unicode, int length); /* 385 */ EXTERN int Tcl_RegExpMatchObj(Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); /* 386 */ EXTERN void Tcl_SetNotifier(Tcl_NotifierProcs *notifierProcPtr); @@ -1041,32 +1126,35 @@ EXTERN int Tcl_GetChannelNames(Tcl_Interp *interp); /* 389 */ EXTERN int Tcl_GetChannelNamesEx(Tcl_Interp *interp, const char *pattern); /* 390 */ -EXTERN int Tcl_ProcObjCmd(void *clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); +EXTERN int Tcl_ProcObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); /* 391 */ EXTERN void Tcl_ConditionFinalize(Tcl_Condition *condPtr); /* 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_ThreadCreateProc *proc, + ClientData clientData, int stackSize, + int flags); /* 394 */ -EXTERN size_t Tcl_ReadRaw(Tcl_Channel chan, char *dst, - size_t bytesToRead); +EXTERN int Tcl_ReadRaw(Tcl_Channel chan, char *dst, + int bytesToRead); /* 395 */ -EXTERN size_t Tcl_WriteRaw(Tcl_Channel chan, const char *src, - size_t srcLen); +EXTERN int Tcl_WriteRaw(Tcl_Channel chan, const char *src, + int srcLen); /* 396 */ EXTERN Tcl_Channel Tcl_GetTopChannel(Tcl_Channel chan); /* 397 */ EXTERN int Tcl_ChannelBuffered(Tcl_Channel chan); /* 398 */ -EXTERN const char * Tcl_ChannelName(const Tcl_ChannelType *chanTypePtr); +EXTERN CONST84_RETURN char * Tcl_ChannelName( + const Tcl_ChannelType *chanTypePtr); /* 399 */ EXTERN Tcl_ChannelTypeVersion Tcl_ChannelVersion( const Tcl_ChannelType *chanTypePtr); /* 400 */ EXTERN Tcl_DriverBlockModeProc * Tcl_ChannelBlockModeProc( @@ -1119,54 +1207,67 @@ EXTERN void Tcl_ClearChannelHandlers(Tcl_Channel channel); /* 418 */ EXTERN int Tcl_IsChannelExisting(const char *channelName); /* 419 */ EXTERN int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs, - const Tcl_UniChar *uct, size_t numChars); + const Tcl_UniChar *uct, + unsigned long numChars); /* 420 */ EXTERN int Tcl_UniCharCaseMatch(const Tcl_UniChar *uniStr, const Tcl_UniChar *uniPattern, int nocase); -/* Slot 421 is reserved */ -/* Slot 422 is reserved */ +/* 421 */ +EXTERN Tcl_HashEntry * Tcl_FindHashEntry(Tcl_HashTable *tablePtr, + const void *key); +/* 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); /* 425 */ -EXTERN void * Tcl_CommandTraceInfo(Tcl_Interp *interp, +EXTERN ClientData Tcl_CommandTraceInfo(Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *procPtr, - void *prevClientData); + ClientData prevClientData); /* 426 */ EXTERN int Tcl_TraceCommand(Tcl_Interp *interp, const char *varName, int flags, - Tcl_CommandTraceProc *proc, void *clientData); + Tcl_CommandTraceProc *proc, + ClientData clientData); /* 427 */ EXTERN void Tcl_UntraceCommand(Tcl_Interp *interp, const char *varName, int flags, - Tcl_CommandTraceProc *proc, void *clientData); + Tcl_CommandTraceProc *proc, + ClientData clientData); /* 428 */ -EXTERN void * Tcl_AttemptAlloc(size_t size); +EXTERN char * Tcl_AttemptAlloc(unsigned int size); /* 429 */ -EXTERN void * Tcl_AttemptDbCkalloc(size_t size, const char *file, - int line); +EXTERN char * Tcl_AttemptDbCkalloc(unsigned int size, + const char *file, int line); /* 430 */ -EXTERN void * Tcl_AttemptRealloc(void *ptr, size_t size); +EXTERN char * Tcl_AttemptRealloc(char *ptr, unsigned int size); /* 431 */ -EXTERN void * Tcl_AttemptDbCkrealloc(void *ptr, size_t size, +EXTERN char * Tcl_AttemptDbCkrealloc(char *ptr, unsigned int size, const char *file, int line); /* 432 */ -EXTERN int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, - size_t length); +EXTERN int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, int length); /* 433 */ EXTERN Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel); /* 434 */ EXTERN Tcl_UniChar * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr); -/* Slot 435 is reserved */ -/* Slot 436 is reserved */ +/* 435 */ +EXTERN int Tcl_GetMathFuncInfo(Tcl_Interp *interp, + const char *name, int *numArgsPtr, + Tcl_ValueType **argTypesPtr, + Tcl_MathProc **procPtr, + ClientData *clientDataPtr); +/* 436 */ +EXTERN Tcl_Obj * Tcl_ListMathFuncs(Tcl_Interp *interp, + const char *pattern); /* 437 */ EXTERN Tcl_Obj * Tcl_SubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 438 */ EXTERN int Tcl_DetachChannel(Tcl_Interp *interp, @@ -1212,11 +1313,11 @@ Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); /* 452 */ EXTERN int Tcl_FSFileAttrsSet(Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr); /* 453 */ -EXTERN const char *const * Tcl_FSFileAttrStrings(Tcl_Obj *pathPtr, +EXTERN const char *CONST86 * Tcl_FSFileAttrStrings(Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); /* 454 */ EXTERN int Tcl_FSStat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); /* 455 */ EXTERN int Tcl_FSAccess(Tcl_Obj *pathPtr, int mode); @@ -1243,56 +1344,56 @@ Tcl_Obj *pathPtr); /* 464 */ EXTERN Tcl_Obj * Tcl_FSJoinToPath(Tcl_Obj *pathPtr, int objc, Tcl_Obj *const objv[]); /* 465 */ -EXTERN void * Tcl_FSGetInternalRep(Tcl_Obj *pathPtr, +EXTERN ClientData Tcl_FSGetInternalRep(Tcl_Obj *pathPtr, const Tcl_Filesystem *fsPtr); /* 466 */ EXTERN Tcl_Obj * Tcl_FSGetTranslatedPath(Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 467 */ EXTERN int Tcl_FSEvalFile(Tcl_Interp *interp, Tcl_Obj *fileName); /* 468 */ EXTERN Tcl_Obj * Tcl_FSNewNativePath( const Tcl_Filesystem *fromFilesystem, - void *clientData); + ClientData clientData); /* 469 */ EXTERN const void * Tcl_FSGetNativePath(Tcl_Obj *pathPtr); /* 470 */ EXTERN Tcl_Obj * Tcl_FSFileSystemInfo(Tcl_Obj *pathPtr); /* 471 */ EXTERN Tcl_Obj * Tcl_FSPathSeparator(Tcl_Obj *pathPtr); /* 472 */ EXTERN Tcl_Obj * Tcl_FSListVolumes(void); /* 473 */ -EXTERN int Tcl_FSRegister(void *clientData, +EXTERN int Tcl_FSRegister(ClientData clientData, const Tcl_Filesystem *fsPtr); /* 474 */ EXTERN int Tcl_FSUnregister(const Tcl_Filesystem *fsPtr); /* 475 */ -EXTERN void * Tcl_FSData(const Tcl_Filesystem *fsPtr); +EXTERN ClientData Tcl_FSData(const Tcl_Filesystem *fsPtr); /* 476 */ EXTERN const char * Tcl_FSGetTranslatedStringPath(Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 477 */ -EXTERN const Tcl_Filesystem * Tcl_FSGetFileSystemForPath(Tcl_Obj *pathPtr); +EXTERN CONST86 Tcl_Filesystem * Tcl_FSGetFileSystemForPath(Tcl_Obj *pathPtr); /* 478 */ EXTERN Tcl_PathType Tcl_FSGetPathType(Tcl_Obj *pathPtr); /* 479 */ EXTERN int Tcl_OutputBuffered(Tcl_Channel chan); /* 480 */ EXTERN void Tcl_FSMountsChanged(const Tcl_Filesystem *fsPtr); /* 481 */ EXTERN int Tcl_EvalTokensStandard(Tcl_Interp *interp, - Tcl_Token *tokenPtr, size_t count); + Tcl_Token *tokenPtr, int count); /* 482 */ EXTERN void Tcl_GetTime(Tcl_Time *timeBuf); /* 483 */ EXTERN Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp, int level, int flags, Tcl_CmdObjTraceProc *objProc, - void *clientData, + ClientData clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 484 */ EXTERN int Tcl_GetCommandInfoFromToken(Tcl_Command token, Tcl_CmdInfo *infoPtr); /* 485 */ @@ -1359,11 +1460,11 @@ const char *pkgName, const Tcl_Config *configuration, const char *valEncoding); /* 506 */ EXTERN Tcl_Namespace * Tcl_CreateNamespace(Tcl_Interp *interp, - const char *name, void *clientData, + const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 507 */ EXTERN void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr); /* 508 */ EXTERN int Tcl_AppendExportList(Tcl_Interp *interp, @@ -1395,20 +1496,21 @@ EXTERN void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 518 */ EXTERN int Tcl_FSEvalFileEx(Tcl_Interp *interp, Tcl_Obj *fileName, const char *encodingName); -/* Slot 519 is reserved */ +/* 519 */ +EXTERN Tcl_ExitProc * Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc); /* 520 */ EXTERN void Tcl_LimitAddHandler(Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, - void *clientData, + ClientData clientData, Tcl_LimitHandlerDeleteProc *deleteProc); /* 521 */ EXTERN void Tcl_LimitRemoveHandler(Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, - void *clientData); + ClientData clientData); /* 522 */ EXTERN int Tcl_LimitReady(Tcl_Interp *interp); /* 523 */ EXTERN int Tcl_LimitCheck(Tcl_Interp *interp); /* 524 */ @@ -1487,15 +1589,15 @@ Tcl_Command token, Tcl_Namespace **namespacePtrPtr); /* 552 */ EXTERN void Tcl_SetTimeProc(Tcl_GetTimeProc *getProc, Tcl_ScaleTimeProc *scaleProc, - void *clientData); + ClientData clientData); /* 553 */ EXTERN void Tcl_QueryTimeProc(Tcl_GetTimeProc **getProc, Tcl_ScaleTimeProc **scaleProc, - void **clientData); + ClientData *clientData); /* 554 */ EXTERN Tcl_DriverThreadActionProc * Tcl_ChannelThreadActionProc( const Tcl_ChannelType *chanTypePtr); /* 555 */ EXTERN Tcl_Obj * Tcl_NewBignumObj(mp_int *value); @@ -1552,12 +1654,12 @@ /* 574 */ EXTERN void Tcl_AppendObjToErrorInfo(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 575 */ EXTERN void Tcl_AppendLimitedToObj(Tcl_Obj *objPtr, - const char *bytes, size_t length, - size_t limit, const char *ellipsis); + const char *bytes, int length, int limit, + const char *ellipsis); /* 576 */ EXTERN Tcl_Obj * Tcl_Format(Tcl_Interp *interp, const char *format, int objc, Tcl_Obj *const objv[]); /* 577 */ EXTERN int Tcl_AppendFormatToObj(Tcl_Interp *interp, @@ -1568,11 +1670,11 @@ /* 579 */ EXTERN void Tcl_AppendPrintfToObj(Tcl_Obj *objPtr, const char *format, ...) TCL_FORMAT_PRINTF(2, 3); /* 580 */ EXTERN int Tcl_CancelEval(Tcl_Interp *interp, - Tcl_Obj *resultObjPtr, void *clientData, + Tcl_Obj *resultObjPtr, ClientData clientData, int flags); /* 581 */ EXTERN int Tcl_Canceled(Tcl_Interp *interp, int flags); /* 582 */ EXTERN int Tcl_CreatePipe(Tcl_Interp *interp, @@ -1579,11 +1681,12 @@ Tcl_Channel *rchan, Tcl_Channel *wchan, int flags); /* 583 */ EXTERN Tcl_Command Tcl_NRCreateCommand(Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, - Tcl_ObjCmdProc *nreProc, void *clientData, + Tcl_ObjCmdProc *nreProc, + ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 584 */ EXTERN int Tcl_NREvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 585 */ @@ -1592,16 +1695,18 @@ /* 586 */ EXTERN int Tcl_NRCmdSwap(Tcl_Interp *interp, Tcl_Command cmd, int objc, Tcl_Obj *const objv[], int flags); /* 587 */ EXTERN void Tcl_NRAddCallback(Tcl_Interp *interp, - Tcl_NRPostProc *postProcPtr, void *data0, - void *data1, void *data2, void *data3); + Tcl_NRPostProc *postProcPtr, + ClientData data0, ClientData data1, + ClientData data2, ClientData data3); /* 588 */ EXTERN int Tcl_NRCallObjProc(Tcl_Interp *interp, - Tcl_ObjCmdProc *objProc, void *clientData, - int objc, Tcl_Obj *const objv[]); + Tcl_ObjCmdProc *objProc, + ClientData clientData, int objc, + Tcl_Obj *const objv[]); /* 589 */ EXTERN unsigned Tcl_GetFSDeviceFromStat(const Tcl_StatBuf *statPtr); /* 590 */ EXTERN unsigned Tcl_GetFSInodeFromStat(const Tcl_StatBuf *statPtr); /* 591 */ @@ -1641,11 +1746,11 @@ EXTERN int Tcl_GetErrorLine(Tcl_Interp *interp); /* 606 */ EXTERN void Tcl_SetErrorLine(Tcl_Interp *interp, int lineNum); /* 607 */ EXTERN void Tcl_TransferResult(Tcl_Interp *sourceInterp, - int result, Tcl_Interp *targetInterp); + int code, Tcl_Interp *targetInterp); /* 608 */ EXTERN int Tcl_InterpActive(Tcl_Interp *interp); /* 609 */ EXTERN void Tcl_BackgroundException(Tcl_Interp *interp, int code); /* 610 */ @@ -1652,18 +1757,18 @@ EXTERN int Tcl_ZlibDeflate(Tcl_Interp *interp, int format, Tcl_Obj *data, int level, Tcl_Obj *gzipHeaderDictObj); /* 611 */ EXTERN int Tcl_ZlibInflate(Tcl_Interp *interp, int format, - Tcl_Obj *data, size_t buffersize, + Tcl_Obj *data, int buffersize, Tcl_Obj *gzipHeaderDictObj); /* 612 */ EXTERN unsigned int Tcl_ZlibCRC32(unsigned int crc, - const unsigned char *buf, size_t len); + const unsigned char *buf, int len); /* 613 */ EXTERN unsigned int Tcl_ZlibAdler32(unsigned int adler, - const unsigned char *buf, size_t len); + const unsigned char *buf, int len); /* 614 */ EXTERN int Tcl_ZlibStreamInit(Tcl_Interp *interp, int mode, int format, int level, Tcl_Obj *dictObj, Tcl_ZlibStream *zshandle); /* 615 */ @@ -1675,11 +1780,11 @@ /* 618 */ EXTERN int Tcl_ZlibStreamPut(Tcl_ZlibStream zshandle, Tcl_Obj *data, int flush); /* 619 */ EXTERN int Tcl_ZlibStreamGet(Tcl_ZlibStream zshandle, - Tcl_Obj *data, size_t count); + Tcl_Obj *data, int count); /* 620 */ EXTERN int Tcl_ZlibStreamClose(Tcl_ZlibStream zshandle); /* 621 */ EXTERN int Tcl_ZlibStreamReset(Tcl_ZlibStream zshandle); /* 622 */ @@ -1708,57 +1813,30 @@ Tcl_LoadHandle handlePtr); /* 630 */ EXTERN void Tcl_ZlibStreamSetCompressionDictionary( Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); -/* 631 */ -EXTERN Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp, - const char *service, const char *host, - unsigned int flags, - Tcl_TcpAcceptProc *acceptProc, - void *callbackData); -/* 632 */ -EXTERN int TclZipfs_Mount(Tcl_Interp *interp, - const char *mountPoint, const char *zipname, - const char *passwd); -/* 633 */ -EXTERN int TclZipfs_Unmount(Tcl_Interp *interp, - const char *mountPoint); -/* 634 */ -EXTERN Tcl_Obj * TclZipfs_TclLibrary(void); -/* 635 */ -EXTERN int TclZipfs_MountBuffer(Tcl_Interp *interp, - const char *mountPoint, unsigned char *data, - size_t datalen, int copy); -/* 636 */ -EXTERN void Tcl_FreeIntRep(Tcl_Obj *objPtr); -/* 637 */ -EXTERN char * Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes, - size_t numBytes); -/* 638 */ -EXTERN Tcl_ObjIntRep * Tcl_FetchIntRep(Tcl_Obj *objPtr, - const Tcl_ObjType *typePtr); -/* 639 */ -EXTERN void Tcl_StoreIntRep(Tcl_Obj *objPtr, - const Tcl_ObjType *typePtr, - const Tcl_ObjIntRep *irPtr); -/* 640 */ -EXTERN int Tcl_HasStringRep(Tcl_Obj *objPtr); -/* 641 */ -EXTERN void Tcl_IncrRefCount(Tcl_Obj *objPtr); -/* 642 */ -EXTERN void Tcl_DecrRefCount(Tcl_Obj *objPtr); -/* 643 */ -EXTERN int Tcl_IsShared(Tcl_Obj *objPtr); -/* 644 */ -EXTERN int Tcl_LinkArray(Tcl_Interp *interp, - const char *varName, void *addr, int type, - size_t size); -/* 645 */ -EXTERN int Tcl_GetIntForIndex(Tcl_Interp *interp, - Tcl_Obj *objPtr, size_t endValue, - size_t *indexPtr); +/* Slot 631 is reserved */ +/* Slot 632 is reserved */ +/* Slot 633 is reserved */ +/* Slot 634 is reserved */ +/* Slot 635 is reserved */ +/* Slot 636 is reserved */ +/* Slot 637 is reserved */ +/* Slot 638 is reserved */ +/* Slot 639 is reserved */ +/* Slot 640 is reserved */ +/* Slot 641 is reserved */ +/* Slot 642 is reserved */ +/* Slot 643 is reserved */ +/* Slot 644 is reserved */ +/* Slot 645 is reserved */ +/* Slot 646 is reserved */ +/* Slot 647 is reserved */ +/* Slot 648 is reserved */ +/* 649 */ +EXTERN void TclUnusedStubEntry(void); typedef struct { const struct TclPlatStubs *tclPlatStubs; const struct TclIntStubs *tclIntStubs; const struct TclIntPlatStubs *tclIntPlatStubs; @@ -1767,26 +1845,26 @@ typedef struct TclStubs { int magic; 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 */ + CONST84_RETURN 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_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_DbCkfree) (void *ptr, const char *file, int line); /* 7 */ - void * (*tcl_DbCkrealloc) (void *ptr, size_t size, const char *file, int line); /* 8 */ + char * (*tcl_Alloc) (unsigned int size); /* 3 */ + void (*tcl_Free) (char *ptr); /* 4 */ + char * (*tcl_Realloc) (char *ptr, unsigned int size); /* 5 */ + char * (*tcl_DbCkalloc) (unsigned int size, const char *file, int line); /* 6 */ + void (*tcl_DbCkfree) (char *ptr, const char *file, int line); /* 7 */ + char * (*tcl_DbCkrealloc) (char *ptr, unsigned int size, const char *file, int line); /* 8 */ #if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ - void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, void *clientData); /* 9 */ + void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, ClientData clientData); /* 9 */ #endif /* UNIX */ #if defined(_WIN32) /* WIN */ void (*reserved9)(void); #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ - void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, void *clientData); /* 9 */ + void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, ClientData clientData); /* 9 */ #endif /* MACOSX */ #if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ void (*tcl_DeleteFileHandler) (int fd); /* 10 */ #endif /* UNIX */ #if defined(_WIN32) /* WIN */ @@ -1798,127 +1876,127 @@ void (*tcl_SetTimer) (const Tcl_Time *timePtr); /* 11 */ void (*tcl_Sleep) (int ms); /* 12 */ int (*tcl_WaitForEvent) (const Tcl_Time *timePtr); /* 13 */ int (*tcl_AppendAllObjTypes) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 14 */ void (*tcl_AppendStringsToObj) (Tcl_Obj *objPtr, ...); /* 15 */ - void (*tcl_AppendToObj) (Tcl_Obj *objPtr, const char *bytes, size_t length); /* 16 */ + void (*tcl_AppendToObj) (Tcl_Obj *objPtr, const char *bytes, int length); /* 16 */ Tcl_Obj * (*tcl_ConcatObj) (int objc, Tcl_Obj *const objv[]); /* 17 */ int (*tcl_ConvertToType) (Tcl_Interp *interp, Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 18 */ void (*tcl_DbDecrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 19 */ void (*tcl_DbIncrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 20 */ int (*tcl_DbIsShared) (Tcl_Obj *objPtr, const char *file, int line); /* 21 */ - void (*reserved22)(void); - Tcl_Obj * (*tcl_DbNewByteArrayObj) (const unsigned char *bytes, size_t length, const char *file, int line); /* 23 */ + Tcl_Obj * (*tcl_DbNewBooleanObj) (int boolValue, const char *file, int line); /* 22 */ + Tcl_Obj * (*tcl_DbNewByteArrayObj) (const unsigned char *bytes, int length, const char *file, int line); /* 23 */ Tcl_Obj * (*tcl_DbNewDoubleObj) (double doubleValue, const char *file, int line); /* 24 */ Tcl_Obj * (*tcl_DbNewListObj) (int objc, Tcl_Obj *const *objv, const char *file, int line); /* 25 */ - void (*reserved26)(void); + Tcl_Obj * (*tcl_DbNewLongObj) (long longValue, const char *file, int line); /* 26 */ Tcl_Obj * (*tcl_DbNewObj) (const char *file, int line); /* 27 */ - Tcl_Obj * (*tcl_DbNewStringObj) (const char *bytes, size_t length, const char *file, int line); /* 28 */ + Tcl_Obj * (*tcl_DbNewStringObj) (const char *bytes, int length, const char *file, int line); /* 28 */ Tcl_Obj * (*tcl_DuplicateObj) (Tcl_Obj *objPtr); /* 29 */ - void (*reserved30)(void); + void (*tclFreeObj) (Tcl_Obj *objPtr); /* 30 */ int (*tcl_GetBoolean) (Tcl_Interp *interp, const char *src, int *boolPtr); /* 31 */ int (*tcl_GetBooleanFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *boolPtr); /* 32 */ unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 33 */ int (*tcl_GetDouble) (Tcl_Interp *interp, const char *src, double *doublePtr); /* 34 */ int (*tcl_GetDoubleFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); /* 35 */ - void (*reserved36)(void); + int (*tcl_GetIndexFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, CONST84 char *const *tablePtr, const char *msg, int flags, int *indexPtr); /* 36 */ int (*tcl_GetInt) (Tcl_Interp *interp, const char *src, int *intPtr); /* 37 */ int (*tcl_GetIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr); /* 38 */ int (*tcl_GetLongFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr); /* 39 */ - const Tcl_ObjType * (*tcl_GetObjType) (const char *typeName); /* 40 */ + CONST86 Tcl_ObjType * (*tcl_GetObjType) (const char *typeName); /* 40 */ char * (*tcl_GetStringFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 41 */ void (*tcl_InvalidateStringRep) (Tcl_Obj *objPtr); /* 42 */ int (*tcl_ListObjAppendList) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *elemListPtr); /* 43 */ int (*tcl_ListObjAppendElement) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *objPtr); /* 44 */ int (*tcl_ListObjGetElements) (Tcl_Interp *interp, Tcl_Obj *listPtr, int *objcPtr, Tcl_Obj ***objvPtr); /* 45 */ int (*tcl_ListObjIndex) (Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj **objPtrPtr); /* 46 */ int (*tcl_ListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, int *lengthPtr); /* 47 */ int (*tcl_ListObjReplace) (Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *const objv[]); /* 48 */ - void (*reserved49)(void); - Tcl_Obj * (*tcl_NewByteArrayObj) (const unsigned char *bytes, size_t length); /* 50 */ + Tcl_Obj * (*tcl_NewBooleanObj) (int boolValue); /* 49 */ + Tcl_Obj * (*tcl_NewByteArrayObj) (const unsigned char *bytes, int length); /* 50 */ Tcl_Obj * (*tcl_NewDoubleObj) (double doubleValue); /* 51 */ - void (*reserved52)(void); + Tcl_Obj * (*tcl_NewIntObj) (int intValue); /* 52 */ Tcl_Obj * (*tcl_NewListObj) (int objc, Tcl_Obj *const objv[]); /* 53 */ - void (*reserved54)(void); + Tcl_Obj * (*tcl_NewLongObj) (long longValue); /* 54 */ Tcl_Obj * (*tcl_NewObj) (void); /* 55 */ - Tcl_Obj * (*tcl_NewStringObj) (const char *bytes, size_t length); /* 56 */ - void (*reserved57)(void); - unsigned char * (*tcl_SetByteArrayLength) (Tcl_Obj *objPtr, size_t length); /* 58 */ - void (*tcl_SetByteArrayObj) (Tcl_Obj *objPtr, const unsigned char *bytes, size_t length); /* 59 */ + Tcl_Obj * (*tcl_NewStringObj) (const char *bytes, int length); /* 56 */ + void (*tcl_SetBooleanObj) (Tcl_Obj *objPtr, int boolValue); /* 57 */ + unsigned char * (*tcl_SetByteArrayLength) (Tcl_Obj *objPtr, int length); /* 58 */ + void (*tcl_SetByteArrayObj) (Tcl_Obj *objPtr, const unsigned char *bytes, int length); /* 59 */ void (*tcl_SetDoubleObj) (Tcl_Obj *objPtr, double doubleValue); /* 60 */ - void (*reserved61)(void); + void (*tcl_SetIntObj) (Tcl_Obj *objPtr, int intValue); /* 61 */ void (*tcl_SetListObj) (Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]); /* 62 */ - void (*reserved63)(void); - void (*tcl_SetObjLength) (Tcl_Obj *objPtr, size_t length); /* 64 */ - void (*tcl_SetStringObj) (Tcl_Obj *objPtr, const char *bytes, size_t length); /* 65 */ - void (*reserved66)(void); - void (*reserved67)(void); + void (*tcl_SetLongObj) (Tcl_Obj *objPtr, long longValue); /* 63 */ + void (*tcl_SetObjLength) (Tcl_Obj *objPtr, int length); /* 64 */ + void (*tcl_SetStringObj) (Tcl_Obj *objPtr, const char *bytes, int length); /* 65 */ + void (*tcl_AddErrorInfo) (Tcl_Interp *interp, const char *message); /* 66 */ + void (*tcl_AddObjErrorInfo) (Tcl_Interp *interp, const char *message, int length); /* 67 */ void (*tcl_AllowExceptions) (Tcl_Interp *interp); /* 68 */ void (*tcl_AppendElement) (Tcl_Interp *interp, const char *element); /* 69 */ void (*tcl_AppendResult) (Tcl_Interp *interp, ...); /* 70 */ - Tcl_AsyncHandler (*tcl_AsyncCreate) (Tcl_AsyncProc *proc, void *clientData); /* 71 */ + Tcl_AsyncHandler (*tcl_AsyncCreate) (Tcl_AsyncProc *proc, ClientData clientData); /* 71 */ void (*tcl_AsyncDelete) (Tcl_AsyncHandler async); /* 72 */ int (*tcl_AsyncInvoke) (Tcl_Interp *interp, int code); /* 73 */ void (*tcl_AsyncMark) (Tcl_AsyncHandler async); /* 74 */ int (*tcl_AsyncReady) (void); /* 75 */ - void (*reserved76)(void); - void (*reserved77)(void); + void (*tcl_BackgroundError) (Tcl_Interp *interp); /* 76 */ + char (*tcl_Backslash) (const char *src, int *readPtr); /* 77 */ 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 (*tcl_CallWhenDeleted) (Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, ClientData clientData); /* 79 */ + void (*tcl_CancelIdleCall) (Tcl_IdleProc *idleProc, ClientData clientData); /* 80 */ int (*tcl_Close) (Tcl_Interp *interp, Tcl_Channel chan); /* 81 */ int (*tcl_CommandComplete) (const char *cmd); /* 82 */ - char * (*tcl_Concat) (int argc, const char *const *argv); /* 83 */ - size_t (*tcl_ConvertElement) (const char *src, char *dst, int flags); /* 84 */ - size_t (*tcl_ConvertCountedElement) (const char *src, size_t length, char *dst, int flags); /* 85 */ - int (*tcl_CreateAlias) (Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int argc, const char *const *argv); /* 86 */ - int (*tcl_CreateAliasObj) (Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]); /* 87 */ - Tcl_Channel (*tcl_CreateChannel) (const Tcl_ChannelType *typePtr, const char *chanName, void *instanceData, int mask); /* 88 */ - void (*tcl_CreateChannelHandler) (Tcl_Channel chan, int mask, Tcl_ChannelProc *proc, void *clientData); /* 89 */ - void (*tcl_CreateCloseHandler) (Tcl_Channel chan, Tcl_CloseProc *proc, void *clientData); /* 90 */ - Tcl_Command (*tcl_CreateCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_CmdProc *proc, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 91 */ - void (*tcl_CreateEventSource) (Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, void *clientData); /* 92 */ - void (*tcl_CreateExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 93 */ + char * (*tcl_Concat) (int argc, CONST84 char *const *argv); /* 83 */ + int (*tcl_ConvertElement) (const char *src, char *dst, int flags); /* 84 */ + int (*tcl_ConvertCountedElement) (const char *src, int length, char *dst, int flags); /* 85 */ + int (*tcl_CreateAlias) (Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, int argc, CONST84 char *const *argv); /* 86 */ + int (*tcl_CreateAliasObj) (Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]); /* 87 */ + Tcl_Channel (*tcl_CreateChannel) (const Tcl_ChannelType *typePtr, const char *chanName, ClientData instanceData, int mask); /* 88 */ + void (*tcl_CreateChannelHandler) (Tcl_Channel chan, int mask, Tcl_ChannelProc *proc, ClientData clientData); /* 89 */ + void (*tcl_CreateCloseHandler) (Tcl_Channel chan, Tcl_CloseProc *proc, ClientData clientData); /* 90 */ + Tcl_Command (*tcl_CreateCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_CmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 91 */ + void (*tcl_CreateEventSource) (Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, ClientData clientData); /* 92 */ + void (*tcl_CreateExitHandler) (Tcl_ExitProc *proc, ClientData clientData); /* 93 */ Tcl_Interp * (*tcl_CreateInterp) (void); /* 94 */ - void (*reserved95)(void); - Tcl_Command (*tcl_CreateObjCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 96 */ - Tcl_Interp * (*tcl_CreateSlave) (Tcl_Interp *interp, const char *slaveName, int isSafe); /* 97 */ - Tcl_TimerToken (*tcl_CreateTimerHandler) (int milliseconds, Tcl_TimerProc *proc, void *clientData); /* 98 */ - Tcl_Trace (*tcl_CreateTrace) (Tcl_Interp *interp, int level, Tcl_CmdTraceProc *proc, void *clientData); /* 99 */ + void (*tcl_CreateMathFunc) (Tcl_Interp *interp, const char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, ClientData clientData); /* 95 */ + Tcl_Command (*tcl_CreateObjCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 96 */ + Tcl_Interp * (*tcl_CreateSlave) (Tcl_Interp *interp, const char *name, int isSafe); /* 97 */ + Tcl_TimerToken (*tcl_CreateTimerHandler) (int milliseconds, Tcl_TimerProc *proc, ClientData clientData); /* 98 */ + Tcl_Trace (*tcl_CreateTrace) (Tcl_Interp *interp, int level, Tcl_CmdTraceProc *proc, ClientData clientData); /* 99 */ void (*tcl_DeleteAssocData) (Tcl_Interp *interp, const char *name); /* 100 */ - void (*tcl_DeleteChannelHandler) (Tcl_Channel chan, Tcl_ChannelProc *proc, void *clientData); /* 101 */ - void (*tcl_DeleteCloseHandler) (Tcl_Channel chan, Tcl_CloseProc *proc, void *clientData); /* 102 */ + void (*tcl_DeleteChannelHandler) (Tcl_Channel chan, Tcl_ChannelProc *proc, ClientData clientData); /* 101 */ + void (*tcl_DeleteCloseHandler) (Tcl_Channel chan, Tcl_CloseProc *proc, ClientData clientData); /* 102 */ int (*tcl_DeleteCommand) (Tcl_Interp *interp, const char *cmdName); /* 103 */ int (*tcl_DeleteCommandFromToken) (Tcl_Interp *interp, Tcl_Command command); /* 104 */ - void (*tcl_DeleteEvents) (Tcl_EventDeleteProc *proc, void *clientData); /* 105 */ - void (*tcl_DeleteEventSource) (Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, void *clientData); /* 106 */ - void (*tcl_DeleteExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 107 */ + void (*tcl_DeleteEvents) (Tcl_EventDeleteProc *proc, ClientData clientData); /* 105 */ + void (*tcl_DeleteEventSource) (Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, ClientData clientData); /* 106 */ + void (*tcl_DeleteExitHandler) (Tcl_ExitProc *proc, ClientData clientData); /* 107 */ void (*tcl_DeleteHashEntry) (Tcl_HashEntry *entryPtr); /* 108 */ void (*tcl_DeleteHashTable) (Tcl_HashTable *tablePtr); /* 109 */ void (*tcl_DeleteInterp) (Tcl_Interp *interp); /* 110 */ void (*tcl_DetachPids) (int numPids, Tcl_Pid *pidPtr); /* 111 */ void (*tcl_DeleteTimerHandler) (Tcl_TimerToken token); /* 112 */ void (*tcl_DeleteTrace) (Tcl_Interp *interp, Tcl_Trace trace); /* 113 */ - void (*tcl_DontCallWhenDeleted) (Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, void *clientData); /* 114 */ + void (*tcl_DontCallWhenDeleted) (Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, ClientData clientData); /* 114 */ int (*tcl_DoOneEvent) (int flags); /* 115 */ - void (*tcl_DoWhenIdle) (Tcl_IdleProc *proc, void *clientData); /* 116 */ - char * (*tcl_DStringAppend) (Tcl_DString *dsPtr, const char *bytes, size_t length); /* 117 */ + void (*tcl_DoWhenIdle) (Tcl_IdleProc *proc, ClientData clientData); /* 116 */ + char * (*tcl_DStringAppend) (Tcl_DString *dsPtr, const char *bytes, int length); /* 117 */ char * (*tcl_DStringAppendElement) (Tcl_DString *dsPtr, const char *element); /* 118 */ void (*tcl_DStringEndSublist) (Tcl_DString *dsPtr); /* 119 */ void (*tcl_DStringFree) (Tcl_DString *dsPtr); /* 120 */ void (*tcl_DStringGetResult) (Tcl_Interp *interp, Tcl_DString *dsPtr); /* 121 */ void (*tcl_DStringInit) (Tcl_DString *dsPtr); /* 122 */ void (*tcl_DStringResult) (Tcl_Interp *interp, Tcl_DString *dsPtr); /* 123 */ - void (*tcl_DStringSetLength) (Tcl_DString *dsPtr, size_t length); /* 124 */ + void (*tcl_DStringSetLength) (Tcl_DString *dsPtr, int length); /* 124 */ void (*tcl_DStringStartSublist) (Tcl_DString *dsPtr); /* 125 */ int (*tcl_Eof) (Tcl_Channel chan); /* 126 */ - const char * (*tcl_ErrnoId) (void); /* 127 */ - const char * (*tcl_ErrnoMsg) (int err); /* 128 */ - void (*reserved129)(void); + CONST84_RETURN char * (*tcl_ErrnoId) (void); /* 127 */ + CONST84_RETURN char * (*tcl_ErrnoMsg) (int err); /* 128 */ + int (*tcl_Eval) (Tcl_Interp *interp, const char *script); /* 129 */ int (*tcl_EvalFile) (Tcl_Interp *interp, const char *fileName); /* 130 */ - void (*reserved131)(void); - void (*tcl_EventuallyFree) (void *clientData, Tcl_FreeProc *freeProc); /* 132 */ + int (*tcl_EvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 131 */ + void (*tcl_EventuallyFree) (ClientData clientData, Tcl_FreeProc *freeProc); /* 132 */ TCL_NORETURN1 void (*tcl_Exit) (int status); /* 133 */ int (*tcl_ExposeCommand) (Tcl_Interp *interp, const char *hiddenCmdToken, const char *cmdName); /* 134 */ int (*tcl_ExprBoolean) (Tcl_Interp *interp, const char *expr, int *ptr); /* 135 */ int (*tcl_ExprBooleanObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *ptr); /* 136 */ int (*tcl_ExprDouble) (Tcl_Interp *interp, const char *expr, double *ptr); /* 137 */ @@ -1926,273 +2004,273 @@ int (*tcl_ExprLong) (Tcl_Interp *interp, const char *expr, long *ptr); /* 139 */ int (*tcl_ExprLongObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, long *ptr); /* 140 */ int (*tcl_ExprObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj **resultPtrPtr); /* 141 */ int (*tcl_ExprString) (Tcl_Interp *interp, const char *expr); /* 142 */ void (*tcl_Finalize) (void); /* 143 */ - void (*reserved144)(void); + void (*tcl_FindExecutable) (const char *argv0); /* 144 */ Tcl_HashEntry * (*tcl_FirstHashEntry) (Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 145 */ int (*tcl_Flush) (Tcl_Channel chan); /* 146 */ void (*tcl_FreeResult) (Tcl_Interp *interp); /* 147 */ - int (*tcl_GetAlias) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *argcPtr, const char ***argvPtr); /* 148 */ - int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */ - void * (*tcl_GetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr); /* 150 */ + int (*tcl_GetAlias) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *argcPtr, CONST84 char ***argvPtr); /* 148 */ + int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */ + ClientData (*tcl_GetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr); /* 150 */ Tcl_Channel (*tcl_GetChannel) (Tcl_Interp *interp, const char *chanName, int *modePtr); /* 151 */ int (*tcl_GetChannelBufferSize) (Tcl_Channel chan); /* 152 */ - int (*tcl_GetChannelHandle) (Tcl_Channel chan, int direction, void **handlePtr); /* 153 */ - void * (*tcl_GetChannelInstanceData) (Tcl_Channel chan); /* 154 */ + int (*tcl_GetChannelHandle) (Tcl_Channel chan, int direction, ClientData *handlePtr); /* 153 */ + ClientData (*tcl_GetChannelInstanceData) (Tcl_Channel chan); /* 154 */ int (*tcl_GetChannelMode) (Tcl_Channel chan); /* 155 */ - const char * (*tcl_GetChannelName) (Tcl_Channel chan); /* 156 */ + CONST84_RETURN char * (*tcl_GetChannelName) (Tcl_Channel chan); /* 156 */ int (*tcl_GetChannelOption) (Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, Tcl_DString *dsPtr); /* 157 */ - const Tcl_ChannelType * (*tcl_GetChannelType) (Tcl_Channel chan); /* 158 */ + CONST86 Tcl_ChannelType * (*tcl_GetChannelType) (Tcl_Channel chan); /* 158 */ int (*tcl_GetCommandInfo) (Tcl_Interp *interp, const char *cmdName, Tcl_CmdInfo *infoPtr); /* 159 */ - const char * (*tcl_GetCommandName) (Tcl_Interp *interp, Tcl_Command command); /* 160 */ + CONST84_RETURN char * (*tcl_GetCommandName) (Tcl_Interp *interp, Tcl_Command command); /* 160 */ int (*tcl_GetErrno) (void); /* 161 */ - const char * (*tcl_GetHostName) (void); /* 162 */ - int (*tcl_GetInterpPath) (Tcl_Interp *askInterp, Tcl_Interp *slaveInterp); /* 163 */ + CONST84_RETURN char * (*tcl_GetHostName) (void); /* 162 */ + int (*tcl_GetInterpPath) (Tcl_Interp *interp, Tcl_Interp *childInterp); /* 163 */ Tcl_Interp * (*tcl_GetMaster) (Tcl_Interp *interp); /* 164 */ const char * (*tcl_GetNameOfExecutable) (void); /* 165 */ Tcl_Obj * (*tcl_GetObjResult) (Tcl_Interp *interp); /* 166 */ #if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ - int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, void **filePtr); /* 167 */ + int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, ClientData *filePtr); /* 167 */ #endif /* UNIX */ #if defined(_WIN32) /* WIN */ void (*reserved167)(void); #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ - int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, void **filePtr); /* 167 */ + int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, ClientData *filePtr); /* 167 */ #endif /* MACOSX */ Tcl_PathType (*tcl_GetPathType) (const char *path); /* 168 */ - size_t (*tcl_Gets) (Tcl_Channel chan, Tcl_DString *dsPtr); /* 169 */ - size_t (*tcl_GetsObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 170 */ + int (*tcl_Gets) (Tcl_Channel chan, Tcl_DString *dsPtr); /* 169 */ + int (*tcl_GetsObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 170 */ int (*tcl_GetServiceMode) (void); /* 171 */ - Tcl_Interp * (*tcl_GetSlave) (Tcl_Interp *interp, const char *slaveName); /* 172 */ + Tcl_Interp * (*tcl_GetSlave) (Tcl_Interp *interp, const char *name); /* 172 */ Tcl_Channel (*tcl_GetStdChannel) (int type); /* 173 */ - void (*reserved174)(void); - void (*reserved175)(void); - const char * (*tcl_GetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 176 */ - void (*reserved177)(void); - void (*reserved178)(void); + CONST84_RETURN char * (*tcl_GetStringResult) (Tcl_Interp *interp); /* 174 */ + CONST84_RETURN char * (*tcl_GetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 175 */ + CONST84_RETURN char * (*tcl_GetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 176 */ + int (*tcl_GlobalEval) (Tcl_Interp *interp, const char *command); /* 177 */ + int (*tcl_GlobalEvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 178 */ int (*tcl_HideCommand) (Tcl_Interp *interp, const char *cmdName, const char *hiddenCmdToken); /* 179 */ int (*tcl_Init) (Tcl_Interp *interp); /* 180 */ void (*tcl_InitHashTable) (Tcl_HashTable *tablePtr, int keyType); /* 181 */ int (*tcl_InputBlocked) (Tcl_Channel chan); /* 182 */ int (*tcl_InputBuffered) (Tcl_Channel chan); /* 183 */ int (*tcl_InterpDeleted) (Tcl_Interp *interp); /* 184 */ int (*tcl_IsSafe) (Tcl_Interp *interp); /* 185 */ - char * (*tcl_JoinPath) (int argc, const char *const *argv, Tcl_DString *resultPtr); /* 186 */ - int (*tcl_LinkVar) (Tcl_Interp *interp, const char *varName, void *addr, int type); /* 187 */ + char * (*tcl_JoinPath) (int argc, CONST84 char *const *argv, Tcl_DString *resultPtr); /* 186 */ + int (*tcl_LinkVar) (Tcl_Interp *interp, const char *varName, char *addr, int type); /* 187 */ void (*reserved188)(void); - Tcl_Channel (*tcl_MakeFileChannel) (void *handle, int mode); /* 189 */ + Tcl_Channel (*tcl_MakeFileChannel) (ClientData handle, int mode); /* 189 */ int (*tcl_MakeSafe) (Tcl_Interp *interp); /* 190 */ - Tcl_Channel (*tcl_MakeTcpClientChannel) (void *tcpSocket); /* 191 */ - char * (*tcl_Merge) (int argc, const char *const *argv); /* 192 */ + Tcl_Channel (*tcl_MakeTcpClientChannel) (ClientData tcpSocket); /* 191 */ + char * (*tcl_Merge) (int argc, CONST84 char *const *argv); /* 192 */ Tcl_HashEntry * (*tcl_NextHashEntry) (Tcl_HashSearch *searchPtr); /* 193 */ void (*tcl_NotifyChannel) (Tcl_Channel channel, int mask); /* 194 */ Tcl_Obj * (*tcl_ObjGetVar2) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 195 */ Tcl_Obj * (*tcl_ObjSetVar2) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags); /* 196 */ - Tcl_Channel (*tcl_OpenCommandChannel) (Tcl_Interp *interp, int argc, const char **argv, int flags); /* 197 */ + Tcl_Channel (*tcl_OpenCommandChannel) (Tcl_Interp *interp, int argc, CONST84 char **argv, int flags); /* 197 */ Tcl_Channel (*tcl_OpenFileChannel) (Tcl_Interp *interp, const char *fileName, const char *modeString, int permissions); /* 198 */ Tcl_Channel (*tcl_OpenTcpClient) (Tcl_Interp *interp, int port, const char *address, const char *myaddr, int myport, int async); /* 199 */ - Tcl_Channel (*tcl_OpenTcpServer) (Tcl_Interp *interp, int port, const char *host, Tcl_TcpAcceptProc *acceptProc, void *callbackData); /* 200 */ - void (*tcl_Preserve) (void *data); /* 201 */ + Tcl_Channel (*tcl_OpenTcpServer) (Tcl_Interp *interp, int port, const char *host, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData); /* 200 */ + void (*tcl_Preserve) (ClientData data); /* 201 */ void (*tcl_PrintDouble) (Tcl_Interp *interp, double value, char *dst); /* 202 */ int (*tcl_PutEnv) (const char *assignment); /* 203 */ - const char * (*tcl_PosixError) (Tcl_Interp *interp); /* 204 */ + CONST84_RETURN char * (*tcl_PosixError) (Tcl_Interp *interp); /* 204 */ void (*tcl_QueueEvent) (Tcl_Event *evPtr, Tcl_QueuePosition position); /* 205 */ - size_t (*tcl_Read) (Tcl_Channel chan, char *bufPtr, size_t toRead); /* 206 */ + int (*tcl_Read) (Tcl_Channel chan, char *bufPtr, int toRead); /* 206 */ void (*tcl_ReapDetachedProcs) (void); /* 207 */ int (*tcl_RecordAndEval) (Tcl_Interp *interp, const char *cmd, int flags); /* 208 */ int (*tcl_RecordAndEvalObj) (Tcl_Interp *interp, Tcl_Obj *cmdPtr, int flags); /* 209 */ void (*tcl_RegisterChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 210 */ void (*tcl_RegisterObjType) (const Tcl_ObjType *typePtr); /* 211 */ Tcl_RegExp (*tcl_RegExpCompile) (Tcl_Interp *interp, const char *pattern); /* 212 */ int (*tcl_RegExpExec) (Tcl_Interp *interp, Tcl_RegExp regexp, const char *text, const char *start); /* 213 */ int (*tcl_RegExpMatch) (Tcl_Interp *interp, const char *text, const char *pattern); /* 214 */ - void (*tcl_RegExpRange) (Tcl_RegExp regexp, size_t index, const char **startPtr, const char **endPtr); /* 215 */ - void (*tcl_Release) (void *clientData); /* 216 */ + void (*tcl_RegExpRange) (Tcl_RegExp regexp, int index, CONST84 char **startPtr, CONST84 char **endPtr); /* 215 */ + void (*tcl_Release) (ClientData clientData); /* 216 */ void (*tcl_ResetResult) (Tcl_Interp *interp); /* 217 */ - size_t (*tcl_ScanElement) (const char *src, int *flagPtr); /* 218 */ - size_t (*tcl_ScanCountedElement) (const char *src, size_t length, int *flagPtr); /* 219 */ - void (*reserved220)(void); + int (*tcl_ScanElement) (const char *src, int *flagPtr); /* 218 */ + int (*tcl_ScanCountedElement) (const char *src, int length, int *flagPtr); /* 219 */ + int (*tcl_SeekOld) (Tcl_Channel chan, int offset, int mode); /* 220 */ int (*tcl_ServiceAll) (void); /* 221 */ int (*tcl_ServiceEvent) (int flags); /* 222 */ - void (*tcl_SetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc *proc, void *clientData); /* 223 */ + void (*tcl_SetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc *proc, ClientData clientData); /* 223 */ void (*tcl_SetChannelBufferSize) (Tcl_Channel chan, int sz); /* 224 */ int (*tcl_SetChannelOption) (Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, const char *newValue); /* 225 */ int (*tcl_SetCommandInfo) (Tcl_Interp *interp, const char *cmdName, const Tcl_CmdInfo *infoPtr); /* 226 */ void (*tcl_SetErrno) (int err); /* 227 */ void (*tcl_SetErrorCode) (Tcl_Interp *interp, ...); /* 228 */ void (*tcl_SetMaxBlockTime) (const Tcl_Time *timePtr); /* 229 */ - void (*reserved230)(void); + void (*tcl_SetPanicProc) (TCL_NORETURN1 Tcl_PanicProc *panicProc); /* 230 */ int (*tcl_SetRecursionLimit) (Tcl_Interp *interp, int depth); /* 231 */ - void (*reserved232)(void); + void (*tcl_SetResult) (Tcl_Interp *interp, char *result, Tcl_FreeProc *freeProc); /* 232 */ int (*tcl_SetServiceMode) (int mode); /* 233 */ void (*tcl_SetObjErrorCode) (Tcl_Interp *interp, Tcl_Obj *errorObjPtr); /* 234 */ void (*tcl_SetObjResult) (Tcl_Interp *interp, Tcl_Obj *resultObjPtr); /* 235 */ void (*tcl_SetStdChannel) (Tcl_Channel channel, int type); /* 236 */ - void (*reserved237)(void); - const char * (*tcl_SetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, const char *newValue, int flags); /* 238 */ - const char * (*tcl_SignalId) (int sig); /* 239 */ - const char * (*tcl_SignalMsg) (int sig); /* 240 */ + CONST84_RETURN char * (*tcl_SetVar) (Tcl_Interp *interp, const char *varName, const char *newValue, int flags); /* 237 */ + CONST84_RETURN char * (*tcl_SetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, const char *newValue, int flags); /* 238 */ + CONST84_RETURN char * (*tcl_SignalId) (int sig); /* 239 */ + CONST84_RETURN char * (*tcl_SignalMsg) (int sig); /* 240 */ void (*tcl_SourceRCFile) (Tcl_Interp *interp); /* 241 */ - int (*tcl_SplitList) (Tcl_Interp *interp, const char *listStr, int *argcPtr, const char ***argvPtr); /* 242 */ - void (*tcl_SplitPath) (const char *path, int *argcPtr, const char ***argvPtr); /* 243 */ - void (*reserved244)(void); - void (*reserved245)(void); - void (*reserved246)(void); - void (*reserved247)(void); - int (*tcl_TraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, void *clientData); /* 248 */ + int (*tcl_SplitList) (Tcl_Interp *interp, const char *listStr, int *argcPtr, CONST84 char ***argvPtr); /* 242 */ + void (*tcl_SplitPath) (const char *path, int *argcPtr, CONST84 char ***argvPtr); /* 243 */ + void (*tcl_StaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 244 */ + int (*tcl_StringMatch) (const char *str, const char *pattern); /* 245 */ + int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */ + int (*tcl_TraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 247 */ + int (*tcl_TraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 248 */ char * (*tcl_TranslateFileName) (Tcl_Interp *interp, const char *name, Tcl_DString *bufferPtr); /* 249 */ - size_t (*tcl_Ungets) (Tcl_Channel chan, const char *str, size_t len, int atHead); /* 250 */ + int (*tcl_Ungets) (Tcl_Channel chan, const char *str, int len, int atHead); /* 250 */ void (*tcl_UnlinkVar) (Tcl_Interp *interp, const char *varName); /* 251 */ int (*tcl_UnregisterChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 252 */ - void (*reserved253)(void); + int (*tcl_UnsetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 253 */ int (*tcl_UnsetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 254 */ - void (*reserved255)(void); - void (*tcl_UntraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, void *clientData); /* 256 */ + void (*tcl_UntraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 255 */ + void (*tcl_UntraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 256 */ void (*tcl_UpdateLinkedVar) (Tcl_Interp *interp, const char *varName); /* 257 */ - void (*reserved258)(void); + int (*tcl_UpVar) (Tcl_Interp *interp, const char *frameName, const char *varName, const char *localName, int flags); /* 258 */ int (*tcl_UpVar2) (Tcl_Interp *interp, const char *frameName, const char *part1, const char *part2, const char *localName, int flags); /* 259 */ int (*tcl_VarEval) (Tcl_Interp *interp, ...); /* 260 */ - void (*reserved261)(void); - void * (*tcl_VarTraceInfo2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, void *prevClientData); /* 262 */ - size_t (*tcl_Write) (Tcl_Channel chan, const char *s, size_t slen); /* 263 */ + ClientData (*tcl_VarTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 261 */ + ClientData (*tcl_VarTraceInfo2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 262 */ + int (*tcl_Write) (Tcl_Channel chan, const char *s, int slen); /* 263 */ void (*tcl_WrongNumArgs) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], const char *message); /* 264 */ int (*tcl_DumpActiveMemory) (const char *fileName); /* 265 */ void (*tcl_ValidateAllMemory) (const char *file, int line); /* 266 */ - void (*reserved267)(void); - void (*reserved268)(void); + void (*tcl_AppendResultVA) (Tcl_Interp *interp, va_list argList); /* 267 */ + void (*tcl_AppendStringsToObjVA) (Tcl_Obj *objPtr, va_list argList); /* 268 */ char * (*tcl_HashStats) (Tcl_HashTable *tablePtr); /* 269 */ - const char * (*tcl_ParseVar) (Tcl_Interp *interp, const char *start, const char **termPtr); /* 270 */ - void (*reserved271)(void); - const char * (*tcl_PkgPresentEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 272 */ - void (*reserved273)(void); - void (*reserved274)(void); - void (*reserved275)(void); - void (*reserved276)(void); + CONST84_RETURN char * (*tcl_ParseVar) (Tcl_Interp *interp, const char *start, CONST84 char **termPtr); /* 270 */ + CONST84_RETURN char * (*tcl_PkgPresent) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 271 */ + CONST84_RETURN char * (*tcl_PkgPresentEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 272 */ + int (*tcl_PkgProvide) (Tcl_Interp *interp, const char *name, const char *version); /* 273 */ + CONST84_RETURN char * (*tcl_PkgRequire) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 274 */ + void (*tcl_SetErrorCodeVA) (Tcl_Interp *interp, va_list argList); /* 275 */ + int (*tcl_VarEvalVA) (Tcl_Interp *interp, va_list argList); /* 276 */ Tcl_Pid (*tcl_WaitPid) (Tcl_Pid pid, int *statPtr, int options); /* 277 */ - void (*reserved278)(void); + TCL_NORETURN1 void (*tcl_PanicVA) (const char *format, va_list argList); /* 278 */ void (*tcl_GetVersion) (int *major, int *minor, int *patchLevel, int *type); /* 279 */ void (*tcl_InitMemory) (Tcl_Interp *interp); /* 280 */ - Tcl_Channel (*tcl_StackChannel) (Tcl_Interp *interp, const Tcl_ChannelType *typePtr, void *instanceData, int mask, Tcl_Channel prevChan); /* 281 */ + Tcl_Channel (*tcl_StackChannel) (Tcl_Interp *interp, const Tcl_ChannelType *typePtr, ClientData instanceData, int mask, Tcl_Channel prevChan); /* 281 */ int (*tcl_UnstackChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 282 */ Tcl_Channel (*tcl_GetStackedChannel) (Tcl_Channel chan); /* 283 */ void (*tcl_SetMainLoop) (Tcl_MainLoopProc *proc); /* 284 */ void (*reserved285)(void); void (*tcl_AppendObjToObj) (Tcl_Obj *objPtr, Tcl_Obj *appendObjPtr); /* 286 */ Tcl_Encoding (*tcl_CreateEncoding) (const Tcl_EncodingType *typePtr); /* 287 */ - void (*tcl_CreateThreadExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 288 */ - void (*tcl_DeleteThreadExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 289 */ - void (*reserved290)(void); - int (*tcl_EvalEx) (Tcl_Interp *interp, const char *script, size_t numBytes, int flags); /* 291 */ + void (*tcl_CreateThreadExitHandler) (Tcl_ExitProc *proc, ClientData clientData); /* 288 */ + void (*tcl_DeleteThreadExitHandler) (Tcl_ExitProc *proc, ClientData clientData); /* 289 */ + void (*tcl_DiscardResult) (Tcl_SavedResult *statePtr); /* 290 */ + int (*tcl_EvalEx) (Tcl_Interp *interp, const char *script, int numBytes, int flags); /* 291 */ int (*tcl_EvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* 292 */ int (*tcl_EvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 293 */ - TCL_NORETURN1 void (*tcl_ExitThread) (int status); /* 294 */ - int (*tcl_ExternalToUtf) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, size_t srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, size_t dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 295 */ - char * (*tcl_ExternalToUtfDString) (Tcl_Encoding encoding, const char *src, size_t srcLen, Tcl_DString *dsPtr); /* 296 */ + void (*tcl_ExitThread) (int status); /* 294 */ + int (*tcl_ExternalToUtf) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 295 */ + char * (*tcl_ExternalToUtfDString) (Tcl_Encoding encoding, const char *src, int srcLen, Tcl_DString *dsPtr); /* 296 */ void (*tcl_FinalizeThread) (void); /* 297 */ - void (*tcl_FinalizeNotifier) (void *clientData); /* 298 */ + void (*tcl_FinalizeNotifier) (ClientData clientData); /* 298 */ void (*tcl_FreeEncoding) (Tcl_Encoding encoding); /* 299 */ Tcl_ThreadId (*tcl_GetCurrentThread) (void); /* 300 */ Tcl_Encoding (*tcl_GetEncoding) (Tcl_Interp *interp, const char *name); /* 301 */ - const char * (*tcl_GetEncodingName) (Tcl_Encoding encoding); /* 302 */ + CONST84_RETURN char * (*tcl_GetEncodingName) (Tcl_Encoding encoding); /* 302 */ void (*tcl_GetEncodingNames) (Tcl_Interp *interp); /* 303 */ - int (*tcl_GetIndexFromObjStruct) (Tcl_Interp *interp, Tcl_Obj *objPtr, const void *tablePtr, size_t offset, const char *msg, int flags, int *indexPtr); /* 304 */ - void * (*tcl_GetThreadData) (Tcl_ThreadDataKey *keyPtr, size_t size); /* 305 */ + int (*tcl_GetIndexFromObjStruct) (Tcl_Interp *interp, Tcl_Obj *objPtr, const void *tablePtr, int offset, const char *msg, int flags, int *indexPtr); /* 304 */ + void * (*tcl_GetThreadData) (Tcl_ThreadDataKey *keyPtr, int size); /* 305 */ Tcl_Obj * (*tcl_GetVar2Ex) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 306 */ - void * (*tcl_InitNotifier) (void); /* 307 */ + ClientData (*tcl_InitNotifier) (void); /* 307 */ void (*tcl_MutexLock) (Tcl_Mutex *mutexPtr); /* 308 */ void (*tcl_MutexUnlock) (Tcl_Mutex *mutexPtr); /* 309 */ void (*tcl_ConditionNotify) (Tcl_Condition *condPtr); /* 310 */ void (*tcl_ConditionWait) (Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, const Tcl_Time *timePtr); /* 311 */ - size_t (*tcl_NumUtfChars) (const char *src, size_t length); /* 312 */ - size_t (*tcl_ReadChars) (Tcl_Channel channel, Tcl_Obj *objPtr, size_t charsToRead, int appendFlag); /* 313 */ - void (*reserved314)(void); - void (*reserved315)(void); + int (*tcl_NumUtfChars) (const char *src, int length); /* 312 */ + int (*tcl_ReadChars) (Tcl_Channel channel, Tcl_Obj *objPtr, int charsToRead, int appendFlag); /* 313 */ + void (*tcl_RestoreResult) (Tcl_Interp *interp, Tcl_SavedResult *statePtr); /* 314 */ + void (*tcl_SaveResult) (Tcl_Interp *interp, Tcl_SavedResult *statePtr); /* 315 */ int (*tcl_SetSystemEncoding) (Tcl_Interp *interp, const char *name); /* 316 */ Tcl_Obj * (*tcl_SetVar2Ex) (Tcl_Interp *interp, const char *part1, const char *part2, Tcl_Obj *newValuePtr, int flags); /* 317 */ void (*tcl_ThreadAlert) (Tcl_ThreadId threadId); /* 318 */ void (*tcl_ThreadQueueEvent) (Tcl_ThreadId threadId, Tcl_Event *evPtr, Tcl_QueuePosition position); /* 319 */ - int (*tcl_UniCharAtIndex) (const char *src, size_t index); /* 320 */ - int (*tcl_UniCharToLower) (int ch); /* 321 */ - int (*tcl_UniCharToTitle) (int ch); /* 322 */ - int (*tcl_UniCharToUpper) (int ch); /* 323 */ + Tcl_UniChar (*tcl_UniCharAtIndex) (const char *src, int index); /* 320 */ + Tcl_UniChar (*tcl_UniCharToLower) (int ch); /* 321 */ + Tcl_UniChar (*tcl_UniCharToTitle) (int ch); /* 322 */ + Tcl_UniChar (*tcl_UniCharToUpper) (int ch); /* 323 */ int (*tcl_UniCharToUtf) (int ch, char *buf); /* 324 */ - const char * (*tcl_UtfAtIndex) (const char *src, size_t index); /* 325 */ - int (*tcl_UtfCharComplete) (const char *src, size_t length); /* 326 */ - size_t (*tcl_UtfBackslash) (const char *src, int *readPtr, char *dst); /* 327 */ - const char * (*tcl_UtfFindFirst) (const char *src, int ch); /* 328 */ - const char * (*tcl_UtfFindLast) (const char *src, int ch); /* 329 */ - const char * (*tcl_UtfNext) (const char *src); /* 330 */ - const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 331 */ - int (*tcl_UtfToExternal) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, size_t srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, size_t dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 332 */ - char * (*tcl_UtfToExternalDString) (Tcl_Encoding encoding, const char *src, size_t srcLen, Tcl_DString *dsPtr); /* 333 */ + CONST84_RETURN char * (*tcl_UtfAtIndex) (const char *src, int index); /* 325 */ + int (*tcl_UtfCharComplete) (const char *src, int length); /* 326 */ + int (*tcl_UtfBackslash) (const char *src, int *readPtr, char *dst); /* 327 */ + CONST84_RETURN char * (*tcl_UtfFindFirst) (const char *src, int ch); /* 328 */ + CONST84_RETURN char * (*tcl_UtfFindLast) (const char *src, int ch); /* 329 */ + CONST84_RETURN char * (*tcl_UtfNext) (const char *src); /* 330 */ + CONST84_RETURN char * (*tcl_UtfPrev) (const char *src, const char *start); /* 331 */ + int (*tcl_UtfToExternal) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 332 */ + char * (*tcl_UtfToExternalDString) (Tcl_Encoding encoding, const char *src, int srcLen, Tcl_DString *dsPtr); /* 333 */ int (*tcl_UtfToLower) (char *src); /* 334 */ int (*tcl_UtfToTitle) (char *src); /* 335 */ int (*tcl_UtfToUniChar) (const char *src, Tcl_UniChar *chPtr); /* 336 */ int (*tcl_UtfToUpper) (char *src); /* 337 */ - size_t (*tcl_WriteChars) (Tcl_Channel chan, const char *src, size_t srcLen); /* 338 */ - size_t (*tcl_WriteObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 339 */ + int (*tcl_WriteChars) (Tcl_Channel chan, const char *src, int srcLen); /* 338 */ + int (*tcl_WriteObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 339 */ char * (*tcl_GetString) (Tcl_Obj *objPtr); /* 340 */ - void (*reserved341)(void); - void (*reserved342)(void); - void (*tcl_AlertNotifier) (void *clientData); /* 343 */ + CONST84_RETURN char * (*tcl_GetDefaultEncodingDir) (void); /* 341 */ + void (*tcl_SetDefaultEncodingDir) (const char *path); /* 342 */ + void (*tcl_AlertNotifier) (ClientData clientData); /* 343 */ void (*tcl_ServiceModeHook) (int mode); /* 344 */ int (*tcl_UniCharIsAlnum) (int ch); /* 345 */ int (*tcl_UniCharIsAlpha) (int ch); /* 346 */ int (*tcl_UniCharIsDigit) (int ch); /* 347 */ int (*tcl_UniCharIsLower) (int ch); /* 348 */ int (*tcl_UniCharIsSpace) (int ch); /* 349 */ int (*tcl_UniCharIsUpper) (int ch); /* 350 */ int (*tcl_UniCharIsWordChar) (int ch); /* 351 */ - size_t (*tcl_UniCharLen) (const Tcl_UniChar *uniStr); /* 352 */ - int (*tcl_UniCharNcmp) (const Tcl_UniChar *ucs, const Tcl_UniChar *uct, size_t numChars); /* 353 */ - char * (*tcl_UniCharToUtfDString) (const Tcl_UniChar *uniStr, size_t uniLength, Tcl_DString *dsPtr); /* 354 */ - Tcl_UniChar * (*tcl_UtfToUniCharDString) (const char *src, size_t length, Tcl_DString *dsPtr); /* 355 */ + int (*tcl_UniCharLen) (const Tcl_UniChar *uniStr); /* 352 */ + int (*tcl_UniCharNcmp) (const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned long numChars); /* 353 */ + char * (*tcl_UniCharToUtfDString) (const Tcl_UniChar *uniStr, int uniLength, Tcl_DString *dsPtr); /* 354 */ + Tcl_UniChar * (*tcl_UtfToUniCharDString) (const char *src, int length, Tcl_DString *dsPtr); /* 355 */ Tcl_RegExp (*tcl_GetRegExpFromObj) (Tcl_Interp *interp, Tcl_Obj *patObj, int flags); /* 356 */ - void (*reserved357)(void); + Tcl_Obj * (*tcl_EvalTokens) (Tcl_Interp *interp, Tcl_Token *tokenPtr, int count); /* 357 */ void (*tcl_FreeParse) (Tcl_Parse *parsePtr); /* 358 */ - void (*tcl_LogCommandInfo) (Tcl_Interp *interp, const char *script, const char *command, size_t length); /* 359 */ - int (*tcl_ParseBraces) (Tcl_Interp *interp, const char *start, size_t numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 360 */ - int (*tcl_ParseCommand) (Tcl_Interp *interp, const char *start, size_t numBytes, int nested, Tcl_Parse *parsePtr); /* 361 */ - int (*tcl_ParseExpr) (Tcl_Interp *interp, const char *start, size_t numBytes, Tcl_Parse *parsePtr); /* 362 */ - int (*tcl_ParseQuotedString) (Tcl_Interp *interp, const char *start, size_t numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 363 */ - int (*tcl_ParseVarName) (Tcl_Interp *interp, const char *start, size_t numBytes, Tcl_Parse *parsePtr, int append); /* 364 */ + void (*tcl_LogCommandInfo) (Tcl_Interp *interp, const char *script, const char *command, int length); /* 359 */ + int (*tcl_ParseBraces) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, CONST84 char **termPtr); /* 360 */ + int (*tcl_ParseCommand) (Tcl_Interp *interp, const char *start, int numBytes, int nested, Tcl_Parse *parsePtr); /* 361 */ + int (*tcl_ParseExpr) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr); /* 362 */ + int (*tcl_ParseQuotedString) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, CONST84 char **termPtr); /* 363 */ + int (*tcl_ParseVarName) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append); /* 364 */ char * (*tcl_GetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 365 */ int (*tcl_Chdir) (const char *dirName); /* 366 */ int (*tcl_Access) (const char *path, int mode); /* 367 */ int (*tcl_Stat) (const char *path, struct stat *bufPtr); /* 368 */ - int (*tcl_UtfNcmp) (const char *s1, const char *s2, size_t n); /* 369 */ - int (*tcl_UtfNcasecmp) (const char *s1, const char *s2, size_t n); /* 370 */ + int (*tcl_UtfNcmp) (const char *s1, const char *s2, unsigned long n); /* 369 */ + int (*tcl_UtfNcasecmp) (const char *s1, const char *s2, unsigned long n); /* 370 */ int (*tcl_StringCaseMatch) (const char *str, const char *pattern, int nocase); /* 371 */ int (*tcl_UniCharIsControl) (int ch); /* 372 */ int (*tcl_UniCharIsGraph) (int ch); /* 373 */ int (*tcl_UniCharIsPrint) (int ch); /* 374 */ int (*tcl_UniCharIsPunct) (int ch); /* 375 */ - int (*tcl_RegExpExecObj) (Tcl_Interp *interp, Tcl_RegExp regexp, Tcl_Obj *textObj, size_t offset, size_t nmatches, int flags); /* 376 */ + int (*tcl_RegExpExecObj) (Tcl_Interp *interp, Tcl_RegExp regexp, Tcl_Obj *textObj, int offset, int nmatches, int flags); /* 376 */ void (*tcl_RegExpGetInfo) (Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr); /* 377 */ - Tcl_Obj * (*tcl_NewUnicodeObj) (const Tcl_UniChar *unicode, size_t numChars); /* 378 */ - void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, size_t numChars); /* 379 */ - size_t (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 380 */ - int (*tcl_GetUniChar) (Tcl_Obj *objPtr, size_t index); /* 381 */ - void (*reserved382)(void); - Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, size_t first, size_t last); /* 383 */ - void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, size_t length); /* 384 */ + Tcl_Obj * (*tcl_NewUnicodeObj) (const Tcl_UniChar *unicode, int numChars); /* 378 */ + void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int numChars); /* 379 */ + int (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 380 */ + Tcl_UniChar (*tcl_GetUniChar) (Tcl_Obj *objPtr, int index); /* 381 */ + Tcl_UniChar * (*tcl_GetUnicode) (Tcl_Obj *objPtr); /* 382 */ + Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, int first, int last); /* 383 */ + void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int length); /* 384 */ int (*tcl_RegExpMatchObj) (Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); /* 385 */ void (*tcl_SetNotifier) (Tcl_NotifierProcs *notifierProcPtr); /* 386 */ Tcl_Mutex * (*tcl_GetAllocMutex) (void); /* 387 */ 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, int objc, Tcl_Obj *const objv[]); /* 390 */ + int (*tcl_ProcObjCmd) (ClientData clientData, Tcl_Interp *interp, int 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 */ - size_t (*tcl_ReadRaw) (Tcl_Channel chan, char *dst, size_t bytesToRead); /* 394 */ - size_t (*tcl_WriteRaw) (Tcl_Channel chan, const char *src, size_t srcLen); /* 395 */ + int (*tcl_CreateThread) (Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, ClientData clientData, int stackSize, int flags); /* 393 */ + int (*tcl_ReadRaw) (Tcl_Channel chan, char *dst, int bytesToRead); /* 394 */ + int (*tcl_WriteRaw) (Tcl_Channel chan, const char *src, int 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 */ + CONST84_RETURN char * (*tcl_ChannelName) (const Tcl_ChannelType *chanTypePtr); /* 398 */ Tcl_ChannelTypeVersion (*tcl_ChannelVersion) (const Tcl_ChannelType *chanTypePtr); /* 399 */ Tcl_DriverBlockModeProc * (*tcl_ChannelBlockModeProc) (const Tcl_ChannelType *chanTypePtr); /* 400 */ Tcl_DriverCloseProc * (*tcl_ChannelCloseProc) (const Tcl_ChannelType *chanTypePtr); /* 401 */ Tcl_DriverClose2Proc * (*tcl_ChannelClose2Proc) (const Tcl_ChannelType *chanTypePtr); /* 402 */ Tcl_DriverInputProc * (*tcl_ChannelInputProc) (const Tcl_ChannelType *chanTypePtr); /* 403 */ @@ -2209,28 +2287,28 @@ int (*tcl_IsChannelRegistered) (Tcl_Interp *interp, Tcl_Channel channel); /* 414 */ void (*tcl_CutChannel) (Tcl_Channel channel); /* 415 */ void (*tcl_SpliceChannel) (Tcl_Channel channel); /* 416 */ void (*tcl_ClearChannelHandlers) (Tcl_Channel channel); /* 417 */ int (*tcl_IsChannelExisting) (const char *channelName); /* 418 */ - int (*tcl_UniCharNcasecmp) (const Tcl_UniChar *ucs, const Tcl_UniChar *uct, size_t numChars); /* 419 */ + int (*tcl_UniCharNcasecmp) (const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned long numChars); /* 419 */ int (*tcl_UniCharCaseMatch) (const Tcl_UniChar *uniStr, const Tcl_UniChar *uniPattern, int nocase); /* 420 */ - void (*reserved421)(void); - void (*reserved422)(void); + Tcl_HashEntry * (*tcl_FindHashEntry) (Tcl_HashTable *tablePtr, const void *key); /* 421 */ + Tcl_HashEntry * (*tcl_CreateHashEntry) (Tcl_HashTable *tablePtr, const void *key, int *newPtr); /* 422 */ void (*tcl_InitCustomHashTable) (Tcl_HashTable *tablePtr, int keyType, const Tcl_HashKeyType *typePtr); /* 423 */ void (*tcl_InitObjHashTable) (Tcl_HashTable *tablePtr); /* 424 */ - void * (*tcl_CommandTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *procPtr, void *prevClientData); /* 425 */ - int (*tcl_TraceCommand) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, void *clientData); /* 426 */ - void (*tcl_UntraceCommand) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, void *clientData); /* 427 */ - void * (*tcl_AttemptAlloc) (size_t size); /* 428 */ - void * (*tcl_AttemptDbCkalloc) (size_t size, const char *file, int line); /* 429 */ - void * (*tcl_AttemptRealloc) (void *ptr, size_t size); /* 430 */ - void * (*tcl_AttemptDbCkrealloc) (void *ptr, size_t size, const char *file, int line); /* 431 */ - int (*tcl_AttemptSetObjLength) (Tcl_Obj *objPtr, size_t length); /* 432 */ + ClientData (*tcl_CommandTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *procPtr, ClientData prevClientData); /* 425 */ + int (*tcl_TraceCommand) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, ClientData clientData); /* 426 */ + void (*tcl_UntraceCommand) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, ClientData clientData); /* 427 */ + char * (*tcl_AttemptAlloc) (unsigned int size); /* 428 */ + char * (*tcl_AttemptDbCkalloc) (unsigned int size, const char *file, int line); /* 429 */ + char * (*tcl_AttemptRealloc) (char *ptr, unsigned int size); /* 430 */ + char * (*tcl_AttemptDbCkrealloc) (char *ptr, unsigned int size, const char *file, int line); /* 431 */ + int (*tcl_AttemptSetObjLength) (Tcl_Obj *objPtr, int length); /* 432 */ Tcl_ThreadId (*tcl_GetChannelThread) (Tcl_Channel channel); /* 433 */ Tcl_UniChar * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 434 */ - void (*reserved435)(void); - void (*reserved436)(void); + int (*tcl_GetMathFuncInfo) (Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, ClientData *clientDataPtr); /* 435 */ + Tcl_Obj * (*tcl_ListMathFuncs) (Tcl_Interp *interp, const char *pattern); /* 436 */ Tcl_Obj * (*tcl_SubstObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 437 */ int (*tcl_DetachChannel) (Tcl_Interp *interp, Tcl_Channel channel); /* 438 */ int (*tcl_IsStandardChannel) (Tcl_Channel channel); /* 439 */ int (*tcl_FSCopyFile) (Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr); /* 440 */ int (*tcl_FSCopyDirectory) (Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr); /* 441 */ @@ -2243,11 +2321,11 @@ int (*tcl_FSRenameFile) (Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr); /* 448 */ int (*tcl_FSLstat) (Tcl_Obj *pathPtr, Tcl_StatBuf *buf); /* 449 */ int (*tcl_FSUtime) (Tcl_Obj *pathPtr, struct utimbuf *tval); /* 450 */ int (*tcl_FSFileAttrsGet) (Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); /* 451 */ int (*tcl_FSFileAttrsSet) (Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr); /* 452 */ - const char *const * (*tcl_FSFileAttrStrings) (Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); /* 453 */ + const char *CONST86 * (*tcl_FSFileAttrStrings) (Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); /* 453 */ int (*tcl_FSStat) (Tcl_Obj *pathPtr, Tcl_StatBuf *buf); /* 454 */ int (*tcl_FSAccess) (Tcl_Obj *pathPtr, int mode); /* 455 */ Tcl_Channel (*tcl_FSOpenFileChannel) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *modeString, int permissions); /* 456 */ Tcl_Obj * (*tcl_FSGetCwd) (Tcl_Interp *interp); /* 457 */ int (*tcl_FSChdir) (Tcl_Obj *pathPtr); /* 458 */ @@ -2255,29 +2333,29 @@ Tcl_Obj * (*tcl_FSJoinPath) (Tcl_Obj *listObj, int elements); /* 460 */ Tcl_Obj * (*tcl_FSSplitPath) (Tcl_Obj *pathPtr, int *lenPtr); /* 461 */ int (*tcl_FSEqualPaths) (Tcl_Obj *firstPtr, Tcl_Obj *secondPtr); /* 462 */ Tcl_Obj * (*tcl_FSGetNormalizedPath) (Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 463 */ Tcl_Obj * (*tcl_FSJoinToPath) (Tcl_Obj *pathPtr, int objc, Tcl_Obj *const objv[]); /* 464 */ - void * (*tcl_FSGetInternalRep) (Tcl_Obj *pathPtr, const Tcl_Filesystem *fsPtr); /* 465 */ + ClientData (*tcl_FSGetInternalRep) (Tcl_Obj *pathPtr, const Tcl_Filesystem *fsPtr); /* 465 */ Tcl_Obj * (*tcl_FSGetTranslatedPath) (Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 466 */ int (*tcl_FSEvalFile) (Tcl_Interp *interp, Tcl_Obj *fileName); /* 467 */ - Tcl_Obj * (*tcl_FSNewNativePath) (const Tcl_Filesystem *fromFilesystem, void *clientData); /* 468 */ + Tcl_Obj * (*tcl_FSNewNativePath) (const Tcl_Filesystem *fromFilesystem, ClientData clientData); /* 468 */ const void * (*tcl_FSGetNativePath) (Tcl_Obj *pathPtr); /* 469 */ Tcl_Obj * (*tcl_FSFileSystemInfo) (Tcl_Obj *pathPtr); /* 470 */ Tcl_Obj * (*tcl_FSPathSeparator) (Tcl_Obj *pathPtr); /* 471 */ Tcl_Obj * (*tcl_FSListVolumes) (void); /* 472 */ - int (*tcl_FSRegister) (void *clientData, const Tcl_Filesystem *fsPtr); /* 473 */ + int (*tcl_FSRegister) (ClientData clientData, const Tcl_Filesystem *fsPtr); /* 473 */ int (*tcl_FSUnregister) (const Tcl_Filesystem *fsPtr); /* 474 */ - void * (*tcl_FSData) (const Tcl_Filesystem *fsPtr); /* 475 */ + ClientData (*tcl_FSData) (const Tcl_Filesystem *fsPtr); /* 475 */ const char * (*tcl_FSGetTranslatedStringPath) (Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 476 */ - const Tcl_Filesystem * (*tcl_FSGetFileSystemForPath) (Tcl_Obj *pathPtr); /* 477 */ + CONST86 Tcl_Filesystem * (*tcl_FSGetFileSystemForPath) (Tcl_Obj *pathPtr); /* 477 */ Tcl_PathType (*tcl_FSGetPathType) (Tcl_Obj *pathPtr); /* 478 */ int (*tcl_OutputBuffered) (Tcl_Channel chan); /* 479 */ void (*tcl_FSMountsChanged) (const Tcl_Filesystem *fsPtr); /* 480 */ - int (*tcl_EvalTokensStandard) (Tcl_Interp *interp, Tcl_Token *tokenPtr, size_t count); /* 481 */ + int (*tcl_EvalTokensStandard) (Tcl_Interp *interp, Tcl_Token *tokenPtr, int count); /* 481 */ void (*tcl_GetTime) (Tcl_Time *timeBuf); /* 482 */ - Tcl_Trace (*tcl_CreateObjTrace) (Tcl_Interp *interp, int level, int flags, Tcl_CmdObjTraceProc *objProc, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 483 */ + Tcl_Trace (*tcl_CreateObjTrace) (Tcl_Interp *interp, int level, int flags, Tcl_CmdObjTraceProc *objProc, ClientData clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 483 */ int (*tcl_GetCommandInfoFromToken) (Tcl_Command token, Tcl_CmdInfo *infoPtr); /* 484 */ int (*tcl_SetCommandInfoFromToken) (Tcl_Command token, const Tcl_CmdInfo *infoPtr); /* 485 */ Tcl_Obj * (*tcl_DbNewWideIntObj) (Tcl_WideInt wideValue, const char *file, int line); /* 486 */ int (*tcl_GetWideIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_WideInt *widePtr); /* 487 */ Tcl_Obj * (*tcl_NewWideIntObj) (Tcl_WideInt wideValue); /* 488 */ @@ -2296,11 +2374,11 @@ int (*tcl_DictObjPutKeyList) (Tcl_Interp *interp, Tcl_Obj *dictPtr, int keyc, Tcl_Obj *const *keyv, Tcl_Obj *valuePtr); /* 501 */ int (*tcl_DictObjRemoveKeyList) (Tcl_Interp *interp, Tcl_Obj *dictPtr, int keyc, Tcl_Obj *const *keyv); /* 502 */ Tcl_Obj * (*tcl_NewDictObj) (void); /* 503 */ Tcl_Obj * (*tcl_DbNewDictObj) (const char *file, int line); /* 504 */ void (*tcl_RegisterConfig) (Tcl_Interp *interp, const char *pkgName, const Tcl_Config *configuration, const char *valEncoding); /* 505 */ - Tcl_Namespace * (*tcl_CreateNamespace) (Tcl_Interp *interp, const char *name, void *clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 506 */ + Tcl_Namespace * (*tcl_CreateNamespace) (Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 506 */ void (*tcl_DeleteNamespace) (Tcl_Namespace *nsPtr); /* 507 */ int (*tcl_AppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 508 */ int (*tcl_Export) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 509 */ int (*tcl_Import) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite); /* 510 */ int (*tcl_ForgetImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 511 */ @@ -2309,13 +2387,13 @@ Tcl_Namespace * (*tcl_FindNamespace) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 514 */ Tcl_Command (*tcl_FindCommand) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 515 */ Tcl_Command (*tcl_GetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 516 */ void (*tcl_GetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 517 */ int (*tcl_FSEvalFileEx) (Tcl_Interp *interp, Tcl_Obj *fileName, const char *encodingName); /* 518 */ - void (*reserved519)(void); - void (*tcl_LimitAddHandler) (Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, void *clientData, Tcl_LimitHandlerDeleteProc *deleteProc); /* 520 */ - void (*tcl_LimitRemoveHandler) (Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, void *clientData); /* 521 */ + Tcl_ExitProc * (*tcl_SetExitProc) (TCL_NORETURN1 Tcl_ExitProc *proc); /* 519 */ + void (*tcl_LimitAddHandler) (Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, ClientData clientData, Tcl_LimitHandlerDeleteProc *deleteProc); /* 520 */ + void (*tcl_LimitRemoveHandler) (Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, ClientData clientData); /* 521 */ int (*tcl_LimitReady) (Tcl_Interp *interp); /* 522 */ int (*tcl_LimitCheck) (Tcl_Interp *interp); /* 523 */ int (*tcl_LimitExceeded) (Tcl_Interp *interp); /* 524 */ void (*tcl_LimitSetCommands) (Tcl_Interp *interp, int commandLimit); /* 525 */ void (*tcl_LimitSetTime) (Tcl_Interp *interp, Tcl_Time *timeLimitPtr); /* 526 */ @@ -2342,12 +2420,12 @@ int (*tcl_GetEnsembleSubcommandList) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj **subcmdListPtr); /* 547 */ int (*tcl_GetEnsembleMappingDict) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj **mapDictPtr); /* 548 */ int (*tcl_GetEnsembleUnknownHandler) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj **unknownListPtr); /* 549 */ int (*tcl_GetEnsembleFlags) (Tcl_Interp *interp, Tcl_Command token, int *flagsPtr); /* 550 */ int (*tcl_GetEnsembleNamespace) (Tcl_Interp *interp, Tcl_Command token, Tcl_Namespace **namespacePtrPtr); /* 551 */ - void (*tcl_SetTimeProc) (Tcl_GetTimeProc *getProc, Tcl_ScaleTimeProc *scaleProc, void *clientData); /* 552 */ - void (*tcl_QueryTimeProc) (Tcl_GetTimeProc **getProc, Tcl_ScaleTimeProc **scaleProc, void **clientData); /* 553 */ + void (*tcl_SetTimeProc) (Tcl_GetTimeProc *getProc, Tcl_ScaleTimeProc *scaleProc, ClientData clientData); /* 552 */ + void (*tcl_QueryTimeProc) (Tcl_GetTimeProc **getProc, Tcl_ScaleTimeProc **scaleProc, ClientData *clientData); /* 553 */ Tcl_DriverThreadActionProc * (*tcl_ChannelThreadActionProc) (const Tcl_ChannelType *chanTypePtr); /* 554 */ Tcl_Obj * (*tcl_NewBignumObj) (mp_int *value); /* 555 */ Tcl_Obj * (*tcl_DbNewBignumObj) (mp_int *value, const char *file, int line); /* 556 */ void (*tcl_SetBignumObj) (Tcl_Obj *obj, mp_int *value); /* 557 */ int (*tcl_GetBignumFromObj) (Tcl_Interp *interp, Tcl_Obj *obj, mp_int *value); /* 558 */ @@ -2365,24 +2443,24 @@ Tcl_Obj * (*tcl_GetEncodingSearchPath) (void); /* 570 */ int (*tcl_SetEncodingSearchPath) (Tcl_Obj *searchPath); /* 571 */ const char * (*tcl_GetEncodingNameFromEnvironment) (Tcl_DString *bufPtr); /* 572 */ int (*tcl_PkgRequireProc) (Tcl_Interp *interp, const char *name, int objc, Tcl_Obj *const objv[], void *clientDataPtr); /* 573 */ void (*tcl_AppendObjToErrorInfo) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 574 */ - void (*tcl_AppendLimitedToObj) (Tcl_Obj *objPtr, const char *bytes, size_t length, size_t limit, const char *ellipsis); /* 575 */ + void (*tcl_AppendLimitedToObj) (Tcl_Obj *objPtr, const char *bytes, int length, int limit, const char *ellipsis); /* 575 */ Tcl_Obj * (*tcl_Format) (Tcl_Interp *interp, const char *format, int objc, Tcl_Obj *const objv[]); /* 576 */ int (*tcl_AppendFormatToObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, const char *format, int objc, Tcl_Obj *const objv[]); /* 577 */ Tcl_Obj * (*tcl_ObjPrintf) (const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 578 */ void (*tcl_AppendPrintfToObj) (Tcl_Obj *objPtr, const char *format, ...) TCL_FORMAT_PRINTF(2, 3); /* 579 */ - int (*tcl_CancelEval) (Tcl_Interp *interp, Tcl_Obj *resultObjPtr, void *clientData, int flags); /* 580 */ + int (*tcl_CancelEval) (Tcl_Interp *interp, Tcl_Obj *resultObjPtr, ClientData clientData, int flags); /* 580 */ int (*tcl_Canceled) (Tcl_Interp *interp, int flags); /* 581 */ int (*tcl_CreatePipe) (Tcl_Interp *interp, Tcl_Channel *rchan, Tcl_Channel *wchan, int flags); /* 582 */ - Tcl_Command (*tcl_NRCreateCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, Tcl_ObjCmdProc *nreProc, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 583 */ + Tcl_Command (*tcl_NRCreateCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, Tcl_ObjCmdProc *nreProc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 583 */ int (*tcl_NREvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 584 */ int (*tcl_NREvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* 585 */ int (*tcl_NRCmdSwap) (Tcl_Interp *interp, Tcl_Command cmd, int objc, Tcl_Obj *const objv[], int flags); /* 586 */ - void (*tcl_NRAddCallback) (Tcl_Interp *interp, Tcl_NRPostProc *postProcPtr, void *data0, void *data1, void *data2, void *data3); /* 587 */ - int (*tcl_NRCallObjProc) (Tcl_Interp *interp, Tcl_ObjCmdProc *objProc, void *clientData, int objc, Tcl_Obj *const objv[]); /* 588 */ + void (*tcl_NRAddCallback) (Tcl_Interp *interp, Tcl_NRPostProc *postProcPtr, ClientData data0, ClientData data1, ClientData data2, ClientData data3); /* 587 */ + int (*tcl_NRCallObjProc) (Tcl_Interp *interp, Tcl_ObjCmdProc *objProc, ClientData clientData, int objc, Tcl_Obj *const objv[]); /* 588 */ unsigned (*tcl_GetFSDeviceFromStat) (const Tcl_StatBuf *statPtr); /* 589 */ unsigned (*tcl_GetFSInodeFromStat) (const Tcl_StatBuf *statPtr); /* 590 */ unsigned (*tcl_GetModeFromStat) (const Tcl_StatBuf *statPtr); /* 591 */ int (*tcl_GetLinkCountFromStat) (const Tcl_StatBuf *statPtr); /* 592 */ int (*tcl_GetUserIdFromStat) (const Tcl_StatBuf *statPtr); /* 593 */ @@ -2397,23 +2475,23 @@ int (*tcl_SetEnsembleParameterList) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj *paramList); /* 602 */ int (*tcl_GetEnsembleParameterList) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj **paramListPtr); /* 603 */ int (*tcl_ParseArgsObjv) (Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, int *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv); /* 604 */ int (*tcl_GetErrorLine) (Tcl_Interp *interp); /* 605 */ void (*tcl_SetErrorLine) (Tcl_Interp *interp, int lineNum); /* 606 */ - void (*tcl_TransferResult) (Tcl_Interp *sourceInterp, int result, Tcl_Interp *targetInterp); /* 607 */ + void (*tcl_TransferResult) (Tcl_Interp *sourceInterp, int code, Tcl_Interp *targetInterp); /* 607 */ int (*tcl_InterpActive) (Tcl_Interp *interp); /* 608 */ void (*tcl_BackgroundException) (Tcl_Interp *interp, int code); /* 609 */ int (*tcl_ZlibDeflate) (Tcl_Interp *interp, int format, Tcl_Obj *data, int level, Tcl_Obj *gzipHeaderDictObj); /* 610 */ - int (*tcl_ZlibInflate) (Tcl_Interp *interp, int format, Tcl_Obj *data, size_t buffersize, Tcl_Obj *gzipHeaderDictObj); /* 611 */ - unsigned int (*tcl_ZlibCRC32) (unsigned int crc, const unsigned char *buf, size_t len); /* 612 */ - unsigned int (*tcl_ZlibAdler32) (unsigned int adler, const unsigned char *buf, size_t len); /* 613 */ + int (*tcl_ZlibInflate) (Tcl_Interp *interp, int format, Tcl_Obj *data, int buffersize, Tcl_Obj *gzipHeaderDictObj); /* 611 */ + unsigned int (*tcl_ZlibCRC32) (unsigned int crc, const unsigned char *buf, int len); /* 612 */ + unsigned int (*tcl_ZlibAdler32) (unsigned int adler, const unsigned char *buf, int len); /* 613 */ int (*tcl_ZlibStreamInit) (Tcl_Interp *interp, int mode, int format, int level, Tcl_Obj *dictObj, Tcl_ZlibStream *zshandle); /* 614 */ Tcl_Obj * (*tcl_ZlibStreamGetCommandName) (Tcl_ZlibStream zshandle); /* 615 */ int (*tcl_ZlibStreamEof) (Tcl_ZlibStream zshandle); /* 616 */ int (*tcl_ZlibStreamChecksum) (Tcl_ZlibStream zshandle); /* 617 */ int (*tcl_ZlibStreamPut) (Tcl_ZlibStream zshandle, Tcl_Obj *data, int flush); /* 618 */ - int (*tcl_ZlibStreamGet) (Tcl_ZlibStream zshandle, Tcl_Obj *data, size_t count); /* 619 */ + int (*tcl_ZlibStreamGet) (Tcl_ZlibStream zshandle, Tcl_Obj *data, int count); /* 619 */ int (*tcl_ZlibStreamClose) (Tcl_ZlibStream zshandle); /* 620 */ int (*tcl_ZlibStreamReset) (Tcl_ZlibStream zshandle); /* 621 */ void (*tcl_SetStartupScript) (Tcl_Obj *path, const char *encoding); /* 622 */ Tcl_Obj * (*tcl_GetStartupScript) (const char **encodingPtr); /* 623 */ int (*tcl_CloseEx) (Tcl_Interp *interp, Tcl_Channel chan, int flags); /* 624 */ @@ -2421,25 +2499,29 @@ int (*tcl_NRSubstObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 626 */ int (*tcl_LoadFile) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *const symv[], int flags, void *procPtrs, Tcl_LoadHandle *handlePtr); /* 627 */ void * (*tcl_FindSymbol) (Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol); /* 628 */ int (*tcl_FSUnloadFile) (Tcl_Interp *interp, Tcl_LoadHandle handlePtr); /* 629 */ void (*tcl_ZlibStreamSetCompressionDictionary) (Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); /* 630 */ - Tcl_Channel (*tcl_OpenTcpServerEx) (Tcl_Interp *interp, const char *service, const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc, void *callbackData); /* 631 */ - int (*tclZipfs_Mount) (Tcl_Interp *interp, const char *mountPoint, const char *zipname, 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 char *mountPoint, unsigned char *data, size_t datalen, int copy); /* 635 */ - void (*tcl_FreeIntRep) (Tcl_Obj *objPtr); /* 636 */ - char * (*tcl_InitStringRep) (Tcl_Obj *objPtr, const char *bytes, size_t numBytes); /* 637 */ - Tcl_ObjIntRep * (*tcl_FetchIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 638 */ - void (*tcl_StoreIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, const Tcl_ObjIntRep *irPtr); /* 639 */ - int (*tcl_HasStringRep) (Tcl_Obj *objPtr); /* 640 */ - void (*tcl_IncrRefCount) (Tcl_Obj *objPtr); /* 641 */ - void (*tcl_DecrRefCount) (Tcl_Obj *objPtr); /* 642 */ - int (*tcl_IsShared) (Tcl_Obj *objPtr); /* 643 */ - int (*tcl_LinkArray) (Tcl_Interp *interp, const char *varName, void *addr, int type, size_t size); /* 644 */ - int (*tcl_GetIntForIndex) (Tcl_Interp *interp, Tcl_Obj *objPtr, size_t endValue, size_t *indexPtr); /* 645 */ + void (*reserved631)(void); + void (*reserved632)(void); + void (*reserved633)(void); + void (*reserved634)(void); + void (*reserved635)(void); + void (*reserved636)(void); + void (*reserved637)(void); + void (*reserved638)(void); + void (*reserved639)(void); + void (*reserved640)(void); + void (*reserved641)(void); + void (*reserved642)(void); + void (*reserved643)(void); + void (*reserved644)(void); + void (*reserved645)(void); + void (*reserved646)(void); + void (*reserved647)(void); + void (*reserved648)(void); + void (*tclUnusedStubEntry) (void); /* 649 */ } TclStubs; extern const TclStubs *tclStubsPtr; #ifdef __cplusplus @@ -2506,25 +2588,28 @@ (tclStubsPtr->tcl_DbDecrRefCount) /* 19 */ #define Tcl_DbIncrRefCount \ (tclStubsPtr->tcl_DbIncrRefCount) /* 20 */ #define Tcl_DbIsShared \ (tclStubsPtr->tcl_DbIsShared) /* 21 */ -/* Slot 22 is reserved */ +#define Tcl_DbNewBooleanObj \ + (tclStubsPtr->tcl_DbNewBooleanObj) /* 22 */ #define Tcl_DbNewByteArrayObj \ (tclStubsPtr->tcl_DbNewByteArrayObj) /* 23 */ #define Tcl_DbNewDoubleObj \ (tclStubsPtr->tcl_DbNewDoubleObj) /* 24 */ #define Tcl_DbNewListObj \ (tclStubsPtr->tcl_DbNewListObj) /* 25 */ -/* Slot 26 is reserved */ +#define Tcl_DbNewLongObj \ + (tclStubsPtr->tcl_DbNewLongObj) /* 26 */ #define Tcl_DbNewObj \ (tclStubsPtr->tcl_DbNewObj) /* 27 */ #define Tcl_DbNewStringObj \ (tclStubsPtr->tcl_DbNewStringObj) /* 28 */ #define Tcl_DuplicateObj \ (tclStubsPtr->tcl_DuplicateObj) /* 29 */ -/* Slot 30 is reserved */ +#define TclFreeObj \ + (tclStubsPtr->tclFreeObj) /* 30 */ #define Tcl_GetBoolean \ (tclStubsPtr->tcl_GetBoolean) /* 31 */ #define Tcl_GetBooleanFromObj \ (tclStubsPtr->tcl_GetBooleanFromObj) /* 32 */ #define Tcl_GetByteArrayFromObj \ @@ -2531,11 +2616,12 @@ (tclStubsPtr->tcl_GetByteArrayFromObj) /* 33 */ #define Tcl_GetDouble \ (tclStubsPtr->tcl_GetDouble) /* 34 */ #define Tcl_GetDoubleFromObj \ (tclStubsPtr->tcl_GetDoubleFromObj) /* 35 */ -/* Slot 36 is reserved */ +#define Tcl_GetIndexFromObj \ + (tclStubsPtr->tcl_GetIndexFromObj) /* 36 */ #define Tcl_GetInt \ (tclStubsPtr->tcl_GetInt) /* 37 */ #define Tcl_GetIntFromObj \ (tclStubsPtr->tcl_GetIntFromObj) /* 38 */ #define Tcl_GetLongFromObj \ @@ -2556,40 +2642,48 @@ (tclStubsPtr->tcl_ListObjIndex) /* 46 */ #define Tcl_ListObjLength \ (tclStubsPtr->tcl_ListObjLength) /* 47 */ #define Tcl_ListObjReplace \ (tclStubsPtr->tcl_ListObjReplace) /* 48 */ -/* Slot 49 is reserved */ +#define Tcl_NewBooleanObj \ + (tclStubsPtr->tcl_NewBooleanObj) /* 49 */ #define Tcl_NewByteArrayObj \ (tclStubsPtr->tcl_NewByteArrayObj) /* 50 */ #define Tcl_NewDoubleObj \ (tclStubsPtr->tcl_NewDoubleObj) /* 51 */ -/* Slot 52 is reserved */ +#define Tcl_NewIntObj \ + (tclStubsPtr->tcl_NewIntObj) /* 52 */ #define Tcl_NewListObj \ (tclStubsPtr->tcl_NewListObj) /* 53 */ -/* Slot 54 is reserved */ +#define Tcl_NewLongObj \ + (tclStubsPtr->tcl_NewLongObj) /* 54 */ #define Tcl_NewObj \ (tclStubsPtr->tcl_NewObj) /* 55 */ #define Tcl_NewStringObj \ (tclStubsPtr->tcl_NewStringObj) /* 56 */ -/* Slot 57 is reserved */ +#define Tcl_SetBooleanObj \ + (tclStubsPtr->tcl_SetBooleanObj) /* 57 */ #define Tcl_SetByteArrayLength \ (tclStubsPtr->tcl_SetByteArrayLength) /* 58 */ #define Tcl_SetByteArrayObj \ (tclStubsPtr->tcl_SetByteArrayObj) /* 59 */ #define Tcl_SetDoubleObj \ (tclStubsPtr->tcl_SetDoubleObj) /* 60 */ -/* Slot 61 is reserved */ +#define Tcl_SetIntObj \ + (tclStubsPtr->tcl_SetIntObj) /* 61 */ #define Tcl_SetListObj \ (tclStubsPtr->tcl_SetListObj) /* 62 */ -/* Slot 63 is reserved */ +#define Tcl_SetLongObj \ + (tclStubsPtr->tcl_SetLongObj) /* 63 */ #define Tcl_SetObjLength \ (tclStubsPtr->tcl_SetObjLength) /* 64 */ #define Tcl_SetStringObj \ (tclStubsPtr->tcl_SetStringObj) /* 65 */ -/* Slot 66 is reserved */ -/* Slot 67 is reserved */ +#define Tcl_AddErrorInfo \ + (tclStubsPtr->tcl_AddErrorInfo) /* 66 */ +#define Tcl_AddObjErrorInfo \ + (tclStubsPtr->tcl_AddObjErrorInfo) /* 67 */ #define Tcl_AllowExceptions \ (tclStubsPtr->tcl_AllowExceptions) /* 68 */ #define Tcl_AppendElement \ (tclStubsPtr->tcl_AppendElement) /* 69 */ #define Tcl_AppendResult \ @@ -2602,12 +2696,14 @@ (tclStubsPtr->tcl_AsyncInvoke) /* 73 */ #define Tcl_AsyncMark \ (tclStubsPtr->tcl_AsyncMark) /* 74 */ #define Tcl_AsyncReady \ (tclStubsPtr->tcl_AsyncReady) /* 75 */ -/* Slot 76 is reserved */ -/* Slot 77 is reserved */ +#define Tcl_BackgroundError \ + (tclStubsPtr->tcl_BackgroundError) /* 76 */ +#define Tcl_Backslash \ + (tclStubsPtr->tcl_Backslash) /* 77 */ #define Tcl_BadChannelOption \ (tclStubsPtr->tcl_BadChannelOption) /* 78 */ #define Tcl_CallWhenDeleted \ (tclStubsPtr->tcl_CallWhenDeleted) /* 79 */ #define Tcl_CancelIdleCall \ @@ -2638,11 +2734,12 @@ (tclStubsPtr->tcl_CreateEventSource) /* 92 */ #define Tcl_CreateExitHandler \ (tclStubsPtr->tcl_CreateExitHandler) /* 93 */ #define Tcl_CreateInterp \ (tclStubsPtr->tcl_CreateInterp) /* 94 */ -/* Slot 95 is reserved */ +#define Tcl_CreateMathFunc \ + (tclStubsPtr->tcl_CreateMathFunc) /* 95 */ #define Tcl_CreateObjCommand \ (tclStubsPtr->tcl_CreateObjCommand) /* 96 */ #define Tcl_CreateSlave \ (tclStubsPtr->tcl_CreateSlave) /* 97 */ #define Tcl_CreateTimerHandler \ @@ -2705,14 +2802,16 @@ (tclStubsPtr->tcl_Eof) /* 126 */ #define Tcl_ErrnoId \ (tclStubsPtr->tcl_ErrnoId) /* 127 */ #define Tcl_ErrnoMsg \ (tclStubsPtr->tcl_ErrnoMsg) /* 128 */ -/* Slot 129 is reserved */ +#define Tcl_Eval \ + (tclStubsPtr->tcl_Eval) /* 129 */ #define Tcl_EvalFile \ (tclStubsPtr->tcl_EvalFile) /* 130 */ -/* Slot 131 is reserved */ +#define Tcl_EvalObj \ + (tclStubsPtr->tcl_EvalObj) /* 131 */ #define Tcl_EventuallyFree \ (tclStubsPtr->tcl_EventuallyFree) /* 132 */ #define Tcl_Exit \ (tclStubsPtr->tcl_Exit) /* 133 */ #define Tcl_ExposeCommand \ @@ -2733,11 +2832,12 @@ (tclStubsPtr->tcl_ExprObj) /* 141 */ #define Tcl_ExprString \ (tclStubsPtr->tcl_ExprString) /* 142 */ #define Tcl_Finalize \ (tclStubsPtr->tcl_Finalize) /* 143 */ -/* Slot 144 is reserved */ +#define Tcl_FindExecutable \ + (tclStubsPtr->tcl_FindExecutable) /* 144 */ #define Tcl_FirstHashEntry \ (tclStubsPtr->tcl_FirstHashEntry) /* 145 */ #define Tcl_Flush \ (tclStubsPtr->tcl_Flush) /* 146 */ #define Tcl_FreeResult \ @@ -2798,16 +2898,20 @@ (tclStubsPtr->tcl_GetServiceMode) /* 171 */ #define Tcl_GetSlave \ (tclStubsPtr->tcl_GetSlave) /* 172 */ #define Tcl_GetStdChannel \ (tclStubsPtr->tcl_GetStdChannel) /* 173 */ -/* Slot 174 is reserved */ -/* Slot 175 is reserved */ +#define Tcl_GetStringResult \ + (tclStubsPtr->tcl_GetStringResult) /* 174 */ +#define Tcl_GetVar \ + (tclStubsPtr->tcl_GetVar) /* 175 */ #define Tcl_GetVar2 \ (tclStubsPtr->tcl_GetVar2) /* 176 */ -/* Slot 177 is reserved */ -/* Slot 178 is reserved */ +#define Tcl_GlobalEval \ + (tclStubsPtr->tcl_GlobalEval) /* 177 */ +#define Tcl_GlobalEvalObj \ + (tclStubsPtr->tcl_GlobalEvalObj) /* 178 */ #define Tcl_HideCommand \ (tclStubsPtr->tcl_HideCommand) /* 179 */ #define Tcl_Init \ (tclStubsPtr->tcl_Init) /* 180 */ #define Tcl_InitHashTable \ @@ -2885,11 +2989,12 @@ (tclStubsPtr->tcl_ResetResult) /* 217 */ #define Tcl_ScanElement \ (tclStubsPtr->tcl_ScanElement) /* 218 */ #define Tcl_ScanCountedElement \ (tclStubsPtr->tcl_ScanCountedElement) /* 219 */ -/* Slot 220 is reserved */ +#define Tcl_SeekOld \ + (tclStubsPtr->tcl_SeekOld) /* 220 */ #define Tcl_ServiceAll \ (tclStubsPtr->tcl_ServiceAll) /* 221 */ #define Tcl_ServiceEvent \ (tclStubsPtr->tcl_ServiceEvent) /* 222 */ #define Tcl_SetAssocData \ @@ -2904,23 +3009,26 @@ (tclStubsPtr->tcl_SetErrno) /* 227 */ #define Tcl_SetErrorCode \ (tclStubsPtr->tcl_SetErrorCode) /* 228 */ #define Tcl_SetMaxBlockTime \ (tclStubsPtr->tcl_SetMaxBlockTime) /* 229 */ -/* Slot 230 is reserved */ +#define Tcl_SetPanicProc \ + (tclStubsPtr->tcl_SetPanicProc) /* 230 */ #define Tcl_SetRecursionLimit \ (tclStubsPtr->tcl_SetRecursionLimit) /* 231 */ -/* Slot 232 is reserved */ +#define Tcl_SetResult \ + (tclStubsPtr->tcl_SetResult) /* 232 */ #define Tcl_SetServiceMode \ (tclStubsPtr->tcl_SetServiceMode) /* 233 */ #define Tcl_SetObjErrorCode \ (tclStubsPtr->tcl_SetObjErrorCode) /* 234 */ #define Tcl_SetObjResult \ (tclStubsPtr->tcl_SetObjResult) /* 235 */ #define Tcl_SetStdChannel \ (tclStubsPtr->tcl_SetStdChannel) /* 236 */ -/* Slot 237 is reserved */ +#define Tcl_SetVar \ + (tclStubsPtr->tcl_SetVar) /* 237 */ #define Tcl_SetVar2 \ (tclStubsPtr->tcl_SetVar2) /* 238 */ #define Tcl_SignalId \ (tclStubsPtr->tcl_SignalId) /* 239 */ #define Tcl_SignalMsg \ @@ -2929,14 +3037,18 @@ (tclStubsPtr->tcl_SourceRCFile) /* 241 */ #define Tcl_SplitList \ (tclStubsPtr->tcl_SplitList) /* 242 */ #define Tcl_SplitPath \ (tclStubsPtr->tcl_SplitPath) /* 243 */ -/* Slot 244 is reserved */ -/* Slot 245 is reserved */ -/* Slot 246 is reserved */ -/* Slot 247 is reserved */ +#define Tcl_StaticPackage \ + (tclStubsPtr->tcl_StaticPackage) /* 244 */ +#define Tcl_StringMatch \ + (tclStubsPtr->tcl_StringMatch) /* 245 */ +#define Tcl_TellOld \ + (tclStubsPtr->tcl_TellOld) /* 246 */ +#define Tcl_TraceVar \ + (tclStubsPtr->tcl_TraceVar) /* 247 */ #define Tcl_TraceVar2 \ (tclStubsPtr->tcl_TraceVar2) /* 248 */ #define Tcl_TranslateFileName \ (tclStubsPtr->tcl_TranslateFileName) /* 249 */ #define Tcl_Ungets \ @@ -2943,24 +3055,28 @@ (tclStubsPtr->tcl_Ungets) /* 250 */ #define Tcl_UnlinkVar \ (tclStubsPtr->tcl_UnlinkVar) /* 251 */ #define Tcl_UnregisterChannel \ (tclStubsPtr->tcl_UnregisterChannel) /* 252 */ -/* Slot 253 is reserved */ +#define Tcl_UnsetVar \ + (tclStubsPtr->tcl_UnsetVar) /* 253 */ #define Tcl_UnsetVar2 \ (tclStubsPtr->tcl_UnsetVar2) /* 254 */ -/* Slot 255 is reserved */ +#define Tcl_UntraceVar \ + (tclStubsPtr->tcl_UntraceVar) /* 255 */ #define Tcl_UntraceVar2 \ (tclStubsPtr->tcl_UntraceVar2) /* 256 */ #define Tcl_UpdateLinkedVar \ (tclStubsPtr->tcl_UpdateLinkedVar) /* 257 */ -/* Slot 258 is reserved */ +#define Tcl_UpVar \ + (tclStubsPtr->tcl_UpVar) /* 258 */ #define Tcl_UpVar2 \ (tclStubsPtr->tcl_UpVar2) /* 259 */ #define Tcl_VarEval \ (tclStubsPtr->tcl_VarEval) /* 260 */ -/* Slot 261 is reserved */ +#define Tcl_VarTraceInfo \ + (tclStubsPtr->tcl_VarTraceInfo) /* 261 */ #define Tcl_VarTraceInfo2 \ (tclStubsPtr->tcl_VarTraceInfo2) /* 262 */ #define Tcl_Write \ (tclStubsPtr->tcl_Write) /* 263 */ #define Tcl_WrongNumArgs \ @@ -2967,26 +3083,34 @@ (tclStubsPtr->tcl_WrongNumArgs) /* 264 */ #define Tcl_DumpActiveMemory \ (tclStubsPtr->tcl_DumpActiveMemory) /* 265 */ #define Tcl_ValidateAllMemory \ (tclStubsPtr->tcl_ValidateAllMemory) /* 266 */ -/* Slot 267 is reserved */ -/* Slot 268 is reserved */ +#define Tcl_AppendResultVA \ + (tclStubsPtr->tcl_AppendResultVA) /* 267 */ +#define Tcl_AppendStringsToObjVA \ + (tclStubsPtr->tcl_AppendStringsToObjVA) /* 268 */ #define Tcl_HashStats \ (tclStubsPtr->tcl_HashStats) /* 269 */ #define Tcl_ParseVar \ (tclStubsPtr->tcl_ParseVar) /* 270 */ -/* Slot 271 is reserved */ +#define Tcl_PkgPresent \ + (tclStubsPtr->tcl_PkgPresent) /* 271 */ #define Tcl_PkgPresentEx \ (tclStubsPtr->tcl_PkgPresentEx) /* 272 */ -/* Slot 273 is reserved */ -/* Slot 274 is reserved */ -/* Slot 275 is reserved */ -/* Slot 276 is reserved */ +#define Tcl_PkgProvide \ + (tclStubsPtr->tcl_PkgProvide) /* 273 */ +#define Tcl_PkgRequire \ + (tclStubsPtr->tcl_PkgRequire) /* 274 */ +#define Tcl_SetErrorCodeVA \ + (tclStubsPtr->tcl_SetErrorCodeVA) /* 275 */ +#define Tcl_VarEvalVA \ + (tclStubsPtr->tcl_VarEvalVA) /* 276 */ #define Tcl_WaitPid \ (tclStubsPtr->tcl_WaitPid) /* 277 */ -/* Slot 278 is reserved */ +#define Tcl_PanicVA \ + (tclStubsPtr->tcl_PanicVA) /* 278 */ #define Tcl_GetVersion \ (tclStubsPtr->tcl_GetVersion) /* 279 */ #define Tcl_InitMemory \ (tclStubsPtr->tcl_InitMemory) /* 280 */ #define Tcl_StackChannel \ @@ -3004,11 +3128,12 @@ (tclStubsPtr->tcl_CreateEncoding) /* 287 */ #define Tcl_CreateThreadExitHandler \ (tclStubsPtr->tcl_CreateThreadExitHandler) /* 288 */ #define Tcl_DeleteThreadExitHandler \ (tclStubsPtr->tcl_DeleteThreadExitHandler) /* 289 */ -/* Slot 290 is reserved */ +#define Tcl_DiscardResult \ + (tclStubsPtr->tcl_DiscardResult) /* 290 */ #define Tcl_EvalEx \ (tclStubsPtr->tcl_EvalEx) /* 291 */ #define Tcl_EvalObjv \ (tclStubsPtr->tcl_EvalObjv) /* 292 */ #define Tcl_EvalObjEx \ @@ -3051,12 +3176,14 @@ (tclStubsPtr->tcl_ConditionWait) /* 311 */ #define Tcl_NumUtfChars \ (tclStubsPtr->tcl_NumUtfChars) /* 312 */ #define Tcl_ReadChars \ (tclStubsPtr->tcl_ReadChars) /* 313 */ -/* Slot 314 is reserved */ -/* Slot 315 is reserved */ +#define Tcl_RestoreResult \ + (tclStubsPtr->tcl_RestoreResult) /* 314 */ +#define Tcl_SaveResult \ + (tclStubsPtr->tcl_SaveResult) /* 315 */ #define Tcl_SetSystemEncoding \ (tclStubsPtr->tcl_SetSystemEncoding) /* 316 */ #define Tcl_SetVar2Ex \ (tclStubsPtr->tcl_SetVar2Ex) /* 317 */ #define Tcl_ThreadAlert \ @@ -3103,12 +3230,14 @@ (tclStubsPtr->tcl_WriteChars) /* 338 */ #define Tcl_WriteObj \ (tclStubsPtr->tcl_WriteObj) /* 339 */ #define Tcl_GetString \ (tclStubsPtr->tcl_GetString) /* 340 */ -/* Slot 341 is reserved */ -/* Slot 342 is reserved */ +#define Tcl_GetDefaultEncodingDir \ + (tclStubsPtr->tcl_GetDefaultEncodingDir) /* 341 */ +#define Tcl_SetDefaultEncodingDir \ + (tclStubsPtr->tcl_SetDefaultEncodingDir) /* 342 */ #define Tcl_AlertNotifier \ (tclStubsPtr->tcl_AlertNotifier) /* 343 */ #define Tcl_ServiceModeHook \ (tclStubsPtr->tcl_ServiceModeHook) /* 344 */ #define Tcl_UniCharIsAlnum \ @@ -3133,11 +3262,12 @@ (tclStubsPtr->tcl_UniCharToUtfDString) /* 354 */ #define Tcl_UtfToUniCharDString \ (tclStubsPtr->tcl_UtfToUniCharDString) /* 355 */ #define Tcl_GetRegExpFromObj \ (tclStubsPtr->tcl_GetRegExpFromObj) /* 356 */ -/* Slot 357 is reserved */ +#define Tcl_EvalTokens \ + (tclStubsPtr->tcl_EvalTokens) /* 357 */ #define Tcl_FreeParse \ (tclStubsPtr->tcl_FreeParse) /* 358 */ #define Tcl_LogCommandInfo \ (tclStubsPtr->tcl_LogCommandInfo) /* 359 */ #define Tcl_ParseBraces \ @@ -3182,11 +3312,12 @@ (tclStubsPtr->tcl_SetUnicodeObj) /* 379 */ #define Tcl_GetCharLength \ (tclStubsPtr->tcl_GetCharLength) /* 380 */ #define Tcl_GetUniChar \ (tclStubsPtr->tcl_GetUniChar) /* 381 */ -/* Slot 382 is reserved */ +#define Tcl_GetUnicode \ + (tclStubsPtr->tcl_GetUnicode) /* 382 */ #define Tcl_GetRange \ (tclStubsPtr->tcl_GetRange) /* 383 */ #define Tcl_AppendUnicodeToObj \ (tclStubsPtr->tcl_AppendUnicodeToObj) /* 384 */ #define Tcl_RegExpMatchObj \ @@ -3259,12 +3390,14 @@ (tclStubsPtr->tcl_IsChannelExisting) /* 418 */ #define Tcl_UniCharNcasecmp \ (tclStubsPtr->tcl_UniCharNcasecmp) /* 419 */ #define Tcl_UniCharCaseMatch \ (tclStubsPtr->tcl_UniCharCaseMatch) /* 420 */ -/* Slot 421 is reserved */ -/* Slot 422 is reserved */ +#define Tcl_FindHashEntry \ + (tclStubsPtr->tcl_FindHashEntry) /* 421 */ +#define Tcl_CreateHashEntry \ + (tclStubsPtr->tcl_CreateHashEntry) /* 422 */ #define Tcl_InitCustomHashTable \ (tclStubsPtr->tcl_InitCustomHashTable) /* 423 */ #define Tcl_InitObjHashTable \ (tclStubsPtr->tcl_InitObjHashTable) /* 424 */ #define Tcl_CommandTraceInfo \ @@ -3285,12 +3418,14 @@ (tclStubsPtr->tcl_AttemptSetObjLength) /* 432 */ #define Tcl_GetChannelThread \ (tclStubsPtr->tcl_GetChannelThread) /* 433 */ #define Tcl_GetUnicodeFromObj \ (tclStubsPtr->tcl_GetUnicodeFromObj) /* 434 */ -/* Slot 435 is reserved */ -/* Slot 436 is reserved */ +#define Tcl_GetMathFuncInfo \ + (tclStubsPtr->tcl_GetMathFuncInfo) /* 435 */ +#define Tcl_ListMathFuncs \ + (tclStubsPtr->tcl_ListMathFuncs) /* 436 */ #define Tcl_SubstObj \ (tclStubsPtr->tcl_SubstObj) /* 437 */ #define Tcl_DetachChannel \ (tclStubsPtr->tcl_DetachChannel) /* 438 */ #define Tcl_IsStandardChannel \ @@ -3451,11 +3586,12 @@ (tclStubsPtr->tcl_GetCommandFromObj) /* 516 */ #define Tcl_GetCommandFullName \ (tclStubsPtr->tcl_GetCommandFullName) /* 517 */ #define Tcl_FSEvalFileEx \ (tclStubsPtr->tcl_FSEvalFileEx) /* 518 */ -/* Slot 519 is reserved */ +#define Tcl_SetExitProc \ + (tclStubsPtr->tcl_SetExitProc) /* 519 */ #define Tcl_LimitAddHandler \ (tclStubsPtr->tcl_LimitAddHandler) /* 520 */ #define Tcl_LimitRemoveHandler \ (tclStubsPtr->tcl_LimitRemoveHandler) /* 521 */ #define Tcl_LimitReady \ @@ -3674,131 +3810,112 @@ (tclStubsPtr->tcl_FindSymbol) /* 628 */ #define Tcl_FSUnloadFile \ (tclStubsPtr->tcl_FSUnloadFile) /* 629 */ #define Tcl_ZlibStreamSetCompressionDictionary \ (tclStubsPtr->tcl_ZlibStreamSetCompressionDictionary) /* 630 */ -#define Tcl_OpenTcpServerEx \ - (tclStubsPtr->tcl_OpenTcpServerEx) /* 631 */ -#define TclZipfs_Mount \ - (tclStubsPtr->tclZipfs_Mount) /* 632 */ -#define TclZipfs_Unmount \ - (tclStubsPtr->tclZipfs_Unmount) /* 633 */ -#define TclZipfs_TclLibrary \ - (tclStubsPtr->tclZipfs_TclLibrary) /* 634 */ -#define TclZipfs_MountBuffer \ - (tclStubsPtr->tclZipfs_MountBuffer) /* 635 */ -#define Tcl_FreeIntRep \ - (tclStubsPtr->tcl_FreeIntRep) /* 636 */ -#define Tcl_InitStringRep \ - (tclStubsPtr->tcl_InitStringRep) /* 637 */ -#define Tcl_FetchIntRep \ - (tclStubsPtr->tcl_FetchIntRep) /* 638 */ -#define Tcl_StoreIntRep \ - (tclStubsPtr->tcl_StoreIntRep) /* 639 */ -#define Tcl_HasStringRep \ - (tclStubsPtr->tcl_HasStringRep) /* 640 */ -#define Tcl_IncrRefCount \ - (tclStubsPtr->tcl_IncrRefCount) /* 641 */ -#define Tcl_DecrRefCount \ - (tclStubsPtr->tcl_DecrRefCount) /* 642 */ -#define Tcl_IsShared \ - (tclStubsPtr->tcl_IsShared) /* 643 */ -#define Tcl_LinkArray \ - (tclStubsPtr->tcl_LinkArray) /* 644 */ -#define Tcl_GetIntForIndex \ - (tclStubsPtr->tcl_GetIntForIndex) /* 645 */ +/* Slot 631 is reserved */ +/* Slot 632 is reserved */ +/* Slot 633 is reserved */ +/* Slot 634 is reserved */ +/* Slot 635 is reserved */ +/* Slot 636 is reserved */ +/* Slot 637 is reserved */ +/* Slot 638 is reserved */ +/* Slot 639 is reserved */ +/* Slot 640 is reserved */ +/* Slot 641 is reserved */ +/* Slot 642 is reserved */ +/* Slot 643 is reserved */ +/* Slot 644 is reserved */ +/* Slot 645 is reserved */ +/* Slot 646 is reserved */ +/* Slot 647 is reserved */ +/* Slot 648 is reserved */ +#define TclUnusedStubEntry \ + (tclStubsPtr->tclUnusedStubEntry) /* 649 */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ + +#undef TclUnusedStubEntry #if defined(USE_TCL_STUBS) # undef Tcl_CreateInterp +# undef Tcl_FindExecutable +# undef Tcl_GetStringResult # undef Tcl_Init +# undef Tcl_SetPanicProc +# undef Tcl_SetVar # undef Tcl_ObjSetVar2 +# undef Tcl_StaticPackage # define Tcl_CreateInterp() (tclStubsPtr->tcl_CreateInterp()) +# define Tcl_GetStringResult(interp) (tclStubsPtr->tcl_GetStringResult(interp)) # define Tcl_Init(interp) (tclStubsPtr->tcl_Init(interp)) +# define Tcl_SetPanicProc(proc) (tclStubsPtr->tcl_SetPanicProc(proc)) +# define Tcl_SetVar(interp, varName, newValue, flags) \ + (tclStubsPtr->tcl_SetVar(interp, varName, newValue, flags)) # define Tcl_ObjSetVar2(interp, part1, part2, newValue, flags) \ (tclStubsPtr->tcl_ObjSetVar2(interp, part1, part2, newValue, flags)) #endif #if defined(_WIN32) && defined(UNICODE) # define Tcl_FindExecutable(arg) ((Tcl_FindExecutable)((const char *)(arg))) # define Tcl_MainEx Tcl_MainExW - EXTERN TCL_NORETURN void Tcl_MainExW(int argc, wchar_t **argv, + EXTERN void Tcl_MainExW(int argc, wchar_t **argv, Tcl_AppInitProc *appInitProc, Tcl_Interp *interp); - EXTERN int TclZipfs_AppHook(int *argc, wchar_t ***argv); #endif #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT +#undef Tcl_SeekOld +#undef Tcl_TellOld + +#undef Tcl_PkgPresent #define Tcl_PkgPresent(interp, name, version, exact) \ Tcl_PkgPresentEx(interp, name, version, exact, NULL) +#undef Tcl_PkgProvide #define Tcl_PkgProvide(interp, name, version) \ Tcl_PkgProvideEx(interp, name, version, NULL) +#undef Tcl_PkgRequire #define Tcl_PkgRequire(interp, name, version, exact) \ Tcl_PkgRequireEx(interp, name, version, exact, NULL) +#undef Tcl_GetIndexFromObj #define Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) \ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, \ sizeof(char *), msg, flags, indexPtr) +#undef Tcl_NewBooleanObj #define Tcl_NewBooleanObj(boolValue) \ - Tcl_NewWideIntObj((boolValue)!=0) + Tcl_NewIntObj((boolValue)!=0) +#undef Tcl_DbNewBooleanObj #define Tcl_DbNewBooleanObj(boolValue, file, line) \ - Tcl_DbNewWideIntObj((boolValue)!=0, file, line) + Tcl_DbNewLongObj((boolValue)!=0, file, line) +#undef Tcl_SetBooleanObj #define Tcl_SetBooleanObj(objPtr, boolValue) \ - Tcl_SetWideIntObj(objPtr, (boolValue)!=0) + Tcl_SetIntObj((objPtr), (boolValue)!=0) +#undef Tcl_SetVar #define Tcl_SetVar(interp, varName, newValue, flags) \ Tcl_SetVar2(interp, varName, NULL, newValue, flags) +#undef Tcl_UnsetVar #define Tcl_UnsetVar(interp, varName, flags) \ Tcl_UnsetVar2(interp, varName, NULL, flags) +#undef Tcl_GetVar #define Tcl_GetVar(interp, varName, flags) \ Tcl_GetVar2(interp, varName, NULL, flags) +#undef Tcl_TraceVar #define Tcl_TraceVar(interp, varName, flags, proc, clientData) \ Tcl_TraceVar2(interp, varName, NULL, flags, proc, clientData) +#undef Tcl_UntraceVar #define Tcl_UntraceVar(interp, varName, flags, proc, clientData) \ Tcl_UntraceVar2(interp, varName, NULL, flags, proc, clientData) +#undef Tcl_VarTraceInfo #define Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData) \ Tcl_VarTraceInfo2(interp, varName, NULL, flags, proc, prevClientData) +#undef Tcl_UpVar #define Tcl_UpVar(interp, frameName, varName, localName, flags) \ Tcl_UpVar2(interp, frameName, varName, NULL, localName, flags) -#define Tcl_AddErrorInfo(interp, message) \ - Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, -1)) -#define Tcl_AddObjErrorInfo(interp, message, length) \ - Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, length)) -#define Tcl_Eval(interp, objPtr) \ - Tcl_EvalEx(interp, objPtr, -1, 0) -#define Tcl_GlobalEval(interp, objPtr) \ - Tcl_EvalEx(interp, objPtr, -1, TCL_EVAL_GLOBAL) -#define Tcl_GetStringResult(interp) Tcl_GetString(Tcl_GetObjResult(interp)) -#define Tcl_SaveResult(interp, statePtr) \ - do { \ - *(statePtr) = Tcl_GetObjResult(interp); \ - Tcl_IncrRefCount(*(statePtr)); \ - Tcl_SetObjResult(interp, Tcl_NewObj()); \ - } while(0) -#define Tcl_RestoreResult(interp, statePtr) \ - do { \ - Tcl_ResetResult(interp); \ - Tcl_SetObjResult(interp, *(statePtr)); \ - Tcl_DecrRefCount(*(statePtr)); \ - } while(0) -#define Tcl_DiscardResult(statePtr) \ - Tcl_DecrRefCount(*(statePtr)) -#define Tcl_SetResult(interp, result, freeProc) \ - do { \ - char *__result = result; \ - Tcl_FreeProc *__freeProc = freeProc; \ - Tcl_SetObjResult(interp, Tcl_NewStringObj(__result, -1)); \ - if (__result != NULL && __freeProc != NULL && __freeProc != TCL_VOLATILE) { \ - if (__freeProc == TCL_DYNAMIC) { \ - Tcl_Free(__result); \ - } else { \ - (*__freeProc)(__result); \ - } \ - } \ - } while(0) #if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) # 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 @@ -3805,14 +3922,24 @@ * Win64 signature. Cygwin64 stubbed extensions cannot use those stub * entries any more, they should use the 64-bit alternatives where * possible. Tcl 9 must find a better solution, but that cannot be done * without introducing a binary incompatibility. */ +# undef Tcl_DbNewLongObj # undef Tcl_GetLongFromObj +# undef Tcl_NewLongObj +# undef Tcl_SetLongObj # undef Tcl_ExprLong # undef Tcl_ExprLongObj +# undef Tcl_UniCharNcmp +# undef Tcl_UtfNcmp +# undef Tcl_UtfNcasecmp +# undef Tcl_UniCharNcasecmp +# define Tcl_DbNewLongObj ((Tcl_Obj*(*)(long,const char*,int))Tcl_DbNewWideIntObj) # define Tcl_GetLongFromObj ((int(*)(Tcl_Interp*,Tcl_Obj*,long*))Tcl_GetWideIntFromObj) +# define Tcl_NewLongObj ((Tcl_Obj*(*)(long))Tcl_NewWideIntObj) +# define Tcl_SetLongObj ((void(*)(Tcl_Obj*,long))Tcl_SetWideIntObj) # define Tcl_ExprLong TclExprLong static inline int TclExprLong(Tcl_Interp *interp, const char *string, long *ptr){ int intValue; int result = tclStubsPtr->tcl_ExprLong(interp, string, (long *)&intValue); if (result == TCL_OK) *ptr = (long)intValue; @@ -3823,81 +3950,31 @@ int intValue; int result = tclStubsPtr->tcl_ExprLongObj(interp, obj, (long *)&intValue); if (result == TCL_OK) *ptr = (long)intValue; return result; } +# define Tcl_UniCharNcmp(ucs,uct,n) \ + ((int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned int))tclStubsPtr->tcl_UniCharNcmp)(ucs,uct,(unsigned int)(n)) +# define Tcl_UtfNcmp(s1,s2,n) \ + ((int(*)(const char*,const char*,unsigned int))tclStubsPtr->tcl_UtfNcmp)(s1,s2,(unsigned int)(n)) +# define Tcl_UtfNcasecmp(s1,s2,n) \ + ((int(*)(const char*,const char*,unsigned int))tclStubsPtr->tcl_UtfNcasecmp)(s1,s2,(unsigned int)(n)) +# define Tcl_UniCharNcasecmp(ucs,uct,n) \ + ((int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned int))tclStubsPtr->tcl_UniCharNcasecmp)(ucs,uct,(unsigned int)(n)) # endif #endif -#ifdef TCL_MEM_DEBUG -# undef Tcl_Alloc -# define Tcl_Alloc(x) \ - (Tcl_DbCkalloc((x), __FILE__, __LINE__)) -# undef Tcl_Free -# define Tcl_Free(x) \ - Tcl_DbCkfree((x), __FILE__, __LINE__) -# undef Tcl_Realloc -# define Tcl_Realloc(x,y) \ - (Tcl_DbCkrealloc((x), (y), __FILE__, __LINE__)) -# undef Tcl_AttemptAlloc -# define Tcl_AttemptAlloc(x) \ - (Tcl_AttemptDbCkalloc((x), __FILE__, __LINE__)) -# undef Tcl_AttemptRealloc -# define Tcl_AttemptRealloc(x,y) \ - (Tcl_AttemptDbCkrealloc((x), (y), __FILE__, __LINE__)) -#endif /* !TCL_MEM_DEBUG */ - -#define Tcl_NewLongObj(value) Tcl_NewWideIntObj((long)(value)) -#define Tcl_NewIntObj(value) Tcl_NewWideIntObj((int)(value)) -#define Tcl_DbNewLongObj(value, file, line) Tcl_DbNewWideIntObj((long)(value), file, line) -#define Tcl_SetIntObj(objPtr, value) Tcl_SetWideIntObj((objPtr), (int)(value)) -#define Tcl_SetLongObj(objPtr, value) Tcl_SetWideIntObj((objPtr), (long)(value)) -#define Tcl_GetUnicode(objPtr) Tcl_GetUnicodeFromObj((objPtr), NULL) -#define Tcl_BackgroundError(interp) Tcl_BackgroundException((interp), TCL_ERROR) -#define Tcl_StringMatch(str, pattern) Tcl_StringCaseMatch((str), (pattern), 0) - /* * Deprecated Tcl procedures: */ -#define Tcl_EvalObj(interp, objPtr) \ - Tcl_EvalObjEx(interp, objPtr, 0) -#define Tcl_GlobalEvalObj(interp, objPtr) \ - Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL) - -#if defined(TCL_8_COMPAT) && !defined(BUILD_tcl) -# ifdef USE_TCL_STUBS -# undef Tcl_Gets -# undef Tcl_GetsObj -# undef Tcl_Read -# undef Tcl_Ungets -# undef Tcl_Write -# undef Tcl_ReadChars -# undef Tcl_WriteChars -# undef Tcl_WriteObj -# undef Tcl_ReadRaw -# undef Tcl_WriteRaw -# define Tcl_Gets(chan, dsPtr) (((Tcl_WideInt)((tclStubsPtr->tcl_Gets)(chan, dsPtr)+1))-1) -# define Tcl_GetsObj(chan, objPtr) (((Tcl_WideInt)((tclStubsPtr->tcl_GetsObj)(chan, objPtr)+1))-1) -# define Tcl_Read(chan, bufPtr, toRead) (((Tcl_WideInt)((tclStubsPtr->tcl_Read)(chan, bufPtr, toRead)+1))-1) -# define Tcl_Ungets(chan, str, len, atHead) (((Tcl_WideInt)((tclStubsPtr->tcl_Ungets)(chan, str, len, atHead)+1))-1) -# define Tcl_Write(chan, s, slen) (((Tcl_WideInt)((tclStubsPtr->tcl_Write)(chan, s, slen)+1))-1) -# define Tcl_ReadChars(channel, objPtr, charsToRead, appendFlag) (((Tcl_WideInt)((tclStubsPtr->tcl_ReadChars)(channel, objPtr, charsToRead, appendFlag)+1))-1) -# define Tcl_WriteChars(chan, src, srcLen) (((Tcl_WideInt)((tclStubsPtr->tcl_WriteChars)(chan, src, srcLen)+1))-1) -# define Tcl_WriteObj(chan, objPtr) (((Tcl_WideInt)((tclStubsPtr->tcl_WriteObj)(chan, objPtr)+1))-1) -# define Tcl_ReadRaw(chan, dst, bytesToRead) (((Tcl_WideInt)((tclStubsPtr->tcl_ReadRaw)(chan, dst, bytesToRead)+1))-1) -# define Tcl_WriteRaw(chan, src, srcLen) (((Tcl_WideInt)((tclStubsPtr->tcl_WriteRaw()(chan, src, srcLen)+1))-1) -# else -# define Tcl_Gets(chan, dsPtr) (((Tcl_WideInt)((Tcl_Gets)(chan, dsPtr)+1))-1) -# define Tcl_GetsObj(chan, objPtr) (((Tcl_WideInt)((Tcl_GetsObj)(chan, objPtr)+1))-1) -# define Tcl_Read(chan, bufPtr, toRead) (((Tcl_WideInt)((Tcl_Read)(chan, bufPtr, toRead)+1))-1) -# define Tcl_Ungets(chan, str, len, atHead) (((Tcl_WideInt)((Tcl_Ungets)(chan, str, len, atHead)+1))-1) -# define Tcl_Write(chan, s, slen) (((Tcl_WideInt)((Tcl_Write)(chan, s, slen)+1))-1) -# define Tcl_ReadChars(channel, objPtr, charsToRead, appendFlag) (((Tcl_WideInt)((Tcl_ReadChars)(channel, objPtr, charsToRead, appendFlag)+1))-1) -# define Tcl_WriteChars(chan, src, srcLen) (((Tcl_WideInt)((Tcl_WriteChars)(chan, src, srcLen)+1))-1) -# define Tcl_WriteObj(chan, objPtr) (((Tcl_WideInt)((Tcl_WriteObj)(chan, objPtr)+1))-1) -# define Tcl_ReadRaw(chan, dst, bytesToRead) (((Tcl_WideInt)((Tcl_ReadRaw)(chan, dst, bytesToRead)+1))-1) -# define Tcl_WriteRaw(chan, src, srcLen) (((Tcl_WideInt)((Tcl_WriteRaw()(chan, src, srcLen)+1))-1) -# endif -#endif +#undef Tcl_EvalObj +#define Tcl_EvalObj(interp,objPtr) \ + Tcl_EvalObjEx((interp),(objPtr),0) +#undef Tcl_GlobalEvalObj +#define Tcl_GlobalEvalObj(interp,objPtr) \ + Tcl_EvalObjEx((interp),(objPtr),TCL_EVAL_GLOBAL) +#define Tcl_CreateChild Tcl_CreateSlave +#define Tcl_GetChild Tcl_GetSlave +#define Tcl_GetParent Tcl_GetMaster #endif /* _TCLDECLS */ Index: generic/tclDictObj.c ================================================================== --- generic/tclDictObj.c +++ generic/tclDictObj.c @@ -10,11 +10,10 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tommath.h" -#include /* * Forward declaration. */ struct Dict; @@ -32,12 +31,10 @@ int objc, Tcl_Obj *const *objv); static int DictFilterCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int DictGetCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -static int DictGetDefCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const *objv); static int DictIncrCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int DictInfoCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int DictKeysCmd(ClientData dummy, Tcl_Interp *interp, @@ -65,11 +62,11 @@ static void DupDictInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static void FreeDictInternalRep(Tcl_Obj *dictPtr); static void InvalidateDictChain(Tcl_Obj *dictObj); static int SetDictFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfDict(Tcl_Obj *dictPtr); -static Tcl_HashEntry * AllocChainEntry(Tcl_HashTable *tablePtr, void *keyPtr); +static Tcl_HashEntry * AllocChainEntry(Tcl_HashTable *tablePtr,void *keyPtr); static inline void InitChainTable(struct Dict *dict); static inline void DeleteChainTable(struct Dict *dict); static inline Tcl_HashEntry *CreateChainEntry(struct Dict *dict, Tcl_Obj *keyPtr, int *newPtr); static inline int DeleteChainEntry(struct Dict *dict, Tcl_Obj *keyPtr); @@ -89,13 +86,10 @@ {"create", DictCreateCmd, TclCompileDictCreateCmd, NULL, NULL, 0 }, {"exists", DictExistsCmd, TclCompileDictExistsCmd, NULL, NULL, 0 }, {"filter", DictFilterCmd, NULL, NULL, NULL, 0 }, {"for", NULL, TclCompileDictForCmd, DictForNRCmd, NULL, 0 }, {"get", DictGetCmd, TclCompileDictGetCmd, NULL, NULL, 0 }, - {"getdef", DictGetDefCmd, TclCompileDictGetWithDefaultCmd, NULL,NULL,0}, - {"getwithdefault", DictGetDefCmd, TclCompileDictGetWithDefaultCmd, - NULL, NULL, 0 }, {"incr", DictIncrCmd, TclCompileDictIncrCmd, NULL, NULL, 0 }, {"info", DictInfoCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 }, {"keys", DictKeysCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 }, {"lappend", DictLappendCmd, TclCompileDictLappendCmd, NULL, NULL, 0 }, {"map", NULL, TclCompileDictMapCmd, DictMapNRCmd, NULL, 0 }, @@ -145,17 +139,24 @@ * created. */ ChainEntry *entryChainTail; /* Other end of linked list of all entries in * the dictionary. Used for doing traversal of * the entries in the order that they are * created. */ - size_t epoch; /* Epoch counter */ + int epoch; /* Epoch counter */ size_t refCount; /* Reference counter (see above) */ Tcl_Obj *chain; /* Linked list used for invalidating the * string representations of updated nested * dictionaries. */ } Dict; +/* + * Accessor macro for converting between a Tcl_Obj* and a Dict. Note that this + * must be assignable as well as readable. + */ + +#define DICT(dictObj) ((dictObj)->internalRep.twoPtrValue.ptr1) + /* * The structure below defines the dictionary object type by means of * functions that can be invoked by generic object code. */ @@ -165,25 +166,10 @@ DupDictInternalRep, /* dupIntRepProc */ UpdateStringOfDict, /* updateStringProc */ SetDictFromAny /* setFromAnyProc */ }; -#define DictSetIntRep(objPtr, dictRepPtr) \ - do { \ - Tcl_ObjIntRep ir; \ - ir.twoPtrValue.ptr1 = (dictRepPtr); \ - ir.twoPtrValue.ptr2 = NULL; \ - Tcl_StoreIntRep((objPtr), &tclDictType, &ir); \ - } while (0) - -#define DictGetIntRep(objPtr, dictRepPtr) \ - do { \ - const Tcl_ObjIntRep *irPtr; \ - irPtr = TclFetchIntRep((objPtr), &tclDictType); \ - (dictRepPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ - } while (0) - /* * The type of the specially adapted version of the Tcl_Obj*-containing hash * table defined in the tclObj.c code. This version differs in that it * allocates a bit more space in each hash entry in order to hold the pointers * used to keep the hash entries in a linked list. @@ -241,17 +227,17 @@ static Tcl_HashEntry * AllocChainEntry( Tcl_HashTable *tablePtr, void *keyPtr) { - Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr; + Tcl_Obj *objPtr = keyPtr; ChainEntry *cPtr; - cPtr = Tcl_Alloc(sizeof(ChainEntry)); + cPtr = ckalloc(sizeof(ChainEntry)); cPtr->entry.key.objPtr = objPtr; Tcl_IncrRefCount(objPtr); - Tcl_SetHashValue(&cPtr->entry, NULL); + cPtr->entry.clientData = NULL; cPtr->prevPtr = cPtr->nextPtr = NULL; return &cPtr->entry; } @@ -375,15 +361,14 @@ static void DupDictInternalRep( Tcl_Obj *srcPtr, Tcl_Obj *copyPtr) { - Dict *oldDict, *newDict = Tcl_Alloc(sizeof(Dict)); + Dict *oldDict = DICT(srcPtr); + Dict *newDict = ckalloc(sizeof(Dict)); ChainEntry *cPtr; - DictGetIntRep(srcPtr, oldDict); - /* * Copy values across from the old hash table. */ InitChainTable(newDict); @@ -403,19 +388,21 @@ /* * Initialise other fields. */ - newDict->epoch = 1; + newDict->epoch = 0; newDict->chain = NULL; newDict->refCount = 1; /* * Store in the object. */ - DictSetIntRep(copyPtr, newDict); + DICT(copyPtr) = newDict; + copyPtr->internalRep.twoPtrValue.ptr2 = NULL; + copyPtr->typePtr = &tclDictType; } /* *---------------------------------------------------------------------- * @@ -436,17 +423,16 @@ static void FreeDictInternalRep( Tcl_Obj *dictPtr) { - Dict *dict; - - DictGetIntRep(dictPtr, dict); + Dict *dict = DICT(dictPtr); if (dict->refCount-- <= 1) { DeleteDict(dict); } + dictPtr->typePtr = NULL; } /* *---------------------------------------------------------------------- * @@ -470,11 +456,11 @@ static void DeleteDict( Dict *dict) { DeleteChainTable(dict); - Tcl_Free(dict); + ckfree(dict); } /* *---------------------------------------------------------------------- * @@ -501,33 +487,28 @@ UpdateStringOfDict( Tcl_Obj *dictPtr) { #define LOCAL_SIZE 64 char localFlags[LOCAL_SIZE], *flagPtr = NULL; - Dict *dict; + Dict *dict = DICT(dictPtr); ChainEntry *cPtr; Tcl_Obj *keyPtr, *valuePtr; - size_t i, length, bytesNeeded = 0; + int i, length, bytesNeeded = 0; const char *elem; char *dst; /* * This field is the most useful one in the whole hash structure, and it * is not exposed by any API function... */ - size_t numElems; - - DictGetIntRep(dictPtr, dict); - - assert (dict != NULL); - - numElems = dict->table.numEntries * 2; + int numElems = dict->table.numEntries * 2; /* Handle empty list case first, simplifies what follows */ if (numElems == 0) { - Tcl_InitStringRep(dictPtr, NULL, 0); + dictPtr->bytes = tclEmptyStringRep; + dictPtr->length = 0; return; } /* * Pass 1: estimate space, gather flags. @@ -534,11 +515,11 @@ */ if (numElems <= LOCAL_SIZE) { flagPtr = localFlags; } else { - flagPtr = Tcl_Alloc(numElems); + flagPtr = ckalloc(numElems); } for (i=0,cPtr=dict->entryChainHead; inextPtr) { /* * Assume that cPtr is never NULL since we know the number of array * elements already. @@ -546,23 +527,34 @@ flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 ); keyPtr = Tcl_GetHashKey(&dict->table, &cPtr->entry); elem = TclGetStringFromObj(keyPtr, &length); bytesNeeded += TclScanElement(elem, length, flagPtr+i); + if (bytesNeeded < 0) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } + flagPtr[i+1] = TCL_DONT_QUOTE_HASH; valuePtr = Tcl_GetHashValue(&cPtr->entry); elem = TclGetStringFromObj(valuePtr, &length); bytesNeeded += TclScanElement(elem, length, flagPtr+i+1); + if (bytesNeeded < 0) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } + } + if (bytesNeeded > INT_MAX - numElems + 1) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } bytesNeeded += numElems; /* * Pass 2: copy into string rep buffer. */ - dst = Tcl_InitStringRep(dictPtr, NULL, bytesNeeded - 1); - TclOOM(dst, bytesNeeded); + dictPtr->length = bytesNeeded - 1; + dictPtr->bytes = ckalloc(bytesNeeded); + dst = dictPtr->bytes; for (i=0,cPtr=dict->entryChainHead; inextPtr) { flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 ); keyPtr = Tcl_GetHashKey(&dict->table, &cPtr->entry); elem = TclGetStringFromObj(keyPtr, &length); dst += TclConvertElement(elem, length, dst, flagPtr[i]); @@ -572,14 +564,14 @@ valuePtr = Tcl_GetHashValue(&cPtr->entry); elem = TclGetStringFromObj(valuePtr, &length); dst += TclConvertElement(elem, length, dst, flagPtr[i+1]); *dst++ = ' '; } - (void)Tcl_InitStringRep(dictPtr, NULL, bytesNeeded - 1); + dictPtr->bytes[dictPtr->length] = '\0'; if (flagPtr != localFlags) { - Tcl_Free(flagPtr); + ckfree(flagPtr); } } /* *---------------------------------------------------------------------- @@ -606,21 +598,21 @@ Tcl_Interp *interp, Tcl_Obj *objPtr) { Tcl_HashEntry *hPtr; int isNew; - Dict *dict = Tcl_Alloc(sizeof(Dict)); + Dict *dict = ckalloc(sizeof(Dict)); InitChainTable(dict); /* * Since lists and dictionaries have very closely-related string * representations (i.e. the same parsing code) we can safely special-case * the conversion from lists to dictionaries. */ - if (TclHasIntRep(objPtr, &tclListType)) { + if (objPtr->typePtr == &tclListType) { int objc, i; Tcl_Obj **objv; /* Cannot fail, we already know the Tcl_ObjType is "list". */ TclListObjGetElements(NULL, objPtr, &objc, &objv); @@ -639,27 +631,26 @@ * Not really a well-formed dictionary as there are duplicate * keys, so better get the string rep here so that we can * convert back. */ - (void) TclGetString(objPtr); + (void) Tcl_GetString(objPtr); TclDecrRefCount(discardedValue); } Tcl_SetHashValue(hPtr, objv[i+1]); Tcl_IncrRefCount(objv[i+1]); /* Since hash now holds ref to it */ } } else { - size_t length; + int length; const char *nextElem = TclGetStringFromObj(objPtr, &length); const char *limit = (nextElem + length); while (nextElem < limit) { Tcl_Obj *keyPtr, *valuePtr; const char *elemStart; - size_t elemSize; - int literal; + int elemSize, literal; if (TclFindDictElement(interp, nextElem, (limit - nextElem), &elemStart, &nextElem, &elemSize, &literal) != TCL_OK) { goto errorInFindDictElement; } @@ -672,18 +663,14 @@ if (literal) { TclNewStringObj(keyPtr, elemStart, elemSize); } else { /* Avoid double copy */ - char *dst; - TclNewObj(keyPtr); - Tcl_InvalidateStringRep(keyPtr); - dst = Tcl_InitStringRep(keyPtr, NULL, elemSize); - TclOOM(dst, elemSize); /* Consider error */ - (void)Tcl_InitStringRep(keyPtr, NULL, - TclCopyAndCollapse(elemSize, elemStart, dst)); + keyPtr->bytes = ckalloc((unsigned) elemSize + 1); + keyPtr->length = TclCopyAndCollapse(elemSize, elemStart, + keyPtr->bytes); } if (TclFindDictElement(interp, nextElem, (limit - nextElem), &elemStart, &nextElem, &elemSize, &literal) != TCL_OK) { TclDecrRefCount(keyPtr); @@ -692,18 +679,14 @@ if (literal) { TclNewStringObj(valuePtr, elemStart, elemSize); } else { /* Avoid double copy */ - char *dst; - TclNewObj(valuePtr); - Tcl_InvalidateStringRep(valuePtr); - dst = Tcl_InitStringRep(valuePtr, NULL, elemSize); - TclOOM(dst, elemSize); /* Consider error */ - (void)Tcl_InitStringRep(valuePtr, NULL, - TclCopyAndCollapse(elemSize, elemStart, dst)); + valuePtr->bytes = ckalloc((unsigned) elemSize + 1); + valuePtr->length = TclCopyAndCollapse(elemSize, elemStart, + valuePtr->bytes); } /* Store key and value in the hash table we're building. */ hPtr = CreateChainEntry(dict, keyPtr, &isNew); if (!isNew) { @@ -721,14 +704,17 @@ * Free the old internalRep before setting the new one. We do this as late * as possible to allow the conversion code, in particular * Tcl_GetStringFromObj, to use that old internalRep. */ - dict->epoch = 1; + TclFreeIntRep(objPtr); + dict->epoch = 0; dict->chain = NULL; dict->refCount = 1; - DictSetIntRep(objPtr, dict); + DICT(objPtr) = dict; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; + objPtr->typePtr = &tclDictType; return TCL_OK; missingValue: if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -735,30 +721,13 @@ "missing value to go with key", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL); } errorInFindDictElement: DeleteChainTable(dict); - Tcl_Free(dict); + ckfree(dict); return TCL_ERROR; } - -static Dict * -GetDictFromObj( - Tcl_Interp *interp, - Tcl_Obj *dictPtr) -{ - Dict *dict; - - DictGetIntRep(dictPtr, dict); - if (dict == NULL) { - if (SetDictFromAny(interp, dictPtr) != TCL_OK) { - return NULL; - } - DictGetIntRep(dictPtr, dict); - } - return dict; -} /* *---------------------------------------------------------------------- * * TclTraceDictPath -- @@ -799,17 +768,15 @@ int flags) { Dict *dict, *newDict; int i; - DictGetIntRep(dictPtr, dict); - if (dict == NULL) { - if (SetDictFromAny(interp, dictPtr) != TCL_OK) { - return NULL; - } - DictGetIntRep(dictPtr, dict); + if (dictPtr->typePtr != &tclDictType + && SetDictFromAny(interp, dictPtr) != TCL_OK) { + return NULL; } + dict = DICT(dictPtr); if (flags & DICT_PATH_UPDATE) { dict->chain = NULL; } for (i=0 ; itypePtr != &tclDictType + && SetDictFromAny(interp, tmpObj) != TCL_OK) { + return NULL; } } - DictGetIntRep(tmpObj, newDict); + newDict = DICT(tmpObj); if (flags & DICT_PATH_UPDATE) { if (Tcl_IsShared(tmpObj)) { TclDecrRefCount(tmpObj); tmpObj = Tcl_DuplicateObj(tmpObj); Tcl_IncrRefCount(tmpObj); Tcl_SetHashValue(hPtr, tmpObj); dict->epoch++; - DictGetIntRep(tmpObj, newDict); + newDict = DICT(tmpObj); } newDict->chain = dictPtr; } dict = newDict; @@ -894,28 +857,21 @@ static void InvalidateDictChain( Tcl_Obj *dictObj) { - Dict *dict; - - DictGetIntRep(dictObj, dict); - assert( dict != NULL); + Dict *dict = DICT(dictObj); do { - dict->refCount++; TclInvalidateStringRep(dictObj); - TclFreeIntRep(dictObj); - DictSetIntRep(dictObj, dict); - dict->epoch++; dictObj = dict->chain; if (dictObj == NULL) { break; } dict->chain = NULL; - DictGetIntRep(dictObj, dict); + dict = DICT(dictObj); } while (dict != NULL); } /* *---------------------------------------------------------------------- @@ -949,20 +905,20 @@ if (Tcl_IsShared(dictPtr)) { Tcl_Panic("%s called with shared object", "Tcl_DictObjPut"); } - dict = GetDictFromObj(interp, dictPtr); - if (dict == NULL) { + if (dictPtr->typePtr != &tclDictType + && SetDictFromAny(interp, dictPtr) != TCL_OK) { return TCL_ERROR; } - TclInvalidateStringRep(dictPtr); + if (dictPtr->bytes != NULL) { + TclInvalidateStringRep(dictPtr); + } + dict = DICT(dictPtr); hPtr = CreateChainEntry(dict, keyPtr, &isNew); - dict->refCount++; - TclFreeIntRep(dictPtr) - DictSetIntRep(dictPtr, dict); Tcl_IncrRefCount(valuePtr); if (!isNew) { Tcl_Obj *oldValuePtr = Tcl_GetHashValue(hPtr); TclDecrRefCount(oldValuePtr); @@ -1000,16 +956,17 @@ Tcl_Obj **valuePtrPtr) { Dict *dict; Tcl_HashEntry *hPtr; - dict = GetDictFromObj(interp, dictPtr); - if (dict == NULL) { + if (dictPtr->typePtr != &tclDictType + && SetDictFromAny(interp, dictPtr) != TCL_OK) { *valuePtrPtr = NULL; return TCL_ERROR; } + dict = DICT(dictPtr); hPtr = Tcl_FindHashEntry(&dict->table, keyPtr); if (hPtr == NULL) { *valuePtrPtr = NULL; } else { *valuePtrPtr = Tcl_GetHashValue(hPtr); @@ -1046,17 +1003,20 @@ if (Tcl_IsShared(dictPtr)) { Tcl_Panic("%s called with shared object", "Tcl_DictObjRemove"); } - dict = GetDictFromObj(interp, dictPtr); - if (dict == NULL) { + if (dictPtr->typePtr != &tclDictType + && SetDictFromAny(interp, dictPtr) != TCL_OK) { return TCL_ERROR; } + dict = DICT(dictPtr); if (DeleteChainEntry(dict, keyPtr)) { - TclInvalidateStringRep(dictPtr); + if (dictPtr->bytes != NULL) { + TclInvalidateStringRep(dictPtr); + } dict->epoch++; } return TCL_OK; } @@ -1084,15 +1044,16 @@ Tcl_Obj *dictPtr, int *sizePtr) { Dict *dict; - dict = GetDictFromObj(interp, dictPtr); - if (dict == NULL) { + if (dictPtr->typePtr != &tclDictType + && SetDictFromAny(interp, dictPtr) != TCL_OK) { return TCL_ERROR; } + dict = DICT(dictPtr); *sizePtr = dict->table.numEntries; return TCL_OK; } /* @@ -1135,18 +1096,19 @@ * otherwise. */ { Dict *dict; ChainEntry *cPtr; - dict = GetDictFromObj(interp, dictPtr); - if (dict == NULL) { + if (dictPtr->typePtr != &tclDictType + && SetDictFromAny(interp, dictPtr) != TCL_OK) { return TCL_ERROR; } + dict = DICT(dictPtr); cPtr = dict->entryChainHead; if (cPtr == NULL) { - searchPtr->epoch = 0; + searchPtr->epoch = -1; *donePtr = 1; } else { *donePtr = 0; searchPtr->dictionaryPtr = (Tcl_Dict) dict; searchPtr->epoch = dict->epoch; @@ -1203,11 +1165,11 @@ /* * If the searh is done; we do no work. */ - if (!searchPtr->epoch) { + if (searchPtr->epoch == -1) { *donePtr = 1; return; } /* @@ -1260,12 +1222,12 @@ Tcl_DictObjDone( Tcl_DictSearch *searchPtr) /* Pointer to a hash search context. */ { Dict *dict; - if (searchPtr->epoch) { - searchPtr->epoch = 0; + if (searchPtr->epoch != -1) { + searchPtr->epoch = -1; dict = (Dict *) searchPtr->dictionaryPtr; if (dict->refCount-- <= 1) { DeleteDict(dict); } } @@ -1313,12 +1275,11 @@ dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_CREATE); if (dictPtr == NULL) { return TCL_ERROR; } - DictGetIntRep(dictPtr, dict); - assert(dict != NULL); + dict = DICT(dictPtr); hPtr = CreateChainEntry(dict, keyv[keyc-1], &isNew); Tcl_IncrRefCount(valuePtr); if (!isNew) { Tcl_Obj *oldValuePtr = Tcl_GetHashValue(hPtr); @@ -1371,12 +1332,11 @@ dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_UPDATE); if (dictPtr == NULL) { return TCL_ERROR; } - DictGetIntRep(dictPtr, dict); - assert(dict != NULL); + dict = DICT(dictPtr); DeleteChainEntry(dict, keyv[keyc-1]); InvalidateDictChain(dictPtr); return TCL_OK; } @@ -1413,16 +1373,18 @@ Tcl_Obj *dictPtr; Dict *dict; TclNewObj(dictPtr); TclInvalidateStringRep(dictPtr); - dict = Tcl_Alloc(sizeof(Dict)); + dict = ckalloc(sizeof(Dict)); InitChainTable(dict); - dict->epoch = 1; + dict->epoch = 0; dict->chain = NULL; dict->refCount = 1; - DictSetIntRep(dictPtr, dict); + DICT(dictPtr) = dict; + dictPtr->internalRep.twoPtrValue.ptr2 = NULL; + dictPtr->typePtr = &tclDictType; return dictPtr; #endif } /* @@ -1461,16 +1423,18 @@ Tcl_Obj *dictPtr; Dict *dict; TclDbNewObj(dictPtr, file, line); TclInvalidateStringRep(dictPtr); - dict = Tcl_Alloc(sizeof(Dict)); + dict = ckalloc(sizeof(Dict)); InitChainTable(dict); - dict->epoch = 1; + dict->epoch = 0; dict->chain = NULL; dict->refCount = 1; - DictSetIntRep(dictPtr, dict); + DICT(dictPtr) = dict; + dictPtr->internalRep.twoPtrValue.ptr2 = NULL; + dictPtr->typePtr = &tclDictType; return dictPtr; #else /* !TCL_MEM_DEBUG */ return Tcl_NewDictObj(); #endif } @@ -1621,75 +1585,10 @@ } /* *---------------------------------------------------------------------- * - * DictGetDefCmd -- - * - * This function implements the "dict getdef" and "dict getwithdefault" - * Tcl commands. See the user documentation for details on what it does, - * and TIP#342 for the formal specification. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -static int -DictGetDefCmd( - ClientData dummy, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - Tcl_Obj *dictPtr, *keyPtr, *valuePtr, *defaultPtr; - Tcl_Obj *const *keyPath; - int numKeys; - - if (objc < 4) { - Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key ...? key default"); - return TCL_ERROR; - } - - /* - * Give the bits of arguments names for clarity. - */ - - dictPtr = objv[1]; - keyPath = &objv[2]; - numKeys = objc - 4; /* Number of keys in keyPath; there's always - * one extra key afterwards too. */ - keyPtr = objv[objc - 2]; - defaultPtr = objv[objc - 1]; - - /* - * Implement the getting-with-default operation. - */ - - dictPtr = TclTraceDictPath(interp, dictPtr, numKeys, keyPath, - DICT_PATH_EXISTS); - if (dictPtr == NULL) { - return TCL_ERROR; - } else if (dictPtr == DICT_PATH_NON_EXISTENT) { - Tcl_SetObjResult(interp, defaultPtr); - } else if (Tcl_DictObjGet(interp, dictPtr, keyPtr, &valuePtr) != TCL_OK) { - return TCL_ERROR; - } else if (valuePtr == NULL) { - Tcl_SetObjResult(interp, defaultPtr); - } else { - Tcl_SetObjResult(interp, valuePtr); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * * DictReplaceCmd -- * * This function implements the "dict replace" Tcl command. See the user * documentation for details on what it does, and TIP#111 for the formal * specification. @@ -1717,17 +1616,20 @@ Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key value ...?"); return TCL_ERROR; } dictPtr = objv[1]; - if (GetDictFromObj(interp, dictPtr) == NULL) { + if (dictPtr->typePtr != &tclDictType + && SetDictFromAny(interp, dictPtr) != TCL_OK) { return TCL_ERROR; } if (Tcl_IsShared(dictPtr)) { dictPtr = Tcl_DuplicateObj(dictPtr); } - TclInvalidateStringRep(dictPtr); + if (dictPtr->bytes != NULL) { + TclInvalidateStringRep(dictPtr); + } for (i=2 ; itypePtr != &tclDictType + && SetDictFromAny(interp, dictPtr) != TCL_OK) { return TCL_ERROR; } if (Tcl_IsShared(dictPtr)) { dictPtr = Tcl_DuplicateObj(dictPtr); } - TclInvalidateStringRep(dictPtr); + if (dictPtr->bytes != NULL) { + TclInvalidateStringRep(dictPtr); + } for (i=2 ; itypePtr != &tclDictType + && SetDictFromAny(interp, targetObj) != TCL_OK) { return TCL_ERROR; } if (objc == 2) { /* @@ -1905,11 +1811,12 @@ * A direct check that we have a dictionary. We don't start the iteration * yet because that might allocate memory or set locks that we do not * need. [Bug 1705778, leak K04] */ - if (GetDictFromObj(interp, objv[1]) == NULL) { + if (objv[1]->typePtr != &tclDictType + && SetDictFromAny(interp, objv[1]) != TCL_OK) { return TCL_ERROR; } if (objc == 3) { pattern = TclGetString(objv[2]); @@ -2075,13 +1982,15 @@ if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "dictionary key ?key ...?"); return TCL_ERROR; } - dictPtr = TclTraceDictPath(NULL, objv[1], objc-3, objv+2,DICT_PATH_EXISTS); - if (dictPtr == NULL || dictPtr == DICT_PATH_NON_EXISTENT || - Tcl_DictObjGet(NULL, dictPtr, objv[objc-1], &valuePtr) != TCL_OK) { + dictPtr = TclTraceDictPath(interp, objv[1], objc-3, objv+2, + DICT_PATH_EXISTS); + if (dictPtr == NULL || dictPtr == DICT_PATH_NON_EXISTENT + || Tcl_DictObjGet(interp, dictPtr, objv[objc-1], + &valuePtr) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); } else { Tcl_SetObjResult(interp, Tcl_NewBooleanObj(valuePtr != NULL)); } return TCL_OK; @@ -2110,26 +2019,29 @@ ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { + Tcl_Obj *dictPtr; Dict *dict; char *statsStr; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "dictionary"); return TCL_ERROR; } - dict = GetDictFromObj(interp, objv[1]); - if (dict == NULL) { + dictPtr = objv[1]; + if (dictPtr->typePtr != &tclDictType + && SetDictFromAny(interp, dictPtr) != TCL_OK) { return TCL_ERROR; } + dict = DICT(dictPtr); statsStr = Tcl_HashStats(&dict->table); Tcl_SetObjResult(interp, Tcl_NewStringObj(statsStr, -1)); - Tcl_Free(statsStr); + ckfree(statsStr); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -2182,15 +2094,16 @@ /* * A little internals surgery to avoid copying a string rep that will * soon be no good. */ + char *saved = dictPtr->bytes; Tcl_Obj *oldPtr = dictPtr; - TclNewObj(dictPtr); - TclInvalidateStringRep(dictPtr); - DupDictInternalRep(oldPtr, dictPtr); + dictPtr->bytes = NULL; + dictPtr = Tcl_DuplicateObj(dictPtr); + oldPtr->bytes = saved; } if (valuePtr == NULL) { /* * Key not in dictionary. Create new key with increment as value. */ @@ -2227,12 +2140,13 @@ Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr); } if (objc == 4) { code = TclIncrObj(interp, valuePtr, objv[3]); } else { - Tcl_Obj *incrPtr = Tcl_NewIntObj(1); + Tcl_Obj *incrPtr; + TclNewIntObj(incrPtr, 1); Tcl_IncrRefCount(incrPtr); code = TclIncrObj(interp, valuePtr, incrPtr); TclDecrRefCount(incrPtr); } } @@ -2323,11 +2237,11 @@ } } if (allocatedValue) { Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr); - } else { + } else if (dictPtr->bytes != NULL) { TclInvalidateStringRep(dictPtr); } resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr, TCL_LEAVE_ERR_MSG); @@ -2362,11 +2276,11 @@ Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { Tcl_Obj *dictPtr, *valuePtr, *resultPtr; - int allocatedDict = 0; + int i, allocatedDict = 0; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?value ...?"); return TCL_ERROR; } @@ -2385,53 +2299,21 @@ TclDecrRefCount(dictPtr); } return TCL_ERROR; } - if ((objc > 3) || (valuePtr == NULL)) { - /* Only go through append activites when something will change. */ - Tcl_Obj *appendObjPtr = NULL; - - if (objc > 3) { - /* Something to append */ - - if (objc == 4) { - appendObjPtr = objv[3]; - } else { - appendObjPtr = TclStringCat(interp, objc-3, objv+3, - TCL_STRING_IN_PLACE); - if (appendObjPtr == NULL) { - return TCL_ERROR; - } - } - } - - if (appendObjPtr == NULL) { - /* => (objc == 3) => (valuePtr == NULL) */ - TclNewObj(valuePtr); - } else if (valuePtr == NULL) { - valuePtr = appendObjPtr; - appendObjPtr = NULL; - } - - if (appendObjPtr) { - if (Tcl_IsShared(valuePtr)) { - valuePtr = Tcl_DuplicateObj(valuePtr); - } - - Tcl_IncrRefCount(appendObjPtr); - Tcl_AppendObjToObj(valuePtr, appendObjPtr); - Tcl_DecrRefCount(appendObjPtr); - } - - Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr); - } - - /* - * Even if nothing changed, we still overwrite so that variable - * trace expectations are met. - */ + if (valuePtr == NULL) { + TclNewObj(valuePtr); + } else if (Tcl_IsShared(valuePtr)) { + valuePtr = Tcl_DuplicateObj(valuePtr); + } + + for (i=3 ; iwideValue; \ - } while (0) - +/* + * How to get the bytecode out of a Tcl_Obj. + */ + +#define BYTECODE(objPtr) \ + ((ByteCode *) (objPtr)->internalRep.twoPtrValue.ptr1) /* *---------------------------------------------------------------------- * * GetLocationInformation -- @@ -193,16 +184,16 @@ void TclPrintObject( FILE *outFile, /* The file to print the source to. */ Tcl_Obj *objPtr, /* Points to the Tcl object whose string * representation should be printed. */ - size_t maxChars) /* Maximum number of chars to print. */ + int maxChars) /* Maximum number of chars to print. */ { char *bytes; - size_t length; + int length; - bytes = TclGetStringFromObj(objPtr, &length); + bytes = Tcl_GetStringFromObj(objPtr, &length); TclPrintSource(outFile, bytes, TclMin(length, maxChars)); } /* *---------------------------------------------------------------------- @@ -224,11 +215,11 @@ void TclPrintSource( FILE *outFile, /* The file to print the source to. */ const char *stringPtr, /* The string to print. */ - size_t maxChars) /* Maximum number of chars to print. */ + int maxChars) /* Maximum number of chars to print. */ { Tcl_Obj *bufferObj; TclNewObj(bufferObj); PrintSourceToObj(bufferObj, stringPtr, maxChars); @@ -252,24 +243,21 @@ static Tcl_Obj * DisassembleByteCodeObj( Tcl_Interp *interp, Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ { - ByteCode *codePtr; + ByteCode *codePtr = BYTECODE(objPtr); unsigned char *codeStart, *codeLimit, *pc; unsigned char *codeDeltaNext, *codeLengthNext; unsigned char *srcDeltaNext, *srcLengthNext; int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i, line; - Interp *iPtr; + Interp *iPtr = (Interp *) *codePtr->interpHandle; Tcl_Obj *bufferObj, *fileObj; - - ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr); - - iPtr = (Interp *) *codePtr->interpHandle; + char ptrBuf1[20], ptrBuf2[20]; TclNewObj(bufferObj); - if (!codePtr->refCount) { + if (codePtr->refCount <= 0) { return bufferObj; /* Already freed. */ } codeStart = codePtr->codeStart; codeLimit = codeStart + codePtr->numCodeBytes; @@ -277,20 +265,23 @@ /* * Print header lines describing the ByteCode. */ + sprintf(ptrBuf1, "%p", codePtr); + sprintf(ptrBuf2, "%p", iPtr); Tcl_AppendPrintfToObj(bufferObj, - "ByteCode %p, refCt %" TCL_Z_MODIFIER "u, epoch %" TCL_Z_MODIFIER "u, interp %p (epoch %" TCL_Z_MODIFIER "u)\n", - codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr, iPtr->compileEpoch); + "ByteCode 0x%s, refCt %u, epoch %u, interp 0x%s (epoch %u)\n", + ptrBuf1, codePtr->refCount, codePtr->compileEpoch, ptrBuf2, + iPtr->compileEpoch); Tcl_AppendToObj(bufferObj, " Source ", -1); PrintSourceToObj(bufferObj, codePtr->source, TclMin(codePtr->numSrcBytes, 55)); GetLocationInformation(codePtr->procPtr, &fileObj, &line); if (line > -1 && fileObj != NULL) { Tcl_AppendPrintfToObj(bufferObj, "\n File \"%s\" Line %d", - TclGetString(fileObj), line); + Tcl_GetString(fileObj), line); } Tcl_AppendPrintfToObj(bufferObj, "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes, codePtr->numLitObjects, codePtr->numAuxDataItems, @@ -321,13 +312,14 @@ if (codePtr->procPtr != NULL) { Proc *procPtr = codePtr->procPtr; int numCompiledLocals = procPtr->numCompiledLocals; + sprintf(ptrBuf1, "%p", procPtr); Tcl_AppendPrintfToObj(bufferObj, - " Proc %p, refCt %" TCL_Z_MODIFIER "u, args %d, compiled locals %d\n", - procPtr, procPtr->refCount, procPtr->numArgs, + " Proc 0x%s, refCt %d, args %d, compiled locals %d\n", + ptrBuf1, procPtr->refCount, procPtr->numArgs, numCompiledLocals); if (numCompiledLocals > 0) { CompiledLocal *localPtr = procPtr->firstLocalPtr; for (i = 0; i < numCompiledLocals; i++) { @@ -406,40 +398,40 @@ codeLengthNext = codePtr->codeLengthStart; srcDeltaNext = codePtr->srcDeltaStart; srcLengthNext = codePtr->srcLengthStart; codeOffset = srcOffset = 0; for (i = 0; i < numCmds; i++) { - if (*codeDeltaNext == 0xFF) { + if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) { codeDeltaNext++; delta = TclGetInt4AtPtr(codeDeltaNext); codeDeltaNext += 4; } else { delta = TclGetInt1AtPtr(codeDeltaNext); codeDeltaNext++; } codeOffset += delta; - if (*codeLengthNext == 0xFF) { + if ((unsigned) *codeLengthNext == (unsigned) 0xFF) { codeLengthNext++; codeLen = TclGetInt4AtPtr(codeLengthNext); codeLengthNext += 4; } else { codeLen = TclGetInt1AtPtr(codeLengthNext); codeLengthNext++; } - if (*srcDeltaNext == 0xFF) { + if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) { srcDeltaNext++; delta = TclGetInt4AtPtr(srcDeltaNext); srcDeltaNext += 4; } else { delta = TclGetInt1AtPtr(srcDeltaNext); srcDeltaNext++; } srcOffset += delta; - if (*srcLengthNext == 0xFF) { + if ((unsigned) *srcLengthNext == (unsigned) 0xFF) { srcLengthNext++; srcLen = TclGetInt4AtPtr(srcLengthNext); srcLengthNext += 4; } else { srcLen = TclGetInt1AtPtr(srcLengthNext); @@ -465,31 +457,31 @@ srcDeltaNext = codePtr->srcDeltaStart; srcLengthNext = codePtr->srcLengthStart; codeOffset = srcOffset = 0; pc = codeStart; for (i = 0; i < numCmds; i++) { - if (*codeDeltaNext == 0xFF) { + if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) { codeDeltaNext++; delta = TclGetInt4AtPtr(codeDeltaNext); codeDeltaNext += 4; } else { delta = TclGetInt1AtPtr(codeDeltaNext); codeDeltaNext++; } codeOffset += delta; - if (*srcDeltaNext == 0xFF) { + if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) { srcDeltaNext++; delta = TclGetInt4AtPtr(srcDeltaNext); srcDeltaNext += 4; } else { delta = TclGetInt1AtPtr(srcDeltaNext); srcDeltaNext++; } srcOffset += delta; - if (*srcLengthNext == 0xFF) { + if ((unsigned) *srcLengthNext == (unsigned) 0xFF) { srcLengthNext++; srcLen = TclGetInt4AtPtr(srcLengthNext); srcLengthNext += 4; } else { srcLen = TclGetInt1AtPtr(srcLengthNext); @@ -565,19 +557,19 @@ opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); break; case OPERAND_UINT1: opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; - Tcl_AppendPrintfToObj(bufferObj, "%u ", opnd); + Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); break; case OPERAND_UINT4: opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; if (opCode == INST_START_CMD) { sprintf(suffixBuffer+strlen(suffixBuffer), ", %u cmds start here", opnd); } - Tcl_AppendPrintfToObj(bufferObj, "%u ", opnd); + Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); break; case OPERAND_OFFSET1: opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++; sprintf(suffixBuffer, "pc %u", pcOffset+opnd); Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); @@ -592,20 +584,20 @@ Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); break; case OPERAND_LIT1: opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; suffixObj = codePtr->objArrayPtr[opnd]; - Tcl_AppendPrintfToObj(bufferObj, "%u ", opnd); + Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); break; case OPERAND_LIT4: opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; suffixObj = codePtr->objArrayPtr[opnd]; - Tcl_AppendPrintfToObj(bufferObj, "%u ", opnd); + Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); break; case OPERAND_AUX4: opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; - Tcl_AppendPrintfToObj(bufferObj, "%u ", opnd); + Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); auxPtr = &codePtr->auxDataArrayPtr[opnd]; break; case OPERAND_IDX4: opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; if (opnd >= -1) { @@ -625,23 +617,23 @@ numBytes += 4; printLVTindex: if (localPtr != NULL) { if (opnd >= localCt) { Tcl_Panic("FormatInstruction: bad local var index %u (%u locals)", - opnd, localCt); + (unsigned) opnd, localCt); } for (j = 0; j < opnd; j++) { localPtr = localPtr->nextPtr; } if (TclIsVarTemporary(localPtr)) { - sprintf(suffixBuffer, "temp var %u", opnd); + sprintf(suffixBuffer, "temp var %u", (unsigned) opnd); } else { sprintf(suffixBuffer, "var "); suffixSrc = localPtr->name; } } - Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", opnd); + Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", (unsigned) opnd); break; case OPERAND_SCLS1: opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; Tcl_AppendPrintfToObj(bufferObj, "%s ", tclStringClassTable[opnd].name); @@ -651,14 +643,14 @@ break; } } if (suffixObj) { const char *bytes; - size_t length; + int length; Tcl_AppendToObj(bufferObj, "\t# ", -1); - bytes = TclGetStringFromObj(codePtr->objArrayPtr[opnd], &length); + bytes = Tcl_GetStringFromObj(codePtr->objArrayPtr[opnd], &length); PrintSourceToObj(bufferObj, bytes, TclMin(length, 40)); } else if (suffixBuffer[0]) { Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer); if (suffixSrc) { PrintSourceToObj(bufferObj, suffixSrc, 40); @@ -806,12 +798,13 @@ TclNewInstNameObj( unsigned char inst) { Tcl_Obj *objPtr = Tcl_NewObj(); - TclInvalidateStringRep(objPtr); - InstNameSetIntRep(objPtr, (long) inst); + objPtr->typePtr = &tclInstNameType; + objPtr->internalRep.longValue = (long) inst; + objPtr->bytes = NULL; return objPtr; } /* @@ -826,26 +819,24 @@ static void UpdateStringOfInstName( Tcl_Obj *objPtr) { - size_t inst; /* NOTE: We know this is really an unsigned char */ - char *dst; - - InstNameGetIntRep(objPtr, inst); - - if (inst > LAST_INST_OPCODE) { - dst = Tcl_InitStringRep(objPtr, NULL, TCL_INTEGER_SPACE + 5); - TclOOM(dst, TCL_INTEGER_SPACE + 5); - sprintf(dst, "inst_%" TCL_Z_MODIFIER "u", inst); - (void) Tcl_InitStringRep(objPtr, NULL, strlen(dst)); + int inst = objPtr->internalRep.longValue; + char *s, buf[20]; + int len; + + if ((inst < 0) || (inst > LAST_INST_OPCODE)) { + sprintf(buf, "inst_%d", inst); + s = buf; } else { - const char *s = tclInstructionTable[inst].name; - size_t len = strlen(s); - dst = Tcl_InitStringRep(objPtr, s, len); - TclOOM(dst, len); + s = (char *) tclInstructionTable[objPtr->internalRep.longValue].name; } + len = strlen(s); + objPtr->bytes = ckalloc(len + 1); + memcpy(objPtr->bytes, s, len + 1); + objPtr->length = len; } /* *---------------------------------------------------------------------- * @@ -862,23 +853,23 @@ const char *stringPtr, /* The string to print. */ int maxChars) /* Maximum number of chars to print. */ { register const char *p; register int i = 0, len; - Tcl_UniChar ch = 0; if (stringPtr == NULL) { Tcl_AppendToObj(appendObj, "\"\"", -1); return; } Tcl_AppendToObj(appendObj, "\"", -1); p = stringPtr; for (; (*p != '\0') && (i < maxChars); p+=len) { + int ucs4; - len = TclUtfToUniChar(p, &ch); - switch (ch) { + len = TclUtfToUCS4(p, &ucs4); + switch (ucs4) { case '"': Tcl_AppendToObj(appendObj, "\\\"", -1); i += 2; continue; case '\f': @@ -900,32 +891,18 @@ case '\v': Tcl_AppendToObj(appendObj, "\\v", -1); i += 2; continue; default: -#if TCL_UTF_MAX > 4 - if (ch > 0xffff) { - Tcl_AppendPrintfToObj(appendObj, "\\U%08x", ch); - i += 10; - } else -#else - /* If len == 0, this means we have a char > 0xffff, resulting in - * TclUtfToUniChar producing a surrogate pair. We want to output - * this pair as a single Unicode character. - */ - if (len == 0) { - int upper = ((ch & 0x3ff) + 1) << 10; - len = TclUtfToUniChar(p, &ch); - Tcl_AppendPrintfToObj(appendObj, "\\U%08x", upper + (ch & 0x3ff)); - i += 10; - } else -#endif - if (ch < 0x20 || ch >= 0x7f) { - Tcl_AppendPrintfToObj(appendObj, "\\u%04x", ch); + if (ucs4 > 0xFFFF) { + Tcl_AppendPrintfToObj(appendObj, "\\U%08x", ucs4); + i += 10; + } else if (ucs4 < 0x20 || ucs4 >= 0x7F) { + Tcl_AppendPrintfToObj(appendObj, "\\u%04x", ucs4); i += 6; } else { - Tcl_AppendPrintfToObj(appendObj, "%c", ch); + Tcl_AppendPrintfToObj(appendObj, "%c", ucs4); i++; } continue; } } @@ -953,19 +930,17 @@ DisassembleByteCodeAsDicts( Tcl_Interp *interp, /* Used for looking up the CmdFrame for the * procedure, if one exists. */ Tcl_Obj *objPtr) /* The bytecode-holding value to take apart */ { - ByteCode *codePtr; + ByteCode *codePtr = BYTECODE(objPtr); Tcl_Obj *description, *literals, *variables, *instructions, *inst; Tcl_Obj *aux, *exn, *commands, *file; unsigned char *pc, *opnd, *codeOffPtr, *codeLenPtr, *srcOffPtr, *srcLenPtr; int codeOffset, codeLength, sourceOffset, sourceLength; int i, val, line; - ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr); - /* * Get the literals from the bytecode. */ literals = Tcl_NewObj(); @@ -1299,11 +1274,10 @@ int idx, result; Tcl_Obj *codeObjPtr = NULL; Proc *procPtr = NULL; Tcl_HashEntry *hPtr; Object *oPtr; - ByteCode *codePtr; Method *methodPtr; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "type ..."); return TCL_ERROR; @@ -1318,23 +1292,31 @@ Tcl_Obj *nsObjPtr; Tcl_Namespace *nsPtr; /* * Compile (if uncompiled) and disassemble a lambda term. + * + * WARNING! Pokes inside the lambda objtype. */ if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "lambdaTerm"); return TCL_ERROR; } - - procPtr = TclGetLambdaFromObj(interp, objv[2], &nsObjPtr); - if (procPtr == NULL) { - return TCL_ERROR; + if (objv[2]->typePtr == &tclLambdaType) { + procPtr = objv[2]->internalRep.twoPtrValue.ptr1; + } + if (procPtr == NULL || procPtr->iPtr != (Interp *) interp) { + result = tclLambdaType.setFromAnyProc(interp, objv[2]); + if (result != TCL_OK) { + return result; + } + procPtr = objv[2]->internalRep.twoPtrValue.ptr1; } memset(&cmd, 0, sizeof(Command)); + nsObjPtr = objv[2]->internalRep.twoPtrValue.ptr2; result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); if (result != TCL_OK) { return result; } cmd.nsPtr = (Namespace *) nsPtr; @@ -1380,13 +1362,12 @@ if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "script"); return TCL_ERROR; } - - if (!TclHasIntRep(objv[2], &tclByteCodeType) && (TCL_OK - != TclSetByteCodeFromAny(interp, objv[2], NULL, NULL))) { + if ((objv[2]->typePtr != &tclByteCodeType) + && (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK)) { return TCL_ERROR; } codeObjPtr = objv[2]; break; @@ -1432,11 +1413,11 @@ /* * Compile if necessary. */ - if (!TclHasIntRep(procPtr->bodyPtr, &tclByteCodeType)) { + if (procPtr->bodyPtr->typePtr != &tclByteCodeType) { Command cmd; /* * Yes, this is ugly, but we need to pass the namespace in to the * compiler in two places. @@ -1497,11 +1478,11 @@ /* * Compile if necessary. */ - if (!TclHasIntRep(procPtr->bodyPtr, &tclByteCodeType)) { + if (procPtr->bodyPtr->typePtr != &tclByteCodeType) { Command cmd; /* * Yes, this is ugly, but we need to pass the namespace in to the * compiler in two places. @@ -1582,11 +1563,11 @@ "body not available for this kind of method", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", "METHODTYPE", NULL); return TCL_ERROR; } - if (!TclHasIntRep(procPtr->bodyPtr, &tclByteCodeType)) { + if (procPtr->bodyPtr->typePtr != &tclByteCodeType) { Command cmd; /* * Yes, this is ugly, but we need to pass the namespace in to the * compiler in two places. @@ -1610,20 +1591,18 @@ /* * Do the actual disassembly. */ - ByteCodeGetIntRep(codeObjPtr, &tclByteCodeType, codePtr); - - if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { + if (BYTECODE(codeObjPtr)->flags & TCL_BYTECODE_PRECOMPILED) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "may not disassemble prebuilt bytecode", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", "BYTECODE", NULL); return TCL_ERROR; } - if (clientData) { + if (PTR2INT(clientData)) { Tcl_SetObjResult(interp, DisassembleByteCodeAsDicts(interp, codeObjPtr)); } else { Tcl_SetObjResult(interp, DisassembleByteCodeObj(interp, codeObjPtr)); Index: generic/tclEncoding.c ================================================================== --- generic/tclEncoding.c +++ generic/tclEncoding.c @@ -44,11 +44,11 @@ * null-terminated strings in this encoding. * If nullSize is 1, this is strlen; if * nullSize is 2, this is a function that * returns the number of bytes in a 0x0000 * terminated string. */ - size_t refCount; /* Number of uses of this structure. */ + int refCount; /* Number of uses of this structure. */ Tcl_HashEntry *hPtr; /* Hash table entry that owns this encoding. */ } Encoding; /* * The following structure is the clientData for a dynamically-loaded, @@ -81,11 +81,11 @@ * the value in the matrix is 0x0000. * malloc'd. */ } TableEncodingData; /* - * The following structures is the clientData for a dynamically-loaded, + * Each of the following structures is the clientData for a dynamically-loaded * escape-driven encoding that is itself comprised of other simpler encodings. * An example is "iso-2022-jp", which uses escape sequences to switch between * ascii, jis0208, jis0212, gb2312, and ksc5601. Note that "escape-driven" * does not necessarily mean that the ESCAPE character is the character used * for switching character sets. @@ -114,13 +114,13 @@ * character of one of the escape sequences in * the following array, the corresponding * entry in this array is 1, otherwise it is * 0. */ int numSubTables; /* Length of following array. */ - EscapeSubTable subTables[1];/* Information about each EscapeSubTable used - * by this encoding type. The actual size will - * be as large as necessary to hold all + EscapeSubTable subTables[TCLFLEXARRAY];/* Information about each EscapeSubTable used + * by this encoding type. The actual size is + * as large as necessary to hold all * EscapeSubTables. */ } EscapeEncodingData; /* * Constants used when loading an encoding file to identify the type of the @@ -154,11 +154,11 @@ /* * A list of directories making up the "library path". Historically this * search path has served many uses, but the only one remaining is a base for * the encodingSearchPath above. If the application does not explicitly set - * the encodingSearchPath, then it will be initialized by appending /encoding + * the encodingSearchPath, then it is initialized by appending /encoding * to each directory in this "libraryPath". */ static ProcessGlobalValue libraryPath = { 0, 0, NULL, NULL, TclpInitLibraryPath, NULL, NULL @@ -175,11 +175,11 @@ TCL_DECLARE_MUTEX(encodingMutex) /* * The following are used to hold the default and current system encodings. * If NULL is passed to one of the conversion routines, the current setting of - * the system encoding will be used to perform the conversion. + * the system encoding is used to perform the conversion. */ static Tcl_Encoding defaultEncoding = NULL; static Tcl_Encoding systemEncoding = NULL; Tcl_Encoding tclIdentityEncoding = NULL; @@ -193,39 +193,29 @@ /* * Functions used only in this module. */ -static int BinaryProc(ClientData clientData, - const char *src, int srcLen, int flags, - Tcl_EncodingState *statePtr, char *dst, int dstLen, - int *srcReadPtr, int *dstWrotePtr, - int *dstCharsPtr); -static void DupEncodingIntRep(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr); -static void EscapeFreeProc(ClientData clientData); -static int EscapeFromUtfProc(ClientData clientData, - const char *src, int srcLen, int flags, - Tcl_EncodingState *statePtr, char *dst, int dstLen, - int *srcReadPtr, int *dstWrotePtr, - int *dstCharsPtr); -static int EscapeToUtfProc(ClientData clientData, - const char *src, int srcLen, int flags, - Tcl_EncodingState *statePtr, char *dst, int dstLen, - int *srcReadPtr, int *dstWrotePtr, - int *dstCharsPtr); -static void FillEncodingFileMap(void); -static void FreeEncoding(Tcl_Encoding encoding); -static void FreeEncodingIntRep(Tcl_Obj *objPtr); -static Encoding * GetTableEncoding(EscapeEncodingData *dataPtr, - int state); -static Tcl_Encoding LoadEncodingFile(Tcl_Interp *interp, const char *name); -static Tcl_Encoding LoadTableEncoding(const char *name, int type, - Tcl_Channel chan); -static Tcl_Encoding LoadEscapeEncoding(const char *name, Tcl_Channel chan); -static Tcl_Channel OpenEncodingFileChannel(Tcl_Interp *interp, - const char *name); -static void TableFreeProc(ClientData clientData); +static Tcl_EncodingConvertProc BinaryProc; +static Tcl_DupInternalRepProc DupEncodingIntRep; +static Tcl_EncodingFreeProc EscapeFreeProc; +static Tcl_EncodingConvertProc EscapeFromUtfProc; +static Tcl_EncodingConvertProc EscapeToUtfProc; +static void FillEncodingFileMap(void); +static void FreeEncoding(Tcl_Encoding encoding); +static Tcl_FreeInternalRepProc FreeEncodingIntRep; +static Encoding * GetTableEncoding(EscapeEncodingData *dataPtr, + int state); +static Tcl_Encoding LoadEncodingFile(Tcl_Interp *interp, + const char *name); +static Tcl_Encoding LoadTableEncoding(const char *name, int type, + Tcl_Channel chan); +static Tcl_Encoding LoadEscapeEncoding(const char *name, + Tcl_Channel chan); +static Tcl_Channel OpenEncodingFileChannel(Tcl_Interp *interp, + const char *name); +static Tcl_EncodingFreeProc TableFreeProc; static int TableFromUtfProc(ClientData clientData, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); @@ -232,16 +222,16 @@ static int TableToUtfProc(ClientData clientData, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); static size_t unilen(const char *src); -static int UniCharToUtfProc(ClientData clientData, +static int UnicodeToUtfProc(ClientData clientData, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); -static int UtfToUniCharProc(ClientData clientData, +static int UtfToUnicodeProc(ClientData clientData, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); static int UtfToUtfProc(ClientData clientData, @@ -277,25 +267,10 @@ */ static const Tcl_ObjType encodingType = { "encoding", FreeEncodingIntRep, DupEncodingIntRep, NULL, NULL }; -#define EncodingSetIntRep(objPtr, encoding) \ - do { \ - Tcl_ObjIntRep ir; \ - ir.twoPtrValue.ptr1 = (encoding); \ - ir.twoPtrValue.ptr2 = NULL; \ - Tcl_StoreIntRep((objPtr), &encodingType, &ir); \ - } while (0) - -#define EncodingGetIntRep(objPtr, encoding) \ - do { \ - const Tcl_ObjIntRep *irPtr; \ - irPtr = TclFetchIntRep ((objPtr), &encodingType); \ - (encoding) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ - } while (0) - /* *---------------------------------------------------------------------- * * Tcl_GetEncodingFromObj -- @@ -318,20 +293,21 @@ Tcl_GetEncodingFromObj( Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Encoding *encodingPtr) { - Tcl_Encoding encoding; const char *name = TclGetString(objPtr); - EncodingGetIntRep(objPtr, encoding); - if (encoding == NULL) { - encoding = Tcl_GetEncoding(interp, name); + if (objPtr->typePtr != &encodingType) { + Tcl_Encoding encoding = Tcl_GetEncoding(interp, name); + if (encoding == NULL) { return TCL_ERROR; } - EncodingSetIntRep(objPtr, encoding); + TclFreeIntRep(objPtr); + objPtr->internalRep.twoPtrValue.ptr1 = encoding; + objPtr->typePtr = &encodingType; } *encodingPtr = Tcl_GetEncoding(NULL, name); return TCL_OK; } @@ -347,14 +323,12 @@ static void FreeEncodingIntRep( Tcl_Obj *objPtr) { - Tcl_Encoding encoding; - - EncodingGetIntRep(objPtr, encoding); - Tcl_FreeEncoding(encoding); + Tcl_FreeEncoding((Tcl_Encoding)objPtr->internalRep.twoPtrValue.ptr1); + objPtr->typePtr = NULL; } /* *---------------------------------------------------------------------- * @@ -368,12 +342,11 @@ static void DupEncodingIntRep( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { - Tcl_Encoding encoding = Tcl_GetEncoding(NULL, TclGetString(srcPtr)); - EncodingSetIntRep(dupPtr, encoding); + dupPtr->internalRep.twoPtrValue.ptr1 = Tcl_GetEncoding(NULL, srcPtr->bytes); } /* *---------------------------------------------------------------------- * @@ -444,13 +417,12 @@ * TclSetLibraryPath -- * * Keeps the per-thread copy of the library path current with changes to * the global copy. * - * NOTE: this routine returns void, so there's no way to report the error - * that searchPath is not a valid list. In that case, this routine will - * silently do nothing. + * Since the result of this routine is void, if searchPath is not a valid + * list this routine silently does nothing. * *---------------------------------------------------------------------- */ void @@ -468,21 +440,20 @@ /* *--------------------------------------------------------------------------- * * FillEncodingFileMap -- * - * Called to bring the encoding file map in sync with the current value + * Called to update the encoding file map with the current value * of the encoding search path. * - * Scan the directories on the encoding search path, find the *.enc - * files, and store the found pathnames in a map associated with the - * encoding name. - * - * In particular, if $dir is on the encoding search path, and the file - * $dir/foo.enc is found, then store a "foo" -> $dir entry in the map. - * Later, any need for the "foo" encoding will quickly * be able to - * construct the $dir/foo.enc pathname for reading the encoding data. + * Finds *.end files in the directories on the encoding search path and + * stores the found pathnames in a map associated with the encoding name. + * + * If $dir is on the encoding search path and the file $dir/foo.enc is + * found, stores a "foo" -> $dir entry in the map. if the "foo" encoding + * is needed later, the $dir/foo.enc name can be quickly constructed in + * order to read the encoding data. * * Results: * None. * * Side effects: @@ -562,26 +533,31 @@ { Tcl_EncodingType type; TableEncodingData *dataPtr; unsigned size; unsigned short i; + union { + char c; + short s; + } isLe; if (encodingsInitialized) { return; } + isLe.s = 1; Tcl_MutexLock(&encodingMutex); Tcl_InitHashTable(&encodingTable, TCL_STRING_KEYS); Tcl_MutexUnlock(&encodingMutex); /* - * Create a few initial encodings. Note that the UTF-8 to UTF-8 - * translation is not a no-op, because it will turn a stream of improperly - * formed UTF-8 into a properly formed stream. + * Create a few initial encodings. UTF-8 to UTF-8 translation is not a + * no-op because it turns a stream of improperly formed UTF-8 into a + * properly formed stream. */ - type.encodingName = NULL; + type.encodingName = "identity"; type.toUtfProc = BinaryProc; type.fromUtfProc = BinaryProc; type.freeProc = NULL; type.nullSize = 1; type.clientData = NULL; @@ -594,32 +570,32 @@ type.nullSize = 1; type.clientData = NULL; Tcl_CreateEncoding(&type); type.encodingName = "unicode"; - type.toUtfProc = UniCharToUtfProc; - type.fromUtfProc = UtfToUniCharProc; + type.toUtfProc = UnicodeToUtfProc; + type.fromUtfProc = UtfToUnicodeProc; type.freeProc = NULL; type.nullSize = 2; - type.clientData = NULL; + type.clientData = INT2PTR(isLe.c); Tcl_CreateEncoding(&type); /* * Need the iso8859-1 encoding in order to process binary data, so force * it to always be embedded. Note that this encoding *must* be a proper * table encoding or some of the escape encodings crash! Hence the ugly * code to duplicate the structure of a table encoding here. */ - dataPtr = Tcl_Alloc(sizeof(TableEncodingData)); + dataPtr = (TableEncodingData *)ckalloc(sizeof(TableEncodingData)); memset(dataPtr, 0, sizeof(TableEncodingData)); dataPtr->fallback = '?'; size = 256*(sizeof(unsigned short *) + sizeof(unsigned short)); - dataPtr->toUnicode = Tcl_Alloc(size); + dataPtr->toUnicode = (unsigned short **)ckalloc(size); memset(dataPtr->toUnicode, 0, size); - dataPtr->fromUnicode = Tcl_Alloc(size); + dataPtr->fromUnicode = (unsigned short **)ckalloc(size); memset(dataPtr->fromUnicode, 0, size); dataPtr->toUnicode[0] = (unsigned short *) (dataPtr->toUnicode + 256); dataPtr->fromUnicode[0] = (unsigned short *) (dataPtr->fromUnicode + 256); for (i=1 ; i<256 ; i++) { @@ -681,17 +657,79 @@ * like escape encodings use. [Bug 524674] Make sure to call * Tcl_FirstHashEntry repeatedly so that all encodings are eventually * cleaned up. */ - FreeEncoding(Tcl_GetHashValue(hPtr)); + FreeEncoding((Tcl_Encoding)Tcl_GetHashValue(hPtr)); hPtr = Tcl_FirstHashEntry(&encodingTable, &search); } Tcl_DeleteHashTable(&encodingTable); Tcl_MutexUnlock(&encodingMutex); } + +/* + *------------------------------------------------------------------------- + * + * Tcl_GetDefaultEncodingDir -- + * + * Legacy public interface to retrieve first directory in the encoding + * searchPath. + * + * Results: + * The directory pathname, as a string, or NULL for an empty encoding + * search path. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +const char * +Tcl_GetDefaultEncodingDir(void) +{ + int numDirs; + Tcl_Obj *first, *searchPath = Tcl_GetEncodingSearchPath(); + + Tcl_ListObjLength(NULL, searchPath, &numDirs); + if (numDirs == 0) { + return NULL; + } + Tcl_ListObjIndex(NULL, searchPath, 0, &first); + + return TclGetString(first); +} + +/* + *------------------------------------------------------------------------- + * + * Tcl_SetDefaultEncodingDir -- + * + * Legacy public interface to set the first directory in the encoding + * search path. + * + * Results: + * None. + * + * Side effects: + * Modifies the encoding search path. + * + *------------------------------------------------------------------------- + */ + +void +Tcl_SetDefaultEncodingDir( + const char *path) +{ + Tcl_Obj *searchPath = Tcl_GetEncodingSearchPath(); + Tcl_Obj *directory = Tcl_NewStringObj(path, -1); + + searchPath = Tcl_DuplicateObj(searchPath); + Tcl_ListObjReplace(NULL, searchPath, 0, 0, 1, &directory); + Tcl_SetEncodingSearchPath(searchPath); +} /* *------------------------------------------------------------------------- * * Tcl_GetEncoding -- @@ -705,15 +743,11 @@ * to any known or loadable encoding, NULL is returned. If NULL was * returned, an error message is left in interp's result object, unless * interp was NULL. * * Side effects: - * The new encoding type is entered into a table visible to all - * interpreters, keyed off the encoding's name. For each call to this - * function, there should eventually be a call to Tcl_FreeEncoding, so - * that the database can be cleaned up when encodings aren't needed - * anymore. + * LoadEncodingFile is called if necessary. * *------------------------------------------------------------------------- */ Tcl_Encoding @@ -732,11 +766,11 @@ return systemEncoding; } hPtr = Tcl_FindHashEntry(&encodingTable, name); if (hPtr != NULL) { - encodingPtr = Tcl_GetHashValue(hPtr); + encodingPtr = (Encoding *)Tcl_GetHashValue(hPtr); encodingPtr->refCount++; Tcl_MutexUnlock(&encodingMutex); return (Tcl_Encoding) encodingPtr; } Tcl_MutexUnlock(&encodingMutex); @@ -747,19 +781,19 @@ /* *--------------------------------------------------------------------------- * * Tcl_FreeEncoding -- * - * This function is called to release an encoding allocated by - * Tcl_CreateEncoding() or Tcl_GetEncoding(). + * Releases an encoding allocated by Tcl_CreateEncoding() or + * Tcl_GetEncoding(). * * Results: * None. * * Side effects: * The reference count associated with the encoding is decremented and - * the encoding may be deleted if nothing is using it anymore. + * the encoding is deleted if nothing is using it anymore. * *--------------------------------------------------------------------------- */ void @@ -774,17 +808,18 @@ /* *---------------------------------------------------------------------- * * FreeEncoding -- * - * This function is called to release an encoding by functions that - * already have the encodingMutex. + * Decrements the reference count of an encoding. The caller must hold + * encodingMutes. * * Results: * None. * * Side effects: + * Releases the resource for an encoding if it is now unused. * The reference count associated with the encoding is decremented and * the encoding may be deleted if nothing is using it anymore. * *---------------------------------------------------------------------- */ @@ -796,21 +831,24 @@ Encoding *encodingPtr = (Encoding *) encoding; if (encodingPtr == NULL) { return; } + if (encodingPtr->refCount<=0) { + Tcl_Panic("FreeEncoding: refcount problem !!!"); + } if (encodingPtr->refCount-- <= 1) { if (encodingPtr->freeProc != NULL) { encodingPtr->freeProc(encodingPtr->clientData); } if (encodingPtr->hPtr != NULL) { Tcl_DeleteHashEntry(encodingPtr->hPtr); } if (encodingPtr->name) { - Tcl_Free(encodingPtr->name); + ckfree(encodingPtr->name); } - Tcl_Free(encodingPtr); + ckfree(encodingPtr); } } /* *------------------------------------------------------------------------- @@ -876,11 +914,11 @@ */ Tcl_MutexLock(&encodingMutex); for (hPtr = Tcl_FirstHashEntry(&encodingTable, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - Encoding *encodingPtr = Tcl_GetHashValue(hPtr); + Encoding *encodingPtr = (Encoding *)Tcl_GetHashValue(hPtr); Tcl_CreateHashEntry(&table, Tcl_NewStringObj(encodingPtr->name, -1), &dummy); } Tcl_MutexUnlock(&encodingMutex); @@ -968,38 +1006,56 @@ /* *--------------------------------------------------------------------------- * * Tcl_CreateEncoding -- * - * This function is called to define a new encoding and the functions - * that are used to convert between the specified encoding and Unicode. + * Defines a new encoding, along with the functions that are used to + * convert to and from Unicode. * * Results: * Returns a token that represents the encoding. If an encoding with the * same name already existed, the old encoding token remains valid and - * continues to behave as it used to, and will eventually be garbage - * collected when the last reference to it goes away. Any subsequent - * calls to Tcl_GetEncoding with the specified name will retrieve the - * most recent encoding token. + * continues to behave as it used to, and is eventually garbage collected + * when the last reference to it goes away. Any subsequent calls to + * Tcl_GetEncoding with the specified name retrieve the most recent + * encoding token. * * Side effects: - * The new encoding type is entered into a table visible to all - * interpreters, keyed off the encoding's name. For each call to this - * function, there should eventually be a call to Tcl_FreeEncoding, so - * that the database can be cleaned up when encodings aren't needed - * anymore. + * A new record having the name of the encoding is entered into a table of + * encodings visible to all interpreters. For each call to this function, + * there should eventually be a call to Tcl_FreeEncoding, which cleans + * deletes the record in the table when an encoding is no longer needed. * *--------------------------------------------------------------------------- */ Tcl_Encoding Tcl_CreateEncoding( const Tcl_EncodingType *typePtr) /* The encoding type. */ { - Encoding *encodingPtr = Tcl_Alloc(sizeof(Encoding)); - encodingPtr->name = NULL; + Tcl_HashEntry *hPtr; + int isNew; + Encoding *encodingPtr; + char *name; + + Tcl_MutexLock(&encodingMutex); + hPtr = Tcl_CreateHashEntry(&encodingTable, typePtr->encodingName, &isNew); + if (isNew == 0) { + /* + * Remove old encoding from hash table, but don't delete it until last + * reference goes away. + */ + + encodingPtr = (Encoding *)Tcl_GetHashValue(hPtr); + encodingPtr->hPtr = NULL; + } + + name = (char *)ckalloc(strlen(typePtr->encodingName) + 1); + + encodingPtr = (Encoding *)ckalloc(sizeof(Encoding)); + encodingPtr->name = strcpy(name, typePtr->encodingName); encodingPtr->toUtfProc = typePtr->toUtfProc; encodingPtr->fromUtfProc = typePtr->fromUtfProc; encodingPtr->freeProc = typePtr->freeProc; encodingPtr->nullSize = typePtr->nullSize; encodingPtr->clientData = typePtr->clientData; @@ -1007,36 +1063,15 @@ encodingPtr->lengthProc = (LengthProc *) strlen; } else { encodingPtr->lengthProc = (LengthProc *) unilen; } encodingPtr->refCount = 1; - encodingPtr->hPtr = NULL; - - if (typePtr->encodingName) { - Tcl_HashEntry *hPtr; - int isNew; - char *name; - - Tcl_MutexLock(&encodingMutex); - hPtr = Tcl_CreateHashEntry(&encodingTable, typePtr->encodingName, &isNew); - if (isNew == 0) { - /* - * Remove old encoding from hash table, but don't delete it until last - * reference goes away. - */ - - Encoding *replaceMe = Tcl_GetHashValue(hPtr); - replaceMe->hPtr = NULL; - } - - name = Tcl_Alloc(strlen(typePtr->encodingName) + 1); - encodingPtr->name = strcpy(name, typePtr->encodingName); encodingPtr->hPtr = hPtr; Tcl_SetHashValue(hPtr, encodingPtr); Tcl_MutexUnlock(&encodingMutex); - } + return (Tcl_Encoding) encodingPtr; } /* *------------------------------------------------------------------------- @@ -1062,20 +1097,19 @@ char * Tcl_ExternalToUtfDString( Tcl_Encoding encoding, /* The encoding for the source string, or NULL * for the default system encoding. */ const char *src, /* Source string in specified encoding. */ - size_t srcLen, /* Source string length in bytes, or -1 for + int srcLen, /* Source string length in bytes, or < 0 for * encoding-specific string length. */ Tcl_DString *dstPtr) /* Uninitialized or free DString in which the * converted string is stored. */ { char *dst; Tcl_EncodingState state; const Encoding *encodingPtr; - int flags, result, soFar, srcRead, dstWrote, dstChars; - size_t dstLen; + int flags, dstLen, result, soFar, srcRead, dstWrote, dstChars; Tcl_DStringInit(dstPtr); dst = Tcl_DStringValue(dstPtr); dstLen = dstPtr->spaceAvl - 1; @@ -1084,11 +1118,11 @@ } encodingPtr = (Encoding *) encoding; if (src == NULL) { srcLen = 0; - } else if (srcLen == TCL_AUTO_LENGTH) { + } else if (srcLen < 0) { srcLen = encodingPtr->lengthProc(src); } flags = TCL_ENCODING_START | TCL_ENCODING_END; @@ -1136,21 +1170,21 @@ Tcl_ExternalToUtf( Tcl_Interp *interp, /* Interp for error return, if not NULL. */ Tcl_Encoding encoding, /* The encoding for the source string, or NULL * for the default system encoding. */ const char *src, /* Source string in specified encoding. */ - size_t srcLen, /* Source string length in bytes, or -1 - * for encoding-specific string length. */ + int srcLen, /* Source string length in bytes, or < 0 for + * encoding-specific string length. */ int flags, /* Conversion control flags. */ Tcl_EncodingState *statePtr,/* Place for conversion routine to store state * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ char *dst, /* Output buffer in which converted string is * stored. */ - size_t dstLen, /* The maximum length of output buffer in + int dstLen, /* The maximum length of output buffer in * bytes. */ int *srcReadPtr, /* Filled with the number of bytes from the * source string that were converted. This may * be less than the original source length if * there was a problem converting some source @@ -1174,11 +1208,11 @@ } encodingPtr = (Encoding *) encoding; if (src == NULL) { srcLen = 0; - } else if (srcLen == TCL_AUTO_LENGTH) { + } else if (srcLen < 0) { srcLen = encodingPtr->lengthProc(src); } if (statePtr == NULL) { flags |= TCL_ENCODING_START | TCL_ENCODING_END; statePtr = &state; @@ -1214,11 +1248,11 @@ flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr); if (*dstCharsPtr <= maxChars) { break; } - dstLen = Tcl_UtfAtIndex(dst, maxChars) - 1 - dst + TCL_UTF_MAX; + dstLen = Tcl_UtfAtIndex(dst, maxChars) - dst + (TCL_UTF_MAX - 1); flags = savedFlags; *statePtr = savedState; } while (1); if (!noTerminate) { /* ...and then append it */ @@ -1232,14 +1266,13 @@ /* *------------------------------------------------------------------------- * * Tcl_UtfToExternalDString -- * - * Convert a source buffer from UTF-8 into the specified encoding. If any + * Convert a source buffer from UTF-8 to the specified encoding. If any * of the bytes in the source buffer are invalid or cannot be represented - * in the target encoding, a default fallback character will be - * substituted. + * in the target encoding, a default fallback character is substituted. * * Results: * The converted bytes are stored in the DString, which is then NULL * terminated in an encoding-specific manner. The return value is a * pointer to the value stored in the DString. @@ -1253,20 +1286,19 @@ char * Tcl_UtfToExternalDString( Tcl_Encoding encoding, /* The encoding for the converted string, or * NULL for the default system encoding. */ const char *src, /* Source string in UTF-8. */ - size_t srcLen, /* Source string length in bytes, or -1 for + int srcLen, /* Source string length in bytes, or < 0 for * strlen(). */ Tcl_DString *dstPtr) /* Uninitialized or free DString in which the * converted string is stored. */ { char *dst; Tcl_EncodingState state; const Encoding *encodingPtr; - int flags, result, soFar, srcRead, dstWrote, dstChars; - size_t dstLen; + int flags, dstLen, result, soFar, srcRead, dstWrote, dstChars; Tcl_DStringInit(dstPtr); dst = Tcl_DStringValue(dstPtr); dstLen = dstPtr->spaceAvl - 1; @@ -1275,11 +1307,11 @@ } encodingPtr = (Encoding *) encoding; if (src == NULL) { srcLen = 0; - } else if (srcLen == TCL_AUTO_LENGTH) { + } else if (srcLen < 0) { srcLen = strlen(src); } flags = TCL_ENCODING_START | TCL_ENCODING_END; while (1) { result = encodingPtr->fromUtfProc(encodingPtr->clientData, src, @@ -1329,21 +1361,21 @@ Tcl_UtfToExternal( Tcl_Interp *interp, /* Interp for error return, if not NULL. */ Tcl_Encoding encoding, /* The encoding for the converted string, or * NULL for the default system encoding. */ const char *src, /* Source string in UTF-8. */ - size_t srcLen, /* Source string length in bytes, or -1 - * for strlen(). */ + int srcLen, /* Source string length in bytes, or < 0 for + * strlen(). */ int flags, /* Conversion control flags. */ Tcl_EncodingState *statePtr,/* Place for conversion routine to store state * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ char *dst, /* Output buffer in which converted string * is stored. */ - size_t dstLen, /* The maximum length of output buffer in + int dstLen, /* The maximum length of output buffer in * bytes. */ int *srcReadPtr, /* Filled with the number of bytes from the * source string that were converted. This may * be less than the original source length if * there was a problem converting some source @@ -1364,11 +1396,11 @@ } encodingPtr = (Encoding *) encoding; if (src == NULL) { srcLen = 0; - } else if (srcLen == TCL_AUTO_LENGTH) { + } else if (srcLen < 0) { srcLen = strlen(src); } if (statePtr == NULL) { flags |= TCL_ENCODING_START | TCL_ENCODING_END; statePtr = &state; @@ -1547,26 +1579,26 @@ * * Read a file that describes an encoding and create a new Encoding from * the data. * * Results: - * The return value is the newly loaded Encoding, or NULL if the file - * didn't exist of was in the incorrect format. If NULL was returned, an - * error message is left in interp's result object, unless interp was - * NULL. + * The return value is the newly loaded Tcl_Encoding or NULL if the file + * didn't exist or could not be processed. If NULL is returned and interp + * is not NULL, an error message is left in interp's result object. * * Side effects: - * File read from disk. + * A corresponding encoding file might be read from persistent storage, in + * which case LoadTableEncoding is called. * *--------------------------------------------------------------------------- */ static Tcl_Encoding LoadEncodingFile( Tcl_Interp *interp, /* Interp for error reporting, if not NULL. */ - const char *name) /* The name of the encoding file on disk and - * also the name for new encoding. */ + const char *name) /* The name of both the encoding file + * and the new encoding. */ { Tcl_Channel chan = NULL; Tcl_Encoding encoding = NULL; int ch; @@ -1616,31 +1648,31 @@ /* *------------------------------------------------------------------------- * * LoadTableEncoding -- * - * Helper function for LoadEncodingTable(). Loads a table to that - * converts between Unicode and some other encoding and creates an - * encoding (using a TableEncoding structure) from that information. + * Helper function for LoadEncodingFile(). Creates a Tcl_EncodingType + * structure along with its corresponding TableEncodingData structure, and + * passes it to Tcl_Createncoding. * - * File contains binary data, but begins with a marker to indicate - * byte-ordering, so that same binary file can be read on either endian - * platforms. + * The file contains binary data but begins with a marker to indicate + * byte-ordering so a single binary file can be read on big or + * little-endian systems. * * Results: - * The return value is the new encoding, or NULL if the encoding could - * not be created (because the file contained invalid data). + * Returns the new Tcl_Encoding, or NULL if it could could + * not be created because the file contained invalid data. * * Side effects: - * None. + * See Tcl_CreateEncoding(). * *------------------------------------------------------------------------- */ static Tcl_Encoding LoadTableEncoding( - const char *name, /* Name for new encoding. */ + const char *name, /* Name of the new encoding. */ int type, /* Type of encoding (ENCODING_?????). */ Tcl_Channel chan) /* File containing new encoding. */ { Tcl_DString lineString; Tcl_Obj *objPtr; @@ -1675,11 +1707,11 @@ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 224 ... 239 */ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 240 ... 255 */ }; Tcl_DStringInit(&lineString); - if (Tcl_Gets(chan, &lineString) == TCL_IO_FAILURE) { + if (Tcl_Gets(chan, &lineString) == -1) { return NULL; } line = Tcl_DStringValue(&lineString); fallback = (int) strtol(line, &line, 16); @@ -1696,11 +1728,11 @@ memset(used, 0, sizeof(used)); #undef PAGESIZE #define PAGESIZE (256 * sizeof(unsigned short)) - dataPtr = Tcl_Alloc(sizeof(TableEncodingData)); + dataPtr = (TableEncodingData *)ckalloc(sizeof(TableEncodingData)); memset(dataPtr, 0, sizeof(TableEncodingData)); dataPtr->fallback = fallback; /* @@ -1708,30 +1740,30 @@ * malloc to get the memory for the array and all the pages needed by the * array. */ size = 256 * sizeof(unsigned short *) + numPages * PAGESIZE; - dataPtr->toUnicode = Tcl_Alloc(size); + dataPtr->toUnicode = (unsigned short **)ckalloc(size); memset(dataPtr->toUnicode, 0, size); pageMemPtr = (unsigned short *) (dataPtr->toUnicode + 256); TclNewObj(objPtr); Tcl_IncrRefCount(objPtr); for (i = 0; i < numPages; i++) { int ch; const char *p; - size_t expected = 3 + 16 * (16 * 4 + 1); + int expected = 3 + 16 * (16 * 4 + 1); if (Tcl_ReadChars(chan, objPtr, expected, 0) != expected) { return NULL; } p = TclGetString(objPtr); hi = (staticHex[UCHAR(p[0])] << 4) + staticHex[UCHAR(p[1])]; dataPtr->toUnicode[hi] = pageMemPtr; p += 2; for (lo = 0; lo < 256; lo++) { - if ((lo & 0x0f) == 0) { + if ((lo & 0x0F) == 0) { p++; } ch = (staticHex[UCHAR(p[0])] << 12) + (staticHex[UCHAR(p[1])] << 8) + (staticHex[UCHAR(p[2])] << 4) + staticHex[UCHAR(p[3])]; if (ch != 0) { @@ -1753,14 +1785,14 @@ } } } /* - * Invert toUnicode array to produce the fromUnicode array. Performs a + * Invert the toUnicode array to produce the fromUnicode array. Performs a * single malloc to get the memory for the array and all the pages needed - * by the array. While reading in the toUnicode array, we remembered what - * pages that would be needed for the fromUnicode array. + * by the array. While reading in the toUnicode array remember what + * pages are needed for the fromUnicode array. */ if (symbol) { used[0] = 1; } @@ -1769,11 +1801,11 @@ if (used[hi]) { numPages++; } } size = 256 * sizeof(unsigned short *) + numPages * PAGESIZE; - dataPtr->fromUnicode = Tcl_Alloc(size); + dataPtr->fromUnicode = (unsigned short **)ckalloc(size); memset(dataPtr->fromUnicode, 0, size); pageMemPtr = (unsigned short *) (dataPtr->fromUnicode + 256); for (hi = 0; hi < 256; hi++) { if (dataPtr->toUnicode[hi] == NULL) { @@ -1788,19 +1820,19 @@ if (page == NULL) { page = pageMemPtr; pageMemPtr += 256; dataPtr->fromUnicode[ch >> 8] = page; } - page[ch & 0xff] = (unsigned short) ((hi << 8) + lo); + page[ch & 0xFF] = (unsigned short) ((hi << 8) + lo); } } } if (type == ENCODING_MULTIBYTE) { /* * If multibyte encodings don't have a backslash character, define - * one. Otherwise, on Windows, native file names won't work because - * the backslash in the file name will map to the unknown character + * one. Otherwise, on Windows, native file names don't work because + * the backslash in the file name maps to the unknown character * (question mark) when converting from UTF-8 to external encoding. */ if (dataPtr->fromUnicode[0] != NULL) { if (dataPtr->fromUnicode[0]['\\'] == '\0') { @@ -1808,17 +1840,17 @@ } } } if (symbol) { /* - * Make a special symbol encoding that not only maps the symbol - * characters from their Unicode code points down into page 0, but - * also ensure that the characters on page 0 map to themselves. This - * is so that a symbol font can be used to display a simple string - * like "abcd" and have alpha, beta, chi, delta show up, rather than - * have "unknown" chars show up because strictly speaking the symbol - * font doesn't have glyphs for those low ASCII chars. + * Make a special symbol encoding that maps each symbol character from + * its Unicode code point down into page 0, and also ensure that each + * characters on page 0 maps to itself so that a symbol font can be + * used to display a simple string like "abcd" and have alpha, beta, + * chi, delta show up, rather than have "unknown" chars show up because + * strictly speaking the symbol font doesn't have glyphs for those low + * ASCII chars. */ page = dataPtr->fromUnicode[0]; if (page == NULL) { page = pageMemPtr; @@ -1861,15 +1893,15 @@ if (line[0] != 'R') { goto doneParse; } /* - * Read lines from the encoding until EOF. + * Read lines until EOF. */ for (TclDStringClear(&lineString); - (len = Tcl_Gets(chan, &lineString)) != -1; + (len = Tcl_Gets(chan, &lineString)) >= 0; TclDStringClear(&lineString)) { const unsigned char *p; int to, from; /* @@ -1894,11 +1926,11 @@ from = (staticHex[p[0]] << 12) + (staticHex[p[1]] << 8) + (staticHex[p[2]] << 4) + staticHex[p[3]]; if (from == 0) { continue; } - dataPtr->fromUnicode[from >> 8][from & 0xff] = to; + dataPtr->fromUnicode[from >> 8][from & 0xFF] = to; } } doneParse: Tcl_DStringFree(&lineString); @@ -1938,11 +1970,11 @@ *------------------------------------------------------------------------- */ static Tcl_Encoding LoadEscapeEncoding( - const char *name, /* Name for new encoding. */ + const char *name, /* Name of the new encoding. */ Tcl_Channel chan) /* File containing new encoding. */ { int i; unsigned size; Tcl_DString escapeData; @@ -1959,11 +1991,11 @@ const char **argv; char *line; Tcl_DString lineString; Tcl_DStringInit(&lineString); - if (Tcl_Gets(chan, &lineString) == TCL_IO_FAILURE) { + if (Tcl_Gets(chan, &lineString) < 0) { break; } line = Tcl_DStringValue(&lineString); if (Tcl_SplitList(NULL, line, &argc, &argv) != TCL_OK) { Tcl_DStringFree(&lineString); @@ -2001,17 +2033,17 @@ } est.encodingPtr = e; Tcl_DStringAppend(&escapeData, (char *) &est, sizeof(est)); } } - Tcl_Free((void *)argv); + ckfree(argv); Tcl_DStringFree(&lineString); } - size = sizeof(EscapeEncodingData) - sizeof(EscapeSubTable) + size = TclOffset(EscapeEncodingData, subTables) + Tcl_DStringLength(&escapeData); - dataPtr = Tcl_Alloc(size); + dataPtr = (EscapeEncodingData *)ckalloc(size); dataPtr->initLen = strlen(init); memcpy(dataPtr->init, init, dataPtr->initLen + 1); dataPtr->finalLen = strlen(final); memcpy(dataPtr->final, final, dataPtr->finalLen + 1); dataPtr->numSubTables = @@ -2110,14 +2142,14 @@ } /* *------------------------------------------------------------------------- * - * UtfExtToUtfIntProc -- + * UtfIntToUtfExtProc -- * * Convert from UTF-8 to UTF-8. While converting null-bytes from the - * Tcl's internal representation (0xc0, 0x80) to the official + * Tcl's internal representation (0xC0, 0x80) to the official * representation (0x00). See UtfToUtfProc for details. * * Results: * Returns TCL_OK if conversion was successful. * @@ -2162,11 +2194,11 @@ *------------------------------------------------------------------------- * * UtfExtToUtfIntProc -- * * Convert from UTF-8 to UTF-8 while converting null-bytes from the - * official representation (0x00) to Tcl's internal representation (0xc0, + * official representation (0x00) to Tcl's internal representation (0xC0, * 0x80). See UtfToUtfProc for details. * * Results: * Returns TCL_OK if conversion was successful. * @@ -2251,11 +2283,11 @@ int *dstCharsPtr, /* Filled with the number of characters that * correspond to the bytes stored in the * output buffer. */ int pureNullMode) /* Convert embedded nulls from internal * representation to real null-bytes or vice - * versa. */ + * versa. Also combine or separate surrogate pairs */ { const char *srcStart, *srcEnd, *srcClose; const char *dstStart, *dstEnd; int result, numChars, charLimit = INT_MAX; Tcl_UniChar *chPtr = (Tcl_UniChar *) statePtr; @@ -2267,18 +2299,18 @@ srcStart = src; srcEnd = src + srcLen; srcClose = srcEnd; if ((flags & TCL_ENCODING_END) == 0) { - srcClose -= TCL_UTF_MAX; + srcClose -= 6; } if (flags & TCL_ENCODING_CHAR_LIMIT) { charLimit = *dstCharsPtr; } dstStart = dst; - dstEnd = dst + dstLen - TCL_UTF_MAX; + dstEnd = dst + dstLen - ((pureNullMode == 1) ? 4 : TCL_UTF_MAX); for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) { if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) { /* * If there is more string to follow, this will ensure that the @@ -2293,42 +2325,69 @@ break; } if (UCHAR(*src) < 0x80 && !(UCHAR(*src) == 0 && pureNullMode == 0)) { /* * Copy 7bit characters, but skip null-bytes when we are in input - * mode, so that they get converted to 0xc080. + * mode, so that they get converted to 0xC080. */ *dst++ = *src++; - } else if (pureNullMode == 1 && UCHAR(*src) == 0xc0 && + *chPtr = 0; /* reset surrogate handling */ + } else if (pureNullMode == 1 && UCHAR(*src) == 0xC0 && (src + 1 < srcEnd) && UCHAR(*(src+1)) == 0x80) { /* - * Convert 0xc080 to real nulls when we are in output mode. + * Convert 0xC080 to real nulls when we are in output mode. */ *dst++ = 0; + *chPtr = 0; /* reset surrogate handling */ src += 2; } else if (!Tcl_UtfCharComplete(src, srcEnd - src)) { /* * Always check before using TclUtfToUniChar. Not doing can so * cause it run beyond the end of the buffer! If we happen such an * incomplete char its bytes are made to represent themselves. */ - *chPtr = (unsigned char) *src; + *chPtr = UCHAR(*src); src += 1; dst += Tcl_UniCharToUtf(*chPtr, dst); } else { - int len = TclUtfToUniChar(src, chPtr); + size_t len = TclUtfToUniChar(src, chPtr); + src += len; - dst += Tcl_UniCharToUtf(*chPtr, dst); + if ((*chPtr & ~0x7FF) == 0xD800) { + Tcl_UniChar low; + /* A surrogate character is detected, handle especially */ #if TCL_UTF_MAX <= 4 - if ((*chPtr >= 0xD800) && (len < 3)) { - src += TclUtfToUniChar(src + len, chPtr); + if ((len < 3) && ((src[3 - len] & 0xC0) != 0x80)) { + /* It's invalid. See [ed29806ba] */ + *chPtr = UCHAR(src[-1]); dst += Tcl_UniCharToUtf(*chPtr, dst); + continue; } #endif + low = *chPtr; + len = (src <= srcEnd-3) ? Tcl_UtfToUniChar(src, &low) : 0; + if (((low & ~0x3FF) != 0xDC00) || (*chPtr & 0x400)) { + *dst++ = (char) (((*chPtr >> 12) | 0xE0) & 0xEF); + *dst++ = (char) (((*chPtr >> 6) | 0x80) & 0xBF); + *dst++ = (char) ((*chPtr | 0x80) & 0xBF); + *chPtr = 0; /* reset surrogate handling */ + continue; + } else if ((TCL_UTF_MAX > 3) || (pureNullMode == 1)) { + int full = (((*chPtr & 0x3FF) << 10) | (low & 0x3FF)) + 0x10000; + *dst++ = (char) (((full >> 18) | 0xF0) & 0xF7); + *dst++ = (char) (((full >> 12) | 0x80) & 0xBF); + *dst++ = (char) (((full >> 6) | 0x80) & 0xBF); + *dst++ = (char) ((full | 0x80) & 0xBF); + *chPtr = 0; /* reset surrogate handling */ + src += len; + continue; + } + } + dst += Tcl_UniCharToUtf(*chPtr, dst); } } *srcReadPtr = src - srcStart; *dstWrotePtr = dst - dstStart; @@ -2337,13 +2396,13 @@ } /* *------------------------------------------------------------------------- * - * UniCharToUtfProc -- + * UnicodeToUtfProc -- * - * Convert from Unicode to UTF-8. + * Convert from UTF-16 to UTF-8. * * Results: * Returns TCL_OK if conversion was successful. * * Side effects: @@ -2351,12 +2410,12 @@ * *------------------------------------------------------------------------- */ static int -UniCharToUtfProc( - ClientData clientData, /* Not used. */ +UnicodeToUtfProc( + ClientData clientData, /* != NULL means LE, == NUL means BE */ const char *src, /* Source string in Unicode. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ Tcl_EncodingState *statePtr,/* Place for conversion routine to store state * information used during a piecewise @@ -2386,14 +2445,20 @@ if (flags & TCL_ENCODING_CHAR_LIMIT) { charLimit = *dstCharsPtr; } result = TCL_OK; - if ((srcLen % sizeof(unsigned short)) != 0) { + + /* check alignment with utf-16 (2 == sizeof(UTF-16)) */ + if ((srcLen % 2) != 0) { + result = TCL_CONVERT_MULTIBYTE; + srcLen--; + } + /* If last code point is a high surrogate, we cannot handle that yet */ + if ((srcLen >= 2) && ((src[srcLen - (clientData?1:2)] & 0xFC) == 0xD8)) { result = TCL_CONVERT_MULTIBYTE; - srcLen /= sizeof(unsigned short); - srcLen *= sizeof(unsigned short); + srcLen-= 2; } srcStart = src; srcEnd = src + srcLen; @@ -2404,16 +2469,19 @@ if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; } + if (clientData) { + ch = (src[1] & 0xFF) << 8 | (src[0] & 0xFF); + } else { + ch = (src[0] & 0xFF) << 8 | (src[1] & 0xFF); + } /* * Special case for 1-byte utf chars for speed. Make sure we work with * unsigned short-size data. */ - - ch = *(unsigned short *)src; if (ch && ch < 0x80) { *dst++ = (ch & 0xFF); } else { dst += Tcl_UniCharToUtf(ch, dst); } @@ -2427,13 +2495,13 @@ } /* *------------------------------------------------------------------------- * - * UtfToUniCharProc -- + * UtfToUnicodeProc -- * - * Convert from UTF-8 to Unicode. + * Convert from UTF-8 to UTF-16. * * Results: * Returns TCL_OK if conversion was successful. * * Side effects: @@ -2441,13 +2509,12 @@ * *------------------------------------------------------------------------- */ static int -UtfToUniCharProc( - ClientData clientData, /* TableEncodingData that specifies - * encoding. */ +UtfToUnicodeProc( + ClientData clientData, /* != NULL means LE, == NUL means BE */ const char *src, /* Source string in UTF-8. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ Tcl_EncodingState *statePtr,/* Place for conversion routine to store state * information used during a piecewise @@ -2502,46 +2569,41 @@ result = TCL_CONVERT_NOSPACE; break; } src += TclUtfToUniChar(src, chPtr); - /* - * Need to handle this in a way that won't cause misalignment by - * casting dst to a Tcl_UniChar. [Bug 1122671] - */ - -#ifdef WORDS_BIGENDIAN -#if TCL_UTF_MAX > 4 - if (*chPtr <= 0xFFFF) { - *dst++ = (*chPtr >> 8); - *dst++ = (*chPtr & 0xFF); - } else { - *dst++ = ((*chPtr & 0x3) >> 8) | 0xDC; - *dst++ = (*chPtr & 0xFF); - *dst++ = (((*chPtr - 0x10000) >> 18) & 0x3) | 0xD8; - *dst++ = (((*chPtr - 0x10000) >> 10) & 0xFF); - } -#else - *dst++ = (*chPtr >> 8); - *dst++ = (*chPtr & 0xFF); -#endif -#else -#if TCL_UTF_MAX > 4 - if (*chPtr <= 0xFFFF) { - *dst++ = (*chPtr & 0xFF); - *dst++ = (*chPtr >> 8); - } else { - *dst++ = (((*chPtr - 0x10000) >> 10) & 0xFF); - *dst++ = (((*chPtr - 0x10000) >> 18) & 0x3) | 0xD8; - *dst++ = (*chPtr & 0xFF); - *dst++ = ((*chPtr & 0x3) >> 8) | 0xDC; - } -#else - *dst++ = (*chPtr & 0xFF); - *dst++ = (*chPtr >> 8); -#endif -#endif + if (clientData) { +#if TCL_UTF_MAX > 4 + if (*chPtr <= 0xFFFF) { + *dst++ = (*chPtr & 0xFF); + *dst++ = (*chPtr >> 8); + } else { + *dst++ = (((*chPtr - 0x10000) >> 10) & 0xFF); + *dst++ = (((*chPtr - 0x10000) >> 18) & 0x3) | 0xD8; + *dst++ = (*chPtr & 0xFF); + *dst++ = ((*chPtr & 0x3) >> 8) | 0xDC; + } +#else + *dst++ = (*chPtr & 0xFF); + *dst++ = (*chPtr >> 8); +#endif + } else { +#if TCL_UTF_MAX > 4 + if (*chPtr <= 0xFFFF) { + *dst++ = (*chPtr >> 8); + *dst++ = (*chPtr & 0xFF); + } else { + *dst++ = ((*chPtr & 0x3) >> 8) | 0xDC; + *dst++ = (*chPtr & 0xFF); + *dst++ = (((*chPtr - 0x10000) >> 18) & 0x3) | 0xD8; + *dst++ = (((*chPtr - 0x10000) >> 10) & 0xFF); + } +#else + *dst++ = (*chPtr >> 8); + *dst++ = (*chPtr & 0xFF); +#endif + } } *srcReadPtr = src - srcStart; *dstWrotePtr = dst - dstStart; *dstCharsPtr = numChars; return result; @@ -2596,11 +2658,11 @@ const char *dstEnd, *dstStart, *prefixBytes; int result, byte, numChars, charLimit = INT_MAX; Tcl_UniChar ch = 0; const unsigned short *const *toUnicode; const unsigned short *pageZero; - TableEncodingData *dataPtr = clientData; + TableEncodingData *dataPtr = (TableEncodingData *)clientData; if (flags & TCL_ENCODING_CHAR_LIMIT) { charLimit = *dstCharsPtr; } srcStart = src; @@ -2707,11 +2769,11 @@ { const char *srcStart, *srcEnd, *srcClose; const char *dstStart, *dstEnd, *prefixBytes; Tcl_UniChar ch = 0; int result, len, word, numChars; - TableEncodingData *dataPtr = clientData; + TableEncodingData *dataPtr = (TableEncodingData *)clientData; const unsigned short *const *fromUnicode; result = TCL_OK; prefixBytes = dataPtr->prefixBytes; @@ -2738,24 +2800,20 @@ break; } len = TclUtfToUniChar(src, &ch); #if TCL_UTF_MAX > 4 - /* - * This prevents a crash condition. More evaluation is required for - * full support of int Tcl_UniChar. [Bug 1004065] - */ - - if (ch & 0xffff0000) { + /* Unicode chars > +U0FFFF cannot be represented in any table encoding */ + if (ch & 0xFFFF0000) { word = 0; } else -#else +#elif TCL_UTF_MAX == 4 if (!len) { word = 0; } else #endif - word = fromUnicode[(ch >> 8)][ch & 0xff]; + word = fromUnicode[(ch >> 8)][ch & 0xFF]; if ((word == 0) && (ch != 0)) { if (flags & TCL_ENCODING_STOPONERROR) { result = TCL_CONVERT_UNKNOWN; break; @@ -2914,13 +2972,12 @@ * correspond to the bytes stored in the * output buffer. */ { const char *srcStart, *srcEnd, *srcClose; const char *dstStart, *dstEnd; - int result, numChars; - - result = TCL_OK; + int result = TCL_OK, numChars; + Tcl_UniChar ch = 0; srcStart = src; srcEnd = src + srcLen; srcClose = srcEnd; if ((flags & TCL_ENCODING_END) == 0) { @@ -2929,11 +2986,10 @@ dstStart = dst; dstEnd = dst + dstLen - 1; for (numChars = 0; src < srcEnd; numChars++) { - Tcl_UniChar ch = 0; int len; if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) { /* * If there is more string to follow, this will ensure that the @@ -2947,20 +3003,20 @@ /* * Check for illegal characters. */ - if (ch > 0xff -#if TCL_UTF_MAX <= 4 + if (ch > 0xFF +#if TCL_UTF_MAX == 4 || ((ch >= 0xD800) && (len < 3)) #endif ) { if (flags & TCL_ENCODING_STOPONERROR) { result = TCL_CONVERT_UNKNOWN; break; } -#if TCL_UTF_MAX <= 4 +#if TCL_UTF_MAX == 4 if ((ch >= 0xD800) && (len < 3)) len = 4; #endif /* * Plunge on, using '?' as a fallback character. */ @@ -3002,21 +3058,21 @@ static void TableFreeProc( ClientData clientData) /* TableEncodingData that specifies * encoding. */ { - TableEncodingData *dataPtr = clientData; + TableEncodingData *dataPtr = (TableEncodingData *)clientData; /* * Make sure we aren't freeing twice on shutdown. [Bug 219314] */ - Tcl_Free(dataPtr->toUnicode); + ckfree(dataPtr->toUnicode); dataPtr->toUnicode = NULL; - Tcl_Free(dataPtr->fromUnicode); + ckfree(dataPtr->fromUnicode); dataPtr->fromUnicode = NULL; - Tcl_Free(dataPtr); + ckfree(dataPtr); } /* *------------------------------------------------------------------------- * @@ -3060,11 +3116,11 @@ * the conversion. */ int *dstCharsPtr) /* Filled with the number of characters that * correspond to the bytes stored in the * output buffer. */ { - EscapeEncodingData *dataPtr = clientData; + EscapeEncodingData *dataPtr = (EscapeEncodingData *)clientData; const char *prefixBytes, *tablePrefixBytes, *srcStart, *srcEnd; const unsigned short *const *tableToUnicode; const Encoding *encodingPtr; int state, result, numChars, charLimit = INT_MAX; const char *dstStart, *dstEnd; @@ -3071,12 +3127,12 @@ if (flags & TCL_ENCODING_CHAR_LIMIT) { charLimit = *dstCharsPtr; } result = TCL_OK; - tablePrefixBytes = NULL; /* lint. */ - tableToUnicode = NULL; /* lint. */ + tablePrefixBytes = NULL; + tableToUnicode = NULL; prefixBytes = dataPtr->prefixBytes; encodingPtr = NULL; srcStart = src; srcEnd = src + srcLen; @@ -3196,11 +3252,11 @@ if (encodingPtr == NULL) { TableEncodingData *tableDataPtr; encodingPtr = GetTableEncoding(dataPtr, state); - tableDataPtr = encodingPtr->clientData; + tableDataPtr = (TableEncodingData *)encodingPtr->clientData; tablePrefixBytes = tableDataPtr->prefixBytes; tableToUnicode = (const unsigned short *const*) tableDataPtr->toUnicode; } @@ -3274,18 +3330,19 @@ * the conversion. */ int *dstCharsPtr) /* Filled with the number of characters that * correspond to the bytes stored in the * output buffer. */ { - EscapeEncodingData *dataPtr = clientData; + EscapeEncodingData *dataPtr = (EscapeEncodingData *)clientData; const Encoding *encodingPtr; const char *srcStart, *srcEnd, *srcClose; const char *dstStart, *dstEnd; int state, result, numChars; const TableEncodingData *tableDataPtr; const char *tablePrefixBytes; const unsigned short *const *tableFromUnicode; + Tcl_UniChar ch = 0; result = TCL_OK; srcStart = src; srcEnd = src + srcLen; @@ -3314,19 +3371,18 @@ } else { state = PTR2INT(*statePtr); } encodingPtr = GetTableEncoding(dataPtr, state); - tableDataPtr = encodingPtr->clientData; + tableDataPtr = (const TableEncodingData *)encodingPtr->clientData; tablePrefixBytes = tableDataPtr->prefixBytes; tableFromUnicode = (const unsigned short *const *) tableDataPtr->fromUnicode; for (numChars = 0; src < srcEnd; numChars++) { unsigned len; int word; - Tcl_UniChar ch = 0; if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) { /* * If there is more string to follow, this will ensure that the * last UTF-8 character in the source buffer hasn't been cut off. @@ -3334,21 +3390,21 @@ result = TCL_CONVERT_MULTIBYTE; break; } len = TclUtfToUniChar(src, &ch); - word = tableFromUnicode[(ch >> 8)][ch & 0xff]; + word = tableFromUnicode[(ch >> 8)][ch & 0xFF]; if ((word == 0) && (ch != 0)) { int oldState; const EscapeSubTable *subTablePtr; oldState = state; for (state = 0; state < dataPtr->numSubTables; state++) { encodingPtr = GetTableEncoding(dataPtr, state); - tableDataPtr = encodingPtr->clientData; - word = tableDataPtr->fromUnicode[(ch >> 8)][ch & 0xff]; + tableDataPtr = (const TableEncodingData *)encodingPtr->clientData; + word = tableDataPtr->fromUnicode[(ch >> 8)][ch & 0xFF]; if (word != 0) { break; } } @@ -3357,11 +3413,11 @@ if (flags & TCL_ENCODING_STOPONERROR) { result = TCL_CONVERT_UNKNOWN; break; } encodingPtr = GetTableEncoding(dataPtr, state); - tableDataPtr = encodingPtr->clientData; + tableDataPtr = (const TableEncodingData *)encodingPtr->clientData; word = tableDataPtr->fallback; } tablePrefixBytes = (const char *) tableDataPtr->prefixBytes; tableFromUnicode = (const unsigned short *const *) @@ -3385,11 +3441,12 @@ state = oldState; result = TCL_CONVERT_NOSPACE; break; } - memcpy(dst, subTablePtr->sequence, subTablePtr->sequenceLen); + memcpy(dst, subTablePtr->sequence, + subTablePtr->sequenceLen); dst += subTablePtr->sequenceLen; } } if (tablePrefixBytes[(word >> 8)] != 0) { @@ -3446,28 +3503,27 @@ /* *--------------------------------------------------------------------------- * * EscapeFreeProc -- * - * This function is invoked when an EscapeEncodingData encoding is - * deleted. It deletes the memory used by the encoding. + * Frees resources used by the encoding. * * Results: * None. * * Side effects: - * Memory freed. + * Memory is freed. * *--------------------------------------------------------------------------- */ static void EscapeFreeProc( ClientData clientData) /* EscapeEncodingData that specifies * encoding. */ { - EscapeEncodingData *dataPtr = clientData; + EscapeEncodingData *dataPtr = (EscapeEncodingData *)clientData; EscapeSubTable *subTablePtr; int i; if (dataPtr == NULL) { return; @@ -3490,11 +3546,11 @@ FreeEncoding((Tcl_Encoding) subTablePtr->encodingPtr); subTablePtr->encodingPtr = NULL; subTablePtr++; } } - Tcl_Free(dataPtr); + ckfree(dataPtr); } /* *--------------------------------------------------------------------------- * @@ -3591,15 +3647,15 @@ */ static void InitializeEncodingSearchPath( char **valuePtr, - size_t *lengthPtr, + int *lengthPtr, Tcl_Encoding *encodingPtr) { const char *bytes; - int i, numDirs; + int i, numDirs, numBytes; Tcl_Obj *libPathObj, *encodingObj, *searchPathObj; TclNewLiteralStringObj(encodingObj, "encoding"); TclNewObj(searchPathObj); Tcl_IncrRefCount(encodingObj); @@ -3625,13 +3681,15 @@ Tcl_DecrRefCount(encodingObj); *encodingPtr = libraryPath.encoding; if (*encodingPtr) { ((Encoding *)(*encodingPtr))->refCount++; } - bytes = TclGetStringFromObj(searchPathObj, lengthPtr); - *valuePtr = Tcl_Alloc(*lengthPtr + 1); - memcpy(*valuePtr, bytes, *lengthPtr + 1); + bytes = Tcl_GetStringFromObj(searchPathObj, &numBytes); + + *lengthPtr = numBytes; + *valuePtr = (char *)ckalloc(numBytes + 1); + memcpy(*valuePtr, bytes, numBytes + 1); Tcl_DecrRefCount(searchPathObj); } /* * Local Variables: Index: generic/tclEnsemble.c ================================================================== --- generic/tclEnsemble.c +++ generic/tclEnsemble.c @@ -19,10 +19,12 @@ static inline Tcl_Obj * NewNsObj(Tcl_Namespace *namespacePtr); static inline int EnsembleUnknownCallback(Tcl_Interp *interp, EnsembleConfig *ensemblePtr, int objc, Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr); +static int NsEnsembleImplementationCmd(ClientData clientData, + Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int NsEnsembleImplementationCmdNR(ClientData clientData, Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static void BuildEnsembleConfig(EnsembleConfig *ensemblePtr); static int NsEnsembleStringOrder(const void *strPtr1, const void *strPtr2); @@ -82,51 +84,38 @@ DupEnsembleCmdRep, /* dupIntRepProc */ NULL, /* updateStringProc */ NULL /* setFromAnyProc */ }; -#define ECRSetIntRep(objPtr, ecRepPtr) \ - do { \ - Tcl_ObjIntRep ir; \ - ir.twoPtrValue.ptr1 = (ecRepPtr); \ - ir.twoPtrValue.ptr2 = NULL; \ - Tcl_StoreIntRep((objPtr), &ensembleCmdType, &ir); \ - } while (0) - -#define ECRGetIntRep(objPtr, ecRepPtr) \ - do { \ - const Tcl_ObjIntRep *irPtr; \ - irPtr = TclFetchIntRep((objPtr), &ensembleCmdType); \ - (ecRepPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ - } while (0) - /* - * The internal rep for caching ensemble subcommand lookups and spelling - * corrections. + * The internal rep for caching ensemble subcommand lookups and + * spell corrections. */ typedef struct { - size_t epoch; /* Used to confirm when the data in this + int epoch; /* Used to confirm when the data in this * really structure matches up with the * ensemble. */ Command *token; /* Reference to the command for which this * structure is a cache of the resolution. */ Tcl_Obj *fix; /* Corrected spelling, if needed. */ - Tcl_HashEntry *hPtr; /* Direct link to entry in the subcommand hash - * table. */ + Tcl_HashEntry *hPtr; /* Direct link to entry in the subcommand + * hash table. */ } EnsembleCmdRep; + static inline Tcl_Obj * NewNsObj( Tcl_Namespace *namespacePtr) { - register Namespace *nsPtr = (Namespace *) namespacePtr; + Namespace *nsPtr = (Namespace *) namespacePtr; if (namespacePtr == TclGetGlobalNamespace(nsPtr->interp)) { return Tcl_NewStringObj("::", 2); + } else { + return Tcl_NewStringObj(nsPtr->fullName, -1); } - return Tcl_NewStringObj(nsPtr->fullName, -1); } /* *---------------------------------------------------------------------- * @@ -156,11 +145,11 @@ int objc, Tcl_Obj *const objv[]) { Tcl_Namespace *namespacePtr; Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp), *cxtPtr, - *foundNsPtr, *altFoundNsPtr, *actualCxtPtr; + *foundNsPtr, *altFoundNsPtr, *actualCxtPtr; Tcl_Command token; Tcl_DictSearch search; Tcl_Obj *listObj; const char *simpleName; int index, done; @@ -311,12 +300,11 @@ patchedDict = Tcl_DuplicateObj(objv[1]); } Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj, newList); } - Tcl_DictObjNext(&search, &subcmdWordsObj, &listObj, - &done); + Tcl_DictObjNext(&search, &subcmdWordsObj,&listObj, &done); } while (!done); if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } @@ -346,23 +334,23 @@ continue; } } TclGetNamespaceForQualName(interp, name, cxtPtr, - TCL_CREATE_NS_IF_UNKNOWN, &foundNsPtr, &altFoundNsPtr, - &actualCxtPtr, &simpleName); + TCL_CREATE_NS_IF_UNKNOWN, &foundNsPtr, &altFoundNsPtr, &actualCxtPtr, + &simpleName); /* * Create the ensemble. Note that this might delete another ensemble * linked to the same namespace, so we must be careful. However, we * should be OK because we only link the namespace into the list once * we've created it (and after any deletions have occurred.) */ token = TclCreateEnsembleInNs(interp, simpleName, - (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, - (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0)); + (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, + (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0)); Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj); Tcl_SetEnsembleMappingDict(interp, token, mapObj); Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj); Tcl_SetEnsembleParameterList(interp, token, paramObj); @@ -586,12 +574,11 @@ if (nsPtr->parentPtr) { Tcl_AppendStringsToObj(newCmd, "::", NULL); } Tcl_AppendObjToObj(newCmd, listv[0]); - Tcl_ListObjReplace(NULL, newList, 0, 1, 1, - &newCmd); + Tcl_ListObjReplace(NULL, newList, 0,1, 1,&newCmd); if (patchedDict == NULL) { patchedDict = Tcl_DuplicateObj(objv[1]); } Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj, newList); @@ -661,28 +648,30 @@ */ Tcl_Command TclCreateEnsembleInNs( Tcl_Interp *interp, - const char *name, /* Simple name of command to create (no - * namespace components). */ - Tcl_Namespace *nameNsPtr, /* Name of namespace to create the command - * in. */ - Tcl_Namespace *ensembleNsPtr, - /* Name of the namespace for the ensemble. */ - int flags) + + const char *name, /* Simple name of command to create (no */ + /* namespace components). */ + Tcl_Namespace /* Name of namespace to create the command in. */ + *nameNsPtr, + Tcl_Namespace + *ensembleNsPtr, /* Name of the namespace for the ensemble. */ + int flags + ) { Namespace *nsPtr = (Namespace *) ensembleNsPtr; EnsembleConfig *ensemblePtr; Tcl_Command token; - ensemblePtr = Tcl_Alloc(sizeof(EnsembleConfig)); + ensemblePtr = ckalloc(sizeof(EnsembleConfig)); token = TclNRCreateCommandInNs(interp, name, - (Tcl_Namespace *) nameNsPtr, TclEnsembleImplementationCmd, - NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig); + (Tcl_Namespace *) nameNsPtr, NsEnsembleImplementationCmd, + NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig); if (token == NULL) { - Tcl_Free(ensemblePtr); + ckfree(ensemblePtr); return NULL; } ensemblePtr->nsPtr = nsPtr; ensemblePtr->epoch = 0; @@ -710,19 +699,22 @@ if (flags & ENSEMBLE_COMPILE) { ((Command *) ensemblePtr->token)->compileProc = TclCompileEnsemble; } return ensemblePtr->token; + } - + + /* *---------------------------------------------------------------------- * * Tcl_CreateEnsemble * - * Create a simple ensemble attached to the given namespace. Deprecated - * (internally) by TclCreateEnsembleInNs. + * Create a simple ensemble attached to the given namespace. + * + * Deprecated by TclCreateEnsembleInNs. * * Value * * The token for the command created. * @@ -738,23 +730,24 @@ Tcl_Interp *interp, const char *name, Tcl_Namespace *namespacePtr, int flags) { - Namespace *nsPtr = (Namespace *) namespacePtr, *foundNsPtr, *altNsPtr, - *actualNsPtr; + Namespace *nsPtr = (Namespace *)namespacePtr, *foundNsPtr, *altNsPtr, + *actualNsPtr; const char * simpleName; if (nsPtr == NULL) { nsPtr = (Namespace *) TclGetCurrentNamespace(interp); } TclGetNamespaceForQualName(interp, name, nsPtr, TCL_CREATE_NS_IF_UNKNOWN, - &foundNsPtr, &altNsPtr, &actualNsPtr, &simpleName); + &foundNsPtr, &altNsPtr, &actualNsPtr, &simpleName); return TclCreateEnsembleInNs(interp, simpleName, - (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, flags); + (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, flags); } + /* *---------------------------------------------------------------------- * * Tcl_SetEnsembleSubcommandList -- @@ -779,11 +772,11 @@ { Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; Tcl_Obj *oldList; - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); return TCL_ERROR; } @@ -855,11 +848,11 @@ Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; Tcl_Obj *oldList; int length; - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); return TCL_ERROR; } @@ -931,11 +924,11 @@ { Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; Tcl_Obj *oldDict; - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); return TCL_ERROR; } @@ -1030,11 +1023,11 @@ { Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; Tcl_Obj *oldList; - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); return TCL_ERROR; } @@ -1096,11 +1089,11 @@ { Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; int wasCompiled; - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); return TCL_ERROR; } @@ -1172,11 +1165,11 @@ Tcl_Obj **subcmdListPtr) { Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); } @@ -1214,11 +1207,11 @@ Tcl_Obj **paramListPtr) { Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); } @@ -1256,11 +1249,11 @@ Tcl_Obj **mapDictPtr) { Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); } @@ -1297,11 +1290,11 @@ Tcl_Obj **unknownListPtr) { Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); } @@ -1338,11 +1331,11 @@ int *flagsPtr) { Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); } @@ -1379,11 +1372,11 @@ Tcl_Namespace **namespacePtrPtr) { Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); } @@ -1429,20 +1422,19 @@ Tcl_FindCommand(interp, TclGetString(cmdNameObj), NULL, flags); if (cmdPtr == NULL) { return NULL; } - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { /* * Reuse existing infrastructure for following import link chains * rather than duplicating it. */ cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); - if (cmdPtr == NULL - || cmdPtr->objProc != TclEnsembleImplementationCmd) { + if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd){ if (flags & TCL_LEAVE_ERR_MSG) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" is not an ensemble command", TclGetString(cmdNameObj))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE", @@ -1476,15 +1468,15 @@ Tcl_IsEnsemble( Tcl_Command token) { Command *cmdPtr = (Command *) token; - if (cmdPtr->objProc == TclEnsembleImplementationCmd) { + if (cmdPtr->objProc == NsEnsembleImplementationCmd) { return 1; } cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); - if (cmdPtr == NULL || cmdPtr->objProc != TclEnsembleImplementationCmd) { + if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) { return 0; } return 1; } @@ -1622,11 +1614,11 @@ Tcl_NRCreateCommand(interp, "___tmp", map[i].proc, map[i].nreProc, map[i].clientData, NULL); Tcl_DStringSetLength(&hiddenBuf, hiddenLen); if (Tcl_HideCommand(interp, "___tmp", Tcl_DStringAppend(&hiddenBuf, map[i].name, -1))) { - Tcl_Panic("%s", Tcl_GetStringResult(interp)); + Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); } } else { /* * Not hidden, so just create it. Yay! */ @@ -1643,19 +1635,19 @@ } Tcl_DStringFree(&buf); Tcl_DStringFree(&hiddenBuf); if (nameParts != NULL) { - Tcl_Free((void *)nameParts); + ckfree((char *) nameParts); } return ensemble; } /* *---------------------------------------------------------------------- * - * TclEnsembleImplementationCmd -- + * NsEnsembleImplementationCmd -- * * Implements an ensemble of commands (being those exported by a * namespace other than the global namespace) as a command with the same * (short) name as the namespace in the parent namespace. * @@ -1670,12 +1662,12 @@ * placed in the interpreter's result. * *---------------------------------------------------------------------- */ -int -TclEnsembleImplementationCmd( +static int +NsEnsembleImplementationCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { @@ -1699,20 +1691,20 @@ * specified but not yet cached command * names. */ int reparseCount = 0; /* Number of reparses. */ Tcl_Obj *errorObj; /* Used for building error messages. */ Tcl_Obj *subObj; - size_t subIdx; + int subIdx; /* * Must recheck objc, since numParameters might have changed. Cf. test * namespace-53.9. */ restartEnsembleParse: subIdx = 1 + ensemblePtr->numParameters; - if ((size_t)objc < subIdx + 1) { + if (objc < subIdx + 1) { /* * We don't have a subcommand argument. Make error message. */ Tcl_DString buf; /* Message being built */ @@ -1755,14 +1747,14 @@ * Table of subcommands is still valid; therefore there might be a * valid cache of discovered information which we can reuse. Do the * check here, and if we're still valid, we can jump straight to the * part where we do the invocation of the subcommand. */ - EnsembleCmdRep *ensembleCmd; - ECRGetIntRep(subObj, ensembleCmd); - if (ensembleCmd) { + if (subObj->typePtr==&ensembleCmdType){ + EnsembleCmdRep *ensembleCmd = subObj->internalRep.twoPtrValue.ptr1; + if (ensembleCmd->epoch == ensemblePtr->epoch && ensembleCmd->token == (Command *)ensemblePtr->token) { prefixObj = Tcl_GetHashValue(ensembleCmd->hPtr); Tcl_IncrRefCount(prefixObj); if (ensembleCmd->fix) { @@ -1805,19 +1797,19 @@ const char *subcmdName; /* Name of the subcommand, or unique prefix of * it (will be an error for a non-unique * prefix). */ char *fullName = NULL; /* Full name of the subcommand. */ - size_t stringLength, i; - size_t tableLength = ensemblePtr->subcommandTable.numEntries; + int stringLength, i; + int tableLength = ensemblePtr->subcommandTable.numEntries; Tcl_Obj *fix; - subcmdName = TclGetStringFromObj(subObj, &stringLength); + subcmdName = Tcl_GetStringFromObj(subObj, &stringLength); for (i=0 ; isubcommandArrayPtr[i], - stringLength); + (unsigned) stringLength); if (cmp == 0) { if (fullName != NULL) { /* * Since there's never the exact-match case to worry about @@ -1970,11 +1962,11 @@ (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? " or ambiguous" : ""), TclGetString(subObj)); if (ensemblePtr->subcommandTable.numEntries == 1) { Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[0], -1); } else { - size_t i; + int i; for (i=0 ; isubcommandTable.numEntries-1 ; i++) { Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[i], -1); Tcl_AppendToObj(errorObj, ", ", 2); } @@ -2015,12 +2007,12 @@ */ int TclInitRewriteEnsemble( Tcl_Interp *interp, - size_t numRemoved, - size_t numInserted, + int numRemoved, + int numInserted, Tcl_Obj *const *objv) { Interp *iPtr = (Interp *) interp; int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL); @@ -2028,11 +2020,11 @@ if (isRootEnsemble) { iPtr->ensembleRewrite.sourceObjs = objv; iPtr->ensembleRewrite.numRemovedObjs = numRemoved; iPtr->ensembleRewrite.numInsertedObjs = numInserted; } else { - size_t numIns = iPtr->ensembleRewrite.numInsertedObjs; + int numIns = iPtr->ensembleRewrite.numInsertedObjs; if (numIns < numRemoved) { iPtr->ensembleRewrite.numRemovedObjs += numRemoved - numIns; iPtr->ensembleRewrite.numInsertedObjs = numInserted; } else { @@ -2098,29 +2090,29 @@ int result) { Tcl_Obj **tmp = (Tcl_Obj **) data[0]; Tcl_Obj **store = (Tcl_Obj **) data[1]; - Tcl_Free(store); - Tcl_Free(tmp); + ckfree(store); + ckfree(tmp); return result; } void TclSpellFix( Tcl_Interp *interp, Tcl_Obj *const *objv, int objc, - size_t badIdx, + int badIdx, Tcl_Obj *bad, Tcl_Obj *fix) { Interp *iPtr = (Interp *) interp; Tcl_Obj *const *search; Tcl_Obj **store; - size_t idx; - size_t size; + int idx; + int size; if (iPtr->ensembleRewrite.sourceObjs == NULL) { iPtr->ensembleRewrite.sourceObjs = objv; iPtr->ensembleRewrite.numRemovedObjs = 0; iPtr->ensembleRewrite.numInsertedObjs = 0; @@ -2129,11 +2121,11 @@ /* * Compute the valid length of the ensemble root. */ size = iPtr->ensembleRewrite.numRemovedObjs + objc - - iPtr->ensembleRewrite.numInsertedObjs; + - iPtr->ensembleRewrite.numInsertedObjs; search = iPtr->ensembleRewrite.sourceObjs; if (search[0] == NULL) { /* * Awful casting abuse here! @@ -2174,13 +2166,13 @@ search = iPtr->ensembleRewrite.sourceObjs; if (search[0] == NULL) { store = (Tcl_Obj **) search[2]; } else { - Tcl_Obj **tmp = Tcl_Alloc(3 * sizeof(Tcl_Obj *)); + Tcl_Obj **tmp = ckalloc(3 * sizeof(Tcl_Obj *)); - store = Tcl_Alloc(size * sizeof(Tcl_Obj *)); + store = ckalloc(size * sizeof(Tcl_Obj *)); memcpy(store, iPtr->ensembleRewrite.sourceObjs, size * sizeof(Tcl_Obj *)); /* * Awful casting abuse here! Note that the NULL in the first element @@ -2402,14 +2394,14 @@ Tcl_Obj *objPtr, EnsembleConfig *ensemblePtr, Tcl_HashEntry *hPtr, Tcl_Obj *fix) { - register EnsembleCmdRep *ensembleCmd; + EnsembleCmdRep *ensembleCmd; - ECRGetIntRep(objPtr, ensembleCmd); - if (ensembleCmd) { + if (objPtr->typePtr == &ensembleCmdType) { + ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; TclCleanupCommandMacro(ensembleCmd->token); if (ensembleCmd->fix) { Tcl_DecrRefCount(ensembleCmd->fix); } } else { @@ -2416,12 +2408,14 @@ /* * Kill the old internal rep, and replace it with a brand new one of * our own. */ - ensembleCmd = Tcl_Alloc(sizeof(EnsembleCmdRep)); - ECRSetIntRep(objPtr, ensembleCmd); + TclFreeIntRep(objPtr); + ensembleCmd = ckalloc(sizeof(EnsembleCmdRep)); + objPtr->internalRep.twoPtrValue.ptr1 = ensembleCmd; + objPtr->typePtr = &ensembleCmdType; } /* * Populate the internal rep. */ @@ -2469,11 +2463,11 @@ while (hPtr != NULL) { Tcl_Obj *prefixObj = Tcl_GetHashValue(hPtr); Tcl_DecrRefCount(prefixObj); hPtr = Tcl_NextHashEntry(&search); } - Tcl_Free(ensemblePtr->subcommandArrayPtr); + ckfree((char *) ensemblePtr->subcommandArrayPtr); } Tcl_DeleteHashTable(hash); } static void @@ -2543,14 +2537,13 @@ *---------------------------------------------------------------------- * * BuildEnsembleConfig -- * * Create the internal data structures that describe how an ensemble - * looks, being a hash mapping from the full command name to the Tcl list + * looks, being a hash mapping from the simple command name to the Tcl list * that describes the implementation prefix words, and a sorted array of - * all the full command names to allow for reasonably efficient - * unambiguous prefix handling. + * the names to allow for reasonably efficient unambiguous prefix handling. * * Results: * None. * * Side effects: @@ -2566,12 +2559,11 @@ EnsembleConfig *ensemblePtr) { Tcl_HashSearch search; /* Used for scanning the set of commands in * the namespace that backs up this * ensemble. */ - size_t i, j; - int isNew; + int i, j, isNew; Tcl_HashTable *hash = &ensemblePtr->subcommandTable; Tcl_HashEntry *hPtr; Tcl_Obj *mapDict = ensemblePtr->subcommandDict; Tcl_Obj *subList = ensemblePtr->subcmdList; @@ -2593,11 +2585,11 @@ /* * Strange case where explicit list of subcommands is same value * as the dict mapping to targets. */ - for (i = 0; i < (size_t)subc; i += 2) { + for (i = 0; i < subc; i += 2) { name = TclGetString(subv[i]); hPtr = Tcl_CreateHashEntry(hash, name, &isNew); if (!isNew) { cmdObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr); Tcl_DecrRefCount(cmdObj); @@ -2613,25 +2605,20 @@ Tcl_SetHashValue(hPtr, cmdPrefixObj); Tcl_IncrRefCount(cmdPrefixObj); } } } else { - /* - * Usual case where we can freely act on the list and dict. - */ + /* Usual case where we can freely act on the list and dict. */ - for (i = 0; i < (size_t)subc; i++) { + for (i = 0; i < subc; i++) { name = TclGetString(subv[i]); hPtr = Tcl_CreateHashEntry(hash, name, &isNew); if (!isNew) { continue; } - /* - * Lookup target in the dictionary. - */ - + /* Lookup target in the dictionary */ if (mapDict) { Tcl_DictObjGet(NULL, mapDict, subv[i], &target); if (target) { Tcl_SetHashValue(hPtr, target); Tcl_IncrRefCount(target); @@ -2639,15 +2626,14 @@ } } /* * target was not in the dictionary so map onto the namespace. - * Note in this case that we do not guarantee that the command - * is actually there; that is the programmer's responsibility - * (or [::unknown] of course). + * Note in this case that we do not guarantee that the + * command is actually there; that is the programmer's + * responsibility (or [::unknown] of course). */ - cmdObj = Tcl_NewStringObj(name, -1); cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); Tcl_SetHashValue(hPtr, cmdPrefixObj); Tcl_IncrRefCount(cmdPrefixObj); } @@ -2739,11 +2725,11 @@ * directly to save a copy, since any time we change the array we change * the hash too, and vice versa) and running quicksort over the array. */ ensemblePtr->subcommandArrayPtr = - Tcl_Alloc(sizeof(char *) * hash->numEntries); + ckalloc(sizeof(char *) * hash->numEntries); /* * Fill array from both ends as this makes us less likely to end up with * performance problems in qsort(), which is good. Note that doing this * makes this code much more opaque, but the naive alternatve: @@ -2772,11 +2758,11 @@ } ensemblePtr->subcommandArrayPtr[--j] = Tcl_GetHashKey(hash, hPtr); hPtr = Tcl_NextHashEntry(&search); } if (hash->numEntries > 1) { - qsort(ensemblePtr->subcommandArrayPtr, hash->numEntries, + qsort(ensemblePtr->subcommandArrayPtr, (unsigned) hash->numEntries, sizeof(char *), NsEnsembleStringOrder); } } /* @@ -2826,18 +2812,18 @@ static void FreeEnsembleCmdRep( Tcl_Obj *objPtr) { - EnsembleCmdRep *ensembleCmd; + EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; - ECRGetIntRep(objPtr, ensembleCmd); TclCleanupCommandMacro(ensembleCmd->token); if (ensembleCmd->fix) { Tcl_DecrRefCount(ensembleCmd->fix); } - Tcl_Free(ensembleCmd); + ckfree(ensembleCmd); + objPtr->typePtr = NULL; } /* *---------------------------------------------------------------------- * @@ -2859,16 +2845,15 @@ static void DupEnsembleCmdRep( Tcl_Obj *objPtr, Tcl_Obj *copyPtr) { - EnsembleCmdRep *ensembleCmd; - EnsembleCmdRep *ensembleCopy = Tcl_Alloc(sizeof(EnsembleCmdRep)); + EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; + EnsembleCmdRep *ensembleCopy = ckalloc(sizeof(EnsembleCmdRep)); - ECRGetIntRep(objPtr, ensembleCmd); - ECRSetIntRep(copyPtr, ensembleCopy); - + copyPtr->typePtr = &ensembleCmdType; + copyPtr->internalRep.twoPtrValue.ptr1 = ensembleCopy; ensembleCopy->epoch = ensembleCmd->epoch; ensembleCopy->token = ensembleCmd->token; ensembleCopy->token->refCount++; ensembleCopy->fix = ensembleCmd->fix; if (ensembleCopy->fix) { @@ -2905,20 +2890,20 @@ * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + DefineLineInformation; Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems; Tcl_Obj *replaced = Tcl_NewObj(), *replacement; Tcl_Command ensemble = (Tcl_Command) cmdPtr; Command *oldCmdPtr = cmdPtr, *newCmdPtr; int len, result, flags = 0, i, depth = 1, invokeAnyway = 0; int ourResult = TCL_ERROR; - size_t numBytes; + unsigned numBytes; const char *word; - DefineLineInformation; Tcl_IncrRefCount(replaced); if (parsePtr->numWords < depth + 1) { goto failed; } @@ -2982,20 +2967,20 @@ * list filters the entries in the map. */ (void) Tcl_GetEnsembleSubcommandList(NULL, ensemble, &listObj); if (listObj != NULL) { - size_t sclen; + int sclen; const char *str; Tcl_Obj *matchObj = NULL; if (Tcl_ListObjGetElements(NULL, listObj, &len, &elems) != TCL_OK) { goto failed; } for (i=0 ; inuloc - 1 > eclIndex) { mapPtr->nuloc--; - Tcl_Free(mapPtr->loc[mapPtr->nuloc].line); + ckfree(mapPtr->loc[mapPtr->nuloc].line); mapPtr->loc[mapPtr->nuloc].line = NULL; } /* * Reset the index of next command. Toss out any from failed nested @@ -3243,20 +3228,20 @@ Tcl_Parse *parsePtr, int depth, Command *cmdPtr, CompileEnv *envPtr) /* Holds resulting instructions. */ { + DefineLineInformation; int result, i; Tcl_Token *saveTokenPtr = parsePtr->tokenPtr; int savedStackDepth = envPtr->currStackDepth; unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart; int savedAuxDataArrayNext = envPtr->auxDataArrayNext; int savedExceptArrayNext = envPtr->exceptArrayNext; #ifdef TCL_COMPILE_DEBUG int savedExceptDepth = envPtr->exceptDepth; #endif - DefineLineInformation; if (cmdPtr->compileProc == NULL) { return TCL_ERROR; } @@ -3354,11 +3339,11 @@ int diff = envPtr->currStackDepth - savedStackDepth; if (diff != 1) { Tcl_Panic("bad stack adjustment when compiling" - " %.*s (was %d instead of 1)", (int)parsePtr->tokenPtr->size, + " %.*s (was %d instead of 1)", parsePtr->tokenPtr->size, parsePtr->tokenPtr->start, diff); } #endif } @@ -3376,16 +3361,15 @@ Tcl_Parse *parsePtr, Tcl_Obj *replacements, Command *cmdPtr, CompileEnv *envPtr) /* Holds resulting instructions. */ { + DefineLineInformation; Tcl_Token *tokPtr; Tcl_Obj *objPtr, **words; char *bytes; - int i, numWords, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME; - size_t length; - DefineLineInformation; + int length, i, numWords, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME; /* * Push the words of the command. Take care; the command words may be * scripts that have backslashes in them, and [info frame 0] can see the * difference. Hence the call to TclContinuationsEnterDerived... @@ -3393,19 +3377,19 @@ Tcl_ListObjGetElements(NULL, replacements, &numWords, &words); for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++, tokPtr = TokenAfter(tokPtr)) { if (i > 0 && i < numWords+1) { - bytes = TclGetStringFromObj(words[i-1], &length); + bytes = Tcl_GetStringFromObj(words[i-1], &length); PushLiteral(envPtr, bytes, length); continue; } SetLineInformation(i); if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) { - int literal = TclRegisterLiteral(envPtr, - tokPtr[1].start, tokPtr[1].size, 0); + int literal = TclRegisterNewLiteral(envPtr, + tokPtr[1].start, tokPtr[1].size); if (envPtr->clNext) { TclContinuationsEnterDerived( TclFetchLiteral(envPtr, literal), tokPtr[1].start - envPtr->source, @@ -3422,15 +3406,15 @@ * the implementation. */ objPtr = Tcl_NewObj(); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); - bytes = TclGetStringFromObj(objPtr, &length); + bytes = Tcl_GetStringFromObj(objPtr, &length); if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) { extraLiteralFlags |= LITERAL_UNSHARED; } - cmdLit = TclRegisterLiteral(envPtr, bytes, length, extraLiteralFlags); + cmdLit = TclRegisterLiteral(envPtr, (char *)bytes, length, extraLiteralFlags); TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLit), cmdPtr); TclEmitPush(cmdLit, envPtr); TclDecrRefCount(objPtr); /* Index: generic/tclEnv.c ================================================================== --- generic/tclEnv.c +++ generic/tclEnv.c @@ -14,27 +14,48 @@ */ #include "tclInt.h" TCL_DECLARE_MUTEX(envMutex) /* To serialize access to environ. */ + +#if defined(_WIN32) +# define tenviron _wenviron +# define tenviron2utfdstr(tenvstr, len, dstr) \ + Tcl_WinTCharToUtf((TCHAR *)tenvstr, len, dstr) +# define utf2tenvirondstr(str, len, dstr) \ + (const WCHAR *)Tcl_WinUtfToTChar(str, len, dstr) +# define techar WCHAR +# ifdef USE_PUTENV +# define putenv(env) _wputenv((const wchar_t *)env) +# endif +#else +# define tenviron environ +# define tenviron2utfdstr(tenvstr, len, dstr) \ + Tcl_ExternalToUtfDString(NULL, tenvstr, len, dstr) +# define utf2tenvirondstr(str, len, dstr) \ + Tcl_UtfToExternalDString(NULL, str, len, dstr) +# define techar char +#endif static struct { - size_t cacheSize; /* Number of env strings in cache. */ + int cacheSize; /* Number of env strings in cache. */ char **cache; /* Array containing all of the environment * strings that Tcl has allocated. */ #ifndef USE_PUTENV - char **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. */ - size_t ourEnvironSize; /* Non-zero means that the environ array was + int ourEnvironSize; /* Non-zero means that the environ array was * malloced and has this many total entries * allocated to it (not all may be in use at * once). Zero means that the environment * array is in its original static state. */ #endif } env; + +#define tNTL sizeof(techar) /* * Declarations for local functions defined in this file: */ @@ -104,28 +125,39 @@ Tcl_InitObjHashTable(&namesHash); varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL, TCL_GLOBAL_ONLY, /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); TclFindArrayPtrElements(varPtr, &namesHash); +#if defined(_WIN32) + if (tenviron == NULL) { + /* + * When we are started from main(), the _wenviron array could + * be NULL and will be initialized by the first _wgetenv() call. + */ + + (void) _wgetenv(L"WINDIR"); + } +#endif + /* * Go through the environment array and transfer its values into Tcl. At * the same time, remove those elements we add/update from the hash table * of existing elements, so that after this part processes, that table * will hold just the parts to remove. */ - if (environ[0] != NULL) { + if (tenviron[0] != NULL) { int i; Tcl_MutexLock(&envMutex); - for (i = 0; environ[i] != NULL; i++) { + for (i = 0; tenviron[i] != NULL; i++) { Tcl_Obj *obj1, *obj2; const char *p1; char *p2; - p1 = Tcl_ExternalToUtfDString(NULL, environ[i], -1, &envString); - p2 = strchr(p1, '='); + p1 = tenviron2utfdstr(tenviron[i], -1, &envString); + p2 = (char *)strchr(p1, '='); if (p2 == NULL) { /* * This condition seem to happen occasionally under some * versions of Solaris, or when encoding accidents swallow the * '='; ignore the entry. @@ -170,11 +202,11 @@ * counterparts in the environment array. */ for (hPtr=Tcl_FirstHashEntry(&namesHash, &search); hPtr!=NULL; hPtr=Tcl_NextHashEntry(&search)) { - Tcl_Obj *elemName = Tcl_GetHashValue(hPtr); + Tcl_Obj *elemName = (Tcl_Obj *)Tcl_GetHashValue(hPtr); TclObjUnsetVar2(interp, varNamePtr, elemName, TCL_GLOBAL_ONLY); } Tcl_DeleteHashTable(&namesHash); Tcl_DecrRefCount(varNamePtr); @@ -214,14 +246,14 @@ const char *name, /* Name of variable whose value is to be set * (UTF-8). */ const char *value) /* New value for variable (UTF-8). */ { Tcl_DString envString; - size_t nameLength, valueLength; - size_t index, length; + unsigned nameLength, valueLength; + int index, length; char *p, *oldValue; - const char *p2; + const techar *p2; /* * Figure out where the entry is going to go. If the name doesn't already * exist, enlarge the array if necessary to make room. If the name exists, * free its old entry. @@ -228,53 +260,53 @@ */ Tcl_MutexLock(&envMutex); index = TclpFindVariable(name, &length); - if (index == TCL_INDEX_NONE) { + if (index == -1) { #ifndef USE_PUTENV /* * We need to handle the case where the environment may be changed * outside our control. ourEnvironSize is only valid if the current * environment is the one we allocated. [Bug 979640] */ - if ((env.ourEnviron != environ) || (length+2 > env.ourEnvironSize)) { - char **newEnviron = Tcl_Alloc((length + 5) * sizeof(char *)); + if ((env.ourEnviron != tenviron) || (length+2 > env.ourEnvironSize)) { + techar **newEnviron = (techar **)ckalloc((length + 5) * sizeof(techar *)); - memcpy(newEnviron, environ, length * sizeof(char *)); + memcpy(newEnviron, tenviron, length * sizeof(techar *)); if ((env.ourEnvironSize != 0) && (env.ourEnviron != NULL)) { - Tcl_Free(env.ourEnviron); + ckfree(env.ourEnviron); } - environ = env.ourEnviron = newEnviron; + tenviron = (env.ourEnviron = newEnviron); env.ourEnvironSize = length + 5; } index = length; - environ[index + 1] = NULL; + tenviron[index + 1] = NULL; #endif /* USE_PUTENV */ oldValue = NULL; nameLength = strlen(name); } else { - const char *env; + const char *oldEnv; /* * Compare the new value to the existing value. If they're the same * then quit immediately (e.g. don't rewrite the value or propagate it * to other interpreters). Otherwise, when there are N interpreters * there will be N! propagations of the same value among the * interpreters. */ - env = Tcl_ExternalToUtfDString(NULL, environ[index], -1, &envString); - if (strcmp(value, env + (length + 1)) == 0) { + oldEnv = tenviron2utfdstr(tenviron[index], -1, &envString); + if (strcmp(value, oldEnv + (length + 1)) == 0) { Tcl_DStringFree(&envString); Tcl_MutexUnlock(&envMutex); return; } Tcl_DStringFree(&envString); - oldValue = environ[index]; + oldValue = (char *)tenviron[index]; nameLength = length; } /* * Create a new entry. Build a complete UTF string that contains a @@ -281,22 +313,22 @@ * "name=value" pattern. Then convert the string to the native encoding, * and set the environ array value. */ valueLength = strlen(value); - p = Tcl_Alloc(nameLength + valueLength + 2); + p = (char *)ckalloc(nameLength + valueLength + 2); memcpy(p, name, nameLength); p[nameLength] = '='; memcpy(p+nameLength+1, value, valueLength+1); - p2 = Tcl_UtfToExternalDString(NULL, p, -1, &envString); + p2 = utf2tenvirondstr(p, -1, &envString); /* * Copy the native string to heap memory. */ - p = Tcl_Realloc(p, Tcl_DStringLength(&envString) + 1); - memcpy(p, p2, Tcl_DStringLength(&envString) + 1); + p = (char *)ckrealloc(p, Tcl_DStringLength(&envString) + tNTL); + memcpy(p, p2, Tcl_DStringLength(&envString) + tNTL); Tcl_DStringFree(&envString); #ifdef USE_PUTENV /* * Update the system environment. @@ -303,28 +335,28 @@ */ putenv(p); index = TclpFindVariable(name, &length); #else - environ[index] = p; + tenviron[index] = (techar *)p; #endif /* USE_PUTENV */ /* * Watch out for versions of putenv that copy the string (e.g. VC++). In * this case we need to free the string immediately. Otherwise update the * string in the cache. */ - if ((index != TCL_INDEX_NONE) && (environ[index] == p)) { + if ((index != -1) && (tenviron[index] == (techar *)p)) { ReplaceString(oldValue, p); #ifdef HAVE_PUTENV_THAT_COPIES } else { /* * This putenv() copies instead of taking ownership. */ - Tcl_Free(p); + ckfree(p); #endif /* HAVE_PUTENV_THAT_COPIES */ } Tcl_MutexUnlock(&envMutex); @@ -377,11 +409,11 @@ * First convert the native string to UTF. Then separate the string into * name and value parts, and call TclSetEnv to do all of the real work. */ name = Tcl_ExternalToUtfDString(NULL, assignment, -1, &nameString); - value = strchr(name, '='); + value = (char *)strchr(name, '='); if ((value != NULL) && (value != name)) { value[0] = '\0'; TclSetEnv(name, value+1); } @@ -412,11 +444,12 @@ void TclUnsetEnv( const char *name) /* Name of variable to remove (UTF-8). */ { char *oldValue; - size_t length, index; + int length; + int index; #ifdef USE_PUTENV_FOR_UNSET Tcl_DString envString; char *string; #else char **envPtr; @@ -428,20 +461,20 @@ /* * First make sure that the environment variable exists to avoid doing * needless work and to avoid recursion on the unset. */ - if (index == TCL_AUTO_LENGTH) { + if (index == -1) { Tcl_MutexUnlock(&envMutex); return; } /* * Remember the old value so we can free it if Tcl created the string. */ - oldValue = environ[index]; + oldValue = (char *)tenviron[index]; /* * Update the system environment. This must be done before we update the * interpreters or we will recurse. */ @@ -451,24 +484,24 @@ * For those platforms that support putenv to unset, Linux indicates * that no = should be included, and Windows requires it. */ #if defined(_WIN32) - string = Tcl_Alloc(length + 2); + string = (char *)ckalloc(length + 2); memcpy(string, name, length); string[length] = '='; string[length+1] = '\0'; #else - string = Tcl_Alloc(length + 1); + string = (char *)ckalloc(length + 1); memcpy(string, name, length); string[length] = '\0'; #endif /* _WIN32 */ - Tcl_UtfToExternalDString(NULL, string, -1, &envString); - string = Tcl_Realloc(string, Tcl_DStringLength(&envString) + 1); + utf2tenvirondstr(string, -1, &envString); + string = (char *)ckrealloc(string, Tcl_DStringLength(&envString) + tNTL); memcpy(string, Tcl_DStringValue(&envString), - Tcl_DStringLength(&envString)+1); + Tcl_DStringLength(&envString) + tNTL); Tcl_DStringFree(&envString); putenv(string); /* @@ -475,23 +508,23 @@ * Watch out for versions of putenv that copy the string (e.g. VC++). In * this case we need to free the string immediately. Otherwise update the * string in the cache. */ - if (environ[index] == string) { + if (tenviron[index] == (techar *)string) { ReplaceString(oldValue, string); #ifdef HAVE_PUTENV_THAT_COPIES } else { /* * This putenv() copies instead of taking ownership. */ - Tcl_Free(string); + ckfree(string); #endif /* HAVE_PUTENV_THAT_COPIES */ } #else /* !USE_PUTENV_FOR_UNSET */ - for (envPtr = environ+index+1; ; envPtr++) { + for (envPtr = (char **)(tenviron+index+1); ; envPtr++) { envPtr[-1] = *envPtr; if (*envPtr == NULL) { break; } } @@ -527,20 +560,20 @@ * (UTF-8). */ Tcl_DString *valuePtr) /* Uninitialized or free DString in which the * value of the environment variable is * stored. */ { - size_t length, index; + int length, index; const char *result; Tcl_MutexLock(&envMutex); index = TclpFindVariable(name, &length); result = NULL; - if (index != TCL_AUTO_LENGTH) { + if (index != -1) { Tcl_DString envStr; - result = Tcl_ExternalToUtfDString(NULL, environ[index], -1, &envStr); + result = tenviron2utfdstr(tenviron[index], -1, &envStr); result += length; if (*result == '=') { result++; Tcl_DStringInit(valuePtr); Tcl_DStringAppend(valuePtr, result, -1); @@ -660,11 +693,11 @@ static void ReplaceString( const char *oldStr, /* Old environment string. */ char *newStr) /* New environment string. */ { - size_t i; + int i; /* * Check to see if the old value was allocated by Tcl. If so, it needs to * be deallocated to avoid memory leaks. Note that this algorithm is O(n), * not O(1). This will result in n-squared behavior if lots of environment @@ -680,11 +713,11 @@ /* * Replace or delete the old value. */ if (env.cache[i]) { - Tcl_Free(env.cache[i]); + ckfree(env.cache[i]); } if (newStr) { env.cache[i] = newStr; } else { @@ -698,15 +731,15 @@ * We need to grow the cache in order to hold the new string. */ const int growth = 5; - env.cache = Tcl_Realloc(env.cache, + env.cache = (char **)ckrealloc(env.cache, (env.cacheSize + growth) * sizeof(char *)); env.cache[env.cacheSize] = newStr; (void) memset(env.cache+env.cacheSize+1, 0, - (growth-1) * sizeof(char *)); + (size_t) (growth-1) * sizeof(char *)); env.cacheSize += growth; } } /* @@ -741,19 +774,19 @@ if (env.cache) { #ifdef PURIFY int i; for (i = 0; i < env.cacheSize; i++) { - Tcl_Free(env.cache[i]); + ckfree(env.cache[i]); } #endif - Tcl_Free(env.cache); + ckfree(env.cache); env.cache = NULL; env.cacheSize = 0; #ifndef USE_PUTENV if ((env.ourEnviron != NULL)) { - Tcl_Free(env.ourEnviron); + ckfree(env.ourEnviron); env.ourEnviron = NULL; } env.ourEnvironSize = 0; #endif } Index: generic/tclEvent.c ================================================================== --- generic/tclEvent.c +++ generic/tclEvent.c @@ -35,11 +35,11 @@ * One of the structures below is associated with the "tclBgError" assoc data * for each interpreter. It keeps track of the head and tail of the list of * pending background errors for the interpreter. */ -typedef struct { +typedef struct ErrAssocData { Tcl_Interp *interp; /* Interpreter in which error occurred. */ Tcl_Obj *cmdPrefix; /* First word(s) of the handler command */ BgError *firstBgPtr; /* First in list of all background errors * waiting to be processed for this * interpreter (NULL if none). */ @@ -98,11 +98,11 @@ * used as a hack to decide to close the * standard channels. */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; -#if TCL_THREADS +#ifdef TCL_THREADS typedef struct { Tcl_ThreadCreateProc *proc; /* Main() function of the thread */ ClientData clientData; /* The one argument to Main() */ } ThreadClientData; static Tcl_ThreadCreateType NewThreadProc(ClientData clientData); @@ -122,11 +122,11 @@ static void FinalizeThread(int quick); /* *---------------------------------------------------------------------- * - * Tcl_BackgroundException -- + * Tcl_BackgroundError -- * * This function is invoked to handle errors that occur in Tcl commands * that are invoked in "background" (e.g. from event or timer bindings). * * Results: @@ -136,10 +136,18 @@ * A handler command is invoked later as an idle handler to process the * error, passing it the interp result and return options. * *---------------------------------------------------------------------- */ + +void +Tcl_BackgroundError( + Tcl_Interp *interp) /* Interpreter in which an error has + * occurred. */ +{ + Tcl_BackgroundException(interp, TCL_ERROR); +} void Tcl_BackgroundException( Tcl_Interp *interp, /* Interpreter in which an exception has * occurred. */ @@ -150,11 +158,11 @@ if (code == TCL_OK) { return; } - errPtr = Tcl_Alloc(sizeof(BgError)); + errPtr = ckalloc(sizeof(BgError)); errPtr->errorMsg = Tcl_GetObjResult(interp); Tcl_IncrRefCount(errPtr->errorMsg); errPtr->returnOpts = Tcl_GetReturnOptions(interp, code); Tcl_IncrRefCount(errPtr->returnOpts); errPtr->nextPtr = NULL; @@ -217,11 +225,11 @@ Tcl_Obj *copyObj = TclListObjCopy(NULL, assocPtr->cmdPrefix); errPtr = assocPtr->firstBgPtr; Tcl_ListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv); - tempObjv = Tcl_Alloc((prefixObjc+2) * sizeof(Tcl_Obj *)); + tempObjv = ckalloc((prefixObjc+2) * sizeof(Tcl_Obj *)); memcpy(tempObjv, prefixObjv, prefixObjc*sizeof(Tcl_Obj *)); tempObjv[prefixObjc] = errPtr->errorMsg; tempObjv[prefixObjc+1] = errPtr->returnOpts; Tcl_AllowExceptions(interp); code = Tcl_EvalObjv(interp, prefixObjc+2, tempObjv, TCL_EVAL_GLOBAL); @@ -232,12 +240,12 @@ Tcl_DecrRefCount(copyObj); Tcl_DecrRefCount(errPtr->errorMsg); Tcl_DecrRefCount(errPtr->returnOpts); assocPtr->firstBgPtr = errPtr->nextPtr; - Tcl_Free(errPtr); - Tcl_Free(tempObjv); + ckfree(errPtr); + ckfree(tempObjv); if (code == TCL_BREAK) { /* * Break means cancel any remaining error reports for this * interpreter. @@ -246,11 +254,11 @@ while (assocPtr->firstBgPtr != NULL) { errPtr = assocPtr->firstBgPtr; assocPtr->firstBgPtr = errPtr->nextPtr; Tcl_DecrRefCount(errPtr->errorMsg); Tcl_DecrRefCount(errPtr->returnOpts); - Tcl_Free(errPtr); + ckfree(errPtr); } } else if ((code == TCL_ERROR) && !Tcl_IsSafe(interp)) { Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR); if (errChannel != NULL) { @@ -515,11 +523,11 @@ if (assocPtr == NULL) { /* * First access: initialize. */ - assocPtr = Tcl_Alloc(sizeof(ErrAssocData)); + assocPtr = ckalloc(sizeof(ErrAssocData)); assocPtr->interp = interp; assocPtr->cmdPrefix = NULL; assocPtr->firstBgPtr = NULL; assocPtr->lastBgPtr = NULL; Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc, assocPtr); @@ -594,11 +602,11 @@ while (assocPtr->firstBgPtr != NULL) { errPtr = assocPtr->firstBgPtr; assocPtr->firstBgPtr = errPtr->nextPtr; Tcl_DecrRefCount(errPtr->errorMsg); Tcl_DecrRefCount(errPtr->returnOpts); - Tcl_Free(errPtr); + ckfree(errPtr); } Tcl_CancelIdleCall(HandleBgErrors, assocPtr); Tcl_DecrRefCount(assocPtr->cmdPrefix); Tcl_EventuallyFree(assocPtr, TCL_DYNAMIC); } @@ -624,11 +632,11 @@ void Tcl_CreateExitHandler( Tcl_ExitProc *proc, /* Function to invoke. */ ClientData clientData) /* Arbitrary value to pass to proc. */ { - ExitHandler *exitPtr = Tcl_Alloc(sizeof(ExitHandler)); + ExitHandler *exitPtr = ckalloc(sizeof(ExitHandler)); exitPtr->proc = proc; exitPtr->clientData = clientData; Tcl_MutexLock(&exitMutex); exitPtr->nextPtr = firstExitPtr; @@ -657,11 +665,11 @@ void TclCreateLateExitHandler( Tcl_ExitProc *proc, /* Function to invoke. */ ClientData clientData) /* Arbitrary value to pass to proc. */ { - ExitHandler *exitPtr = Tcl_Alloc(sizeof(ExitHandler)); + ExitHandler *exitPtr = ckalloc(sizeof(ExitHandler)); exitPtr->proc = proc; exitPtr->clientData = clientData; Tcl_MutexLock(&exitMutex); exitPtr->nextPtr = firstLateExitPtr; @@ -702,11 +710,11 @@ if (prevPtr == NULL) { firstExitPtr = exitPtr->nextPtr; } else { prevPtr->nextPtr = exitPtr->nextPtr; } - Tcl_Free(exitPtr); + ckfree(exitPtr); break; } } Tcl_MutexUnlock(&exitMutex); return; @@ -745,11 +753,11 @@ if (prevPtr == NULL) { firstLateExitPtr = exitPtr->nextPtr; } else { prevPtr->nextPtr = exitPtr->nextPtr; } - Tcl_Free(exitPtr); + ckfree(exitPtr); break; } } Tcl_MutexUnlock(&exitMutex); return; @@ -779,11 +787,11 @@ ClientData clientData) /* Arbitrary value to pass to proc. */ { ExitHandler *exitPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - exitPtr = Tcl_Alloc(sizeof(ExitHandler)); + exitPtr = ckalloc(sizeof(ExitHandler)); exitPtr->proc = proc; exitPtr->clientData = clientData; exitPtr->nextPtr = tsdPtr->firstExitPtr; tsdPtr->firstExitPtr = exitPtr; } @@ -821,11 +829,11 @@ if (prevPtr == NULL) { tsdPtr->firstExitPtr = exitPtr->nextPtr; } else { prevPtr->nextPtr = exitPtr->nextPtr; } - Tcl_Free(exitPtr); + ckfree(exitPtr); return; } } } @@ -899,11 +907,11 @@ */ firstExitPtr = exitPtr->nextPtr; Tcl_MutexUnlock(&exitMutex); exitPtr->proc(exitPtr->clientData); - Tcl_Free(exitPtr); + ckfree(exitPtr); Tcl_MutexLock(&exitMutex); } firstExitPtr = NULL; Tcl_MutexUnlock(&exitMutex); } @@ -1033,18 +1041,15 @@ * Initialize locks used by the memory allocators before anything * interesting happens so we can use the allocators in the * implementation of self-initializing locks. */ - TclInitThreadStorage(); /* Creates master hash table for + TclInitThreadStorage(); /* Creates hash table for * thread local storage */ -#if USE_TCLALLOC +#if defined(USE_TCLALLOC) && USE_TCLALLOC TclInitAlloc(); /* Process wide mutex init */ #endif -#if TCL_THREADS && defined(USE_THREAD_ALLOC) - TclInitThreadAlloc(); /* Setup thread allocator caches */ -#endif #ifdef TCL_MEM_DEBUG TclInitDbCkalloc(); /* Process wide mutex init */ #endif TclpInitPlatform(); /* Creates signal handler(s) */ @@ -1127,11 +1132,11 @@ */ firstLateExitPtr = exitPtr->nextPtr; Tcl_MutexUnlock(&exitMutex); exitPtr->proc(exitPtr->clientData); - Tcl_Free(exitPtr); + ckfree(exitPtr); Tcl_MutexLock(&exitMutex); } firstLateExitPtr = NULL; Tcl_MutexUnlock(&exitMutex); @@ -1150,11 +1155,11 @@ */ TclFinalizeFilesystem(); /* - * Undo all Tcl_ObjType registrations, and reset the master list of free + * Undo all Tcl_ObjType registrations, and reset the global list of free * Tcl_Obj's. After this returns, no more Tcl_Obj's should be allocated or * freed. * * Note in particular that TclFinalizeObjects() must follow * TclFinalizeFilesystem() because TclFinalizeFilesystem free's the @@ -1215,11 +1220,11 @@ /* * Close down the thread-specific object allocator. */ -#if TCL_THREADS && defined(USE_THREAD_ALLOC) +#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) TclFinalizeThreadAlloc(); #endif /* * We defer unloading of packages until very late to avoid memory access @@ -1238,11 +1243,11 @@ TclFinalizeLoad(); TclResetFilesystem(); /* - * At this point, there should no longer be any Tcl_Alloc'ed memory. + * At this point, there should no longer be any ckalloc'ed memory. */ TclFinalizeMemorySubsystem(); alreadyFinalized: @@ -1297,11 +1302,11 @@ * callback should call Tcl_DeleteThreadExitHandler on itself. */ tsdPtr->firstExitPtr = exitPtr->nextPtr; exitPtr->proc(exitPtr->clientData); - Tcl_Free(exitPtr); + ckfree(exitPtr); } TclFinalizeIOSubsystem(); TclFinalizeNotifier(); TclFinalizeAsync(); TclFinalizeThreadObjects(); @@ -1398,11 +1403,11 @@ if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "name"); return TCL_ERROR; } - nameString = TclGetString(objv[1]); + nameString = Tcl_GetString(objv[1]); if (Tcl_TraceVar2(interp, nameString, NULL, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, VwaitVarProc, &done) != TCL_OK) { return TCL_ERROR; }; @@ -1533,11 +1538,11 @@ Tcl_ResetResult(interp); return TCL_OK; } -#if TCL_THREADS +#ifdef TCL_THREADS /* *---------------------------------------------------------------------- * * NewThreadProc -- * @@ -1560,11 +1565,11 @@ ClientData threadClientData; Tcl_ThreadCreateProc *threadProc; threadProc = cdPtr->proc; threadClientData = cdPtr->clientData; - Tcl_Free(clientData); /* Allocated in Tcl_CreateThread() */ + ckfree(clientData); /* Allocated in Tcl_CreateThread() */ threadProc(threadClientData); TCL_THREAD_CREATE_RETURN; } @@ -1592,23 +1597,23 @@ int Tcl_CreateThread( Tcl_ThreadId *idPtr, /* Return, the ID of the thread */ Tcl_ThreadCreateProc *proc, /* Main() function of the thread */ ClientData clientData, /* The one argument to Main() */ - size_t stackSize, /* Size of stack for the new thread */ + int stackSize, /* Size of stack for the new thread */ int flags) /* Flags controlling behaviour of the new * thread. */ { -#if TCL_THREADS - ThreadClientData *cdPtr = Tcl_Alloc(sizeof(ThreadClientData)); +#ifdef TCL_THREADS + ThreadClientData *cdPtr = ckalloc(sizeof(ThreadClientData)); int result; cdPtr->proc = proc; cdPtr->clientData = clientData; result = TclpThreadCreate(idPtr, NewThreadProc, cdPtr, stackSize, flags); if (result != TCL_OK) { - Tcl_Free(cdPtr); + ckfree(cdPtr); } return result; #else return TCL_ERROR; #endif /* TCL_THREADS */ Index: generic/tclExecute.c ================================================================== --- generic/tclExecute.c +++ generic/tclExecute.c @@ -32,18 +32,18 @@ #if (FLT_RADIX == 2) && (DBL_MANT_DIG == 53) && (DBL_MAX_EXP == 1024) #define IEEE_FLOATING_POINT #endif /* - * A counter that is used to work out when the bytecode engine should call - * Tcl_AsyncReady() to see whether there is a signal that needs handling, and - * other expensive periodic operations. + * A mask (should be 2**n-1) that is used to work out when the bytecode engine + * should call Tcl_AsyncReady() to see whether there is a signal that needs + * handling. */ -#ifndef ASYNC_CHECK_COUNT -# define ASYNC_CHECK_COUNT 64 -#endif /* !ASYNC_CHECK_COUNT */ +#ifndef ASYNC_CHECK_COUNT_MASK +# define ASYNC_CHECK_COUNT_MASK 63 +#endif /* !ASYNC_CHECK_COUNT_MASK */ /* * Boolean flag indicating whether the Tcl bytecode interpreter has been * initialized. */ @@ -71,15 +71,15 @@ * Mapping from expression instruction opcodes to strings; used for error * messages. Note that these entries must match the order and number of the * expression opcodes (e.g., INST_LOR) in tclCompile.h. * * Does not include the string for INST_EXPON (and beyond), as that is - * disjoint for backward-compatibility reasons. + * disjoint for backward-compatability reasons. */ static const char *const operatorStrings[] = { - "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>", + "||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>", "+", "-", "*", "/", "%", "+", "-", "~", "!" }; /* * Mapping from Tcl result codes to strings; used for error and debugging @@ -95,22 +95,80 @@ /* * These are used by evalstats to monitor object usage in Tcl. */ #ifdef TCL_COMPILE_STATS -size_t tclObjsAlloced = 0; -size_t tclObjsFreed = 0; -size_t tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; +long tclObjsAlloced = 0; +long tclObjsFreed = 0; +long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; #endif /* TCL_COMPILE_STATS */ + +/* + * Support pre-8.5 bytecodes unless specifically requested otherwise. + */ + +#ifndef TCL_SUPPORT_84_BYTECODE +#define TCL_SUPPORT_84_BYTECODE 1 +#endif + +#if TCL_SUPPORT_84_BYTECODE +/* + * We need to know the tclBuiltinFuncTable to support translation of pre-8.5 + * math functions to the namespace-based ::tcl::mathfunc::op in 8.5+. + */ + +typedef struct { + const char *name; /* Name of function. */ + int numArgs; /* Number of arguments for function. */ +} BuiltinFunc; + +/* + * Table describing the built-in math functions. Entries in this table are + * indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's + * operand byte. + */ + +static BuiltinFunc const tclBuiltinFuncTable[] = { + {"acos", 1}, + {"asin", 1}, + {"atan", 1}, + {"atan2", 2}, + {"ceil", 1}, + {"cos", 1}, + {"cosh", 1}, + {"exp", 1}, + {"floor", 1}, + {"fmod", 2}, + {"hypot", 2}, + {"log", 1}, + {"log10", 1}, + {"pow", 2}, + {"sin", 1}, + {"sinh", 1}, + {"sqrt", 1}, + {"tan", 1}, + {"tanh", 1}, + {"abs", 1}, + {"double", 1}, + {"int", 1}, + {"rand", 0}, + {"round", 1}, + {"srand", 1}, + {"wide", 1}, + {NULL, 0}, +}; + +#define LAST_BUILTIN_FUNC 25 +#endif /* * NR_TEBC * Helpers for NR - non-recursive calls to TEBC * Minimal data required to fully reconstruct the execution state. */ -typedef struct { +typedef struct TEBCdata { ByteCode *codePtr; /* Constant until the BC returns */ /* -----------------------------------------*/ ptrdiff_t *catchTop; /* These fields are used on return TO this */ Tcl_Obj *auxObjList; /* this level: they record the state when a */ CmdFrame cmdFrame; /* new codePtr was received for NR */ @@ -151,11 +209,11 @@ /* * These variable-access macros have to coincide with those in tclVar.c */ #define VarHashGetValue(hPtr) \ - ((Var *) ((char *)hPtr - offsetof(VarInHash, entry))) + ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry))) static inline Var * VarHashCreateVar( TclVarHashTable *tablePtr, Tcl_Obj *key, @@ -257,44 +315,54 @@ do { \ pc += (pcAdjustment); \ switch (*pc) { \ case INST_JUMP_FALSE1: \ NEXT_INST_F(((condition)? 2 : TclGetInt1AtPtr(pc+1)), (cleanup), 0); \ + break; \ case INST_JUMP_TRUE1: \ NEXT_INST_F(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \ + break; \ case INST_JUMP_FALSE4: \ NEXT_INST_F(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \ + break; \ case INST_JUMP_TRUE4: \ NEXT_INST_F(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \ + break; \ default: \ if ((condition) < 0) { \ TclNewIntObj(objResultPtr, -1); \ } else { \ objResultPtr = TCONST((condition) > 0); \ } \ NEXT_INST_F(0, (cleanup), 1); \ + break; \ } \ } while (0) #define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \ do { \ pc += (pcAdjustment); \ switch (*pc) { \ case INST_JUMP_FALSE1: \ NEXT_INST_V(((condition)? 2 : TclGetInt1AtPtr(pc+1)), (cleanup), 0); \ + break; \ case INST_JUMP_TRUE1: \ NEXT_INST_V(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \ + break; \ case INST_JUMP_FALSE4: \ NEXT_INST_V(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \ + break; \ case INST_JUMP_TRUE4: \ NEXT_INST_V(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \ + break; \ default: \ if ((condition) < 0) { \ TclNewIntObj(objResultPtr, -1); \ } else { \ objResultPtr = TCONST((condition) > 0); \ } \ NEXT_INST_V(0, (cleanup), 1); \ + break; \ } \ } while (0) #else /* TCL_COMPILE_DEBUG */ #define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \ do{ \ @@ -438,24 +506,59 @@ * * MODULE_SCOPE int GetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, * ClientData *ptrPtr, int *tPtr); */ +#ifdef TCL_WIDE_INT_IS_LONG +#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ + (((objPtr)->typePtr == &tclIntType) \ + ? (*(tPtr) = TCL_NUMBER_LONG, \ + *(ptrPtr) = (ClientData) \ + (&((objPtr)->internalRep.longValue)), TCL_OK) : \ + ((objPtr)->typePtr == &tclDoubleType) \ + ? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \ + ? (*(tPtr) = TCL_NUMBER_NAN) \ + : (*(tPtr) = TCL_NUMBER_DOUBLE)), \ + *(ptrPtr) = (ClientData) \ + (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ + (((objPtr)->bytes != NULL) && ((objPtr)->length == 0)) \ + ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \ + TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) +#else /* !TCL_WIDE_INT_IS_LONG */ #define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ - ((TclHasIntRep((objPtr), &tclIntType)) \ - ? (*(tPtr) = TCL_NUMBER_INT, \ - *(ptrPtr) = (void *) \ + (((objPtr)->typePtr == &tclIntType) \ + ? (*(tPtr) = TCL_NUMBER_LONG, \ + *(ptrPtr) = (ClientData) \ + (&((objPtr)->internalRep.longValue)), TCL_OK) : \ + ((objPtr)->typePtr == &tclWideIntType) \ + ? (*(tPtr) = TCL_NUMBER_WIDE, \ + *(ptrPtr) = (ClientData) \ (&((objPtr)->internalRep.wideValue)), TCL_OK) : \ - TclHasIntRep((objPtr), &tclDoubleType) \ + ((objPtr)->typePtr == &tclDoubleType) \ ? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \ ? (*(tPtr) = TCL_NUMBER_NAN) \ : (*(tPtr) = TCL_NUMBER_DOUBLE)), \ - *(ptrPtr) = (void *) \ + *(ptrPtr) = (ClientData) \ (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ (((objPtr)->bytes != NULL) && ((objPtr)->length == 0)) \ - ? TCL_ERROR : \ + ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \ TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) +#endif /* TCL_WIDE_INT_IS_LONG */ + +/* + * Macro used in this file to save a function call for common uses of + * Tcl_GetBooleanFromObj(). The ANSI C "prototype" is: + * + * MODULE_SCOPE int TclGetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, + * int *boolPtr); + */ + +#define TclGetBooleanFromObj(interp, objPtr, boolPtr) \ + ((((objPtr)->typePtr == &tclIntType) \ + || ((objPtr)->typePtr == &tclBooleanType)) \ + ? (*(boolPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \ + : Tcl_GetBooleanFromObj((interp), (objPtr), (boolPtr))) /* * Macro used to make the check for type overflow more mnemonic. This works by * comparing sign bits; the rest of the word is irrelevant. The ANSI C * "prototype" (where inttype_t is any integer type) is: @@ -481,10 +584,44 @@ /* * Auxiliary tables used to compute powers of small integers. */ +#if (LONG_MAX == 0x7FFFFFFF) + +/* + * Maximum base that, when raised to powers 2, 3, ... 8, fits in a 32-bit + * signed integer. + */ + +static const long MaxBase32[] = {46340, 1290, 215, 73, 35, 21, 14}; +static const size_t MaxBase32Size = sizeof(MaxBase32)/sizeof(long); + +/* + * Table giving 3, 4, ..., 11, raised to the powers 9, 10, ..., as far as they + * fit in a 32-bit signed integer. Exp32Index[i] gives the starting index of + * powers of i+3; Exp32Value[i] gives the corresponding powers. + */ + +static const unsigned short Exp32Index[] = { + 0, 11, 18, 23, 26, 29, 31, 32, 33 +}; +static const size_t Exp32IndexSize = + sizeof(Exp32Index) / sizeof(unsigned short); +static const long Exp32Value[] = { + 19683, 59049, 177147, 531441, 1594323, 4782969, 14348907, 43046721, + 129140163, 387420489, 1162261467, 262144, 1048576, 4194304, + 16777216, 67108864, 268435456, 1073741824, 1953125, 9765625, + 48828125, 244140625, 1220703125, 10077696, 60466176, 362797056, + 40353607, 282475249, 1977326743, 134217728, 1073741824, 387420489, + 1000000000 +}; +static const size_t Exp32ValueSize = sizeof(Exp32Value)/sizeof(long); +#endif /* LONG_MAX == 0x7FFFFFFF -- 32 bit machine */ + +#if (LONG_MAX > 0x7FFFFFFF) || !defined(TCL_WIDE_INT_IS_LONG) + /* * Maximum base that, when raised to powers 2, 3, ..., 16, fits in a * Tcl_WideInt. */ @@ -584,10 +721,11 @@ (Tcl_WideInt)161051*161051*161051*11*11*11, (Tcl_WideInt)248832*248832*248832*12*12, (Tcl_WideInt)371293*371293*371293*13*13 }; static const size_t Exp64ValueSize = sizeof(Exp64Value) / sizeof(Tcl_WideInt); +#endif /* (LONG_MAX > 0x7FFFFFFF) || !defined(TCL_WIDE_INT_IS_LONG) */ /* * Markers for ExecuteExtendedBinaryMathOp. */ @@ -614,31 +752,33 @@ #endif /* TCL_COMPILE_DEBUG */ static ByteCode * CompileExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr); static void DeleteExecStack(ExecStack *esPtr); static void DupExprCodeInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); +MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr, + Tcl_Obj *value2Ptr); static Tcl_Obj * ExecuteExtendedBinaryMathOp(Tcl_Interp *interp, int opcode, Tcl_Obj **constants, Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr); static Tcl_Obj * ExecuteExtendedUnaryMathOp(int opcode, Tcl_Obj *valuePtr); static void FreeExprCodeInternalRep(Tcl_Obj *objPtr); static ExceptionRange * GetExceptRangeForPc(const unsigned char *pc, int searchMode, ByteCode *codePtr); static const char * GetSrcInfoForPc(const unsigned char *pc, - ByteCode *codePtr, size_t *lengthPtr, + ByteCode *codePtr, int *lengthPtr, const unsigned char **pcBeg, int *cmdIdxPtr); static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, int growth, int move); static void IllegalExprOperandType(Tcl_Interp *interp, const unsigned char *pc, Tcl_Obj *opndPtr); static void InitByteCodeExecution(Tcl_Interp *interp); static inline int wordSkip(void *ptr); static void ReleaseDictIterator(Tcl_Obj *objPtr); /* Useful elsewhere, make available in tclInt.h or stubs? */ -static Tcl_Obj ** StackAllocWords(Tcl_Interp *interp, size_t numWords); -static Tcl_Obj ** StackReallocWords(Tcl_Interp *interp, size_t numWords); +static Tcl_Obj ** StackAllocWords(Tcl_Interp *interp, int numWords); +static Tcl_Obj ** StackReallocWords(Tcl_Interp *interp, int numWords); static Tcl_NRPostProc CopyCallback; static Tcl_NRPostProc ExprObjCallback; static Tcl_NRPostProc FinalizeOONext; static Tcl_NRPostProc FinalizeOONextFilter; static Tcl_NRPostProc TEBCresume; @@ -688,26 +828,24 @@ ReleaseDictIterator( Tcl_Obj *objPtr) { Tcl_DictSearch *searchPtr; Tcl_Obj *dictPtr; - const Tcl_ObjIntRep *irPtr; - - irPtr = TclFetchIntRep(objPtr, &dictIteratorType); - assert(irPtr != NULL); /* * First kill the search, and then release the reference to the dictionary * that we were holding. */ - searchPtr = irPtr->twoPtrValue.ptr1; + searchPtr = objPtr->internalRep.twoPtrValue.ptr1; Tcl_DictObjDone(searchPtr); - Tcl_Free(searchPtr); + ckfree(searchPtr); - dictPtr = irPtr->twoPtrValue.ptr2; + dictPtr = objPtr->internalRep.twoPtrValue.ptr2; TclDecrRefCount(dictPtr); + + objPtr->typePtr = NULL; } /* *---------------------------------------------------------------------- * @@ -770,21 +908,21 @@ ExecEnv * TclCreateExecEnv( Tcl_Interp *interp, /* Interpreter for which the execution * environment is being created. */ - size_t size) /* The initial stack size, in number of words + int size) /* The initial stack size, in number of words * [sizeof(Tcl_Obj*)] */ { - ExecEnv *eePtr = Tcl_Alloc(sizeof(ExecEnv)); - ExecStack *esPtr = Tcl_Alloc(sizeof(ExecStack) - + (size-1) * sizeof(Tcl_Obj *)); + ExecEnv *eePtr = ckalloc(sizeof(ExecEnv)); + ExecStack *esPtr = ckalloc(TclOffset(ExecStack, stackWords) + + size * sizeof(Tcl_Obj *)); eePtr->execStackPtr = esPtr; - TclNewIntObj(eePtr->constants[0], 0); + TclNewBooleanObj(eePtr->constants[0], 0); Tcl_IncrRefCount(eePtr->constants[0]); - TclNewIntObj(eePtr->constants[1], 1); + TclNewBooleanObj(eePtr->constants[1], 1); Tcl_IncrRefCount(eePtr->constants[1]); eePtr->interp = interp; eePtr->callbackPtr = NULL; eePtr->corPtr = NULL; eePtr->rewind = 0; @@ -834,11 +972,11 @@ esPtr->prevPtr->nextPtr = esPtr->nextPtr; } if (esPtr->nextPtr) { esPtr->nextPtr->prevPtr = esPtr->prevPtr; } - Tcl_Free(esPtr); + ckfree(esPtr); } void TclDeleteExecEnv( ExecEnv *eePtr) /* Execution environment to free. */ @@ -866,11 +1004,11 @@ Tcl_Panic("Deleting execEnv with pending TEOV callbacks!"); } if (eePtr->corPtr && !cachedInExit) { Tcl_Panic("Deleting execEnv with existing coroutine"); } - Tcl_Free(eePtr); + ckfree(eePtr); } /* *---------------------------------------------------------------------- * @@ -957,12 +1095,12 @@ int growth, /* How much larger than the current used * size. */ int move) /* 1 if move words since last marker. */ { ExecStack *esPtr = eePtr->execStackPtr, *oldPtr = NULL; - size_t newBytes; - int newElems, currElems, needed = growth - (esPtr->endPtr - esPtr->tosPtr); + int newBytes, newElems, currElems; + int needed = growth - (esPtr->endPtr - esPtr->tosPtr); Tcl_Obj **markerPtr = esPtr->markerPtr, **memStart; int moveWords = 0; if (move) { if (!markerPtr) { @@ -1040,14 +1178,14 @@ } #else newElems = needed; #endif - newBytes = sizeof(ExecStack) + (newElems-1) * sizeof(Tcl_Obj *); + newBytes = TclOffset(ExecStack, stackWords) + newElems * sizeof(Tcl_Obj *); oldPtr = esPtr; - esPtr = Tcl_Alloc(newBytes); + esPtr = ckalloc(newBytes); oldPtr->nextPtr = esPtr; esPtr->prevPtr = oldPtr; esPtr->nextPtr = NULL; esPtr->endPtr = &esPtr->stackWords[newElems-1]; @@ -1103,11 +1241,11 @@ */ static Tcl_Obj ** StackAllocWords( Tcl_Interp *interp, - size_t numWords) + int numWords) { /* * Note that GrowEvaluationStack sets a marker in the stack. This marker * is read when rewinding, e.g., by TclStackFree. */ @@ -1121,11 +1259,11 @@ } static Tcl_Obj ** StackReallocWords( Tcl_Interp *interp, - size_t numWords) + int numWords) { Interp *iPtr = (Interp *) interp; ExecEnv *eePtr = iPtr->execEnvPtr; Tcl_Obj **resPtr = GrowEvaluationStack(eePtr, numWords, 1); @@ -1142,11 +1280,11 @@ ExecEnv *eePtr; ExecStack *esPtr; Tcl_Obj **markerPtr, *marker; if (iPtr == NULL || iPtr->execEnvPtr == NULL) { - Tcl_Free(freePtr); + ckfree((char *) freePtr); return; } /* * Rewind the stack to the previous marker position. The current marker, @@ -1200,36 +1338,36 @@ } void * TclStackAlloc( Tcl_Interp *interp, - size_t numBytes) + int numBytes) { Interp *iPtr = (Interp *) interp; - size_t numWords; + int numWords; if (iPtr == NULL || iPtr->execEnvPtr == NULL) { - return (void *) Tcl_Alloc(numBytes); + return (void *) ckalloc(numBytes); } numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); - return StackAllocWords(interp, numWords); + return (void *) StackAllocWords(interp, numWords); } void * TclStackRealloc( Tcl_Interp *interp, void *ptr, - size_t numBytes) + int numBytes) { Interp *iPtr = (Interp *) interp; ExecEnv *eePtr; ExecStack *esPtr; Tcl_Obj **markerPtr; - size_t numWords; + int numWords; if (iPtr == NULL || iPtr->execEnvPtr == NULL) { - return Tcl_Realloc(ptr, numBytes); + return (void *) ckrealloc((char *) ptr, numBytes); } eePtr = iPtr->execEnvPtr; esPtr = eePtr->execStackPtr; markerPtr = esPtr->markerPtr; @@ -1267,11 +1405,11 @@ int Tcl_ExprObj( Tcl_Interp *interp, /* Context in which to evaluate the * expression. */ - Tcl_Obj *objPtr, /* Points to Tcl object containing expression + Tcl_Obj *objPtr, /* Points to Tcl object containing expression * to evaluate. */ Tcl_Obj **resultPtrPtr) /* Where the Tcl_Obj* that is the expression * result is stored if no errors occur. */ { NRE_callback *rootPtr = TOP_CB(interp); @@ -1366,13 +1504,15 @@ * CompileExprObj -- * Compile a Tcl expression value into ByteCode. * * Results: * A (ByteCode *) is returned pointing to the resulting ByteCode. + * The caller must manage its refCount and arrange for a call to + * TclCleanupByteCode() when the last reference disappears. * * Side effects: - * The Tcl_ObjType of objPtr is changed to the "exprcode" type, + * The Tcl_ObjType of objPtr is changed to the "bytecode" type, * and the ByteCode is kept in the internal rep (along with context * data for checking validity) for faster operations the next time * CompileExprObj is called on the same value. * *---------------------------------------------------------------------- @@ -1392,32 +1532,28 @@ /* * Get the expression ByteCode from the object. If it exists, make sure it * is valid in the current context. */ - - ByteCodeGetIntRep(objPtr, &exprCodeType, codePtr); - - if (codePtr != NULL) { + if (objPtr->typePtr == &exprCodeType) { Namespace *namespacePtr = iPtr->varFramePtr->nsPtr; + codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != namespacePtr) || (codePtr->nsEpoch != namespacePtr->resolverEpoch) || (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) { - Tcl_StoreIntRep(objPtr, &exprCodeType, NULL); - codePtr = NULL; + FreeExprCodeInternalRep(objPtr); } } - - if (codePtr == NULL) { + if (objPtr->typePtr != &exprCodeType) { /* * TIP #280: No invoker (yet) - Expression compilation. */ - size_t length; + int length; const char *string = TclGetStringFromObj(objPtr, &length); TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0); TclCompileExpr(interp, string, length, &compEnv, 0); @@ -1425,11 +1561,11 @@ * Successful compilation. If the expression yielded no instructions, * push an zero object as the expression's result. */ if (compEnv.codeNext == compEnv.codeStart) { - TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, 0), + TclEmitPush(TclRegisterNewLiteral(&compEnv, "0", 1), &compEnv); } /* * Add a "done" instruction as the last instruction and change the @@ -1436,12 +1572,14 @@ * object into a ByteCode object. Ownership of the literal objects and * aux data items is given to the ByteCode object. */ TclEmitOpcode(INST_DONE, &compEnv); - codePtr = TclInitByteCodeObj(objPtr, &exprCodeType, &compEnv); + TclInitByteCodeObj(objPtr, &compEnv); + objPtr->typePtr = &exprCodeType; TclFreeCompileEnv(&compEnv); + codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; } #ifdef TCL_COMPILE_DEBUG @@ -1509,15 +1647,16 @@ static void FreeExprCodeInternalRep( Tcl_Obj *objPtr) { - ByteCode *codePtr; - ByteCodeGetIntRep(objPtr, &exprCodeType, codePtr); - assert(codePtr != NULL); + ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; - TclReleaseByteCode(codePtr); + objPtr->typePtr = NULL; + if (codePtr->refCount-- <= 1) { + TclCleanupByteCode(codePtr); + } } /* *---------------------------------------------------------------------- * @@ -1549,12 +1688,11 @@ * If the object is not already of tclByteCodeType, compile it (and reset * the compilation flags in the interpreter; this should be done after any * compilation). Otherwise, check that it is "fresh" enough. */ - ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr); - if (codePtr != NULL) { + if (objPtr->typePtr == &tclByteCodeType) { /* * Make sure the Bytecode hasn't been invalidated by, e.g., someone * redefining a command with a compile procedure (this might make the * compiled code wrong). The object needs to be recompiled if it was * compiled in/for a different interpreter, or for a different @@ -1568,10 +1706,11 @@ * #def'ed out because [info body] was changed to never return a * bytecode type object, which should obviate us from the extra checks * here. */ + codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != namespacePtr) || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) { if (!(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { @@ -1695,11 +1834,11 @@ iPtr->invokeCmdFramePtr = invoker; iPtr->invokeWord = word; TclSetByteCodeFromAny(interp, objPtr, NULL, NULL); iPtr->invokeCmdFramePtr = NULL; - ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr); + codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; } return codePtr; @@ -1753,10 +1892,41 @@ TclGetIntFromObj(interp, incrPtr, &type1); Tcl_AddErrorInfo(interp, "\n (reading increment)"); return TCL_ERROR; } + + if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { + long augend = *((const long *) ptr1); + long addend = *((const long *) ptr2); + long sum = augend + addend; + + /* + * Overflow when (augend and sum have different sign) and (augend and + * addend have the same sign). This is encapsulated in the Overflowing + * macro. + */ + + if (!Overflowing(augend, addend, sum)) { + TclSetLongObj(valuePtr, sum); + return TCL_OK; + } +#ifndef TCL_WIDE_INT_IS_LONG + { + Tcl_WideInt w1 = (Tcl_WideInt) augend; + Tcl_WideInt w2 = (Tcl_WideInt) addend; + + /* + * We know the sum value is outside the long range, so we use the + * macro form that doesn't range test again. + */ + + TclSetWideIntObj(valuePtr, w1 + w2); + return TCL_OK; + } +#endif + } if ((type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) { /* * Produce error message (reparse?!) */ @@ -1771,26 +1941,28 @@ TclGetIntFromObj(interp, incrPtr, &type1); Tcl_AddErrorInfo(interp, "\n (reading increment)"); return TCL_ERROR; } - if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) { +#ifndef TCL_WIDE_INT_IS_LONG + if ((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) { Tcl_WideInt w1, w2, sum; - w1 = *((const Tcl_WideInt *)ptr1); - w2 = *((const Tcl_WideInt *)ptr2); + TclGetWideIntFromObj(NULL, valuePtr, &w1); + TclGetWideIntFromObj(NULL, incrPtr, &w2); sum = w1 + w2; /* * Check for overflow. */ if (!Overflowing(w1, w2, sum)) { - TclSetIntObj(valuePtr, sum); + Tcl_SetWideIntObj(valuePtr, sum); return TCL_OK; } } +#endif Tcl_TakeBignumFromObj(interp, valuePtr, &value); Tcl_GetBignumFromObj(interp, incrPtr, &incr); mp_add(&value, &incr, &value); mp_clear(&incr); @@ -1866,11 +2038,11 @@ int size = sizeof(TEBCdata) - 1 + (codePtr->maxStackDepth + codePtr->maxExceptDepth) * sizeof(void *); int numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *); - TclPreserveByteCode(codePtr); + codePtr->refCount++; /* * Reserve the stack, setup the TEBCdataPtr (TD) and CallFrame * * The execution uses a unified stack: first a TEBCdata, immediately @@ -1922,11 +2094,18 @@ /* * Push the callback for bytecode execution */ TclNRAddCallback(interp, TEBCresume, TD, /* pc */ NULL, - /* cleanup */ INT2PTR(0), NULL); + /* cleanup */ INT2PTR(0), INT2PTR(iPtr->evalFlags)); + + /* + * Reset discard result flag - because it is applicable for this call only, + * and should not affect all the nested invocations may return result. + */ + iPtr->evalFlags &= ~TCL_EVAL_DISCARD_RESULT; + return TCL_OK; } static int TEBCresume( @@ -1955,18 +2134,12 @@ /* * Constants: variables that do not change during the execution, used * sporadically: no special need for speed. */ - unsigned interruptCounter = 1; - /* Counter that is used to work out when to - * call Tcl_AsyncReady(). This must be 1 - * initially so that we call the async-check - * stanza early, otherwise there are command - * sequences that can make the interpreter - * busy-loop without an opportunity to - * recognise an interrupt. */ + int instructionCount = 0; /* Counter that is used to work out when to + * call Tcl_AsyncReady() */ const char *curInstName; #ifdef TCL_COMPILE_DEBUG int traceInstructions; /* Whether we are doing instruction-level * tracing or not. */ #endif @@ -1984,10 +2157,11 @@ TEBCdata *TD = data[0]; #define auxObjList (TD->auxObjList) #define catchTop (TD->catchTop) #define codePtr (TD->codePtr) +#define curEvalFlags PTR2INT(data[3]) /* calling iPtr->evalFlags */ /* * Globals: variables that store state, must remain valid at all times. */ @@ -2002,21 +2176,21 @@ * executing an instruction. */ int cleanup = PTR2INT(data[2]); Tcl_Obj *objResultPtr; - int checkInterp; /* Indicates when a check of interp readyness + int checkInterp = 0; /* Indicates when a check of interp readyness * is necessary. Set by CACHE_STACK_INFO() */ /* * Locals - variables that are used within opcodes or bounded sections of * the file (jumps between opcodes within a family). * NOTE: These are now mostly defined locally where needed. */ Tcl_Obj *objPtr, *valuePtr, *value2Ptr, *part1Ptr, *part2Ptr, *tmpPtr; - Tcl_Obj **objv; + Tcl_Obj **objv = NULL; int objc = 0; int opnd, length, pcAdjustment; Var *varPtr, *arrayPtr; #ifdef TCL_COMPILE_DEBUG char cmdNameBuf[21]; @@ -2037,12 +2211,27 @@ } #endif if (!pc) { /* bytecode is starting from scratch */ - checkInterp = 0; pc = codePtr->codeStart; + + /* + * Reset the interp's result to avoid possible duplications of large + * objects [3c6e47363e], [781585], [804681], This can happen by start + * also in nested compiled blocks (enclosed in parent cycle). + * See else branch below for opposite handling by continuation/resume. + */ + + objPtr = iPtr->objResultPtr; + if (objPtr->refCount > 1) { + TclDecrRefCount(objPtr); + TclNewObj(objPtr); + Tcl_IncrRefCount(objPtr); + iPtr->objResultPtr = objPtr; + } + goto cleanup0; } else { /* resume from invocation */ CACHE_STACK_INFO(); @@ -2059,12 +2248,13 @@ if (iPtr->execEnvPtr->rewind) { result = TCL_ERROR; goto abnormalReturn; } if (codePtr->flags & TCL_BYTECODE_RECOMPILE) { - iPtr->flags |= ERR_ALREADY_LOGGED; codePtr->flags &= ~TCL_BYTECODE_RECOMPILE; + checkInterp = 1; + iPtr->flags |= ERR_ALREADY_LOGGED; } if (result != TCL_OK) { pc--; goto processExceptionReturn; @@ -2077,11 +2267,11 @@ TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=", objc, cmdNameBuf), Tcl_GetObjResult(interp)); /* - * Reset the interp's result to avoid possible duplications of large + * Obtain and reset interp's result to avoid possible duplications of * objects [Bug 781585]. We do not call Tcl_ResetResult to avoid any * side effects caused by the resetting of errorInfo and errorCode * [Bug 804681], which are not needed here. We chose instead to * manipulate the interp's object result directly. * @@ -2120,14 +2310,16 @@ cleanup -= 2; while (cleanup--) { objPtr = POP_OBJECT(); TclDecrRefCount(objPtr); } + /* FALLTHRU */ case 2: cleanup2_pushObjResultPtr: objPtr = POP_OBJECT(); TclDecrRefCount(objPtr); + /* FALLTHRU */ case 1: cleanup1_pushObjResultPtr: objPtr = OBJ_AT_TOS; TclDecrRefCount(objPtr); } @@ -2140,18 +2332,21 @@ cleanup -= 2; while (cleanup--) { objPtr = POP_OBJECT(); TclDecrRefCount(objPtr); } + /* FALLTHRU */ case 2: cleanup2: objPtr = POP_OBJECT(); TclDecrRefCount(objPtr); + /* FALLTHRU */ case 1: cleanup1: objPtr = POP_OBJECT(); TclDecrRefCount(objPtr); + /* FALLTHRU */ case 0: /* * We really want to do nothing now, but this is needed for some * compilers (SunPro CC). */ @@ -2160,15 +2355,14 @@ } cleanup0: /* * Check for asynchronous handlers [Bug 746722]; we do the check every - * ASYNC_CHECK_COUNT instructions. + * ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-1). */ - if ((--interruptCounter) == 0) { - interruptCounter = ASYNC_CHECK_COUNT; + if ((instructionCount++ & ASYNC_CHECK_COUNT_MASK) == 0) { DECACHE_STACK_INFO(); if (TclAsyncReady(iPtr)) { result = Tcl_AsyncInvoke(interp, result); if (result == TCL_ERROR) { CACHE_STACK_INFO(); @@ -2235,16 +2429,16 @@ * Peephole: do not run INST_START_CMD, just skip it */ iPtr->cmdCount += TclGetUInt4AtPtr(pc+5); if (checkInterp) { - checkInterp = 0; if (((codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsEpoch != iPtr->varFramePtr->nsPtr->resolverEpoch)) && !(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { goto instStartCmdFailed; } + checkInterp = 0; } inst = *(pc += 9); goto peepholeStart; } else if (inst == INST_NOP) { #ifndef TCL_COMPILE_DEBUG @@ -2378,11 +2572,11 @@ TRACE(("[%.30s] => YIELD...\n", O2S(valuePtr))); } else { /* FIXME: What is the right thing to trace? */ fprintf(stdout, "%d: (%u) yielding to [%.30s]\n", iPtr->numLevels, (unsigned)(pc - codePtr->codeStart), - TclGetString(valuePtr)); + Tcl_GetString(valuePtr)); } fflush(stdout); } #endif @@ -2467,10 +2661,18 @@ goto processExceptionReturn; } case INST_DONE: if (tosPtr > initTosPtr) { + + if ((curEvalFlags & TCL_EVAL_DISCARD_RESULT) && (result == TCL_OK)) { + /* simulate pop & fast done (like it does continue in loop) */ + TRACE_WITH_OBJ(("=> discarding "), OBJ_AT_TOS); + objPtr = POP_OBJECT(); + TclDecrRefCount(objPtr); + goto abnormalReturn; + } /* * Set the interpreter's object result to point to the topmost * object from the stack, and check for a possible [catch]. The * stackTop's level and refCount will be handled by "processCatch" * or "abnormalReturn". @@ -2491,27 +2693,31 @@ case INST_PUSH4: objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)]; TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), objResultPtr); NEXT_INST_F(5, 0, 1); + break; case INST_POP: TRACE_WITH_OBJ(("=> discarding "), OBJ_AT_TOS); objPtr = POP_OBJECT(); TclDecrRefCount(objPtr); NEXT_INST_F(1, 0, 0); + break; case INST_DUP: objResultPtr = OBJ_AT_TOS; TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); + break; case INST_OVER: opnd = TclGetUInt4AtPtr(pc+1); objResultPtr = OBJ_AT_DEPTH(opnd); TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); NEXT_INST_F(5, 0, 1); + break; case INST_REVERSE: { Tcl_Obj **a, **b; opnd = TclGetUInt4AtPtr(pc+1); @@ -2524,23 +2730,160 @@ a++; b--; } TRACE(("%u => OK\n", opnd)); NEXT_INST_F(5, 0, 0); } + break; - case INST_STR_CONCAT1: + case INST_STR_CONCAT1: { + int appendLen = 0; + char *bytes, *p; + Tcl_Obj **currPtr; + int onlyb = 1; opnd = TclGetUInt1AtPtr(pc+1); - objResultPtr = TclStringCat(interp, opnd, &OBJ_AT_DEPTH(opnd-1), - TCL_STRING_IN_PLACE); - if (objResultPtr == NULL) { - TRACE_ERROR(interp); - goto gotError; + + /* + * Detect only-bytearray-or-null case. + */ + + for (currPtr=&OBJ_AT_DEPTH(opnd-1); currPtr<=&OBJ_AT_TOS; currPtr++) { + if (((*currPtr)->typePtr != &tclByteArrayType) + && ((*currPtr)->bytes != tclEmptyStringRep)) { + onlyb = 0; + break; + } else if (((*currPtr)->typePtr == &tclByteArrayType) && + ((*currPtr)->bytes != NULL)) { + onlyb = 0; + break; + } + } + + /* + * Compute the length to be appended. + */ + + if (onlyb) { + for (currPtr = &OBJ_AT_DEPTH(opnd-2); + appendLen >= 0 && currPtr <= &OBJ_AT_TOS; currPtr++) { + if ((*currPtr)->bytes != tclEmptyStringRep) { + Tcl_GetByteArrayFromObj(*currPtr, &length); + appendLen += length; + } + } + } else { + for (currPtr = &OBJ_AT_DEPTH(opnd-2); + appendLen >= 0 && currPtr <= &OBJ_AT_TOS; currPtr++) { + bytes = TclGetStringFromObj(*currPtr, &length); + if (bytes != NULL) { + appendLen += length; + } + } + } + + if (appendLen < 0) { + /* TODO: convert panic to error ? */ + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } + + /* + * If nothing is to be appended, just return the first object by + * dropping all the others from the stack; this saves both the + * computation and copy of the string rep of the first object, + * enabling the fast '$x[set x {}]' idiom for 'K $x [set x {}]'. + */ + + if (appendLen == 0) { + TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); + NEXT_INST_V(2, (opnd-1), 0); + } + + /* + * If the first object is shared, we need a new obj for the result; + * otherwise, we can reuse the first object. In any case, make sure it + * has enough room to accomodate all the concatenated bytes. Note that + * if it is unshared its bytes are copied by ckrealloc, so that we set + * the loop parameters to avoid copying them again: p points to the + * end of the already copied bytes, currPtr to the second object. + */ + + objResultPtr = OBJ_AT_DEPTH(opnd-1); + if (!onlyb) { + bytes = TclGetStringFromObj(objResultPtr, &length); + if (length + appendLen < 0) { + /* TODO: convert panic to error ? */ + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", + INT_MAX); + } +#ifndef TCL_COMPILE_DEBUG + if (bytes != tclEmptyStringRep && !Tcl_IsShared(objResultPtr)) { + TclFreeIntRep(objResultPtr); + objResultPtr->bytes = ckrealloc(bytes, length+appendLen+1); + objResultPtr->length = length + appendLen; + p = TclGetString(objResultPtr) + length; + currPtr = &OBJ_AT_DEPTH(opnd - 2); + } else +#endif + { + p = ckalloc(length + appendLen + 1); + TclNewObj(objResultPtr); + objResultPtr->bytes = p; + objResultPtr->length = length + appendLen; + currPtr = &OBJ_AT_DEPTH(opnd - 1); + } + + /* + * Append the remaining characters. + */ + + for (; currPtr <= &OBJ_AT_TOS; currPtr++) { + bytes = TclGetStringFromObj(*currPtr, &length); + if (bytes != NULL) { + memcpy(p, bytes, length); + p += length; + } + } + *p = '\0'; + } else { + bytes = (char *) Tcl_GetByteArrayFromObj(objResultPtr, &length); + if (length + appendLen < 0) { + /* TODO: convert panic to error ? */ + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", + INT_MAX); + } +#ifndef TCL_COMPILE_DEBUG + if (!Tcl_IsShared(objResultPtr)) { + bytes = (char *) Tcl_SetByteArrayLength(objResultPtr, + length + appendLen); + p = bytes + length; + currPtr = &OBJ_AT_DEPTH(opnd - 2); + } else +#endif + { + TclNewObj(objResultPtr); + bytes = (char *) Tcl_SetByteArrayLength(objResultPtr, + length + appendLen); + p = bytes; + currPtr = &OBJ_AT_DEPTH(opnd - 1); + } + + /* + * Append the remaining characters. + */ + + for (; currPtr <= &OBJ_AT_TOS; currPtr++) { + if ((*currPtr)->bytes != tclEmptyStringRep) { + bytes = (char *) Tcl_GetByteArrayFromObj(*currPtr,&length); + memcpy(p, bytes, length); + p += length; + } + } } TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); NEXT_INST_V(2, opnd, 1); + } case INST_CONCAT_STK: /* * Pop the opnd (objc) top stack elements, run through Tcl_ConcatObj, * and then decrement their ref counts. @@ -2556,11 +2899,11 @@ * Push an element to the auxObjList. This records the current * stack depth - i.e., the point in the stack where the expanded * command starts. * * Use a Tcl_Obj as linked list element; slight mem waste, but faster - * allocation than Tcl_Alloc. This also abuses the Tcl_Obj structure, as + * allocation than ckalloc. This also abuses the Tcl_Obj structure, as * we do not define a special tclObjType for it. It is not dangerous * as the obj is never passed anywhere, so that all manipulations are * performed here and in INST_INVOKE_EXPANDED (in case of an expansion * error, also in INST_EXPAND_STKTOP). */ @@ -2569,10 +2912,11 @@ objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(CURR_DEPTH); objPtr->length = 0; PUSH_TAUX_OBJ(objPtr); TRACE(("=> mark depth as %d\n", (int) CURR_DEPTH)); NEXT_INST_F(1, 0, 0); + break; case INST_EXPAND_DROP: /* * Drops an element of the auxObjList, popping stack elements to * restore the stack to the state before the point where the aux @@ -2647,10 +2991,11 @@ TRACE_APPEND(("OK\n")); Tcl_DecrRefCount(objPtr); NEXT_INST_F(5, 0, 0); } + break; case INST_EXPR_STK: { ByteCode *newCodePtr; bcFramePtr->data.tebc.pc = (char *) pc; @@ -2666,19 +3011,22 @@ /* * INVOCATION BLOCK */ - instEvalStk: case INST_EVAL_STK: + instEvalStk: bcFramePtr->data.tebc.pc = (char *) pc; iPtr->cmdFramePtr = bcFramePtr; cleanup = 1; pc += 1; + /* yield next instruction */ TEBC_YIELD(); - return TclNREvalObjEx(interp, OBJ_AT_TOS, 0, NULL, 0); + /* add TEBCResume for object at top of stack */ + return TclNRExecuteByteCode(interp, + TclCompileObj(interp, OBJ_AT_TOS, NULL, 0)); case INST_INVOKE_EXPANDED: CLANG_ASSERT(auxObjList); objc = CURR_DEPTH - PTR2INT(auxObjList->internalRep.twoPtrValue.ptr2); POP_TAUX_OBJ(); @@ -2691,10 +3039,11 @@ * Nothing was expanded, return {}. */ TclNewObj(objResultPtr); NEXT_INST_F(1, 0, 1); + break; case INST_INVOKE_STK4: objc = TclGetUInt4AtPtr(pc+1); pcAdjustment = 5; goto doInvocation; @@ -2745,10 +3094,95 @@ pc += pcAdjustment; TEBC_YIELD(); return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR | TCL_EVAL_SOURCE_IN_FRAME, NULL); + +#if TCL_SUPPORT_84_BYTECODE + case INST_CALL_BUILTIN_FUNC1: + /* + * Call one of the built-in pre-8.5 Tcl math functions. This + * translates to INST_INVOKE_STK1 with the first argument of + * ::tcl::mathfunc::$objv[0]. We need to insert the named math + * function into the stack. + */ + + opnd = TclGetUInt1AtPtr(pc+1); + if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) { + TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd)); + Tcl_Panic("TclNRExecuteByteCode: unrecognized builtin function code %d", opnd); + } + + TclNewLiteralStringObj(objPtr, "::tcl::mathfunc::"); + Tcl_AppendToObj(objPtr, tclBuiltinFuncTable[opnd].name, -1); + + /* + * Only 0, 1 or 2 args. + */ + + { + int numArgs = tclBuiltinFuncTable[opnd].numArgs; + Tcl_Obj *tmpPtr1, *tmpPtr2; + + if (numArgs == 0) { + PUSH_OBJECT(objPtr); + } else if (numArgs == 1) { + tmpPtr1 = POP_OBJECT(); + PUSH_OBJECT(objPtr); + PUSH_OBJECT(tmpPtr1); + Tcl_DecrRefCount(tmpPtr1); + } else { + tmpPtr2 = POP_OBJECT(); + tmpPtr1 = POP_OBJECT(); + PUSH_OBJECT(objPtr); + PUSH_OBJECT(tmpPtr1); + PUSH_OBJECT(tmpPtr2); + Tcl_DecrRefCount(tmpPtr1); + Tcl_DecrRefCount(tmpPtr2); + } + objc = numArgs + 1; + } + pcAdjustment = 2; + goto doInvocation; + + case INST_CALL_FUNC1: + /* + * Call a non-builtin Tcl math function previously registered by a + * call to Tcl_CreateMathFunc pre-8.5. This is essentially + * INST_INVOKE_STK1 converting the first arg to + * ::tcl::mathfunc::$objv[0]. + */ + + objc = TclGetUInt1AtPtr(pc+1); /* Number of arguments. The function + * name is the 0-th argument. */ + + objPtr = OBJ_AT_DEPTH(objc-1); + TclNewLiteralStringObj(tmpPtr, "::tcl::mathfunc::"); + Tcl_AppendObjToObj(tmpPtr, objPtr); + Tcl_DecrRefCount(objPtr); + + /* + * Variation of PUSH_OBJECT. + */ + + OBJ_AT_DEPTH(objc-1) = tmpPtr; + Tcl_IncrRefCount(tmpPtr); + + pcAdjustment = 2; + goto doInvocation; +#else + /* + * INST_CALL_BUILTIN_FUNC1 and INST_CALL_FUNC1 were made obsolete by the + * changes to add a ::tcl::mathfunc namespace in 8.5. Optional support + * remains for existing bytecode precompiled files. + */ + + case INST_CALL_BUILTIN_FUNC1: + Tcl_Panic("TclNRExecuteByteCode: obsolete INST_CALL_BUILTIN_FUNC1 found"); + case INST_CALL_FUNC1: + Tcl_Panic("TclNRExecuteByteCode: obsolete INST_CALL_FUNC1 found"); +#endif case INST_INVOKE_REPLACE: objc = TclGetUInt4AtPtr(pc+1); opnd = TclGetUInt1AtPtr(pc+5); objPtr = POP_OBJECT(); @@ -3390,11 +3824,13 @@ /*TODO: Consider more untangling here; merge with LOAD and STORE ? */ { Tcl_Obj *incrPtr; +#ifndef TCL_WIDE_INT_IS_LONG Tcl_WideInt w; +#endif long increment; case INST_INCR_SCALAR1: case INST_INCR_ARRAY1: case INST_INCR_ARRAY_STK: @@ -3416,11 +3852,11 @@ case INST_INCR_ARRAY_STK_IMM: case INST_INCR_SCALAR_STK_IMM: case INST_INCR_STK_IMM: increment = TclGetInt1AtPtr(pc+1); - incrPtr = Tcl_NewIntObj(increment); + TclNewIntObj(incrPtr, increment); Tcl_IncrRefCount(incrPtr); pcAdjustment = 2; doIncrStk: if ((*pc == INST_INCR_ARRAY_STK_IMM) @@ -3451,11 +3887,11 @@ goto doIncrVar; case INST_INCR_ARRAY1_IMM: opnd = TclGetUInt1AtPtr(pc+1); increment = TclGetInt1AtPtr(pc+2); - incrPtr = Tcl_NewIntObj(increment); + TclNewIntObj(incrPtr, increment); Tcl_IncrRefCount(incrPtr); pcAdjustment = 3; doIncrArray: part1Ptr = NULL; @@ -3489,13 +3925,13 @@ ClientData ptr; int type; objPtr = varPtr->value.objPtr; if (GetNumberFromObj(NULL, objPtr, &ptr, &type) == TCL_OK) { - if (type == TCL_NUMBER_INT) { - Tcl_WideInt augend = *((const Tcl_WideInt *)ptr); - Tcl_WideInt sum = augend + increment; + if (type == TCL_NUMBER_LONG) { + long augend = *((const long *)ptr); + long sum = augend + increment; /* * Overflow when (augend and sum have different sign) and * (augend and increment have the same sign). This is * encapsulated in the Overflowing macro. @@ -3503,19 +3939,20 @@ if (!Overflowing(augend, increment, sum)) { TRACE(("%u %ld => ", opnd, increment)); if (Tcl_IsShared(objPtr)) { objPtr->refCount--; /* We know it's shared. */ - TclNewIntObj(objResultPtr, sum); + TclNewLongObj(objResultPtr, sum); Tcl_IncrRefCount(objResultPtr); varPtr->value.objPtr = objResultPtr; } else { objResultPtr = objPtr; - TclSetIntObj(objPtr, sum); + TclSetLongObj(objPtr, sum); } goto doneIncr; } +#ifndef TCL_WIDE_INT_IS_LONG w = (Tcl_WideInt)augend; TRACE(("%u %ld => ", opnd, increment)); if (Tcl_IsShared(objPtr)) { objPtr->refCount--; /* We know it's shared. */ @@ -3528,24 +3965,58 @@ /* * We know the sum value is outside the long range; * use macro form that doesn't range test again. */ - TclSetIntObj(objPtr, w+increment); + TclSetWideIntObj(objPtr, w+increment); } goto doneIncr; - } /* end if (type == TCL_NUMBER_INT) */ +#endif + } /* end if (type == TCL_NUMBER_LONG) */ +#ifndef TCL_WIDE_INT_IS_LONG + if (type == TCL_NUMBER_WIDE) { + Tcl_WideInt sum; + + w = *((const Tcl_WideInt *) ptr); + sum = w + increment; + + /* + * Check for overflow. + */ + + if (!Overflowing(w, increment, sum)) { + TRACE(("%u %ld => ", opnd, increment)); + if (Tcl_IsShared(objPtr)) { + objPtr->refCount--; /* We know it's shared. */ + objResultPtr = Tcl_NewWideIntObj(sum); + Tcl_IncrRefCount(objResultPtr); + varPtr->value.objPtr = objResultPtr; + } else { + objResultPtr = objPtr; + + /* + * We *do not* know the sum value is outside the + * long range (wide + long can yield long); use + * the function call that checks range. + */ + + Tcl_SetWideIntObj(objPtr, sum); + } + goto doneIncr; + } + } +#endif } if (Tcl_IsShared(objPtr)) { objPtr->refCount--; /* We know it's shared */ objResultPtr = Tcl_DuplicateObj(objPtr); Tcl_IncrRefCount(objResultPtr); varPtr->value.objPtr = objResultPtr; } else { objResultPtr = objPtr; } - TclNewIntObj(incrPtr, increment); + TclNewLongObj(incrPtr, increment); if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) { Tcl_DecrRefCount(incrPtr); TRACE_ERROR(interp); goto gotError; } @@ -3555,11 +4026,11 @@ /* * All other cases, flow through to generic handling. */ - TclNewIntObj(incrPtr, increment); + TclNewLongObj(incrPtr, increment); Tcl_IncrRefCount(incrPtr); doIncrScalar: varPtr = LOCAL(opnd); while (TclIsVarLink(varPtr)) { @@ -3566,11 +4037,11 @@ varPtr = varPtr->value.linkPtr; } arrayPtr = NULL; part1Ptr = part2Ptr = NULL; cleanup = 0; - TRACE(("%u %s => ", opnd, TclGetString(incrPtr))); + TRACE(("%u %s => ", opnd, Tcl_GetString(incrPtr))); doIncrVar: if (TclIsVarDirectModifyable2(varPtr, arrayPtr)) { objPtr = varPtr->value.objPtr; if (Tcl_IsShared(objPtr)) { @@ -3833,11 +4304,35 @@ errorInUnset: CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; + + /* + * This is really an unset operation these days. Do not issue. + */ + + case INST_DICT_DONE: + opnd = TclGetUInt4AtPtr(pc+1); + TRACE(("%u => OK\n", opnd)); + varPtr = LOCAL(opnd); + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + if (TclIsVarDirectUnsettable(varPtr) && !TclIsVarInHash(varPtr)) { + if (!TclIsVarUndefined(varPtr)) { + TclDecrRefCount(varPtr->value.objPtr); + } + varPtr->value.objPtr = NULL; + } else { + DECACHE_STACK_INFO(); + TclPtrUnsetVarIdx(interp, varPtr, NULL, NULL, NULL, 0, opnd); + CACHE_STACK_INFO(); + } + NEXT_INST_F(5, 0, 0); } + break; /* * End of INST_UNSET instructions. * ----------------------------------------------------------------- * Start of INST_ARRAY instructions. @@ -3916,11 +4411,14 @@ Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; } - TclInitArrayVar(varPtr); + TclSetVarArray(varPtr); + varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable)); + TclInitVarHashTable(varPtr->value.tablePtr, + TclGetVarNsPtr(varPtr)); #ifdef TCL_COMPILE_DEBUG TRACE_APPEND(("done\n")); } else { TRACE_APPEND(("nothing to do\n")); #endif @@ -4051,10 +4549,11 @@ */ TRACE_APPEND(("link made\n")); NEXT_INST_F(5, 1, 0); } + break; /* * End of variable linking instructions. * ----------------------------------------------------------------- */ @@ -4062,10 +4561,11 @@ case INST_JUMP1: opnd = TclGetInt1AtPtr(pc+1); TRACE(("%d => new pc %u\n", opnd, (unsigned)(pc + opnd - codePtr->codeStart))); NEXT_INST_F(opnd, 0, 0); + break; case INST_JUMP4: opnd = TclGetInt4AtPtr(pc+1); TRACE(("%d => new pc %u\n", opnd, (unsigned)(pc + opnd - codePtr->codeStart))); @@ -4124,10 +4624,11 @@ } } #endif NEXT_INST_F(jmpOffset[b], 1, 0); } + break; case INST_JUMP_TABLE: { Tcl_HashEntry *hPtr; JumptableInfo *jtPtr; @@ -4149,10 +4650,56 @@ } else { TRACE_APPEND(("not found in table\n")); NEXT_INST_F(5, 1, 0); } } + break; + + /* + * These two instructions are now redundant: the complete logic of the LOR + * and LAND is now handled by the expression compiler. + */ + + case INST_LOR: + case INST_LAND: { + /* + * Operands must be boolean or numeric. No int->double conversions are + * performed. + */ + + int i1, i2, iResult; + + value2Ptr = OBJ_AT_TOS; + valuePtr = OBJ_UNDER_TOS; + if (TclGetBooleanFromObj(NULL, valuePtr, &i1) != TCL_OK) { + TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), + (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); + DECACHE_STACK_INFO(); + IllegalExprOperandType(interp, pc, valuePtr); + CACHE_STACK_INFO(); + goto gotError; + } + + if (TclGetBooleanFromObj(NULL, value2Ptr, &i2) != TCL_OK) { + TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr), + (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); + DECACHE_STACK_INFO(); + IllegalExprOperandType(interp, pc, value2Ptr); + CACHE_STACK_INFO(); + goto gotError; + } + + if (*pc == INST_LOR) { + iResult = (i1 || i2); + } else { + iResult = (i1 && i2); + } + objResultPtr = TCONST(iResult); + TRACE(("%.20s %.20s => %d\n", O2S(valuePtr),O2S(value2Ptr),iResult)); + NEXT_INST_F(1, 2, 1); + } + break; /* * ----------------------------------------------------------------- * Start of general introspector instructions. */ @@ -4167,10 +4714,11 @@ strlen(currNsPtr->fullName)); } TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); } + break; case INST_COROUTINE_NAME: { CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; TclNewObj(objResultPtr); if (corPtr && !(corPtr->cmdPtr->flags & CMD_IS_DELETED)) { @@ -4178,14 +4726,16 @@ objResultPtr); } TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); } + break; case INST_INFO_LEVEL_NUM: TclNewIntObj(objResultPtr, iPtr->varFramePtr->level); TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); + break; case INST_INFO_LEVEL_ARGS: { int level; CallFrame *framePtr = iPtr->varFramePtr; CallFrame *rootFramePtr = iPtr->rootFramePtr; @@ -4527,12 +5077,12 @@ * ----------------------------------------------------------------- * Start of INST_LIST and related instructions. */ { - int numIndices, nocase, match, cflags; - size_t slength, length2, fromIdx, toIdx, index, s1len, s2len; + int index, numIndices, fromIdx, toIdx; + int nocase, match, length2, cflags, s1len, s2len; const char *s1, *s2; case INST_LIST: /* * Pop the opnd (objc) top stack elements into a new list obj and then @@ -4562,12 +5112,12 @@ /* * Extract the desired list element. */ if ((TclListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK) - && !TclHasIntRep(value2Ptr, &tclListType) - && (TclGetIntForIndexM(NULL, value2Ptr, objc-1, + && (value2Ptr->typePtr != &tclListType) + && (TclGetIntForIndexM(NULL , value2Ptr, objc-1, &index) == TCL_OK)) { TclDecrRefCount(value2Ptr); tosPtr--; pcAdjustment = 1; goto lindexFastPath; @@ -4611,11 +5161,11 @@ index = TclIndexDecode(opnd, objc - 1); pcAdjustment = 5; lindexFastPath: - if (index < (size_t)objc) { + if (index >= 0 && index < objc) { objResultPtr = objv[index]; } else { TclNewObj(objResultPtr); } @@ -4735,15 +5285,15 @@ toIdx = TclGetInt4AtPtr(pc+5); TRACE(("\"%.30s\" %d %d => ", O2S(valuePtr), TclGetInt4AtPtr(pc+1), TclGetInt4AtPtr(pc+5))); /* - * Get the length of the list, making sure that it really is a list + * Get the contents of the list, making sure that it really is a list * in the process. */ - if (TclListObjLength(interp, valuePtr, &objc) != TCL_OK) { + if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } /* @@ -4767,36 +5317,62 @@ goto emptyList; } /* Decode index value operands. */ - if (toIdx == TCL_INDEX_NONE) { - emptyList: - objResultPtr = Tcl_NewObj(); - TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr))); - NEXT_INST_F(9, 1, 1); + /* + assert ( toIdx != TCL_INDEX_AFTER); + * + * Extra safety for legacy bytecodes: + */ + if (toIdx == TCL_INDEX_AFTER) { + toIdx = TCL_INDEX_END; + } + + if ((toIdx == TCL_INDEX_BEFORE) || (fromIdx == TCL_INDEX_AFTER)) { + goto emptyList; } toIdx = TclIndexDecode(toIdx, objc - 1); - if (toIdx == TCL_INDEX_NONE) { + if (toIdx < 0) { goto emptyList; - } else if (toIdx + 1 >= (size_t)objc + 1) { + } else if (toIdx >= objc) { toIdx = objc - 1; } - assert (toIdx < (size_t)objc); + assert ( toIdx >= 0 && toIdx < objc); /* - assert ( fromIdx != TCL_INDEX_NONE ); + assert ( fromIdx != TCL_INDEX_BEFORE ); * * Extra safety for legacy bytecodes: */ - if (fromIdx == TCL_INDEX_NONE) { + if (fromIdx == TCL_INDEX_BEFORE) { fromIdx = TCL_INDEX_START; } fromIdx = TclIndexDecode(fromIdx, objc - 1); + if (fromIdx < 0) { + fromIdx = 0; + } - objResultPtr = TclListObjRange(valuePtr, fromIdx, toIdx); + if (fromIdx <= toIdx) { + /* Construct the subsquence list */ + /* unshared optimization */ + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewListObj(toIdx-fromIdx+1, objv+fromIdx); + } else { + if (toIdx != objc - 1) { + Tcl_ListObjReplace(NULL, valuePtr, toIdx + 1, LIST_MAX, + 0, NULL); + } + Tcl_ListObjReplace(NULL, valuePtr, 0, fromIdx, 0, NULL); + TRACE_APPEND(("%.30s\n", O2S(valuePtr))); + NEXT_INST_F(9, 0, 0); + } + } else { + emptyList: + TclNewObj(objResultPtr); + } TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr))); NEXT_INST_F(9, 1, 1); case INST_LIST_IN: @@ -4878,14 +5454,10 @@ */ case INST_STR_EQ: case INST_STR_NEQ: /* String (in)equality check */ case INST_STR_CMP: /* String compare. */ - case INST_STR_LT: - case INST_STR_GT: - case INST_STR_LE: - case INST_STR_GE: stringCompare: value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; { @@ -4912,23 +5484,19 @@ case INST_STR_NEQ: case INST_NEQ: match = (match != 0); break; case INST_LT: - case INST_STR_LT: match = (match < 0); break; case INST_GT: - case INST_STR_GT: match = (match > 0); break; case INST_LE: - case INST_STR_LE: match = (match <= 0); break; case INST_GE: - case INST_STR_GE: match = (match >= 0); break; } } @@ -4936,62 +5504,62 @@ (match < 0 ? -1 : match > 0 ? 1 : 0))); JUMP_PEEPHOLE_F(match, 1, 2); case INST_STR_LEN: valuePtr = OBJ_AT_TOS; - slength = Tcl_GetCharLength(valuePtr); - objResultPtr = TclNewWideIntObjFromSize(slength); - TRACE(("\"%.20s\" => %" TCL_Z_MODIFIER "u\n", O2S(valuePtr), slength)); + length = Tcl_GetCharLength(valuePtr); + TclNewIntObj(objResultPtr, length); + TRACE(("\"%.20s\" => %d\n", O2S(valuePtr), length)); NEXT_INST_F(1, 1, 1); case INST_STR_UPPER: valuePtr = OBJ_AT_TOS; TRACE(("\"%.20s\" => ", O2S(valuePtr))); if (Tcl_IsShared(valuePtr)) { - s1 = TclGetStringFromObj(valuePtr, &slength); - TclNewStringObj(objResultPtr, s1, slength); - slength = Tcl_UtfToUpper(TclGetString(objResultPtr)); - Tcl_SetObjLength(objResultPtr, slength); + s1 = TclGetStringFromObj(valuePtr, &length); + TclNewStringObj(objResultPtr, s1, length); + length = Tcl_UtfToUpper(TclGetString(objResultPtr)); + Tcl_SetObjLength(objResultPtr, length); TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } else { - slength = Tcl_UtfToUpper(TclGetString(valuePtr)); - Tcl_SetObjLength(valuePtr, slength); + length = Tcl_UtfToUpper(TclGetString(valuePtr)); + Tcl_SetObjLength(valuePtr, length); TclFreeIntRep(valuePtr); TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } case INST_STR_LOWER: valuePtr = OBJ_AT_TOS; TRACE(("\"%.20s\" => ", O2S(valuePtr))); if (Tcl_IsShared(valuePtr)) { - s1 = TclGetStringFromObj(valuePtr, &slength); - TclNewStringObj(objResultPtr, s1, slength); - slength = Tcl_UtfToLower(TclGetString(objResultPtr)); - Tcl_SetObjLength(objResultPtr, slength); + s1 = TclGetStringFromObj(valuePtr, &length); + TclNewStringObj(objResultPtr, s1, length); + length = Tcl_UtfToLower(TclGetString(objResultPtr)); + Tcl_SetObjLength(objResultPtr, length); TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } else { - slength = Tcl_UtfToLower(TclGetString(valuePtr)); - Tcl_SetObjLength(valuePtr, slength); + length = Tcl_UtfToLower(TclGetString(valuePtr)); + Tcl_SetObjLength(valuePtr, length); TclFreeIntRep(valuePtr); TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } case INST_STR_TITLE: valuePtr = OBJ_AT_TOS; TRACE(("\"%.20s\" => ", O2S(valuePtr))); if (Tcl_IsShared(valuePtr)) { - s1 = TclGetStringFromObj(valuePtr, &slength); - TclNewStringObj(objResultPtr, s1, slength); - slength = Tcl_UtfToTitle(TclGetString(objResultPtr)); - Tcl_SetObjLength(objResultPtr, slength); + s1 = TclGetStringFromObj(valuePtr, &length); + TclNewStringObj(objResultPtr, s1, length); + length = Tcl_UtfToTitle(TclGetString(objResultPtr)); + Tcl_SetObjLength(objResultPtr, length); TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } else { - slength = Tcl_UtfToTitle(TclGetString(valuePtr)); - Tcl_SetObjLength(valuePtr, slength); + length = Tcl_UtfToTitle(TclGetString(valuePtr)); + Tcl_SetObjLength(valuePtr, length); TclFreeIntRep(valuePtr); TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } @@ -5002,66 +5570,54 @@ /* * Get char length to calulate what 'end' means. */ - slength = Tcl_GetCharLength(valuePtr); - if (TclGetIntForIndexM(interp, value2Ptr, slength-1, &index)!=TCL_OK) { + length = Tcl_GetCharLength(valuePtr); + if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) { TRACE_ERROR(interp); goto gotError; } - if (index >= slength) { + if ((index < 0) || (index >= length)) { TclNewObj(objResultPtr); } else if (TclIsPureByteArray(valuePtr)) { objResultPtr = Tcl_NewByteArrayObj( Tcl_GetByteArrayFromObj(valuePtr, NULL)+index, 1); - } else if (valuePtr->bytes && slength == valuePtr->length) { + } else if (valuePtr->bytes && length == valuePtr->length) { objResultPtr = Tcl_NewStringObj((const char *) valuePtr->bytes+index, 1); } else { - char buf[4] = ""; - int ch = Tcl_GetUniChar(valuePtr, index); - - /* - * This could be: Tcl_NewUnicodeObj((const Tcl_UniChar *)&ch, 1) - * but creating the object as a string seems to be faster in - * practical use. - */ - if (ch == -1) { - objResultPtr = Tcl_NewObj(); - } else { - slength = Tcl_UniCharToUtf(ch, buf); - if ((ch >= 0xD800) && (slength < 3)) { - slength += Tcl_UniCharToUtf(-1, buf + slength); - } - objResultPtr = Tcl_NewStringObj(buf, slength); - } + char buf[8] = ""; + int ch = TclGetUCS4(valuePtr, index); + + length = TclUCS4ToUtf(ch, buf); + objResultPtr = Tcl_NewStringObj(buf, length); } TRACE_APPEND(("\"%s\"\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); case INST_STR_RANGE: TRACE(("\"%.20s\" %.20s %.20s =>", O2S(OBJ_AT_DEPTH(2)), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS))); - slength = Tcl_GetCharLength(OBJ_AT_DEPTH(2)) - 1; - if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, slength, + length = Tcl_GetCharLength(OBJ_AT_DEPTH(2)) - 1; + if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length, &fromIdx) != TCL_OK - || TclGetIntForIndexM(interp, OBJ_AT_TOS, slength, + || TclGetIntForIndexM(interp, OBJ_AT_TOS, length, &toIdx) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } - if (fromIdx == TCL_INDEX_NONE) { - fromIdx = TCL_INDEX_START; + if (fromIdx < 0) { + fromIdx = 0; } - if (toIdx + 1 >= slength + 1) { - toIdx = slength; + if (toIdx >= length) { + toIdx = length; } - if (toIdx + 1 >= fromIdx + 1) { + if (toIdx >= fromIdx) { objResultPtr = Tcl_GetRange(OBJ_AT_DEPTH(2), fromIdx, toIdx); } else { TclNewObj(objResultPtr); } TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); @@ -5069,54 +5625,62 @@ case INST_STR_RANGE_IMM: valuePtr = OBJ_AT_TOS; fromIdx = TclGetInt4AtPtr(pc+1); toIdx = TclGetInt4AtPtr(pc+5); - slength = Tcl_GetCharLength(valuePtr); - TRACE(("\"%.20s\" %" TCL_LL_MODIFIER "d %" TCL_LL_MODIFIER "d => ", O2S(valuePtr), TclWideIntFromSize(fromIdx), TclWideIntFromSize(toIdx))); + length = Tcl_GetCharLength(valuePtr); + TRACE(("\"%.20s\" %d %d => ", O2S(valuePtr), fromIdx, toIdx)); /* Every range of an empty value is an empty value */ - if (slength == 0) { + if (length == 0) { TRACE_APPEND(("\n")); NEXT_INST_F(9, 0, 0); } /* Decode index operands. */ /* - assert ( toIdx != TCL_INDEX_NONE ); - * - * Extra safety for legacy bytecodes: - */ - if (toIdx == TCL_INDEX_NONE) { - goto emptyRange; - } - - toIdx = TclIndexDecode(toIdx, slength - 1); - if (toIdx == TCL_INDEX_NONE) { - goto emptyRange; - } else if (toIdx >= slength) { - toIdx = slength - 1; - } - - assert ( toIdx != TCL_INDEX_NONE && toIdx < slength ); - - /* - assert ( fromIdx != TCL_INDEX_NONE ); - * - * Extra safety for legacy bytecodes: - */ - if (fromIdx == TCL_INDEX_NONE) { - fromIdx = TCL_INDEX_START; - } - - fromIdx = TclIndexDecode(fromIdx, slength - 1); - if (fromIdx == TCL_INDEX_NONE) { - fromIdx = TCL_INDEX_START; - } - - if (fromIdx + 1 <= toIdx + 1) { + assert ( toIdx != TCL_INDEX_BEFORE ); + assert ( toIdx != TCL_INDEX_AFTER); + * + * Extra safety for legacy bytecodes: + */ + if (toIdx == TCL_INDEX_BEFORE) { + goto emptyRange; + } + if (toIdx == TCL_INDEX_AFTER) { + toIdx = TCL_INDEX_END; + } + + toIdx = TclIndexDecode(toIdx, length - 1); + if (toIdx < 0) { + goto emptyRange; + } else if (toIdx >= length) { + toIdx = length - 1; + } + + assert ( toIdx >= 0 && toIdx < length ); + + /* + assert ( fromIdx != TCL_INDEX_BEFORE ); + assert ( fromIdx != TCL_INDEX_AFTER); + * + * Extra safety for legacy bytecodes: + */ + if (fromIdx == TCL_INDEX_BEFORE) { + fromIdx = TCL_INDEX_START; + } + if (fromIdx == TCL_INDEX_AFTER) { + goto emptyRange; + } + + fromIdx = TclIndexDecode(fromIdx, length - 1); + if (fromIdx < 0) { + fromIdx = 0; + } + + if (fromIdx <= toIdx) { objResultPtr = Tcl_GetRange(valuePtr, fromIdx, toIdx); } else { emptyRange: TclNewObj(objResultPtr); } @@ -5123,22 +5687,22 @@ TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_F(9, 1, 1); { Tcl_UniChar *ustring1, *ustring2, *ustring3, *end, *p; - size_t length3; + int length3, endIdx; Tcl_Obj *value3Ptr; case INST_STR_REPLACE: value3Ptr = POP_OBJECT(); valuePtr = OBJ_AT_DEPTH(2); - slength = Tcl_GetCharLength(valuePtr) - 1; + endIdx = Tcl_GetCharLength(valuePtr) - 1; TRACE(("\"%.20s\" %s %s \"%.20s\" => ", O2S(valuePtr), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(value3Ptr))); - if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, slength, + if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, endIdx, &fromIdx) != TCL_OK - || TclGetIntForIndexM(interp, OBJ_AT_TOS, slength, + || TclGetIntForIndexM(interp, OBJ_AT_TOS, endIdx, &toIdx) != TCL_OK) { TclDecrRefCount(value3Ptr); TRACE_ERROR(interp); goto gotError; } @@ -5145,36 +5709,109 @@ TclDecrRefCount(OBJ_AT_TOS); (void) POP_OBJECT(); TclDecrRefCount(OBJ_AT_TOS); (void) POP_OBJECT(); - if ((toIdx == TCL_INDEX_NONE) || - (fromIdx + 1 > slength + 1) || - (toIdx + 1 < fromIdx + 1)) { + if ((toIdx < 0) || + (fromIdx > endIdx) || + (toIdx < fromIdx)) { TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); TclDecrRefCount(value3Ptr); NEXT_INST_F(1, 0, 0); } - if (fromIdx == TCL_INDEX_NONE) { - fromIdx = TCL_INDEX_START; + if (fromIdx < 0) { + fromIdx = 0; } - if (toIdx + 1 > slength + 1) { - toIdx = slength; + if (toIdx > endIdx) { + toIdx = endIdx; } - if ((fromIdx == TCL_INDEX_START) && (toIdx == slength)) { + if (fromIdx == 0 && toIdx == endIdx) { TclDecrRefCount(OBJ_AT_TOS); OBJ_AT_TOS = value3Ptr; TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr))); NEXT_INST_F(1, 0, 0); } - objResultPtr = TclStringReplace(interp, valuePtr, fromIdx, - toIdx - fromIdx + 1, value3Ptr, TCL_STRING_IN_PLACE); + length3 = Tcl_GetCharLength(value3Ptr); + /* + * See if we can splice in place. This happens when the number of + * characters being replaced is the same as the number of characters + * in the string to be inserted. + */ + + if (length3 - 1 == toIdx - fromIdx) { + unsigned char *bytes1, *bytes2; + + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_DuplicateObj(valuePtr); + } else { + objResultPtr = valuePtr; + } + if (TclIsPureByteArray(objResultPtr) + && TclIsPureByteArray(value3Ptr)) { + bytes1 = Tcl_GetByteArrayFromObj(objResultPtr, NULL); + bytes2 = Tcl_GetByteArrayFromObj(value3Ptr, NULL); + memcpy(bytes1 + fromIdx, bytes2, length3); + } else { + ustring1 = Tcl_GetUnicodeFromObj(objResultPtr, NULL); + ustring2 = Tcl_GetUnicodeFromObj(value3Ptr, NULL); + memcpy(ustring1 + fromIdx, ustring2, + length3 * sizeof(Tcl_UniChar)); + } + Tcl_InvalidateStringRep(objResultPtr); + TclDecrRefCount(value3Ptr); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); + if (objResultPtr == valuePtr) { + NEXT_INST_F(1, 0, 0); + } else { + NEXT_INST_F(1, 1, 1); + } + } + + /* + * Get the unicode representation; this is where we guarantee to lose + * bytearrays. + */ + + ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length); + length--; + + /* + * Remove substring using copying. + */ + + objResultPtr = NULL; + if (fromIdx > 0) { + objResultPtr = Tcl_NewUnicodeObj(ustring1, fromIdx); + } + if (length3 > 0) { + if (objResultPtr) { + Tcl_AppendObjToObj(objResultPtr, value3Ptr); + } else if (Tcl_IsShared(value3Ptr)) { + objResultPtr = Tcl_DuplicateObj(value3Ptr); + } else { + objResultPtr = value3Ptr; + } + } + if (toIdx < length) { + if (objResultPtr) { + Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1, + length - toIdx); + } else { + objResultPtr = Tcl_NewUnicodeObj(ustring1 + toIdx + 1, + length - toIdx); + } + } + if (objResultPtr == NULL) { + /* This has to be the case [string replace $s 0 end {}] */ + /* which has result {} which is same as value3Ptr. */ + objResultPtr = value3Ptr; + } if (objResultPtr == value3Ptr) { /* See [Bug 82e7f67325] */ TclDecrRefCount(OBJ_AT_TOS); OBJ_AT_TOS = value3Ptr; TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr))); @@ -5193,32 +5830,32 @@ goto doneStringMap; } else if (valuePtr == value2Ptr) { objResultPtr = value3Ptr; goto doneStringMap; } - ustring1 = TclGetUnicodeFromObj(valuePtr, &slength); - if (slength == 0) { + ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length); + if (length == 0) { objResultPtr = valuePtr; goto doneStringMap; } - ustring2 = TclGetUnicodeFromObj(value2Ptr, &length2); - if (length2 > slength || length2 == 0) { + ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2); + if (length2 > length || length2 == 0) { objResultPtr = valuePtr; goto doneStringMap; - } else if (length2 == slength) { - if (memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * slength)) { + } else if (length2 == length) { + if (memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length)) { objResultPtr = valuePtr; } else { objResultPtr = value3Ptr; } goto doneStringMap; } - ustring3 = TclGetUnicodeFromObj(value3Ptr, &length3); + ustring3 = Tcl_GetUnicodeFromObj(value3Ptr, &length3); objResultPtr = Tcl_NewUnicodeObj(ustring1, 0); p = ustring1; - end = ustring1 + slength; + end = ustring1 + length; for (; ustring1 < end; ustring1++) { if ((*ustring1 == *ustring2) && (length2==1 || memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length2) == 0)) { if (p != ustring1) { @@ -5243,36 +5880,64 @@ TRACE_WITH_OBJ(("%.20s %.20s %.20s => ", O2S(value2Ptr), O2S(value3Ptr), O2S(valuePtr)), objResultPtr); NEXT_INST_V(1, 3, 1); case INST_STR_FIND: - slength = TclStringFirst(OBJ_UNDER_TOS, OBJ_AT_TOS, 0); + ustring1 = Tcl_GetUnicodeFromObj(OBJ_AT_TOS, &length); /* Haystack */ + ustring2 = Tcl_GetUnicodeFromObj(OBJ_UNDER_TOS, &length2);/* Needle */ - TRACE(("%.20s %.20s => %" TCL_LL_MODIFIER "d\n", - O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), TclWideIntFromSize(slength))); - objResultPtr = TclNewWideIntObjFromSize(slength); + match = -1; + if (length2 > 0 && length2 <= length) { + end = ustring1 + length - length2 + 1; + for (p=ustring1 ; p %d\n", + O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match)); + TclNewIntObj(objResultPtr, match); NEXT_INST_F(1, 2, 1); case INST_STR_FIND_LAST: - slength = TclStringLast(OBJ_UNDER_TOS, OBJ_AT_TOS, TCL_INDEX_END); + ustring1 = Tcl_GetUnicodeFromObj(OBJ_AT_TOS, &length); /* Haystack */ + ustring2 = Tcl_GetUnicodeFromObj(OBJ_UNDER_TOS, &length2);/* Needle */ - TRACE(("%.20s %.20s => %" TCL_LL_MODIFIER "d\n", - O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), TclWideIntFromSize(slength))); - objResultPtr = TclNewWideIntObjFromSize(slength); + match = -1; + if (length2 > 0 && length2 <= length) { + for (p=ustring1+length-length2 ; p>=ustring1 ; p--) { + if ((*p == *ustring2) && + memcmp(ustring2,p,sizeof(Tcl_UniChar)*length2) == 0) { + match = p - ustring1; + break; + } + } + } + + TRACE(("%.20s %.20s => %d\n", + O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match)); + + TclNewIntObj(objResultPtr, match); NEXT_INST_F(1, 2, 1); case INST_STR_CLASS: opnd = TclGetInt1AtPtr(pc+1); valuePtr = OBJ_AT_TOS; TRACE(("%s \"%.30s\" => ", tclStringClassTable[opnd].name, O2S(valuePtr))); - ustring1 = TclGetUnicodeFromObj(valuePtr, &slength); + ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length); match = 1; - if (slength > 0) { - end = ustring1 + slength; - for (p=ustring1 ; p 0) { + int ch; + end = ustring1 + length; + for (p=ustring1 ; ptypePtr == &tclStringType) + || (value2Ptr->typePtr == &tclStringType)) { Tcl_UniChar *ustring1, *ustring2; - ustring1 = TclGetUnicodeFromObj(valuePtr, &slength); - ustring2 = TclGetUnicodeFromObj(value2Ptr, &length2); - match = TclUniCharMatch(ustring1, slength, ustring2, length2, + ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length); + ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2); + match = TclUniCharMatch(ustring1, length, ustring2, length2, nocase); } else if (TclIsPureByteArray(valuePtr) && !nocase) { unsigned char *bytes1, *bytes2; - size_t wlen1 = 0, wlen2 = 0; - bytes1 = TclGetByteArrayFromObj(valuePtr, &wlen1); - bytes2 = TclGetByteArrayFromObj(value2Ptr, &wlen2); - match = TclByteArrayMatch(bytes1, wlen1, bytes2, wlen2, 0); + bytes1 = Tcl_GetByteArrayFromObj(valuePtr, &length); + bytes2 = Tcl_GetByteArrayFromObj(value2Ptr, &length2); + match = TclByteArrayMatch(bytes1, length, bytes2, length2, 0); } else { match = Tcl_StringCaseMatch(TclGetString(valuePtr), TclGetString(value2Ptr), nocase); } @@ -5323,34 +5987,34 @@ JUMP_PEEPHOLE_F(match, 2, 2); { const char *string1, *string2; - size_t trim1, trim2; + int trim1, trim2; case INST_STR_TRIM_LEFT: valuePtr = OBJ_UNDER_TOS; /* String */ value2Ptr = OBJ_AT_TOS; /* TrimSet */ string2 = TclGetStringFromObj(value2Ptr, &length2); - string1 = TclGetStringFromObj(valuePtr, &slength); - trim1 = TclTrimLeft(string1, slength, string2, length2); + string1 = TclGetStringFromObj(valuePtr, &length); + trim1 = TclTrimLeft(string1, length, string2, length2); trim2 = 0; goto createTrimmedString; case INST_STR_TRIM_RIGHT: valuePtr = OBJ_UNDER_TOS; /* String */ value2Ptr = OBJ_AT_TOS; /* TrimSet */ string2 = TclGetStringFromObj(value2Ptr, &length2); - string1 = TclGetStringFromObj(valuePtr, &slength); - trim2 = TclTrimRight(string1, slength, string2, length2); + string1 = TclGetStringFromObj(valuePtr, &length); + trim2 = TclTrimRight(string1, length, string2, length2); trim1 = 0; goto createTrimmedString; case INST_STR_TRIM: valuePtr = OBJ_UNDER_TOS; /* String */ value2Ptr = OBJ_AT_TOS; /* TrimSet */ string2 = TclGetStringFromObj(value2Ptr, &length2); - string1 = TclGetStringFromObj(valuePtr, &slength); - trim1 = TclTrim(string1, slength, string2, length2, &trim2); + string1 = TclGetStringFromObj(valuePtr, &length); + trim1 = TclTrim(string1, length, string2, length2, &trim2); createTrimmedString: /* * Careful here; trim set often contains non-ASCII characters so we * take care when printing. [Bug 971cb4f1db] */ @@ -5369,11 +6033,11 @@ printf("\n"); } #endif NEXT_INST_F(1, 1, 0); } else { - objResultPtr = Tcl_NewStringObj(string1+trim1, slength-trim1-trim2); + objResultPtr = Tcl_NewStringObj(string1+trim1, length-trim1-trim2); #ifdef TCL_COMPILE_DEBUG if (traceInstructions) { TclPrintObject(stdout, objResultPtr, 30); printf("\n"); } @@ -5424,22 +6088,39 @@ */ { ClientData ptr1, ptr2; int type1, type2; - Tcl_WideInt w1, w2, wResult; + long l1, l2, lResult; case INST_NUM_TYPE: if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) { type1 = 0; + } else if (type1 == TCL_NUMBER_LONG) { + /* value is between LONG_MIN and LONG_MAX */ + /* [string is integer] is -UINT_MAX to UINT_MAX range */ + int i; + + if (TclGetIntFromObj(NULL, OBJ_AT_TOS, &i) != TCL_OK) { + type1 = TCL_NUMBER_WIDE; + } +#ifndef TCL_WIDE_INT_IS_LONG + } else if (type1 == TCL_NUMBER_WIDE) { + /* value is between WIDE_MIN and WIDE_MAX */ + /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */ + int i; + if (TclGetIntFromObj(NULL, OBJ_AT_TOS, &i) == TCL_OK) { + type1 = TCL_NUMBER_LONG; + } +#endif } else if (type1 == TCL_NUMBER_BIG) { /* value is an integer outside the WIDE_MIN to WIDE_MAX range */ - /* [string is wideinteger] is WIDE_MIN to WIDE_MAX range */ + /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */ Tcl_WideInt w; if (TclGetWideIntFromObj(NULL, OBJ_AT_TOS, &w) == TCL_OK) { - type1 = TCL_NUMBER_INT; + type1 = TCL_NUMBER_WIDE; } } TclNewIntObj(objResultPtr, type1); TRACE(("\"%.20s\" => %d\n", O2S(OBJ_AT_TOS), type1)); NEXT_INST_F(1, 1, 1); @@ -5481,14 +6162,14 @@ } if (valuePtr == value2Ptr) { compare = MP_EQ; goto convertComparison; } - if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) { - w1 = *((const Tcl_WideInt *)ptr1); - w2 = *((const Tcl_WideInt *)ptr2); - compare = (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ); + if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { + l1 = *((const long *)ptr1); + l2 = *((const long *)ptr2); + compare = (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ); } else { compare = TclCompareTwoNumbers(valuePtr, value2Ptr); } /* @@ -5560,57 +6241,58 @@ /* * Check for common, simple case. */ - if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) { - w1 = *((const Tcl_WideInt *)ptr1); - w2 = *((const Tcl_WideInt *)ptr2); + if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { + l1 = *((const long *)ptr1); + l2 = *((const long *)ptr2); switch (*pc) { case INST_MOD: - if (w2 == 0) { + if (l2 == 0) { TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr), O2S(value2Ptr))); goto divideByZero; - } else if ((w2 == 1) || (w2 == -1)) { + } else if ((l2 == 1) || (l2 == -1)) { /* * Div. by |1| always yields remainder of 0. */ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); objResultPtr = TCONST(0); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); - } else if (w1 == 0) { + } else if (l1 == 0) { /* * 0 % (non-zero) always yields remainder of 0. */ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); objResultPtr = TCONST(0); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } else { - wResult = w1 / w2; + lResult = l1 / l2; /* * Force Tcl's integer division rules. * TODO: examine for logic simplification */ - if ((wResult < 0 || (wResult == 0 && - ((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) && - (wResult * w2 != w1)) { - wResult -= 1; - } - wResult = w1 - w2*wResult; - goto wideResultOfArithmetic; - } + if ((lResult < 0 || (lResult == 0 && + ((l1 < 0 && l2 > 0) || (l1 > 0 && l2 < 0)))) && + (lResult * l2 != l1)) { + lResult -= 1; + } + lResult = l1 - l2*lResult; + goto longResultOfArithmetic; + } + break; case INST_RSHIFT: - if (w2 < 0) { + if (l2 < 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "negative shift argument", -1)); #ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", @@ -5617,30 +6299,30 @@ "domain error: argument not in valid range", NULL); CACHE_STACK_INFO(); #endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ goto gotError; - } else if (w1 == 0) { + } else if (l1 == 0) { TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); objResultPtr = TCONST(0); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } else { /* * Quickly force large right shifts to 0 or -1. */ - if (w2 >= (Tcl_WideInt)(CHAR_BIT*sizeof(long))) { + if (l2 >= (long)(CHAR_BIT*sizeof(long))) { /* * We assume that INT_MAX is much larger than the * number of bits in a long. This is a pretty safe * assumption, given that the former is usually around * 4e9 and the latter 32 or 64... */ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - if (w1 > 0L) { + if (l1 > 0L) { objResultPtr = TCONST(0); } else { TclNewIntObj(objResultPtr, -1); } TRACE(("%s\n", O2S(objResultPtr))); @@ -5649,16 +6331,17 @@ /* * Handle shifts within the native long range. */ - wResult = w1 >> ((int) w2); - goto wideResultOfArithmetic; + lResult = l1 >> ((int) l2); + goto longResultOfArithmetic; } + break; case INST_LSHIFT: - if (w2 < 0) { + if (l2 < 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "negative shift argument", -1)); #ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", @@ -5665,16 +6348,16 @@ "domain error: argument not in valid range", NULL); CACHE_STACK_INFO(); #endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ goto gotError; - } else if (w1 == 0) { + } else if (l1 == 0) { TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); objResultPtr = TCONST(0); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); - } else if (w2 > INT_MAX) { + } else if (l2 > (long) INT_MAX) { /* * Technically, we could hold the value (1 << (INT_MAX+1)) * in an mp_int, but since we're using mp_mul_2d() to do * the work, and it takes only an int argument, that's a * good place to draw the line. @@ -5688,21 +6371,21 @@ "integer value too large to represent", NULL); CACHE_STACK_INFO(); #endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ goto gotError; } else { - int shift = (int) w2; + int shift = (int) l2; /* * Handle shifts within the native long range. */ - if ((size_t) shift < CHAR_BIT*sizeof(long) && (w1 != 0) - && !((w1>0 ? w1 : ~w1) & + if ((size_t) shift < CHAR_BIT*sizeof(long) && (l1 != 0) + && !((l1>0 ? l1 : ~l1) & -(1L<<(CHAR_BIT*sizeof(long) - 1 - shift)))) { - wResult = w1 << shift; - goto wideResultOfArithmetic; + lResult = l1 << shift; + goto longResultOfArithmetic; } } /* * Too large; need to use the broken-out function. @@ -5710,18 +6393,27 @@ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); break; case INST_BITAND: - wResult = w1 & w2; - goto wideResultOfArithmetic; + lResult = l1 & l2; + goto longResultOfArithmetic; case INST_BITOR: - wResult = w1 | w2; - goto wideResultOfArithmetic; + lResult = l1 | l2; + goto longResultOfArithmetic; case INST_BITXOR: - wResult = w1 ^ w2; - goto wideResultOfArithmetic; + lResult = l1 ^ l2; + longResultOfArithmetic: + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if (Tcl_IsShared(valuePtr)) { + TclNewLongObj(objResultPtr, lResult); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + TclSetLongObj(valuePtr, lResult); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); } } /* * DO NOT MERGE THIS WITH THE EQUIVALENT SECTION LATER! That would @@ -5800,28 +6492,37 @@ /* * Handle (long,long) arithmetic as best we can without going out to * an external function. */ - if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) { - w1 = *((const Tcl_WideInt *)ptr1); - w2 = *((const Tcl_WideInt *)ptr2); + if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { + Tcl_WideInt w1, w2, wResult; + + l1 = *((const long *)ptr1); + l2 = *((const long *)ptr2); switch (*pc) { case INST_ADD: + w1 = (Tcl_WideInt) l1; + w2 = (Tcl_WideInt) l2; wResult = w1 + w2; +#ifdef TCL_WIDE_INT_IS_LONG /* * Check for overflow. */ if (Overflowing(w1, w2, wResult)) { goto overflow; } +#endif goto wideResultOfArithmetic; case INST_SUB: + w1 = (Tcl_WideInt) l1; + w2 = (Tcl_WideInt) l2; wResult = w1 - w2; +#ifdef TCL_WIDE_INT_IS_LONG /* * Must check for overflow. The macro tests for overflows in * sums by looking at the sign bits. As we have a subtraction * here, we are adding -w2. As -w2 could in turn overflow, we * test with ~w2 instead: it has the opposite sign bit to w2 @@ -5831,56 +6532,58 @@ */ if (Overflowing(w1, ~w2, wResult)) { goto overflow; } +#endif wideResultOfArithmetic: TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); if (Tcl_IsShared(valuePtr)) { objResultPtr = Tcl_NewWideIntObj(wResult); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } - TclSetIntObj(valuePtr, wResult); + Tcl_SetWideIntObj(valuePtr, wResult); TRACE(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 0); + break; case INST_DIV: - if (w2 == 0) { + if (l2 == 0) { TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr), O2S(value2Ptr))); goto divideByZero; - } else if ((w1 == WIDE_MIN) && (w2 == -1)) { + } else if ((l1 == LONG_MIN) && (l2 == -1)) { /* - * Can't represent (-WIDE_MIN) as a Tcl_WideInt. + * Can't represent (-LONG_MIN) as a long. */ goto overflow; } - wResult = w1 / w2; + lResult = l1 / l2; /* * Force Tcl's integer division rules. * TODO: examine for logic simplification */ - if (((wResult < 0) || ((wResult == 0) && - ((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) && - ((wResult * w2) != w1)) { - wResult -= 1; + if (((lResult < 0) || ((lResult == 0) && + ((l1 < 0 && l2 > 0) || (l1 > 0 && l2 < 0)))) && + ((lResult * l2) != l1)) { + lResult -= 1; } - goto wideResultOfArithmetic; + goto longResultOfArithmetic; case INST_MULT: - if (((sizeof(Tcl_WideInt) >= 2*sizeof(int)) - && (w1 <= INT_MAX) && (w1 >= INT_MIN) - && (w2 <= INT_MAX) && (w2 >= INT_MIN)) - || ((sizeof(Tcl_WideInt) >= 2*sizeof(short)) - && (w1 <= SHRT_MAX) && (w1 >= SHRT_MIN) - && (w2 <= SHRT_MAX) && (w2 >= SHRT_MIN))) { - wResult = w1 * w2; - goto wideResultOfArithmetic; + if (((sizeof(long) >= 2*sizeof(int)) + && (l1 <= INT_MAX) && (l1 >= INT_MIN) + && (l2 <= INT_MAX) && (l2 >= INT_MIN)) + || ((sizeof(long) >= 2*sizeof(short)) + && (l1 <= SHRT_MAX) && (l1 >= SHRT_MIN) + && (l2 <= SHRT_MAX) && (l2 >= SHRT_MIN))) { + lResult = l1 * l2; + goto longResultOfArithmetic; } } /* * Fall through with INST_EXPON, INST_DIV and large multiplies. @@ -5943,18 +6646,18 @@ DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); CACHE_STACK_INFO(); goto gotError; } - if (type1 == TCL_NUMBER_INT) { - w1 = *((const Tcl_WideInt *) ptr1); + if (type1 == TCL_NUMBER_LONG) { + l1 = *((const long *) ptr1); if (Tcl_IsShared(valuePtr)) { - TclNewIntObj(objResultPtr, ~w1); + TclNewLongObj(objResultPtr, ~l1); TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } - TclSetIntObj(valuePtr, ~w1); + TclSetLongObj(valuePtr, ~l1); TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } objResultPtr = ExecuteExtendedUnaryMathOp(*pc, valuePtr); if (objResultPtr != NULL) { @@ -5980,19 +6683,20 @@ switch (type1) { case TCL_NUMBER_NAN: /* -NaN => NaN */ TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); - case TCL_NUMBER_INT: - w1 = *((const Tcl_WideInt *) ptr1); - if (w1 != WIDE_MIN) { + break; + case TCL_NUMBER_LONG: + l1 = *((const long *) ptr1); + if (l1 != LONG_MIN) { if (Tcl_IsShared(valuePtr)) { - TclNewIntObj(objResultPtr, -w1); + TclNewLongObj(objResultPtr, -l1); TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } - TclSetIntObj(valuePtr, -w1); + TclSetLongObj(valuePtr, -l1); TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } /* FALLTHROUGH */ } @@ -6088,26 +6792,28 @@ } TclInvalidateStringRep(valuePtr); TRACE_APPEND(("numeric, same Tcl_Obj\n")); NEXT_INST_F(1, 0, 0); } + break; /* * End of numeric operator instructions. * ----------------------------------------------------------------- */ case INST_TRY_CVT_TO_BOOLEAN: valuePtr = OBJ_AT_TOS; - if (TclHasIntRep(valuePtr, &tclBooleanType)) { + if (valuePtr->typePtr == &tclBooleanType) { objResultPtr = TCONST(1); } else { - int result = (TclSetBooleanFromAny(NULL, valuePtr) == TCL_OK); - objResultPtr = TCONST(result); + int res = (TclSetBooleanFromAny(NULL, valuePtr) == TCL_OK); + objResultPtr = TCONST(res); } TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(valuePtr)), objResultPtr); NEXT_INST_F(1, 0, 1); + break; case INST_BREAK: /* DECACHE_STACK_INFO(); Tcl_ResetResult(interp); @@ -6129,15 +6835,177 @@ TRACE(("=> CONTINUE!\n")); goto processExceptionReturn; { ForeachInfo *infoPtr; - Tcl_Obj *listPtr, **elements, *tmpPtr; + Var *iterVarPtr, *listVarPtr; + Tcl_Obj *oldValuePtr, *listPtr, **elements; + ForeachVarList *varListPtr; + int numLists, iterNum, listTmpIndex, listLen, numVars; + int varIndex, valIndex, continueLoop, j, iterTmpIndex; + long i; + + case INST_FOREACH_START4: /* DEPRECATED */ + /* + * Initialize the temporary local var that holds the count of the + * number of iterations of the loop body to -1. + */ + + opnd = TclGetUInt4AtPtr(pc+1); + infoPtr = codePtr->auxDataArrayPtr[opnd].clientData; + iterTmpIndex = infoPtr->loopCtTemp; + iterVarPtr = LOCAL(iterTmpIndex); + oldValuePtr = iterVarPtr->value.objPtr; + + if (oldValuePtr == NULL) { + TclNewLongObj(iterVarPtr->value.objPtr, -1); + Tcl_IncrRefCount(iterVarPtr->value.objPtr); + } else { + TclSetLongObj(oldValuePtr, -1); + } + TRACE(("%u => loop iter count temp %d\n", opnd, iterTmpIndex)); + +#ifndef TCL_COMPILE_DEBUG + /* + * Remark that the compiler ALWAYS sets INST_FOREACH_STEP4 immediately + * after INST_FOREACH_START4 - let us just fall through instead of + * jumping back to the top. + */ + + pc += 5; + TCL_DTRACE_INST_NEXT(); +#else + NEXT_INST_F(5, 0, 0); +#endif + + case INST_FOREACH_STEP4: /* DEPRECATED */ + /* + * "Step" a foreach loop (i.e., begin its next iteration) by assigning + * the next value list element to each loop var. + */ + + opnd = TclGetUInt4AtPtr(pc+1); + TRACE(("%u => ", opnd)); + infoPtr = codePtr->auxDataArrayPtr[opnd].clientData; + numLists = infoPtr->numLists; + + /* + * Increment the temp holding the loop iteration number. + */ + + iterVarPtr = LOCAL(infoPtr->loopCtTemp); + valuePtr = iterVarPtr->value.objPtr; + iterNum = valuePtr->internalRep.longValue + 1; + TclSetLongObj(valuePtr, iterNum); + + /* + * Check whether all value lists are exhausted and we should stop the + * loop. + */ + + continueLoop = 0; + listTmpIndex = infoPtr->firstValueTemp; + for (i = 0; i < numLists; i++) { + varListPtr = infoPtr->varLists[i]; + numVars = varListPtr->numVars; + + listVarPtr = LOCAL(listTmpIndex); + listPtr = listVarPtr->value.objPtr; + if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) { + TRACE_APPEND(("ERROR converting list %ld, \"%.30s\": %s\n", + i, O2S(listPtr), O2S(Tcl_GetObjResult(interp)))); + goto gotError; + } + if (listLen > iterNum * numVars) { + continueLoop = 1; + } + listTmpIndex++; + } + + /* + * If some var in some var list still has a remaining list element + * iterate one more time. Assign to var the next element from its + * value list. We already checked above that each list temp holds a + * valid list object (by calling Tcl_ListObjLength), but cannot rely + * on that check remaining valid: one list could have been shimmered + * as a side effect of setting a traced variable. + */ + + if (continueLoop) { + listTmpIndex = infoPtr->firstValueTemp; + for (i = 0; i < numLists; i++) { + varListPtr = infoPtr->varLists[i]; + numVars = varListPtr->numVars; + + listVarPtr = LOCAL(listTmpIndex); + listPtr = TclListObjCopy(NULL, listVarPtr->value.objPtr); + TclListObjGetElements(interp, listPtr, &listLen, &elements); + + valIndex = (iterNum * numVars); + for (j = 0; j < numVars; j++) { + if (valIndex >= listLen) { + TclNewObj(valuePtr); + } else { + valuePtr = elements[valIndex]; + } + + varIndex = varListPtr->varIndexes[j]; + varPtr = LOCAL(varIndex); + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + if (TclIsVarDirectWritable(varPtr)) { + value2Ptr = varPtr->value.objPtr; + if (valuePtr != value2Ptr) { + if (value2Ptr != NULL) { + TclDecrRefCount(value2Ptr); + } + varPtr->value.objPtr = valuePtr; + Tcl_IncrRefCount(valuePtr); + } + } else { + DECACHE_STACK_INFO(); + if (TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL, + valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){ + CACHE_STACK_INFO(); + TRACE_APPEND(( + "ERROR init. index temp %d: %s\n", + varIndex, O2S(Tcl_GetObjResult(interp)))); + TclDecrRefCount(listPtr); + goto gotError; + } + CACHE_STACK_INFO(); + } + valIndex++; + } + TclDecrRefCount(listPtr); + listTmpIndex++; + } + } + TRACE_APPEND(("%d lists, iter %d, %s loop\n", + numLists, iterNum, (continueLoop? "continue" : "exit"))); + + /* + * Run-time peep-hole optimisation: the compiler ALWAYS follows + * INST_FOREACH_STEP4 with an INST_JUMP_FALSE. We just skip that + * instruction and jump direct from here. + */ + + pc += 5; + if (*pc == INST_JUMP_FALSE1) { + NEXT_INST_F((continueLoop? 2 : TclGetInt1AtPtr(pc+1)), 0, 0); + } else { + NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0); + } + + } + { + ForeachInfo *infoPtr; + Tcl_Obj *listPtr, **elements; ForeachVarList *varListPtr; - int numLists, listLen, numVars; - int listTmpDepth; - size_t iterNum, iterMax, iterTmp; + int numLists, iterMax, listLen, numVars; + int iterTmp, iterNum, listTmpDepth; int varIndex, valIndex, j; long i; case INST_FOREACH_START: /* @@ -6184,12 +7052,12 @@ * thing is properly garbage collected. THIS OBJ MAKES NO SENSE, but * it will never leave this scope and is read-only. */ TclNewObj(tmpPtr); - tmpPtr->internalRep.twoPtrValue.ptr1 = NULL; - tmpPtr->internalRep.twoPtrValue.ptr2 = (void *)iterMax; + tmpPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(0); + tmpPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(iterMax); PUSH_OBJECT(tmpPtr); /* iterCounts object */ /* * Store a pointer to the ForeachInfo struct; same dirty trick * as above @@ -6217,12 +7085,12 @@ infoPtr = tmpPtr->internalRep.twoPtrValue.ptr1; numLists = infoPtr->numLists; TRACE(("=> ")); tmpPtr = OBJ_AT_DEPTH(1); - iterNum = (size_t)tmpPtr->internalRep.twoPtrValue.ptr1; - iterMax = (size_t)tmpPtr->internalRep.twoPtrValue.ptr2; + iterNum = PTR2INT(tmpPtr->internalRep.twoPtrValue.ptr1); + iterMax = PTR2INT(tmpPtr->internalRep.twoPtrValue.ptr2); /* * If some list still has a remaining list element iterate one more * time. Assign to var the next element from its value list. */ @@ -6230,11 +7098,11 @@ if (iterNum < iterMax) { /* * Set the variables and jump back to run the body */ - tmpPtr->internalRep.twoPtrValue.ptr1 =(void *)(iterNum + 1); + tmpPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(iterNum + 1); listTmpDepth = numLists + 1; for (i = 0; i < numLists; i++) { varListPtr = infoPtr->varLists[i]; @@ -6321,10 +7189,11 @@ objPtr = OBJ_AT_DEPTH(3 + numLists); Tcl_ListObjAppendElement(NULL, objPtr, OBJ_AT_TOS); NEXT_INST_F(1, 1, 0); } + break; case INST_BEGIN_CATCH4: /* * Record start of the catch command with exception range index equal * to the operand. Push the current stack depth onto the special catch @@ -6334,19 +7203,21 @@ *(++catchTop) = CURR_DEPTH; TRACE(("%u => catchTop=%d, stackTop=%d\n", TclGetUInt4AtPtr(pc+1), (int) (catchTop - initCatchTop - 1), (int) CURR_DEPTH)); NEXT_INST_F(5, 0, 0); + break; case INST_END_CATCH: catchTop--; DECACHE_STACK_INFO(); Tcl_ResetResult(interp); CACHE_STACK_INFO(); result = TCL_OK; TRACE(("=> catchTop=%d\n", (int) (catchTop - initCatchTop - 1))); NEXT_INST_F(1, 0, 0); + break; case INST_PUSH_RESULT: objResultPtr = Tcl_GetObjResult(interp); TRACE_WITH_OBJ(("=> "), objResultPtr); @@ -6356,22 +7227,25 @@ TclNewObj(objPtr); Tcl_IncrRefCount(objPtr); iPtr->objResultPtr = objPtr; NEXT_INST_F(1, 0, -1); + break; case INST_PUSH_RETURN_CODE: TclNewIntObj(objResultPtr, result); TRACE(("=> %u\n", result)); NEXT_INST_F(1, 0, 1); + break; case INST_PUSH_RETURN_OPTIONS: DECACHE_STACK_INFO(); objResultPtr = Tcl_GetReturnOptions(interp, result); CACHE_STACK_INFO(); TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); + break; case INST_RETURN_CODE_BRANCH: { int code; if (TclGetIntFromObj(NULL, OBJ_AT_TOS, &code) != TCL_OK) { @@ -6408,27 +7282,59 @@ goto gotError; } TRACE_APPEND(("OK\n")); NEXT_INST_F(1, 1, 0); + case INST_DICT_GET: case INST_DICT_EXISTS: { + Tcl_Interp *interp2 = interp; int found; opnd = TclGetUInt4AtPtr(pc+1); TRACE(("%u => ", opnd)); dictPtr = OBJ_AT_DEPTH(opnd); + if (*pc == INST_DICT_EXISTS) { + interp2 = NULL; + } if (opnd > 1) { - dictPtr = TclTraceDictPath(NULL, dictPtr, opnd-1, - &OBJ_AT_DEPTH(opnd-1), DICT_PATH_EXISTS); - if (dictPtr == NULL || dictPtr == DICT_PATH_NON_EXISTENT) { - found = 0; - goto afterDictExists; + dictPtr = TclTraceDictPath(interp2, dictPtr, opnd-1, + &OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ); + if (dictPtr == NULL) { + if (*pc == INST_DICT_EXISTS) { + found = 0; + goto afterDictExists; + } + TRACE_WITH_OBJ(( + "ERROR tracing dictionary path into \"%.30s\": ", + O2S(OBJ_AT_DEPTH(opnd))), + Tcl_GetObjResult(interp)); + goto gotError; } } - if (Tcl_DictObjGet(NULL, dictPtr, OBJ_AT_TOS, + if (Tcl_DictObjGet(interp2, dictPtr, OBJ_AT_TOS, &objResultPtr) == TCL_OK) { - found = (objResultPtr ? 1 : 0); + if (*pc == INST_DICT_EXISTS) { + found = (objResultPtr ? 1 : 0); + goto afterDictExists; + } + if (!objResultPtr) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "key \"%s\" not known in dictionary", + TclGetString(OBJ_AT_TOS))); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", + TclGetString(OBJ_AT_TOS), NULL); + CACHE_STACK_INFO(); + TRACE_ERROR(interp); + goto gotError; + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(5, opnd+1, 1); + } else if (*pc != INST_DICT_EXISTS) { + TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s", + O2S(dictPtr), O2S(Tcl_GetObjResult(interp)))); + goto gotError; } else { found = 0; } afterDictExists: TRACE_APPEND(("%d\n", found)); @@ -6440,72 +7346,10 @@ * someone doing something else). */ JUMP_PEEPHOLE_V(found, 5, opnd+1); } - case INST_DICT_GET: - opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u => ", opnd)); - dictPtr = OBJ_AT_DEPTH(opnd); - if (opnd > 1) { - dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1, - &OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ); - if (dictPtr == NULL) { - TRACE_WITH_OBJ(( - "ERROR tracing dictionary path into \"%.30s\": ", - O2S(OBJ_AT_DEPTH(opnd))), - Tcl_GetObjResult(interp)); - goto gotError; - } - } - if (Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, - &objResultPtr) != TCL_OK) { - TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s", - O2S(dictPtr), O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - if (!objResultPtr) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "key \"%s\" not known in dictionary", - TclGetString(OBJ_AT_TOS))); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", - TclGetString(OBJ_AT_TOS), NULL); - CACHE_STACK_INFO(); - TRACE_ERROR(interp); - goto gotError; - } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd+1, 1); - case INST_DICT_GET_DEF: - opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u => ", opnd)); - dictPtr = OBJ_AT_DEPTH(opnd+1); - if (opnd > 1) { - dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1, - &OBJ_AT_DEPTH(opnd), DICT_PATH_EXISTS); - if (dictPtr == NULL) { - TRACE_WITH_OBJ(( - "ERROR tracing dictionary path into \"%.30s\": ", - O2S(OBJ_AT_DEPTH(opnd+1))), - Tcl_GetObjResult(interp)); - goto gotError; - } else if (dictPtr == DICT_PATH_NON_EXISTENT) { - goto dictGetDefUseDefault; - } - } - if (Tcl_DictObjGet(interp, dictPtr, OBJ_UNDER_TOS, - &objResultPtr) != TCL_OK) { - TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s", - O2S(dictPtr), O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } else if (!objResultPtr) { - dictGetDefUseDefault: - objResultPtr = OBJ_AT_TOS; - } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd+2, 1); case INST_DICT_SET: case INST_DICT_UNSET: case INST_DICT_INCR_IMM: opnd = TclGetUInt4AtPtr(pc+1); @@ -6548,11 +7392,11 @@ break; } if (valuePtr == NULL) { Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS,Tcl_NewIntObj(opnd)); } else { - value2Ptr = Tcl_NewIntObj(opnd); + TclNewIntObj(value2Ptr, opnd); Tcl_IncrRefCount(value2Ptr); if (Tcl_IsShared(valuePtr)) { valuePtr = Tcl_DuplicateObj(valuePtr); Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS, valuePtr); } @@ -6753,11 +7597,11 @@ case INST_DICT_FIRST: opnd = TclGetUInt4AtPtr(pc+1); TRACE(("%u => ", opnd)); dictPtr = POP_OBJECT(); - searchPtr = Tcl_Alloc(sizeof(Tcl_DictSearch)); + searchPtr = ckalloc(sizeof(Tcl_DictSearch)); if (Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr, &valuePtr, &done) != TCL_OK) { /* * dictPtr is no longer on the stack, and we're not @@ -6764,24 +7608,21 @@ * moving it into the intrep of an iterator. We need * to drop the refcount [Tcl Bug 9b352768e6]. */ Tcl_DecrRefCount(dictPtr); - Tcl_Free(searchPtr); + ckfree(searchPtr); TRACE_ERROR(interp); goto gotError; } - { - Tcl_ObjIntRep ir; - TclNewObj(statePtr); - ir.twoPtrValue.ptr1 = searchPtr; - ir.twoPtrValue.ptr2 = dictPtr; - Tcl_StoreIntRep(statePtr, &dictIteratorType, &ir); - } + TclNewObj(statePtr); + statePtr->typePtr = &dictIteratorType; + statePtr->internalRep.twoPtrValue.ptr1 = searchPtr; + statePtr->internalRep.twoPtrValue.ptr2 = dictPtr; varPtr = LOCAL(opnd); if (varPtr->value.objPtr) { - if (TclHasIntRep(varPtr->value.objPtr, &dictIteratorType)) { + if (varPtr->value.objPtr->typePtr == &dictIteratorType) { Tcl_Panic("mis-issued dictFirst!"); } TclDecrRefCount(varPtr->value.objPtr); } varPtr->value.objPtr = statePtr; @@ -6790,21 +7631,15 @@ case INST_DICT_NEXT: opnd = TclGetUInt4AtPtr(pc+1); TRACE(("%u => ", opnd)); statePtr = (*LOCAL(opnd)).value.objPtr; - { - const Tcl_ObjIntRep *irPtr; - - if (statePtr && - (irPtr = TclFetchIntRep(statePtr, &dictIteratorType))) { - searchPtr = irPtr->twoPtrValue.ptr1; - Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done); - } else { - Tcl_Panic("mis-issued dictNext!"); - } - } + if (statePtr == NULL || statePtr->typePtr != &dictIteratorType) { + Tcl_Panic("mis-issued dictNext!"); + } + searchPtr = statePtr->internalRep.twoPtrValue.ptr1; + Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done); pushDictIteratorResult: if (done) { TclNewObj(emptyPtr); PUSH_OBJECT(emptyPtr); PUSH_OBJECT(emptyPtr); @@ -6849,11 +7684,11 @@ if (TclListObjGetElements(interp, OBJ_AT_TOS, &length, &keyPtrPtr) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } - if ((size_t)length != duiPtr->length) { + if (length != duiPtr->length) { Tcl_Panic("dictUpdateStart argument length mismatch"); } for (i=0 ; i "), objResultPtr); NEXT_INST_F(2, 0, 1); } + break; default: Tcl_Panic("TclNRExecuteByteCode: unrecognized opCode %u", *pc); } /* end of switch on opCode */ @@ -7209,16 +8046,15 @@ if (iPtr->execEnvPtr->rewind) { goto abnormalReturn; } if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { const unsigned char *pcBeg; - size_t xxx1length; - bytes = GetSrcInfoForPc(pc, codePtr, &xxx1length, &pcBeg, NULL); + bytes = GetSrcInfoForPc(pc, codePtr, &length, &pcBeg, NULL); DECACHE_STACK_INFO(); TclLogCommandInfo(interp, codePtr->source, bytes, - bytes ? xxx1length : 0, pcBeg, tosPtr); + bytes ? length : 0, pcBeg, tosPtr); CACHE_STACK_INFO(); } iPtr->flags &= ~ERR_ALREADY_LOGGED; /* @@ -7322,11 +8158,11 @@ /* * end of infinite loop dispatching on instructions. */ /* - * Abnormal return code. Restore the stack to state it had when + * Done or abnormal return code. Restore the stack to state it had when * starting to execute the ByteCode. Panic if the stack is below the * initial level. */ abnormalReturn: @@ -7357,11 +8193,13 @@ } CLANG_ASSERT(bcFramePtr); } iPtr->cmdFramePtr = bcFramePtr->nextPtr; - TclReleaseByteCode(codePtr); + if (codePtr->refCount-- <= 1) { + TclCleanupByteCode(codePtr); + } TclStackFree(interp, TD); /* free my stack */ return result; /* @@ -7376,31 +8214,33 @@ */ instStartCmdFailed: { const char *bytes; - size_t xxx1length; - - checkInterp = 1; - xxx1length = 0; - - /* - * We used to switch to direct eval; for NRE-awareness we now - * compile and eval the command so that this evaluation does not - * add a new TEBC instance. [Bug 2910748] - */ + + length = 0; if (TclInterpReady(interp) == TCL_ERROR) { goto gotError; } + /* + * We used to switch to direct eval; for NRE-awareness we now + * compile and eval the command so that this evaluation does not + * add a new TEBC instance. Bug [2910748], bug [fa6bf38d07] + * + * TODO: recompile, search this command and eval a code starting from, + * so that this evaluation does not add a new TEBC instance without + * NRE-trampoline. + */ + codePtr->flags |= TCL_BYTECODE_RECOMPILE; - bytes = GetSrcInfoForPc(pc, codePtr, &xxx1length, NULL, NULL); + bytes = GetSrcInfoForPc(pc, codePtr, &length, NULL, NULL); opnd = TclGetUInt4AtPtr(pc+1); pc += (opnd-1); assert(bytes); - PUSH_OBJECT(Tcl_NewStringObj(bytes, xxx1length)); + PUSH_OBJECT(Tcl_NewStringObj(bytes, length)); goto instEvalStk; } } #undef codePtr @@ -7464,14 +8304,51 @@ contextPtr->oPtr->flags |= FILTER_HANDLING; return result; } /* - * WidePwrSmallExpon -- + * LongPwrSmallExpon -- , WidePwrSmallExpon -- * - * Helper to calculate small powers of integers whose result is wide. + * Helpers to calculate small powers of integers whose result is long or wide. */ +#if (LONG_MAX == 0x7FFFFFFF) +static inline long +LongPwrSmallExpon(long l1, long exponent) { + + long lResult; + + lResult = l1 * l1; /* b**2 */ + switch (exponent) { + case 2: + break; + case 3: + lResult *= l1; /* b**3 */ + break; + case 4: + lResult *= lResult; /* b**4 */ + break; + case 5: + lResult *= lResult; /* b**4 */ + lResult *= l1; /* b**5 */ + break; + case 6: + lResult *= l1; /* b**3 */ + lResult *= lResult; /* b**6 */ + break; + case 7: + lResult *= l1; /* b**3 */ + lResult *= lResult; /* b**6 */ + lResult *= l1; /* b**7 */ + break; + case 8: + lResult *= lResult; /* b**4 */ + lResult *= lResult; /* b**8 */ + break; + } + return lResult; +} +#endif static inline Tcl_WideInt WidePwrSmallExpon(Tcl_WideInt w1, long exponent) { Tcl_WideInt wResult; @@ -7581,15 +8458,23 @@ int opcode, /* What operation to perform. */ Tcl_Obj **constants, /* The execution environment's constants. */ Tcl_Obj *valuePtr, /* The first operand on the stack. */ Tcl_Obj *value2Ptr) /* The second operand on the stack. */ { +#define LONG_RESULT(l) \ + if (Tcl_IsShared(valuePtr)) { \ + TclNewLongObj(objResultPtr, l); \ + return objResultPtr; \ + } else { \ + Tcl_SetLongObj(valuePtr, l); \ + return NULL; \ + } #define WIDE_RESULT(w) \ if (Tcl_IsShared(valuePtr)) { \ return Tcl_NewWideIntObj(w); \ } else { \ - TclSetIntObj(valuePtr, w); \ + Tcl_SetWideIntObj(valuePtr, w); \ return NULL; \ } #define BIG_RESULT(b) \ if (Tcl_IsShared(valuePtr)) { \ return Tcl_NewBignumObj(b); \ @@ -7607,10 +8492,11 @@ } int type1, type2; ClientData ptr1, ptr2; double d1, d2, dResult; + long l1, l2, lResult; Tcl_WideInt w1, w2, wResult; mp_int big1, big2, bigResult, bigRemainder; Tcl_Obj *objResultPtr; int invalid, zero; long shift; @@ -7620,48 +8506,41 @@ switch (opcode) { case INST_MOD: /* TODO: Attempts to re-use unshared operands on stack */ - w2 = 0; /* silence gcc warning */ - if (type2 == TCL_NUMBER_INT) { - w2 = *((const Tcl_WideInt *)ptr2); - if (w2 == 0) { + l2 = 0; /* silence gcc warning */ + if (type2 == TCL_NUMBER_LONG) { + l2 = *((const long *)ptr2); + if (l2 == 0) { return DIVIDED_BY_ZERO; } - if ((w2 == 1) || (w2 == -1)) { + if ((l2 == 1) || (l2 == -1)) { /* * Div. by |1| always yields remainder of 0. */ return constants[0]; } } - if (type1 == TCL_NUMBER_INT) { +#ifndef TCL_WIDE_INT_IS_LONG + if (type1 == TCL_NUMBER_WIDE) { w1 = *((const Tcl_WideInt *)ptr1); - - if (w1 == 0) { - /* - * 0 % (non-zero) always yields remainder of 0. - */ - - return constants[0]; - } - if (type2 == TCL_NUMBER_INT) { + if (type2 != TCL_NUMBER_BIG) { Tcl_WideInt wQuotient, wRemainder; - w2 = *((const Tcl_WideInt *)ptr2); + TclGetWideIntFromObj(NULL, value2Ptr, &w2); wQuotient = w1 / w2; /* * Force Tcl's integer division rules. * TODO: examine for logic simplification */ if (((wQuotient < (Tcl_WideInt) 0) || ((wQuotient == (Tcl_WideInt) 0) - && ((w1 < 0 && w2 > 0) - || (w1 > 0 && w2 < 0)))) + && ((w1 < (Tcl_WideInt)0 && w2 > (Tcl_WideInt)0) + || (w1 > (Tcl_WideInt)0 && w2 < (Tcl_WideInt)0)))) && (wQuotient * w2 != w1)) { wQuotient -= (Tcl_WideInt) 1; } wRemainder = w1 - w2*wQuotient; WIDE_RESULT(wRemainder); @@ -7668,16 +8547,16 @@ } Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); /* TODO: internals intrusion */ - if ((w1 > ((Tcl_WideInt) 0)) ^ (big2.sign == MP_ZPOS)) { + if ((w1 > ((Tcl_WideInt) 0)) ^ !mp_isneg(&big2)) { /* * Arguments are opposite sign; remainder is sum. */ - TclInitBignumFromWideInt(&big1, w1); + TclBNInitBignumFromWideInt(&big1, w1); mp_add(&big2, &big1, &big2); mp_clear(&big1); BIG_RESULT(&big2); } @@ -7686,16 +8565,17 @@ */ mp_clear(&big2); return NULL; } +#endif Tcl_GetBignumFromObj(NULL, valuePtr, &big1); Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); mp_init(&bigResult); mp_init(&bigRemainder); mp_div(&big1, &big2, &bigResult, &bigRemainder); - if ((bigRemainder.used != 0) && (bigRemainder.sign != big2.sign)) { + if (!mp_iszero(&bigRemainder) && (bigRemainder.sign != big2.sign)) { /* * Convert to Tcl's integer division rules. */ mp_sub_d(&bigResult, 1, &bigResult); @@ -7712,16 +8592,21 @@ /* * Reject negative shift argument. */ switch (type2) { - case TCL_NUMBER_INT: - invalid = (*((const Tcl_WideInt *)ptr2) < 0); + case TCL_NUMBER_LONG: + invalid = (*((const long *)ptr2) < 0L); + break; +#ifndef TCL_WIDE_INT_IS_LONG + case TCL_NUMBER_WIDE: + invalid = (*((const Tcl_WideInt *)ptr2) < (Tcl_WideInt)0); break; +#endif case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - invalid = big2.sign != MP_ZPOS; + invalid = (mp_cmp_d(&big2, 0) == MP_LT); mp_clear(&big2); break; default: /* Unused, here to silence compiler warning */ invalid = 0; @@ -7734,11 +8619,11 @@ /* * Zero shifted any number of bits is still zero. */ - if ((type1==TCL_NUMBER_INT) && (*((const Tcl_WideInt *)ptr1) == 0)) { + if ((type1==TCL_NUMBER_LONG) && (*((const long *)ptr1) == (long)0)) { return constants[0]; } if (opcode == INST_LSHIFT) { /* @@ -7747,12 +8632,12 @@ * BEWARE! Can't use Tcl_GetIntFromObj() here because that * converts values in the (unsigned) range to their signed int * counterparts, leading to incorrect results. */ - if ((type2 != TCL_NUMBER_INT) - || (*((const Tcl_WideInt *)ptr2) > INT_MAX)) { + if ((type2 != TCL_NUMBER_LONG) + || (*((const long *)ptr2) > (long) INT_MAX)) { /* * Technically, we could hold the value (1 << (INT_MAX+1)) in * an mp_int, but since we're using mp_mul_2d() to do the * work, and it takes only an int argument, that's a good * place to draw the line. @@ -7760,19 +8645,19 @@ Tcl_SetObjResult(interp, Tcl_NewStringObj( "integer value too large to represent", -1)); return GENERAL_ARITHMETIC_ERROR; } - shift = (int)(*((const Tcl_WideInt *)ptr2)); + shift = (int)(*((const long *)ptr2)); /* * Handle shifts within the native wide range. */ - if ((type1 == TCL_NUMBER_INT) + if ((type1 != TCL_NUMBER_BIG) && ((size_t)shift < CHAR_BIT*sizeof(Tcl_WideInt))) { - w1 = *((const Tcl_WideInt *)ptr1); + TclGetWideIntFromObj(NULL, valuePtr, &w1); if (!((w1>0 ? w1 : ~w1) & -(((Tcl_WideInt)1) << (CHAR_BIT*sizeof(Tcl_WideInt) - 1 - shift)))) { WIDE_RESULT(w1 << shift); } @@ -7780,54 +8665,61 @@ } else { /* * Quickly force large right shifts to 0 or -1. */ - if ((type2 != TCL_NUMBER_INT) - || (*(const Tcl_WideInt *)ptr2 > INT_MAX)) { + if ((type2 != TCL_NUMBER_LONG) + || (*(const long *)ptr2 > INT_MAX)) { /* * Again, technically, the value to be shifted could be an * mp_int so huge that a right shift by (INT_MAX+1) bits could * not take us to the result of 0 or -1, but since we're using * mp_div_2d to do the work, and it takes only an int * argument, we draw the line there. */ switch (type1) { - case TCL_NUMBER_INT: - zero = (*(const Tcl_WideInt *)ptr1 > 0); + case TCL_NUMBER_LONG: + zero = (*(const long *)ptr1 > 0L); + break; +#ifndef TCL_WIDE_INT_IS_LONG + case TCL_NUMBER_WIDE: + zero = (*(const Tcl_WideInt *)ptr1 > (Tcl_WideInt)0); break; +#endif case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); - zero = (big1.sign == MP_ZPOS); + zero = (mp_cmp_d(&big1, 0) == MP_GT); mp_clear(&big1); break; default: /* Unused, here to silence compiler warning. */ zero = 0; } if (zero) { return constants[0]; } - WIDE_RESULT(-1); + LONG_RESULT(-1); } - shift = (int)(*(const Tcl_WideInt *)ptr2); + shift = (int)(*(const long *)ptr2); +#ifndef TCL_WIDE_INT_IS_LONG /* * Handle shifts within the native wide range. */ - if (type1 == TCL_NUMBER_INT) { + if (type1 == TCL_NUMBER_WIDE) { w1 = *(const Tcl_WideInt *)ptr1; if ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideInt)) { - if (w1 >= 0) { + if (w1 >= (Tcl_WideInt)0) { return constants[0]; } - WIDE_RESULT(-1); + LONG_RESULT(-1); } WIDE_RESULT(w1 >> shift); } +#endif } Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); mp_init(&bigResult); @@ -7841,11 +8733,11 @@ } case INST_BITOR: case INST_BITXOR: case INST_BITAND: - if ((type1 != TCL_NUMBER_INT) || (type2 != TCL_NUMBER_INT)) { + if ((type1 == TCL_NUMBER_BIG) || (type2 == TCL_NUMBER_BIG)) { Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); mp_init(&bigResult); @@ -7866,28 +8758,50 @@ mp_clear(&big1); mp_clear(&big2); BIG_RESULT(&bigResult); } - w1 = *((const Tcl_WideInt *)ptr1); - w2 = *((const Tcl_WideInt *)ptr2); +#ifndef TCL_WIDE_INT_IS_LONG + if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) { + TclGetWideIntFromObj(NULL, valuePtr, &w1); + TclGetWideIntFromObj(NULL, value2Ptr, &w2); + + switch (opcode) { + case INST_BITAND: + wResult = w1 & w2; + break; + case INST_BITOR: + wResult = w1 | w2; + break; + case INST_BITXOR: + wResult = w1 ^ w2; + break; + default: + /* Unused, here to silence compiler warning. */ + wResult = 0; + } + WIDE_RESULT(wResult); + } +#endif + l1 = *((const long *)ptr1); + l2 = *((const long *)ptr2); switch (opcode) { case INST_BITAND: - wResult = w1 & w2; + lResult = l1 & l2; break; case INST_BITOR: - wResult = w1 | w2; + lResult = l1 | l2; break; case INST_BITXOR: - wResult = w1 ^ w2; + lResult = l1 ^ l2; break; default: /* Unused, here to silence compiler warning. */ - wResult = 0; + lResult = 0; } - WIDE_RESULT(wResult); + LONG_RESULT(lResult); case INST_EXPON: { int oddExponent = 0, negativeExponent = 0; unsigned short base; @@ -7899,61 +8813,100 @@ return EXPONENT_OF_ZERO; } dResult = pow(d1, d2); goto doubleResult; } + l1 = l2 = 0; w1 = w2 = 0; /* to silence compiler warning (maybe-uninitialized) */ - if (type2 == TCL_NUMBER_INT) { - w2 = *((const Tcl_WideInt *) ptr2); - if (w2 == 0) { + switch (type2) { + case TCL_NUMBER_LONG: + l2 = *((const long *) ptr2); +#ifndef TCL_WIDE_INT_IS_LONG + pwrLongExpon: +#endif + if (l2 == 0) { /* * Anything to the zero power is 1. */ return constants[1]; - } else if (w2 == 1) { + } else if (l2 == 1) { /* * Anything to the first power is itself */ return NULL; } - + negativeExponent = (l2 < 0); + oddExponent = (int) (l2 & 1); + break; +#ifndef TCL_WIDE_INT_IS_LONG + case TCL_NUMBER_WIDE: + w2 = *((const Tcl_WideInt *)ptr2); + /* check it fits in long */ + l2 = (long)w2; + if (w2 == l2) { + type2 = TCL_NUMBER_LONG; + goto pwrLongExpon; + } negativeExponent = (w2 < 0); oddExponent = (int) (w2 & (Tcl_WideInt)1); - } else { + break; +#endif + case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - negativeExponent = big2.sign != MP_ZPOS; + negativeExponent = (mp_cmp_d(&big2, 0) == MP_LT); mp_mod_2d(&big2, 1, &big2); - oddExponent = big2.used != 0; + oddExponent = !mp_iszero(&big2); mp_clear(&big2); - } - - if (type1 == TCL_NUMBER_INT) { - w1 = *((const Tcl_WideInt *)ptr1); - - if (negativeExponent) { - switch (w1) { - case 0: - /* - * Zero to a negative power is div by zero error. - */ - - return EXPONENT_OF_ZERO; - case -1: - if (oddExponent) { - WIDE_RESULT(-1); - } - /* fallthrough */ - case 1: - /* - * 1 to any power is 1. - */ - - return constants[1]; - } - } + break; + } + + switch (type1) { + case TCL_NUMBER_LONG: + l1 = *((const long *)ptr1); +#ifndef TCL_WIDE_INT_IS_LONG + pwrLongBase: +#endif + switch (l1) { + case 0: + /* + * Zero to a positive power is zero. + * Zero to a negative power is div by zero error. + */ + + return (!negativeExponent) ? constants[0] : EXPONENT_OF_ZERO; + case 1: + /* + * 1 to any power is 1. + */ + + return constants[1]; + case -1: + if (!negativeExponent) { + if (!oddExponent) { + return constants[1]; + } + LONG_RESULT(-1); + } + /* negativeExponent */ + if (oddExponent) { + LONG_RESULT(-1); + } + return constants[1]; + } + break; +#ifndef TCL_WIDE_INT_IS_LONG + case TCL_NUMBER_WIDE: + w1 = *((const Tcl_WideInt *) ptr1); + /* check it fits in long */ + l1 = (long)w1; + if (w1 == l1) { + type1 = TCL_NUMBER_LONG; + goto pwrLongBase; + } +#endif } if (negativeExponent) { /* * Integers with magnitude greater than 1 raise to a negative @@ -7960,81 +8913,123 @@ * power yield the answer zero (see TIP 123). */ return constants[0]; } - if (type1 != TCL_NUMBER_INT) { + + if (type1 == TCL_NUMBER_BIG) { goto overflowExpon; } - switch (w1) { - case 0: - /* - * Zero to a positive power is zero. - */ - - return constants[0]; - case 1: - /* - * 1 to any power is 1. - */ - - return constants[1]; - case -1: - if (!oddExponent) { - return constants[1]; - } - WIDE_RESULT(-1); - } - /* * We refuse to accept exponent arguments that exceed one mp_digit - * which means the max exponent value is 2**28-1 = 0x0fffffff = + * which means the max exponent value is 2**28-1 = 0x0FFFFFFF = * 268435455, which fits into a signed 32 bit int which is within the * range of the long int type. This means any numeric Tcl_Obj value - * not using TCL_NUMBER_INT type must hold a value larger than we + * not using TCL_NUMBER_LONG type must hold a value larger than we * accept. */ - if (type2 != TCL_NUMBER_INT) { + if (type2 != TCL_NUMBER_LONG) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "exponent too large", -1)); return GENERAL_ARITHMETIC_ERROR; } - /* From here (up to overflowExpon) w1 and exponent w2 are wide-int's. */ - assert(type1 == TCL_NUMBER_INT && type2 == TCL_NUMBER_INT); - - if (w1 == 2) { - /* - * Reduce small powers of 2 to shifts. - */ - - if ((Tcl_WideUInt) w2 < (Tcl_WideUInt) CHAR_BIT*sizeof(Tcl_WideInt) - 1) { - WIDE_RESULT(((Tcl_WideInt) 1) << (int)w2); - } - goto overflowExpon; - } - if (w1 == -2) { - int signum = oddExponent ? -1 : 1; - - /* - * Reduce small powers of 2 to shifts. - */ - - if ((Tcl_WideUInt) w2 < CHAR_BIT * sizeof(Tcl_WideInt) - 1) { - WIDE_RESULT(signum * (((Tcl_WideInt) 1) << (int) w2)); - } - goto overflowExpon; - } - if (w2 - 2 < (long)MaxBase64Size - && w1 <= MaxBase64[w2 - 2] - && w1 >= -MaxBase64[w2 - 2]) { + /* From here (up to overflowExpon) exponent is long (l2). */ + + if (type1 == TCL_NUMBER_LONG) { + if (l1 == 2) { + /* + * Reduce small powers of 2 to shifts. + */ + + if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) { + LONG_RESULT(1L << l2); + } +#if !defined(TCL_WIDE_INT_IS_LONG) + if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1) { + WIDE_RESULT(((Tcl_WideInt) 1) << l2); + } +#endif + goto overflowExpon; + } + if (l1 == -2) { + int signum = oddExponent ? -1 : 1; + + /* + * Reduce small powers of 2 to shifts. + */ + + if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) { + LONG_RESULT(signum * (1L << l2)); + } +#if !defined(TCL_WIDE_INT_IS_LONG) + if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){ + WIDE_RESULT(signum * (((Tcl_WideInt) 1) << l2)); + } +#endif + goto overflowExpon; + } +#if (LONG_MAX == 0x7FFFFFFF) + if (l2 - 2 < (long)MaxBase32Size + && l1 <= MaxBase32[l2 - 2] + && l1 >= -MaxBase32[l2 - 2]) { + /* + * Small powers of 32-bit integers. + */ + lResult = LongPwrSmallExpon(l1, l2); + + LONG_RESULT(lResult); + } + + if (l1 - 3 >= 0 && l1 -2 < (long)Exp32IndexSize + && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) { + base = Exp32Index[l1 - 3] + + (unsigned short) (l2 - 2 - MaxBase32Size); + if (base < Exp32Index[l1 - 2]) { + /* + * 32-bit number raised to intermediate power, done by + * table lookup. + */ + + LONG_RESULT(Exp32Value[base]); + } + } + if (-l1 - 3 >= 0 && -l1 - 2 < (long)Exp32IndexSize + && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) { + base = Exp32Index[-l1 - 3] + + (unsigned short) (l2 - 2 - MaxBase32Size); + if (base < Exp32Index[-l1 - 2]) { + /* + * 32-bit number raised to intermediate power, done by + * table lookup. + */ + + lResult = (oddExponent) ? + -Exp32Value[base] : Exp32Value[base]; + LONG_RESULT(lResult); + } + } +#endif +#if (LONG_MAX > 0x7FFFFFFF) || !defined(TCL_WIDE_INT_IS_LONG) + /* Code below (up to overflowExpon) works with wide-int base */ + w1 = l1; +#endif + } + +#if (LONG_MAX > 0x7FFFFFFF) || !defined(TCL_WIDE_INT_IS_LONG) + + /* From here (up to overflowExpon) base is wide-int (w1). */ + + if (l2 - 2 < (long)MaxBase64Size + && w1 <= MaxBase64[l2 - 2] + && w1 >= -MaxBase64[l2 - 2]) { /* * Small powers of integers whose result is wide. */ - wResult = WidePwrSmallExpon(w1, (long)w2); + wResult = WidePwrSmallExpon(w1, l2); WIDE_RESULT(wResult); } /* @@ -8041,13 +9036,13 @@ * Handle cases of powers > 16 that still fit in a 64-bit word by * doing table lookup. */ if (w1 - 3 >= 0 && w1 - 2 < (long)Exp64IndexSize - && w2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { + && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { base = Exp64Index[w1 - 3] - + (unsigned short) (w2 - 2 - MaxBase64Size); + + (unsigned short) (l2 - 2 - MaxBase64Size); if (base < Exp64Index[w1 - 2]) { /* * 64-bit number raised to intermediate power, done by * table lookup. */ @@ -8055,13 +9050,13 @@ WIDE_RESULT(Exp64Value[base]); } } if (-w1 - 3 >= 0 && -w1 - 2 < (long)Exp64IndexSize - && w2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { + && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { base = Exp64Index[-w1 - 3] - + (unsigned short) (w2 - 2 - MaxBase64Size); + + (unsigned short) (l2 - 2 - MaxBase64Size); if (base < Exp64Index[-w1 - 2]) { /* * 64-bit number raised to intermediate power, done by * table lookup. */ @@ -8068,10 +9063,11 @@ wResult = oddExponent ? -Exp64Value[base] : Exp64Value[base]; WIDE_RESULT(wResult); } } +#endif overflowExpon: if ((TclGetWideIntFromObj(NULL, value2Ptr, &w2) != TCL_OK) || (value2Ptr->typePtr != &tclIntType) @@ -8080,11 +9076,11 @@ "exponent too large", -1)); return GENERAL_ARITHMETIC_ERROR; } Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); mp_init(&bigResult); - mp_expt_d_ex(&big1, w2, &bigResult, 1); + mp_expt_u32(&big1, (unsigned int)w2, &bigResult); mp_clear(&big1); BIG_RESULT(&bigResult); } case INST_ADD: @@ -8140,18 +9136,20 @@ return GENERAL_ARITHMETIC_ERROR; } #endif DOUBLE_RESULT(dResult); } - if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) { - w1 = *((const Tcl_WideInt *)ptr1); - w2 = *((const Tcl_WideInt *)ptr2); + if ((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) { + TclGetWideIntFromObj(NULL, valuePtr, &w1); + TclGetWideIntFromObj(NULL, value2Ptr, &w2); switch (opcode) { case INST_ADD: wResult = w1 + w2; - if ((type1 == TCL_NUMBER_INT) || (type2 == TCL_NUMBER_INT)) +#ifndef TCL_WIDE_INT_IS_LONG + if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) +#endif { /* * Check for overflow. */ @@ -8161,11 +9159,13 @@ } break; case INST_SUB: wResult = w1 - w2; - if ((type1 == TCL_NUMBER_INT) || (type2 == TCL_NUMBER_INT)) +#ifndef TCL_WIDE_INT_IS_LONG + if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) +#endif { /* * Must check for overflow. The macro tests for overflows * in sums by looking at the sign bits. As we have a * subtraction here, we are adding -w2. As -w2 could in @@ -8181,11 +9181,12 @@ } } break; case INST_MULT: - if ((w1 < INT_MIN) || (w1 > INT_MAX) || (w2 < INT_MIN) || (w2 > INT_MAX)) { + if ((type1 != TCL_NUMBER_LONG) || (type2 != TCL_NUMBER_LONG) + || (sizeof(Tcl_WideInt) < 2*sizeof(long))) { goto overflowBasic; } wResult = w1 * w2; break; @@ -8193,14 +9194,14 @@ if (w2 == 0) { return DIVIDED_BY_ZERO; } /* - * Need a bignum to represent (WIDE_MIN / -1) + * Need a bignum to represent (LLONG_MIN / -1) */ - if ((w1 == WIDE_MIN) && (w2 == -1)) { + if ((w1 == LLONG_MIN) && (w2 == -1)) { goto overflowBasic; } wResult = w1 / w2; /* @@ -8239,20 +9240,20 @@ break; case INST_MULT: mp_mul(&big1, &big2, &bigResult); break; case INST_DIV: - if (big2.used == 0) { + if (mp_iszero(&big2)) { mp_clear(&big1); mp_clear(&big2); mp_clear(&bigResult); return DIVIDED_BY_ZERO; } mp_init(&bigRemainder); mp_div(&big1, &big2, &bigResult, &bigRemainder); /* TODO: internals intrusion */ - if ((bigRemainder.used != 0) + if (!mp_iszero(&bigRemainder) && (bigRemainder.sign != big2.sign)) { /* * Convert to Tcl's integer division rules. */ @@ -8284,40 +9285,52 @@ (void) GetNumberFromObj(NULL, valuePtr, &ptr, &type); switch (opcode) { case INST_BITNOT: - if (type == TCL_NUMBER_INT) { +#ifndef TCL_WIDE_INT_IS_LONG + if (type == TCL_NUMBER_WIDE) { w = *((const Tcl_WideInt *) ptr); WIDE_RESULT(~w); } +#endif Tcl_TakeBignumFromObj(NULL, valuePtr, &big); /* ~a = - a - 1 */ - mp_neg(&big, &big); + (void)mp_neg(&big, &big); mp_sub_d(&big, 1, &big); BIG_RESULT(&big); case INST_UMINUS: switch (type) { case TCL_NUMBER_DOUBLE: DOUBLE_RESULT(-(*((const double *) ptr))); - case TCL_NUMBER_INT: + case TCL_NUMBER_LONG: + w = (Tcl_WideInt) (*((const long *) ptr)); + if (w != LLONG_MIN) { + WIDE_RESULT(-w); + } + TclBNInitBignumFromLong(&big, *(const long *) ptr); + break; +#ifndef TCL_WIDE_INT_IS_LONG + case TCL_NUMBER_WIDE: w = *((const Tcl_WideInt *) ptr); - if (w != WIDE_MIN) { + if (w != LLONG_MIN) { WIDE_RESULT(-w); } - TclInitBignumFromWideInt(&big, w); + TclBNInitBignumFromWideInt(&big, w); break; +#endif default: Tcl_TakeBignumFromObj(NULL, valuePtr, &big); } - mp_neg(&big, &big); + (void)mp_neg(&big, &big); BIG_RESULT(&big); } Tcl_Panic("unexpected opcode"); return NULL; } +#undef LONG_RESULT #undef WIDE_RESULT #undef BIG_RESULT #undef DOUBLE_RESULT /* @@ -8345,34 +9358,43 @@ { int type1 = TCL_NUMBER_NAN, type2 = TCL_NUMBER_NAN, compare; ClientData ptr1, ptr2; mp_int big1, big2; double d1, d2, tmp; + long l1, l2; +#ifndef TCL_WIDE_INT_IS_LONG Tcl_WideInt w1, w2; +#endif (void) GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); (void) GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); switch (type1) { - case TCL_NUMBER_INT: - w1 = *((const Tcl_WideInt *)ptr1); + case TCL_NUMBER_LONG: + l1 = *((const long *)ptr1); switch (type2) { - case TCL_NUMBER_INT: + case TCL_NUMBER_LONG: + l2 = *((const long *)ptr2); + longCompare: + return (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ); +#ifndef TCL_WIDE_INT_IS_LONG + case TCL_NUMBER_WIDE: w2 = *((const Tcl_WideInt *)ptr2); - wideCompare: - return (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ); + w1 = (Tcl_WideInt)l1; + goto wideCompare; +#endif case TCL_NUMBER_DOUBLE: d2 = *((const double *)ptr2); - d1 = (double) w1; + d1 = (double) l1; /* * If the double has a fractional part, or if the long can be * converted to double without loss of precision, then compare as * doubles. */ - if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) || w1 == (Tcl_WideInt) d1 + if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) || l1 == (long) d1 || modf(d2, &tmp) != 0.0) { goto doubleCompare; } /* @@ -8385,58 +9407,116 @@ * double values that are equivalent within double precision. * Converting the double to an integer gets done exactly, then * integer comparison can tell the difference. */ - if (d2 < (double)WIDE_MIN) { + if (d2 < (double)LONG_MIN) { + return MP_GT; + } + if (d2 > (double)LONG_MAX) { + return MP_LT; + } + l2 = (long) d2; + goto longCompare; + case TCL_NUMBER_BIG: + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + if (mp_cmp_d(&big2, 0) == MP_LT) { + compare = MP_GT; + } else { + compare = MP_LT; + } + mp_clear(&big2); + return compare; + } + break; + +#ifndef TCL_WIDE_INT_IS_LONG + case TCL_NUMBER_WIDE: + w1 = *((const Tcl_WideInt *)ptr1); + switch (type2) { + case TCL_NUMBER_WIDE: + w2 = *((const Tcl_WideInt *)ptr2); + wideCompare: + return (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ); + case TCL_NUMBER_LONG: + l2 = *((const long *)ptr2); + w2 = (Tcl_WideInt)l2; + goto wideCompare; + case TCL_NUMBER_DOUBLE: + d2 = *((const double *)ptr2); + d1 = (double) w1; + if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) + || w1 == (Tcl_WideInt) d1 || modf(d2, &tmp) != 0.0) { + goto doubleCompare; + } + if (d2 < (double)LLONG_MIN) { return MP_GT; } - if (d2 > (double)WIDE_MAX) { + if (d2 > (double)LLONG_MAX) { return MP_LT; } w2 = (Tcl_WideInt) d2; goto wideCompare; case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - if (big2.sign != MP_ZPOS) { + if (mp_isneg(&big2)) { compare = MP_GT; } else { compare = MP_LT; } mp_clear(&big2); return compare; } + break; +#endif case TCL_NUMBER_DOUBLE: d1 = *((const double *)ptr1); switch (type2) { case TCL_NUMBER_DOUBLE: d2 = *((const double *)ptr2); doubleCompare: return (d1 < d2) ? MP_LT : ((d1 > d2) ? MP_GT : MP_EQ); - case TCL_NUMBER_INT: + case TCL_NUMBER_LONG: + l2 = *((const long *)ptr2); + d2 = (double) l2; + if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) || l2 == (long) d2 + || modf(d1, &tmp) != 0.0) { + goto doubleCompare; + } + if (d1 < (double)LONG_MIN) { + return MP_LT; + } + if (d1 > (double)LONG_MAX) { + return MP_GT; + } + l1 = (long) d1; + goto longCompare; +#ifndef TCL_WIDE_INT_IS_LONG + case TCL_NUMBER_WIDE: w2 = *((const Tcl_WideInt *)ptr2); d2 = (double) w2; if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) || w2 == (Tcl_WideInt) d2 || modf(d1, &tmp) != 0.0) { goto doubleCompare; } - if (d1 < (double)WIDE_MIN) { + if (d1 < (double)LLONG_MIN) { return MP_LT; } - if (d1 > (double)WIDE_MAX) { + if (d1 > (double)LLONG_MAX) { return MP_GT; } w1 = (Tcl_WideInt) d1; goto wideCompare; +#endif case TCL_NUMBER_BIG: if (TclIsInfinite(d1)) { return (d1 > 0.0) ? MP_GT : MP_LT; } Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - if ((d1 < (double)WIDE_MAX) && (d1 > (double)WIDE_MIN)) { - if (big2.sign != MP_ZPOS) { + if ((d1 < (double)LONG_MAX) && (d1 > (double)LONG_MIN)) { + if (mp_isneg(&big2)) { compare = MP_GT; } else { compare = MP_LT; } mp_clear(&big2); @@ -8449,15 +9529,19 @@ goto doubleCompare; } Tcl_InitBignumFromDouble(NULL, d1, &big1); goto bigCompare; } + break; case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); switch (type2) { - case TCL_NUMBER_INT: +#ifndef TCL_WIDE_INT_IS_LONG + case TCL_NUMBER_WIDE: +#endif + case TCL_NUMBER_LONG: compare = mp_cmp_d(&big1, 0); mp_clear(&big1); return compare; case TCL_NUMBER_DOUBLE: d2 = *((const double *)ptr2); @@ -8464,11 +9548,11 @@ if (TclIsInfinite(d2)) { compare = (d2 > 0.0) ? MP_LT : MP_GT; mp_clear(&big1); return compare; } - if ((d2 < (double)WIDE_MAX) && (d2 > (double)WIDE_MIN)) { + if ((d2 < (double)LONG_MAX) && (d2 > (double)LONG_MIN)) { compare = mp_cmp_d(&big1, 0); mp_clear(&big1); return compare; } if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) @@ -8485,14 +9569,15 @@ compare = mp_cmp(&big1, &big2); mp_clear(&big1); mp_clear(&big2); return compare; } + break; default: Tcl_Panic("unexpected number type"); - return TCL_ERROR; } + return TCL_ERROR; } #ifdef TCL_COMPILE_DEBUG /* *---------------------------------------------------------------------- @@ -8518,13 +9603,14 @@ * stdout. */ { Proc *procPtr = codePtr->procPtr; Interp *iPtr = (Interp *) *codePtr->interpHandle; - fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %" TCL_Z_MODIFIER "u, epoch %" TCL_Z_MODIFIER "u, interp 0x%p (epoch %" TCL_Z_MODIFIER "u)\n", + fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %u, epoch %u, interp 0x%p (epoch %u)\n", codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr, iPtr->compileEpoch); + fprintf(stdout, " Source: "); TclPrintSource(stdout, codePtr->source, 60); fprintf(stdout, "\n Cmds %d, src %d, inst %u, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", codePtr->numCommands, codePtr->numSrcBytes, @@ -8546,11 +9632,11 @@ (unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)), codePtr->numCmdLocBytes); #endif /* TCL_COMPILE_STATS */ if (procPtr != NULL) { fprintf(stdout, - " Proc 0x%p, refCt %" TCL_Z_MODIFIER "u, args %d, compiled locals %d\n", + " Proc 0x%p, refCt %d, args %d, compiled locals %d\n", procPtr, procPtr->refCount, procPtr->numArgs, procPtr->numCompiledLocals); } } #endif /* TCL_COMPILE_DEBUG */ @@ -8587,40 +9673,40 @@ int checkStack) /* 0 if the stack depth check should be * skipped. */ { int stackUpperBound = codePtr->maxStackDepth; /* Greatest legal value for stackTop. */ - size_t relativePc = (size_t) (pc - codePtr->codeStart); - size_t codeStart = (size_t) codePtr->codeStart; - size_t codeEnd = (size_t) + unsigned relativePc = (unsigned) (pc - codePtr->codeStart); + unsigned long codeStart = (unsigned long) codePtr->codeStart; + unsigned long codeEnd = (unsigned long) (codePtr->codeStart + codePtr->numCodeBytes); unsigned char opCode = *pc; - if (((size_t) pc < codeStart) || ((size_t) pc > codeEnd)) { + if (((unsigned long) pc < codeStart) || ((unsigned long) pc > codeEnd)) { fprintf(stderr, "\nBad instruction pc 0x%p in TclNRExecuteByteCode\n", pc); Tcl_Panic("TclNRExecuteByteCode execution failure: bad pc"); } - if ((unsigned) opCode >= LAST_INST_OPCODE) { - fprintf(stderr, "\nBad opcode %d at pc %" TCL_Z_MODIFIER "u in TclNRExecuteByteCode\n", + if ((unsigned) opCode > LAST_INST_OPCODE) { + fprintf(stderr, "\nBad opcode %d at pc %u in TclNRExecuteByteCode\n", (unsigned) opCode, relativePc); Tcl_Panic("TclNRExecuteByteCode execution failure: bad opcode"); } if (checkStack && ((stackTop < 0) || (stackTop > stackUpperBound))) { - size_t numChars; + int numChars; const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL, NULL); - fprintf(stderr, "\nBad stack top %d at pc %" TCL_Z_MODIFIER "u in TclNRExecuteByteCode (min 0, max %i)", + fprintf(stderr, "\nBad stack top %d at pc %u in TclNRExecuteByteCode (min 0, max %i)", stackTop, relativePc, stackUpperBound); if (cmd != NULL) { Tcl_Obj *message; TclNewLiteralStringObj(message, "\n executing "); Tcl_IncrRefCount(message); Tcl_AppendLimitedToObj(message, cmd, numChars, 100, NULL); - fprintf(stderr,"%s\n", TclGetString(message)); + fprintf(stderr,"%s\n", Tcl_GetString(message)); Tcl_DecrRefCount(message); } else { fprintf(stderr, "\n"); } Tcl_Panic("TclNRExecuteByteCode execution failure: bad stack top"); @@ -8656,20 +9742,29 @@ * with the illegal type. */ { ClientData ptr; int type; const unsigned char opcode = *pc; - const char *description, *operator = "unknown"; + const char *description, *op = "unknown"; if (opcode == INST_EXPON) { - operator = "**"; + op = "**"; } else if (opcode <= INST_LNOT) { - operator = operatorStrings[opcode - INST_BITOR]; + op = operatorStrings[opcode - INST_LOR]; } if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) { - description = "non-numeric string"; + int numBytes; + const char *bytes = Tcl_GetStringFromObj(opndPtr, &numBytes); + + if (numBytes == 0) { + description = "empty string"; + } else if (TclCheckBadOctal(NULL, bytes)) { + description = "invalid octal number"; + } else { + description = "non-numeric string"; + } } else if (type == TCL_NUMBER_NAN) { description = "non-numeric floating-point value"; } else if (type == TCL_NUMBER_DOUBLE) { description = "floating-point value"; } else { @@ -8676,12 +9771,11 @@ /* TODO: No caller needs this. Eliminate? */ description = "(big) integer"; } Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't use %s \"%s\" as operand of \"%s\"", description, - TclGetString(opndPtr), operator)); + "can't use %s as operand of \"%s\"", description, op)); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", description, NULL); } /* *---------------------------------------------------------------------- @@ -8754,12 +9848,11 @@ * there find the list of word locations for this command. */ ExtCmdLoc *eclPtr; ECL *locPtr = NULL; - size_t srcOffset; - int i; + int srcOffset, i; Interp *iPtr = (Interp *) *codePtr->interpHandle; Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr); if (!hePtr) { @@ -8801,32 +9894,32 @@ * return the closest command's source info. * This points within a bytecode instruction * in codePtr's code. */ ByteCode *codePtr, /* The bytecode sequence in which to look up * the command source for the pc. */ - size_t *lengthPtr, /* If non-NULL, the location where the length + int *lengthPtr, /* If non-NULL, the location where the length * of the command's source should be stored. * If NULL, no length is stored. */ const unsigned char **pcBeg,/* If non-NULL, the bytecode location * where the current instruction starts. * If NULL; no pointer is stored. */ int *cmdIdxPtr) /* If non-NULL, the location where the index * of the command containing the pc should * be stored. */ { - size_t pcOffset = (size_t)(pc - codePtr->codeStart); - size_t numCmds = codePtr->numCommands; + int pcOffset = (pc - codePtr->codeStart); + int numCmds = codePtr->numCommands; unsigned char *codeDeltaNext, *codeLengthNext; unsigned char *srcDeltaNext, *srcLengthNext; - size_t codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i; + int codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i; int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */ int bestSrcOffset = -1; /* Initialized to avoid compiler warning. */ int bestSrcLength = -1; /* Initialized to avoid compiler warning. */ int bestCmdIdx = -1; /* The pc must point within the bytecode */ - assert (pcOffset < (size_t)codePtr->numCodeBytes); + assert ((pcOffset >= 0) && (pcOffset < codePtr->numCodeBytes)); /* * Decode the code and source offset and length for each command. The * closest enclosing command is the last one whose code started before * pcOffset. @@ -8965,12 +10058,12 @@ * for the enclosing ExceptionRange. */ { ExceptionRange *rangeArrayPtr; int numRanges = codePtr->numExceptRanges; ExceptionRange *rangePtr; - size_t pcOffset = pc - codePtr->codeStart; - size_t start; + int pcOffset = pc - codePtr->codeStart; + int start; if (numRanges == 0) { return NULL; } @@ -9072,11 +10165,11 @@ } else { Tcl_Obj *objPtr = Tcl_ObjPrintf( "unknown floating-point error, errno = %d", errno); Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", - TclGetString(objPtr), NULL); + Tcl_GetString(objPtr), NULL); Tcl_SetObjResult(interp, objPtr); } } #ifdef TCL_COMPILE_STATS @@ -9143,20 +10236,21 @@ double totalCodeBytes, currentCodeBytes; double totalLiteralBytes, currentLiteralBytes; double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved; double strBytesSharedMultX, strBytesSharedOnce; double numInstructions, currentHeaderBytes; - size_t numCurrentByteCodes, numByteCodeLits; - size_t refCountSum, literalMgmtBytes, sum, decadeHigh, length; - size_t numSharedMultX, numSharedOnce, minSizeDecade, maxSizeDecade, i; + long numCurrentByteCodes, numByteCodeLits; + long refCountSum, literalMgmtBytes, sum; + int numSharedMultX, numSharedOnce; + int decadeHigh, minSizeDecade, maxSizeDecade, length, i; char *litTableStats; LiteralEntry *entryPtr; Tcl_Obj *objPtr; #define Percent(a,b) ((a) * 100.0 / (b)) - objPtr = Tcl_NewObj(); + TclNewObj(objPtr); Tcl_IncrRefCount(objPtr); numInstructions = 0.0; for (i = 0; i < 256; i++) { if (statsPtr->instructionCount[i] != 0) { @@ -9187,16 +10281,16 @@ * Summary statistics, total and current source and ByteCode sizes. */ Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n"); Tcl_AppendPrintfToObj(objPtr, - "Compilation and execution statistics for interpreter %p\n", - iPtr); + "Compilation and execution statistics for interpreter %#lx\n", + (long int)iPtr); - Tcl_AppendPrintfToObj(objPtr, "\nNumber ByteCodes executed\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, "\nNumber ByteCodes executed\t%ld\n", statsPtr->numExecutions); - Tcl_AppendPrintfToObj(objPtr, "Number ByteCodes compiled\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, "Number ByteCodes compiled\t%ld\n", statsPtr->numCompilations); Tcl_AppendPrintfToObj(objPtr, " Mean executions/compile\t%.1f\n", statsPtr->numExecutions / (float)statsPtr->numCompilations); Tcl_AppendPrintfToObj(objPtr, "\nInstructions executed\t\t%.0f\n", @@ -9204,46 +10298,46 @@ Tcl_AppendPrintfToObj(objPtr, " Mean inst/compile\t\t%.0f\n", numInstructions / statsPtr->numCompilations); Tcl_AppendPrintfToObj(objPtr, " Mean inst/execution\t\t%.0f\n", numInstructions / statsPtr->numExecutions); - Tcl_AppendPrintfToObj(objPtr, "\nTotal ByteCodes\t\t\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, "\nTotal ByteCodes\t\t\t%ld\n", statsPtr->numCompilations); Tcl_AppendPrintfToObj(objPtr, " Source bytes\t\t\t%.6g\n", statsPtr->totalSrcBytes); Tcl_AppendPrintfToObj(objPtr, " Code bytes\t\t\t%.6g\n", totalCodeBytes); Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes\t\t%.6g\n", statsPtr->totalByteCodeBytes); Tcl_AppendPrintfToObj(objPtr, " Literal bytes\t\t%.6g\n", totalLiteralBytes); - Tcl_AppendPrintfToObj(objPtr, " table %" TCL_Z_MODIFIER "u + bkts %" TCL_Z_MODIFIER "u + entries %" TCL_Z_MODIFIER "u + objects %" TCL_Z_MODIFIER "u + strings %.6g\n", - sizeof(LiteralTable), - iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), - statsPtr->numLiteralsCreated * sizeof(LiteralEntry), - statsPtr->numLiteralsCreated * sizeof(Tcl_Obj), + Tcl_AppendPrintfToObj(objPtr, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n", + (unsigned long) sizeof(LiteralTable), + (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)), + (unsigned long) (statsPtr->numLiteralsCreated * sizeof(LiteralEntry)), + (unsigned long) (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj)), statsPtr->totalLitStringBytes); Tcl_AppendPrintfToObj(objPtr, " Mean code/compile\t\t%.1f\n", totalCodeBytes / statsPtr->numCompilations); Tcl_AppendPrintfToObj(objPtr, " Mean code/source\t\t%.1f\n", totalCodeBytes / statsPtr->totalSrcBytes); - Tcl_AppendPrintfToObj(objPtr, "\nCurrent (active) ByteCodes\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, "\nCurrent (active) ByteCodes\t%ld\n", numCurrentByteCodes); Tcl_AppendPrintfToObj(objPtr, " Source bytes\t\t\t%.6g\n", statsPtr->currentSrcBytes); Tcl_AppendPrintfToObj(objPtr, " Code bytes\t\t\t%.6g\n", currentCodeBytes); Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes\t\t%.6g\n", statsPtr->currentByteCodeBytes); Tcl_AppendPrintfToObj(objPtr, " Literal bytes\t\t%.6g\n", currentLiteralBytes); - Tcl_AppendPrintfToObj(objPtr, " table %" TCL_Z_MODIFIER "u + bkts %" TCL_Z_MODIFIER "u + entries %" TCL_Z_MODIFIER "u + objects %" TCL_Z_MODIFIER "u + strings %.6g\n", - sizeof(LiteralTable), - iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), - iPtr->literalTable.numEntries * sizeof(LiteralEntry), - iPtr->literalTable.numEntries * sizeof(Tcl_Obj), + Tcl_AppendPrintfToObj(objPtr, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n", + (unsigned long) sizeof(LiteralTable), + (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)), + (unsigned long) (iPtr->literalTable.numEntries * sizeof(LiteralEntry)), + (unsigned long) (iPtr->literalTable.numEntries * sizeof(Tcl_Obj)), statsPtr->currentLitStringBytes); Tcl_AppendPrintfToObj(objPtr, " Mean code/source\t\t%.1f\n", currentCodeBytes / statsPtr->currentSrcBytes); Tcl_AppendPrintfToObj(objPtr, " Code + source bytes\t\t%.6g (%0.1f mean code/src)\n", (currentCodeBytes + statsPtr->currentSrcBytes), @@ -9256,21 +10350,21 @@ * Shared objects must be duplicated before they can be modified. */ numSharedMultX = 0; Tcl_AppendPrintfToObj(objPtr, "\nTcl_IsShared object check (all objects):\n"); - Tcl_AppendPrintfToObj(objPtr, " Object had refcount <=1 (not shared)\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, " Object had refcount <=1 (not shared)\t%ld\n", tclObjsShared[1]); for (i = 2; i < TCL_MAX_SHARED_OBJ_STATS; i++) { - Tcl_AppendPrintfToObj(objPtr, " refcount ==%" TCL_Z_MODIFIER "u\t\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, " refcount ==%d\t\t%ld\n", i, tclObjsShared[i]); numSharedMultX += tclObjsShared[i]; } - Tcl_AppendPrintfToObj(objPtr, " refcount >=%" TCL_Z_MODIFIER "u\t\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, " refcount >=%d\t\t%ld\n", i, tclObjsShared[0]); numSharedMultX += tclObjsShared[0]; - Tcl_AppendPrintfToObj(objPtr, " Total shared objects\t\t\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, " Total shared objects\t\t\t%d\n", numSharedMultX); /* * Literal table statistics. */ @@ -9284,14 +10378,14 @@ strBytesSharedMultX = 0.0; strBytesSharedOnce = 0.0; for (i = 0; i < globalTablePtr->numBuckets; i++) { for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL; entryPtr = entryPtr->nextPtr) { - if (TclHasIntRep(entryPtr->objPtr, &tclByteCodeType)) { + if (entryPtr->objPtr->typePtr == &tclByteCodeType) { numByteCodeLits++; } - (void) TclGetStringFromObj(entryPtr->objPtr, &length); + (void) Tcl_GetStringFromObj(entryPtr->objPtr, &length); refCountSum += entryPtr->refCount; objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj)); strBytesIfUnshared += (entryPtr->refCount * (length+1)); if (entryPtr->refCount > 1) { numSharedMultX++; @@ -9303,24 +10397,24 @@ } } sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared) - currentLiteralBytes; - Tcl_AppendPrintfToObj(objPtr, "\nTotal objects (all interps)\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, "\nTotal objects (all interps)\t%ld\n", tclObjsAlloced); - Tcl_AppendPrintfToObj(objPtr, "Current objects\t\t\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, "Current objects\t\t\t%ld\n", (tclObjsAlloced - tclObjsFreed)); - Tcl_AppendPrintfToObj(objPtr, "Total literal objects\t\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, "Total literal objects\t\t%ld\n", statsPtr->numLiteralsCreated); - Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal objects\t\t%" TCL_Z_MODIFIER "u (%0.1f%% of current objects)\n", + Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal objects\t\t%d (%0.1f%% of current objects)\n", globalTablePtr->numEntries, Percent(globalTablePtr->numEntries, tclObjsAlloced-tclObjsFreed)); - Tcl_AppendPrintfToObj(objPtr, " ByteCode literals\t\t%" TCL_Z_MODIFIER "u (%0.1f%% of current literals)\n", + Tcl_AppendPrintfToObj(objPtr, " ByteCode literals\t\t%ld (%0.1f%% of current literals)\n", numByteCodeLits, Percent(numByteCodeLits, globalTablePtr->numEntries)); - Tcl_AppendPrintfToObj(objPtr, " Literals reused > 1x\t\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, " Literals reused > 1x\t\t%d\n", numSharedMultX); Tcl_AppendPrintfToObj(objPtr, " Mean reference count\t\t%.2f\n", ((double) refCountSum) / globalTablePtr->numEntries); Tcl_AppendPrintfToObj(objPtr, " Mean len, str reused >1x \t%.2f\n", (numSharedMultX ? strBytesSharedMultX/numSharedMultX : 0.0)); @@ -9341,11 +10435,11 @@ (objBytesIfUnshared + strBytesIfUnshared), objBytesIfUnshared, strBytesIfUnshared); Tcl_AppendPrintfToObj(objPtr, " String sharing savings \t%.6g = unshared %.6g - shared %.6g\n", (strBytesIfUnshared - statsPtr->currentLitStringBytes), strBytesIfUnshared, statsPtr->currentLitStringBytes); - Tcl_AppendPrintfToObj(objPtr, " Literal mgmt overhead\t\t%" TCL_Z_MODIFIER "u (%0.1f%% of bytes with sharing)\n", + Tcl_AppendPrintfToObj(objPtr, " Literal mgmt overhead\t\t%ld (%0.1f%% of bytes with sharing)\n", literalMgmtBytes, Percent(literalMgmtBytes, currentLiteralBytes)); Tcl_AppendPrintfToObj(objPtr, " table %lu + buckets %lu + entries %lu\n", (unsigned long) sizeof(LiteralTable), (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)), @@ -9391,29 +10485,28 @@ */ Tcl_AppendPrintfToObj(objPtr, "\nLiteral string sizes:\n"); Tcl_AppendPrintfToObj(objPtr, "\t Up to length\t\tPercentage\n"); maxSizeDecade = 0; - i = 32; - while (i-- > 0) { + for (i = 31; i >= 0; i--) { if (statsPtr->literalCount[i] > 0) { maxSizeDecade = i; break; } } sum = 0; for (i = 0; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->literalCount[i]; - Tcl_AppendPrintfToObj(objPtr, "\t%10" TCL_Z_MODIFIER "u\t\t%8.0f%%\n", + Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n", decadeHigh, Percent(sum, statsPtr->numLiteralsCreated)); } litTableStats = TclLiteralStats(globalTablePtr); Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal table statistics:\n%s\n", litTableStats); - Tcl_Free(litTableStats); + ckfree(litTableStats); /* * Source and ByteCode size distributions. */ @@ -9434,11 +10527,11 @@ } sum = 0; for (i = minSizeDecade; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->srcCount[i]; - Tcl_AppendPrintfToObj(objPtr, "\t%10" TCL_Z_MODIFIER "u\t\t%8.0f%%\n", + Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n", decadeHigh, Percent(sum, statsPtr->numCompilations)); } Tcl_AppendPrintfToObj(objPtr, "\nByteCode sizes:\n"); Tcl_AppendPrintfToObj(objPtr, "\t Up to size\t\tPercentage\n"); @@ -9457,11 +10550,11 @@ } sum = 0; for (i = minSizeDecade; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->byteCodeCount[i]; - Tcl_AppendPrintfToObj(objPtr, "\t%10" TCL_Z_MODIFIER "u\t\t%8.0f%%\n", + Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n", decadeHigh, Percent(sum, statsPtr->numCompilations)); } Tcl_AppendPrintfToObj(objPtr, "\nByteCode longevity (excludes Current ByteCodes):\n"); Tcl_AppendPrintfToObj(objPtr, "\t Up to ms\t\tPercentage\n"); @@ -9489,12 +10582,12 @@ /* * Instruction counts. */ Tcl_AppendPrintfToObj(objPtr, "\nInstruction counts:\n"); - for (i = 0; i < LAST_INST_OPCODE; i++) { - Tcl_AppendPrintfToObj(objPtr, "%20s %8" TCL_Z_MODIFIER "u ", + for (i = 0; i <= LAST_INST_OPCODE; i++) { + Tcl_AppendPrintfToObj(objPtr, "%20s %8ld ", tclInstructionTable[i].name, statsPtr->instructionCount[i]); if (statsPtr->instructionCount[i]) { Tcl_AppendPrintfToObj(objPtr, "%6.1f%%\n", Percent(statsPtr->instructionCount[i], numInstructions)); } else { @@ -9502,19 +10595,19 @@ } } #ifdef TCL_MEM_DEBUG Tcl_AppendPrintfToObj(objPtr, "\nHeap Statistics:\n"); - TclDumpMemoryInfo(objPtr, 1); + TclDumpMemoryInfo((ClientData) objPtr, 1); #endif Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n"); if (objc == 1) { Tcl_SetObjResult(interp, objPtr); } else { Tcl_Channel outChan; - char *str = TclGetStringFromObj(objv[1], &length); + char *str = Tcl_GetStringFromObj(objv[1], &length); if (length) { if (strcmp(str, "stdout") == 0) { outChan = Tcl_GetStdChannel(TCL_STDOUT); } else if (strcmp(str, "stderr") == 0) { Index: generic/tclFCmd.c ================================================================== --- generic/tclFCmd.c +++ generic/tclFCmd.c @@ -902,11 +902,11 @@ resultPtr = NULL; } } } if (resultPtr == NULL) { - resultPtr = Tcl_NewObj(); + TclNewObj(resultPtr); } Tcl_IncrRefCount(resultPtr); Tcl_DecrRefCount(splitPtr); return resultPtr; } @@ -1083,12 +1083,15 @@ Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL); goto end; } if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings, - "option", INDEX_TEMP_TABLE, &index) != TCL_OK) { + "option", 0, &index) != TCL_OK) { goto end; + } + if (attributeStringsAllocated != NULL) { + TclFreeIntRep(objv[0]); } if (Tcl_FSFileAttrsGet(interp, index, filePtr, &objPtr) != TCL_OK) { goto end; } @@ -1108,12 +1111,15 @@ goto end; } for (i = 0; i < objc ; i += 2) { if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings, - "option", INDEX_TEMP_TABLE, &index) != TCL_OK) { + "option", 0, &index) != TCL_OK) { goto end; + } + if (attributeStringsAllocated != NULL) { + TclFreeIntRep(objv[i]); } if (i + 1 == objc) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "value for \"%s\" missing", TclGetString(objv[i]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FATTR", @@ -1343,11 +1349,11 @@ } /* *--------------------------------------------------------------------------- * - * TclFileTemporaryCmd -- + * TclFileTemporaryCmd * * This function implements the "tempfile" subcommand of the "file" * command. * * Results: @@ -1387,11 +1393,11 @@ if (objc > 1) { nameVarObj = objv[1]; TclNewObj(nameObj); } if (objc > 2) { - size_t length; + int length; Tcl_Obj *templateObj = objv[2]; const char *string = TclGetStringFromObj(templateObj, &length); /* * Treat an empty string as if it wasn't there. @@ -1501,158 +1507,13 @@ } } Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1)); return TCL_OK; } - -/* - *--------------------------------------------------------------------------- - * - * TclFileTempDirCmd -- - * - * This function implements the "tempdir" subcommand of the "file" - * command. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * Creates a temporary directory. - * - *--------------------------------------------------------------------------- - */ - -int -TclFileTempDirCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_Obj *dirNameObj; /* Object that will contain the directory - * name. */ - Tcl_Obj *baseDirObj = NULL, *nameBaseObj = NULL; - /* Pieces of template. Each piece is NULL if - * it is omitted. The platform temporary file - * engine might ignore some pieces. */ - - if (objc < 1 || objc > 2) { - Tcl_WrongNumArgs(interp, 1, objv, "?template?"); - return TCL_ERROR; - } - - if (objc > 1) { - int length; - Tcl_Obj *templateObj = objv[1]; - const char *string = TclGetStringFromObj(templateObj, &length); - const int onWindows = (tclPlatform == TCL_PLATFORM_WINDOWS); - - /* - * Treat an empty string as if it wasn't there. - */ - - if (length == 0) { - goto makeTemporary; - } - - /* - * The template only gives a directory if there is a directory - * separator in it, and only gives a base name if there's at least one - * character after the last directory separator. - */ - - if (strchr(string, '/') == NULL - && (!onWindows || strchr(string, '\\') == NULL)) { - /* - * No directory separator, so just assume we have a file name. - * This is a bit wrong on Windows where we could have problems - * with disk name prefixes... but those are much less common in - * naked form so we just pass through and let the OS figure it out - * instead. - */ - - nameBaseObj = templateObj; - Tcl_IncrRefCount(nameBaseObj); - } else if (string[length-1] != '/' - && (!onWindows || string[length-1] != '\\')) { - /* - * If the template has a non-terminal directory separator, split - * into dirname and tail. - */ - - baseDirObj = TclPathPart(interp, templateObj, TCL_PATH_DIRNAME); - nameBaseObj = TclPathPart(interp, templateObj, TCL_PATH_TAIL); - } else { - /* - * Otherwise, there must be a terminal directory separator, so - * just the directory is given. - */ - - baseDirObj = templateObj; - Tcl_IncrRefCount(baseDirObj); - } - - /* - * Only allow creation of temporary directories in the native - * filesystem since they are frequently used for integration with - * external tools or system libraries. - */ - - if (baseDirObj != NULL && Tcl_FSGetFileSystemForPath(baseDirObj) - != &tclNativeFilesystem) { - TclDecrRefCount(baseDirObj); - baseDirObj = NULL; - } - } - - /* - * Convert empty parts of the template into unspecified parts. - */ - - if (baseDirObj && !TclGetString(baseDirObj)[0]) { - TclDecrRefCount(baseDirObj); - baseDirObj = NULL; - } - if (nameBaseObj && !TclGetString(nameBaseObj)[0]) { - TclDecrRefCount(nameBaseObj); - nameBaseObj = NULL; - } - - /* - * Create and open the temporary file. - */ - - makeTemporary: - dirNameObj = TclpCreateTemporaryDirectory(baseDirObj, nameBaseObj); - - /* - * If we created pieces of template, get rid of them now. - */ - - if (baseDirObj) { - TclDecrRefCount(baseDirObj); - } - if (nameBaseObj) { - TclDecrRefCount(nameBaseObj); - } - - /* - * Deal with results. - */ - - if (dirNameObj == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't create temporary directory: %s", - Tcl_PosixError(interp))); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, dirNameObj); - return TCL_OK; -} /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: generic/tclFileName.c ================================================================== --- generic/tclFileName.c +++ generic/tclFileName.c @@ -384,11 +384,12 @@ int *driveNameLengthPtr, /* Returns length of drive, if non-NULL and * path was absolute */ Tcl_Obj **driveNameRef) { Tcl_PathType type = TCL_PATH_ABSOLUTE; - const char *path = TclGetString(pathPtr); + int pathLen; + const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen); if (path[0] == '~') { /* * This case is common to all platforms. Paths that begin with ~ are * absolute. @@ -501,15 +502,15 @@ * Perform platform specific splitting. */ switch (tclPlatform) { case TCL_PLATFORM_UNIX: - resultPtr = SplitUnixPath(TclGetString(pathPtr)); + resultPtr = SplitUnixPath(Tcl_GetString(pathPtr)); break; case TCL_PLATFORM_WINDOWS: - resultPtr = SplitWinPath(TclGetString(pathPtr)); + resultPtr = SplitWinPath(Tcl_GetString(pathPtr)); break; } /* * Compute the number of elements in the result. @@ -534,11 +535,11 @@ * of path components. *argvPtr will be filled in with the address of an * array whose elements point to the elements of path, in order. * *argcPtr will get filled in with the number of valid elements in the * array. A single block of memory is dynamically allocated to hold both * the argv array and a copy of the path elements. The caller must - * eventually free this memory by calling Tcl_Free() on *argvPtr. Note: + * eventually free this memory by calling ckfree() on *argvPtr. Note: * *argvPtr and *argcPtr are only modified if the procedure returns * normally. * * Side effects: * Allocates memory. @@ -554,12 +555,11 @@ const char ***argvPtr) /* Pointer to place to store pointer to array * of pointers to path elements. */ { Tcl_Obj *resultPtr = NULL; /* Needed only to prevent gcc warnings. */ Tcl_Obj *tmpPtr, *eltPtr; - int i; - size_t size, len; + int i, size, len; char *p; const char *str; /* * Perform the splitting, using objectified, vfs-aware code. @@ -576,31 +576,32 @@ */ size = 1; for (i = 0; i < *argcPtr; i++) { Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr); - (void)TclGetStringFromObj(eltPtr, &len); + Tcl_GetStringFromObj(eltPtr, &len); size += len + 1; } /* * Allocate a buffer large enough to hold the contents of all of the list * plus the argv pointers and the terminating NULL pointer. */ - *argvPtr = Tcl_Alloc((((*argcPtr) + 1) * sizeof(char *)) + size); + *argvPtr = (const char **)ckalloc( + ((((*argcPtr) + 1) * sizeof(char *)) + size)); /* * Position p after the last argv pointer and copy the contents of the * list in, piece by piece. */ p = (char *) &(*argvPtr)[(*argcPtr) + 1]; for (i = 0; i < *argcPtr; i++) { Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr); - str = TclGetStringFromObj(eltPtr, &len); - memcpy(p, str, len+1); + str = Tcl_GetStringFromObj(eltPtr, &len); + memcpy(p, str, len + 1); p += len+1; } /* * Now set up the argv pointers. @@ -640,18 +641,19 @@ static Tcl_Obj * SplitUnixPath( const char *path) /* Pointer to string containing a path. */ { - size_t length; + int length; const char *origPath = path, *elementStart; - Tcl_Obj *result = Tcl_NewObj(); + Tcl_Obj *result; /* * Deal with the root directory as a special case. */ + TclNewObj(result); if (*path == '/') { Tcl_Obj *rootElt; ++path; #if defined(__CYGWIN__) || defined(__QNX__) /* @@ -729,17 +731,18 @@ static Tcl_Obj * SplitWinPath( const char *path) /* Pointer to string containing a path. */ { - size_t length; + int length; const char *p, *elementStart; Tcl_PathType type = TCL_PATH_ABSOLUTE; Tcl_DString buf; - Tcl_Obj *result = Tcl_NewObj(); + Tcl_Obj *result; Tcl_DStringInit(&buf); + TclNewObj(result); p = ExtractWinRoot(path, &buf, 0, &type); /* * Terminate the root portion, if we matched something. */ @@ -819,16 +822,16 @@ pair[0] = pathPtr; pair[1] = objv[0]; return TclJoinPath(2, pair, 0); } else { int elemc = objc + 1; - Tcl_Obj *ret, **elemv = Tcl_Alloc(elemc*sizeof(Tcl_Obj *)); + Tcl_Obj *ret, **elemv = (Tcl_Obj**)ckalloc(elemc*sizeof(Tcl_Obj *)); elemv[0] = pathPtr; memcpy(elemv+1, objv, objc*sizeof(Tcl_Obj *)); ret = TclJoinPath(elemc, elemv, 0); - Tcl_Free(elemv); + ckfree(elemv); return ret; } } /* @@ -850,17 +853,16 @@ void TclpNativeJoinPath( Tcl_Obj *prefix, const char *joining) { - int needsSep; - size_t length; + int length, needsSep; char *dest; const char *p; const char *start; - start = TclGetStringFromObj(prefix, &length); + start = Tcl_GetStringFromObj(prefix, &length); /* * Remove the ./ from tilde prefixed elements, and drive-letter prefixed * elements on Windows, unless it is the first component. */ @@ -884,21 +886,21 @@ * Append a separator if needed. */ if (length > 0 && (start[length-1] != '/')) { Tcl_AppendToObj(prefix, "/", 1); - (void)TclGetStringFromObj(prefix, &length); + Tcl_GetStringFromObj(prefix, &length); } needsSep = 0; /* * Append the element, eliminating duplicate and trailing slashes. */ Tcl_SetObjLength(prefix, length + (int) strlen(p)); - dest = TclGetString(prefix) + length; + dest = Tcl_GetString(prefix) + length; for (; *p != '\0'; p++) { if (*p == '/') { while (p[1] == '/') { p++; } @@ -908,11 +910,11 @@ } else { *dest++ = *p; needsSep = 1; } } - length = dest - TclGetString(prefix); + length = dest - Tcl_GetString(prefix); Tcl_SetObjLength(prefix, length); break; case TCL_PLATFORM_WINDOWS: /* @@ -920,20 +922,20 @@ */ if ((length > 0) && (start[length-1] != '/') && (start[length-1] != ':')) { Tcl_AppendToObj(prefix, "/", 1); - (void)TclGetStringFromObj(prefix, &length); + Tcl_GetStringFromObj(prefix, &length); } needsSep = 0; /* * Append the element, eliminating duplicate and trailing slashes. */ Tcl_SetObjLength(prefix, length + (int) strlen(p)); - dest = TclGetString(prefix) + length; + dest = Tcl_GetString(prefix) + length; for (; *p != '\0'; p++) { if ((*p == '/') || (*p == '\\')) { while ((p[1] == '/') || (p[1] == '\\')) { p++; } @@ -943,11 +945,11 @@ } else { *dest++ = *p; needsSep = 1; } } - length = dest - TclGetString(prefix); + length = dest - Tcl_GetString(prefix); Tcl_SetObjLength(prefix, length); break; } return; } @@ -975,20 +977,20 @@ Tcl_JoinPath( int argc, const char *const *argv, Tcl_DString *resultPtr) /* Pointer to previously initialized DString */ { - int i; - size_t len; - Tcl_Obj *listObj = Tcl_NewObj(); + int i, len; + Tcl_Obj *listObj; Tcl_Obj *resultObj; const char *resultStr; /* * Build the list of paths. */ + TclNewObj(listObj); for (i = 0; i < argc; i++) { Tcl_ListObjAppendElement(NULL, listObj, Tcl_NewStringObj(argv[i], -1)); } @@ -1003,11 +1005,11 @@ /* * Store the result. */ - resultStr = TclGetStringFromObj(resultObj, &len); + resultStr = Tcl_GetStringFromObj(resultObj, &len); Tcl_DStringAppend(resultPtr, resultStr, len); Tcl_DecrRefCount(resultObj); /* * Return a pointer to the result. @@ -1072,11 +1074,11 @@ * Convert forward slashes to backslashes in Windows paths because some * system interfaces don't accept forward slashes. */ if (tclPlatform == TCL_PLATFORM_WINDOWS) { - register char *p; + char *p; for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) { if (*p == '/') { *p = '\\'; } } @@ -1217,11 +1219,10 @@ * See the user documentation. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ int Tcl_GlobObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ @@ -1235,25 +1236,26 @@ Tcl_DString prefix; static const char *const options[] = { "-directory", "-join", "-nocomplain", "-path", "-tails", "-types", "--", NULL }; - enum options { + enum globOptionsEnum { GLOB_DIR, GLOB_JOIN, GLOB_NOCOMPLAIN, GLOB_PATH, GLOB_TAILS, GLOB_TYPE, GLOB_LAST }; enum pathDirOptions {PATH_NONE = -1 , PATH_GENERAL = 0, PATH_DIR = 1}; Tcl_GlobTypeData *globTypes = NULL; + (void)dummy; globFlags = 0; join = 0; dir = PATH_NONE; typePtr = NULL; for (i = 1; i < objc; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) != TCL_OK) { - string = TclGetString(objv[i]); + string = Tcl_GetStringFromObj(objv[i], &length); if (string[0] == '-') { /* * It looks like the command contains an option so signal an * error. */ @@ -1268,11 +1270,11 @@ Tcl_ResetResult(interp); break; } } - switch (index) { + switch ((enum globOptionsEnum) index) { case GLOB_NOCOMPLAIN: /* -nocomplain */ globFlags |= TCL_GLOBMODE_NO_COMPLAIN; break; case GLOB_DIR: /* -dir */ if (i == (objc-1)) { @@ -1281,11 +1283,14 @@ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); return TCL_ERROR; } if (dir != PATH_NONE) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "\"-directory\" cannot be used with \"-path\"", -1)); + dir == PATH_DIR + ? "\"-directory\" may only be used once" + : "\"-directory\" cannot be used with \"-path\"", + -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BADOPTIONCOMBINATION", NULL); return TCL_ERROR; } dir = PATH_DIR; @@ -1306,11 +1311,14 @@ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); return TCL_ERROR; } if (dir != PATH_NONE) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "\"-path\" cannot be used with \"-directory\"", -1)); + dir == PATH_GENERAL + ? "\"-path\" may only be used once" + : "\"-path\" cannot be used with \"-dictionary\"", + -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BADOPTIONCOMBINATION", NULL); return TCL_ERROR; } dir = PATH_GENERAL; @@ -1344,11 +1352,11 @@ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BADOPTIONCOMBINATION", NULL); return TCL_ERROR; } - separators = NULL; /* lint. */ + separators = NULL; switch (tclPlatform) { case TCL_PLATFORM_UNIX: separators = "/"; break; case TCL_PLATFORM_WINDOWS: @@ -1355,13 +1363,13 @@ separators = "/\\:"; break; } if (dir == PATH_GENERAL) { - size_t pathlength; + int pathlength; const char *last; - const char *first = TclGetStringFromObj(pathOrDir,&pathlength); + const char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength); /* * Find the last path separator in the path */ @@ -1407,11 +1415,11 @@ * a valid path like '/' or 'C:/' into an incorrect path like * '' or 'C:'. The way we do this is to add a separator if * there are none presently in the prefix. */ - if (strpbrk(TclGetString(pathOrDir), "\\/") == NULL) { + if (strpbrk(Tcl_GetString(pathOrDir), "\\/") == NULL) { Tcl_AppendToObj(pathOrDir, last-1, 1); } } /* @@ -1449,22 +1457,22 @@ Tcl_ListObjLength(interp, typePtr, &length); if (length <= 0) { goto skipTypes; } - globTypes = TclStackAlloc(interp, sizeof(Tcl_GlobTypeData)); + globTypes = (Tcl_GlobTypeData *)TclStackAlloc(interp, sizeof(Tcl_GlobTypeData)); globTypes->type = 0; globTypes->perm = 0; globTypes->macType = NULL; globTypes->macCreator = NULL; while (--length >= 0) { - size_t len; + int len; const char *str; Tcl_ListObjIndex(interp, typePtr, length, &look); - str = TclGetStringFromObj(look, &len); + str = Tcl_GetStringFromObj(look, &len); if (strcmp("readonly", str) == 0) { globTypes->perm |= TCL_GLOB_PERM_RONLY; } else if (strcmp("hidden", str) == 0) { globTypes->perm |= TCL_GLOB_PERM_HIDDEN; } else if (len == 1) { @@ -1514,26 +1522,25 @@ globTypes->macType = look; Tcl_IncrRefCount(look); } else { Tcl_Obj *item; - int llen; - if ((Tcl_ListObjLength(NULL, look, &llen) == TCL_OK) - && (llen == 3)) { + if ((Tcl_ListObjLength(NULL, look, &len) == TCL_OK) + && (len == 3)) { Tcl_ListObjIndex(interp, look, 0, &item); - if (!strcmp("macintosh", TclGetString(item))) { + if (!strcmp("macintosh", Tcl_GetString(item))) { Tcl_ListObjIndex(interp, look, 1, &item); - if (!strcmp("type", TclGetString(item))) { + if (!strcmp("type", Tcl_GetString(item))) { Tcl_ListObjIndex(interp, look, 2, &item); if (globTypes->macType != NULL) { goto badMacTypesArg; } globTypes->macType = item; Tcl_IncrRefCount(item); continue; - } else if (!strcmp("creator", TclGetString(item))) { + } else if (!strcmp("creator", Tcl_GetString(item))) { Tcl_ListObjIndex(interp, look, 2, &item); if (globTypes->macCreator != NULL) { goto badMacTypesArg; } globTypes->macCreator = item; @@ -1549,11 +1556,11 @@ */ badTypesArg: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad argument to \"-types\": %s", - TclGetString(look))); + Tcl_GetString(look))); Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", NULL); result = TCL_ERROR; join = 0; goto endOfGlob; @@ -1613,11 +1620,11 @@ } } Tcl_DStringFree(&str); } else { for (i = 0; i < objc; i++) { - string = TclGetString(objv[i]); + string = Tcl_GetString(objv[i]); if (TclGlob(interp, string, pathOrDir, globFlags, globTypes) != TCL_OK) { result = TCL_ERROR; goto endOfGlob; } @@ -1645,11 +1652,11 @@ } else { const char *sep = ""; for (i = 0; i < objc; i++) { Tcl_AppendPrintfToObj(errorMsg, "%s%s", - sep, TclGetString(objv[i])); + sep, Tcl_GetString(objv[i])); sep = " "; } } Tcl_AppendToObj(errorMsg, "\"", -1); Tcl_SetObjResult(interp, errorMsg); @@ -1681,13 +1688,12 @@ /* *---------------------------------------------------------------------- * * TclGlob -- * - * This procedure prepares arguments for the DoGlob call. It sets the - * separator string based on the platform, performs * tilde substitution, - * and calls DoGlob. + * Sets the separator string based on the platform, performs tilde + * substitution, and calls DoGlob. * * The interpreter's result, on entry to this function, must be a valid * Tcl list (e.g. it could be empty), since we will lappend any new * results to that list. If it is not a valid list, this function will * fail to do anything very meaningful. @@ -1706,11 +1712,10 @@ * The 'pattern' is written to. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ int TclGlob( Tcl_Interp *interp, /* Interpreter for returning error message or * appending list of matching file names. */ char *pattern, /* Glob pattern to match. Must not refer to a @@ -1725,11 +1730,11 @@ const char *head; char *tail, *start; int result; Tcl_Obj *filenamesObj, *savedResultObj; - separators = NULL; /* lint. */ + separators = NULL; switch (tclPlatform) { case TCL_PLATFORM_UNIX: separators = "/"; break; case TCL_PLATFORM_WINDOWS: @@ -1848,11 +1853,11 @@ if (cwd == NULL) { Tcl_DecrRefCount(temp); return TCL_ERROR; } - pathPrefix = Tcl_NewStringObj(TclGetString(cwd), 3); + pathPrefix = Tcl_NewStringObj(Tcl_GetString(cwd), 3); Tcl_DecrRefCount(cwd); if (tail[0] == '/') { tail++; } else { tail += 2; @@ -1882,11 +1887,11 @@ */ separators = "/\\"; } else if (tclPlatform == TCL_PLATFORM_UNIX) { - if (pathPrefix == NULL && tail[0] == '/' && tail[1] != '/') { + if (pathPrefix == NULL && tail[0] == '/') { pathPrefix = Tcl_NewStringObj(tail, 1); tail++; Tcl_IncrRefCount(pathPrefix); } } @@ -1982,11 +1987,11 @@ */ if (globFlags & TCL_GLOBMODE_TAILS) { int objc, i; Tcl_Obj **objv; - size_t prefixLen; + int prefixLen; const char *pre; /* * If this length has never been set, set it here. */ @@ -1993,11 +1998,11 @@ if (pathPrefix == NULL) { Tcl_Panic("Called TclGlob with TCL_GLOBMODE_TAILS and pathPrefix==NULL"); } - pre = TclGetStringFromObj(pathPrefix, &prefixLen); + pre = Tcl_GetStringFromObj(pathPrefix, &prefixLen); if (prefixLen > 0 && (strchr(separators, pre[prefixLen-1]) == NULL)) { /* * If we're on Windows and the prefix is a volume relative one * like 'C:', then there won't be a path separator in between, so @@ -2010,12 +2015,12 @@ } } Tcl_ListObjGetElements(NULL, filenamesObj, &objc, &objv); for (i = 0; i< objc; i++) { - size_t len; - const char *oldStr = TclGetStringFromObj(objv[i], &len); + int len; + const char *oldStr = Tcl_GetStringFromObj(objv[i], &len); Tcl_Obj *elem; if (len == prefixLen) { if ((pattern[0] == '\0') || (strchr(separators, pattern[0]) == NULL)) { @@ -2059,11 +2064,11 @@ *---------------------------------------------------------------------- * * SkipToChar -- * * This function traverses a glob pattern looking for the next unquoted - * occurance of the specified character at the same braces nesting level. + * occurrence of the specified character at the same braces nesting level. * * Results: * Updates stringPtr to point to the matching character, or to the end of * the string if nothing matched. The return value is 1 if a match was * found at the top level, otherwise it is 0. @@ -2078,11 +2083,11 @@ SkipToChar( char **stringPtr, /* Pointer string to check. */ int match) /* Character to find. */ { int quoted, level; - register char *p; + char *p; quoted = 0; level = 0; for (p = *stringPtr; *p != '\0'; p++) { @@ -2342,11 +2347,11 @@ result = Tcl_ListObjGetElements(interp, subdirsPtr, &subdirc, &subdirv); for (i=0; result==TCL_OK && i 0) && (strchr(separators, joined[len-1]) == NULL)) { Tcl_AppendToObj(joinedPtr, "/", 1); } } Tcl_AppendToObj(joinedPtr, Tcl_DStringValue(&append), Tcl_DStringLength(&append)); @@ -2483,14 +2488,14 @@ * when not using -dir or -path, e.g. 'glob [file join * //machine/share/subdir *]' requires adding a separator here. * This behaviour is not currently tested for in the test suite. */ - size_t len; - const char *joined = TclGetStringFromObj(joinedPtr,&len); + int len; + const char *joined = Tcl_GetStringFromObj(joinedPtr,&len); - if (strchr(separators, joined[len-1]) == NULL) { + if ((len > 0) && (strchr(separators, joined[len-1]) == NULL)) { if (Tcl_FSGetPathType(pathPtr) != TCL_PATH_VOLUME_RELATIVE) { Tcl_AppendToObj(joinedPtr, "/", 1); } } } @@ -2513,11 +2518,11 @@ * extensions may be used unchanged on systems where largefile support is * optional. * * Results: * A pointer to a Tcl_StatBuf which may be deallocated by being passed to - * Tcl_Free(). + * ckfree(). * * Side effects: * None. * *--------------------------------------------------------------------------- @@ -2524,11 +2529,11 @@ */ Tcl_StatBuf * Tcl_AllocStatBuf(void) { - return Tcl_Alloc(sizeof(Tcl_StatBuf)); + return (Tcl_StatBuf *)ckalloc(sizeof(Tcl_StatBuf)); } /* *--------------------------------------------------------------------------- * @@ -2549,25 +2554,25 @@ unsigned Tcl_GetFSDeviceFromStat( const Tcl_StatBuf *statPtr) { - return statPtr->st_dev; + return (unsigned) statPtr->st_dev; } unsigned Tcl_GetFSInodeFromStat( const Tcl_StatBuf *statPtr) { - return statPtr->st_ino; + return (unsigned) statPtr->st_ino; } unsigned Tcl_GetModeFromStat( const Tcl_StatBuf *statPtr) { - return statPtr->st_mode; + return (unsigned) statPtr->st_mode; } int Tcl_GetLinkCountFromStat( const Tcl_StatBuf *statPtr) @@ -2629,11 +2634,11 @@ const Tcl_StatBuf *statPtr) { #ifdef HAVE_STRUCT_STAT_ST_BLOCKS return (Tcl_WideUInt) statPtr->st_blocks; #else - register unsigned blksize = Tcl_GetBlockSizeFromStat(statPtr); + unsigned blksize = Tcl_GetBlockSizeFromStat(statPtr); return ((Tcl_WideUInt) statPtr->st_size + blksize - 1) / blksize; #endif } @@ -2640,11 +2645,11 @@ unsigned Tcl_GetBlockSizeFromStat( const Tcl_StatBuf *statPtr) { #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE - return statPtr->st_blksize; + return (unsigned) statPtr->st_blksize; #else /* * Not a great guess, but will do... */ Index: generic/tclFileSystem.h ================================================================== --- generic/tclFileSystem.h +++ generic/tclFileSystem.h @@ -28,11 +28,11 @@ MODULE_SCOPE Tcl_Obj * TclFSMakePathRelative(Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_Obj *cwdPtr); MODULE_SCOPE int TclFSEnsureEpochOk(Tcl_Obj *pathPtr, const Tcl_Filesystem **fsPtrPtr); MODULE_SCOPE void TclFSSetPathDetails(Tcl_Obj *pathPtr, - const Tcl_Filesystem *fsPtr, void *clientData); + const Tcl_Filesystem *fsPtr, ClientData clientData); MODULE_SCOPE Tcl_Obj * TclFSNormalizeAbsolutePath(Tcl_Interp *interp, Tcl_Obj *pathPtr); MODULE_SCOPE size_t TclFSEpoch(void); /* Index: generic/tclGet.c ================================================================== --- generic/tclGet.c +++ generic/tclGet.c @@ -140,11 +140,11 @@ code = TclSetBooleanFromAny(interp, &obj); if (obj.refCount > 1) { Tcl_Panic("invalid sharing of Tcl_Obj on C stack"); } if (code == TCL_OK) { - *boolPtr = obj.internalRep.wideValue != 0; + *boolPtr = obj.internalRep.longValue; } return code; } /* Index: generic/tclGetDate.y ================================================================== --- generic/tclGetDate.y +++ generic/tclGetDate.y @@ -14,11 +14,11 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ %parse-param {DateInfo* info} %lex-param {DateInfo* info} -%pure-parser +%define api.pure /* %error-verbose would be nice, but our token names are meaningless */ %locations %{ /* @@ -43,10 +43,18 @@ #ifdef _MSC_VER #pragma warning( disable : 4102 ) #endif /* _MSC_VER */ +/* + * Meridian: am, pm, or 24-hour style. + */ + +typedef enum _MERIDIAN { + MERam, MERpm, MER24 +} MERIDIAN; + /* * yyparse will accept a 'struct DateInfo' as its parameter; that's where the * parsed fields will be returned. */ @@ -61,11 +69,11 @@ int dateHaveDate; time_t dateHour; time_t dateMinutes; time_t dateSeconds; - int dateMeridian; + MERIDIAN dateMeridian; int dateHaveTime; time_t dateTimezone; int dateDSTmode; int dateHaveZone; @@ -87,12 +95,12 @@ time_t *dateRelPointer; int dateDigitCount; } DateInfo; -#define YYMALLOC Tcl_Alloc -#define YYFREE(x) (Tcl_Free((void*) (x))) +#define YYMALLOC ckalloc +#define YYFREE(x) (ckfree((void*) (x))) #define yyDSTmode (info->dateDSTmode) #define yyDayOrdinal (info->dateDayOrdinal) #define yyDayNumber (info->dateDayNumber) #define yyMonthOrdinal (info->dateMonthOrdinal) @@ -148,18 +156,10 @@ typedef enum _DSTMODE { DSTon, DSToff, DSTmaybe } DSTMODE; -/* - * Meridian: am, pm, or 24-hour style. - */ - -typedef enum _MERIDIAN { - MERam, MERpm, MER24 -} MERIDIAN; - %} %union { time_t Number; enum _MERIDIAN Meridian; @@ -264,47 +264,36 @@ yyHour = $1; yyMinutes = $3; yySeconds = 0; yyMeridian = $4; } - | tUNUMBER ':' tUNUMBER '-' tUNUMBER { - yyHour = $1; - yyMinutes = $3; - yyMeridian = MER24; - yyDSTmode = DSToff; - yyTimezone = ($5 % 100 + ($5 / 100) * 60); - ++yyHaveZone; - } | tUNUMBER ':' tUNUMBER ':' tUNUMBER o_merid { yyHour = $1; yyMinutes = $3; yySeconds = $5; yyMeridian = $6; } - | tUNUMBER ':' tUNUMBER ':' tUNUMBER '-' tUNUMBER { - yyHour = $1; - yyMinutes = $3; - yySeconds = $5; - yyMeridian = MER24; - yyDSTmode = DSToff; - yyTimezone = ($7 % 100 + ($7 / 100) * 60); - ++yyHaveZone; - } ; zone : tZONE tDST { yyTimezone = $1; + if (yyTimezone > HOUR( 12)) yyTimezone -= HOUR(100); yyDSTmode = DSTon; } | tZONE { yyTimezone = $1; + if (yyTimezone > HOUR( 12)) yyTimezone -= HOUR(100); yyDSTmode = DSToff; } | tDAYZONE { yyTimezone = $1; yyDSTmode = DSTon; } + | sign tUNUMBER { + yyTimezone = -$1*($2 % 100 + ($2 / 100) * 60); + yyDSTmode = DSToff; + } ; day : tDAY { yyDayOrdinal = 1; yyDayNumber = $1; @@ -384,21 +373,31 @@ yyMonthOrdinal = $2; yyMonth = $3; } ; -iso : tISOBASE tZONE tISOBASE { - if ($2 != HOUR( 7)) YYABORT; +iso : tUNUMBER '-' tUNUMBER '-' tUNUMBER tZONE + tUNUMBER ':' tUNUMBER ':' tUNUMBER { + if ($6 != HOUR( 7) + HOUR(100)) YYABORT; + yyYear = $1; + yyMonth = $3; + yyDay = $5; + yyHour = $7; + yyMinutes = $9; + yySeconds = $11; + } + | tISOBASE tZONE tISOBASE { + if ($2 != HOUR( 7) + HOUR(100)) YYABORT; yyYear = $1 / 10000; yyMonth = ($1 % 10000)/100; yyDay = $1 % 100; yyHour = $3 / 10000; yyMinutes = ($3 % 10000)/100; yySeconds = $3 % 100; } | tISOBASE tZONE tUNUMBER ':' tUNUMBER ':' tUNUMBER { - if ($2 != HOUR( 7)) YYABORT; + if ($2 != HOUR( 7) + HOUR(100)) YYABORT; yyYear = $1 / 10000; yyMonth = ($1 % 10000)/100; yyDay = $1 % 100; yyHour = $3; yyMinutes = $5; @@ -673,35 +672,35 @@ /* * Military timezone table. */ static const TABLE MilitaryTable[] = { - { "a", tZONE, -HOUR( 1) }, - { "b", tZONE, -HOUR( 2) }, - { "c", tZONE, -HOUR( 3) }, - { "d", tZONE, -HOUR( 4) }, - { "e", tZONE, -HOUR( 5) }, - { "f", tZONE, -HOUR( 6) }, - { "g", tZONE, -HOUR( 7) }, - { "h", tZONE, -HOUR( 8) }, - { "i", tZONE, -HOUR( 9) }, - { "k", tZONE, -HOUR(10) }, - { "l", tZONE, -HOUR(11) }, - { "m", tZONE, -HOUR(12) }, - { "n", tZONE, HOUR( 1) }, - { "o", tZONE, HOUR( 2) }, - { "p", tZONE, HOUR( 3) }, - { "q", tZONE, HOUR( 4) }, - { "r", tZONE, HOUR( 5) }, - { "s", tZONE, HOUR( 6) }, - { "t", tZONE, HOUR( 7) }, - { "u", tZONE, HOUR( 8) }, - { "v", tZONE, HOUR( 9) }, - { "w", tZONE, HOUR( 10) }, - { "x", tZONE, HOUR( 11) }, - { "y", tZONE, HOUR( 12) }, - { "z", tZONE, HOUR( 0) }, + { "a", tZONE, -HOUR( 1) + HOUR(100) }, + { "b", tZONE, -HOUR( 2) + HOUR(100) }, + { "c", tZONE, -HOUR( 3) + HOUR(100) }, + { "d", tZONE, -HOUR( 4) + HOUR(100) }, + { "e", tZONE, -HOUR( 5) + HOUR(100) }, + { "f", tZONE, -HOUR( 6) + HOUR(100) }, + { "g", tZONE, -HOUR( 7) + HOUR(100) }, + { "h", tZONE, -HOUR( 8) + HOUR(100) }, + { "i", tZONE, -HOUR( 9) + HOUR(100) }, + { "k", tZONE, -HOUR(10) + HOUR(100) }, + { "l", tZONE, -HOUR(11) + HOUR(100) }, + { "m", tZONE, -HOUR(12) + HOUR(100) }, + { "n", tZONE, HOUR( 1) + HOUR(100) }, + { "o", tZONE, HOUR( 2) + HOUR(100) }, + { "p", tZONE, HOUR( 3) + HOUR(100) }, + { "q", tZONE, HOUR( 4) + HOUR(100) }, + { "r", tZONE, HOUR( 5) + HOUR(100) }, + { "s", tZONE, HOUR( 6) + HOUR(100) }, + { "t", tZONE, HOUR( 7) + HOUR(100) }, + { "u", tZONE, HOUR( 8) + HOUR(100) }, + { "v", tZONE, HOUR( 9) + HOUR(100) }, + { "w", tZONE, HOUR( 10) + HOUR(100) }, + { "x", tZONE, HOUR( 11) + HOUR(100) }, + { "y", tZONE, HOUR( 12) + HOUR(100) }, + { "z", tZONE, HOUR( 0) + HOUR(100) }, { NULL, 0, 0 } }; /* * Dump error messages in the bit bucket. @@ -715,16 +714,16 @@ { Tcl_Obj* t; Tcl_AppendToObj(infoPtr->messages, infoPtr->separatrix, -1); Tcl_AppendToObj(infoPtr->messages, s, -1); Tcl_AppendToObj(infoPtr->messages, " (characters ", -1); - t = Tcl_NewIntObj(location->first_column); + TclNewIntObj(t, location->first_column); Tcl_IncrRefCount(t); Tcl_AppendObjToObj(infoPtr->messages, t); Tcl_DecrRefCount(t); Tcl_AppendToObj(infoPtr->messages, "-", -1); - t = Tcl_NewIntObj(location->last_column); + TclNewIntObj(t, location->last_column); Tcl_IncrRefCount(t); Tcl_AppendObjToObj(infoPtr->messages, t); Tcl_DecrRefCount(t); Tcl_AppendToObj(infoPtr->messages, ")", -1); infoPtr->separatrix = "\n"; @@ -763,13 +762,13 @@ static int LookupWord( YYSTYPE* yylvalPtr, char *buff) { - register char *p; - register char *q; - register const TABLE *tp; + char *p; + char *q; + const TABLE *tp; int i, abbrev; /* * Make it lowercase. */ @@ -888,18 +887,18 @@ TclDatelex( YYSTYPE* yylvalPtr, YYLTYPE* location, DateInfo *info) { - register char c; - register char *p; + char c; + char *p; char buff[20]; int Count; location->first_column = yyInput - info->dateStart; for ( ; ; ) { - while (TclIsSpaceProc(UCHAR(*yyInput))) { + while (TclIsSpaceProcM(*yyInput)) { yyInput++; } if (isdigit(UCHAR(c = *yyInput))) { /* INTL: digit */ /* @@ -958,20 +957,21 @@ } } int TclClockOldscanObjCmd( - void *clientData, /* Unused */ + void *dummy, /* Unused */ Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Count of paraneters */ Tcl_Obj *const *objv) /* Parameters */ { Tcl_Obj *result, *resultElement; int yr, mo, da; DateInfo dateInfo; DateInfo* info = &dateInfo; int status; + (void)dummy; if (objc != 5) { Tcl_WrongNumArgs(interp, 1, objv, "stringToParse baseYear baseMonth baseDay" ); return TCL_ERROR; @@ -1001,11 +1001,11 @@ yyDayOrdinal = 0; yyDayNumber = 0; yyHaveRel = 0; yyRelMonth = 0; yyRelDay = 0; yyRelSeconds = 0; yyRelPointer = NULL; - dateInfo.messages = Tcl_NewObj(); + TclNewObj(dateInfo.messages); dateInfo.separatrix = ""; Tcl_IncrRefCount(dateInfo.messages); status = yyparse(&dateInfo); if (status == 1) { @@ -1058,64 +1058,64 @@ Tcl_NewStringObj("more than one ordinal month in string", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } - result = Tcl_NewObj(); - resultElement = Tcl_NewObj(); + TclNewObj(result); + TclNewObj(resultElement); if (yyHaveDate) { Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyYear)); + Tcl_NewIntObj((int) yyYear)); Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyMonth)); + Tcl_NewIntObj((int) yyMonth)); Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyDay)); + Tcl_NewIntObj((int) yyDay)); } Tcl_ListObjAppendElement(interp, result, resultElement); if (yyHaveTime) { - Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj( - ToSeconds(yyHour, yyMinutes, yySeconds, yyMeridian))); + Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj((int) + ToSeconds(yyHour, yyMinutes, yySeconds, (MERIDIAN)yyMeridian))); } else { Tcl_ListObjAppendElement(interp, result, Tcl_NewObj()); } - resultElement = Tcl_NewObj(); + TclNewObj(resultElement); if (yyHaveZone) { Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(-yyTimezone)); + Tcl_NewIntObj((int) -yyTimezone)); Tcl_ListObjAppendElement(interp, resultElement, Tcl_NewIntObj(1 - yyDSTmode)); } Tcl_ListObjAppendElement(interp, result, resultElement); - resultElement = Tcl_NewObj(); - if (yyHaveRel) { - Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyRelMonth)); - Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyRelDay)); - Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyRelSeconds)); - } - Tcl_ListObjAppendElement(interp, result, resultElement); - - resultElement = Tcl_NewObj(); - if (yyHaveDay && !yyHaveDate) { - Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyDayOrdinal)); - Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyDayNumber)); - } - Tcl_ListObjAppendElement(interp, result, resultElement); - - resultElement = Tcl_NewObj(); - if (yyHaveOrdinalMonth) { - Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyMonthOrdinal)); - Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyMonth)); + TclNewObj(resultElement); + if (yyHaveRel) { + Tcl_ListObjAppendElement(interp, resultElement, + Tcl_NewIntObj((int) yyRelMonth)); + Tcl_ListObjAppendElement(interp, resultElement, + Tcl_NewIntObj((int) yyRelDay)); + Tcl_ListObjAppendElement(interp, resultElement, + Tcl_NewIntObj((int) yyRelSeconds)); + } + Tcl_ListObjAppendElement(interp, result, resultElement); + + TcNewObj(resultElement); + if (yyHaveDay && !yyHaveDate) { + Tcl_ListObjAppendElement(interp, resultElement, + Tcl_NewIntObj((int) yyDayOrdinal)); + Tcl_ListObjAppendElement(interp, resultElement, + Tcl_NewIntObj((int) yyDayNumber)); + } + Tcl_ListObjAppendElement(interp, result, resultElement); + + TclNewObj(resultElement); + if (yyHaveOrdinalMonth) { + Tcl_ListObjAppendElement(interp, resultElement, + Tcl_NewIntObj((int) yyMonthOrdinal)); + Tcl_ListObjAppendElement(interp, resultElement, + Tcl_NewIntObj((int) yyMonth)); } Tcl_ListObjAppendElement(interp, result, resultElement); Tcl_SetObjResult(interp, result); return TCL_OK; Index: generic/tclHash.c ================================================================== --- generic/tclHash.c +++ generic/tclHash.c @@ -11,10 +11,17 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" +/* + * Prevent macros from clashing with function definitions. + */ + +#undef Tcl_FindHashEntry +#undef Tcl_CreateHashEntry + /* * When there are this many entries per bucket, on average, rebuild the hash * table to make it larger. */ @@ -26,28 +33,41 @@ * preliminary values that are arbitrarily similar will end up in different * buckets. The hash function was taken from a random-number generator. */ #define RANDOM_INDEX(tablePtr, i) \ - ((((i)*(size_t)1103515245) >> (tablePtr)->downShift) & (tablePtr)->mask) + ((((i)*1103515245L) >> (tablePtr)->downShift) & (tablePtr)->mask) /* * Prototypes for the array hash key methods. */ static Tcl_HashEntry * AllocArrayEntry(Tcl_HashTable *tablePtr, void *keyPtr); static int CompareArrayKeys(void *keyPtr, Tcl_HashEntry *hPtr); -static TCL_HASH_TYPE HashArrayKey(Tcl_HashTable *tablePtr, void *keyPtr); +static unsigned int HashArrayKey(Tcl_HashTable *tablePtr, void *keyPtr); + +/* + * Prototypes for the one word hash key methods. Not actually declared because + * this is a critical path that is implemented in the core hash table access + * function. + */ + +#if 0 +static Tcl_HashEntry * AllocOneWordEntry(Tcl_HashTable *tablePtr, + void *keyPtr); +static int CompareOneWordKeys(void *keyPtr, Tcl_HashEntry *hPtr); +static unsigned int HashOneWordKey(Tcl_HashTable *tablePtr, void *keyPtr); +#endif /* * Prototypes for the string hash key methods. */ static Tcl_HashEntry * AllocStringEntry(Tcl_HashTable *tablePtr, void *keyPtr); static int CompareStringKeys(void *keyPtr, Tcl_HashEntry *hPtr); -static TCL_HASH_TYPE HashStringKey(Tcl_HashTable *tablePtr, void *keyPtr); +static unsigned int HashStringKey(Tcl_HashTable *tablePtr, void *keyPtr); /* * Function prototypes for static functions in this file: */ @@ -191,11 +211,11 @@ } /* *---------------------------------------------------------------------- * - * FindHashEntry -- + * Tcl_FindHashEntry -- * * Given a hash table find the entry with a matching key. * * Results: * The return value is a token for the matching entry in the hash table, @@ -204,10 +224,18 @@ * Side effects: * None. * *---------------------------------------------------------------------- */ + +Tcl_HashEntry * +Tcl_FindHashEntry( + Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */ + const void *key) /* Key to use to find matching entry. */ +{ + return (*((tablePtr)->findProc))(tablePtr, key); +} static Tcl_HashEntry * FindHashEntry( Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */ const char *key) /* Key to use to find matching entry. */ @@ -217,11 +245,11 @@ /* *---------------------------------------------------------------------- * - * CreateHashEntry -- + * Tcl_CreateHashEntry -- * * Given a hash table with string keys, and a string key, find the entry * with a matching key. If there is no matching entry, then create a new * entry that does match. * @@ -234,10 +262,21 @@ * Side effects: * A new entry may be added to the hash table. * *---------------------------------------------------------------------- */ + +Tcl_HashEntry * +Tcl_CreateHashEntry( + Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */ + const void *key, /* Key to use to find or create matching + * entry. */ + int *newPtr) /* Store info here telling whether a new entry + * was created. */ +{ + return (*((tablePtr)->createProc))(tablePtr, key, newPtr); +} static Tcl_HashEntry * CreateHashEntry( Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */ const char *key, /* Key to use to find or create matching @@ -245,11 +284,12 @@ int *newPtr) /* Store info here telling whether a new entry * was created. */ { register Tcl_HashEntry *hPtr; const Tcl_HashKeyType *typePtr; - size_t hash, index; + unsigned int hash; + int index; if (tablePtr->keyType == TCL_STRING_KEYS) { typePtr = &tclStringHashKeyType; } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) { typePtr = &tclOneWordHashKeyType; @@ -266,11 +306,11 @@ index = RANDOM_INDEX(tablePtr, hash); } else { index = hash & tablePtr->mask; } } else { - hash = (size_t) key; + hash = PTR2UINT(key); index = RANDOM_INDEX(tablePtr, hash); } /* * Search all of the entries in the appropriate bucket. @@ -279,13 +319,15 @@ if (typePtr->compareKeysProc) { Tcl_CompareHashKeysProc *compareKeysProc = typePtr->compareKeysProc; for (hPtr = tablePtr->buckets[index]; hPtr != NULL; hPtr = hPtr->nextPtr) { - if (hash != hPtr->hash) { +#if TCL_HASH_KEY_STORE_HASH + if (hash != PTR2UINT(hPtr->hash)) { continue; } +#endif /* if keys pointers or values are equal */ if ((key == hPtr->key.oneWordValue) || compareKeysProc((void *) key, hPtr) ) { if (newPtr) { @@ -295,13 +337,15 @@ } } } else { for (hPtr = tablePtr->buckets[index]; hPtr != NULL; hPtr = hPtr->nextPtr) { - if (hash != hPtr->hash) { +#if TCL_HASH_KEY_STORE_HASH + if (hash != PTR2UINT(hPtr->hash)) { continue; } +#endif if (key == hPtr->key.oneWordValue) { if (newPtr) { *newPtr = 0; } return hPtr; @@ -319,19 +363,25 @@ *newPtr = 1; if (typePtr->allocEntryProc) { hPtr = typePtr->allocEntryProc(tablePtr, (void *) key); } else { - hPtr = Tcl_Alloc(sizeof(Tcl_HashEntry)); + hPtr = ckalloc(sizeof(Tcl_HashEntry)); hPtr->key.oneWordValue = (char *) key; - Tcl_SetHashValue(hPtr, NULL); + hPtr->clientData = 0; } hPtr->tablePtr = tablePtr; - hPtr->hash = hash; +#if TCL_HASH_KEY_STORE_HASH + hPtr->hash = UINT2PTR(hash); hPtr->nextPtr = tablePtr->buckets[index]; tablePtr->buckets[index] = hPtr; +#else + hPtr->bucketPtr = &tablePtr->buckets[index]; + hPtr->nextPtr = *hPtr->bucketPtr; + *hPtr->bucketPtr = hPtr; +#endif tablePtr->numEntries++; /* * If the table has exceeded a decent size, rebuild it with many more * buckets. @@ -367,11 +417,13 @@ { register Tcl_HashEntry *prevPtr; const Tcl_HashKeyType *typePtr; Tcl_HashTable *tablePtr; Tcl_HashEntry **bucketPtr; - size_t index; +#if TCL_HASH_KEY_STORE_HASH + int index; +#endif tablePtr = entryPtr->tablePtr; if (tablePtr->keyType == TCL_STRING_KEYS) { typePtr = &tclStringHashKeyType; @@ -382,18 +434,22 @@ typePtr = tablePtr->typePtr; } else { typePtr = &tclArrayHashKeyType; } +#if TCL_HASH_KEY_STORE_HASH if (typePtr->hashKeyProc == NULL || typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { - index = RANDOM_INDEX(tablePtr, entryPtr->hash); + index = RANDOM_INDEX(tablePtr, PTR2INT(entryPtr->hash)); } else { - index = entryPtr->hash & tablePtr->mask; + index = PTR2UINT(entryPtr->hash) & tablePtr->mask; } bucketPtr = &tablePtr->buckets[index]; +#else + bucketPtr = entryPtr->bucketPtr; +#endif if (*bucketPtr == entryPtr) { *bucketPtr = entryPtr->nextPtr; } else { for (prevPtr = *bucketPtr; ; prevPtr = prevPtr->nextPtr) { @@ -409,11 +465,11 @@ tablePtr->numEntries--; if (typePtr->freeEntryProc) { typePtr->freeEntryProc(entryPtr); } else { - Tcl_Free(entryPtr); + ckfree(entryPtr); } } /* *---------------------------------------------------------------------- @@ -436,11 +492,11 @@ Tcl_DeleteHashTable( register Tcl_HashTable *tablePtr) /* Table to delete. */ { register Tcl_HashEntry *hPtr, *nextPtr; const Tcl_HashKeyType *typePtr; - size_t i; + int i; if (tablePtr->keyType == TCL_STRING_KEYS) { typePtr = &tclStringHashKeyType; } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) { typePtr = &tclOneWordHashKeyType; @@ -460,11 +516,11 @@ while (hPtr != NULL) { nextPtr = hPtr->nextPtr; if (typePtr->freeEntryProc) { typePtr->freeEntryProc(hPtr); } else { - Tcl_Free(hPtr); + ckfree(hPtr); } hPtr = nextPtr; } } @@ -474,11 +530,11 @@ if (tablePtr->buckets != tablePtr->staticBuckets) { if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) { TclpSysFree((char *) tablePtr->buckets); } else { - Tcl_Free(tablePtr->buckets); + ckfree(tablePtr->buckets); } } /* * Arrange for panics if the table is used again without @@ -585,11 +641,11 @@ char * Tcl_HashStats( Tcl_HashTable *tablePtr) /* Table for which to produce stats. */ { #define NUM_COUNTERS 10 - size_t count[NUM_COUNTERS], overflow, i, j; + int count[NUM_COUNTERS], overflow, i, j; double average, tmp; register Tcl_HashEntry *hPtr; char *result, *p; /* @@ -619,20 +675,20 @@ /* * Print out the histogram and a few other pieces of information. */ - result = Tcl_Alloc((NUM_COUNTERS * 60) + 300); - sprintf(result, "%" TCL_Z_MODIFIER "u entries in table, %" TCL_Z_MODIFIER "u buckets\n", + result = ckalloc((NUM_COUNTERS * 60) + 300); + sprintf(result, "%d entries in table, %d buckets\n", tablePtr->numEntries, tablePtr->numBuckets); p = result + strlen(result); for (i = 0; i < NUM_COUNTERS; i++) { - sprintf(p, "number of buckets with %" TCL_Z_MODIFIER "u entries: %" TCL_Z_MODIFIER "u\n", + sprintf(p, "number of buckets with %d entries: %d\n", i, count[i]); p += strlen(p); } - sprintf(p, "number of buckets with %d or more entries: %" TCL_Z_MODIFIER "u\n", + sprintf(p, "number of buckets with %d or more entries: %d\n", NUM_COUNTERS, overflow); p += strlen(p); sprintf(p, "average search distance for entry: %.1f", average); return result; } @@ -654,31 +710,31 @@ */ static Tcl_HashEntry * AllocArrayEntry( Tcl_HashTable *tablePtr, /* Hash table. */ - void *keyPtr) /* Key to store in the hash table entry. */ + void *keyPtr) /* Key to store in the hash table entry. */ { int *array = (int *) keyPtr; register int *iPtr1, *iPtr2; Tcl_HashEntry *hPtr; int count; - size_t size; + unsigned int size; count = tablePtr->keyType; size = sizeof(Tcl_HashEntry) + (count*sizeof(int)) - sizeof(hPtr->key); if (size < sizeof(Tcl_HashEntry)) { size = sizeof(Tcl_HashEntry); } - hPtr = Tcl_Alloc(size); + hPtr = ckalloc(size); for (iPtr1 = array, iPtr2 = hPtr->key.words; count > 0; count--, iPtr1++, iPtr2++) { *iPtr2 = *iPtr1; } - Tcl_SetHashValue(hPtr, NULL); + hPtr->clientData = 0; return hPtr; } /* @@ -698,15 +754,15 @@ *---------------------------------------------------------------------- */ static int CompareArrayKeys( - void *keyPtr, /* New key to compare. */ + void *keyPtr, /* New key to compare. */ Tcl_HashEntry *hPtr) /* Existing key to compare. */ { - const int *iPtr1 = keyPtr; - const int *iPtr2 = hPtr->key.words; + register const int *iPtr1 = (const int *) keyPtr; + register const int *iPtr2 = (const int *) hPtr->key.words; Tcl_HashTable *tablePtr = hPtr->tablePtr; int count; for (count = tablePtr->keyType; ; count--, iPtr1++, iPtr2++) { if (count == 0) { @@ -735,17 +791,17 @@ * None. * *---------------------------------------------------------------------- */ -static TCL_HASH_TYPE +static unsigned int HashArrayKey( Tcl_HashTable *tablePtr, /* Hash table. */ - void *keyPtr) /* Key from which to compute hash value. */ + void *keyPtr) /* Key from which to compute hash value. */ { register const int *array = (const int *) keyPtr; - register TCL_HASH_TYPE result; + register unsigned int result; int count; for (result = 0, count = tablePtr->keyType; count > 0; count--, array++) { result += *array; @@ -770,23 +826,24 @@ */ static Tcl_HashEntry * AllocStringEntry( Tcl_HashTable *tablePtr, /* Hash table. */ - void *keyPtr) /* Key to store in the hash table entry. */ + void *keyPtr) /* Key to store in the hash table entry. */ { const char *string = (const char *) keyPtr; Tcl_HashEntry *hPtr; - size_t size, allocsize; + unsigned int size, allocsize; allocsize = size = strlen(string) + 1; if (size < sizeof(hPtr->key)) { allocsize = sizeof(hPtr->key); } - hPtr = Tcl_Alloc(offsetof(Tcl_HashEntry, key) + allocsize); + hPtr = ckalloc(TclOffset(Tcl_HashEntry, key) + allocsize); + memset(hPtr, 0, sizeof(Tcl_HashEntry) + allocsize - sizeof(hPtr->key)); memcpy(hPtr->key.string, string, size); - Tcl_SetHashValue(hPtr, NULL); + hPtr->clientData = 0; return hPtr; } /* *---------------------------------------------------------------------- @@ -805,14 +862,17 @@ *---------------------------------------------------------------------- */ static int CompareStringKeys( - void *keyPtr, /* New key to compare. */ + void *keyPtr, /* New key to compare. */ Tcl_HashEntry *hPtr) /* Existing key to compare. */ { - return !strcmp(keyPtr, hPtr->key.string); + register const char *p1 = (const char *) keyPtr; + register const char *p2 = (const char *) hPtr->key.string; + + return !strcmp(p1, p2); } /* *---------------------------------------------------------------------- * @@ -828,17 +888,17 @@ * None. * *---------------------------------------------------------------------- */ -static TCL_HASH_TYPE +static unsigned HashStringKey( Tcl_HashTable *tablePtr, /* Hash table. */ - void *keyPtr) /* Key from which to compute hash value. */ + void *keyPtr) /* Key from which to compute hash value. */ { register const char *string = keyPtr; - register TCL_HASH_TYPE result; + register unsigned int result; register char c; /* * I tried a zillion different hash functions and asked many other people * for advice. Many people had their own favorite functions, all @@ -882,11 +942,11 @@ /* *---------------------------------------------------------------------- * * BogusFind -- * - * This function is invoked when Tcl_FindHashEntry is called on a + * This function is invoked when an Tcl_FindHashEntry is called on a * table that has been deleted. * * Results: * If Tcl_Panic returns (which it shouldn't) this function returns NULL. * @@ -909,11 +969,11 @@ /* *---------------------------------------------------------------------- * * BogusCreate -- * - * This function is invoked when Tcl_CreateHashEntry is called on a + * This function is invoked when an Tcl_CreateHashEntry is called on a * table that has been deleted. * * Results: * If panic returns (which it shouldn't) this function returns NULL. * @@ -956,18 +1016,18 @@ static void RebuildTable( register Tcl_HashTable *tablePtr) /* Table to enlarge. */ { - size_t count, index, oldSize = tablePtr->numBuckets; + int count, index, oldSize = tablePtr->numBuckets; Tcl_HashEntry **oldBuckets = tablePtr->buckets; register Tcl_HashEntry **oldChainPtr, **newChainPtr; register Tcl_HashEntry *hPtr; const Tcl_HashKeyType *typePtr; /* Avoid outgrowing capability of the memory allocators */ - if (oldSize > UINT_MAX / (4 * sizeof(Tcl_HashEntry *))) { + if (oldSize > (int)(UINT_MAX / (4 * sizeof(Tcl_HashEntry *)))) { tablePtr->rebuildSize = INT_MAX; return; } if (tablePtr->keyType == TCL_STRING_KEYS) { @@ -986,41 +1046,60 @@ * constants for new array size. */ tablePtr->numBuckets *= 4; if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) { - tablePtr->buckets = TclpSysAlloc( - tablePtr->numBuckets * sizeof(Tcl_HashEntry *)); + tablePtr->buckets = (Tcl_HashEntry **) TclpSysAlloc((unsigned) + (tablePtr->numBuckets * sizeof(Tcl_HashEntry *)), 0); } else { tablePtr->buckets = - Tcl_Alloc(tablePtr->numBuckets * sizeof(Tcl_HashEntry *)); + ckalloc(tablePtr->numBuckets * sizeof(Tcl_HashEntry *)); } for (count = tablePtr->numBuckets, newChainPtr = tablePtr->buckets; count > 0; count--, newChainPtr++) { *newChainPtr = NULL; } tablePtr->rebuildSize *= 4; - if (tablePtr->downShift > 1) { - tablePtr->downShift -= 2; - } + tablePtr->downShift -= 2; tablePtr->mask = (tablePtr->mask << 2) + 3; /* * Rehash all of the existing entries into the new bucket array. */ for (oldChainPtr = oldBuckets; oldSize > 0; oldSize--, oldChainPtr++) { for (hPtr = *oldChainPtr; hPtr != NULL; hPtr = *oldChainPtr) { *oldChainPtr = hPtr->nextPtr; +#if TCL_HASH_KEY_STORE_HASH if (typePtr->hashKeyProc == NULL || typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { - index = RANDOM_INDEX(tablePtr, hPtr->hash); + index = RANDOM_INDEX(tablePtr, PTR2INT(hPtr->hash)); } else { - index = hPtr->hash & tablePtr->mask; + index = PTR2UINT(hPtr->hash) & tablePtr->mask; } hPtr->nextPtr = tablePtr->buckets[index]; tablePtr->buckets[index] = hPtr; +#else + void *key = Tcl_GetHashKey(tablePtr, hPtr); + + if (typePtr->hashKeyProc) { + unsigned int hash; + + hash = typePtr->hashKeyProc(tablePtr, key); + if (typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { + index = RANDOM_INDEX(tablePtr, hash); + } else { + index = hash & tablePtr->mask; + } + } else { + index = RANDOM_INDEX(tablePtr, key); + } + + hPtr->bucketPtr = &tablePtr->buckets[index]; + hPtr->nextPtr = *hPtr->bucketPtr; + *hPtr->bucketPtr = hPtr; +#endif } } /* * Free up the old bucket array, if it was dynamically allocated. @@ -1028,11 +1107,11 @@ if (oldBuckets != tablePtr->staticBuckets) { if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) { TclpSysFree((char *) oldBuckets); } else { - Tcl_Free(oldBuckets); + ckfree(oldBuckets); } } } /* Index: generic/tclHistory.c ================================================================== --- generic/tclHistory.c +++ generic/tclHistory.c @@ -60,21 +60,29 @@ * record: don't execute command. * TCL_EVAL_GLOBAL means use Tcl_GlobalEval * instead of Tcl_Eval. */ { register Tcl_Obj *cmdPtr; + int length = strlen(cmd); int result; - if (cmd[0]) { + if (length > 0) { /* * Call Tcl_RecordAndEvalObj to do the actual work. */ - cmdPtr = Tcl_NewStringObj(cmd, -1); + cmdPtr = Tcl_NewStringObj(cmd, length); Tcl_IncrRefCount(cmdPtr); result = Tcl_RecordAndEvalObj(interp, cmdPtr, flags); + /* + * Move the interpreter's object result to the string result, then + * reset the object result. + */ + + (void) Tcl_GetStringResult(interp); + /* * Discard the Tcl object created to hold the command. */ Tcl_DecrRefCount(cmdPtr); @@ -128,11 +136,11 @@ /* * Create the references to the [::history add] command if necessary. */ if (histObjsPtr == NULL) { - histObjsPtr = Tcl_Alloc(sizeof(HistoryObjs)); + histObjsPtr = ckalloc(sizeof(HistoryObjs)); TclNewLiteralStringObj(histObjsPtr->historyObj, "::history"); TclNewLiteralStringObj(histObjsPtr->addObj, "add"); Tcl_IncrRefCount(histObjsPtr->historyObj); Tcl_IncrRefCount(histObjsPtr->addObj); Tcl_SetAssocData(interp, HISTORY_OBJS_KEY, DeleteHistoryObjs, @@ -208,15 +216,15 @@ { register HistoryObjs *histObjsPtr = clientData; TclDecrRefCount(histObjsPtr->historyObj); TclDecrRefCount(histObjsPtr->addObj); - Tcl_Free(histObjsPtr); + ckfree(histObjsPtr); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: generic/tclIO.c ================================================================== --- generic/tclIO.c +++ generic/tclIO.c @@ -114,11 +114,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 { +typedef struct ThreadSpecificData { NextChannelHandler *nestedHandlerPtr; /* This variable holds the list of nested * Tcl_NotifyChannel invocations. */ ChannelState *firstCSPtr; /* List of all channels currently open, * indexed by ChannelState, as only one @@ -189,25 +189,23 @@ Channel *chanPtr, int mask); static int DetachChannel(Tcl_Interp *interp, Tcl_Channel chan); static void DiscardInputQueued(ChannelState *statePtr, int discardSavedBuffers); static void DiscardOutputQueued(ChannelState *chanPtr); -static int DoRead(Channel *chanPtr, char *dst, size_t bytesToRead, +static int DoRead(Channel *chanPtr, char *dst, int bytesToRead, int allowShortReads); -static int DoReadChars(Channel *chan, Tcl_Obj *objPtr, size_t toRead, +static int DoReadChars(Channel *chan, Tcl_Obj *objPtr, int toRead, int appendFlag); static int FilterInputBytes(Channel *chanPtr, GetsState *statePtr); static int FlushChannel(Tcl_Interp *interp, Channel *chanPtr, int calledFromAsyncFlush); static int TclGetsObjBinary(Tcl_Channel chan, Tcl_Obj *objPtr); -static Tcl_Encoding GetBinaryEncoding(); +static Tcl_Encoding GetBinaryEncoding(void); static void FreeBinaryEncoding(ClientData clientData); static Tcl_HashTable * GetChannelTable(Tcl_Interp *interp); static int GetInput(Channel *chanPtr); -static int HaveVersion(const Tcl_ChannelType *typePtr, - Tcl_ChannelTypeVersion minimumVersion); static void PeekAhead(Channel *chanPtr, char **dstEndPtr, GetsState *gsPtr); static int ReadBytes(ChannelState *statePtr, Tcl_Obj *objPtr, int charsLeft); static int ReadChars(ChannelState *statePtr, Tcl_Obj *objPtr, @@ -237,11 +235,11 @@ * Simplifying helper macros. All may use their argument(s) multiple times. * The ANSI C "prototypes" for the macros are listed below, together with a * short description of what the macro does. * * -------------------------------------------------------------------------- - * size_t BytesLeft(ChannelBuffer *bufPtr) + * int BytesLeft(ChannelBuffer *bufPtr) * * Returns the number of bytes of data remaining in the buffer. * * int SpaceLeft(ChannelBuffer *bufPtr) * @@ -275,25 +273,25 @@ * Returns a pointer to where characters should be removed from the * buffer. * -------------------------------------------------------------------------- */ -#define BytesLeft(bufPtr) ((size_t)((bufPtr)->nextAdded - (bufPtr)->nextRemoved)) +#define BytesLeft(bufPtr) ((bufPtr)->nextAdded - (bufPtr)->nextRemoved) -#define SpaceLeft(bufPtr) ((size_t)((bufPtr)->bufLength - (bufPtr)->nextAdded)) +#define SpaceLeft(bufPtr) ((bufPtr)->bufLength - (bufPtr)->nextAdded) #define IsBufferReady(bufPtr) ((bufPtr)->nextAdded > (bufPtr)->nextRemoved) #define IsBufferEmpty(bufPtr) ((bufPtr)->nextAdded == (bufPtr)->nextRemoved) #define IsBufferFull(bufPtr) ((bufPtr) && (bufPtr)->nextAdded >= (bufPtr)->bufLength) #define IsBufferOverflowing(bufPtr) ((bufPtr)->nextAdded>(bufPtr)->bufLength) -#define InsertPoint(bufPtr) ((bufPtr)->buf + (bufPtr)->nextAdded) +#define InsertPoint(bufPtr) (&(bufPtr)->buf[(bufPtr)->nextAdded]) -#define RemovePoint(bufPtr) ((bufPtr)->buf + (bufPtr)->nextRemoved) +#define RemovePoint(bufPtr) (&(bufPtr)->buf[(bufPtr)->nextRemoved]) /* * For working with channel state flag bits. */ @@ -319,13 +317,13 @@ */ typedef struct ResolvedChanName { ChannelState *statePtr; /* The saved lookup result */ Tcl_Interp *interp; /* The interp in which the lookup was done. */ - size_t epoch; /* The epoch of the channel when the lookup + int epoch; /* The epoch of the channel when the lookup * was done. Use to verify validity. */ - size_t refCount; /* Share this struct among many Tcl_Obj. */ + int refCount; /* Share this struct among many Tcl_Obj. */ } ResolvedChanName; static void DupChannelIntRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static void FreeChannelIntRep(Tcl_Obj *objPtr); @@ -335,26 +333,10 @@ DupChannelIntRep, /* dupIntRepProc */ NULL, /* updateStringProc */ NULL /* setFromAnyProc */ }; -#define ChanSetIntRep(objPtr, resPtr) \ - do { \ - Tcl_ObjIntRep ir; \ - (resPtr)->refCount++; \ - ir.twoPtrValue.ptr1 = (resPtr); \ - ir.twoPtrValue.ptr2 = NULL; \ - Tcl_StoreIntRep((objPtr), &chanObjType, &ir); \ - } while (0) - -#define ChanGetIntRep(objPtr, resPtr) \ - do { \ - const Tcl_ObjIntRep *irPtr; \ - irPtr = TclFetchIntRep((objPtr), &chanObjType); \ - (resPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ - } while (0) - #define BUSY_STATE(st, fl) \ ((((st)->csPtrR) && ((fl) & TCL_READABLE)) || \ (((st)->csPtrW) && ((fl) & TCL_WRITABLE))) #define MAX_CHANNEL_BUFFER_SIZE (1024*1024) @@ -381,19 +363,10 @@ } else { return chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp, 0); } } -static inline int -ChanCloseHalf( - Channel *chanPtr, - Tcl_Interp *interp, - int flags) -{ - return chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp, flags); -} - /* *--------------------------------------------------------------------------- * * ChanRead -- * @@ -438,11 +411,11 @@ if (GotFlag(chanPtr->state, CHANNEL_EOF)) { chanPtr->state->inputEncodingFlags |= TCL_ENCODING_START; } ResetFlag(chanPtr->state, CHANNEL_BLOCKED | CHANNEL_EOF); chanPtr->state->inputEncodingFlags &= ~TCL_ENCODING_END; - if (WillRead(chanPtr) == -1) { + if (WillRead(chanPtr) < 0) { return -1; } bytesRead = chanPtr->typePtr->inputProc(chanPtr->instanceData, dst, dstSize, &result); @@ -454,20 +427,11 @@ if (GotFlag(chanPtr->state, CHANNEL_EOF)) { chanPtr->state->inputEncodingFlags |= TCL_ENCODING_START; } ResetFlag(chanPtr->state, CHANNEL_BLOCKED | CHANNEL_EOF); chanPtr->state->inputEncodingFlags &= ~TCL_ENCODING_END; - if (bytesRead == -1) { - if ((result == EWOULDBLOCK) || (result == EAGAIN)) { - SetFlag(chanPtr->state, CHANNEL_BLOCKED); - result = EAGAIN; - } - Tcl_SetErrno(result); - } else if (bytesRead == 0) { - SetFlag(chanPtr->state, CHANNEL_EOF); - chanPtr->state->inputEncodingFlags |= TCL_ENCODING_END; - } else { + if (bytesRead > 0) { /* * If we get a short read, signal up that we may be BLOCKED. We should * avoid calling the driver because on some platforms we will block in * the low level reading code even though the channel is set into * nonblocking mode. @@ -474,10 +438,19 @@ */ if (bytesRead < dstSize) { SetFlag(chanPtr->state, CHANNEL_BLOCKED); } + } else if (bytesRead == 0) { + SetFlag(chanPtr->state, CHANNEL_EOF); + chanPtr->state->inputEncodingFlags |= TCL_ENCODING_END; + } else if (bytesRead < 0) { + if ((result == EWOULDBLOCK) || (result == EAGAIN)) { + SetFlag(chanPtr->state, CHANNEL_BLOCKED); + result = EAGAIN; + } + Tcl_SetErrno(result); } return bytesRead; } static inline Tcl_WideInt @@ -490,23 +463,22 @@ /* * Note that we prefer the wideSeekProc if that field is available in the * type and non-NULL. */ - if (HaveVersion(chanPtr->typePtr, TCL_CHANNEL_VERSION_3) && - chanPtr->typePtr->wideSeekProc != NULL) { - return chanPtr->typePtr->wideSeekProc(chanPtr->instanceData, + if (Tcl_ChannelWideSeekProc(chanPtr->typePtr) != NULL) { + return Tcl_ChannelWideSeekProc(chanPtr->typePtr)(chanPtr->instanceData, offset, mode, errnoPtr); } - if (offsetLONG_MAX) { + if (offsetTcl_LongAsWide(LONG_MAX)) { *errnoPtr = EOVERFLOW; - return -1; + return Tcl_LongAsWide(-1); } - return chanPtr->typePtr->seekProc(chanPtr->instanceData, - offset, mode, errnoPtr); + return Tcl_LongAsWide(Tcl_ChannelSeekProc(chanPtr->typePtr)(chanPtr->instanceData, + Tcl_WideAsLong(offset), mode, errnoPtr)); } static inline void ChanThreadAction( Channel *chanPtr, @@ -671,11 +643,11 @@ */ statePtr->refCount--; } - if (statePtr->refCount + 1 <= 1) { + if (statePtr->refCount <= 0) { /* * Close it only if the refcount indicates that the channel is * not referenced from any interpreter. If it is, that * interpreter will close the channel when it gets destroyed. */ @@ -858,11 +830,11 @@ * callback. */ { ChannelState *statePtr = ((Channel *) chan)->state; CloseCallback *cbPtr; - cbPtr = Tcl_Alloc(sizeof(CloseCallback)); + cbPtr = (CloseCallback *)ckalloc(sizeof(CloseCallback)); cbPtr->proc = proc; cbPtr->clientData = clientData; cbPtr->nextPtr = statePtr->closeCbPtr; statePtr->closeCbPtr = cbPtr; @@ -904,11 +876,11 @@ if (cbPrevPtr == NULL) { statePtr->closeCbPtr = cbPtr->nextPtr; } else { cbPrevPtr->nextPtr = cbPtr->nextPtr; } - Tcl_Free(cbPtr); + ckfree(cbPtr); break; } cbPrevPtr = cbPtr; } } @@ -937,13 +909,13 @@ Tcl_Interp *interp) { Tcl_HashTable *hTblPtr; /* Hash table of channels. */ Tcl_Channel stdinChan, stdoutChan, stderrChan; - hTblPtr = Tcl_GetAssocData(interp, "tclIO", NULL); + hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, "tclIO", NULL); if (hTblPtr == NULL) { - hTblPtr = Tcl_Alloc(sizeof(Tcl_HashTable)); + hTblPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(hTblPtr, TCL_STRING_KEYS); Tcl_SetAssocData(interp, "tclIO", (Tcl_InterpDeleteProc *) DeleteChannelTable, hTblPtr); /* @@ -1007,14 +979,14 @@ /* * Delete all the registered channels - this will close channels whose * refcount reaches zero. */ - hTblPtr = clientData; + hTblPtr = (Tcl_HashTable *)clientData; for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); hPtr != NULL; hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch)) { - chanPtr = Tcl_GetHashValue(hPtr); + chanPtr = (Channel *)Tcl_GetHashValue(hPtr); statePtr = chanPtr->state; /* * Remove any fileevents registered in this interpreter. */ @@ -1031,11 +1003,11 @@ Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, TclChannelEventScriptInvoker, sPtr); TclDecrRefCount(sPtr->scriptPtr); - Tcl_Free(sPtr); + ckfree(sPtr); } else { prevPtr = sPtr; } } @@ -1054,11 +1026,11 @@ } } } Tcl_DeleteHashTable(hTblPtr); - Tcl_Free(hTblPtr); + ckfree(hTblPtr); } /* *---------------------------------------------------------------------- * @@ -1089,27 +1061,27 @@ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (tsdPtr->stdinInitialized == 1 && tsdPtr->stdinChannel != NULL && statePtr == ((Channel *)tsdPtr->stdinChannel)->state) { - if (statePtr->refCount + 1 < 3) { + if (statePtr->refCount < 2) { statePtr->refCount = 0; tsdPtr->stdinChannel = NULL; return; } } else if (tsdPtr->stdoutInitialized == 1 && tsdPtr->stdoutChannel != NULL && statePtr == ((Channel *)tsdPtr->stdoutChannel)->state) { - if (statePtr->refCount + 1 < 3) { + if (statePtr->refCount < 2) { statePtr->refCount = 0; tsdPtr->stdoutChannel = NULL; return; } } else if (tsdPtr->stderrInitialized == 1 && tsdPtr->stderrChannel != NULL && statePtr == ((Channel *)tsdPtr->stderrChannel)->state) { - if (statePtr->refCount + 1 < 3) { + if (statePtr->refCount < 2) { statePtr->refCount = 0; tsdPtr->stderrChannel = NULL; return; } } @@ -1267,11 +1239,11 @@ /* * If the refCount reached zero, close the actual channel. */ - if (statePtr->refCount + 1 <= 1) { + if (statePtr->refCount <= 0) { Tcl_Preserve(statePtr); if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { /* * We don't want to re-enter Tcl_Close(). */ @@ -1377,11 +1349,11 @@ chanPtr = ((Channel *) chan)->state->bottomChanPtr; statePtr = chanPtr->state; if (interp != NULL) { - hTblPtr = Tcl_GetAssocData(interp, "tclIO", NULL); + hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, "tclIO", NULL); if (hTblPtr == NULL) { return TCL_ERROR; } hPtr = Tcl_FindHashEntry(hTblPtr, statePtr->channelName); if (hPtr == NULL) { @@ -1480,11 +1452,11 @@ * Always return bottom-most channel in the stack. This one lives the * longest - other channels may go away unnoticed. The other APIs * compensate where necessary to retrieve the topmost channel again. */ - chanPtr = Tcl_GetHashValue(hPtr); + chanPtr = (Channel *)Tcl_GetHashValue(hPtr); chanPtr = chanPtr->state->bottomChanPtr; if (modePtr != NULL) { *modePtr = chanPtr->state->flags & (TCL_READABLE|TCL_WRITABLE); } @@ -1524,56 +1496,58 @@ int flags) { ChannelState *statePtr; ResolvedChanName *resPtr = NULL; Tcl_Channel chan; + (void)flags; if (interp == NULL) { return TCL_ERROR; } - ChanGetIntRep(objPtr, resPtr); - if (resPtr) { + if (objPtr->typePtr == &chanObjType) { /* * Confirm validity of saved lookup results. */ + resPtr = (ResolvedChanName *) objPtr->internalRep.twoPtrValue.ptr1; statePtr = resPtr->statePtr; if ((resPtr->interp == interp) /* Same interp context */ /* No epoch change in channel since lookup */ && (resPtr->epoch == statePtr->epoch)) { /* - * Have a valid saved lookup. Jump to end to return it. - */ + * Have a valid saved lookup. Jump to end to return it. + */ goto valid; } } chan = Tcl_GetChannel(interp, TclGetString(objPtr), NULL); if (chan == NULL) { if (resPtr) { - Tcl_StoreIntRep(objPtr, &chanObjType, NULL); + FreeChannelIntRep(objPtr); } return TCL_ERROR; } if (resPtr && resPtr->refCount == 1) { - /* - * Re-use the ResolvedCmdName struct. - */ + /* Re-use the ResolvedCmdName struct */ + Tcl_Release((ClientData) resPtr->statePtr); - Tcl_Release(resPtr->statePtr); } else { - resPtr = (ResolvedChanName *) Tcl_Alloc(sizeof(ResolvedChanName)); - resPtr->refCount = 0; - ChanSetIntRep(objPtr, resPtr); /* Overwrites, if needed */ + TclFreeIntRep(objPtr); + + resPtr = (ResolvedChanName *) ckalloc(sizeof(ResolvedChanName)); + resPtr->refCount = 1; + objPtr->internalRep.twoPtrValue.ptr1 = (ClientData) resPtr; + objPtr->typePtr = &chanObjType; } statePtr = ((Channel *)chan)->state; resPtr->statePtr = statePtr; - Tcl_Preserve(statePtr); + Tcl_Preserve((ClientData) statePtr); resPtr->interp = interp; resPtr->epoch = statePtr->epoch; valid: *channelPtr = (Tcl_Channel) statePtr->bottomChanPtr; @@ -1647,12 +1621,12 @@ /* * JH: We could subsequently memset these to 0 to avoid the numerous * assignments to 0/NULL below. */ - chanPtr = Tcl_Alloc(sizeof(Channel)); - statePtr = Tcl_Alloc(sizeof(ChannelState)); + chanPtr = (Channel *)ckalloc(sizeof(Channel)); + statePtr = (ChannelState *)ckalloc(sizeof(ChannelState)); chanPtr->state = statePtr; chanPtr->instanceData = instanceData; chanPtr->typePtr = typePtr; @@ -1667,14 +1641,14 @@ /* * Make sure we allocate at least 7 bytes, so it fits for "stdout" * later. */ - tmp = Tcl_Alloc((len < 7) ? 7 : len); + tmp = (char *)ckalloc((len < 7) ? 7 : len); strcpy(tmp, chanName); } else { - tmp = Tcl_Alloc(7); + tmp = (char *)ckalloc(7); tmp[0] = '\0'; } statePtr->channelName = tmp; statePtr->flags = mask; @@ -1943,11 +1917,11 @@ statePtr->inQueueHead = NULL; statePtr->inQueueTail = NULL; } - chanPtr = Tcl_Alloc(sizeof(Channel)); + chanPtr = (Channel *)ckalloc(sizeof(Channel)); /* * Save some of the current state into the new structure, reinitialize the * parts which will stay with the transformation. * @@ -2005,20 +1979,20 @@ } if (--chanPtr->refCount) { return; } if (chanPtr->typePtr == NULL) { - Tcl_Free(chanPtr); + ckfree(chanPtr); } } static void ChannelFree( Channel *chanPtr) { - if (!chanPtr->refCount) { - Tcl_Free(chanPtr); + if (chanPtr->refCount == 0) { + ckfree(chanPtr); return; } chanPtr->typePtr = NULL; } @@ -2185,11 +2159,11 @@ /* * This channel does not cover another one. Simply do a close, if * necessary. */ - if (statePtr->refCount + 1 <= 1) { + if (statePtr->refCount <= 0) { if (Tcl_Close(interp, chan) != TCL_OK) { /* * TIP #219, Tcl Channel Reflection API. * "TclChanCaughtErrorBypass" is not required here, it was * done already by "Tcl_Close". @@ -2472,11 +2446,11 @@ { ChannelBuffer *bufPtr; int n; n = length + CHANNELBUFFER_HEADER_SIZE + BUFFER_PADDING + BUFFER_PADDING; - bufPtr = Tcl_Alloc(n); + bufPtr = (ChannelBuffer *)ckalloc(n); bufPtr->nextAdded = BUFFER_PADDING; bufPtr->nextRemoved = BUFFER_PADDING; bufPtr->bufLength = length + BUFFER_PADDING; bufPtr->nextPtr = NULL; bufPtr->refCount = 1; @@ -2485,11 +2459,11 @@ static void PreserveChannelBuffer( ChannelBuffer *bufPtr) { - if (!bufPtr->refCount) { + if (bufPtr->refCount == 0) { Tcl_Panic("Reuse of ChannelBuffer! %p", bufPtr); } bufPtr->refCount++; } @@ -2498,18 +2472,18 @@ ChannelBuffer *bufPtr) { if (--bufPtr->refCount) { return; } - Tcl_Free(bufPtr); + ckfree(bufPtr); } static int IsShared( ChannelBuffer *bufPtr) { - return bufPtr->refCount + 1 > 2; + return bufPtr->refCount > 1; } /* *---------------------------------------------------------------------- * @@ -2878,13 +2852,13 @@ DiscardOutputQueued(statePtr); ReleaseChannelBuffer(bufPtr); break; } else { /* - * TODO: Consider detecting and reacting to short writes on + * TODO: Consider detecting and reacting to short writes on * blocking channels. Ought not happen. See iocmd-24.2. - */ + */ wroteSome = 1; } bufPtr->nextRemoved += written; @@ -2925,11 +2899,11 @@ * write in this call, and we've completed the BG flush. * These are the two cases above. If we get here, that means * there is some kind failure in the writable event machinery. * * The tls extension indeed suffers from flaws in its channel - * event mgmt. See http://core.tcl.tk/tcl/info/c31ca233ca. + * event mgmt. See https://core.tcl-lang.org/tcl/info/c31ca233ca. * Until that patch is broadly distributed, disable the * assertion checking here, so that programs using Tcl and * tls can be debugged. assert(!calledFromAsyncFlush); @@ -2941,11 +2915,11 @@ * If the channel is flagged as closed, delete it when the refCount drops * to zero, the output queue is empty and there is no output in the * current output buffer. */ - if (GotFlag(statePtr, CHANNEL_CLOSED) && (statePtr->refCount + 1 <= 1) && + if (GotFlag(statePtr, CHANNEL_CLOSED) && (statePtr->refCount <= 0) && (statePtr->outQueueHead == NULL) && ((statePtr->curOutPtr == NULL) || IsBufferEmpty(statePtr->curOutPtr))) { errorCode = CloseChannel(interp, chanPtr, errorCode); goto done; @@ -3077,11 +3051,11 @@ * closed. All the other channels in the stack are not allowed to remove. */ if (chanPtr == statePtr->bottomChanPtr) { if (statePtr->channelName != NULL) { - Tcl_Free(statePtr->channelName); + ckfree(statePtr->channelName); statePtr->channelName = NULL; } Tcl_FreeEncoding(statePtr->encoding); } @@ -3213,10 +3187,13 @@ /* * TIP #218, Channel Thread Actions */ ChanThreadAction((Channel *) chan, TCL_CHANNEL_THREAD_REMOVE); + + /* Channel is not managed by any thread */ + statePtr->managingThread = NULL; } void Tcl_CutChannel( Tcl_Channel chan) /* The channel being added. Must not be @@ -3257,10 +3234,13 @@ */ for (; chanPtr != NULL ; chanPtr = chanPtr->upChanPtr) { ChanThreadAction(chanPtr, TCL_CHANNEL_THREAD_REMOVE); } + + /* Channel is not managed by any thread */ + statePtr->managingThread = NULL; } /* *---------------------------------------------------------------------- * @@ -3382,11 +3362,11 @@ { CloseCallback *cbPtr; /* Iterate over close callbacks for this * channel. */ Channel *chanPtr; /* The real IO channel. */ ChannelState *statePtr; /* State of real IO channel. */ - int result; /* Of calling FlushChannel. */ + int result = 0; /* Of calling FlushChannel. */ int flushcode; int stickyError; if (chan == NULL) { return TCL_OK; @@ -3408,11 +3388,11 @@ chanPtr = (Channel *) chan; statePtr = chanPtr->state; chanPtr = statePtr->topChanPtr; - if (statePtr->refCount + 1 > 1) { + if (statePtr->refCount > 0) { Tcl_Panic("called Tcl_Close on channel with refCount > 0"); } if (GotFlag(statePtr, CHANNEL_INCLOSE)) { if (interp) { @@ -3460,24 +3440,19 @@ } } Tcl_ClearChannelHandlers(chan); - /* - * Cancel any outstanding timer. - */ - Tcl_DeleteTimerHandler(statePtr->timer); - /* * Invoke the registered close callbacks and delete their records. */ while (statePtr->closeCbPtr != NULL) { cbPtr = statePtr->closeCbPtr; statePtr->closeCbPtr = cbPtr->nextPtr; cbPtr->proc(cbPtr->clientData); - Tcl_Free(cbPtr); + ckfree(cbPtr); } ResetFlag(statePtr, CHANNEL_INCLOSE); /* @@ -3486,12 +3461,13 @@ */ if (chanPtr->typePtr->closeProc == TCL_CLOSE2PROC) { result = chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp, TCL_CLOSE_READ); - } else { - result = 0; + if ((result == EINVAL) || result == ENOTCONN) { + result = 0; + } } /* * The call to FlushChannel will flush any queued output and invoke the * close function of the channel driver, or it will set up the channel to @@ -3531,17 +3507,21 @@ /* * Bug 97069ea11a: set error message if a flush code is set and no error * message set up to now. */ - if (flushcode != 0 && interp != NULL + if (flushcode != 0) { + /* flushcode has precedence, if available */ + result = flushcode; + } + if ((result != 0) && (result != TCL_ERROR) && (interp != NULL) && 0 == Tcl_GetCharLength(Tcl_GetObjResult(interp))) { - Tcl_SetErrno(flushcode); + Tcl_SetErrno(result); Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_PosixError(interp), -1)); } - if ((flushcode != 0) || (result != 0)) { + if (result != 0) { return TCL_ERROR; } return TCL_OK; } @@ -3559,11 +3539,11 @@ * Closes one direction of the channel. * * NOTE: * Tcl_CloseEx closes the specified direction of the channel as far as * the user is concerned. The channel keeps existing however. You cannot - * calls this function to close the last possible direction of the + * call this function to close the last possible direction of the * channel. Use Tcl_Close for that. * *---------------------------------------------------------------------- */ @@ -3580,22 +3560,30 @@ if (chan == NULL) { return TCL_OK; } - /* TODO: assert flags validity ? */ - chanPtr = (Channel *) chan; statePtr = chanPtr->state; + + if ((flags & (TCL_READABLE | TCL_WRITABLE)) == 0) { + return Tcl_Close(interp, chan); + } + if ((flags & (TCL_READABLE | TCL_WRITABLE)) == (TCL_READABLE | TCL_WRITABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "double-close of channels not supported by %ss", + chanPtr->typePtr->typeName)); + return TCL_ERROR; + } /* * Does the channel support half-close anyway? Error if not. */ if (!chanPtr->typePtr->close2Proc) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "half-close of channels not supported by %ss", + "half-close of channels not supported by %ss", chanPtr->typePtr->typeName)); return TCL_ERROR; } /* @@ -3827,11 +3815,11 @@ * Finally do what is asked of us. Close and free the channel driver state * for the chosen side of the channel. This may leave a TIP #219 error * message in the interp. */ - result = ChanCloseHalf(chanPtr, interp, flags); + result = chanPtr->typePtr->close2Proc(chanPtr->instanceData, NULL, flags); /* * If we are being called synchronously, report either any latent error on * the channel or the current error. */ @@ -3943,11 +3931,11 @@ * Remove all the channel handler records attached to the channel itself. */ for (chPtr = statePtr->chPtr; chPtr != NULL; chPtr = chNext) { chNext = chPtr->nextPtr; - Tcl_Free(chPtr); + ckfree(chPtr); } statePtr->chPtr = NULL; /* * Cancel any pending copy operation. @@ -3970,11 +3958,11 @@ */ for (ePtr = statePtr->scriptRecordPtr; ePtr != NULL; ePtr = eNextPtr) { eNextPtr = ePtr->nextPtr; TclDecrRefCount(ePtr->scriptPtr); - Tcl_Free(ePtr); + ckfree(ePtr); } statePtr->scriptRecordPtr = NULL; } /* @@ -3989,25 +3977,25 @@ * the specified channel to the topmost channel in a stack. * * No encoding conversions are applied to the bytes being read. * * Results: - * The number of bytes written or TCL_IO_FAILURE in case of error. If - * TCL_IO_FAILURE, Tcl_GetErrno will return the error code. + * The number of bytes written or -1 in case of error. If -1, + * Tcl_GetErrno will return the error code. * * Side effects: * May buffer up output and may cause output to be produced on the * channel. * *---------------------------------------------------------------------- */ -size_t +int Tcl_Write( Tcl_Channel chan, /* The channel to buffer output for. */ const char *src, /* Data to queue in output buffer. */ - size_t srcLen) /* Length of data in bytes, or -1 for + int srcLen) /* Length of data in bytes, or < 0 for * strlen(). */ { /* * Always use the topmost channel of the stack */ @@ -4017,18 +4005,18 @@ statePtr = ((Channel *) chan)->state; chanPtr = statePtr->topChanPtr; if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) { - return TCL_IO_FAILURE; + return -1; } - if (srcLen == TCL_AUTO_LENGTH) { + if (srcLen < 0) { srcLen = strlen(src); } - if (WriteBytes(chanPtr, src, srcLen) == -1) { - return TCL_IO_FAILURE; + if (WriteBytes(chanPtr, src, srcLen) < 0) { + return -1; } return srcLen; } /* @@ -4043,48 +4031,47 @@ * compensate for stacking. * * No encoding conversions are applied to the bytes being read. * * Results: - * The number of bytes written or TCL_IO_FAILURE in case of error. If - * TCL_IO_FAILURE, Tcl_GetErrno will return the error code. + * The number of bytes written or -1 in case of error. If -1, + * Tcl_GetErrno will return the error code. * * Side effects: * May buffer up output and may cause output to be produced on the * channel. * *---------------------------------------------------------------------- */ -size_t +int Tcl_WriteRaw( Tcl_Channel chan, /* The channel to buffer output for. */ const char *src, /* Data to queue in output buffer. */ - size_t srcLen) /* Length of data in bytes, or -1 for + int srcLen) /* Length of data in bytes, or < 0 for * strlen(). */ { Channel *chanPtr = ((Channel *) chan); ChannelState *statePtr = chanPtr->state; /* State info for channel */ - int errorCode; - size_t written; + int errorCode, written; if (CheckChannelErrors(statePtr, TCL_WRITABLE | CHANNEL_RAW_MODE) != 0) { - return TCL_IO_FAILURE; + return -1; } - if (srcLen == TCL_AUTO_LENGTH) { + if (srcLen < 0) { srcLen = strlen(src); } /* * Go immediately to the driver, do all the error handling by ourselves. * The code was stolen from 'FlushChannel'. */ written = ChanWrite(chanPtr, src, srcLen, &errorCode); - if (written == TCL_IO_FAILURE) { + if (written < 0) { Tcl_SetErrno(errorCode); } return written; } @@ -4100,40 +4087,40 @@ * ready e.g. if it contains a newline and we are in line buffering * mode. Compensates stacking, i.e. will redirect the data from the * specified channel to the topmost channel in a stack. * * Results: - * The number of bytes written or TCL_IO_FAILURE in case of error. If - * TCL_IO_FAILURE, Tcl_GetErrno will return the error code. + * The number of bytes written or -1 in case of error. If -1, + * Tcl_GetErrno will return the error code. * * Side effects: * May buffer up output and may cause output to be produced on the * channel. * *---------------------------------------------------------------------- */ -size_t +int Tcl_WriteChars( Tcl_Channel chan, /* The channel to buffer output for. */ const char *src, /* UTF-8 characters to queue in output * buffer. */ - size_t len) /* Length of string in bytes, or -1 for + int len) /* Length of string in bytes, or < 0 for * strlen(). */ { Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; /* State info for channel */ int result; Tcl_Obj *objPtr; if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) { - return TCL_IO_FAILURE; + return -1; } chanPtr = statePtr->topChanPtr; - if (len == TCL_AUTO_LENGTH) { + if (len < 0) { len = strlen(src); } if (statePtr->encoding) { return WriteChars(chanPtr, src, len); } @@ -4148,11 +4135,11 @@ if ((len == 1) && (UCHAR(*src) < 0xC0)) { return WriteBytes(chanPtr, src, len); } objPtr = Tcl_NewStringObj(src, len); - src = (char *) TclGetByteArrayFromObj(objPtr, &len); + src = (char *) Tcl_GetByteArrayFromObj(objPtr, &len); result = WriteBytes(chanPtr, src, len); TclDecrRefCount(objPtr); return result; } @@ -4179,11 +4166,11 @@ * channel. * *---------------------------------------------------------------------- */ -size_t +int Tcl_WriteObj( Tcl_Channel chan, /* The channel to buffer output for. */ Tcl_Obj *objPtr) /* The object to write. */ { /* @@ -4191,20 +4178,20 @@ */ Channel *chanPtr; ChannelState *statePtr; /* State info for channel */ const char *src; - size_t srcLen = 0; + int srcLen; statePtr = ((Channel *) chan)->state; chanPtr = statePtr->topChanPtr; if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) { - return TCL_IO_FAILURE; + return -1; } if (statePtr->encoding == NULL) { - src = (char *) TclGetByteArrayFromObj(objPtr, &srcLen); + src = (char *) Tcl_GetByteArrayFromObj(objPtr, &srcLen); return WriteBytes(chanPtr, src, srcLen); } else { src = TclGetStringFromObj(objPtr, &srcLen); return WriteChars(chanPtr, src, srcLen); } @@ -4214,34 +4201,35 @@ WillWrite( Channel *chanPtr) { int inputBuffered; - if ((chanPtr->typePtr->seekProc != NULL) && - ((inputBuffered = Tcl_InputBuffered((Tcl_Channel) chanPtr)) > 0)){ - int ignore; + if ((Tcl_ChannelSeekProc(chanPtr->typePtr) != NULL) && + ((inputBuffered = Tcl_InputBuffered((Tcl_Channel) chanPtr)) > 0)){ + int ignore; - DiscardInputQueued(chanPtr->state, 0); - ChanSeek(chanPtr, -inputBuffered, SEEK_CUR, &ignore); + DiscardInputQueued(chanPtr->state, 0); + ChanSeek(chanPtr, -inputBuffered, SEEK_CUR, &ignore); } } static int WillRead( Channel *chanPtr) { if (chanPtr->typePtr == NULL) { /* - * Prevent read attempts on a closed channel. - */ + * Prevent read attempts on a closed channel. + */ - DiscardInputQueued(chanPtr->state, 0); + DiscardInputQueued(chanPtr->state, 0); Tcl_SetErrno(EINVAL); return -1; } - if ((chanPtr->typePtr->seekProc != NULL) - && (Tcl_OutputBuffered((Tcl_Channel) chanPtr) > 0)) { + if ((Tcl_ChannelSeekProc(chanPtr->typePtr) != NULL) + && (Tcl_OutputBuffered((Tcl_Channel) chanPtr) > 0)) { + /* * CAVEAT - The assumption here is that FlushChannel() will push out * the bytes of any writes that are in progress. Since this is a * seekable channel, we assume it is not one that can block and force * bg flushing. Channels we know that can do that - sockets, pipes - @@ -4248,13 +4236,13 @@ * are not seekable. If the assumption is wrong, more drastic measures * may be required here like temporarily setting the channel into * blocking mode. */ - if (FlushChannel(NULL, chanPtr, 0) != 0) { - return -1; - } + if (FlushChannel(NULL, chanPtr, 0) != 0) { + return -1; + } } return 0; } /* @@ -4300,11 +4288,11 @@ endEncoding = ((statePtr->outputEncodingFlags & TCL_ENCODING_END) != 0); if (GotFlag(statePtr, CHANNEL_LINEBUFFERED) || (statePtr->outputTranslation != TCL_TRANSLATE_LF)) { - nextNewLine = memchr(src, '\n', srcLen); + nextNewLine = (char *)memchr(src, '\n', srcLen); } while (srcLen + saved + endEncoding > 0) { ChannelBuffer *bufPtr; char *dst, safe[BUFFER_PADDING]; @@ -4338,19 +4326,19 @@ statePtr->outputEncodingFlags, &statePtr->outputEncodingState, dst, dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL); /* - * See chan-io-1.[89]. Tcl Bug 506297. - */ + * See chan-io-1.[89]. Tcl Bug 506297. + */ statePtr->outputEncodingFlags &= ~TCL_ENCODING_START; if ((result != TCL_OK) && (srcRead + dstWrote == 0)) { /* - * We're reading from invalid/incomplete UTF-8. - */ + * We're reading from invalid/incomplete UTF-8. + */ ReleaseChannelBuffer(bufPtr); if (total == 0) { Tcl_SetErrno(EINVAL); return -1; @@ -4398,11 +4386,11 @@ src++; srcLen--; total += dstWrote; dst += dstWrote; dstLen -= dstWrote; - nextNewLine = memchr(src, '\n', srcLen); + nextNewLine = (char *)memchr(src, '\n', srcLen); needNlFlush = 1; } if (IsBufferOverflowing(bufPtr)) { /* @@ -4411,11 +4399,11 @@ * the output buffer, so that we would get a completely full * buffer before flushing it. The extra bytes will be moved to the * beginning of the next buffer. */ - saved = 1 + ~SpaceLeft(bufPtr); + saved = -SpaceLeft(bufPtr); memcpy(safe, dst + dstLen, saved); bufPtr->nextAdded = bufPtr->bufLength; } if ((srcLen + saved == 0) && (result == TCL_OK)) { @@ -4451,12 +4439,10 @@ if (FlushChannel(NULL, chanPtr, 0) != 0) { return -1; } } - UpdateInterest(chanPtr); - return total; } /* *--------------------------------------------------------------------------- @@ -4475,24 +4461,24 @@ * the channel. * *--------------------------------------------------------------------------- */ -size_t +int Tcl_Gets( Tcl_Channel chan, /* Channel from which to read. */ Tcl_DString *lineRead) /* The line read will be appended to this * DString as UTF-8 characters. The caller * must have initialized it and is responsible * for managing the storage. */ { Tcl_Obj *objPtr; - size_t charsStored; + int charsStored; TclNewObj(objPtr); charsStored = Tcl_GetsObj(chan, objPtr); - if (charsStored + 1 > 1) { + if (charsStored > 0) { TclDStringAppendObj(lineRead, objPtr); } TclDecrRefCount(objPtr); return charsStored; } @@ -4518,11 +4504,11 @@ * leave channel pointing after EOL, but don't return EOL in dst buffer. * *--------------------------------------------------------------------------- */ -size_t +int Tcl_GetsObj( Tcl_Channel chan, /* Channel from which to read. */ Tcl_Obj *objPtr) /* The line read will be appended to this * object as UTF-8 characters. */ { @@ -4529,18 +4515,17 @@ GetsState gs; Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; /* State info for channel */ ChannelBuffer *bufPtr; - int inEofChar, skip, copiedTotal, oldFlags, oldRemoved; - size_t oldLength; + int inEofChar, skip, copiedTotal, oldLength, oldFlags, oldRemoved; Tcl_Encoding encoding; char *dst, *dstEnd, *eol, *eof; Tcl_EncodingState oldState; if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) { - return TCL_IO_FAILURE; + return -1; } /* * If we're sitting ready to read the eofchar, there's no need to * do it. @@ -4551,11 +4536,11 @@ assert(statePtr->inputEncodingFlags & TCL_ENCODING_END); assert(!GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR)); /* TODO: Do we need this? */ UpdateInterest(chanPtr); - return TCL_IO_FAILURE; + return -1; } /* * A binary version of Tcl_GetsObj. This could also handle encodings that * are ascii-7 pure (iso8859, utf-8, ...) with a final encoding conversion @@ -4581,11 +4566,11 @@ /* * Preserved so we can restore the channel's state in case we don't find a * newline in the available input. */ - (void)TclGetStringFromObj(objPtr, &oldLength); + TclGetStringFromObj(objPtr, &oldLength); oldFlags = statePtr->inputEncodingFlags; oldState = statePtr->inputEncodingState; oldRemoved = BUFFER_PADDING; if (bufPtr != NULL) { oldRemoved = bufPtr->nextRemoved; @@ -4678,11 +4663,11 @@ * LF at the begining of the next buffer, unless EOF char * was found already. */ if (eol >= dstEnd) { - size_t offset; + int offset; if (eol != eof) { offset = eol - objPtr->bytes; dst = dstEnd; if (FilterInputBytes(chanPtr, &gs) != 0) { @@ -4712,18 +4697,18 @@ if ((eol < dstEnd) && (*eol == '\n')) { /* * Skip the raw bytes that make up the '\n'. */ - char tmp[TCL_UTF_MAX]; int rawRead; + char tmp[TCL_UTF_MAX]; bufPtr = gs.bufPtr; Tcl_ExternalToUtf(NULL, gs.encoding, RemovePoint(bufPtr), gs.rawRead, statePtr->inputEncodingFlags | TCL_ENCODING_NO_TERMINATE, &gs.state, tmp, - TCL_UTF_MAX, &rawRead, NULL, NULL); + sizeof(tmp), &rawRead, NULL, NULL); bufPtr->nextRemoved += rawRead; gs.rawRead -= rawRead; gs.bytesWrote--; gs.charsWrote--; memmove(dst, dst + 1, dstEnd - dst); @@ -4945,13 +4930,12 @@ { Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; /* State info for channel */ ChannelBuffer *bufPtr; - int inEofChar, skip, copiedTotal, oldFlags, oldRemoved; - size_t rawLen, byteLen = 0, oldLength; - int eolChar; + int inEofChar, skip, copiedTotal, oldLength, oldFlags, oldRemoved; + int rawLen, byteLen, eolChar; unsigned char *dst, *dstEnd, *eol, *eof, *byteArray; /* * This operation should occur at the top of a channel stack. */ @@ -4964,11 +4948,11 @@ /* * Preserved so we can restore the channel's state in case we don't find a * newline in the available input. */ - byteArray = TclGetByteArrayFromObj(objPtr, &byteLen); + byteArray = Tcl_GetByteArrayFromObj(objPtr, &byteLen); oldFlags = statePtr->inputEncodingFlags; oldRemoved = BUFFER_PADDING; oldLength = byteLen; if (bufPtr != NULL) { oldRemoved = bufPtr->nextRemoved; @@ -5202,10 +5186,11 @@ static void FreeBinaryEncoding( ClientData dummy) /* Not used */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + (void)dummy; if (tsdPtr->binaryEncoding != NULL) { Tcl_FreeEncoding(tsdPtr->binaryEncoding); tsdPtr->binaryEncoding = NULL; } @@ -5407,11 +5392,11 @@ bufPtr->nextPtr = nextPtr; statePtr->inQueueTail = nextPtr; } extra = rawLen - gsPtr->rawRead; memcpy(nextPtr->buf + (BUFFER_PADDING - extra), - raw + gsPtr->rawRead, extra); + raw + gsPtr->rawRead, (size_t) extra); nextPtr->nextRemoved -= extra; bufPtr->nextAdded -= extra; } } @@ -5587,15 +5572,15 @@ * May cause input to be buffered. * *---------------------------------------------------------------------- */ -size_t +int Tcl_Read( Tcl_Channel chan, /* The channel from which to read. */ char *dst, /* Where to store input read. */ - size_t bytesToRead) /* Maximum number of bytes to read. */ + int bytesToRead) /* Maximum number of bytes to read. */ { Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; /* State info for channel */ @@ -5604,11 +5589,11 @@ */ chanPtr = statePtr->topChanPtr; if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) { - return TCL_IO_FAILURE; + return -1; } return DoRead(chanPtr, dst, bytesToRead, 0); } @@ -5632,39 +5617,39 @@ * May cause input to be buffered. * *---------------------------------------------------------------------- */ -size_t +int Tcl_ReadRaw( Tcl_Channel chan, /* The channel from which to read. */ char *readBuf, /* Where to store input read. */ - size_t bytesToRead) /* Maximum number of bytes to read. */ + int bytesToRead) /* Maximum number of bytes to read. */ { Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; /* State info for channel */ int copied = 0; assert(bytesToRead > 0); if (CheckChannelErrors(statePtr, TCL_READABLE | CHANNEL_RAW_MODE) != 0) { - return TCL_IO_FAILURE; + return -1; } /* * First read bytes from the push-back buffers. */ while (chanPtr->inQueueHead && bytesToRead > 0) { ChannelBuffer *bufPtr = chanPtr->inQueueHead; int bytesInBuffer = BytesLeft(bufPtr); - int toCopy = (bytesInBuffer < (int)bytesToRead) ? bytesInBuffer - : (int)bytesToRead; + int toCopy = (bytesInBuffer < bytesToRead) ? bytesInBuffer + : bytesToRead; /* - * Copy the current chunk into the read buffer. - */ + * Copy the current chunk into the read buffer. + */ memcpy(readBuf, RemovePoint(bufPtr), toCopy); bufPtr->nextRemoved += toCopy; copied += toCopy; readBuf += toCopy; @@ -5699,11 +5684,17 @@ */ if (bytesToRead > 0) { int nread = ChanRead(chanPtr, readBuf, bytesToRead); - if (nread == -1) { + if (nread > 0) { + /* + * Successful read (short is OK) - add to bytes copied. + */ + + copied += nread; + } else if (nread < 0) { /* * An error signaled. If CHANNEL_BLOCKED, then the error is not * real, but an indication of blocked state. In that case, retain * the flag and let caller receive the short read of copied bytes * from the pushback. HOWEVER, if copied==0 bytes from pushback @@ -5713,16 +5704,10 @@ */ if (!GotFlag(statePtr, CHANNEL_BLOCKED) || copied == 0) { copied = -1; } - } else if (nread > 0) { - /* - * Successful read (short is OK) - add to bytes copied. - */ - - copied += nread; } else { /* * nread == 0. Driver is at EOF. Let that state filter up. */ } @@ -5750,15 +5735,15 @@ * May cause input to be buffered. * *--------------------------------------------------------------------------- */ -size_t +int Tcl_ReadChars( Tcl_Channel chan, /* The channel to read. */ Tcl_Obj *objPtr, /* Input data is stored in this object. */ - size_t toRead, /* Maximum number of characters to store, or + int toRead, /* Maximum number of characters to store, or * -1 to read all available data (up to EOF or * when channel blocks). */ int appendFlag) /* If non-zero, data read from the channel * will be appended to the object. Otherwise, * the data will replace the existing contents @@ -5810,11 +5795,11 @@ static int DoReadChars( Channel *chanPtr, /* The channel to read. */ Tcl_Obj *objPtr, /* Input data is stored in this object. */ - size_t toRead, /* Maximum number of characters to store, or + int toRead, /* Maximum number of characters to store, or * -1 to read all available data (up to EOF or * when channel blocks). */ int appendFlag) /* If non-zero, data read from the channel * will be appended to the object. Otherwise, * the data will replace the existing contents @@ -5896,11 +5881,11 @@ if (GotFlag(statePtr, CHANNEL_EOF)) { statePtr->inputEncodingFlags |= TCL_ENCODING_START; } ResetFlag(statePtr, CHANNEL_BLOCKED|CHANNEL_EOF); statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; - for (copied = 0; toRead > 0; ) { + for (copied = 0; (unsigned) toRead > 0; ) { copiedNow = -1; if (statePtr->inQueueHead != NULL) { if (binaryMode) { copiedNow = ReadBytes(statePtr, objPtr, toRead); } else { @@ -6014,11 +5999,11 @@ Tcl_Obj *objPtr, /* Input data is appended to this ByteArray * object. Its length is how much space has * been allocated to hold data, not how many * bytes of data have been stored in the * object. */ - int bytesToRead) /* Maximum number of bytes to store, or -1 to + int bytesToRead) /* Maximum number of bytes to store, or < 0 to * get all available bytes. Bytes are obtained * from the first buffer in the queue - even * if this number is larger than the number of * bytes available in the first buffer, only * the bytes from the first buffer are @@ -6091,12 +6076,11 @@ Tcl_EncodingState savedState = statePtr->inputEncodingState; ChannelBuffer *bufPtr = statePtr->inQueueHead; int savedIEFlags = statePtr->inputEncodingFlags; int savedFlags = statePtr->flags; char *dst, *src = RemovePoint(bufPtr); - size_t numBytes; - int srcLen = BytesLeft(bufPtr); + int numBytes, srcLen = BytesLeft(bufPtr); /* * One src byte can yield at most one character. So when the number of * src bytes we plan to read is less than the limit on character count to * be read, clearly we will remain within that limit, and we can use the @@ -6115,11 +6099,11 @@ int dstLimit = TCL_UTF_MAX - 1 + toRead * factor / UTF_EXPANSION_FACTOR; (void) TclGetStringFromObj(objPtr, &numBytes); Tcl_AppendToObj(objPtr, NULL, dstLimit); if (toRead == srcLen) { - size_t size; + unsigned int size; dst = TclGetStringStorage(objPtr, &size) + numBytes; dstLimit = size - numBytes; } else { dst = TclGetString(objPtr) + numBytes; @@ -6267,12 +6251,12 @@ * char from that alone. We have to know what's next. So why do * we only have the one decoded char? */ if (code != TCL_OK) { - char buffer[TCL_UTF_MAX + 1]; int read, decoded, count; + char buffer[TCL_UTF_MAX + 1]; /* * Didn't get everything the buffer could offer */ @@ -6284,11 +6268,11 @@ || BytesLeft(bufPtr->nextPtr) == 0 || 0 == (statePtr->inputEncodingFlags & TCL_ENCODING_END)); Tcl_ExternalToUtf(NULL, encoding, src, srcLen, (statePtr->inputEncodingFlags | TCL_ENCODING_NO_TERMINATE), - &statePtr->inputEncodingState, buffer, TCL_UTF_MAX + 1, + &statePtr->inputEncodingState, buffer, sizeof(buffer), &read, &decoded, &count); if (count == 2) { if (buffer[1] == '\n') { /* \r\n translate to \n */ @@ -6354,12 +6338,12 @@ if (dstWrote == 0) { ChannelBuffer *nextPtr; /* - * We were not able to read any chars. - */ + * We were not able to read any chars. + */ assert(numChars == 0); /* * There is one situation where this is the correct final result. @@ -6375,11 +6359,11 @@ goto consume; } /* - * Otherwise, reading zero characters indicates there's something + * Otherwise, reading zero characters indicates there's something * incomplete at the end of the src buffer. Maybe there were not * enough src bytes to decode into a char. Maybe a lone \r could * not be translated (crlf mode). Need to combine any unused src * bytes we have in the first buffer with subsequent bytes to try * again. @@ -6484,21 +6468,21 @@ switch (statePtr->inputTranslation) { case TCL_TRANSLATE_LF: case TCL_TRANSLATE_CR: if (srcLen > dstLen) { - /* - * In these modes, each src byte become a dst byte. - */ + /* + * In these modes, each src byte become a dst byte. + */ srcLen = dstLen; } break; default: /* - * In other modes, at most 2 src bytes become a dst byte. - */ + * In other modes, at most 2 src bytes become a dst byte. + */ if (srcLen/2 > dstLen) { srcLen = 2 * dstLen; } break; @@ -6508,11 +6492,11 @@ /* * Make sure we do not read past any logical end of channel input * created by the presence of the input eof char. */ - if ((eof = memchr(srcStart, inEofChar, srcLen))) { + if ((eof = (const char *)memchr(srcStart, inEofChar, srcLen))) { srcLen = eof - srcStart; } } switch (statePtr->inputTranslation) { @@ -6523,11 +6507,11 @@ } if (statePtr->inputTranslation == TCL_TRANSLATE_CR) { char *dst = dstStart; char *dstEnd = dstStart + srcLen; - while ((dst = memchr(dst, '\r', dstEnd - dst))) { + while ((dst = (char *)memchr(dst, '\r', dstEnd - dst))) { *dst++ = '\n'; } } dstLen = srcLen; break; @@ -6534,11 +6518,11 @@ case TCL_TRANSLATE_CRLF: { const char *crFound, *src = srcStart; char *dst = dstStart; int lesser = (dstLen < srcLen) ? dstLen : srcLen; - while ((crFound = memchr(src, '\r', lesser))) { + while ((crFound = (const char *)memchr(src, '\r', lesser))) { int numBytes = crFound - src; memmove(dst, src, numBytes); dst += numBytes; dstLen -= numBytes; src += numBytes; srcLen -= numBytes; @@ -6574,11 +6558,11 @@ if ((statePtr->flags & INPUT_SAW_CR) && srcLen) { if (*src == '\n') { src++; srcLen--; } ResetFlag(statePtr, INPUT_SAW_CR); } lesser = (dstLen < srcLen) ? dstLen : srcLen; - while ((crFound = memchr(src, '\r', lesser))) { + while ((crFound = (const char *)memchr(src, '\r', lesser))) { int numBytes = crFound - src; memmove(dst, src, numBytes); dst[numBytes] = '\n'; dst += numBytes + 1; dstLen -= numBytes + 1; @@ -6621,23 +6605,23 @@ * * Causes the supplied string to be added to the input queue of the * channel, at either the head or tail of the queue. * * Results: - * The number of bytes stored in the channel, or TCL_IO_FAILURE on error. + * The number of bytes stored in the channel, or -1 on error. * * Side effects: * Adds input to the input queue of a channel. * *---------------------------------------------------------------------- */ -size_t +int Tcl_Ungets( Tcl_Channel chan, /* The channel for which to add the input. */ const char *str, /* The input itself. */ - size_t len, /* The length of the input. */ + int len, /* The length of the input. */ int atEnd) /* If non-zero, add at end of queue; otherwise * add at head of queue. */ { Channel *chanPtr; /* The real IO channel. */ ChannelState *statePtr; /* State of actual channel. */ @@ -6657,11 +6641,11 @@ * CheckChannelErrors clears too many flag bits in this one case. */ flags = statePtr->flags; if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) { - len = TCL_IO_FAILURE; + len = -1; goto done; } statePtr->flags = flags; /* @@ -6842,25 +6826,28 @@ if (CheckForDeadChannel(NULL, statePtr)) { return EINVAL; } /* - * WARNING: There was once a comment here claiming that it was a bad idea - * to make another call to the inputproc of a channel driver when EOF has - * already been detected on the channel. Through much of Tcl's history, - * this warning was then completely negated by having all (most?) read - * paths clear the EOF setting before reaching here. So we had a guard - * that was never triggered. - * - * Don't be tempted to restore the guard. Even if EOF is set on the - * channel, continue through and call the inputproc again. This is the - * way to enable the ability to [read] again beyond the EOF, which seems a - * strange thing to do, but for which use cases exist [Tcl Bug 5adc350683] - * and which may even be essential for channels representing things like - * ttys or other devices where the stream might take the logical form of a - * series of 'files' separated by an EOF condition. - * + * WARNING: There was once a comment here claiming that it was + * a bad idea to make another call to the inputproc of a channel + * driver when EOF has already been detected on the channel. Through + * much of Tcl's history, this warning was then completely negated + * by having all (most?) read paths clear the EOF setting before + * reaching here. So we had a guard that was never triggered. + * + * Don't be tempted to restore the guard. Even if EOF is set on + * the channel, continue through and call the inputproc again. This + * is the way to enable the ability to [read] again beyond the EOF, + * which seems a strange thing to do, but for which use cases exist + * [Tcl Bug 5adc350683] and which may even be essential for channels + * representing things like ttys or other devices where the stream + * might take the logical form of a series of 'files' separated by + * an EOF condition. + */ + + /* * First check for more buffers in the pushback area of the topmost * channel in the stack and use them. They can be the result of a * transformation which went away without reading all the information * placed in the area when it was stacked. */ @@ -6999,11 +6986,11 @@ /* * Disallow seek on channels whose type does not have a seek procedure * defined. This means that the channel does not support seeking. */ - if (chanPtr->typePtr->seekProc == NULL) { + if (Tcl_ChannelSeekProc(chanPtr->typePtr) == NULL) { Tcl_SetErrno(EINVAL); return -1; } /* @@ -7163,11 +7150,11 @@ /* * Disallow tell on channels whose type does not have a seek procedure * defined. This means that the channel does not support seeking. */ - if (chanPtr->typePtr->seekProc == NULL) { + if (Tcl_ChannelSeekProc(chanPtr->typePtr) == NULL) { Tcl_SetErrno(EINVAL); return -1; } /* @@ -7193,10 +7180,51 @@ if (inputBuffered != 0) { return curPos - inputBuffered; } return curPos + outputBuffered; } + +/* + *--------------------------------------------------------------------------- + * + * Tcl_SeekOld, Tcl_TellOld -- + * + * Backward-compatibility versions of the seek/tell interface that do not + * support 64-bit offsets. This interface is not documented or expected + * to be supported indefinitely. + * + * Results: + * As for Tcl_Seek and Tcl_Tell respectively, except truncated to + * whatever value will fit in an 'int'. + * + * Side effects: + * As for Tcl_Seek and Tcl_Tell respectively. + * + *--------------------------------------------------------------------------- + */ + +int +Tcl_SeekOld( + Tcl_Channel chan, /* The channel on which to seek. */ + int offset, /* Offset to seek to. */ + int mode) /* Relative to which location to seek? */ +{ + Tcl_WideInt wOffset, wResult; + + wOffset = Tcl_LongAsWide((long) offset); + wResult = Tcl_Seek(chan, wOffset, mode); + return (int) Tcl_WideAsLong(wResult); +} + +int +Tcl_TellOld( + Tcl_Channel chan) /* The channel to return pos for. */ +{ + Tcl_WideInt wResult = Tcl_Tell(chan); + + return (int) Tcl_WideAsLong(wResult); +} /* *--------------------------------------------------------------------------- * * Tcl_TruncateChannel -- @@ -7249,11 +7277,11 @@ * pre-read input data. */ WillWrite(chanPtr); - if (WillRead(chanPtr) == -1) { + if (WillRead(chanPtr) < 0) { return TCL_ERROR; } /* * We're all flushed to disk now and we also don't have any unfortunate @@ -7482,11 +7510,11 @@ for (bytesBuffered = 0, bufPtr = statePtr->outQueueHead; bufPtr != NULL; bufPtr = bufPtr->nextPtr) { bytesBuffered += BytesLeft(bufPtr); } if (statePtr->curOutPtr != NULL) { - register ChannelBuffer *curOutPtr = statePtr->curOutPtr; + ChannelBuffer *curOutPtr = statePtr->curOutPtr; if (IsBufferReady(curOutPtr)) { bytesBuffered += BytesLeft(curOutPtr); } } @@ -7669,19 +7697,19 @@ &argc, &argv) != TCL_OK) { Tcl_Panic("malformed option list in channel driver"); } Tcl_ResetResult(interp); errObj = Tcl_ObjPrintf("bad option \"%s\": should be one of ", - optionName); + optionName ? optionName : ""); argc--; for (i = 0; i < argc; i++) { Tcl_AppendPrintfToObj(errObj, "-%s, ", argv[i]); } Tcl_AppendPrintfToObj(errObj, "or -%s", argv[i]); Tcl_SetObjResult(interp, errObj); Tcl_DStringFree(&ds); - Tcl_Free((void *)argv); + ckfree(argv); } Tcl_SetErrno(EINVAL); return TCL_ERROR; } @@ -8068,11 +8096,11 @@ if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -eofchar: must be non-NUL ASCII" " character", -1)); } - Tcl_Free((void *)argv); + ckfree(argv); return TCL_ERROR; } if (GotFlag(statePtr, TCL_READABLE)) { statePtr->inEofChar = inValue; } @@ -8083,15 +8111,15 @@ if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -eofchar: should be a list of zero," " one, or two elements", -1)); } - Tcl_Free((void *)argv); + ckfree(argv); return TCL_ERROR; } if (argv != NULL) { - Tcl_Free((void *)argv); + ckfree(argv); } /* * [Bug 930851] Reset EOF and BLOCKED flags. Changing the character * which signals eof can transform a current eof condition into a 'go @@ -8121,11 +8149,11 @@ if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -translation: must be a one or two" " element list", -1)); } - Tcl_Free((void *)argv); + ckfree(argv); return TCL_ERROR; } if (readMode) { TclEolTranslation translation; @@ -8151,11 +8179,11 @@ if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -translation: must be one of " "auto, binary, cr, lf, crlf, or platform", -1)); } - Tcl_Free((void *)argv); + ckfree(argv); return TCL_ERROR; } /* * Reset the EOL flags since we need to look at any buffered data @@ -8201,15 +8229,15 @@ if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -translation: must be one of " "auto, binary, cr, lf, crlf, or platform", -1)); } - Tcl_Free((void *)argv); + ckfree(argv); return TCL_ERROR; } } - Tcl_Free((void *)argv); + ckfree(argv); return TCL_OK; } else if (chanPtr->typePtr->setOptionProc != NULL) { return chanPtr->typePtr->setOptionProc(chanPtr->instanceData, interp, optionName, newValue); } else { @@ -8264,11 +8292,11 @@ Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, TclChannelEventScriptInvoker, sPtr); TclDecrRefCount(sPtr->scriptPtr); - Tcl_Free(sPtr); + ckfree(sPtr); } else { prevPtr = sPtr; } } } @@ -8356,10 +8384,17 @@ * Preserve the channel struct in case the script closes it. */ TclChannelPreserve((Tcl_Channel)channel); Tcl_Preserve(statePtr); + + /* + * Avoid processing if the channel owner has been changed. + */ + if (statePtr->managingThread != Tcl_GetCurrentThread()) { + goto done; + } /* * If we are flushing in the background, be sure to call FlushChannel for * writable events. Note that we have to discard the writable event so we * don't call any write handlers before the flush is complete. @@ -8391,10 +8426,17 @@ chPtr->proc(chPtr->clientData, chPtr->mask & mask); chPtr = nh.nextHandlerPtr; } else { chPtr = chPtr->nextPtr; } + + /* + * Stop if the channel owner has been changed in-between. + */ + if (chanPtr->state->managingThread != Tcl_GetCurrentThread()) { + goto done; + } } /* * Update the notifier interest, since it may have changed after invoking * event handlers. Skip that if the channel was deleted in the call to the @@ -8408,10 +8450,11 @@ * UpdateInterest() call, one would think. */ UpdateInterest(chanPtr); } +done: Tcl_Release(statePtr); TclChannelRelease(channel); tsdPtr->nestedHandlerPtr = nh.nestedHandlerPtr; } @@ -8512,20 +8555,10 @@ statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, ChannelTimerProc, chanPtr); } } } - - if (!statePtr->timer - && mask & TCL_WRITABLE - && GotFlag(statePtr, CHANNEL_NONBLOCKING)) { - - statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, - ChannelTimerProc,chanPtr); - } - - ChanWatch(chanPtr, mask); } /* *---------------------------------------------------------------------- @@ -8546,29 +8579,14 @@ static void ChannelTimerProc( ClientData clientData) { - Channel *chanPtr = clientData; + Channel *chanPtr = (Channel *)clientData; ChannelState *statePtr = chanPtr->state; /* State info for channel */ - Tcl_Preserve(statePtr); - statePtr->timer = NULL; - if (statePtr->interestMask & TCL_WRITABLE - && GotFlag(statePtr, CHANNEL_NONBLOCKING) - && !GotFlag(statePtr, BG_FLUSH_SCHEDULED) - ) { - /* - * Restart the timer in case a channel handler reenters the event loop - * before UpdateInterest gets called by Tcl_NotifyChannel. - */ - statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, - ChannelTimerProc,chanPtr); - Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_WRITABLE); - } - if (!GotFlag(statePtr, CHANNEL_NEED_MORE_DATA) && (statePtr->interestMask & TCL_READABLE) && (statePtr->inQueueHead != NULL) && IsBufferReady(statePtr->inQueueHead)) { /* @@ -8576,15 +8594,17 @@ * before UpdateInterest gets called by Tcl_NotifyChannel. */ statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, ChannelTimerProc,chanPtr); + Tcl_Preserve(statePtr); Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_READABLE); + Tcl_Release(statePtr); } else { + statePtr->timer = NULL; UpdateInterest(chanPtr); } - Tcl_Release(statePtr); } /* *---------------------------------------------------------------------- * @@ -8634,11 +8654,11 @@ (chPtr->clientData == clientData)) { break; } } if (chPtr == NULL) { - chPtr = Tcl_Alloc(sizeof(ChannelHandler)); + chPtr = (ChannelHandler *)ckalloc(sizeof(ChannelHandler)); chPtr->mask = 0; chPtr->proc = proc; chPtr->clientData = clientData; chPtr->chanPtr = chanPtr; chPtr->nextPtr = statePtr->chPtr; @@ -8738,11 +8758,11 @@ if (prevChPtr == NULL) { statePtr->chPtr = chPtr->nextPtr; } else { prevChPtr->nextPtr = chPtr->nextPtr; } - Tcl_Free(chPtr); + ckfree(chPtr); /* * Recompute the interest list for the channel, so that infinite loops * will not result if Tcl_DeleteChannelHandler is called inside an event. */ @@ -8797,11 +8817,11 @@ Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, TclChannelEventScriptInvoker, esPtr); TclDecrRefCount(esPtr->scriptPtr); - Tcl_Free(esPtr); + ckfree(esPtr); break; } } } @@ -8846,11 +8866,11 @@ } makeCH = (esPtr == NULL); if (makeCH) { - esPtr = Tcl_Alloc(sizeof(EventScriptRecord)); + esPtr = (EventScriptRecord *)ckalloc(sizeof(EventScriptRecord)); } /* * Initialize the structure before calling Tcl_CreateChannelHandler, * because a reflected channel calling 'chan postevent' aka @@ -8902,15 +8922,20 @@ * registered. */ EventScriptRecord *esPtr; /* The event script + interpreter to eval it * in. */ int result; /* Result of call to eval script. */ - esPtr = clientData; + esPtr = (EventScriptRecord *)clientData; chanPtr = esPtr->chanPtr; mask = esPtr->mask; interp = esPtr->interp; + /* + * Be sure event executed in managed channel (covering bugs similar [f583715154]). + */ + assert(chanPtr->state->managingThread == Tcl_GetCurrentThread()); + /* * We must preserve the interpreter so we can report errors on it later. * Note that we do not need to preserve the channel because that is done * by Tcl_NotifyChannel before calling channel handlers. */ @@ -8957,11 +8982,11 @@ */ /* ARGSUSED */ int Tcl_FileEventObjCmd( - ClientData clientData, /* Not used. */ + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Interpreter in which the channel for which * to create the handler is found. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { @@ -8971,10 +8996,11 @@ const char *chanName; int modeIndex; /* Index of mode argument. */ int mask; static const char *const modeOptions[] = {"readable", "writable", NULL}; static const int maskArray[] = {TCL_READABLE, TCL_WRITABLE}; + (void)dummy; if ((objc != 3) && (objc != 4)) { Tcl_WrongNumArgs(interp, 1, objv, "channelId event ?script?"); return TCL_ERROR; } @@ -9056,11 +9082,11 @@ ClientData clientData) { /* calling CopyData with mask==0 still implies immediate invocation of the * -command callback, and completion of the fcopy. */ - CopyData(clientData, 0); + CopyData((CopyState *)clientData, 0); } /* *---------------------------------------------------------------------- * @@ -9079,10 +9105,22 @@ * May schedule a background copy operation that causes both channels to * be marked busy. * *---------------------------------------------------------------------- */ + +int +TclCopyChannelOld( + Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Channel inChan, /* Channel to read from. */ + Tcl_Channel outChan, /* Channel to write to. */ + int toRead, /* Amount of data to copy, or -1 for all. */ + Tcl_Obj *cmdPtr) /* Pointer to script to execute or NULL. */ +{ + return TclCopyChannel(interp, inChan, outChan, (Tcl_WideInt) toRead, + cmdPtr); +} int TclCopyChannel( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Channel inChan, /* Channel to read from. */ @@ -9162,11 +9200,11 @@ * Allocate a new CopyState to maintain info about the current copy in * progress. This structure will be deallocated when the copy is * completed. */ - csPtr = Tcl_Alloc(sizeof(CopyState) + !moveBytes * inStatePtr->bufSize); + csPtr = (CopyState *)ckalloc(sizeof(CopyState) + !moveBytes * inStatePtr->bufSize); csPtr->bufSize = !moveBytes * inStatePtr->bufSize; csPtr->readPtr = inPtr; csPtr->writePtr = outPtr; csPtr->readFlags = readFlags; csPtr->writeFlags = writeFlags; @@ -9456,12 +9494,11 @@ { Tcl_Interp *interp; Tcl_Obj *cmdPtr, *errObj = NULL, *bufObj = NULL, *msg = NULL; Tcl_Channel inChan, outChan; ChannelState *inStatePtr, *outStatePtr; - int result = TCL_OK, size; - size_t sizeb; + int result = TCL_OK, size, sizeb; Tcl_WideInt total; const char *buffer; int inBinary, outBinary, sameEncoding; /* Encoding control */ int underflow; /* Input underflow */ @@ -9523,21 +9560,21 @@ if ((csPtr->toRead == (Tcl_WideInt) -1) || (csPtr->toRead > (Tcl_WideInt) csPtr->bufSize)) { sizeb = csPtr->bufSize; } else { - sizeb = csPtr->toRead; + sizeb = (int) csPtr->toRead; } if (inBinary || sameEncoding) { size = DoRead(inStatePtr->topChanPtr, csPtr->buffer, sizeb, !GotFlag(inStatePtr, CHANNEL_NONBLOCKING)); } else { size = DoReadChars(inStatePtr->topChanPtr, bufObj, sizeb, 0 /* No append */); } - underflow = (size >= 0) && ((size_t)size < sizeb); /* Input underflow */ + underflow = (size >= 0) && (size < sizeb); /* Input underflow */ } if (size < 0) { readError: if (interp) { @@ -9575,12 +9612,12 @@ csPtr); } if (size == 0) { if (!GotFlag(inStatePtr, CHANNEL_NONBLOCKING)) { /* - * We allowed a short read. Keep trying. - */ + * We allowed a short read. Keep trying. + */ continue; } if (bufObj != NULL) { TclDecrRefCount(bufObj); @@ -9617,11 +9654,11 @@ * to 'size' (It can be smaller or larger, in the latter case able to * drive toRead below -1, causing infinite looping). Completely * unsuitable for updating totals and toRead. */ - if (sizeb == TCL_AUTO_LENGTH) { + if (sizeb < 0) { writeError: if (interp) { TclNewObj(errObj); Tcl_AppendStringsToObj(errObj, "error writing \"", Tcl_GetChannelName(outChan), "\": ", NULL); @@ -9785,15 +9822,17 @@ static int DoRead( Channel *chanPtr, /* The channel from which to read. */ char *dst, /* Where to store input read. */ - size_t bytesToRead, /* Maximum number of bytes to read. */ + int bytesToRead, /* Maximum number of bytes to read. */ int allowShortReads) /* Allow half-blocking (pipes,sockets) */ { ChannelState *statePtr = chanPtr->state; char *p = dst; + + assert(bytesToRead >= 0); /* * Early out when we know a read will get the eofchar. * * NOTE: This seems to be a bug. The special handling for @@ -9844,11 +9883,11 @@ * Don't read more data if we have what we need. */ while (!bufPtr || /* We got no buffer! OR */ (!IsBufferFull(bufPtr) && /* Our buffer has room AND */ - ((size_t)BytesLeft(bufPtr) < bytesToRead))) { + (BytesLeft(bufPtr) < bytesToRead))) { /* Not enough bytes in it yet * to fill the dst */ int code; moreData: @@ -9857,20 +9896,20 @@ assert(bufPtr != NULL); if (GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED)) { /* - * Further reads cannot do any more. - */ + * Further reads cannot do any more. + */ break; } if (code) { /* - * Read error - */ + * Read error + */ UpdateInterest(chanPtr); TclChannelRelease((Tcl_Channel)chanPtr); return -1; } @@ -9918,41 +9957,41 @@ assert(RemovePoint(bufPtr)[0] == '\r'); assert(BytesLeft(bufPtr) == 1); if (bufPtr->nextPtr == NULL) { /* - * There's no more buffered data... - */ + * There's no more buffered data... + */ if (statePtr->flags & CHANNEL_EOF) { /* - * ...and there never will be. - */ + * ...and there never will be. + */ *p++ = '\r'; bytesToRead--; bufPtr->nextRemoved++; } else if (statePtr->flags & CHANNEL_BLOCKED) { /* - * ...and we cannot get more now. - */ + * ...and we cannot get more now. + */ SetFlag(statePtr, CHANNEL_NEED_MORE_DATA); break; } else { /* - * ...so we need to get some. - */ + * ...so we need to get some. + */ goto moreData; } } if (bufPtr->nextPtr) { /* - * There's a next buffer. Shift orphan \r to it. - */ + * There's a next buffer. Shift orphan \r to it. + */ ChannelBuffer *nextPtr = bufPtr->nextPtr; nextPtr->nextRemoved -= 1; RemovePoint(nextPtr)[0] = '\r'; @@ -10019,11 +10058,11 @@ static void CopyEventProc( ClientData clientData, int mask) { - (void) CopyData(clientData, mask); + (void) CopyData((CopyState *)clientData, mask); } /* *---------------------------------------------------------------------- * @@ -10088,11 +10127,11 @@ Tcl_DeleteChannelHandler(outChan, MBEvent, csPtr); TclDecrRefCount(csPtr->cmdPtr); } inStatePtr->csPtrR = NULL; outStatePtr->csPtrW = NULL; - Tcl_Free(csPtr); + ckfree(csPtr); } /* *---------------------------------------------------------------------- * @@ -10352,11 +10391,11 @@ */ chanPtr = ((Channel *) chan)->state->bottomChanPtr; statePtr = chanPtr->state; - hTblPtr = Tcl_GetAssocData(interp, "tclIO", NULL); + hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, "tclIO", NULL); if (hTblPtr == NULL) { return 0; } hPtr = Tcl_FindHashEntry(hTblPtr, statePtr->channelName); if (hPtr == NULL) { @@ -10390,11 +10429,11 @@ Tcl_Channel chan) /* The channel to query */ { ChannelState *statePtr = ((Channel *) chan)->state; /* State of real channel structure. */ - return ((statePtr->refCount + 1 > 2) ? 1 : 0); + return ((statePtr->refCount > 1) ? 1 : 0); } /* *---------------------------------------------------------------------- * @@ -10486,53 +10525,19 @@ Tcl_ChannelTypeVersion Tcl_ChannelVersion( const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ { - if (chanTypePtr->version == TCL_CHANNEL_VERSION_2) { - return TCL_CHANNEL_VERSION_2; - } else if (chanTypePtr->version == TCL_CHANNEL_VERSION_3) { - return TCL_CHANNEL_VERSION_3; - } else if (chanTypePtr->version == TCL_CHANNEL_VERSION_4) { - return TCL_CHANNEL_VERSION_4; - } else if (chanTypePtr->version == TCL_CHANNEL_VERSION_5) { - return TCL_CHANNEL_VERSION_5; - } else { + if ((chanTypePtr->version < TCL_CHANNEL_VERSION_2) + || (chanTypePtr->version > TCL_CHANNEL_VERSION_5)) { /* * In = (PTR2INT(minimumVersion)); + return chanTypePtr->version; } /* *---------------------------------------------------------------------- * @@ -10551,19 +10556,18 @@ Tcl_DriverBlockModeProc * Tcl_ChannelBlockModeProc( const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ { - if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_2)) { - return chanTypePtr->blockModeProc; + if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_2) { + /* + * The v1 structure had the blockModeProc in a different place. + */ + return (Tcl_DriverBlockModeProc *) chanTypePtr->version; } - /* - * The v1 structure had the blockModeProc in a different place. - */ - - return (Tcl_DriverBlockModeProc *) chanTypePtr->version; + return chanTypePtr->blockModeProc; } /* *---------------------------------------------------------------------- * @@ -10799,14 +10803,14 @@ Tcl_DriverFlushProc * Tcl_ChannelFlushProc( const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ { - if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_2)) { - return chanTypePtr->flushProc; + if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_2) { + return NULL; } - return NULL; + return chanTypePtr->flushProc; } /* *---------------------------------------------------------------------- * @@ -10826,14 +10830,14 @@ Tcl_DriverHandlerProc * Tcl_ChannelHandlerProc( const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ { - if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_2)) { - return chanTypePtr->handlerProc; + if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_2) { + return NULL; } - return NULL; + return chanTypePtr->handlerProc; } /* *---------------------------------------------------------------------- * @@ -10853,14 +10857,14 @@ Tcl_DriverWideSeekProc * Tcl_ChannelWideSeekProc( const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ { - if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_3)) { - return chanTypePtr->wideSeekProc; + if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_3) { + return NULL; } - return NULL; + return chanTypePtr->wideSeekProc; } /* *---------------------------------------------------------------------- * @@ -10881,14 +10885,14 @@ Tcl_DriverThreadActionProc * Tcl_ChannelThreadActionProc( const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ { - if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_4)) { - return chanTypePtr->threadActionProc; + if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_4) { + return NULL; } - return NULL; + return chanTypePtr->threadActionProc; } /* *---------------------------------------------------------------------- * @@ -11061,11 +11065,11 @@ } if (newcode >= 0) { lcn += 2; } - lvn = Tcl_Alloc(lcn * sizeof(Tcl_Obj *)); + lvn = (Tcl_Obj **)ckalloc(lcn * sizeof(Tcl_Obj *)); /* * New level/code information is spliced into the first occurence of * -level, -code, further occurences are ignored. The options cannot be * not present, we would not come here. Options which are ok are simply @@ -11114,11 +11118,11 @@ lvn[j++] = lv[i]; } msg = Tcl_NewListObj(j, lvn); - Tcl_Free(lvn); + ckfree(lvn); return msg; } /* *---------------------------------------------------------------------- @@ -11196,14 +11200,14 @@ Tcl_DriverTruncateProc * Tcl_ChannelTruncateProc( const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ { - if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_5)) { - return chanTypePtr->truncateProc; + if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_5) { + return NULL; } - return NULL; + return chanTypePtr->truncateProc; } /* *---------------------------------------------------------------------- * @@ -11222,20 +11226,20 @@ *---------------------------------------------------------------------- */ static void DupChannelIntRep( - register Tcl_Obj *srcPtr, /* Object with internal rep to copy. Must have + Tcl_Obj *srcPtr, /* Object with internal rep to copy. Must have * an internal rep of type "Channel". */ - register Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not + Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not * currently have an internal rep.*/ { - ResolvedChanName *resPtr; + ResolvedChanName *resPtr = srcPtr->internalRep.twoPtrValue.ptr1; - ChanGetIntRep(srcPtr, resPtr); - assert(resPtr); - ChanSetIntRep(copyPtr, resPtr); + resPtr->refCount++; + copyPtr->internalRep.twoPtrValue.ptr1 = resPtr; + copyPtr->typePtr = srcPtr->typePtr; } /* *---------------------------------------------------------------------- * @@ -11254,19 +11258,18 @@ static void FreeChannelIntRep( Tcl_Obj *objPtr) /* Object with internal rep to free. */ { - ResolvedChanName *resPtr; + ResolvedChanName *resPtr = objPtr->internalRep.twoPtrValue.ptr1; - ChanGetIntRep(objPtr, resPtr); - assert(resPtr); - if (resPtr->refCount-- > 1) { + objPtr->typePtr = NULL; + if (--resPtr->refCount) { return; } Tcl_Release(resPtr->statePtr); - Tcl_Free(resPtr); + ckfree(resPtr); } #if 0 /* * For future debugging work, a simple function to print the flags of a Index: generic/tclIO.h ================================================================== --- generic/tclIO.h +++ generic/tclIO.h @@ -34,25 +34,25 @@ * * Buffers data being sent to or from a channel. */ typedef struct ChannelBuffer { - size_t refCount; /* Current uses count */ + int refCount; /* Current uses count */ int nextAdded; /* The next position into which a character * will be put in the buffer. */ int nextRemoved; /* Position of next byte to be removed from * the buffer. */ int bufLength; /* How big is the buffer? */ struct ChannelBuffer *nextPtr; /* Next buffer in chain. */ - char buf[1]; /* Placeholder for real buffer. The real + char buf[TCLFLEXARRAY]; /* Placeholder for real buffer. The real * buffer occuppies this space + bufSize-1 * bytes. This must be the last field in the * structure. */ } ChannelBuffer; -#define CHANNELBUFFER_HEADER_SIZE offsetof(ChannelBuffer, buf) +#define CHANNELBUFFER_HEADER_SIZE TclOffset(ChannelBuffer, buf) /* * How much extra space to allocate in buffer to hold bytes from previous * buffer (when converting to UTF-8) or to hold bytes that will go to next * buffer (when converting from UTF-8). @@ -94,11 +94,11 @@ * specific) instance data, and at a channel type structure. */ typedef struct Channel { struct ChannelState *state; /* Split out state information */ - void *instanceData; /* Instance-specific data provided by creator + ClientData 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 * channels. See Tcl_StackChannel. */ @@ -111,11 +111,11 @@ */ ChannelBuffer *inQueueHead; /* Points at first buffer in input queue. */ ChannelBuffer *inQueueTail; /* Points at last buffer in input queue. */ - size_t refCount; + int refCount; } Channel; /* * struct ChannelState: * @@ -161,11 +161,11 @@ int outEofChar; /* If nonzero, append this to the channel when * it is closed if it is open for writing. */ int unreportedError; /* Non-zero if an error report was deferred * because it happened in the background. The * value is the POSIX error code. */ - size_t refCount; /* How many interpreters hold references to + int refCount; /* How many interpreters hold references to * this IO channel? */ struct CloseCallback *closeCbPtr; /* Callbacks registered to be called when the * channel is closed. */ char *outputStage; /* Temporary staging buffer used when @@ -212,11 +212,11 @@ Tcl_Obj* chanMsg; Tcl_Obj* unreportedMsg; /* Non-NULL if an error report was deferred * because it happened in the background. The * value is the chanMg, if any. #219's * companion to 'unreportedError'. */ - size_t epoch; /* Used to test validity of stored channelname + int epoch; /* Used to test validity of stored channelname * lookup results. */ } ChannelState; /* * Values for the flags field in Channel. Any ORed combination of the Index: generic/tclIOCmd.c ================================================================== --- generic/tclIOCmd.c +++ generic/tclIOCmd.c @@ -13,21 +13,21 @@ /* * Callback structure for accept callback in a TCP server. */ -typedef struct { - Tcl_Obj *script; /* Script to invoke. */ +typedef struct AcceptCallback { + char *script; /* Script to invoke. */ Tcl_Interp *interp; /* Interpreter in which to run it. */ } AcceptCallback; /* * Thread local storage used to maintain a per-thread stdout channel obj. * It must be per-thread because of std channel limitations. */ -typedef struct { +typedef struct ThreadSpecificData { int initialized; /* Set to 1 when the module is initialized. */ Tcl_Obj *stdoutObjPtr; /* Cached stdout channel Tcl_Obj */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; @@ -35,11 +35,12 @@ /* * Static functions for this file: */ static void FinalizeIOCmdTSD(ClientData clientData); -static Tcl_TcpAcceptProc AcceptCallbackProc; +static void AcceptCallbackProc(ClientData callbackData, + Tcl_Channel chan, char *address, int port); static int ChanPendingObjCmd(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int ChanTruncateObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, @@ -111,10 +112,11 @@ Tcl_Obj *string; /* String to write. */ Tcl_Obj *chanObjPtr = NULL; /* channel object. */ int newline; /* Add a newline at end? */ int result; /* Result of puts operation. */ int mode; /* Mode in which channel is opened. */ + ThreadSpecificData *tsdPtr; switch (objc) { case 2: /* [puts $x] */ string = objv[1]; newline = 1; @@ -135,20 +137,33 @@ newline = 0; if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) { chanObjPtr = objv[2]; string = objv[3]; break; +#if TCL_MAJOR_VERSION < 9 + } else if (strcmp(TclGetString(objv[3]), "nonewline") == 0) { + /* + * The code below provides backwards compatibility with an old + * form of the command that is no longer recommended or + * documented. See also [Bug #3151675]. Will be removed in Tcl 9, + * maybe even earlier. + */ + + chanObjPtr = objv[1]; + string = objv[2]; + break; +#endif } /* Fall through */ default: /* [puts] or * [puts some bad number of arguments...] */ Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channelId? string"); return TCL_ERROR; } if (chanObjPtr == NULL) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + tsdPtr = TCL_TSD_INIT(&dataKey); if (!tsdPtr->initialized) { tsdPtr->initialized = 1; TclNewLiteralStringObj(tsdPtr->stdoutObjPtr, "stdout"); Tcl_IncrRefCount(tsdPtr->stdoutObjPtr); @@ -166,16 +181,16 @@ return TCL_ERROR; } TclChannelPreserve(chan); result = Tcl_WriteObj(chan, string); - if (result == -1) { + if (result < 0) { goto error; } if (newline != 0) { result = Tcl_WriteChars(chan, "\n", 1); - if (result == -1) { + if (result < 0) { goto error; } } TclChannelRelease(chan); return TCL_OK; @@ -424,15 +439,29 @@ toRead = -1; if (i < objc) { if ((TclGetIntFromObj(interp, objv[i], &toRead) != TCL_OK) || (toRead < 0)) { +#if TCL_MAJOR_VERSION < 9 + /* + * The code below provides backwards compatibility with an old + * form of the command that is no longer recommended or + * documented. See also [Bug #3151675]. Will be removed in Tcl 9, + * maybe even earlier. + */ + + if (strcmp(TclGetString(objv[i]), "nonewline") != 0) { +#endif Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected non-negative integer but got \"%s\"", TclGetString(objv[i]))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL); return TCL_ERROR; +#if TCL_MAJOR_VERSION < 9 + } + newline = 1; +#endif } } resultPtr = Tcl_NewObj(); Tcl_IncrRefCount(resultPtr); @@ -460,11 +489,11 @@ * If requested, remove the last newline in the channel if at EOF. */ if ((charactersRead > 0) && (newline != 0)) { const char *result; - size_t length; + int length; result = TclGetStringFromObj(resultPtr, &length); if (result[length - 1] == '\n') { Tcl_SetObjLength(resultPtr, length - 1); } @@ -530,11 +559,11 @@ mode = modeArray[optionIndex]; } TclChannelPreserve(chan); result = Tcl_Seek(chan, offset, mode); - if (result == -1) { + if (result == Tcl_LongAsWide(-1)) { /* * TIP #219. * Capture error messages put by the driver into the bypass area and * put them into the regular interpreter result. Fall back to the * regular message if nothing was found in the bypass. @@ -682,11 +711,11 @@ } /* * Special handling is needed if and only if the channel mode supports * more than the direction to close. Because if the close the last - * direction suppported we can and will go through the regular + * direction supported we can and will go through the regular * process. */ if ((Tcl_GetChannelMode(chan) & (TCL_CLOSE_READ|TCL_CLOSE_WRITE)) != dir) { @@ -706,11 +735,11 @@ * a terminating newline. */ Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); const char *string; - size_t len; + int len; if (Tcl_IsShared(resultPtr)) { resultPtr = Tcl_DuplicateObj(resultPtr); Tcl_SetObjResult(interp, resultPtr); } @@ -868,12 +897,12 @@ Tcl_Obj *resultPtr; const char **argv; /* An array for the string arguments. Stored * on the _Tcl_ stack. */ const char *string; Tcl_Channel chan; - int argc, background, i, index, keepNewline, result, skip, ignoreStderr; - size_t length; + int argc, background, i, index, keepNewline, result, skip, length; + int ignoreStderr; static const char *const options[] = { "-ignorestderr", "-keepnewline", "--", NULL }; enum options { EXEC_IGNORESTDERR, EXEC_KEEPNEWLINE, EXEC_LAST @@ -923,11 +952,11 @@ * Create the string argument array "argv". Make sure argv is large enough * to hold the argc arguments plus 1 extra for the zero end-of-argv word. */ argc = objc - skip; - argv = TclStackAlloc(interp, (argc + 1) * sizeof(char *)); + argv = TclStackAlloc(interp, (unsigned)(argc + 1) * sizeof(char *)); /* * Copy the string conversions of each (post option) object into the * argument vector. */ @@ -962,11 +991,11 @@ return TCL_OK; } resultPtr = Tcl_NewObj(); if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) { - if (Tcl_ReadChars(chan, resultPtr, -1, 0) == TCL_IO_FAILURE) { + if (Tcl_ReadChars(chan, resultPtr, -1, 0) < 0) { /* * TIP #219. * Capture error messages put by the driver into the bypass area * and put them into the regular interpreter result. Fall back to * the regular message if nothing was found in the bypass. @@ -1163,11 +1192,11 @@ chan = Tcl_OpenCommandChannel(interp, cmdObjc, cmdArgv, flags); if (binary && chan) { Tcl_SetChannelOption(interp, chan, "-translation", "binary"); } } - Tcl_Free((void *)cmdArgv); + ckfree(cmdArgv); } if (chan == NULL) { return TCL_ERROR; } Tcl_RegisterChannel(interp, chan); @@ -1212,11 +1241,11 @@ AcceptCallback *acceptCallbackPtr = Tcl_GetHashValue(hPtr); acceptCallbackPtr->interp = NULL; } Tcl_DeleteHashTable(hTblPtr); - Tcl_Free(hTblPtr); + ckfree(hTblPtr); } /* *---------------------------------------------------------------------- * @@ -1252,11 +1281,11 @@ int isNew; /* Is the entry new? */ hTblPtr = Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL); if (hTblPtr == NULL) { - hTblPtr = Tcl_Alloc(sizeof(Tcl_HashTable)); + hTblPtr = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS); Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks", TcpAcceptCallbacksDeleteProc, hTblPtr); } @@ -1342,38 +1371,30 @@ * away, this is signalled by setting the interp field of the callback * data to NULL. */ if (acceptCallbackPtr->interp != NULL) { + char portBuf[TCL_INTEGER_SPACE]; + char *script = acceptCallbackPtr->script; Tcl_Interp *interp = acceptCallbackPtr->interp; - Tcl_Obj *script, *objv[2]; - int result = TCL_OK; - - objv[0] = acceptCallbackPtr->script; - objv[1] = Tcl_NewListObj(3, NULL); - Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewStringObj( - Tcl_GetChannelName(chan), -1)); - Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewStringObj(address, -1)); - Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewIntObj(port)); - - script = Tcl_ConcatObj(2, objv); - Tcl_IncrRefCount(script); - Tcl_DecrRefCount(objv[1]); - + int result; + + Tcl_Preserve(script); Tcl_Preserve(interp); + + TclFormatInt(portBuf, port); Tcl_RegisterChannel(interp, chan); /* * Artificially bump the refcount to protect the channel from being * deleted while the script is being evaluated. */ Tcl_RegisterChannel(NULL, chan); - result = Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT|TCL_EVAL_GLOBAL); - Tcl_DecrRefCount(script); - + result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan), + " ", address, " ", portBuf, NULL); if (result != TCL_OK) { Tcl_BackgroundException(interp, result); Tcl_UnregisterChannel(interp, chan); } @@ -1383,10 +1404,11 @@ */ Tcl_UnregisterChannel(NULL, chan); Tcl_Release(interp); + Tcl_Release(script); } else { /* * The interpreter has been deleted, so there is no useful way to use * the client socket - just close it. */ @@ -1426,12 +1448,12 @@ if (acceptCallbackPtr->interp != NULL) { UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp, acceptCallbackPtr); } - Tcl_DecrRefCount(acceptCallbackPtr->script); - Tcl_Free(acceptCallbackPtr); + Tcl_EventuallyFree(acceptCallbackPtr->script, TCL_DYNAMIC); + ckfree(acceptCallbackPtr); } /* *---------------------------------------------------------------------- * @@ -1455,30 +1477,25 @@ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { static const char *const socketOptions[] = { - "-async", "-myaddr", "-myport", "-reuseaddr", "-reuseport", "-server", - NULL + "-async", "-myaddr", "-myport", "-server", NULL }; enum socketOptions { - SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_REUSEADDR, SKT_REUSEPORT, - SKT_SERVER + SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER }; - int optionIndex, a, server = 0, myport = 0, async = 0, reusep = -1, - reusea = -1; - unsigned int flags = 0; - const char *host, *port, *myaddr = NULL; - Tcl_Obj *script = NULL; + int optionIndex, a, server = 0, port, myport = 0, async = 0; + const char *host, *script = NULL, *myaddr = NULL; Tcl_Channel chan; if (TclpHasSockets(interp) != TCL_OK) { return TCL_ERROR; } for (a = 1; a < objc; a++) { - const char *arg = TclGetString(objv[a]); + const char *arg = Tcl_GetString(objv[a]); if (arg[0] != '-') { break; } if (Tcl_GetIndexFromObj(interp, objv[a], socketOptions, "option", @@ -1529,33 +1546,11 @@ if (a >= objc) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "no argument given for -server option", -1)); return TCL_ERROR; } - script = objv[a]; - break; - case SKT_REUSEADDR: - a++; - if (a >= objc) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "no argument given for -reuseaddr option", -1)); - return TCL_ERROR; - } - if (Tcl_GetBooleanFromObj(interp, objv[a], &reusea) != TCL_OK) { - return TCL_ERROR; - } - break; - case SKT_REUSEPORT: - a++; - if (a >= objc) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "no argument given for -reuseport option", -1)); - return TCL_ERROR; - } - if (Tcl_GetBooleanFromObj(interp, objv[a], &reusep) != TCL_OK) { - return TCL_ERROR; - } + script = TclGetString(objv[a]); break; default: Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions"); } } @@ -1576,68 +1571,37 @@ iPtr = (Interp *) interp; Tcl_WrongNumArgs(interp, 1, objv, "?-myaddr addr? ?-myport myport? ?-async? host port"); iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS; Tcl_WrongNumArgs(interp, 1, objv, - "-server command ?-reuseaddr boolean? ?-reuseport boolean? " - "?-myaddr addr? port"); - return TCL_ERROR; - } - - if (!server && (reusea != -1 || reusep != -1)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "options -reuseaddr and -reuseport are only valid for servers", - -1)); - return TCL_ERROR; - } - - /* - * Set the options to their default value if the user didn't override - * their value. - */ - - if (reusep == -1) { - reusep = 0; - } - if (reusea == -1) { - reusea = 1; - } - - /* - * Build the bitset with the flags values. - */ - - if (reusea) { - flags |= TCL_TCPSERVER_REUSEADDR; - } - if (reusep) { - flags |= TCL_TCPSERVER_REUSEPORT; - } - - /* - * All the arguments should have been parsed by now, 'a' points to the - * last one, the port number. - */ - - if (a != objc-1) { + "-server command ?-myaddr addr? port"); + return TCL_ERROR; + } + + if (a == objc-1) { + if (TclSockGetPort(interp, TclGetString(objv[a]), "tcp", + &port) != TCL_OK) { + return TCL_ERROR; + } + } else { goto wrongNumArgs; } - port = TclGetString(objv[a]); - if (server) { - AcceptCallback *acceptCallbackPtr = Tcl_Alloc(sizeof(AcceptCallback)); + AcceptCallback *acceptCallbackPtr = + ckalloc(sizeof(AcceptCallback)); + unsigned len = strlen(script) + 1; + char *copyScript = ckalloc(len); - Tcl_IncrRefCount(script); - acceptCallbackPtr->script = script; + memcpy(copyScript, script, len); + acceptCallbackPtr->script = copyScript; acceptCallbackPtr->interp = interp; - - chan = Tcl_OpenTcpServerEx(interp, port, host, flags, - AcceptCallbackProc, acceptCallbackPtr); + chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc, + acceptCallbackPtr); if (chan == NULL) { - Tcl_DecrRefCount(script); - Tcl_Free(acceptCallbackPtr); + ckfree(copyScript); + ckfree(acceptCallbackPtr); return TCL_ERROR; } /* * Register with the interpreter to let us know when the interpreter @@ -1654,17 +1618,11 @@ * be informed when the interpreter is deleted. */ Tcl_CreateCloseHandler(chan, TcpServerCloseProc, acceptCallbackPtr); } else { - int portNum; - - if (TclSockGetPort(interp, port, "tcp", &portNum) != TCL_OK) { - return TCL_ERROR; - } - - chan = Tcl_OpenTcpClient(interp, portNum, host, myaddr, myport, async); + chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async); if (chan == NULL) { return TCL_ERROR; } } @@ -1884,11 +1842,11 @@ /* * User wants to truncate to the current file position. */ length = Tcl_Tell(chan); - if (length == -1) { + if (length == Tcl_WideAsLong(-1)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "could not determine current location in \"%s\": %s", TclGetString(objv[1]), Tcl_PosixError(interp))); return TCL_ERROR; } Index: generic/tclIOGT.c ================================================================== --- generic/tclIOGT.c +++ generic/tclIOGT.c @@ -21,10 +21,12 @@ static int TransformBlockModeProc(ClientData instanceData, int mode); static int TransformCloseProc(ClientData instanceData, Tcl_Interp *interp); +static int TransformClose2Proc(ClientData instanceData, + Tcl_Interp *interp, int flags); static int TransformInputProc(ClientData instanceData, char *buf, int toRead, int *errorCodePtr); static int TransformOutputProc(ClientData instanceData, const char *buf, int toWrite, int *errorCodePtr); static int TransformSeekProc(ClientData instanceData, long offset, @@ -125,11 +127,11 @@ TransformSeekProc, /* Seek proc. */ TransformSetOptionProc, /* Set option proc. */ TransformGetOptionProc, /* Get option proc. */ TransformWatchProc, /* Initialize notifier. */ TransformGetFileHandleProc, /* Get OS handles out of channel. */ - NULL, /* close2proc */ + TransformClose2Proc, /* close2proc */ TransformBlockModeProc, /* Set blocking/nonblocking mode.*/ NULL, /* Flush proc. */ TransformNotifyProc, /* Handling of events bubbling up. */ TransformWideSeekProc, /* Wide seek proc. */ NULL, /* Thread action. */ @@ -209,11 +211,11 @@ Tcl_Obj *command; /* Tcl code to execute for a buffer */ ResultBuffer result; /* Internal buffer used to store the result of * a transformation of incoming data. Also * serves as buffer of all data not yet * consumed by the reader. */ - size_t refCount; + int refCount; }; static void PreserveData( TransformChannelData *dataPtr) @@ -223,16 +225,16 @@ static void ReleaseData( TransformChannelData *dataPtr) { - if (dataPtr->refCount-- > 1) { + if (--dataPtr->refCount) { return; } ResultClear(&dataPtr->result); Tcl_DecrRefCount(dataPtr->command); - Tcl_Free(dataPtr); + ckfree(dataPtr); } /* *---------------------------------------------------------------------- * @@ -285,11 +287,11 @@ * Now initialize the transformation state and stack it upon the specified * channel. One of the necessary things to do is to retrieve the blocking * regime of the underlying channel and to use the same for us too. */ - dataPtr = Tcl_Alloc(sizeof(TransformChannelData)); + dataPtr = (TransformChannelData *)ckalloc(sizeof(TransformChannelData)); dataPtr->refCount = 1; Tcl_DStringInit(&ds); Tcl_GetChannelOption(interp, chan, "-blocking", &ds); dataPtr->readIsFlushed = 0; @@ -376,11 +378,11 @@ int preserve) /* Flag. If true the procedure will preserve * the result state of all accessed * interpreters. */ { Tcl_Obj *resObj; /* See below, switch (transmit). */ - size_t resLen = 0; + int resLen; unsigned char *resBuf; Tcl_InterpState state = NULL; int res = TCL_OK; Tcl_Obj *command = TclListObjCopy(NULL, dataPtr->command); Tcl_Interp *eval = dataPtr->interp; @@ -441,27 +443,27 @@ case TRANSMIT_DOWN: if (dataPtr->self == NULL) { break; } resObj = Tcl_GetObjResult(eval); - resBuf = TclGetByteArrayFromObj(resObj, &resLen); + resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen); Tcl_WriteRaw(Tcl_GetStackedChannel(dataPtr->self), (char *) resBuf, resLen); break; case TRANSMIT_SELF: if (dataPtr->self == NULL) { break; } resObj = Tcl_GetObjResult(eval); - resBuf = TclGetByteArrayFromObj(resObj, &resLen); + resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen); Tcl_WriteRaw(dataPtr->self, (char *) resBuf, resLen); break; case TRANSMIT_IBUF: resObj = Tcl_GetObjResult(eval); - resBuf = TclGetByteArrayFromObj(resObj, &resLen); + resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen); ResultAdd(&dataPtr->result, resBuf, resLen); break; case TRANSMIT_NUM: /* @@ -501,11 +503,11 @@ static int TransformBlockModeProc( ClientData instanceData, /* State of transformation. */ int mode) /* New blocking mode. */ { - TransformChannelData *dataPtr = instanceData; + TransformChannelData *dataPtr = (TransformChannelData *)instanceData; if (mode == TCL_MODE_NONBLOCKING) { dataPtr->flags |= CHANNEL_ASYNC; } else { dataPtr->flags &= ~CHANNEL_ASYNC; @@ -514,11 +516,11 @@ } /* *---------------------------------------------------------------------- * - * TransformCloseProc -- + * TransformCloseProc/TransformClose2Proc -- * * Trap handler. Called by the generic IO system during destruction of * the transformation channel. * * Side effects: @@ -590,10 +592,22 @@ Tcl_Release(dataPtr->self); dataPtr->self = NULL; ReleaseData(dataPtr); return TCL_OK; } + +static int +TransformClose2Proc( + ClientData instanceData, + Tcl_Interp *interp, + int flags) +{ + if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) == 0) { + return TransformCloseProc(instanceData, interp); + } + return EINVAL; +} /* *---------------------------------------------------------------------- * * TransformInputProc -- @@ -614,11 +628,11 @@ ClientData instanceData, char *buf, int toRead, int *errorCodePtr) { - TransformChannelData *dataPtr = instanceData; + TransformChannelData *dataPtr = (TransformChannelData *)instanceData; int gotBytes, read, copied; Tcl_Channel downChan; /* * Should assert(dataPtr->mode & TCL_READABLE); @@ -781,11 +795,11 @@ ClientData instanceData, const char *buf, int toWrite, int *errorCodePtr) { - TransformChannelData *dataPtr = instanceData; + TransformChannelData *dataPtr = (TransformChannelData *)instanceData; /* * Should assert(dataPtr->mode & TCL_WRITABLE); */ @@ -833,11 +847,11 @@ ClientData instanceData, /* The channel to manipulate. */ long offset, /* Size of movement. */ int mode, /* How to move. */ int *errorCodePtr) /* Location of error flag. */ { - TransformChannelData *dataPtr = instanceData; + TransformChannelData *dataPtr = (TransformChannelData *)instanceData; Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self); const Tcl_ChannelType *parentType = Tcl_GetChannelType(parent); Tcl_DriverSeekProc *parentSeekProc = Tcl_ChannelSeekProc(parentType); if ((offset == 0) && (mode == SEEK_CUR)) { @@ -900,11 +914,11 @@ ClientData instanceData, /* The channel to manipulate. */ Tcl_WideInt offset, /* Size of movement. */ int mode, /* How to move. */ int *errorCodePtr) /* Location of error flag. */ { - TransformChannelData *dataPtr = instanceData; + TransformChannelData *dataPtr = (TransformChannelData *)instanceData; Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self); const Tcl_ChannelType *parentType = Tcl_GetChannelType(parent); Tcl_DriverSeekProc *parentSeekProc = Tcl_ChannelSeekProc(parentType); Tcl_DriverWideSeekProc *parentWideSeekProc = Tcl_ChannelWideSeekProc(parentType); @@ -918,11 +932,12 @@ if (parentWideSeekProc != NULL) { return parentWideSeekProc(parentData, offset, mode, errorCodePtr); } - return parentSeekProc(parentData, 0, mode, errorCodePtr); + return Tcl_LongAsWide(parentSeekProc(parentData, 0, mode, + errorCodePtr)); } /* * It is a real request to change the position. Flush all data waiting for * output and discard everything in the input buffers. Then pass the @@ -958,17 +973,17 @@ * whether we are losing information in truncating the bits of the * offset). Luckily, there's a defined error for what happens when trying * to go out of the representable range. */ - if (offsetLONG_MAX) { + if (offsetTcl_LongAsWide(LONG_MAX)) { *errorCodePtr = EOVERFLOW; - return -1; + return Tcl_LongAsWide(-1); } - return parentSeekProc(parentData, offset, - mode, errorCodePtr); + return Tcl_LongAsWide(parentSeekProc(parentData, Tcl_WideAsLong(offset), + mode, errorCodePtr)); } /* *---------------------------------------------------------------------- * @@ -992,11 +1007,11 @@ ClientData instanceData, Tcl_Interp *interp, const char *optionName, const char *value) { - TransformChannelData *dataPtr = instanceData; + TransformChannelData *dataPtr = (TransformChannelData *)instanceData; Tcl_Channel downChan = Tcl_GetStackedChannel(dataPtr->self); Tcl_DriverSetOptionProc *setOptionProc; setOptionProc = Tcl_ChannelSetOptionProc(Tcl_GetChannelType(downChan)); if (setOptionProc == NULL) { @@ -1030,11 +1045,11 @@ ClientData instanceData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr) { - TransformChannelData *dataPtr = instanceData; + TransformChannelData *dataPtr = (TransformChannelData *)instanceData; Tcl_Channel downChan = Tcl_GetStackedChannel(dataPtr->self); Tcl_DriverGetOptionProc *getOptionProc; getOptionProc = Tcl_ChannelGetOptionProc(Tcl_GetChannelType(downChan)); if (getOptionProc != NULL) { @@ -1076,11 +1091,11 @@ static void TransformWatchProc( ClientData instanceData, /* Channel to watch. */ int mask) /* Events of interest. */ { - TransformChannelData *dataPtr = instanceData; + TransformChannelData *dataPtr = (TransformChannelData *)instanceData; Tcl_Channel downChan; /* * The caller expressed interest in events occuring for this channel. We * are forwarding the call to the underlying channel now. @@ -1155,11 +1170,11 @@ TransformGetFileHandleProc( ClientData instanceData, /* Channel to query. */ int direction, /* Direction of interest. */ ClientData *handlePtr) /* Place to store the handle into. */ { - TransformChannelData *dataPtr = instanceData; + TransformChannelData *dataPtr = (TransformChannelData *)instanceData; /* * Return the handle belonging to parent channel. IOW, pass the request * down and the result up. */ @@ -1189,11 +1204,11 @@ TransformNotifyProc( ClientData clientData, /* The state of the notified * transformation. */ int mask) /* The mask of occuring events. */ { - TransformChannelData *dataPtr = clientData; + TransformChannelData *dataPtr = (TransformChannelData *)clientData; /* * An event occured in the underlying channel. This transformation doesn't * process such events thus returns the incoming mask unchanged. */ @@ -1232,11 +1247,11 @@ static void TransformChannelHandlerTimer( ClientData clientData) /* Transformation to query. */ { - TransformChannelData *dataPtr = clientData; + TransformChannelData *dataPtr = (TransformChannelData *)clientData; dataPtr->timer = NULL; if (!(dataPtr->watchMask&TCL_READABLE) || ResultEmpty(&dataPtr->result)) { /* * The timer fired, but either is there no (more) interest in the @@ -1270,11 +1285,11 @@ ResultBuffer *r) /* Reference to the buffer to clear out. */ { r->used = 0; if (r->allocated) { - Tcl_Free(r->buf); + ckfree(r->buf); r->buf = NULL; r->allocated = 0; } } @@ -1414,14 +1429,14 @@ * Extension of the internal buffer is required. */ if (r->allocated == 0) { r->allocated = toWrite + INCREMENT; - r->buf = Tcl_Alloc(r->allocated); + r->buf = (unsigned char *)ckalloc(r->allocated); } else { r->allocated += toWrite + INCREMENT; - r->buf = Tcl_Realloc(r->buf, r->allocated); + r->buf = (unsigned char *)ckrealloc(r->buf, r->allocated); } } /* * Now we may copy the data. Index: generic/tclIORChan.c ================================================================== --- generic/tclIORChan.c +++ generic/tclIORChan.c @@ -31,17 +31,19 @@ * Signatures of all functions used in the C layer of the reflection. */ static int ReflectClose(ClientData clientData, Tcl_Interp *interp); +static int ReflectClose2(ClientData clientData, + Tcl_Interp *interp, int flags); static int ReflectInput(ClientData clientData, char *buf, int toRead, int *errorCodePtr); static int ReflectOutput(ClientData clientData, const char *buf, int toWrite, int *errorCodePtr); static void ReflectWatch(ClientData clientData, int mask); static int ReflectBlock(ClientData clientData, int mode); -#if TCL_THREADS +#ifdef TCL_THREADS static void ReflectThread(ClientData clientData, int action); static int ReflectEventRun(Tcl_Event *ev, int flags); static int ReflectEventDelete(Tcl_Event *ev, ClientData cd); #endif static Tcl_WideInt ReflectSeekWide(ClientData clientData, @@ -52,12 +54,10 @@ Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr); static int ReflectSetOption(ClientData clientData, Tcl_Interp *interp, const char *optionName, const char *newValue); -static void TimerRunRead(ClientData clientData); -static void TimerRunWrite(ClientData clientData); /* * The C layer channel type/driver definition used by the reflection. This is * a version 3 structure. */ @@ -71,16 +71,16 @@ ReflectSeek, /* Move location of access point. NULL'able */ ReflectSetOption, /* Set options. NULL'able */ ReflectGetOption, /* Get options. NULL'able */ ReflectWatch, /* Initialize notifier */ NULL, /* Get OS handle from the channel. NULL'able */ - NULL, /* No close2 support. NULL'able */ + ReflectClose2, /* No close2 support. NULL'able */ ReflectBlock, /* Set blocking/nonblocking. NULL'able */ NULL, /* Flush channel. Not used by core. NULL'able */ NULL, /* Handle events. NULL'able */ ReflectSeekWide, /* Move access point (64 bit). NULL'able */ -#if TCL_THREADS +#ifdef TCL_THREADS ReflectThread, /* thread action, tracking owner */ #else NULL, /* thread action */ #endif NULL /* truncate */ @@ -97,11 +97,11 @@ * Tcl level part of the channel. NULL here * signals the channel is dead because the * interpreter/thread containing its Tcl * command is gone. */ -#if TCL_THREADS +#ifdef TCL_THREADS Tcl_ThreadId thread; /* Thread the 'interp' belongs to. == Handler thread */ Tcl_ThreadId owner; /* Thread owning the structure. == Channel thread */ #endif Tcl_Obj *cmd; /* Callback command prefix */ Tcl_Obj *methods; /* Methods to append to command prefix */ @@ -112,33 +112,24 @@ * in. */ int dead; /* Boolean signal that some operations * should no longer be attempted. */ - Tcl_TimerToken readTimer; /* - A token for the timer that is scheduled in - order to call Tcl_NotifyChannel when the - channel is readable - */ - Tcl_TimerToken writeTimer; /* - A token for the timer that is scheduled in - order to call Tcl_NotifyChannel when the - channel is writable - */ - /* * Note regarding the usage of timers. * * Most channel implementations need a timer in the C level to ensure that * data in buffers is flushed out through the generation of fake file * events. * * See 'rechan', 'memchan', etc. * - * A timer is used here as well in order to ensure at least on pass through - * the event loop when a channel becomes ready. See issues 67a5eabbd3d1 and - * ef28eb1f1516. + * Here this is _not_ required. Interest in events is posted to the Tcl + * level via 'watch'. And posting of events is possible from the Tcl level + * as well, via 'chan postevent'. This means that the generation of all + * events, fake or not, timer based or not, is completely in the hands of + * the Tcl level. Therefore no timer here. */ } ReflectedChannel; /* * Structure of the table maping from channel handles to reflected @@ -210,11 +201,11 @@ #define IMPLIES(a,b) ((!(a)) || (b)) #define NEGIMPL(a,b) #define HAS(x,f) (x & FLAG(f)) -#if TCL_THREADS +#ifdef TCL_THREADS /* * Thread specific types and structures. * * We are here essentially creating a very specific implementation of 'thread * send'. @@ -245,11 +236,11 @@ * forward an operation code, the argument details, and reference to results. * The command is assembled in the CT and belongs fully to that thread. No * sharing problems. */ -typedef struct { +typedef struct ForwardParamBase { int code; /* O: Ok/Fail of the cmd handler */ char *msgStr; /* O: Error message for handler failure */ int mustFree; /* O: True if msgStr is allocated, false if * otherwise (static). */ } ForwardParamBase; @@ -261,11 +252,11 @@ */ struct ForwardParamInput { ForwardParamBase base; /* "Supertype". MUST COME FIRST. */ char *buf; /* O: Where to store the read bytes */ - size_t toRead; /* I: #bytes to read, + int toRead; /* I: #bytes to read, * O: #bytes actually read */ }; struct ForwardParamOutput { ForwardParamBase base; /* "Supertype". MUST COME FIRST. */ const char *buf; /* I: Where the bytes to write come from */ @@ -320,11 +311,11 @@ /* * General event structure, with reference to operation specific data. */ -typedef struct { +typedef struct ForwardingEvent { Tcl_Event event; /* Basic event data, has to be first item */ ForwardingResult *resultPtr; ForwardedOperation op; /* Forwarded driver operation */ ReflectedChannel *rcPtr; /* Channel instance */ ForwardParam *param; /* Packaged arguments and return values, a @@ -357,11 +348,11 @@ ForwardingResult *prevPtr, *nextPtr; /* Links into the list of pending forwarded * results. */ }; -typedef struct { +typedef struct ThreadSpecificData { /* * Table of all reflected channels owned by this thread. This is the * per-thread version of the per-interpreter map. */ @@ -394,11 +385,11 @@ static int ForwardProc(Tcl_Event *evPtr, int mask); static void SrcExitProc(ClientData clientData); #define FreeReceivedError(p) \ if ((p)->base.mustFree) { \ - Tcl_Free((p)->base.msgStr); \ + ckfree((p)->base.msgStr); \ } #define PassReceivedErrorInterp(i,p) \ if ((i) != NULL) { \ Tcl_SetChannelErrorInterp((i), \ Tcl_NewStringObj((p)->base.msgStr, -1)); \ @@ -460,11 +451,11 @@ static const char *msg_read_toomuch = "{read delivered more than requested}"; static const char *msg_write_toomuch = "{write wrote more than requested}"; static const char *msg_write_nothing = "{write wrote nothing}"; static const char *msg_seek_beforestart = "{Tried to seek before origin}"; -#if TCL_THREADS +#ifdef TCL_THREADS static const char *msg_send_originlost = "{Channel thread lost}"; #endif /* TCL_THREADS */ static const char *msg_send_dstlost = "{Owner lost}"; static const char *msg_dstlost = "-code 1 -level 0 -errorcode NONE -errorinfo {} -errorline 1 {Owner lost}"; @@ -490,11 +481,11 @@ *---------------------------------------------------------------------- */ int TclChanCreateObjCmd( - ClientData clientData, + ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { ReflectedChannel *rcPtr; /* Instance data of the new channel */ @@ -516,10 +507,11 @@ ReflectedChannelMap *rcmPtr; /* Map of reflected channels with handlers in * this interp. */ Tcl_HashEntry *hPtr; /* Entry in the above map */ int isNew; /* Placeholder. */ + (void)dummy; /* * Syntax: chan create MODE CMDPREFIX * [0] [1] [2] [3] * @@ -602,11 +594,11 @@ */ if (Tcl_ListObjGetElements(NULL, resObj, &listc, &listv) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s initialize\" returned non-list: %s", - TclGetString(cmdObj), TclGetString(resObj))); + Tcl_GetString(cmdObj), Tcl_GetString(resObj))); Tcl_DecrRefCount(resObj); goto error; } methods = 0; @@ -628,39 +620,39 @@ Tcl_DecrRefCount(resObj); if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" does not support all required methods", - TclGetString(cmdObj))); + Tcl_GetString(cmdObj))); goto error; } if ((mode & TCL_READABLE) && !HAS(methods, METH_READ)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" lacks a \"read\" method", - TclGetString(cmdObj))); + Tcl_GetString(cmdObj))); goto error; } if ((mode & TCL_WRITABLE) && !HAS(methods, METH_WRITE)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" lacks a \"write\" method", - TclGetString(cmdObj))); + Tcl_GetString(cmdObj))); goto error; } if (!IMPLIES(HAS(methods, METH_CGET), HAS(methods, METH_CGETALL))) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" supports \"cget\" but not \"cgetall\"", - TclGetString(cmdObj))); + Tcl_GetString(cmdObj))); goto error; } if (!IMPLIES(HAS(methods, METH_CGETALL), HAS(methods, METH_CGET))) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" supports \"cgetall\" but not \"cget\"", - TclGetString(cmdObj))); + Tcl_GetString(cmdObj))); goto error; } Tcl_ResetResult(interp); @@ -679,11 +671,11 @@ * Some of the nullable methods are not supported. We clone the * channel type, null the associated C functions, and use the result * as the actual channel type. */ - Tcl_ChannelType *clonePtr = Tcl_Alloc(sizeof(Tcl_ChannelType)); + Tcl_ChannelType *clonePtr = (Tcl_ChannelType *)ckalloc(sizeof(Tcl_ChannelType)); memcpy(clonePtr, &tclRChannelType, sizeof(Tcl_ChannelType)); if (!(methods & FLAG(METH_CONFIGURE))) { clonePtr->setOptionProc = NULL; @@ -715,11 +707,11 @@ &isNew); if (!isNew && chanPtr != Tcl_GetHashValue(hPtr)) { Tcl_Panic("TclChanCreateObjCmd: duplicate channel names"); } Tcl_SetHashValue(hPtr, chan); -#if TCL_THREADS +#ifdef TCL_THREADS rcmPtr = GetThreadReflectedChannelMap(); hPtr = Tcl_CreateHashEntry(&rcmPtr->map, chanPtr->state->channelName, &isNew); Tcl_SetHashValue(hPtr, chan); #endif @@ -734,11 +726,11 @@ error: Tcl_DecrRefCount(rcPtr->name); Tcl_DecrRefCount(rcPtr->methods); Tcl_DecrRefCount(rcPtr->cmd); - Tcl_Free(rcPtr); + ckfree((char*) rcPtr); return TCL_ERROR; #undef MODE #undef CMD } @@ -759,12 +751,12 @@ * latter implies that arbitrary side effects are possible. * *---------------------------------------------------------------------- */ -#if TCL_THREADS -typedef struct { +#ifdef TCL_THREADS +typedef struct ReflectEvent { Tcl_Event header; ReflectedChannel *rcPtr; int events; } ReflectEvent; @@ -779,10 +771,11 @@ * deleted. See ReflectClose() for the Tcl_DeleteEvents() calls * accomplishing that. */ ReflectEvent *e = (ReflectEvent *) ev; + (void)flags; Tcl_NotifyChannel(e->rcPtr->chan, e->events); return 1; } @@ -807,11 +800,11 @@ } #endif int TclChanPostEventObjCmd( - ClientData clientData, + ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { /* @@ -836,10 +829,11 @@ ReflectedChannel *rcPtr; /* Associated instance data */ int events; /* Mask of events to post */ ReflectedChannelMap *rcmPtr;/* Map of reflected channels with handlers in * this interp. */ Tcl_HashEntry *hPtr; /* Entry in the above map */ + (void)dummy; /* * Number of arguments... */ @@ -880,11 +874,11 @@ * We keep the old checks for both, for paranioa, but abort now instead of * throwing errors, as failure now means that our internal datastructures * have gone seriously haywire. */ - chan = Tcl_GetHashValue(hPtr); + chan = (Tcl_Channel)Tcl_GetHashValue(hPtr); chanTypePtr = Tcl_GetChannelType(chan); /* * We use a function referenced by the channel type as our cookie to * detect calls to non-reflecting channels. The channel type itself is not @@ -896,11 +890,11 @@ if (chanTypePtr->watchProc != &ReflectWatch) { Tcl_Panic("TclChanPostEventObjCmd: channel is not a reflected channel"); } - rcPtr = Tcl_GetChannelInstanceData(chan); + rcPtr = (ReflectedChannel *)Tcl_GetChannelInstanceData(chan); if (rcPtr->interp != interp) { Tcl_Panic("TclChanPostEventObjCmd: postevent accepted for call from outside interpreter"); } @@ -926,28 +920,17 @@ /* * We have the channel and the events to post. */ -#if TCL_THREADS +#ifdef TCL_THREADS if (rcPtr->owner == rcPtr->thread) { #endif - if (events & TCL_READABLE) { - if (rcPtr->readTimer == NULL) { - rcPtr->readTimer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, - TimerRunRead, rcPtr); - } - } - if (events & TCL_WRITABLE) { - if (rcPtr->writeTimer == NULL) { - rcPtr->writeTimer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, - TimerRunWrite, rcPtr); - } - } -#if TCL_THREADS + Tcl_NotifyChannel(chan, events); +#ifdef TCL_THREADS } else { - ReflectEvent *ev = Tcl_Alloc(sizeof(ReflectEvent)); + ReflectEvent *ev = (ReflectEvent *)ckalloc(sizeof(ReflectEvent)); ev->header.proc = ReflectEventRun; ev->events = events; ev->rcPtr = rcPtr; @@ -987,28 +970,10 @@ return TCL_OK; #undef CHAN #undef EVENT } - -static void -TimerRunRead( - ClientData clientData) -{ - ReflectedChannel *rcPtr = clientData; - rcPtr->readTimer = NULL; - Tcl_NotifyChannel(rcPtr->chan, TCL_READABLE); -} - -static void -TimerRunWrite( - ClientData clientData) -{ - ReflectedChannel *rcPtr = clientData; - rcPtr->writeTimer = NULL; - Tcl_NotifyChannel(rcPtr->chan, TCL_WRITABLE); -} /* * Channel error message marshalling utilities. */ @@ -1131,11 +1096,11 @@ */ /* *---------------------------------------------------------------------- * - * ReflectClose -- + * ReflectClose/ReflectClose2 -- * * This function is invoked when the channel is closed, to delete the * driver specific instance data. * * Results: @@ -1150,11 +1115,11 @@ static int ReflectClose( ClientData clientData, Tcl_Interp *interp) { - ReflectedChannel *rcPtr = clientData; + ReflectedChannel *rcPtr = (ReflectedChannel *)clientData; int result; /* Result code for 'close' */ Tcl_Obj *resObj; /* Result data for 'close' */ ReflectedChannelMap *rcmPtr;/* Map of reflected channels with handlers in * this interp */ Tcl_HashEntry *hPtr; /* Entry in the above map */ @@ -1175,11 +1140,11 @@ * Note: DeleteThreadReflectedChannelMap() is the thread exit handler * for the origin thread. Use this to clean up the structure? Except * if lost? */ -#if TCL_THREADS +#ifdef TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; ForwardOpToHandlerThread(rcPtr, ForwardedClose, &p); result = p.base.code; @@ -1196,28 +1161,22 @@ } #endif tctPtr = ((Channel *)rcPtr->chan)->typePtr; if (tctPtr && tctPtr != &tclRChannelType) { - Tcl_Free((void *)tctPtr); + ckfree((char *)tctPtr); ((Channel *)rcPtr->chan)->typePtr = NULL; } - if (rcPtr->readTimer != NULL) { - Tcl_DeleteTimerHandler(rcPtr->readTimer); - } - if (rcPtr->writeTimer != NULL) { - Tcl_DeleteTimerHandler(rcPtr->writeTimer); - } Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); return EOK; } /* * Are we in the correct thread? */ -#if TCL_THREADS +#ifdef TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; ForwardOpToHandlerThread(rcPtr, ForwardedClose, &p); result = p.base.code; @@ -1260,11 +1219,11 @@ Tcl_GetChannelName(rcPtr->chan)); if (hPtr) { Tcl_DeleteHashEntry(hPtr); } } -#if TCL_THREADS +#ifdef TCL_THREADS rcmPtr = GetThreadReflectedChannelMap(); hPtr = Tcl_FindHashEntry(&rcmPtr->map, Tcl_GetChannelName(rcPtr->chan)); if (hPtr) { Tcl_DeleteHashEntry(hPtr); @@ -1271,22 +1230,28 @@ } } #endif tctPtr = ((Channel *)rcPtr->chan)->typePtr; if (tctPtr && tctPtr != &tclRChannelType) { - Tcl_Free((void *)tctPtr); - ((Channel *)rcPtr->chan)->typePtr = NULL; - } - if (rcPtr->readTimer != NULL) { - Tcl_DeleteTimerHandler(rcPtr->readTimer); - } - if (rcPtr->writeTimer != NULL) { - Tcl_DeleteTimerHandler(rcPtr->writeTimer); + ckfree((char *)tctPtr); + ((Channel *)rcPtr->chan)->typePtr = NULL; } Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); return (result == TCL_OK) ? EOK : EINVAL; } + +static int +ReflectClose2( + ClientData clientData, + Tcl_Interp *interp, + int flags) +{ + if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) == 0) { + return ReflectClose(clientData, interp); + } + return EINVAL; +} /* *---------------------------------------------------------------------- * * ReflectInput -- @@ -1307,21 +1272,21 @@ ClientData clientData, char *buf, int toRead, int *errorCodePtr) { - ReflectedChannel *rcPtr = clientData; + ReflectedChannel *rcPtr = (ReflectedChannel *)clientData; Tcl_Obj *toReadObj; - size_t bytec = 0; /* Number of returned bytes */ + int bytec; /* Number of returned bytes */ unsigned char *bytev; /* Array of returned bytes */ Tcl_Obj *resObj; /* Result data for 'read' */ /* * Are we in the correct thread? */ -#if TCL_THREADS +#ifdef TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; p.input.buf = buf; p.input.toRead = toRead; @@ -1329,19 +1294,19 @@ ForwardOpToHandlerThread(rcPtr, ForwardedInput, &p); if (p.base.code != TCL_OK) { if (p.base.code < 0) { /* - * No error message, this is an errno signal. - */ + * No error message, this is an errno signal. + */ *errorCodePtr = -p.base.code; } else { PassReceivedError(rcPtr->chan, &p); *errorCodePtr = EINVAL; } - p.input.toRead = TCL_AUTO_LENGTH; + p.input.toRead = -1; } else { *errorCodePtr = EOK; } return p.input.toRead; @@ -1351,11 +1316,11 @@ /* ASSERT: rcPtr->method & FLAG(METH_READ) */ /* ASSERT: rcPtr->mode & TCL_READABLE */ Tcl_Preserve(rcPtr); - toReadObj = Tcl_NewIntObj(toRead); + TclNewIntObj(toReadObj, toRead); Tcl_IncrRefCount(toReadObj); if (InvokeTclMethod(rcPtr, METH_READ, toReadObj, NULL, &resObj)!=TCL_OK) { int code = ErrnoReturn(rcPtr, resObj); @@ -1366,20 +1331,20 @@ Tcl_SetChannelError(rcPtr->chan, resObj); goto invalid; } - bytev = TclGetByteArrayFromObj(resObj, &bytec); + bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); - if ((size_t)toRead < bytec) { + if (toRead < bytec) { SetChannelErrorStr(rcPtr->chan, msg_read_toomuch); - goto invalid; + goto invalid; } *errorCodePtr = EOK; - if (bytec + 1 > 1) { + if (bytec > 0) { memcpy(buf, bytev, bytec); } stop: Tcl_DecrRefCount(toReadObj); @@ -1414,20 +1379,20 @@ ClientData clientData, const char *buf, int toWrite, int *errorCodePtr) { - ReflectedChannel *rcPtr = clientData; + ReflectedChannel *rcPtr = (ReflectedChannel *)clientData; Tcl_Obj *bufObj; Tcl_Obj *resObj; /* Result data for 'write' */ int written; /* * Are we in the correct thread? */ -#if TCL_THREADS +#ifdef TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; p.output.buf = buf; p.output.toWrite = toWrite; @@ -1435,12 +1400,12 @@ ForwardOpToHandlerThread(rcPtr, ForwardedOutput, &p); if (p.base.code != TCL_OK) { if (p.base.code < 0) { /* - * No error message, this is an errno signal. - */ + * No error message, this is an errno signal. + */ *errorCodePtr = -p.base.code; } else { PassReceivedError(rcPtr->chan, &p); *errorCodePtr = EINVAL; @@ -1543,20 +1508,20 @@ ClientData clientData, Tcl_WideInt offset, int seekMode, int *errorCodePtr) { - ReflectedChannel *rcPtr = clientData; + ReflectedChannel *rcPtr = (ReflectedChannel *)clientData; Tcl_Obj *offObj, *baseObj; Tcl_Obj *resObj; /* Result for 'seek' */ Tcl_WideInt newLoc; /* * Are we in the correct thread? */ -#if TCL_THREADS +#ifdef TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; p.seek.seekMode = seekMode; p.seek.offset = offset; @@ -1626,11 +1591,11 @@ * standard seeking, i.e. non-wide. Because of this we have to implement * it, a dummy is not enough. We simply delegate the call to the wide * routine. */ - return ReflectSeekWide(clientData, offset, seekMode, + return (int) ReflectSeekWide(clientData, Tcl_LongAsWide(offset), seekMode, errorCodePtr); } /* *---------------------------------------------------------------------- @@ -1652,11 +1617,11 @@ static void ReflectWatch( ClientData clientData, int mask) { - ReflectedChannel *rcPtr = clientData; + ReflectedChannel *rcPtr = (ReflectedChannel *)clientData; Tcl_Obj *maskObj; /* * We restrict the interest to what the channel can support. IOW there * will never be write events for a channel which is not writable. @@ -1675,11 +1640,11 @@ /* * Are we in the correct thread? */ -#if TCL_THREADS +#ifdef TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; p.watch.mask = mask; ForwardOpToHandlerThread(rcPtr, ForwardedWatch, &p); @@ -1724,20 +1689,20 @@ static int ReflectBlock( ClientData clientData, int nonblocking) { - ReflectedChannel *rcPtr = clientData; + ReflectedChannel *rcPtr = (ReflectedChannel *)clientData; Tcl_Obj *blockObj; int errorNum; /* EINVAL or EOK (success). */ Tcl_Obj *resObj; /* Result data for 'blocking' */ /* * Are we in the correct thread? */ -#if TCL_THREADS +#ifdef TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; p.block.nonblocking = nonblocking; @@ -1769,11 +1734,11 @@ Tcl_Release(rcPtr); return errorNum; } -#if TCL_THREADS +#ifdef TCL_THREADS /* *---------------------------------------------------------------------- * * ReflectThread -- * @@ -1791,11 +1756,11 @@ static void ReflectThread( ClientData clientData, int action) { - ReflectedChannel *rcPtr = clientData; + ReflectedChannel *rcPtr = (ReflectedChannel *)clientData; switch (action) { case TCL_CHANNEL_THREAD_INSERT: rcPtr->owner = Tcl_GetCurrentThread(); break; @@ -1830,20 +1795,20 @@ ClientData 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 = clientData; + ReflectedChannel *rcPtr = (ReflectedChannel *)clientData; Tcl_Obj *optionObj, *valueObj; int result; /* Result code for 'configure' */ Tcl_Obj *resObj; /* Result data for 'configure' */ /* * Are we in the correct thread? */ -#if TCL_THREADS +#ifdef TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; p.setOpt.name = optionName; p.setOpt.value = newValue; @@ -1907,11 +1872,11 @@ /* * This code is special. It has regular passing of Tcl result, and errors. * The bypass functions are not required. */ - ReflectedChannel *rcPtr = clientData; + ReflectedChannel *rcPtr = (ReflectedChannel *)clientData; Tcl_Obj *optionObj; Tcl_Obj *resObj; /* Result data for 'configure' */ int listc, result = TCL_OK; Tcl_Obj **listv; MethodName method; @@ -1918,11 +1883,11 @@ /* * Are we in the correct thread? */ -#if TCL_THREADS +#ifdef TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { int opcode; ForwardParam p; p.getOpt.name = optionName; @@ -2007,12 +1972,12 @@ "Expected list with even number of " "elements, got %d element%s instead", listc, (listc == 1 ? "" : "s"))); goto error; } else { - size_t len; - const char *str = TclGetStringFromObj(resObj, &len); + int len; + const char *str = Tcl_GetStringFromObj(resObj, &len); if (len) { TclDStringAppendLiteral(dsPtr, " "); Tcl_DStringAppend(dsPtr, str, len); } @@ -2123,11 +2088,11 @@ static Tcl_Obj * DecodeEventMask( int mask) { - register const char *eventStr; + const char *eventStr; Tcl_Obj *evObj; switch (mask & RANDW) { case RANDW: eventStr = "read write"; @@ -2174,20 +2139,18 @@ Tcl_Obj *handleObj) { ReflectedChannel *rcPtr; MethodName mn = METH_BLOCKING; - rcPtr = Tcl_Alloc(sizeof(ReflectedChannel)); + rcPtr = (ReflectedChannel *)ckalloc(sizeof(ReflectedChannel)); /* rcPtr->chan: Assigned by caller. Dummy data here. */ rcPtr->chan = NULL; rcPtr->interp = interp; rcPtr->dead = 0; - rcPtr->readTimer = 0; - rcPtr->writeTimer = 0; -#if TCL_THREADS +#ifdef TCL_THREADS rcPtr->thread = Tcl_GetCurrentThread(); #endif rcPtr->mode = mode; rcPtr->interest = 0; /* Initially no interest registered */ @@ -2261,11 +2224,11 @@ Tcl_DecrRefCount(rcPtr->methods); } if (rcPtr->cmd) { Tcl_DecrRefCount(rcPtr->cmd); } - Tcl_Free(rcPtr); + ckfree(rcPtr); } /* *---------------------------------------------------------------------- * @@ -2382,12 +2345,12 @@ * This is complex and ugly, and would be completely unnecessary * if we only added support for a TCL_FORBID_EXCEPTIONS flag. */ if (result != TCL_ERROR) { - size_t cmdLen; - const char *cmdString = TclGetStringFromObj(cmd, &cmdLen); + int cmdLen; + const char *cmdString = Tcl_GetStringFromObj(cmd, &cmdLen); Tcl_IncrRefCount(cmd); Tcl_ResetResult(rcPtr->interp); Tcl_SetObjResult(rcPtr->interp, Tcl_ObjPrintf( "chan handler returned bad code: %d", result)); @@ -2462,11 +2425,11 @@ resObj = Tcl_GetObjResult(rcPtr->interp); if (((Tcl_GetIntFromObj(rcPtr->interp, resObj, &code) != TCL_OK) || (code >= 0))) { - if (strcmp("EAGAIN", TclGetString(resObj)) == 0) { + if (strcmp("EAGAIN", Tcl_GetString(resObj)) == 0) { code = -EAGAIN; } else { code = 0; } } @@ -2494,14 +2457,14 @@ static ReflectedChannelMap * GetReflectedChannelMap( Tcl_Interp *interp) { - ReflectedChannelMap *rcmPtr = Tcl_GetAssocData(interp, RCMKEY, NULL); + ReflectedChannelMap *rcmPtr = (ReflectedChannelMap *)Tcl_GetAssocData(interp, RCMKEY, NULL); if (rcmPtr == NULL) { - rcmPtr = Tcl_Alloc(sizeof(ReflectedChannelMap)); + rcmPtr = (ReflectedChannelMap *)ckalloc(sizeof(ReflectedChannelMap)); Tcl_InitHashTable(&rcmPtr->map, TCL_STRING_KEYS); Tcl_SetAssocData(interp, RCMKEY, (Tcl_InterpDeleteProc *) DeleteReflectedChannelMap, rcmPtr); } return rcmPtr; @@ -2552,17 +2515,17 @@ static void DeleteReflectedChannelMap( ClientData clientData, /* The per-interpreter data structure. */ Tcl_Interp *interp) /* The interpreter being deleted. */ { - ReflectedChannelMap *rcmPtr = clientData; + ReflectedChannelMap *rcmPtr = (ReflectedChannelMap *)clientData; /* The map */ Tcl_HashSearch hSearch; /* Search variable. */ Tcl_HashEntry *hPtr; /* Search variable. */ ReflectedChannel *rcPtr; Tcl_Channel chan; -#if TCL_THREADS +#ifdef TCL_THREADS ForwardingResult *resultPtr; ForwardingEvent *evPtr; ForwardParam *paramPtr; #endif @@ -2579,20 +2542,20 @@ */ for (hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch); hPtr != NULL; hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch)) { - chan = Tcl_GetHashValue(hPtr); - rcPtr = Tcl_GetChannelInstanceData(chan); + chan = (Tcl_Channel)Tcl_GetHashValue(hPtr); + rcPtr = (ReflectedChannel *)Tcl_GetChannelInstanceData(chan); MarkDead(rcPtr); Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(&rcmPtr->map); - Tcl_Free(&rcmPtr->map); + ckfree(&rcmPtr->map); -#if TCL_THREADS +#ifdef TCL_THREADS /* * The origin interpreter for one or more reflected channels is gone. */ /* @@ -2625,12 +2588,12 @@ */ evPtr = resultPtr->evPtr; /* - * Basic crash safety until this routine can get revised [3411310] - */ + * Basic crash safety until this routine can get revised [3411310] + */ if (evPtr == NULL) { continue; } paramPtr = evPtr->param; @@ -2657,12 +2620,12 @@ rcmPtr = GetThreadReflectedChannelMap(); for (hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { - chan = Tcl_GetHashValue(hPtr); - rcPtr = Tcl_GetChannelInstanceData(chan); + chan = (Tcl_Channel)Tcl_GetHashValue(hPtr); + rcPtr = (ReflectedChannel *)Tcl_GetChannelInstanceData(chan); if (rcPtr->interp != interp) { /* * Ignore entries for other interpreters. */ @@ -2674,11 +2637,11 @@ Tcl_DeleteHashEntry(hPtr); } #endif } -#if TCL_THREADS +#ifdef TCL_THREADS /* *---------------------------------------------------------------------- * * GetThreadReflectedChannelMap -- * @@ -2698,11 +2661,11 @@ GetThreadReflectedChannelMap(void) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!tsdPtr->rcmPtr) { - tsdPtr->rcmPtr = Tcl_Alloc(sizeof(ReflectedChannelMap)); + tsdPtr->rcmPtr = (ReflectedChannelMap *)ckalloc(sizeof(ReflectedChannelMap)); Tcl_InitHashTable(&tsdPtr->rcmPtr->map, TCL_STRING_KEYS); Tcl_CreateThreadExitHandler(DeleteThreadReflectedChannelMap, NULL); } return tsdPtr->rcmPtr; @@ -2726,17 +2689,18 @@ *---------------------------------------------------------------------- */ static void DeleteThreadReflectedChannelMap( - ClientData clientData) /* The per-thread data structure. */ + ClientData dummy) /* The per-thread data structure. */ { Tcl_HashSearch hSearch; /* Search variable. */ Tcl_HashEntry *hPtr; /* Search variable. */ Tcl_ThreadId self = Tcl_GetCurrentThread(); ReflectedChannelMap *rcmPtr; /* The map */ ForwardingResult *resultPtr; + (void)dummy; /* * The origin thread for one or more reflected channels is gone. * NOTE: If this function is called due to a thread getting killed the * per-interp DeleteReflectedChannelMap is apparently not called. @@ -2775,12 +2739,12 @@ */ evPtr = resultPtr->evPtr; /* - * Basic crash safety until this routine can get revised [3411310] - */ + * Basic crash safety until this routine can get revised [3411310] + */ if (evPtr == NULL ) { continue; } paramPtr = evPtr->param; @@ -2815,17 +2779,17 @@ rcmPtr = GetThreadReflectedChannelMap(); for (hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch); hPtr != NULL; hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch)) { - Tcl_Channel chan = Tcl_GetHashValue(hPtr); - ReflectedChannel *rcPtr = Tcl_GetChannelInstanceData(chan); + Tcl_Channel chan = (Tcl_Channel)Tcl_GetHashValue(hPtr); + ReflectedChannel *rcPtr = (ReflectedChannel *)Tcl_GetChannelInstanceData(chan); MarkDead(rcPtr); Tcl_DeleteHashEntry(hPtr); } - Tcl_Free(rcmPtr); + ckfree(rcmPtr); } static void ForwardOpToHandlerThread( ReflectedChannel *rcPtr, /* Channel instance */ @@ -2861,12 +2825,12 @@ /* * Create and initialize the event and data structures. */ - evPtr = Tcl_Alloc(sizeof(ForwardingEvent)); - resultPtr = Tcl_Alloc(sizeof(ForwardingResult)); + evPtr = (ForwardingEvent *)ckalloc(sizeof(ForwardingEvent)); + resultPtr = (ForwardingResult *)ckalloc(sizeof(ForwardingResult)); evPtr->event.proc = ForwardProc; evPtr->resultPtr = resultPtr; evPtr->op = op; evPtr->rcPtr = rcPtr; @@ -2944,11 +2908,11 @@ * Note: The event structure has already been deleted. */ Tcl_DeleteThreadExitHandler(SrcExitProc, evPtr); - Tcl_Free(resultPtr); + ckfree(resultPtr); } static int ForwardProc( Tcl_Event *evGPtr, @@ -2979,10 +2943,11 @@ ForwardParam *paramPtr = evPtr->param; Tcl_Obj *resObj = NULL; /* Interp result of InvokeTclMethod */ ReflectedChannelMap *rcmPtr;/* Map of reflected channels with handlers in * this interp. */ Tcl_HashEntry *hPtr; /* Entry in the above map */ + (void)mask; /* * Ignore the event if no one is waiting for its result anymore. */ @@ -3032,38 +2997,40 @@ MarkDead(rcPtr); break; } case ForwardedInput: { - Tcl_Obj *toReadObj = Tcl_NewIntObj(paramPtr->input.toRead); - Tcl_IncrRefCount(toReadObj); + Tcl_Obj *toReadObj; + + TclNewIntObj(toReadObj, paramPtr->input.toRead); + Tcl_IncrRefCount(toReadObj); - Tcl_Preserve(rcPtr); + Tcl_Preserve(rcPtr); if (InvokeTclMethod(rcPtr, METH_READ, toReadObj, NULL, &resObj)!=TCL_OK){ int code = ErrnoReturn(rcPtr, resObj); if (code < 0) { paramPtr->base.code = code; } else { ForwardSetObjError(paramPtr, resObj); } - paramPtr->input.toRead = TCL_IO_FAILURE; + paramPtr->input.toRead = -1; } else { /* * Process a regular result. */ - size_t bytec = 0; /* Number of returned bytes */ + int bytec; /* Number of returned bytes */ unsigned char *bytev; /* Array of returned bytes */ - bytev = TclGetByteArrayFromObj(resObj, &bytec); + bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); if (paramPtr->input.toRead < bytec) { ForwardSetStaticError(paramPtr, msg_read_toomuch); - paramPtr->input.toRead = TCL_IO_FAILURE; + paramPtr->input.toRead = -1; } else { - if (bytec + 1 > 1) { + if (bytec > 0) { memcpy(paramPtr->input.buf, bytev, bytec); } paramPtr->input.toRead = bytec; } } @@ -3239,19 +3206,19 @@ } else if ((listc % 2) == 1) { /* * Odd number of elements is wrong. [x]. */ - char *buf = Tcl_Alloc(200); + char *buf = (char *)ckalloc(200); sprintf(buf, "{Expected list with even number of elements, got %d %s instead}", listc, (listc == 1 ? "element" : "elements")); ForwardSetDynamicError(paramPtr, buf); } else { - size_t len; - const char *str = TclGetStringFromObj(resObj, &len); + int len; + const char *str = Tcl_GetStringFromObj(resObj, &len); if (len) { TclDStringAppendLiteral(paramPtr->getOpt.value, " "); Tcl_DStringAppend(paramPtr->getOpt.value, str, len); } @@ -3296,11 +3263,11 @@ static void SrcExitProc( ClientData clientData) { - ForwardingEvent *evPtr = clientData; + ForwardingEvent *evPtr = (ForwardingEvent *)clientData; ForwardingResult *resultPtr; ForwardParam *paramPtr; /* * NOTE (2): Can this handler be called with the originator blocked? @@ -3345,15 +3312,15 @@ static void ForwardSetObjError( ForwardParam *paramPtr, Tcl_Obj *obj) { - size_t len; - const char *msgStr = TclGetStringFromObj(obj, &len); + int len; + const char *msgStr = Tcl_GetStringFromObj(obj, &len); len++; - ForwardSetDynamicError(paramPtr, Tcl_Alloc(len)); + ForwardSetDynamicError(paramPtr, ckalloc(len)); memcpy(paramPtr->base.msgStr, msgStr, len); } #endif /* Index: generic/tclIORTrans.c ================================================================== --- generic/tclIORTrans.c +++ generic/tclIORTrans.c @@ -25,20 +25,18 @@ #endif #ifndef EOK #define EOK 0 #endif -/* DUPLICATE of HaveVersion() in tclIO.c // TODO - MODULE_SCOPE */ -static int HaveVersion(const Tcl_ChannelType *typePtr, - Tcl_ChannelTypeVersion minimumVersion); - /* * Signatures of all functions used in the C layer of the reflection. */ static int ReflectClose(ClientData clientData, Tcl_Interp *interp); +static int ReflectClose2(ClientData clientData, + Tcl_Interp *interp, int flags); static int ReflectInput(ClientData clientData, char *buf, int toRead, int *errorCodePtr); static int ReflectOutput(ClientData clientData, const char *buf, int toWrite, int *errorCodePtr); static void ReflectWatch(ClientData clientData, int mask); @@ -70,11 +68,11 @@ ReflectSeek, /* Move location of access point. */ ReflectSetOption, /* Set options. */ ReflectGetOption, /* Get options. */ ReflectWatch, /* Initialize notifier. */ ReflectHandle, /* Get OS handle from the channel. */ - NULL, /* No close2 support. NULL'able. */ + ReflectClose2, /* No close2 support. NULL'able. */ ReflectBlock, /* Set blocking/nonblocking. */ NULL, /* Flush channel. Not used by core. * NULL'able. */ ReflectNotify, /* Handle events. */ ReflectSeekWide, /* Move access point (64 bit). */ @@ -85,14 +83,14 @@ /* * Structure of the buffer to hold transform results to be consumed by higher * layers upon reading from the channel, plus the functions to manage such. */ -typedef struct { +typedef struct _ResultBuffer_ { unsigned char *buf; /* Reference to the buffer area. */ - size_t allocated; /* Allocated size of the buffer area. */ - size_t used; /* Number of bytes in the buffer, + int allocated; /* Allocated size of the buffer area. */ + int used; /* Number of bytes in the buffer, * <= allocated. */ } ResultBuffer; #define ResultLength(r) ((r)->used) /* static int ResultLength(ResultBuffer *r); */ @@ -125,11 +123,11 @@ * Tcl level part of the channel. */ Tcl_Obj *handle; /* Reference to transform handle. Also stored * in the argv, see below. The separate field * gives us direct access, needed when working * with the reflection maps. */ -#if TCL_THREADS +#ifdef TCL_THREADS Tcl_ThreadId thread; /* Thread the 'interp' belongs to. */ #endif Tcl_TimerToken timer; @@ -218,11 +216,11 @@ #define IMPLIES(a,b) ((!(a)) || (b)) #define NEGIMPL(a,b) #define HAS(x,f) (x & FLAG(f)) -#if TCL_THREADS +#ifdef TCL_THREADS /* * Thread specific types and structures. * * We are here essentially creating a very specific implementation of 'thread * send'. @@ -251,11 +249,11 @@ * forward an operation code, the argument details, and reference to results. * The command is assembled in the CT and belongs fully to that thread. No * sharing problems. */ -typedef struct { +typedef struct ForwardParamBase { int code; /* O: Ok/Fail of the cmd handler */ char *msgStr; /* O: Error message for handler failure */ int mustFree; /* O: True if msgStr is allocated, false if * otherwise (static). */ } ForwardParamBase; @@ -268,11 +266,11 @@ struct ForwardParamTransform { ForwardParamBase base; /* "Supertype". MUST COME FIRST. */ char *buf; /* I: Bytes to transform, * O: Bytes in transform result */ - size_t size; /* I: #bytes to transform, + int size; /* I: #bytes to transform, * O: #bytes in the transform result */ }; struct ForwardParamLimit { ForwardParamBase base; /* "Supertype". MUST COME FIRST. */ int max; /* O: Character read limit */ @@ -296,11 +294,11 @@ /* * General event structure, with reference to operation specific data. */ -typedef struct { +typedef struct ForwardingEvent { Tcl_Event event; /* Basic event data, has to be first item */ ForwardingResult *resultPtr; ForwardedOperation op; /* Forwarded driver operation */ ReflectedTransform *rtPtr; /* Channel instance */ ForwardParam *param; /* Packaged arguments and return values, a @@ -327,11 +325,11 @@ ForwardingResult *prevPtr, *nextPtr; /* Links into the list of pending forwarded * results. */ }; -typedef struct { +typedef struct ThreadSpecificData { /* * Table of all reflected transformations owned by this thread. */ ReflectedTransformMap *rtmPtr; @@ -364,11 +362,11 @@ static void SrcExitProc(ClientData clientData); #define FreeReceivedError(p) \ do { \ if ((p)->base.mustFree) { \ - Tcl_Free((p)->base.msgStr); \ + ckfree((p)->base.msgStr); \ } \ } while (0) #define PassReceivedErrorInterp(i,p) \ do { \ if ((i) != NULL) { \ @@ -436,11 +434,11 @@ * list-quoting to keep the words of the message together. See also [x]. */ static const char *msg_read_unsup = "{read not supported by Tcl driver}"; static const char *msg_write_unsup = "{write not supported by Tcl driver}"; -#if TCL_THREADS +#ifdef TCL_THREADS static const char *msg_send_originlost = "{Channel thread lost}"; static const char *msg_send_dstlost = "{Owner lost}"; #endif /* TCL_THREADS */ static const char *msg_dstlost = "-code 1 -level 0 -errorcode NONE -errorinfo {} -errorline 1 {Owner lost}"; @@ -499,11 +497,11 @@ *---------------------------------------------------------------------- */ int TclChanPushObjCmd( - ClientData clientData, + ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { ReflectedTransform *rtPtr; /* Instance data of the new (transform) @@ -526,10 +524,11 @@ ReflectedTransformMap *rtmPtr; /* Map of reflected transforms with handlers * in this interp. */ Tcl_HashEntry *hPtr; /* Entry in the above map */ int isNew; /* Placeholder. */ + (void)dummy; /* * Syntax: chan push CHANNEL CMDPREFIX * [0] [1] [2] [3] * @@ -552,11 +551,11 @@ /* * First argument is a channel handle. */ chanObj = objv[CHAN]; - parentChan = Tcl_GetChannel(interp, TclGetString(chanObj), &mode); + parentChan = Tcl_GetChannel(interp, Tcl_GetString(chanObj), &mode); if (parentChan == NULL) { return TCL_ERROR; } parentChan = Tcl_GetTopChannel(parentChan); @@ -606,11 +605,11 @@ */ if (Tcl_ListObjGetElements(NULL, resObj, &listc, &listv) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s initialize\" returned non-list: %s", - TclGetString(cmdObj), TclGetString(resObj))); + Tcl_GetString(cmdObj), Tcl_GetString(resObj))); Tcl_DecrRefCount(resObj); goto error; } methods = 0; @@ -617,12 +616,12 @@ while (listc > 0) { if (Tcl_GetIndexFromObj(interp, listv[listc-1], methodNames, "method", TCL_EXACT, &methIndex) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s initialize\" returned %s", - TclGetString(cmdObj), - Tcl_GetStringResult(interp))); + Tcl_GetString(cmdObj), + Tcl_GetString(Tcl_GetObjResult(interp)))); Tcl_DecrRefCount(resObj); goto error; } methods |= FLAG(methIndex); @@ -631,11 +630,11 @@ Tcl_DecrRefCount(resObj); if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" does not support all required methods", - TclGetString(cmdObj))); + Tcl_GetString(cmdObj))); goto error; } /* * Mode tell us what the parent channel supports. The methods tell us what @@ -653,11 +652,11 @@ } if (!mode) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" makes the channel inaccessible", - TclGetString(cmdObj))); + Tcl_GetString(cmdObj))); goto error; } /* * The mode and support for it is ok, now check the internal constraints. @@ -664,18 +663,18 @@ */ if (!IMPLIES(HAS(methods, METH_DRAIN), HAS(methods, METH_READ))) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" supports \"drain\" but not \"read\"", - TclGetString(cmdObj))); + Tcl_GetString(cmdObj))); goto error; } if (!IMPLIES(HAS(methods, METH_FLUSH), HAS(methods, METH_WRITE))) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" supports \"flush\" but not \"write\"", - TclGetString(cmdObj))); + Tcl_GetString(cmdObj))); goto error; } Tcl_ResetResult(interp); @@ -692,18 +691,18 @@ * Register the transform in our our map for proper handling of deleted * interpreters and/or threads. */ rtmPtr = GetReflectedTransformMap(interp); - hPtr = Tcl_CreateHashEntry(&rtmPtr->map, TclGetString(rtId), &isNew); + hPtr = Tcl_CreateHashEntry(&rtmPtr->map, Tcl_GetString(rtId), &isNew); if (!isNew && rtPtr != Tcl_GetHashValue(hPtr)) { Tcl_Panic("TclChanPushObjCmd: duplicate transformation handle"); } Tcl_SetHashValue(hPtr, rtPtr); -#if TCL_THREADS +#ifdef TCL_THREADS rtmPtr = GetThreadReflectedTransformMap(); - hPtr = Tcl_CreateHashEntry(&rtmPtr->map, TclGetString(rtId), &isNew); + hPtr = Tcl_CreateHashEntry(&rtmPtr->map, Tcl_GetString(rtId), &isNew); Tcl_SetHashValue(hPtr, rtPtr); #endif /* TCL_THREADS */ /* * Return the channel as the result of the command. @@ -744,11 +743,11 @@ *---------------------------------------------------------------------- */ int TclChanPopObjCmd( - ClientData clientData, + ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { /* @@ -762,10 +761,11 @@ #define CHAN (1) const char *chanId; /* Tcl level channel handle */ Tcl_Channel chan; /* Channel associated to the handle */ int mode; /* Channel r/w mode */ + (void)dummy; /* * Number of arguments... */ @@ -883,11 +883,11 @@ static int ReflectClose( ClientData clientData, Tcl_Interp *interp) { - ReflectedTransform *rtPtr = clientData; + ReflectedTransform *rtPtr = (ReflectedTransform *)clientData; int errorCode, errorCodeSet = 0; int result = TCL_OK; /* Result code for 'close' */ Tcl_Obj *resObj; /* Result data for 'close' */ ReflectedTransformMap *rtmPtr; /* Map of reflected transforms with handlers @@ -909,11 +909,11 @@ * Note: DeleteThreadReflectedTransformMap() is the thread exit handler * for the origin thread. Use this to clean up the structure? Except * if lost? */ -#if TCL_THREADS +#ifdef TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; ForwardOpToOwnerThread(rtPtr, ForwardedClose, &p); result = p.base.code; @@ -936,11 +936,11 @@ * that check is not necessary. We always go through 'finalize'. */ if (HAS(rtPtr->methods, METH_DRAIN) && !rtPtr->readIsDrained) { if (!TransformDrain(rtPtr, &errorCode)) { -#if TCL_THREADS +#ifdef TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); return errorCode; } @@ -950,11 +950,11 @@ } } if (HAS(rtPtr->methods, METH_FLUSH)) { if (!TransformFlush(rtPtr, &errorCode, FLUSH_WRITE)) { -#if TCL_THREADS +#ifdef TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); return errorCode; } @@ -966,11 +966,11 @@ /* * Are we in the correct thread? */ -#if TCL_THREADS +#ifdef TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; ForwardOpToOwnerThread(rtPtr, ForwardedClose, &p); result = p.base.code; @@ -1012,11 +1012,11 @@ * the per-interp DeleteReflectedTransformMap exit-handler. */ if (!rtPtr->dead) { rtmPtr = GetReflectedTransformMap(rtPtr->interp); - hPtr = Tcl_FindHashEntry(&rtmPtr->map, TclGetString(rtPtr->handle)); + hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle)); if (hPtr) { Tcl_DeleteHashEntry(hPtr); } /* @@ -1023,22 +1023,34 @@ * In a threaded interpreter we manage a per-thread map as well, * to allow us to survive if the script level pulls the rug out * under a channel by deleting the owning thread. */ -#if TCL_THREADS +#ifdef TCL_THREADS rtmPtr = GetThreadReflectedTransformMap(); - hPtr = Tcl_FindHashEntry(&rtmPtr->map, TclGetString(rtPtr->handle)); + hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle)); if (hPtr) { Tcl_DeleteHashEntry(hPtr); } #endif /* TCL_THREADS */ } Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); return errorCodeSet ? errorCode : ((result == TCL_OK) ? EOK : EINVAL); } + +static int +ReflectClose2( + ClientData clientData, + Tcl_Interp *interp, + int flags) +{ + if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) == 0) { + return ReflectClose(clientData, interp); + } + return EINVAL; +} /* *---------------------------------------------------------------------- * * ReflectInput -- @@ -1059,11 +1071,11 @@ ClientData clientData, char *buf, int toRead, int *errorCodePtr) { - ReflectedTransform *rtPtr = clientData; + ReflectedTransform *rtPtr = (ReflectedTransform *)clientData; int gotBytes, copied, readBytes; Tcl_Obj *bufObj; /* * The following check can be done before thread redirection, because we @@ -1252,11 +1264,11 @@ ClientData clientData, const char *buf, int toWrite, int *errorCodePtr) { - ReflectedTransform *rtPtr = clientData; + ReflectedTransform *rtPtr = (ReflectedTransform *)clientData; /* * The following check can be done before thread redirection, because we * are reading from an item which is readonly, i.e. will never change * during the lifetime of the channel. @@ -1325,11 +1337,11 @@ ClientData clientData, Tcl_WideInt offset, int seekMode, int *errorCodePtr) { - ReflectedTransform *rtPtr = clientData; + ReflectedTransform *rtPtr = (ReflectedTransform *)clientData; Channel *parent = (Channel *) rtPtr->parent; Tcl_WideInt curPos; /* Position on the device. */ Tcl_DriverSeekProc *seekProc = Tcl_ChannelSeekProc(Tcl_GetChannelType(rtPtr->parent)); @@ -1338,11 +1350,11 @@ * Fail if the parent channel is not seekable. */ if (seekProc == NULL) { Tcl_SetErrno(EINVAL); - return -1; + return Tcl_LongAsWide(-1); } /* * Check if we can leave out involving the Tcl level, i.e. transformation * handler. This is true for tell requests, and transformations which @@ -1384,21 +1396,21 @@ * Now seek to the new position in the channel as requested by the * caller. Note that we prefer the wideSeekProc if that is available and * non-NULL... */ - if (HaveVersion(parent->typePtr, TCL_CHANNEL_VERSION_3) && - parent->typePtr->wideSeekProc != NULL) { - curPos = parent->typePtr->wideSeekProc(parent->instanceData, offset, + if (Tcl_ChannelWideSeekProc(parent->typePtr) != NULL) { + curPos = Tcl_ChannelWideSeekProc(parent->typePtr)(parent->instanceData, offset, seekMode, errorCodePtr); - } else if (offset < LONG_MIN || offset > LONG_MAX) { + } else if (offset < Tcl_LongAsWide(LONG_MIN) || + offset > Tcl_LongAsWide(LONG_MAX)) { *errorCodePtr = EOVERFLOW; - curPos = -1; + curPos = Tcl_LongAsWide(-1); } else { - curPos = parent->typePtr->seekProc( - parent->instanceData, offset, seekMode, - errorCodePtr); + curPos = Tcl_LongAsWide(Tcl_ChannelSeekProc(parent->typePtr)( + parent->instanceData, Tcl_WideAsLong(offset), seekMode, + errorCodePtr)); } if (curPos == -1) { Tcl_SetErrno(*errorCodePtr); } @@ -1419,11 +1431,11 @@ * standard seeking, i.e. non-wide. Because of this we have to implement * it, a dummy is not enough. We simply delegate the call to the wide * routine. */ - return ReflectSeekWide(clientData, offset, seekMode, + return (int) ReflectSeekWide(clientData, Tcl_LongAsWide(offset), seekMode, errorCodePtr); } /* *---------------------------------------------------------------------- @@ -1445,11 +1457,11 @@ static void ReflectWatch( ClientData clientData, int mask) { - ReflectedTransform *rtPtr = clientData; + ReflectedTransform *rtPtr = (ReflectedTransform *)clientData; Tcl_DriverWatchProc *watchProc; watchProc = Tcl_ChannelWatchProc(Tcl_GetChannelType(rtPtr->parent)); watchProc(Tcl_GetChannelInstanceData(rtPtr->parent), mask); @@ -1496,11 +1508,11 @@ static int ReflectBlock( ClientData clientData, int nonblocking) { - ReflectedTransform *rtPtr = clientData; + ReflectedTransform *rtPtr = (ReflectedTransform *)clientData; /* * Transformations simply record the blocking mode in their C level * structure for use by --> ReflectInput. The Tcl level doesn't see this * information or change. As such thread forwarding is not required. @@ -1531,11 +1543,11 @@ ClientData 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 */ { - ReflectedTransform *rtPtr = clientData; + ReflectedTransform *rtPtr = (ReflectedTransform *)clientData; /* * Transformations have no options. Thus the call is passed down unchanged * to the parent channel for processing. Its results are passed back * unchanged as well. This all happens in the thread we are in. As the Tcl @@ -1573,11 +1585,11 @@ ClientData 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 */ { - ReflectedTransform *rtPtr = clientData; + ReflectedTransform *rtPtr = (ReflectedTransform *)clientData; /* * Transformations have no options. Thus the call is passed down unchanged * to the parent channel for processing. Its results are passed back * unchanged as well. This all happens in the thread we are in. As the Tcl @@ -1621,11 +1633,11 @@ ReflectHandle( ClientData clientData, int direction, ClientData *handlePtr) { - ReflectedTransform *rtPtr = clientData; + ReflectedTransform *rtPtr = (ReflectedTransform *)clientData; /* * Transformations have no handle of their own. As such we simply query * the parent channel for it. This way the qery will ripple down through * all transformations until reaches the base channel. Which then returns @@ -1656,11 +1668,11 @@ static int ReflectNotify( ClientData clientData, int mask) { - ReflectedTransform *rtPtr = clientData; + ReflectedTransform *rtPtr = (ReflectedTransform *)clientData; /* * An event occured in the underlying channel. * * We delete our timer. It was not fired, yet we are here, so the channel @@ -1704,11 +1716,11 @@ static Tcl_Obj * DecodeEventMask( int mask) { - register const char *eventStr; + const char *eventStr; Tcl_Obj *evObj; switch (mask & RANDW) { case RANDW: eventStr = "read write"; @@ -1756,19 +1768,20 @@ { ReflectedTransform *rtPtr; int listc; Tcl_Obj **listv; int i; + (void)mode; - rtPtr = Tcl_Alloc(sizeof(ReflectedTransform)); + rtPtr = (ReflectedTransform *)ckalloc(sizeof(ReflectedTransform)); /* rtPtr->chan: Assigned by caller. Dummy data here. */ /* rtPtr->methods: Assigned by caller. Dummy data here. */ rtPtr->chan = NULL; rtPtr->methods = 0; -#if TCL_THREADS +#ifdef TCL_THREADS rtPtr->thread = Tcl_GetCurrentThread(); #endif rtPtr->parent = parentChan; rtPtr->interp = interp; rtPtr->handle = handleObj; @@ -1804,11 +1817,11 @@ * argv [0] ... [.] | [argc-2] [argc-1] | [argc] [argc+2] * cmd ... pfx | method chan | detail1 detail2 */ rtPtr->argc = listc + 2; - rtPtr->argv = Tcl_Alloc(sizeof(Tcl_Obj *) * (listc+4)); + rtPtr->argv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * (listc+4)); /* * Duplicate object references. */ @@ -1912,12 +1925,12 @@ TimerKill(rtPtr); ResultClear(&rtPtr->result); FreeReflectedTransformArgs(rtPtr); - Tcl_Free(rtPtr->argv); - Tcl_Free(rtPtr); + ckfree(rtPtr->argv); + ckfree(rtPtr); } /* *---------------------------------------------------------------------- * @@ -2039,12 +2052,12 @@ * This is complex and ugly, and would be completely unnecessary * if we only added support for a TCL_FORBID_EXCEPTIONS flag. */ if (result != TCL_ERROR) { Tcl_Obj *cmd = Tcl_NewListObj(cmdc, rtPtr->argv); - size_t cmdLen; - const char *cmdString = TclGetStringFromObj(cmd, &cmdLen); + int cmdLen; + const char *cmdString = Tcl_GetStringFromObj(cmd, &cmdLen); Tcl_IncrRefCount(cmd); Tcl_ResetResult(rtPtr->interp); Tcl_SetObjResult(rtPtr->interp, Tcl_ObjPrintf( "chan handler returned bad code: %d", result)); @@ -2109,14 +2122,14 @@ static ReflectedTransformMap * GetReflectedTransformMap( Tcl_Interp *interp) { - ReflectedTransformMap *rtmPtr = Tcl_GetAssocData(interp, RTMKEY, NULL); + ReflectedTransformMap *rtmPtr = (ReflectedTransformMap *)Tcl_GetAssocData(interp, RTMKEY, NULL); if (rtmPtr == NULL) { - rtmPtr = Tcl_Alloc(sizeof(ReflectedTransformMap)); + rtmPtr = (ReflectedTransformMap *)ckalloc(sizeof(ReflectedTransformMap)); Tcl_InitHashTable(&rtmPtr->map, TCL_STRING_KEYS); Tcl_SetAssocData(interp, RTMKEY, (Tcl_InterpDeleteProc *) DeleteReflectedTransformMap, rtmPtr); } return rtmPtr; @@ -2149,11 +2162,11 @@ { ReflectedTransformMap *rtmPtr; /* The map */ Tcl_HashSearch hSearch; /* Search variable. */ Tcl_HashEntry *hPtr; /* Search variable. */ ReflectedTransform *rtPtr; -#if TCL_THREADS +#ifdef TCL_THREADS ForwardingResult *resultPtr; ForwardingEvent *evPtr; ForwardParam *paramPtr; #endif /* TCL_THREADS */ @@ -2167,23 +2180,23 @@ * in a different thread we actually do the same as * DeleteThreadReflectedTransformMap(), just restricted to the channels of * this interp. */ - rtmPtr = clientData; + rtmPtr = (ReflectedTransformMap *)clientData; for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch); hPtr != NULL; hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch)) { - rtPtr = Tcl_GetHashValue(hPtr); + rtPtr = (ReflectedTransform *)Tcl_GetHashValue(hPtr); rtPtr->dead = 1; Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(&rtmPtr->map); - Tcl_Free(&rtmPtr->map); + ckfree(&rtmPtr->map); -#if TCL_THREADS +#ifdef TCL_THREADS /* * The origin interpreter for one or more reflected channels is gone. */ /* @@ -2195,11 +2208,11 @@ rtmPtr = GetThreadReflectedTransformMap(); for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { - rtPtr = Tcl_GetHashValue(hPtr); + rtPtr = (ReflectedTransform *)Tcl_GetHashValue(hPtr); if (rtPtr->interp != interp) { /* * Ignore entries for other interpreters. */ @@ -2251,11 +2264,11 @@ } Tcl_MutexUnlock(&rtForwardMutex); #endif /* TCL_THREADS */ } -#if TCL_THREADS +#ifdef TCL_THREADS /* *---------------------------------------------------------------------- * * GetThreadReflectedTransformMap -- * @@ -2275,11 +2288,11 @@ GetThreadReflectedTransformMap(void) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!tsdPtr->rtmPtr) { - tsdPtr->rtmPtr = Tcl_Alloc(sizeof(ReflectedTransformMap)); + tsdPtr->rtmPtr = (ReflectedTransformMap *)ckalloc(sizeof(ReflectedTransformMap)); Tcl_InitHashTable(&tsdPtr->rtmPtr->map, TCL_STRING_KEYS); Tcl_CreateThreadExitHandler(DeleteThreadReflectedTransformMap, NULL); } return tsdPtr->rtmPtr; @@ -2303,17 +2316,18 @@ *---------------------------------------------------------------------- */ static void DeleteThreadReflectedTransformMap( - ClientData clientData) /* The per-thread data structure. */ + ClientData dummy) /* The per-thread data structure. */ { Tcl_HashSearch hSearch; /* Search variable. */ Tcl_HashEntry *hPtr; /* Search variable. */ Tcl_ThreadId self = Tcl_GetCurrentThread(); ReflectedTransformMap *rtmPtr; /* The map */ ForwardingResult *resultPtr; + (void)dummy; /* * The origin thread for one or more reflected channels is gone. * NOTE: If this function is called due to a thread getting killed the * per-interp DeleteReflectedTransformMap is apparently not called. @@ -2327,17 +2341,17 @@ rtmPtr = GetThreadReflectedTransformMap(); for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch); hPtr != NULL; hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch)) { - ReflectedTransform *rtPtr = Tcl_GetHashValue(hPtr); + ReflectedTransform *rtPtr = (ReflectedTransform *)Tcl_GetHashValue(hPtr); rtPtr->dead = 1; FreeReflectedTransformArgs(rtPtr); Tcl_DeleteHashEntry(hPtr); } - Tcl_Free(rtmPtr); + ckfree(rtmPtr); /* * Go through the list of pending results and cancel all whose events were * destined for this thread. While this is in progress we block any * other access to the list of pending results. @@ -2410,12 +2424,12 @@ /* * Create and initialize the event and data structures. */ - evPtr = Tcl_Alloc(sizeof(ForwardingEvent)); - resultPtr = Tcl_Alloc(sizeof(ForwardingResult)); + evPtr = (ForwardingEvent *)ckalloc(sizeof(ForwardingEvent)); + resultPtr = (ForwardingResult *)ckalloc(sizeof(ForwardingResult)); evPtr->event.proc = ForwardProc; evPtr->resultPtr = resultPtr; evPtr->op = op; evPtr->rtPtr = rtPtr; @@ -2491,11 +2505,11 @@ * notifier, after it serviced the event. */ Tcl_DeleteThreadExitHandler(SrcExitProc, evPtr); - Tcl_Free(resultPtr); + ckfree(resultPtr); } static int ForwardProc( Tcl_Event *evGPtr, @@ -2522,10 +2536,11 @@ Tcl_Obj *resObj = NULL; /* Interp result of InvokeTclMethod */ ReflectedTransformMap *rtmPtr; /* Map of reflected channels with handlers in * this interp. */ Tcl_HashEntry *hPtr; /* Entry in the above map */ + (void)mask; /* * Ignore the event if no one is waiting for its result anymore. */ @@ -2565,21 +2580,21 @@ * prevent future accesses (like by 'postevent') from finding and * dereferencing a dangling pointer. */ rtmPtr = GetReflectedTransformMap(interp); - hPtr = Tcl_FindHashEntry(&rtmPtr->map, TclGetString(rtPtr->handle)); + hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle)); Tcl_DeleteHashEntry(hPtr); /* * In a threaded interpreter we manage a per-thread map as well, to * allow us to survive if the script level pulls the rug out under a * channel by deleting the owning thread. */ rtmPtr = GetThreadReflectedTransformMap(); - hPtr = Tcl_FindHashEntry(&rtmPtr->map, TclGetString(rtPtr->handle)); + hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle)); Tcl_DeleteHashEntry(hPtr); FreeReflectedTransformArgs(rtPtr); break; @@ -2588,27 +2603,27 @@ paramPtr->transform.buf, paramPtr->transform.size); Tcl_IncrRefCount(bufObj); if (InvokeTclMethod(rtPtr, "read", bufObj, NULL, &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); - paramPtr->transform.size = TCL_AUTO_LENGTH; + paramPtr->transform.size = -1; } else { /* * Process a regular return. Contains the transformation result. * Sent it back to the request originator. */ - size_t bytec = 0; /* Number of returned bytes */ + int bytec; /* Number of returned bytes */ unsigned char *bytev; /* Array of returned bytes */ - bytev = TclGetByteArrayFromObj(resObj, &bytec); + bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); paramPtr->transform.size = bytec; if (bytec > 0) { - paramPtr->transform.buf = Tcl_Alloc(bytec); + paramPtr->transform.buf = (char *)ckalloc(bytec); memcpy(paramPtr->transform.buf, bytev, bytec); } else { paramPtr->transform.buf = NULL; } } @@ -2622,27 +2637,27 @@ paramPtr->transform.buf, paramPtr->transform.size); Tcl_IncrRefCount(bufObj); if (InvokeTclMethod(rtPtr, "write", bufObj, NULL, &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); - paramPtr->transform.size = TCL_AUTO_LENGTH; + paramPtr->transform.size = -1; } else { /* * Process a regular return. Contains the transformation result. * Sent it back to the request originator. */ - size_t bytec = 0; /* Number of returned bytes */ + int bytec; /* Number of returned bytes */ unsigned char *bytev; /* Array of returned bytes */ - bytev = TclGetByteArrayFromObj(resObj, &bytec); + bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); paramPtr->transform.size = bytec; if (bytec > 0) { - paramPtr->transform.buf = Tcl_Alloc(bytec); + paramPtr->transform.buf = (char *)ckalloc(bytec); memcpy(paramPtr->transform.buf, bytev, bytec); } else { paramPtr->transform.buf = NULL; } } @@ -2652,26 +2667,26 @@ } case ForwardedDrain: if (InvokeTclMethod(rtPtr, "drain", NULL, NULL, &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); - paramPtr->transform.size = TCL_AUTO_LENGTH; + paramPtr->transform.size = -1; } else { /* * Process a regular return. Contains the transformation result. * Sent it back to the request originator. */ - size_t bytec = 0; /* Number of returned bytes */ + int bytec; /* Number of returned bytes */ unsigned char *bytev; /* Array of returned bytes */ - bytev = TclGetByteArrayFromObj(resObj, &bytec); + bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); paramPtr->transform.size = bytec; if (bytec > 0) { - paramPtr->transform.buf = Tcl_Alloc(bytec); + paramPtr->transform.buf = (char *)ckalloc(bytec); memcpy(paramPtr->transform.buf, bytev, bytec); } else { paramPtr->transform.buf = NULL; } } @@ -2678,27 +2693,27 @@ break; case ForwardedFlush: if (InvokeTclMethod(rtPtr, "flush", NULL, NULL, &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); - paramPtr->transform.size = TCL_AUTO_LENGTH; + paramPtr->transform.size = -1; } else { /* * Process a regular return. Contains the transformation result. * Sent it back to the request originator. */ - size_t bytec = 0; /* Number of returned bytes */ + int bytec; /* Number of returned bytes */ unsigned char *bytev; /* Array of returned bytes */ - bytev = TclGetByteArrayFromObj(resObj, &bytec); + bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); paramPtr->transform.size = bytec; if (bytec > 0) { - paramPtr->transform.buf = Tcl_Alloc(bytec); + paramPtr->transform.buf = (char *)ckalloc(bytec); memcpy(paramPtr->transform.buf, bytev, bytec); } else { paramPtr->transform.buf = NULL; } } @@ -2754,11 +2769,11 @@ static void SrcExitProc( ClientData clientData) { - ForwardingEvent *evPtr = clientData; + ForwardingEvent *evPtr = (ForwardingEvent *)clientData; ForwardingResult *resultPtr; ForwardParam *paramPtr; /* * NOTE (2): Can this handler be called with the originator blocked? @@ -2803,15 +2818,15 @@ static void ForwardSetObjError( ForwardParam *paramPtr, Tcl_Obj *obj) { - size_t len; - const char *msgStr = TclGetStringFromObj(obj, &len); + int len; + const char *msgStr = Tcl_GetStringFromObj(obj, &len); len++; - ForwardSetDynamicError(paramPtr, Tcl_Alloc(len)); + ForwardSetDynamicError(paramPtr, ckalloc(len)); memcpy(paramPtr->base.msgStr, msgStr, len); } #endif /* TCL_THREADS */ /* @@ -2894,11 +2909,11 @@ static void TimerRun( ClientData clientData) { - ReflectedTransform *rtPtr = clientData; + ReflectedTransform *rtPtr = (ReflectedTransform *)clientData; rtPtr->timer = NULL; Tcl_NotifyChannel(rtPtr->chan, TCL_READABLE); } @@ -2952,11 +2967,11 @@ if (!rPtr->allocated) { return; } - Tcl_Free(rPtr->buf); + ckfree((char *) rPtr->buf); rPtr->buf = NULL; rPtr->allocated = 0; } /* @@ -2987,14 +3002,14 @@ * NOTE: Currently linear. Should be doubling to amortize. */ if (rPtr->allocated == 0) { rPtr->allocated = toWrite + RB_INCREMENT; - rPtr->buf = UCHARP(Tcl_Alloc(rPtr->allocated)); + rPtr->buf = UCHARP(ckalloc(rPtr->allocated)); } else { rPtr->allocated += toWrite + RB_INCREMENT; - rPtr->buf = UCHARP(Tcl_Realloc((char *) rPtr->buf, + rPtr->buf = UCHARP(ckrealloc((char *) rPtr->buf, rPtr->allocated)); } } /* @@ -3035,19 +3050,19 @@ /* * Nothing to copy in the case of an empty buffer. */ copied = 0; - } else if (rPtr->used == (size_t)toRead) { + } else if (rPtr->used == toRead) { /* * We have just enough. Copy everything to the caller. */ memcpy(buf, rPtr->buf, toRead); rPtr->used = 0; copied = toRead; - } else if (rPtr->used > (size_t)toRead) { + } else if (rPtr->used > toRead) { /* * The internal buffer contains more than requested. Copy the * requested subset to the caller, and shift the remaining bytes down. */ @@ -3078,22 +3093,22 @@ ReflectedTransform *rtPtr, int *errorCodePtr, Tcl_Obj *bufObj) { Tcl_Obj *resObj; - size_t bytec = 0; /* Number of returned bytes */ + int bytec; /* Number of returned bytes */ unsigned char *bytev; /* Array of returned bytes */ /* * Are we in the correct thread? */ -#if TCL_THREADS +#ifdef TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; - p.transform.buf = (char *) TclGetByteArrayFromObj(bufObj, + p.transform.buf = (char *) Tcl_GetByteArrayFromObj(bufObj, &(p.transform.size)); ForwardOpToOwnerThread(rtPtr, ForwardedInput, &p); if (p.base.code != TCL_OK) { @@ -3102,11 +3117,11 @@ return 0; } *errorCodePtr = EOK; ResultAdd(&rtPtr->result, UCHARP(p.transform.buf), p.transform.size); - Tcl_Free(p.transform.buf); + ckfree(p.transform.buf); return 1; } #endif /* TCL_THREADS */ /* ASSERT: rtPtr->method & FLAG(METH_READ) */ @@ -3117,11 +3132,11 @@ Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ *errorCodePtr = EINVAL; return 0; } - bytev = TclGetByteArrayFromObj(resObj, &bytec); + bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); ResultAdd(&rtPtr->result, bytev, bytec); Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ return 1; } @@ -3133,19 +3148,19 @@ unsigned char *buf, int toWrite) { Tcl_Obj *bufObj; Tcl_Obj *resObj; - size_t bytec = 0; /* Number of returned bytes */ + int bytec; /* Number of returned bytes */ unsigned char *bytev; /* Array of returned bytes */ int res; /* * Are we in the correct thread? */ -#if TCL_THREADS +#ifdef TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; p.transform.buf = (char *) buf; p.transform.size = toWrite; @@ -3159,11 +3174,11 @@ } *errorCodePtr = EOK; res = Tcl_WriteRaw(rtPtr->parent, (char *) p.transform.buf, p.transform.size); - Tcl_Free(p.transform.buf); + ckfree(p.transform.buf); } else #endif /* TCL_THREADS */ { /* ASSERT: rtPtr->method & FLAG(METH_WRITE) */ /* ASSERT: rtPtr->mode & TCL_WRITABLE */ @@ -3179,11 +3194,11 @@ return 0; } *errorCodePtr = EOK; - bytev = TclGetByteArrayFromObj(resObj, &bytec); + bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); res = Tcl_WriteRaw(rtPtr->parent, (char *) bytev, bytec); Tcl_DecrRefCount(bufObj); Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ } @@ -3200,18 +3215,18 @@ TransformDrain( ReflectedTransform *rtPtr, int *errorCodePtr) { Tcl_Obj *resObj; - size_t bytec = 0; /* Number of returned bytes */ + int bytec; /* Number of returned bytes */ unsigned char *bytev; /* Array of returned bytes */ /* * Are we in the correct thread? */ -#if TCL_THREADS +#ifdef TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; ForwardOpToOwnerThread(rtPtr, ForwardedDrain, &p); @@ -3221,11 +3236,11 @@ return 0; } *errorCodePtr = EOK; ResultAdd(&rtPtr->result, UCHARP(p.transform.buf), p.transform.size); - Tcl_Free(p.transform.buf); + ckfree(p.transform.buf); } else #endif /* TCL_THREADS */ { if (InvokeTclMethod(rtPtr, "drain", NULL, NULL, &resObj)!=TCL_OK) { Tcl_SetChannelError(rtPtr->chan, resObj); @@ -3232,11 +3247,11 @@ Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ *errorCodePtr = EINVAL; return 0; } - bytev = TclGetByteArrayFromObj(resObj, &bytec); + bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); ResultAdd(&rtPtr->result, bytev, bytec); Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ } @@ -3249,19 +3264,19 @@ ReflectedTransform *rtPtr, int *errorCodePtr, int op) { Tcl_Obj *resObj; - size_t bytec = 0; /* Number of returned bytes */ + int bytec; /* Number of returned bytes */ unsigned char *bytev; /* Array of returned bytes */ int res; /* * Are we in the correct thread? */ -#if TCL_THREADS +#ifdef TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; ForwardOpToOwnerThread(rtPtr, ForwardedFlush, &p); @@ -3276,11 +3291,11 @@ res = Tcl_WriteRaw(rtPtr->parent, (char *) p.transform.buf, p.transform.size); } else { res = 0; } - Tcl_Free(p.transform.buf); + ckfree(p.transform.buf); } else #endif /* TCL_THREADS */ { if (InvokeTclMethod(rtPtr, "flush", NULL, NULL, &resObj)!=TCL_OK) { Tcl_SetChannelError(rtPtr->chan, resObj); @@ -3288,11 +3303,11 @@ *errorCodePtr = EINVAL; return 0; } if (op == FLUSH_WRITE) { - bytev = TclGetByteArrayFromObj(resObj, &bytec); + bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); res = Tcl_WriteRaw(rtPtr->parent, (char *) bytev, bytec); } else { res = 0; } Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ @@ -3312,11 +3327,11 @@ { /* * Are we in the correct thread? */ -#if TCL_THREADS +#ifdef TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; ForwardOpToOwnerThread(rtPtr, ForwardedClear, &p); return; @@ -3344,11 +3359,11 @@ /* * Are we in the correct thread? */ -#if TCL_THREADS +#ifdef TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; ForwardOpToOwnerThread(rtPtr, ForwardedLimit, &p); @@ -3387,40 +3402,13 @@ Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ Tcl_RestoreInterpState(rtPtr->interp, sr); return 1; } - -/* DUPLICATE of HaveVersion() in tclIO.c - *---------------------------------------------------------------------- - * - * HaveVersion -- - * - * Return whether a channel type is (at least) of a given version. - * - * Results: - * True if the minimum version is exceeded by the version actually - * present. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -HaveVersion( - const Tcl_ChannelType *chanTypePtr, - Tcl_ChannelTypeVersion minimumVersion) -{ - Tcl_ChannelTypeVersion actualVersion = Tcl_ChannelVersion(chanTypePtr); - - return PTR2INT(actualVersion) >= PTR2INT(minimumVersion); -} /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: generic/tclIOSock.c ================================================================== --- generic/tclIOSock.c +++ generic/tclIOSock.c @@ -10,33 +10,28 @@ */ #include "tclInt.h" #if defined(_WIN32) -/* - * On Windows, we need to do proper Unicode->UTF-8 conversion. - */ +/* On Windows, we need to do proper Unicode->UTF-8 conversion. */ -typedef struct { +typedef struct ThreadSpecificData { int initialized; Tcl_DString errorMsg; /* UTF-8 encoded error-message */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; #undef gai_strerror -static const char * -gai_strerror( - int code) -{ +static const char *gai_strerror(int code) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (tsdPtr->initialized) { Tcl_DStringFree(&tsdPtr->errorMsg); } else { tsdPtr->initialized = 1; } - Tcl_WinTCharToUtf(gai_strerrorW(code), -1, &tsdPtr->errorMsg); + Tcl_WinTCharToUtf((TCHAR *)gai_strerrorW(code), -1, &tsdPtr->errorMsg); return Tcl_DStringValue(&tsdPtr->errorMsg); } #endif /* @@ -59,12 +54,12 @@ */ int TclSockGetPort( Tcl_Interp *interp, - const char *string, /* Integer or service name */ - const char *proto, /* "tcp" or "udp", typically */ + const char *string, /* Integer or service name */ + const char *proto, /* "tcp" or "udp", typically */ int *portPtr) /* Return port number */ { struct servent *sp; /* Protocol info for named services */ Tcl_DString ds; const char *native; @@ -129,11 +124,11 @@ setsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_SNDBUF, (char *) &size, len); } len = sizeof(int); getsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_RCVBUF, - (char *) ¤t, &len); + (char *) ¤t, &len); if (current < size) { len = sizeof(int); setsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_RCVBUF, (char *) &size, len); } @@ -157,19 +152,19 @@ *---------------------------------------------------------------------- */ int TclCreateSocketAddress( - Tcl_Interp *interp, /* Interpreter for querying the desired socket - * family */ - struct addrinfo **addrlist, /* Socket address list */ - const char *host, /* Host. NULL implies INADDR_ANY */ - int port, /* Port number */ - int willBind, /* Is this an address to bind() to or to - * connect() to? */ - const char **errorMsgPtr) /* Place to store the error message detail, if - * available. */ + Tcl_Interp *interp, /* Interpreter for querying + * the desired socket family */ + struct addrinfo **addrlist, /* Socket address list */ + const char *host, /* Host. NULL implies INADDR_ANY */ + int port, /* Port number */ + int willBind, /* Is this an address to bind() to or + * to connect() to? */ + const char **errorMsgPtr) /* Place to store the error message + * detail, if available. */ { struct addrinfo hints; struct addrinfo *p; struct addrinfo *v4head = NULL, *v4ptr = NULL; struct addrinfo *v6head = NULL, *v6ptr = NULL; @@ -184,48 +179,47 @@ /* * Workaround for OSX's apparent inability to resolve "localhost", "0" * when the loopback device is the only available network interface. */ - if (host != NULL && port == 0) { - portstring = NULL; + portstring = NULL; } else { - TclFormatInt(portbuf, port); - portstring = portbuf; + TclFormatInt(portbuf, port); + portstring = portbuf; } (void) memset(&hints, 0, sizeof(hints)); hints.ai_family = AF_UNSPEC; /* - * Magic variable to enforce a certain address family; to be superseded - * by a TIP that adds explicit switches to [socket]. + * Magic variable to enforce a certain address family - to be superseded + * by a TIP that adds explicit switches to [socket] */ if (interp != NULL) { - family = Tcl_GetVar2(interp, "::tcl::unsupported::socketAF", NULL, 0); - if (family != NULL) { - if (strcmp(family, "inet") == 0) { - hints.ai_family = AF_INET; - } else if (strcmp(family, "inet6") == 0) { - hints.ai_family = AF_INET6; - } - } + family = Tcl_GetVar(interp, "::tcl::unsupported::socketAF", 0); + if (family != NULL) { + if (strcmp(family, "inet") == 0) { + hints.ai_family = AF_INET; + } else if (strcmp(family, "inet6") == 0) { + hints.ai_family = AF_INET6; + } + } } hints.ai_socktype = SOCK_STREAM; #if 0 /* * We found some problems when using AI_ADDRCONFIG, e.g. on systems that * have no networking besides the loopback interface and want to resolve * localhost. See [Bugs 3385024, 3382419, 3382431]. As the advantage of - * using AI_ADDRCONFIG is probably low even in situations where it works, + * using AI_ADDRCONFIG in situations where it works, is probably low, * we'll leave it out for now. After all, it is just an optimisation. * - * Missing on NetBSD. + * Missing on: OpenBSD, NetBSD. * Causes failure when used on AIX 5.1 and HP-UX */ #if defined(AI_ADDRCONFIG) && !defined(_AIX) && !defined(__hpux) hints.ai_flags |= AI_ADDRCONFIG; @@ -255,11 +249,10 @@ * Put IPv4 addresses before IPv6 addresses to maximize backwards * compatibility of [fconfigure -sockname] output. * * There might be more elegant/efficient ways to do this. */ - if (willBind) { for (p = *addrlist; p != NULL; p = p->ai_next) { if (p->ai_family == AF_INET) { if (v4head == NULL) { v4head = p; @@ -286,45 +279,13 @@ *addrlist = v4head; } } return 1; } - -/* - *---------------------------------------------------------------------- - * - * Tcl_OpenTcpServer -- - * - * Opens a TCP server socket and creates a channel around it. - * - * Results: - * The channel or NULL if failed. If an error occurred, an error message - * is left in the interp's result if interp is not NULL. - * - * Side effects: - * Opens a server socket and creates a new channel. - * - *---------------------------------------------------------------------- - */ - -Tcl_Channel -Tcl_OpenTcpServer( - Tcl_Interp *interp, - int port, - const char *host, - Tcl_TcpAcceptProc *acceptProc, - ClientData callbackData) -{ - char portbuf[TCL_INTEGER_SPACE]; - - TclFormatInt(portbuf, port); - return Tcl_OpenTcpServerEx(interp, portbuf, host, TCL_TCPSERVER_REUSEADDR, - acceptProc, callbackData); -} /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: generic/tclIOUtil.c ================================================================== --- generic/tclIOUtil.c +++ generic/tclIOUtil.c @@ -55,11 +55,11 @@ * private copies of some global data. This way we avoid most of the * synchronization calls which boosts performance, at cost of having to update * this information each time the corresponding epoch counter changes. */ -typedef struct { +typedef struct ThreadSpecificData { int initialized; size_t cwdPathEpoch; size_t filesystemEpoch; Tcl_Obj *cwdPathPtr; ClientData cwdClientData; @@ -182,11 +182,11 @@ TclpObjCopyFile, TclpObjRenameFile, TclpObjCopyDirectory, TclpObjLstat, /* Needs casts since we're using version_2. */ - (Tcl_FSLoadFileProc *) TclpDlopen, + (Tcl_FSLoadFileProc *)(void *) TclpDlopen, (Tcl_FSGetCwdProc *) TclpGetNativeCwd, TclpObjChdir }; /* @@ -242,11 +242,11 @@ * combination which was used, and the original and modified filenames, so * that we can correctly undo the entire operation when we want to unload the * code. */ -typedef struct { +typedef struct FsDivertLoad { Tcl_LoadHandle loadHandle; Tcl_FSUnloadFileProc *unloadProcPtr; Tcl_Obj *divertedFile; const Tcl_Filesystem *divertedFilesystem; ClientData divertedFileNativeRep; @@ -273,12 +273,12 @@ if (ret != -1) { #ifndef TCL_WIDE_INT_IS_LONG Tcl_WideInt tmp1, tmp2, tmp3 = 0; # define OUT_OF_RANGE(x) \ - (((Tcl_WideInt)(x)) < LONG_MIN || \ - ((Tcl_WideInt)(x)) > LONG_MAX) + (((Tcl_WideInt)(x)) < Tcl_LongAsWide(LONG_MIN) || \ + ((Tcl_WideInt)(x)) > Tcl_LongAsWide(LONG_MAX)) # define OUT_OF_URANGE(x) \ (((Tcl_WideUInt)(x)) > ((Tcl_WideUInt)ULONG_MAX)) /* * Perform the result-buffer overflow check manually. @@ -325,13 +325,13 @@ oldStyleBuf->st_rdev = buf.st_rdev; oldStyleBuf->st_nlink = buf.st_nlink; oldStyleBuf->st_uid = buf.st_uid; oldStyleBuf->st_gid = buf.st_gid; oldStyleBuf->st_size = (off_t) buf.st_size; - oldStyleBuf->st_atime = buf.st_atime; - oldStyleBuf->st_mtime = buf.st_mtime; - oldStyleBuf->st_ctime = buf.st_ctime; + oldStyleBuf->st_atime = Tcl_GetAccessTimeFromStat(&buf); + oldStyleBuf->st_mtime = Tcl_GetModificationTimeFromStat(&buf); + oldStyleBuf->st_ctime = Tcl_GetChangeTimeFromStat(&buf); #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE oldStyleBuf->st_blksize = buf.st_blksize; #endif #ifdef HAVE_STRUCT_STAT_ST_BLOCKS #ifdef HAVE_BLKCNT_T @@ -455,11 +455,11 @@ fsRecPtr = tsdPtr->filesystemList; while (fsRecPtr != NULL) { tmpFsRecPtr = fsRecPtr->nextPtr; fsRecPtr->fsPtr = NULL; - Tcl_Free(fsRecPtr); + ckfree(fsRecPtr); fsRecPtr = tmpFsRecPtr; } tsdPtr->filesystemList = NULL; tsdPtr->initialized = 0; } @@ -537,15 +537,15 @@ } if (tsdPtr->cwdPathPtr == *pathPtrPtr) { return 1; } else { - size_t len1, len2; + int len1, len2; const char *str1, *str2; - str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1); - str2 = TclGetStringFromObj(*pathPtrPtr, &len2); + str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1); + str2 = Tcl_GetStringFromObj(*pathPtrPtr, &len2); if ((len1 == len2) && !memcmp(str1, str2, len1)) { /* * They are equal, but different objects. Update so they will be * the same object in the future. */ @@ -594,11 +594,11 @@ */ list = NULL; fsRecPtr = tmpFsRecPtr; while (fsRecPtr != NULL) { - tmpFsRecPtr = Tcl_Alloc(sizeof(FilesystemRecord)); + tmpFsRecPtr = ckalloc(sizeof(FilesystemRecord)); *tmpFsRecPtr = *fsRecPtr; tmpFsRecPtr->nextPtr = list; tmpFsRecPtr->prevPtr = NULL; list = tmpFsRecPtr; fsRecPtr = fsRecPtr->prevPtr; @@ -607,13 +607,12 @@ tsdPtr->filesystemEpoch = theFilesystemEpoch; Tcl_MutexUnlock(&filesystemMutex); while (toFree) { FilesystemRecord *next = toFree->nextPtr; - toFree->fsPtr = NULL; - Tcl_Free(toFree); + ckfree(toFree); toFree = next; } /* * Make sure the above gets released on thread exit. @@ -669,10 +668,11 @@ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); return tsdPtr->filesystemEpoch; } + /* * If non-NULL, clientData is owned by us and must be freed later. */ @@ -679,16 +679,16 @@ static void FsUpdateCwd( Tcl_Obj *cwdObj, ClientData clientData) { - size_t len = 0; + int len; const char *str = NULL; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); if (cwdObj != NULL) { - str = TclGetStringFromObj(cwdObj, &len); + str = Tcl_GetStringFromObj(cwdObj, &len); } Tcl_MutexLock(&cwdMutex); if (cwdPathPtr != NULL) { Tcl_DecrRefCount(cwdPathPtr); @@ -780,16 +780,14 @@ fsRecPtr = filesystemList; while (fsRecPtr != NULL) { FilesystemRecord *tmpFsRecPtr = fsRecPtr->nextPtr; - /* - * The native filesystem is static, so we don't free it. - */ + /* The native filesystem is static, so we don't free it. */ if (fsRecPtr != &nativeFilesystemRecord) { - Tcl_Free(fsRecPtr); + ckfree(fsRecPtr); } fsRecPtr = tmpFsRecPtr; } if (++theFilesystemEpoch == 0) { ++theFilesystemEpoch; @@ -827,10 +825,19 @@ { filesystemList = &nativeFilesystemRecord; if (++theFilesystemEpoch == 0) { ++theFilesystemEpoch; } + +#ifdef _WIN32 + /* + * Cleans up the win32 API filesystem proc lookup table. This must happen + * very late in finalization so that deleting of copied dlls can occur. + */ + + TclWinResetInterfaces(); +#endif } /* *---------------------------------------------------------------------- * @@ -870,11 +877,11 @@ if (fsPtr == NULL) { return TCL_ERROR; } - newFilesystemPtr = Tcl_Alloc(sizeof(FilesystemRecord)); + newFilesystemPtr = ckalloc(sizeof(FilesystemRecord)); newFilesystemPtr->clientData = clientData; newFilesystemPtr->fsPtr = fsPtr; /* @@ -936,11 +943,11 @@ *---------------------------------------------------------------------- */ int Tcl_FSUnregister( - const Tcl_Filesystem *fsPtr)/* The filesystem record to remove. */ + const Tcl_Filesystem *fsPtr) /* The filesystem record to remove. */ { int retVal = TCL_ERROR; FilesystemRecord *fsRecPtr; Tcl_MutexLock(&filesystemMutex); @@ -973,11 +980,11 @@ if (++theFilesystemEpoch == 0) { ++theFilesystemEpoch; } - Tcl_Free(fsRecPtr); + ckfree(fsRecPtr); retVal = TCL_OK; } else { fsRecPtr = fsRecPtr->nextPtr; } @@ -1201,11 +1208,11 @@ break; /* Break out of for loop. */ } } if (!found && dir) { Tcl_Obj *norm; - size_t len, mlen; + int len, mlen; /* * We know mElt is absolute normalized and lies inside pathPtr, so * now we must add to the result the right representation of mElt, * i.e. the representation which is relative to pathPtr. @@ -1213,20 +1220,20 @@ norm = Tcl_FSGetNormalizedPath(NULL, pathPtr); if (norm != NULL) { const char *path, *mount; - mount = TclGetStringFromObj(mElt, &mlen); - path = TclGetStringFromObj(norm, &len); + mount = Tcl_GetStringFromObj(mElt, &mlen); + path = Tcl_GetStringFromObj(norm, &len); if (path[len-1] == '/') { /* * Deal with the root of the volume. */ len--; } - len++; /* account for '/' in the mElt [Bug 1602539] */ + len++; /* account for '/' in the mElt [Bug 1602539] */ mElt = TclNewFSPathObj(pathPtr, mount + len, mlen - len); Tcl_ListObjAppendElement(NULL, resultPtr, mElt); } /* * No need to increment gLength, since we don't want to compare @@ -1388,66 +1395,35 @@ Tcl_Obj *pathPtr, /* The path to normalize in place. */ int startAt) /* Start at this char-offset. */ { FilesystemRecord *fsRecPtr, *firstFsRecPtr; - size_t i; - int isVfsPath = 0; - char *path; - - /* - * Paths starting with a UNC prefix whose final character is a colon - * are reserved for VFS use. These names can not conflict with real - * UNC paths per https://msdn.microsoft.com/en-us/library/gg465305.aspx - * and rfc3986's definition of reg-name. - * - * We check these first to avoid useless calls to the native filesystem's - * normalizePathProc. - */ - path = TclGetStringFromObj(pathPtr, &i); - - if ( (i >= 3) && ( (path[0] == '/' && path[1] == '/') - || (path[0] == '\\' && path[1] == '\\') ) ) { - for ( i = 2; ; i++) { - if (path[i] == '\0') break; - if (path[i] == path[0]) break; - } - --i; - if (path[i] == ':') isVfsPath = 1; - } - - /* - * Call each of the "normalise path" functions in succession. - */ + /* + * Call each of the "normalise path" functions in succession. This is a + * special case, in which if we have a native filesystem handler, we call + * it first. This is because the root of Tcl's filesystem is always a + * native filesystem (i.e. '/' on unix is native). + */ + firstFsRecPtr = FsGetFirstFilesystem(); Claim(); - - if (!isVfsPath) { - - /* - * If we have a native filesystem handler, we call it first. This is - * because the root of Tcl's filesystem is always a native filesystem - * (i.e., '/' on unix is native). - */ - - for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) { - if (fsRecPtr->fsPtr != &tclNativeFilesystem) { - continue; - } - - /* - * TODO: Assume that we always find the native file system; it should - * always be there... - */ - - if (fsRecPtr->fsPtr->normalizePathProc != NULL) { - startAt = fsRecPtr->fsPtr->normalizePathProc(interp, pathPtr, - startAt); - } - break; - } + for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) { + if (fsRecPtr->fsPtr != &tclNativeFilesystem) { + continue; + } + + /* + * TODO: Assume that we always find the native file system; it should + * always be there... + */ + + if (fsRecPtr->fsPtr->normalizePathProc != NULL) { + startAt = fsRecPtr->fsPtr->normalizePathProc(interp, pathPtr, + startAt); + } + break; } for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) { /* * Skip the native system next time through. @@ -1545,11 +1521,11 @@ int mode, modeArgc, c, i, gotRW; const char **modeArgv, *flag; #define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR) /* - * Check for the simpler fopen-like access modes (e.g., "r"). They are + * Check for the simpler fopen-like access modes (e.g. "r"). They are * distinguished from the POSIX access modes by the presence of a * lower-case first letter. */ *seekFlagPtr = 0; @@ -1665,11 +1641,11 @@ if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "access mode \"%s\" not supported by this system", flag)); } - Tcl_Free((void *)modeArgv); + ckfree(modeArgv); return -1; #endif } else if ((c == 'N') && (strcmp(flag, "NONBLOCK") == 0)) { #ifdef O_NONBLOCK @@ -1678,11 +1654,11 @@ if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "access mode \"%s\" not supported by this system", flag)); } - Tcl_Free((void *)modeArgv); + ckfree(modeArgv); return -1; #endif } else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) { mode |= O_TRUNC; @@ -1694,16 +1670,16 @@ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid access mode \"%s\": must be RDONLY, WRONLY, " "RDWR, APPEND, BINARY, CREAT, EXCL, NOCTTY, NONBLOCK," " or TRUNC", flag)); } - Tcl_Free((void *)modeArgv); + ckfree(modeArgv); return -1; } } - Tcl_Free((void *)modeArgv); + ckfree(modeArgv); if (!gotRW) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "access mode must include either RDONLY, WRONLY, or RDWR", @@ -1750,12 +1726,11 @@ Tcl_Obj *pathPtr, /* Path of file to process. Tilde-substitution * will be performed on this name. */ const char *encodingName) /* If non-NULL, then use this encoding for the * file. NULL means use the system encoding. */ { - size_t length; - int result = TCL_ERROR; + int length, result = TCL_ERROR; Tcl_StatBuf statBuf; Tcl_Obj *oldScriptFile; Interp *iPtr; const char *string; Tcl_Channel chan; @@ -1767,18 +1742,18 @@ if (Tcl_FSStat(pathPtr, &statBuf) == -1) { Tcl_SetErrno(errno); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", - TclGetString(pathPtr), Tcl_PosixError(interp))); + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); return result; } chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644); if (chan == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", - TclGetString(pathPtr), Tcl_PosixError(interp))); + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); return result; } /* * The eofchar is \32 (^Z). This is the usual on Windows, but we effect @@ -1806,30 +1781,30 @@ /* * Try to read first character of stream, so we can check for utf-8 BOM to * be handled especially. */ - if (Tcl_ReadChars(chan, objPtr, 1, 0) == TCL_IO_FAILURE) { + if (Tcl_ReadChars(chan, objPtr, 1, 0) < 0) { Tcl_Close(interp, chan); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", - TclGetString(pathPtr), Tcl_PosixError(interp))); + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); goto end; } - string = TclGetString(objPtr); + string = Tcl_GetString(objPtr); /* * If first character is not a BOM, append the remaining characters, * otherwise replace them. [Bug 3466099] */ if (Tcl_ReadChars(chan, objPtr, -1, - memcmp(string, "\xef\xbb\xbf", 3)) == TCL_IO_FAILURE) { + memcmp(string, "\xef\xbb\xbf", 3)) < 0) { Tcl_Close(interp, chan); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", - TclGetString(pathPtr), Tcl_PosixError(interp))); + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); goto end; } if (Tcl_Close(interp, chan) != TCL_OK) { goto end; @@ -1837,11 +1812,11 @@ iPtr = (Interp *) interp; oldScriptFile = iPtr->scriptFile; iPtr->scriptFile = pathPtr; Tcl_IncrRefCount(iPtr->scriptFile); - string = TclGetStringFromObj(objPtr, &length); + string = Tcl_GetStringFromObj(objPtr, &length); /* * TIP #280 Force the evaluator to open a frame for a sourced file. */ @@ -1864,17 +1839,17 @@ } else if (result == TCL_ERROR) { /* * Record information telling where the error occurred. */ - const char *pathString = TclGetStringFromObj(pathPtr, &length); - unsigned limit = 150; + const char *pathString = Tcl_GetStringFromObj(pathPtr, &length); + int limit = 150; int overflow = (length > limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (file \"%.*s%s\" line %d)", - (overflow ? limit : (unsigned)length), pathString, + (overflow ? limit : length), pathString, (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } end: Tcl_DecrRefCount(objPtr); @@ -1901,21 +1876,20 @@ if (Tcl_FSStat(pathPtr, &statBuf) == -1) { Tcl_SetErrno(errno); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", - TclGetString(pathPtr), Tcl_PosixError(interp))); + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); return TCL_ERROR; } chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644); if (chan == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", - TclGetString(pathPtr), Tcl_PosixError(interp))); + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); return TCL_ERROR; } - TclPkgFileSeen(interp, TclGetString(pathPtr)); /* * The eofchar is \32 (^Z). This is the usual on Windows, but we effect * this cross-platform to allow for scripted documents. [Bug: 2040] */ @@ -1941,31 +1915,31 @@ /* * Try to read first character of stream, so we can check for utf-8 BOM to * be handled especially. */ - if (Tcl_ReadChars(chan, objPtr, 1, 0) == TCL_IO_FAILURE) { + if (Tcl_ReadChars(chan, objPtr, 1, 0) < 0) { Tcl_Close(interp, chan); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", - TclGetString(pathPtr), Tcl_PosixError(interp))); + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); Tcl_DecrRefCount(objPtr); return TCL_ERROR; } - string = TclGetString(objPtr); + string = Tcl_GetString(objPtr); /* * If first character is not a BOM, append the remaining characters, * otherwise replace them. [Bug 3466099] */ if (Tcl_ReadChars(chan, objPtr, -1, - memcmp(string, "\xef\xbb\xbf", 3)) == TCL_IO_FAILURE) { + memcmp(string, "\xef\xbb\xbf", 3)) < 0) { Tcl_Close(interp, chan); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", - TclGetString(pathPtr), Tcl_PosixError(interp))); + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); Tcl_DecrRefCount(objPtr); return TCL_ERROR; } if (Tcl_Close(interp, chan) != TCL_OK) { @@ -2015,18 +1989,18 @@ } else if (result == TCL_ERROR) { /* * Record information telling where the error occurred. */ - size_t length; - const char *pathString = TclGetStringFromObj(pathPtr, &length); - const unsigned int limit = 150; + int length; + const char *pathString = Tcl_GetStringFromObj(pathPtr, &length); + const int limit = 150; int overflow = (length > limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (file \"%.*s%s\" line %d)", - (overflow ? limit : (unsigned int)length), pathString, + (overflow ? limit : length), pathString, (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } Tcl_DecrRefCount(objPtr); return result; @@ -2299,11 +2273,11 @@ if (seekFlag && Tcl_Seek(retVal, (Tcl_WideInt) 0, SEEK_END) < (Tcl_WideInt) 0) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "could not seek to end of file while opening \"%s\": %s", - TclGetString(pathPtr), Tcl_PosixError(interp))); + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); } Tcl_Close(NULL, retVal); return NULL; } if (binary) { @@ -2318,11 +2292,11 @@ Tcl_SetErrno(ENOENT); if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't open \"%s\": %s", - TclGetString(pathPtr), Tcl_PosixError(interp))); + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); } return NULL; } /* @@ -2692,11 +2666,10 @@ Claim(); for (; (retVal == NULL) && (fsRecPtr != NULL); fsRecPtr = fsRecPtr->nextPtr) { ClientData retCd; TclFSGetCwdProc2 *proc2; - if (fsRecPtr->fsPtr->getCwdProc == NULL) { continue; } if (fsRecPtr->fsPtr->version == TCL_FILESYSTEM_VERSION_1) { @@ -2866,15 +2839,15 @@ * paths. Therefore we can be more efficient than calling * 'Tcl_FSEqualPaths', and in addition avoid a nasty infinite loop * bug when trying to normalize tsdPtr->cwdPathPtr. */ - size_t len1, len2; + int len1, len2; const char *str1, *str2; - str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1); - str2 = TclGetStringFromObj(norm, &len2); + str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1); + str2 = Tcl_GetStringFromObj(norm, &len2); if ((len1 == len2) && (strcmp(str1, str2) == 0)) { /* * If the paths were equal, we can be more efficient and * retain the old path object which will probably already be * shared. In this case we can simply free the normalized path @@ -3165,12 +3138,12 @@ /* * Workaround for issue with modern HPUX which do allow the unlink (no ETXTBSY * error) yet somehow trash some internal data structures which prevents the * second and further shared libraries from getting properly loaded. Only the - * first is ok. We try to get around the issue by not unlinking, i.e., - * emulating the behaviour of the older HPUX which denied removal. + * first is ok. We try to get around the issue by not unlinking, + * i.e. emulating the behaviour of the older HPUX which denied removal. * * Doing the unlink is also an issue within docker containers, whose AUFS * bungles this as well, see * https://github.com/dotcloud/docker/issues/1911 * @@ -3184,64 +3157,59 @@ * By default the unlink is done (if not in AUFS). However if the variable is * present and set to true (any integer > 0) then the unlink is skipped. */ static int -skipUnlink( - Tcl_Obj *shlibFile) +skipUnlink (Tcl_Obj* shlibFile) { - /* - * Order of testing: + /* Order of testing: * 1. On hpux we generally want to skip unlink in general * * Outside of hpux then: - * 2. For a general user request (TCL_TEMPLOAD_NO_UNLINK present, - * non-empty, => int) + * 2. For a general user request (TCL_TEMPLOAD_NO_UNLINK present, non-empty, => int) * 3. For general AUFS environment (statfs, if available). * * Ad 2: This variable can disable/override the AUFS detection, i.e. for - * testing if a newer AUFS does not have the bug any more. + * testing if a newer AUFS does not have the bug any more. * - * Ad 3: This is conditionally compiled in. Condition currently must be - * set manually. This part needs proper tests in the configure(.in). + * Ad 3: This is conditionally compiled in. Condition currently must be set manually. + * This part needs proper tests in the configure(.in). */ #ifdef hpux return 1; #else - char *skipstr = getenv("TCL_TEMPLOAD_NO_UNLINK"); + char* skipstr; + skipstr = getenv ("TCL_TEMPLOAD_NO_UNLINK"); if (skipstr && (skipstr[0] != '\0')) { return atoi(skipstr); } #ifdef TCL_TEMPLOAD_NO_UNLINK #ifndef NO_FSTATFS { struct statfs fs; - /* - * Have fstatfs. May not have the AUFS super magic ... Indeed our build + /* Have fstatfs. May not have the AUFS super magic ... Indeed our build * box is too old to have it directly in the headers. Define taken from * http://mooon.googlecode.com/svn/trunk/linux_include/linux/aufs_type.h * http://aufs.sourceforge.net/ * Better reference will be gladly taken. */ #ifndef AUFS_SUPER_MAGIC #define AUFS_SUPER_MAGIC ('a' << 24 | 'u' << 16 | 'f' << 8 | 's') #endif /* AUFS_SUPER_MAGIC */ - if ((statfs(TclGetString(shlibFile), &fs) == 0) - && (fs.f_type == AUFS_SUPER_MAGIC)) { + if ((statfs(Tcl_GetString (shlibFile), &fs) == 0) && + (fs.f_type == AUFS_SUPER_MAGIC)) { return 1; } } #endif /* ... NO_FSTATFS */ #endif /* ... TCL_TEMPLOAD_NO_UNLINK */ - /* - * Fallback: !hpux, no EV override, no AUFS (detection, nor detected): - * Don't skip - */ + /* Fallback: !hpux, no EV override, no AUFS (detection, nor detected): + * Don't skip */ return 0; #endif /* hpux */ } int @@ -3274,11 +3242,11 @@ Tcl_SetErrno(ENOENT); return TCL_ERROR; } if (fsPtr->loadFileProc != NULL) { - int retVal = ((Tcl_FSLoadFileProc2 *)(fsPtr->loadFileProc)) + retVal = ((Tcl_FSLoadFileProc2 *)(void *)(fsPtr->loadFileProc)) (interp, pathPtr, handlePtr, &unloadProcPtr, flags); if (retVal == TCL_OK) { if (*handlePtr == NULL) { return TCL_ERROR; @@ -3302,11 +3270,11 @@ if (Tcl_FSAccess(pathPtr, R_OK) != 0) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't load library \"%s\": %s", - TclGetString(pathPtr), Tcl_PosixError(interp))); + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); } return TCL_ERROR; } #ifdef TCL_LOAD_FROM_MEMORY @@ -3442,12 +3410,13 @@ /* * Try to delete the file immediately - this is possible in some OSes, and * avoids any worries about leaving the copy laying around on exit. */ - if (!skipUnlink(copyToPtr) && - (Tcl_FSDeleteFile(copyToPtr) == TCL_OK)) { + if ( + !skipUnlink (copyToPtr) && + (Tcl_FSDeleteFile(copyToPtr) == TCL_OK)) { Tcl_DecrRefCount(copyToPtr); /* * We tell our caller about the real shared library which was loaded. * Note that this does mean that the package list maintained by 'load' @@ -3465,11 +3434,11 @@ /* * When we unload this file, we need to divert the unloading so we can * unload and cleanup the temporary file correctly. */ - tvdlPtr = Tcl_Alloc(sizeof(FsDivertLoad)); + tvdlPtr = ckalloc(sizeof(FsDivertLoad)); /* * Remember three pieces of information. This allows us to cleanup the * diverted load completely, on platforms which allow proper unloading of * code. @@ -3511,11 +3480,11 @@ Tcl_DecrRefCount(copyToPtr); } copyToPtr = NULL; - divertedLoadHandle = Tcl_Alloc(sizeof(struct Tcl_LoadHandle_)); + divertedLoadHandle = ckalloc(sizeof(struct Tcl_LoadHandle_)); divertedLoadHandle->clientData = tvdlPtr; divertedLoadHandle->findSymbolProcPtr = DivertFindSymbol; divertedLoadHandle->unloadFileProcPtr = DivertUnloadFile; *handlePtr = divertedLoadHandle; @@ -3657,12 +3626,12 @@ */ Tcl_DecrRefCount(tvdlPtr->divertedFile); } - Tcl_Free(tvdlPtr); - Tcl_Free(loadHandle); + ckfree(tvdlPtr); + ckfree(loadHandle); } /* *---------------------------------------------------------------------- * @@ -3807,11 +3776,11 @@ */ Tcl_DecrRefCount(tvdlPtr->divertedFile); } - Tcl_Free(tvdlPtr); + ckfree(tvdlPtr); } /* *--------------------------------------------------------------------------- * @@ -4032,11 +4001,11 @@ if (fsPtr->filesystemSeparatorProc != NULL) { Tcl_Obj *sep = fsPtr->filesystemSeparatorProc(pathPtr); if (sep != NULL) { Tcl_IncrRefCount(sep); - separator = TclGetString(sep)[0]; + separator = Tcl_GetString(sep)[0]; Tcl_DecrRefCount(sep); } } /* @@ -4044,11 +4013,11 @@ * name may contain strange characters, like colons and multiple forward * slashes (for example 'ftp://' is a valid vfs drive name) */ result = Tcl_NewObj(); - p = TclGetString(pathPtr); + p = Tcl_GetString(pathPtr); Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj(p, driveNameLength)); p += driveNameLength; /* @@ -4121,12 +4090,12 @@ * non-NULL, then set to the name of the * drive, network-volume which contains the * path, already with a refCount for the * caller. */ { - size_t pathLen; - const char *path = TclGetStringFromObj(pathPtr, &pathLen); + int pathLen; + const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen); Tcl_PathType type; type = TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, driveNameLengthPtr, driveNameRef); @@ -4229,17 +4198,17 @@ numVolumes = -1; } while (numVolumes > 0) { Tcl_Obj *vol; - size_t len; + int len; const char *strVol; numVolumes--; Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol); - strVol = TclGetStringFromObj(vol,&len); - if ((size_t) pathLen < len) { + strVol = Tcl_GetStringFromObj(vol,&len); + if (pathLen < len) { continue; } if (strncmp(strVol, path, len) == 0) { type = TCL_PATH_ABSOLUTE; if (filesystemPtrPtr != NULL) { @@ -4421,12 +4390,12 @@ /* * Set modification date of copied file. */ if (Tcl_FSLstat(source, &sourceStatBuf) == 0) { - tval.actime = sourceStatBuf.st_atime; - tval.modtime = sourceStatBuf.st_mtime; + tval.actime = Tcl_GetAccessTimeFromStat(&sourceStatBuf); + tval.modtime = Tcl_GetModificationTimeFromStat(&sourceStatBuf); Tcl_FSUtime(target, &tval); } done: return result; @@ -4577,18 +4546,18 @@ if (recursive) { Tcl_Obj *cwdPtr = Tcl_FSGetCwd(NULL); if (cwdPtr != NULL) { const char *cwdStr, *normPathStr; - size_t cwdLen, normLen; + int cwdLen, normLen; Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr); if (normPath != NULL) { - normPathStr = TclGetStringFromObj(normPath, &normLen); - cwdStr = TclGetStringFromObj(cwdPtr, &cwdLen); + normPathStr = Tcl_GetStringFromObj(normPath, &normLen); + cwdStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen); if ((cwdLen >= normLen) && (strncmp(normPathStr, cwdStr, - normLen) == 0)) { + (size_t) normLen) == 0)) { /* * The cwd is inside the directory, so we perform a 'cd * [file dirname $path]'. */ @@ -4648,11 +4617,11 @@ } /* * Check if the filesystem has changed in some way since this object's * internal representation was calculated. Before doing that, assure we - * have the most up-to-date copy of the master filesystem. This is + * have the most up-to-date copy of the first filesystem. This is * accomplished by the FsGetFirstFilesystem() call. */ fsRecPtr = FsGetFirstFilesystem(); Claim(); @@ -4748,11 +4717,11 @@ static void NativeFreeInternalRep( ClientData clientData) { - Tcl_Free(clientData); + ckfree(clientData); } /* *--------------------------------------------------------------------------- * Index: generic/tclIndexObj.c ================================================================== --- generic/tclIndexObj.c +++ generic/tclIndexObj.c @@ -20,11 +20,10 @@ */ static int GetIndexFromObjList(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj *tableObjPtr, const char *msg, int flags, int *indexPtr); -static int SetIndexFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfIndex(Tcl_Obj *objPtr); static void DupIndex(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr); static void FreeIndex(Tcl_Obj *objPtr); static int PrefixAllObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, @@ -46,11 +45,11 @@ static const Tcl_ObjType indexType = { "index", /* name */ FreeIndex, /* freeIntRepProc */ DupIndex, /* dupIntRepProc */ UpdateStringOfIndex, /* updateStringProc */ - SetIndexFromAny /* setFromAnyProc */ + NULL /* setFromAnyProc */ }; /* * The definition of the internal representation of the "index" object; The * internalRep.twoPtrValue.ptr1 field of an object of "index" type will be a @@ -59,12 +58,12 @@ * Keep this structure declaration in sync with tclTestObj.c */ typedef struct { void *tablePtr; /* Pointer to the table of strings */ - size_t offset; /* Offset between table entries */ - size_t index; /* Selected index into table. */ + int offset; /* Offset between table entries */ + int index; /* Selected index into table. */ } IndexRep; /* * The following macros greatly simplify moving through a table... */ @@ -73,10 +72,73 @@ (*((const char *const *)(((char *)(table)) + (offset)))) #define NEXT_ENTRY(table, offset) \ (&(STRING_AT(table, offset))) #define EXPAND_OF(indexRep) \ STRING_AT((indexRep)->tablePtr, (indexRep)->offset*(indexRep)->index) + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetIndexFromObj -- + * + * This function looks up an object's value in a table of strings and + * returns the index of the matching string, if any. + * + * Results: + * If the value of objPtr is identical to or a unique abbreviation for + * one of the entries in tablePtr, then the return value is TCL_OK and the + * index of the matching entry is stored at *indexPtr. If there isn't a + * proper match, then TCL_ERROR is returned and an error message is left + * in interp's result (unless interp is NULL). The msg argument is used + * in the error message; for example, if msg has the value "option" then + * the error message will say something flag 'bad option "foo": must be + * ...' + * + * Side effects: + * The result of the lookup is cached as the internal rep of objPtr, so + * that repeated lookups can be done quickly. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_GetIndexFromObj +int +Tcl_GetIndexFromObj( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr, /* Object containing the string to lookup. */ + const char *const*tablePtr, /* Array of strings to compare against the + * value of objPtr; last entry must be NULL + * and there must not be duplicate entries. */ + const char *msg, /* Identifying word to use in error + * messages. */ + int flags, /* 0 or TCL_EXACT */ + int *indexPtr) /* Place to store resulting integer index. */ +{ + + /* + * See if there is a valid cached result from a previous lookup (doing the + * check here saves the overhead of calling Tcl_GetIndexFromObjStruct in + * the common case where the result is cached). + */ + + if (objPtr->typePtr == &indexType) { + IndexRep *indexRep = objPtr->internalRep.twoPtrValue.ptr1; + + /* + * Here's hoping we don't get hit by unfortunate packing constraints + * on odd platforms like a Cray PVP... + */ + + if (indexRep->tablePtr == (void *) tablePtr + && indexRep->offset == sizeof(char *)) { + *indexPtr = indexRep->index; + return TCL_OK; + } + } + return Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *), + msg, flags, indexPtr); +} /* *---------------------------------------------------------------------- * * GetIndexFromObjList -- @@ -129,30 +191,35 @@ /* * Build a string table from the list. */ - tablePtr = Tcl_Alloc((objc + 1) * sizeof(char *)); + tablePtr = ckalloc((objc + 1) * sizeof(char *)); for (t = 0; t < objc; t++) { if (objv[t] == objPtr) { /* * An exact match is always chosen, so we can stop here. */ - Tcl_Free((void *)tablePtr); + ckfree(tablePtr); *indexPtr = t; return TCL_OK; } - tablePtr[t] = TclGetString(objv[t]); + tablePtr[t] = Tcl_GetString(objv[t]); } tablePtr[objc] = NULL; result = Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, - sizeof(char *), msg, flags | INDEX_TEMP_TABLE, indexPtr); + sizeof(char *), msg, flags, indexPtr); - Tcl_Free((void *)tablePtr); + /* + * The internal rep must be cleared since tablePtr will go away. + */ + + TclFreeIntRep(objPtr); + ckfree(tablePtr); return result; } /* @@ -188,11 +255,11 @@ const void *tablePtr, /* The first string in the table. The second * string will be at this address plus the * offset, the third plus the offset again, * etc. The last entry must be NULL and there * must not be duplicate entries. */ - size_t offset, /* The number of bytes between entries */ + int offset, /* The number of bytes between entries */ const char *msg, /* Identifying word to use in error * messages. */ int flags, /* 0 or TCL_EXACT */ int *indexPtr) /* Place to store resulting integer index. */ { @@ -200,29 +267,25 @@ const char *key, *p1; const char *p2; const char *const *entryPtr; Tcl_Obj *resultPtr; IndexRep *indexRep; - const Tcl_ObjIntRep *irPtr; /* Protect against invalid values, like -1 or 0. */ - if (offset+1 <= sizeof(char *)) { - offset = sizeof(char *); + if (offset < (int)sizeof(char *)) { + offset = (int)sizeof(char *); } /* * See if there is a valid cached result from a previous lookup. */ - if (!(flags & INDEX_TEMP_TABLE)) { - irPtr = TclFetchIntRep(objPtr, &indexType); - if (irPtr) { - indexRep = irPtr->twoPtrValue.ptr1; + if (objPtr->typePtr == &indexType) { + indexRep = objPtr->internalRep.twoPtrValue.ptr1; if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) { *indexPtr = indexRep->index; return TCL_OK; } - } } /* * Lookup the value of the object in the table. Accept unique * abbreviations unless TCL_EXACT is set in flags. @@ -274,25 +337,21 @@ * Cache the found representation. Note that we want to avoid allocating a * new internal-rep if at all possible since that is potentially a slow * operation. */ - if (!(flags & INDEX_TEMP_TABLE)) { - irPtr = TclFetchIntRep(objPtr, &indexType); - if (irPtr) { - indexRep = irPtr->twoPtrValue.ptr1; + if (objPtr->typePtr == &indexType) { + indexRep = objPtr->internalRep.twoPtrValue.ptr1; } else { - Tcl_ObjIntRep ir; - - indexRep = Tcl_Alloc(sizeof(IndexRep)); - ir.twoPtrValue.ptr1 = indexRep; - Tcl_StoreIntRep(objPtr, &indexType, &ir); + TclFreeIntRep(objPtr); + indexRep = ckalloc(sizeof(IndexRep)); + objPtr->internalRep.twoPtrValue.ptr1 = indexRep; + objPtr->typePtr = &indexType; } indexRep->tablePtr = (void *) tablePtr; indexRep->offset = offset; indexRep->index = index; - } *indexPtr = index; return TCL_OK; error: @@ -335,43 +394,10 @@ } /* *---------------------------------------------------------------------- * - * SetIndexFromAny -- - * - * This function is called to convert a Tcl object to index internal - * form. However, this doesn't make sense (need to have a table of - * keywords in order to do the conversion) so the function always - * generates an error. - * - * Results: - * The return value is always TCL_ERROR, and an error message is left in - * interp's result if interp isn't NULL. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -SetIndexFromAny( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr) /* The object to convert. */ -{ - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can't convert value to index except via Tcl_GetIndexFromObj API", - -1)); - } - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * * UpdateStringOfIndex -- * * This function is called to convert a Tcl object from index internal * form to its string form. No abbreviation is ever generated. * @@ -386,14 +412,20 @@ static void UpdateStringOfIndex( Tcl_Obj *objPtr) { - IndexRep *indexRep = TclFetchIntRep(objPtr, &indexType)->twoPtrValue.ptr1; + IndexRep *indexRep = objPtr->internalRep.twoPtrValue.ptr1; + register char *buf; + register unsigned len; register const char *indexStr = EXPAND_OF(indexRep); - Tcl_InitStringRep(objPtr, indexStr, strlen(indexStr)); + len = strlen(indexStr); + buf = ckalloc(len + 1); + memcpy(buf, indexStr, len+1); + objPtr->bytes = buf; + objPtr->length = len; } /* *---------------------------------------------------------------------- * @@ -415,18 +447,16 @@ static void DupIndex( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { - Tcl_ObjIntRep ir; - IndexRep *dupIndexRep = Tcl_Alloc(sizeof(IndexRep)); - - memcpy(dupIndexRep, TclFetchIntRep(srcPtr, &indexType)->twoPtrValue.ptr1, - sizeof(IndexRep)); - - ir.twoPtrValue.ptr1 = dupIndexRep; - Tcl_StoreIntRep(dupPtr, &indexType, &ir); + IndexRep *srcIndexRep = srcPtr->internalRep.twoPtrValue.ptr1; + IndexRep *dupIndexRep = ckalloc(sizeof(IndexRep)); + + memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep)); + dupPtr->internalRep.twoPtrValue.ptr1 = dupIndexRep; + dupPtr->typePtr = &indexType; } /* *---------------------------------------------------------------------- * @@ -446,11 +476,11 @@ static void FreeIndex( Tcl_Obj *objPtr) { - Tcl_Free(TclFetchIntRep(objPtr, &indexType)->twoPtrValue.ptr1); + ckfree(objPtr->internalRep.twoPtrValue.ptr1); objPtr->typePtr = NULL; } /* *---------------------------------------------------------------------- @@ -542,11 +572,11 @@ "missing value for -message", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL); return TCL_ERROR; } i++; - message = TclGetString(objv[i]); + message = Tcl_GetString(objv[i]); break; case PRFMATCH_ERROR: if (i > objc-4) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing value for -error", -1)); @@ -632,12 +662,11 @@ ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int tableObjc, result, t; - size_t length, elemLength; + int tableObjc, result, t, length, elemLength; const char *string, *elemString; Tcl_Obj **tableObjv, *resultPtr; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "table string"); @@ -647,14 +676,14 @@ result = Tcl_ListObjGetElements(interp, objv[1], &tableObjc, &tableObjv); if (result != TCL_OK) { return result; } resultPtr = Tcl_NewListObj(0, NULL); - string = TclGetStringFromObj(objv[2], &length); + string = Tcl_GetStringFromObj(objv[2], &length); for (t = 0; t < tableObjc; t++) { - elemString = TclGetStringFromObj(tableObjv[t], &elemLength); + elemString = Tcl_GetStringFromObj(tableObjv[t], &elemLength); /* * A prefix cannot match if it is longest. */ @@ -690,12 +719,11 @@ ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int tableObjc, result, t; - size_t i, length, elemLength, resultLength; + int tableObjc, result, i, t, length, elemLength, resultLength; const char *string, *elemString, *resultString; Tcl_Obj **tableObjv; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "table string"); @@ -704,17 +732,17 @@ result = Tcl_ListObjGetElements(interp, objv[1], &tableObjc, &tableObjv); if (result != TCL_OK) { return result; } - string = TclGetStringFromObj(objv[2], &length); + string = Tcl_GetStringFromObj(objv[2], &length); resultString = NULL; resultLength = 0; for (t = 0; t < tableObjc; t++) { - elemString = TclGetStringFromObj(tableObjv[t], &elemLength); + elemString = Tcl_GetStringFromObj(tableObjv[t], &elemLength); /* * First check if the prefix string matches the element. A prefix * cannot match if it is longest. */ @@ -750,11 +778,11 @@ if (resultString[i] != elemString[i]) { /* * Adjust in case we stopped in the middle of a UTF char. */ - resultLength = Tcl_UtfPrev(&resultString[i+1], + resultLength = TclUtfPrev(&resultString[i+1], resultString) - resultString; break; } } } @@ -814,16 +842,38 @@ const char *message) /* Error message to print after the leading * objects in objv. The message may be * NULL. */ { Tcl_Obj *objPtr; - int i; - size_t len, elemLen; + int i, len, elemLen; char flags; Interp *iPtr = (Interp *) interp; const char *elementStr; + /* + * [incr Tcl] does something fairly horrific when generating error + * messages for its ensembles; it passes the whole set of ensemble + * arguments as a list in the first argument. This means that this code + * causes a problem in iTcl if it attempts to correctly quote all + * arguments, which would be the correct thing to do. We work around this + * nasty behaviour for now, and hope that we can remove it all in the + * future... + */ + +#ifndef AVOID_HACKS_FOR_ITCL + int isFirst = 1; /* Special flag used to inhibit the treating + * of the first word as a list element so the + * hacky way Itcl generates error messages for + * its ensembles will still work. [Bug + * 1066837] */ +# define MAY_QUOTE_WORD (!isFirst) +# define AFTER_FIRST_WORD (isFirst = 0) +#else /* !AVOID_HACKS_FOR_ITCL */ +# define MAY_QUOTE_WORD 1 +# define AFTER_FIRST_WORD (void) 0 +#endif /* AVOID_HACKS_FOR_ITCL */ + TclNewObj(objPtr); if (iPtr->flags & INTERP_ALTERNATE_WRONG_ARGS) { iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS; Tcl_AppendObjToObj(objPtr, Tcl_GetObjResult(interp)); Tcl_AppendToObj(objPtr, " or \"", -1); @@ -873,33 +923,36 @@ for (i=0 ; itwoPtrValue.ptr1; + if (origObjv[i]->typePtr == &indexType) { + register IndexRep *indexRep = + origObjv[i]->internalRep.twoPtrValue.ptr1; elementStr = EXPAND_OF(indexRep); elemLen = strlen(elementStr); } else { elementStr = TclGetStringFromObj(origObjv[i], &elemLen); } flags = 0; len = TclScanElement(elementStr, elemLen, &flags); - if (len != elemLen) { - char *quotedElementStr = TclStackAlloc(interp, len + 1); + if (MAY_QUOTE_WORD && len != elemLen) { + char *quotedElementStr = TclStackAlloc(interp, + (unsigned)len + 1); len = TclConvertElement(elementStr, elemLen, quotedElementStr, flags); Tcl_AppendToObj(objPtr, quotedElementStr, len); TclStackFree(interp, quotedElementStr); } else { Tcl_AppendToObj(objPtr, elementStr, elemLen); } + + AFTER_FIRST_WORD; /* * Add a space if the word is not the last one (which has a * moderately complex condition here). */ @@ -920,14 +973,13 @@ /* * If the object is an index type use the index table which allows for * the correct error message even if the subcommand was abbreviated. * Otherwise, just use the string rep. */ - const Tcl_ObjIntRep *irPtr; - if ((irPtr = TclFetchIntRep(objv[i], &indexType))) { - register IndexRep *indexRep = irPtr->twoPtrValue.ptr1; + if (objv[i]->typePtr == &indexType) { + register IndexRep *indexRep = objv[i]->internalRep.twoPtrValue.ptr1; Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), NULL); } else { /* * Quote the argument if it contains spaces (Bug 942757). @@ -935,21 +987,24 @@ elementStr = TclGetStringFromObj(objv[i], &elemLen); flags = 0; len = TclScanElement(elementStr, elemLen, &flags); - if (len != elemLen) { - char *quotedElementStr = TclStackAlloc(interp, len + 1); + if (MAY_QUOTE_WORD && len != elemLen) { + char *quotedElementStr = TclStackAlloc(interp, + (unsigned) len + 1); len = TclConvertElement(elementStr, elemLen, quotedElementStr, flags); Tcl_AppendToObj(objPtr, quotedElementStr, len); TclStackFree(interp, quotedElementStr); } else { Tcl_AppendToObj(objPtr, elementStr, elemLen); } } + + AFTER_FIRST_WORD; /* * Append a space character (" ") if there is more text to follow * (either another element from objv, or the message string). */ @@ -969,10 +1024,12 @@ Tcl_AppendStringsToObj(objPtr, message, NULL); } Tcl_AppendStringsToObj(objPtr, "\"", NULL); Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); Tcl_SetObjResult(interp, objPtr); +#undef MAY_QUOTE_WORD +#undef AFTER_FIRST_WORD } /* *---------------------------------------------------------------------- * @@ -1027,11 +1084,11 @@ * from objv. */ int dstIndex; /* Used to keep track of current arguments * being processed, primarily for error * reporting. */ int objc; /* # arguments in objv still to process. */ - size_t length; /* Number of characters in current argument */ + int length; /* Number of characters in current argument */ if (remObjv != NULL) { /* * Then we should copy the name of the command (0th argument). The * upper bound on the number of elements is known, and (undocumented, @@ -1038,11 +1095,11 @@ * but historically true) there should be a NULL argument after the * last result. [Bug 3413857] */ nrem = 1; - leftovers = Tcl_Alloc((1 + *objcPtr) * sizeof(Tcl_Obj *)); + leftovers = ckalloc((1 + *objcPtr) * sizeof(Tcl_Obj *)); leftovers[0] = objv[0]; } else { nrem = 0; leftovers = NULL; } @@ -1056,11 +1113,11 @@ while (objc > 0) { curArg = objv[srcIndex]; srcIndex++; objc--; - str = TclGetStringFromObj(curArg, &length); + str = Tcl_GetStringFromObj(curArg, &length); if (length > 0) { c = str[1]; } else { c = 0; } @@ -1124,11 +1181,11 @@ } if (Tcl_GetIntFromObj(interp, objv[srcIndex], (int *) infoPtr->dstPtr) == TCL_ERROR) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected integer argument for \"%s\" but got \"%s\"", - infoPtr->keyStr, TclGetString(objv[srcIndex]))); + infoPtr->keyStr, Tcl_GetString(objv[srcIndex]))); goto error; } srcIndex++; objc--; break; @@ -1135,11 +1192,11 @@ case TCL_ARGV_STRING: if (objc == 0) { goto missingArg; } *((const char **) infoPtr->dstPtr) = - TclGetString(objv[srcIndex]); + Tcl_GetString(objv[srcIndex]); srcIndex++; objc--; break; case TCL_ARGV_REST: /* @@ -1157,11 +1214,11 @@ } if (Tcl_GetDoubleFromObj(interp, objv[srcIndex], (double *) infoPtr->dstPtr) == TCL_ERROR) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected floating-point argument for \"%s\" but got \"%s\"", - infoPtr->keyStr, TclGetString(objv[srcIndex]))); + infoPtr->keyStr, Tcl_GetString(objv[srcIndex]))); goto error; } srcIndex++; objc--; break; @@ -1222,11 +1279,11 @@ memcpy(leftovers+nrem, objv+srcIndex, objc*sizeof(Tcl_Obj *)); nrem += objc; } leftovers[nrem] = NULL; *objcPtr = nrem++; - *remObjv = Tcl_Realloc(leftovers, nrem * sizeof(Tcl_Obj *)); + *remObjv = ckrealloc(leftovers, nrem * sizeof(Tcl_Obj *)); return TCL_OK; /* * Make sure to handle freeing any temporary space we've allocated on the * way to an error. @@ -1235,11 +1292,11 @@ missingArg: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" option requires an additional argument", str)); error: if (leftovers != NULL) { - Tcl_Free(leftovers); + ckfree(leftovers); } return TCL_ERROR; } /* @@ -1279,17 +1336,17 @@ * everything line up. */ width = 4; for (infoPtr = argTable; infoPtr->type != TCL_ARGV_END; infoPtr++) { - size_t length; + int length; if (infoPtr->keyStr == NULL) { continue; } length = strlen(infoPtr->keyStr); - if (length > (size_t)width) { + if (length > width) { width = length; } } /* @@ -1365,11 +1422,11 @@ { static const char *const returnCodes[] = { "ok", "error", "return", "break", "continue", NULL }; - if (!TclHasIntRep(value, &indexType) + if ((value->typePtr != &indexType) && TclGetIntFromObj(NULL, value, codePtr) == TCL_OK) { return TCL_OK; } if (Tcl_GetIndexFromObj(NULL, value, returnCodes, NULL, TCL_EXACT, codePtr) == TCL_OK) { Index: generic/tclInt.decls ================================================================== --- generic/tclInt.decls +++ generic/tclInt.decls @@ -46,17 +46,16 @@ } declare 6 { void TclCleanupCommand(Command *cmdPtr) } declare 7 { - size_t TclCopyAndCollapse(size_t count, const char *src, char *dst) + int TclCopyAndCollapse(int count, const char *src, char *dst) } -# Removed in 9.0: -#declare 8 { -# int TclCopyChannelOld(Tcl_Interp *interp, Tcl_Channel inChan, -# Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr) -#} +declare 8 { + int TclCopyChannelOld(Tcl_Interp *interp, Tcl_Channel inChan, + Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr) +} # TclCreatePipeline unofficially exported for use by BLT. declare 9 { int TclCreatePipeline(Tcl_Interp *interp, int argc, const char **argv, @@ -78,11 +77,11 @@ #declare 13 { # int TclDoGlob(Tcl_Interp *interp, char *separators, # Tcl_DString *headPtr, char *tail, Tcl_GlobTypeData *types) #} declare 14 { - int TclDumpMemoryInfo(void *clientData, int flags) + int TclDumpMemoryInfo(ClientData clientData, int flags) } # Removed in 8.1: # declare 15 { # void TclExpandParseValue(ParseValue *pvPtr, int needed) # } @@ -106,18 +105,18 @@ # int TclFileRenameCmd(Tcl_Interp *interp, int argc, char **argv) #} declare 22 { int TclFindElement(Tcl_Interp *interp, const char *listStr, int listLength, const char **elementPtr, const char **nextPtr, - size_t *sizePtr, int *bracePtr) + int *sizePtr, int *bracePtr) } declare 23 { Proc *TclFindProc(Interp *iPtr, const char *procName) } # Replaced with macro (see tclInt.h) in Tcl 8.5.0, restored in 8.5.10 declare 24 { - size_t TclFormatInt(char *buffer, Tcl_WideInt n) + int TclFormatInt(char *buffer, long n) } declare 25 { void TclFreePackageInfo(Interp *iPtr) } # Removed in 8.1: @@ -150,21 +149,20 @@ } # Removed in 8.5: #declare 33 { # TclCmdProcType TclGetInterpProc(void) #} -# Removed in 9.0: -#declare 34 {deprecated {Use Tcl_GetIntForIndex}} { -# int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, -# int endValue, int *indexPtr) -#} +declare 34 { + int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, + int endValue, int *indexPtr) +} # Removed in 8.4b2: #declare 35 { # Tcl_Obj *TclGetIndexedScalar(Tcl_Interp *interp, int localIndex, # int flags) #} -# Removed in 8.6a2: +# Removed in 8.6a2 #declare 36 { # int TclGetLong(Tcl_Interp *interp, const char *str, long *longPtr) #} declare 37 { int TclGetLoadedPackages(Tcl_Interp *interp, const char *targetName) @@ -183,11 +181,11 @@ } declare 41 { Tcl_Command TclGetOriginalCommand(Tcl_Command command) } declare 42 { - const char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr) + CONST86 char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr) } # Removed in 8.5a2: #declare 43 { # int TclGlobalInvoke(Tcl_Interp *interp, int argc, const char **argv, # int flags) @@ -226,15 +224,15 @@ #declare 52 { # int TclInvoke(Tcl_Interp *interp, int argc, const char **argv, # int flags) #} declare 53 { - int TclInvokeObjectCommand(void *clientData, Tcl_Interp *interp, - int argc, const char **argv) + int TclInvokeObjectCommand(ClientData clientData, Tcl_Interp *interp, + int argc, CONST84 char **argv) } declare 54 { - int TclInvokeStringCommand(void *clientData, Tcl_Interp *interp, + int TclInvokeStringCommand(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) } declare 55 { Proc *TclIsProc(Command *cmdPtr) } @@ -266,11 +264,11 @@ } declare 62 { int TclObjCommandComplete(Tcl_Obj *cmdPtr) } declare 63 { - int TclObjInterpProc(void *clientData, Tcl_Interp *interp, + int TclObjInterpProc(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) } declare 64 { int TclObjInvoke(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags) @@ -289,11 +287,11 @@ # Replaced by Tcl_FSAccess in 8.4: #declare 68 { # int TclpAccess(const char *path, int mode) #} declare 69 { - void *TclpAlloc(size_t size) + char *TclpAlloc(unsigned int size) } #declare 70 { # int TclpCopyFile(const char *source, const char *dest) #} #declare 71 { @@ -305,23 +303,23 @@ #} #declare 73 { # int TclpDeleteFile(const char *path) #} declare 74 { - void TclpFree(void *ptr) + void TclpFree(char *ptr) } declare 75 { - Tcl_WideUInt TclpGetClicks(void) + unsigned long TclpGetClicks(void) } declare 76 { - Tcl_WideUInt TclpGetSeconds(void) + unsigned long TclpGetSeconds(void) } -# Removed in 9.0: -#declare 77 { -# void TclpGetTime(Tcl_Time *time) -#} +# deprecated +declare 77 { + void TclpGetTime(Tcl_Time *time) +} # Removed in 8.6: #declare 78 { # int TclpGetTimeZone(unsigned long time) #} # Replaced by Tcl_FSListVolumes in 8.4: @@ -332,11 +330,11 @@ #declare 80 { # Tcl_Channel TclpOpenFileChannel(Tcl_Interp *interp, char *fileName, # char *modeString, int permissions) #} declare 81 { - void *TclpRealloc(void *ptr, size_t size) + char *TclpRealloc(char *ptr, unsigned int size) } #declare 82 { # int TclpRemoveDirectory(const char *path, int recursive, # Tcl_DString *errorPtr) #} @@ -357,15 +355,14 @@ # int flags, char **termPtr, ParseValue *pvPtr) # } # declare 87 { # void TclPlatformInit(Tcl_Interp *interp) # } -# Removed in 9.0: -#declare 88 { -# char *TclPrecTraceProc(void *clientData, Tcl_Interp *interp, -# const char *name1, const char *name2, int flags) -#} +declare 88 { + char *TclPrecTraceProc(ClientData clientData, Tcl_Interp *interp, + const char *name1, const char *name2, int flags) +} declare 89 { int TclPreventAliasLoop(Tcl_Interp *interp, Tcl_Interp *cmdInterp, Tcl_Command cmd) } # Removed in 8.1 (only available if compiled with TCL_COMPILE_DEBUG): @@ -379,11 +376,11 @@ int TclProcCompileProc(Tcl_Interp *interp, Proc *procPtr, Tcl_Obj *bodyPtr, Namespace *nsPtr, const char *description, const char *procName) } declare 93 { - void TclProcDeleteProc(void *clientData) + void TclProcDeleteProc(ClientData clientData) } # Removed in 8.5: #declare 94 { # int TclProcInterpProc(void *clientData, Tcl_Interp *interp, # int argc, const char **argv) @@ -411,23 +408,22 @@ #declare 100 { # Tcl_Obj *TclSetIndexedScalar(Tcl_Interp *interp, int localIndex, # Tcl_Obj *objPtr, int flags) #} declare 101 { - const char *TclSetPreInitScript(const char *string) + CONST86 char *TclSetPreInitScript(const char *string) } declare 102 { void TclSetupEnv(Tcl_Interp *interp) } declare 103 { int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto, int *portPtr) } -# Removed in 9.0: -#declare 104 { -# int TclSockMinimumBuffersOld(int sock, int size) -#} +declare 104 { + int TclSockMinimumBuffersOld(int sock, int size) +} # Replaced by Tcl_FSStat in 8.4: #declare 105 { # int TclStat(const char *path, Tcl_StatBuf *buf) #} #declare 106 { @@ -456,39 +452,33 @@ declare 111 { void Tcl_AddInterpResolvers(Tcl_Interp *interp, const char *name, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc) } -# Removed in 9.0: -#declare 112 { -# int Tcl_AppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, -# Tcl_Obj *objPtr) -#} -# Removed in 9.0: -#declare 113 { -# Tcl_Namespace *Tcl_CreateNamespace(Tcl_Interp *interp, const char *name, -# void *clientData, Tcl_NamespaceDeleteProc *deleteProc) -#} -# Removed in 9.0: -#declare 114 { -# void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr) -#} -# Removed in 9.0: -#declare 115 { -# int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr, -# const char *pattern, int resetListFirst) -#} -# Removed in 9.0: -#declare 116 { -# Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name, -# Tcl_Namespace *contextNsPtr, int flags) -#} -# Removed in 9.0: -#declare 117 { -# Tcl_Namespace *Tcl_FindNamespace(Tcl_Interp *interp, const char *name, -# Tcl_Namespace *contextNsPtr, int flags) -#} +declare 112 { + int Tcl_AppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + Tcl_Obj *objPtr) +} +declare 113 { + Tcl_Namespace *Tcl_CreateNamespace(Tcl_Interp *interp, const char *name, + ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc) +} +declare 114 { + void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr) +} +declare 115 { + int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + const char *pattern, int resetListFirst) +} +declare 116 { + Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name, + Tcl_Namespace *contextNsPtr, int flags) +} +declare 117 { + Tcl_Namespace *Tcl_FindNamespace(Tcl_Interp *interp, const char *name, + Tcl_Namespace *contextNsPtr, int flags) +} declare 118 { int Tcl_GetInterpResolvers(Tcl_Interp *interp, const char *name, Tcl_ResolverInfo *resInfo) } declare 119 { @@ -497,41 +487,35 @@ } declare 120 { Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags) } -# Removed in 9.0: -#declare 121 { -# int Tcl_ForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, -# const char *pattern) -#} -# Removed in 9.0: -#declare 122 { -# Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr) -#} -# Removed in 9.0: -#declare 123 { -# void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command, -# Tcl_Obj *objPtr) -#} -# Removed in 9.0: -#declare 124 { -# Tcl_Namespace *Tcl_GetCurrentNamespace(Tcl_Interp *interp) -#} -# Removed in 9.0: -#declare 125 { -# Tcl_Namespace *Tcl_GetGlobalNamespace(Tcl_Interp *interp) -#} +declare 121 { + int Tcl_ForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + const char *pattern) +} +declare 122 { + Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr) +} +declare 123 { + void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command, + Tcl_Obj *objPtr) +} +declare 124 { + Tcl_Namespace *Tcl_GetCurrentNamespace(Tcl_Interp *interp) +} +declare 125 { + Tcl_Namespace *Tcl_GetGlobalNamespace(Tcl_Interp *interp) +} declare 126 { void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr) } -# Removed in 9.0: -#declare 127 { -# int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr, -# const char *pattern, int allowOverwrite) -#} +declare 127 { + int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + const char *pattern, int allowOverwrite) +} declare 128 { void Tcl_PopCallFrame(Tcl_Interp *interp) } declare 129 { int Tcl_PushCallFrame(Tcl_Interp *interp, Tcl_CallFrame *framePtr, @@ -546,14 +530,13 @@ Tcl_ResolveCompiledVarProc *compiledVarProc) } declare 132 { int TclpHasSockets(Tcl_Interp *interp) } -# Removed in 9.0 -#declare 133 { -# struct tm *TclpGetDate(const time_t *time, int useGMT) -#} +declare 133 { + struct tm *TclpGetDate(const time_t *time, int useGMT) +} # Removed in 8.5 #declare 134 { # size_t TclpStrftime(char *s, size_t maxsize, const char *format, # const struct tm *t, int useGMT) #} @@ -565,11 +548,11 @@ #declare 137 { # int TclpChdir(const char *dirName) #} declare 138 { - const char *TclGetEnv(const char *name, Tcl_DString *valuePtr) + CONST84_RETURN char *TclGetEnv(const char *name, Tcl_DString *valuePtr) } #declare 139 { # int TclpLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, # char *sym2, Tcl_PackageInitProc **proc1Ptr, # Tcl_PackageInitProc **proc2Ptr, void **clientDataPtr) @@ -577,15 +560,15 @@ #declare 140 { # int TclLooksLikeInt(const char *bytes, int length) #} # This is used by TclX, but should otherwise be considered private declare 141 { - const char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr) + CONST84_RETURN char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr) } declare 142 { int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr, - CompileHookProc *hookProc, void *clientData) + CompileHookProc *hookProc, ClientData clientData) } declare 143 { int TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr) } @@ -613,12 +596,12 @@ declare 150 { int TclRegAbout(Tcl_Interp *interp, Tcl_RegExp re) } declare 151 { - void TclRegExpRangeUniChar(Tcl_RegExp re, size_t index, size_t *startPtr, - size_t *endPtr) + void TclRegExpRangeUniChar(Tcl_RegExp re, int index, int *startPtr, + int *endPtr) } declare 152 { void TclSetLibraryPath(Tcl_Obj *pathPtr) } declare 153 { @@ -640,18 +623,18 @@ int status) } declare 157 { Var *TclVarTraceExists(Tcl_Interp *interp, const char *varName) } -# REMOVED - use public Tcl_SetStartupScript() -#declare 158 { -# void TclSetStartupScriptFileName(const char *filename) -#} -# REMOVED - use public Tcl_GetStartupScript() -#declare 159 { -# const char *TclGetStartupScriptFileName(void) -#} +# REMOVED (except from stub table) - use public Tcl_SetStartupScript() +declare 158 { + void TclSetStartupScriptFileName(const char *filename) +} +# REMOVED (except from stub table) - use public Tcl_GetStartupScript() +declare 159 { + const char *TclGetStartupScriptFileName(void) +} #declare 160 { # int TclpMatchFilesTypes(Tcl_Interp *interp, char *separators, # Tcl_DString *dirPtr, char *pattern, char *tail, # GlobTypeData *types) #} @@ -660,11 +643,11 @@ declare 161 { int TclChannelTransform(Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr) } declare 162 { - void TclChannelEventScriptInvoker(void *clientData, int flags) + void TclChannelEventScriptInvoker(ClientData clientData, int flags) } # ALERT: The result of 'TclGetInstructionTable' is actually a # "const InstructionDesc*" but we do not want to describe this structure in # "tclInt.h". It is described in "tclCompile.h". Use a cast to the @@ -692,41 +675,41 @@ int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr) } # VFS-aware versions of Tcl*StartupScriptFileName (158 and 159 above) -# REMOVED - use public Tcl_SetStartupScript() -#declare 167 { -# void TclSetStartupScriptPath(Tcl_Obj *pathPtr) -#} -# REMOVED - use public Tcl_GetStartupScript() -#declare 168 { -# Tcl_Obj *TclGetStartupScriptPath(void) -#} +# REMOVED (except from stub table) - use public Tcl_SetStartupScript() +declare 167 { + void TclSetStartupScriptPath(Tcl_Obj *pathPtr) +} +# REMOVED (except from stub table) - use public Tcl_GetStartupScript() +declare 168 { + Tcl_Obj *TclGetStartupScriptPath(void) +} # variant of Tcl_UtfNCmp that takes n as bytes, not chars declare 169 { - int TclpUtfNcmp2(const char *s1, const char *s2, size_t n) + int TclpUtfNcmp2(const char *s1, const char *s2, unsigned long n) } declare 170 { int TclCheckInterpTraces(Tcl_Interp *interp, const char *command, - size_t numChars, Command *cmdPtr, int result, int traceFlags, + int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]) } declare 171 { int TclCheckExecutionTraces(Tcl_Interp *interp, const char *command, - size_t numChars, Command *cmdPtr, int result, int traceFlags, + int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]) } declare 172 { int TclInThreadExit(void) } # added for 8.4.2 declare 173 { - int TclUniCharMatch(const Tcl_UniChar *string, size_t strLen, - const Tcl_UniChar *pattern, size_t ptnLen, int flags) + int TclUniCharMatch(const Tcl_UniChar *string, int strLen, + const Tcl_UniChar *pattern, int ptnLen, int flags) } # added for 8.4.3 #declare 174 { @@ -745,17 +728,17 @@ } declare 177 { void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason) } -# TIP 338 made these public - now declared in tcl.h -#declare 178 { -# void Tcl_SetStartupScript(Tcl_Obj *pathPtr, const char *encodingName) -#} -#declare 179 { -# Tcl_Obj *Tcl_GetStartupScript(const char **encodingNamePtr) -#} +# TIP 338 made these public - now declared in tcl.h too +declare 178 { + void Tcl_SetStartupScript(Tcl_Obj *pathPtr, const char *encodingName) +} +declare 179 { + Tcl_Obj *Tcl_GetStartupScript(const char **encodingNamePtr) +} # REMOVED # Allocate lists without copying arrays # declare 180 { # Tcl_Obj *TclNewListObjDirect(int objc, Tcl_Obj **objv) @@ -763,18 +746,18 @@ #declare 181 { # Tcl_Obj *TclDbNewListObjDirect(int objc, Tcl_Obj **objv, # const char *file, int line) #} -# Removed in 9.0 -#declare 182 { -# struct tm *TclpLocaltime(const time_t *clock) -#} -# Removed in 9.0 -#declare 183 { -# struct tm *TclpGmtime(const time_t *clock) -#} +# TclpGmtime and TclpLocaltime promoted to the generic interface from unix + +declare 182 { + struct tm *TclpLocaltime(const time_t *clock) +} +declare 183 { + struct tm *TclpGmtime(const time_t *clock) +} # For the new "Thread Storage" subsystem. ### REMOVED on grounds it should never have been exposed. All these ### functions are now either static in tclThreadStorage.c or @@ -885,11 +868,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, int numBytes) } declare 216 { void TclStackFree(Tcl_Interp *interp, void *freePtr) } declare 217 { @@ -912,17 +895,17 @@ } declare 226 { int TclObjBeingDeleted(Tcl_Obj *objPtr) } declare 227 { - void TclSetNsPath(Namespace *nsPtr, size_t pathLength, + void TclSetNsPath(Namespace *nsPtr, int pathLength, Tcl_Namespace *pathAry[]) } # Used to be needed for TclOO-extension; unneeded now that TclOO is in the # core and NRE-enabled # declare 228 { -# int TclObjInterpProcCore(register Tcl_Interp *interp, Tcl_Obj *procNameObj, +# int TclObjInterpProcCore(Tcl_Interp *interp, Tcl_Obj *procNameObj, # int skip, ProcErrorProc *errorProc) # } declare 229 { int TclPtrMakeUpvar(Tcl_Interp *interp, Var *otherP1Ptr, const char *myName, int myFlags, int index) @@ -955,23 +938,23 @@ void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr) } # TIP 337 made this one public -#declare 236 { -# void TclBackgroundException(Tcl_Interp *interp, int code) -#} +declare 236 { + void TclBackgroundException(Tcl_Interp *interp, int code) +} # TIP #285: Script cancellation support. declare 237 { int TclResetCancellation(Tcl_Interp *interp, int force) } # NRE functions for "rogue" extensions to exploit NRE; they will need to # include NRE.h too. declare 238 { - int TclNRInterpProc(void *clientData, Tcl_Interp *interp, + int TclNRInterpProc(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) } declare 239 { int TclNRInterpProcCore(Tcl_Interp *interp, Tcl_Obj *procNameObj, int skip, ProcErrorProc *errorProc) @@ -1000,12 +983,12 @@ } declare 245 { Tcl_HashTable *TclGetNamespaceCommandTable(Tcl_Namespace *nsPtr) } declare 246 { - int TclInitRewriteEnsemble(Tcl_Interp *interp, size_t numRemoved, - size_t numInserted, Tcl_Obj *const *objv) + int TclInitRewriteEnsemble(Tcl_Interp *interp, int numRemoved, + int numInserted, Tcl_Obj *const *objv) } declare 247 { void TclResetRewriteEnsemble(Tcl_Interp *interp, int isRootEnsemble) } @@ -1024,11 +1007,11 @@ } # Allow extensions for optimization declare 251 { int TclRegisterLiteral(void *envPtr, - const char *bytes, size_t length, int flags) + char *bytes, int length, int flags) } # Exporting of the internal API to variables. declare 252 { @@ -1052,19 +1035,18 @@ } declare 256 { int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags) } + declare 257 { void TclStaticPackage(Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) } -# TIP 431: temporary directory creation function -declare 258 { - Tcl_Obj *TclpCreateTemporaryDirectory(Tcl_Obj *dirObj, - Tcl_Obj *basenameObj) +declare 260 { + void TclUnusedStubEntry(void) } ############################################################################## # Define the platform specific internal Tcl interface. These functions are @@ -1076,24 +1058,21 @@ # Windows specific functions declare 0 win { void TclWinConvertError(DWORD errCode) } -# Removed in 9.0: -#declare 1 win { -# void TclWinConvertWSAError(DWORD errCode) -#} -# Removed in 9.0: -#declare 2 win { -# struct servent *TclWinGetServByName(const char *nm, -# const char *proto) -#} -# Removed in 9.0: -#declare 3 win { -# int TclWinGetSockOpt(SOCKET s, int level, int optname, -# char *optval, int *optlen) -#} +declare 1 win { + void TclWinConvertWSAError(DWORD errCode) +} +declare 2 win { + struct servent *TclWinGetServByName(const char *nm, + const char *proto) +} +declare 3 win { + int TclWinGetSockOpt(SOCKET s, int level, int optname, + char *optval, int *optlen) +} declare 4 win { HINSTANCE TclWinGetTclInstance(void) } # new for 8.4.20+/8.5.12+ Cygwin only declare 5 win { @@ -1101,31 +1080,28 @@ } # Removed in 8.1: # declare 5 win { # HINSTANCE TclWinLoadLibrary(char *name) # } -# Removed in 9.0: -#declare 6 win { -# unsigned short TclWinNToHS(unsigned short ns) -#} -# Removed in 9.0: -#declare 7 win { -# int TclWinSetSockOpt(SOCKET s, int level, int optname, -# const char *optval, int optlen) -#} +declare 6 win { + unsigned short TclWinNToHS(unsigned short ns) +} +declare 7 win { + int TclWinSetSockOpt(SOCKET s, int level, int optname, + const char *optval, int optlen) +} declare 8 win { - size_t TclpGetPid(Tcl_Pid pid) -} -# Removed in 9.0: -#declare 9 win { -# int TclWinGetPlatformId(void) -#} -# Removed in 9.0: -#declare 10 win { -# Tcl_DirEntry *TclpReaddir(TclDIR *dir) -#} -# Removed in 8.3.1 (for Win32s only): + int TclpGetPid(Tcl_Pid pid) +} +declare 9 win { + int TclWinGetPlatformId(void) +} +# new for 8.4.20+/8.5.12+ Cygwin only +declare 10 win { + Tcl_DirEntry *TclpReaddir(TclDIR *dir) +} +# Removed in 8.3.1 (for Win32s only) #declare 10 win { # int TclWinSynchSpawn(void *args, int type, void **trans, Tcl_Pid *pidPtr) #} # Pipe channel functions @@ -1169,16 +1145,16 @@ } declare 19 win { TclFile TclpOpenFile(const char *fname, int mode) } declare 20 win { - void TclWinAddProcess(HANDLE hProcess, size_t id) + void TclWinAddProcess(HANDLE hProcess, DWORD id) } -# Removed in 9.0: -#declare 21 win { -# char *TclpInetNtoa(struct in_addr addr) -#} +# new for 8.4.20+/8.5.12+ +declare 21 win { + char *TclpInetNtoa(struct in_addr addr) +} # removed permanently for 8.4 #declare 21 win { # void TclpAsyncMark(Tcl_AsyncHandler async) #} @@ -1195,27 +1171,25 @@ } # replaced by generic TclGetPlatform #declare 25 win { # TclPlatformType *TclWinGetPlatform(void) #} -# Removed in 9.0: -#declare 26 win { -# void TclWinSetInterfaces(int wide) -#} +declare 26 win { + void TclWinSetInterfaces(int wide) +} # Added in Tcl 8.3.3 / 8.4 declare 27 win { void TclWinFlushDirtyChannels(void) } # Added in 8.4.2 -# Removed in 9.0: -#declare 28 win { -# void TclWinResetInterfaces(void) -#} +declare 28 win { + void TclWinResetInterfaces(void) +} ################################ # Unix specific functions # Pipe channel functions @@ -1236,14 +1210,13 @@ declare 4 unix { int TclpCreateProcess(Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr) } -# Signature changed in 8.1: -# declare 5 unix { -# TclFile TclpCreateTempFile(char *contents, Tcl_DString *namePtr) -# } +declare 5 unix { + int TclUnixWaitForFile_(int fd, int mask, int timeout) +} declare 6 unix { TclFile TclpMakeFile(Tcl_Channel channel, int direction) } declare 7 unix { TclFile TclpOpenFile(const char *fname, int mode) @@ -1258,26 +1231,24 @@ TclFile TclpCreateTempFile(const char *contents) } # Added in 8.4: -# Removed in 9.0: -#declare 10 unix { -# Tcl_DirEntry *TclpReaddir(TclDIR *dir) -#} -# Removed in 9.0: -#declare 11 unix { -# struct tm *TclpLocaltime_unix(const time_t *clock) -#} -# Removed in 9.0: -#declare 12 unix { -# struct tm *TclpGmtime_unix(const time_t *clock) -#} -# Removed in 9.0: -#declare 13 unix { -# char *TclpInetNtoa(struct in_addr addr) -#} +declare 10 unix { + Tcl_DirEntry *TclpReaddir(TclDIR *dir) +} +# Slots 11 and 12 are forwarders for functions that were promoted to +# generic Stubs +declare 11 unix { + struct tm *TclpLocaltime_unix(const time_t *clock) +} +declare 12 unix { + struct tm *TclpGmtime_unix(const time_t *clock) +} +declare 13 unix { + char *TclpInetNtoa(struct in_addr addr) +} # Added in 8.5: declare 14 unix { int TclUnixCopyFile(const char *src, const char *dst, @@ -1285,40 +1256,41 @@ } ################################ # Mac OS X specific functions -declare 15 macosx { +declare 15 {unix macosx} { int TclMacOSXGetFileAttribute(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr) } -declare 16 macosx { +declare 16 {unix macosx} { int TclMacOSXSetFileAttribute(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr) } -declare 17 macosx { +declare 17 {unix macosx} { int TclMacOSXCopyFileAttributes(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr) } -declare 18 macosx { +declare 18 {unix macosx} { int TclMacOSXMatchType(Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types) } -declare 19 macosx { +declare 19 {unix macosx} { void TclMacOSXNotifierAddRunLoopMode(const void *runLoopMode) } +declare 22 {unix macosx} { + TclFile TclpCreateTempFile_(const char *contents) +} declare 29 {win unix} { - int TclWinCPUID(int index, int *regs) + int TclWinCPUID(unsigned int index, unsigned int *regs) } # Added in 8.6; core of TclpOpenTemporaryFile declare 30 {win unix} { int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj) } - - # Local Variables: # mode: tcl # End: Index: generic/tclInt.h ================================================================== --- generic/tclInt.h +++ generic/tclInt.h @@ -23,24 +23,10 @@ * Some numerics configuration options. */ #undef ACCEPT_NAN -/* - * Used to tag functions that are only to be visible within the module being - * built and not outside it (where this is supported by the linker). - * Also used in the platform-specific *Port.h files. - */ - -#ifndef MODULE_SCOPE -# ifdef __cplusplus -# define MODULE_SCOPE extern "C" -# else -# define MODULE_SCOPE extern -# endif -#endif - /* * Common include files needed by most of the Tcl source files are included * here, so that system-dependent personalizations for the include files only * have to be made in once place. This results in a few extra includes, but * greater modularity. The order of the three groups of #includes is @@ -50,11 +36,10 @@ #include "tclPort.h" #include #include -#include #ifdef NO_STDLIB_H # include "../compat/stdlib.h" #else # include #endif @@ -94,59 +79,52 @@ # undef WORDS_BIGENDIAN # endif # endif #endif +/* + * Used to tag functions that are only to be visible within the module being + * built and not outside it (where this is supported by the linker). + */ + +#ifndef MODULE_SCOPE +# ifdef __cplusplus +# define MODULE_SCOPE extern "C" +# else +# define MODULE_SCOPE extern +# endif +#endif + /* * Macros used to cast between pointers and integers (e.g. when storing an int * in ClientData), on 64-bit architectures they avoid gcc warning about "cast * to/from pointer from/to integer of different size". */ #if !defined(INT2PTR) && !defined(PTR2INT) # if defined(HAVE_INTPTR_T) || defined(intptr_t) # define INT2PTR(p) ((void *)(intptr_t)(p)) -# define PTR2INT(p) ((intptr_t)(p)) +# define PTR2INT(p) ((int)(intptr_t)(p)) # else # define INT2PTR(p) ((void *)(p)) -# define PTR2INT(p) ((long)(p)) +# define PTR2INT(p) ((int)(p)) # endif #endif #if !defined(UINT2PTR) && !defined(PTR2UINT) # if defined(HAVE_UINTPTR_T) || defined(uintptr_t) # define UINT2PTR(p) ((void *)(uintptr_t)(p)) -# define PTR2UINT(p) ((uintptr_t)(p)) +# define PTR2UINT(p) ((unsigned int)(uintptr_t)(p)) # else # define UINT2PTR(p) ((void *)(p)) -# define PTR2UINT(p) ((unsigned long)(p)) +# define PTR2UINT(p) ((unsigned int)(p)) # endif #endif #if defined(_WIN32) && defined(_MSC_VER) # define vsnprintf _vsnprintf #endif -#if !defined(TCL_THREADS) -# define TCL_THREADS 1 -#endif -#if !TCL_THREADS -# undef TCL_DECLARE_MUTEX -# define TCL_DECLARE_MUTEX(name) -# undef Tcl_MutexLock -# define Tcl_MutexLock(mutexPtr) -# undef Tcl_MutexUnlock -# define Tcl_MutexUnlock(mutexPtr) -# undef Tcl_MutexFinalize -# define Tcl_MutexFinalize(mutexPtr) -# undef Tcl_ConditionNotify -# define Tcl_ConditionNotify(condPtr) -# undef Tcl_ConditionWait -# define Tcl_ConditionWait(condPtr, mutexPtr, timePtr) -# undef Tcl_ConditionFinalize -# define Tcl_ConditionFinalize(condPtr) -#endif - /* * The following procedures allow namespaces to be customized to support * special name resolution rules for commands/variables. */ @@ -167,17 +145,17 @@ Tcl_ResolveRuntimeVarProc *fetchProc; Tcl_ResolveVarDeleteProc *deleteProc; } Tcl_ResolvedVarInfo; typedef int (Tcl_ResolveCompiledVarProc)(Tcl_Interp *interp, - const char *name, int length, Tcl_Namespace *context, + CONST84 char *name, int length, Tcl_Namespace *context, Tcl_ResolvedVarInfo **rPtr); -typedef int (Tcl_ResolveVarProc)(Tcl_Interp *interp, const char *name, +typedef int (Tcl_ResolveVarProc)(Tcl_Interp *interp, CONST84 char *name, Tcl_Namespace *context, int flags, Tcl_Var *rPtr); -typedef int (Tcl_ResolveCmdProc)(Tcl_Interp *interp, const char *name, +typedef int (Tcl_ResolveCmdProc)(Tcl_Interp *interp, CONST84 char *name, Tcl_Namespace *context, int flags, Tcl_Command *rPtr); typedef struct Tcl_ResolverInfo { Tcl_ResolveCmdProc *cmdResProc; /* Procedure handling command name @@ -197,10 +175,13 @@ * lookup is performed for upvar (or similar) purposes, with slightly * different rules: * - Bug #696893 - variable is either proc-local or in the current * namespace; never follow the second (global) resolution path * - Bug #631741 - do not use special namespace or interp resolvers + * + * It should also not collide with the (deprecated) TCL_PARSE_PART1 flag + * (Bug #835020) */ #define TCL_AVOID_RESOLVERS 0x40000 /* @@ -252,11 +233,11 @@ * This contains no ::'s. The name of the * global namespace is "" although "::" is an * synonym. */ char *fullName; /* The namespace's fully qualified name. This * starts with ::. */ - void *clientData; /* An arbitrary value associated with this + ClientData clientData; /* An arbitrary value associated with this * namespace. */ Tcl_NamespaceDeleteProc *deleteProc; /* Procedure invoked when deleting the * namespace to, e.g., free clientData. */ struct Namespace *parentPtr;/* Points to the namespace that contains this @@ -269,20 +250,20 @@ Tcl_HashTable *childTablePtr; /* Contains any child namespaces. Indexed by * strings; values have type (Namespace *). If * NULL, there are no children. */ #endif - size_t nsId; /* Unique id for the namespace. */ - Tcl_Interp *interp; /* The interpreter containing this + long nsId; /* Unique id for the namespace. */ + 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. */ - size_t activationCount; /* Number of "activations" or active call + int activationCount; /* Number of "activations" or active call * frames for this namespace that are on the * Tcl call stack. The namespace won't be * freed until activationCount becomes zero. */ - size_t refCount; /* Count of references by namespaceName + int refCount; /* Count of references by namespaceName * objects. The namespace can't be freed until * refCount becomes zero. */ Tcl_HashTable cmdTable; /* Contains all the commands currently * registered in the namespace. Indexed by * strings; values have type (Command *). @@ -299,20 +280,20 @@ * pattern may include "string match" style * wildcard characters to specify multiple * commands; however, no namespace qualifiers * are allowed. NULL if no export patterns are * registered. */ - size_t numExportPatterns; /* Number of export patterns currently + int numExportPatterns; /* Number of export patterns currently * registered using "namespace export". */ - size_t maxExportPatterns; /* Number of export patterns for which space + int maxExportPatterns; /* Mumber of export patterns for which space * is currently allocated. */ - size_t cmdRefEpoch; /* Incremented if a newly added command + int cmdRefEpoch; /* Incremented if a newly added command * shadows a command for which this namespace * has already cached a Command* pointer; this * causes all its cached Command* pointers to * be invalidated. */ - size_t resolverEpoch; /* Incremented whenever (a) the name + int resolverEpoch; /* Incremented whenever (a) the name * resolution rules change for this namespace * or (b) a newly added command shadows a * command that is compiled to bytecodes. This * invalidates all byte codes compiled in the * namespace, causing the code to be @@ -335,11 +316,11 @@ * usual variable resolution mechanism in Tcl. * This procedure is invoked within * LookupCompiledLocal to resolve variable * references within the namespace at compile * time. */ - size_t exportLookupEpoch; /* Incremented whenever a command is added to + int exportLookupEpoch; /* Incremented whenever a command is added to * a namespace, removed from a namespace or * the exports of a namespace are changed. * Allows TIP#112-driven command lists to be * validated efficiently. */ Tcl_Ensemble *ensembles; /* List of structures that contain the details @@ -346,11 +327,11 @@ * of the ensembles that are implemented on * top of this namespace. */ Tcl_Obj *unknownHandlerPtr; /* A script fragment to be used when command * resolution in this namespace fails. TIP * 181. */ - size_t commandPathLength; /* The length of the explicit path. */ + int commandPathLength; /* The length of the explicit path. */ NamespacePathEntry *commandPathArray; /* The explicit path of the namespace as an * array. */ NamespacePathEntry *commandPathSourceList; /* Linked list of path entries that point to @@ -436,11 +417,11 @@ Tcl_Command token; /* The token for the command that provides * ensemble support for the namespace, or NULL * if the command has been deleted (or never * existed; the global namespace never has an * ensemble command.) */ - size_t epoch; /* The epoch at which this ensemble's table of + int epoch; /* The epoch at which this ensemble's table of * exported commands is valid. */ char **subcommandArrayPtr; /* Array of ensemble subcommand names. At all * consistent points, this will have the same * number of entries as there are entries in * the subcommandTable hash. */ @@ -523,11 +504,11 @@ */ typedef struct VarTrace { Tcl_VarTraceProc *traceProc;/* Procedure to call when operations given by * flags are performed on variable. */ - void *clientData; /* Argument to pass to proc. */ + ClientData clientData; /* Argument to pass to proc. */ int flags; /* What events the trace procedure is * interested in: OR-ed combination of * TCL_TRACE_READS, TCL_TRACE_WRITES, * TCL_TRACE_UNSETS and TCL_TRACE_ARRAY. */ struct VarTrace *nextPtr; /* Next in list of traces associated with a @@ -542,18 +523,18 @@ typedef struct CommandTrace { Tcl_CommandTraceProc *traceProc; /* Procedure to call when operations given by * flags are performed on command. */ - void *clientData; /* Argument to pass to proc. */ + ClientData clientData; /* Argument to pass to proc. */ int flags; /* What events the trace procedure is * interested in: OR-ed combination of * TCL_TRACE_RENAME, TCL_TRACE_DELETE. */ struct CommandTrace *nextPtr; /* Next in list of traces associated with a * particular command. */ - size_t refCount; /* Used to ensure this structure is not + int 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. */ } CommandTrace; @@ -612,21 +593,21 @@ Tcl_Obj *objPtr; /* The variable's object value. Used for * scalar variables and array elements. */ TclVarHashTable *tablePtr;/* For array variables, this points to * information about the hash table used to * implement the associative array. Points to - * Tcl_Alloc-ed data. */ + * ckalloc-ed data. */ struct Var *linkPtr; /* If this is a global variable being referred * to in a procedure, or a variable created by * "upvar", this field points to the * referenced variable's Var struct. */ } value; } Var; typedef struct VarInHash { Var var; - size_t refCount; /* Counts number of active uses of this + int refCount; /* Counts number of active uses of this * variable: 1 for the entry in the hash * table, 1 for each additional variable whose * linkPtr points here, 1 for each nested * trace active on variable, and 1 if the * variable is a namespace variable. This @@ -894,10 +875,16 @@ * Data structures related to procedures. These are used primarily in * tclProc.c, tclCompile.c, and tclExecute.c. *---------------------------------------------------------------- */ +#if defined(__GNUC__) && (__GNUC__ > 2) +# define TCLFLEXARRAY 0 +#else +# define TCLFLEXARRAY 1 +#endif + /* * Forward declaration to prevent an error when the forward reference to * Command is encountered in the Proc and ImportRef types declared below. */ @@ -919,11 +906,11 @@ typedef struct CompiledLocal { struct CompiledLocal *nextPtr; /* Next compiler-recognized local variable for * this procedure, or NULL if this is the last * local. */ - size_t nameLength; /* The number of bytes in local variable's name. + int nameLength; /* The number of bytes in local variable's name. * Among others used to speed up var lookups. */ int frameIndex; /* Index in the array of compiler-assigned * variables in the procedure call frame. */ int flags; /* Flag bits for the local variable. Same as * the flags for the Var structure above, @@ -934,14 +921,14 @@ * or, if an argument, no default value. */ Tcl_ResolvedVarInfo *resolveInfo; /* Customized variable resolution info * supplied by the Tcl_ResolveCompiledVarProc * associated with a namespace. Each variable - * is marked by a unique tag during + * is marked by a unique ClientData tag during * compilation, and that same tag is used to * find the variable at runtime. */ - char name[1]; /* Name of the local variable starts here. If + 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! */ } CompiledLocal; @@ -953,11 +940,11 @@ */ typedef struct Proc { struct Interp *iPtr; /* Interpreter for which this command is * defined. */ - size_t refCount; /* Reference count: 1 if still present in + int refCount; /* Reference count: 1 if still present in * command table plus 1 for each call to the * procedure that is currently active. This * structure can be freed when refCount * becomes zero. */ struct Command *cmdPtr; /* Points to the Command structure for this @@ -995,11 +982,11 @@ typedef struct Trace { int level; /* Only trace commands at nesting level less * than or equal to this. */ Tcl_CmdObjTraceProc *proc; /* Procedure to call to trace command. */ - void *clientData; /* Arbitrary value to pass to proc. */ + ClientData 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; /* Procedure to call when trace is deleted. */ @@ -1047,11 +1034,11 @@ * piece of data. */ typedef struct AssocData { Tcl_InterpDeleteProc *proc; /* Proc to call when deleting. */ - void *clientData; /* Value to pass to proc. */ + ClientData clientData; /* Value to pass to proc. */ } AssocData; /* * The structure below defines a call frame. A call frame defines a naming * context for a procedure call: its local naming scope (for local variables) @@ -1070,11 +1057,11 @@ * Will be grown to contain: pointers to the varnames (allocated at the end), * plus the init values for each variable (suitable to be memcopied on init) */ typedef struct LocalCache { - size_t refCount; + int refCount; int numVars; Tcl_Obj *varName0; } LocalCache; #define localName(framePtr, i) \ @@ -1125,11 +1112,11 @@ * compiler including arguments. */ Var *compiledLocals; /* Points to the array of local variables * recognized by the compiler. The compiler * emits code that refers to these variables * using an index into this array. */ - void *clientData; /* Pointer to some context that is used by + ClientData clientData; /* Pointer to some context that is used by * object systems. The meaning of the contents * of this field is defined by the code that * sets it, and it should only ever be set by * the code that is pushing the frame. In that * case, the code that sets it should also @@ -1149,14 +1136,10 @@ #define FRAME_IS_OO_DEFINE 0x8 /* The frame is part of the inside workings of * the [oo::define] command; the clientData * field contains an Object reference that has * been confirmed to refer to a class. Part of * TIP#257. */ -#define FRAME_IS_PRIVATE_DEFINE 0x10 - /* Marks this frame as being used for private - * declarations with [oo::define]. Usually - * OR'd with FRAME_IS_OO_DEFINE. TIP#500. */ /* * TIP #280 * The structure below defines a command frame. A command frame provides * location information for all commands executing a tcl script (source, eval, @@ -1225,11 +1208,11 @@ const char *pc; /* ... and instruction pointer. */ } tebc; } data; Tcl_Obj *cmdObj; const char *cmd; /* The executed command, if possible... */ - size_t len; /* ... and its length. */ + int len; /* ... and its length. */ const struct CFWordBC *litarg; /* Link to set of literal arguments which have * ben pushed on the lineLABCPtr stack by * TclArgumentBCEnter(). These will be removed * by TclArgumentBCRelease. */ @@ -1236,17 +1219,17 @@ } CmdFrame; typedef struct CFWord { CmdFrame *framePtr; /* CmdFrame to access. */ int word; /* Index of the word in the command. */ - size_t refCount; /* Number of times the word is on the + int refCount; /* Number of times the word is on the * stack. */ } CFWord; typedef struct CFWordBC { CmdFrame *framePtr; /* CmdFrame to access. */ - size_t pc; /* Instruction pointer of a command in + int pc; /* Instruction pointer of a command in * ExtCmdLoc.loc[.] */ int word; /* Index of word in * ExtCmdLoc.loc[cmd]->line[.] */ struct CFWordBC *prevPtr; /* Previous entry in stack for same Tcl_Obj. */ struct CFWordBC *nextPtr; /* Next entry for same command call. See @@ -1275,11 +1258,11 @@ #define CLL_END (-1) typedef struct ContLineLoc { int num; /* Number of entries in loc, not counting the * final -1 marker entry. */ - int loc[1]; /* Table of locations, as character offsets. + int loc[TCLFLEXARRAY];/* Table of locations, as character offsets. * The table is allocated as part of the * structure, extending behind the nominal end * of the structure. An entry containing the * value -1 is put after the last location, as * end-marker/sentinel. */ @@ -1313,21 +1296,21 @@ * Structure passed to describe procedure-like "procedures" that are not * procedures (e.g. a lambda) so that their details can be reported correctly * by [info frame]. Contains a sub-structure for each extra field. */ -typedef Tcl_Obj * (GetFrameInfoValueProc)(void *clientData); +typedef Tcl_Obj * (GetFrameInfoValueProc)(ClientData clientData); typedef struct { const char *name; /* Name of this field. */ GetFrameInfoValueProc *proc; /* Function to generate a Tcl_Obj* from the * clientData, or just use the clientData * directly (after casting) if NULL. */ - void *clientData; /* Context for above function, or Tcl_Obj* if + ClientData clientData; /* Context for above function, or Tcl_Obj* if * proc field is NULL. */ } ExtraFrameInfoField; typedef struct { - size_t length; /* Length of array. */ + int length; /* Length of array. */ ExtraFrameInfoField fields[2]; /* Really as long as necessary, but this is * long enough for nearly anything. */ } ExtraFrameInfo; @@ -1364,11 +1347,11 @@ /* * This is a convenience macro used to initialize a thread local storage ptr. */ #define TCL_TSD_INIT(keyPtr) \ - Tcl_GetThreadData((keyPtr), sizeof(ThreadSpecificData)) + (ThreadSpecificData *)Tcl_GetThreadData((keyPtr), sizeof(ThreadSpecificData)) /* *---------------------------------------------------------------- * Data structures related to bytecode compilation and execution. These are * used primarily in tclCompile.c, tclExecute.c, and tclBasic.c. @@ -1412,11 +1395,11 @@ * The type of procedure called from the compilation hook point in * SetByteCodeFromAny. */ typedef int (CompileHookProc)(Tcl_Interp *interp, - struct CompileEnv *compEnvPtr, void *clientData); + struct CompileEnv *compEnvPtr, ClientData clientData); /* * The data structure for a (linked list of) execution stacks. */ @@ -1424,11 +1407,11 @@ struct ExecStack *prevPtr; struct ExecStack *nextPtr; Tcl_Obj **markerPtr; Tcl_Obj **endPtr; Tcl_Obj **tosPtr; - Tcl_Obj *stackWords[1]; + Tcl_Obj *stackWords[TCLFLEXARRAY]; } ExecStack; /* * The data structure defining the execution environment for ByteCode's. * There is one ExecEnv structure per Tcl interpreter. It holds the evaluation @@ -1499,15 +1482,15 @@ struct LiteralEntry *nextPtr; /* Points to next entry in this hash bucket or * NULL if end of chain. */ Tcl_Obj *objPtr; /* Points to Tcl object that holds the * literal's bytes and length. */ - size_t refCount; /* If in an interpreter's global literal + int refCount; /* If in an interpreter's global literal * table, the number of ByteCode structures * that share the literal object; the literal * entry can be freed when refCount drops to - * 0. If in a local literal table, TCL_AUTO_LENGTH. */ + * 0. If in a local literal table, -1. */ Namespace *nsPtr; /* Namespace in which this literal is used. We * try to avoid sharing literal non-FQ command * names among different namespaces to reduce * shimmering. */ } LiteralEntry; @@ -1517,17 +1500,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 + int numBuckets; /* Total number of buckets allocated at * **buckets. */ - size_t numEntries; /* Total number of entries present in + int numEntries; /* Total number of entries present in * table. */ - size_t rebuildSize; /* Enlarge table when numEntries gets to be + int rebuildSize; /* Enlarge table when numEntries gets to be * this large. */ - size_t mask; /* Mask value used in hashing function. */ + int 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 @@ -1534,37 +1517,37 @@ * interpreter's operation in that interpreter. */ #ifdef TCL_COMPILE_STATS typedef struct ByteCodeStats { - size_t numExecutions; /* Number of ByteCodes executed. */ - size_t numCompilations; /* Number of ByteCodes created. */ - size_t numByteCodesFreed; /* Number of ByteCodes destroyed. */ - size_t instructionCount[256]; /* Number of times each instruction was + long numExecutions; /* Number of ByteCodes executed. */ + long numCompilations; /* Number of ByteCodes created. */ + long numByteCodesFreed; /* Number of ByteCodes destroyed. */ + long instructionCount[256]; /* Number of times each instruction was * executed. */ double totalSrcBytes; /* Total source bytes ever compiled. */ double totalByteCodeBytes; /* Total bytes for all ByteCodes. */ double currentSrcBytes; /* Src bytes for all current ByteCodes. */ double currentByteCodeBytes;/* Code bytes in all current ByteCodes. */ - size_t srcCount[32]; /* Source size distribution: # of srcs of + long srcCount[32]; /* Source size distribution: # of srcs of * size [2**(n-1)..2**n), n in [0..32). */ - size_t byteCodeCount[32]; /* ByteCode size distribution. */ - size_t lifetimeCount[32]; /* ByteCode lifetime distribution (ms). */ + long byteCodeCount[32]; /* ByteCode size distribution. */ + long lifetimeCount[32]; /* ByteCode lifetime distribution (ms). */ double currentInstBytes; /* Instruction bytes-current ByteCodes. */ double currentLitBytes; /* Current literal bytes. */ double currentExceptBytes; /* Current exception table bytes. */ double currentAuxBytes; /* Current auxiliary information bytes. */ double currentCmdMapBytes; /* Current src<->code map bytes. */ - size_t numLiteralsCreated; /* Total literal objects ever compiled. */ + long numLiteralsCreated; /* Total literal objects ever compiled. */ double totalLitStringBytes; /* Total string bytes in all literals. */ double currentLitStringBytes; /* String bytes in current literals. */ - size_t literalCount[32]; /* Distribution of literal string sizes. */ + long literalCount[32]; /* Distribution of literal string sizes. */ } ByteCodeStats; #endif /* TCL_COMPILE_STATS */ /* * Structure used in implementation of those core ensembles which are @@ -1575,11 +1558,11 @@ typedef struct { const char *name; /* The name of the subcommand. */ Tcl_ObjCmdProc *proc; /* The implementation of the subcommand. */ CompileProc *compileProc; /* The compiler for the subcommand. */ Tcl_ObjCmdProc *nreProc; /* NRE implementation of this command. */ - void *clientData; /* Any clientData to give the command. */ + ClientData clientData; /* Any clientData to give the command. */ int unsafe; /* Whether this command is to be hidden by * default in a safe interpreter. */ } EnsembleImplMap; /* @@ -1641,28 +1624,28 @@ * already (this can happen if deleteProc * causes the command to be deleted or * recreated). */ Namespace *nsPtr; /* Points to the namespace containing this * command. */ - size_t refCount; /* 1 if in command hashtable plus 1 for each + int refCount; /* 1 if in command hashtable plus 1 for each * reference from a CmdName Tcl object * representing a command's name in a ByteCode * instruction sequence. This structure can be * freed when refCount becomes zero. */ - size_t cmdEpoch; /* Incremented to invalidate any references + int cmdEpoch; /* Incremented to invalidate any references * that point to this command when it is * renamed, deleted, hidden, or exposed. */ CompileProc *compileProc; /* Procedure called to compile command. NULL * if no compile proc exists for command. */ Tcl_ObjCmdProc *objProc; /* Object-based command procedure. */ - void *objClientData; /* Arbitrary value passed to object proc. */ + ClientData objClientData; /* Arbitrary value passed to object proc. */ Tcl_CmdProc *proc; /* String-based command procedure. */ - void *clientData; /* Arbitrary value passed to string proc. */ + ClientData clientData; /* Arbitrary value passed to string proc. */ Tcl_CmdDeleteProc *deleteProc; /* Procedure invoked when deleting command to, * e.g., free all client data. */ - void *deleteData; /* Arbitrary value passed to deleteProc. */ + ClientData deleteData; /* Arbitrary value passed to deleteProc. */ int flags; /* Miscellaneous bits of information about * command. See below for definitions. */ ImportRef *importRefPtr; /* List of each imported Command created in * another namespace when this command is * imported. These imported commands redirect @@ -1703,10 +1686,11 @@ #define CMD_TRACE_ACTIVE 0x02 #define CMD_HAS_EXEC_TRACES 0x04 #define CMD_COMPILES_EXPANDED 0x08 #define CMD_REDEF_IN_PROGRESS 0x10 #define CMD_VIA_RESOLVER 0x20 +#define CMD_DEAD 0x40 /* *---------------------------------------------------------------- * Data structures related to name resolution procedures. @@ -1766,11 +1750,11 @@ typedef struct AllocCache { struct Cache *nextPtr; /* Linked list of cache entries. */ Tcl_ThreadId owner; /* Which thread's cache is this? */ Tcl_Obj *firstObjPtr; /* List of free objects for thread. */ - size_t numObjects; /* Number of objects for thread. */ + int numObjects; /* Number of objects for thread. */ } AllocCache; /* *---------------------------------------------------------------- * This structure defines an interpreter, which is a collection of commands @@ -1780,48 +1764,66 @@ *---------------------------------------------------------------- */ typedef struct Interp { /* - * The first two fields were named "result" and "freeProc" in earlier - * versions of Tcl. They are no longer used within Tcl, and are no - * longer available to be accessed by extensions. However, they cannot - * be removed. Why? There is a deployed base of stub-enabled extensions - * that query the value of iPtr->stubTable. For them to continue to work, - * the location of the field "stubTable" within the Interp struct cannot - * change. The most robust way to assure that is to leave all fields up to - * that one undisturbed. + * Note: the first three fields must match exactly the fields in a + * Tcl_Interp struct (see tcl.h). If you change one, be sure to change the + * other. + * + * The interpreter's result is held in both the string and the + * objResultPtr fields. These fields hold, respectively, the result's + * string or object value. The interpreter's result is always in the + * result field if that is non-empty, otherwise it is in objResultPtr. + * The two fields are kept consistent unless some C code sets + * interp->result directly. Programs should not access result and + * objResultPtr directly; instead, they should always get and set the + * result using procedures such as Tcl_SetObjResult, Tcl_GetObjResult, and + * Tcl_GetStringResult. See the SetResult man page for details. */ - const char *legacyResult; - void (*legacyFreeProc) (void); + char *result; /* If the last command returned a string + * result, this points to it. Should not be + * accessed directly; see comment above. */ + Tcl_FreeProc *freeProc; /* Zero means a string result is statically + * allocated. TCL_DYNAMIC means string result + * was allocated with ckalloc and should be + * freed with ckfree. Other values give + * address of procedure to invoke to free the + * string result. Tcl_Eval must free it before + * executing next command. */ int errorLine; /* When TCL_ERROR is returned, this gives the * line number in the command where the error * occurred (1 means first line). */ const struct TclStubs *stubTable; - /* Pointer to the exported Tcl stub table. In - * ancient pre-8.1 versions of Tcl this was a - * pointer to the objResultPtr or a pointer to a - * buckets array in a hash table. Deployed stubs - * enabled extensions check for a NULL pointer value - * and for a TCL_STUBS_MAGIC value to verify they - * are not [load]ing into one of those pre-stubs - * interps. - */ + /* Pointer to the exported Tcl stub table. On + * previous versions of Tcl this is a pointer + * to the objResultPtr or a pointer to a + * buckets array in a hash table. We therefore + * have to do some careful checking before we + * can use this. */ TclHandle handle; /* Handle used to keep track of when this * interp is deleted. */ Namespace *globalNsPtr; /* The interpreter's global namespace. */ Tcl_HashTable *hiddenCmdTablePtr; /* Hash table used by tclBasic.c to keep track * of hidden commands on a per-interp * basis. */ - void *interpInfo; /* Information used by tclInterp.c to keep - * track of master/slave interps on a + ClientData interpInfo; /* Information used by tclInterp.c to keep + * track of parent/child interps on a * per-interp basis. */ - void (*optimizer)(void *envPtr); + 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; + /* * Information related to procedures and variables. See tclProc.c and * tclVar.c for usage. */ @@ -1846,10 +1848,23 @@ CallFrame *rootFramePtr; /* Global frame pointer for this * interpreter. */ Namespace *lookupNsPtr; /* Namespace to use ONLY on the next * TCL_EVAL_INVOKE call to Tcl_EvalObjv. */ + /* + * Information used by Tcl_AppendResult to keep track of partial results. + * See Tcl_AppendResult code for details. + */ + + char *appendResult; /* Storage space for results generated by + * Tcl_AppendResult. Ckalloc-ed. NULL means + * not yet allocated. */ + int appendAvl; /* Total amount of space available at + * partialResult. */ + int appendUsed; /* Number of non-null bytes currently stored + * at partialResult. */ + /* * Information about packages. Used only in tclPkg.c. */ Tcl_HashTable packageTable; /* Describes all of the packages loaded in or @@ -1862,22 +1877,23 @@ * NULL. */ /* * Miscellaneous information: */ - size_t cmdCount; /* Total number of times a command procedure + int cmdCount; /* Total number of times a command procedure * 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. */ + int unused1; /* No longer used (was termOffset) */ 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. */ - size_t compileEpoch; /* Holds the current "compilation epoch" for + int compileEpoch; /* Holds the current "compilation epoch" for * this interpreter. This is incremented to * invalidate existing ByteCodes when, e.g., a * command with a compile procedure is * redefined. */ Proc *compiledProcPtr; /* If a procedure is being compiled, a pointer @@ -1905,10 +1921,12 @@ * 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. */ + char resultSpace[TCL_RESULT_SIZE+1]; + /* Static space holding small results. */ 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. */ @@ -1947,11 +1965,11 @@ * check the limits. */ int exceeded; /* Which limits have been exceeded, described * as flag values the same as the 'active' * field. */ - size_t cmdCount; /* Limit for how many commands to execute in + int cmdCount; /* Limit for how many commands to execute in * the interpreter. */ LimitHandler *cmdHandlers; /* Handlers to execute when the limit is * reached. */ int cmdGranularity; /* Mod factor used to determine how often to @@ -1983,13 +2001,13 @@ Tcl_Obj *const *sourceObjs; /* What arguments were actually input into the * *root* ensemble command? (Nested ensembles * don't rewrite this.) NULL if we're not * processing an ensemble. */ - size_t numRemovedObjs; /* How many arguments have been stripped off + int numRemovedObjs; /* How many arguments have been stripped off * because of ensemble processing. */ - size_t numInsertedObjs; /* How many of the current arguments were + int numInsertedObjs; /* How many of the current arguments were * inserted by an ensemble. */ } ensembleRewrite; /* * TIP #219: Global info for the I/O system. @@ -2069,11 +2087,11 @@ * (a) do not change during the thread's lifetime * (b) require access to TSD to determine at runtime * (c) are accessed very often (e.g., at each command call) * * Note that these are the same for all interps in the same thread. They - * just have to be initialised for the thread's master interp, slaves + * just have to be initialised for the thread's parent interp, children * inherit the value. * * They are used by the macros defined below. */ @@ -2193,10 +2211,11 @@ #define TCL_ALLOW_EXCEPTIONS 0x04 #define TCL_EVAL_FILE 0x02 #define TCL_EVAL_SOURCE_IN_FRAME 0x10 #define TCL_EVAL_NORESOLVE 0x20 +#define TCL_EVAL_DISCARD_RESULT 0x40 /* * Flag bits for Interp structures: * * DELETED: Non-zero means the interpreter has been deleted: @@ -2296,17 +2315,10 @@ * (notably tbcload) require it. */ #define TCL_ALIGN(x) (((int)(x) + 7) & ~7) -/* - * A common panic alert when memory allocation fails. - */ - -#define TclOOM(ptr, size) \ - ((size) && ((ptr)||(Tcl_Panic("unable to alloc %" TCL_Z_MODIFIER "u bytes", (size_t)(size)),1))) - /* * The following enum values are used to specify the runtime platform setting * of the tclPlatform variable. */ @@ -2354,11 +2366,11 @@ * used to hold all element pointers. This is done to make append operations * faster. */ typedef struct List { - size_t refCount; + int refCount; int maxElemCount; /* Total number of element array slots. */ int elemCount; /* Current number of list elements. */ int canonicalFlag; /* Set if the string representation was * derived from the list representation. May * be ignored if there is no string rep at @@ -2368,18 +2380,24 @@ } List; #define LIST_MAX \ (1 + (int)(((size_t)UINT_MAX - sizeof(List))/sizeof(Tcl_Obj *))) #define LIST_SIZE(numElems) \ - (sizeof(List) + (((numElems) - 1) * sizeof(Tcl_Obj *))) + (unsigned)(sizeof(List) + (((numElems) - 1) * sizeof(Tcl_Obj *))) /* * Macro used to get the elements of a list object. */ #define ListRepPtr(listPtr) \ ((List *) (listPtr)->internalRep.twoPtrValue.ptr1) + +#define ListSetIntRep(objPtr, listRepPtr) \ + (objPtr)->internalRep.twoPtrValue.ptr1 = (void *)(listRepPtr), \ + (objPtr)->internalRep.twoPtrValue.ptr2 = NULL, \ + (listRepPtr)->refCount++, \ + (objPtr)->typePtr = &tclListType #define ListObjGetElements(listPtr, objc, objv) \ ((objv) = &(ListRepPtr(listPtr)->elements), \ (objc) = ListRepPtr(listPtr)->elemCount) @@ -2409,63 +2427,68 @@ #define TCL_EACH_KEEP_NONE 0 /* Discard iteration result like [foreach] */ #define TCL_EACH_COLLECT 1 /* Collect iteration result like [lmap] */ /* - * Macros providing a faster path to booleans and integers: - * Tcl_GetBooleanFromObj, Tcl_GetLongFromObj, Tcl_GetIntFromObj - * and Tcl_GetIntForIndex. + * Macros providing a faster path to integers: Tcl_GetLongFromObj, + * Tcl_GetIntFromObj and TclGetIntForIndex. * * WARNING: these macros eval their args more than once. */ -#define TclGetBooleanFromObj(interp, objPtr, boolPtr) \ - (((objPtr)->typePtr == &tclIntType \ - || (objPtr)->typePtr == &tclBooleanType) \ - ? (*(boolPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \ - : Tcl_GetBooleanFromObj((interp), (objPtr), (boolPtr))) - -#ifdef TCL_WIDE_INT_IS_LONG #define TclGetLongFromObj(interp, objPtr, longPtr) \ (((objPtr)->typePtr == &tclIntType) \ - ? ((*(longPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \ - : Tcl_GetLongFromObj((interp), (objPtr), (longPtr))) -#else -#define TclGetLongFromObj(interp, objPtr, longPtr) \ - (((objPtr)->typePtr == &tclIntType \ - && (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(LONG_MIN) \ - && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(LONG_MAX)) \ - ? ((*(longPtr) = (long)(objPtr)->internalRep.wideValue), TCL_OK) \ - : Tcl_GetLongFromObj((interp), (objPtr), (longPtr))) -#endif - + ? ((*(longPtr) = (objPtr)->internalRep.longValue), TCL_OK) \ + : Tcl_GetLongFromObj((interp), (objPtr), (longPtr))) + +#if (LONG_MAX == INT_MAX) +#define TclGetIntFromObj(interp, objPtr, intPtr) \ + (((objPtr)->typePtr == &tclIntType) \ + ? ((*(intPtr) = (objPtr)->internalRep.longValue), TCL_OK) \ + : Tcl_GetIntFromObj((interp), (objPtr), (intPtr))) +#define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \ + (((objPtr)->typePtr == &tclIntType) \ + ? ((*(idxPtr) = (objPtr)->internalRep.longValue), TCL_OK) \ + : TclGetIntForIndex((interp), (objPtr), (endValue), (idxPtr))) +#else #define TclGetIntFromObj(interp, objPtr, intPtr) \ (((objPtr)->typePtr == &tclIntType \ - && (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(INT_MIN) \ - && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(INT_MAX)) \ - ? ((*(intPtr) = (int)(objPtr)->internalRep.wideValue), TCL_OK) \ + && (objPtr)->internalRep.longValue >= -(Tcl_WideInt)(UINT_MAX) \ + && (objPtr)->internalRep.longValue <= (Tcl_WideInt)(UINT_MAX)) \ + ? ((*(intPtr) = (objPtr)->internalRep.longValue), TCL_OK) \ : Tcl_GetIntFromObj((interp), (objPtr), (intPtr))) #define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \ (((objPtr)->typePtr == &tclIntType \ - && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(INT_MAX)) \ - ? ((*(idxPtr) = ((objPtr)->internalRep.wideValue >= 0) \ - ? (size_t)(objPtr)->internalRep.wideValue : TCL_INDEX_NONE), TCL_OK) \ - : Tcl_GetIntForIndex((interp), (objPtr), (endValue), (idxPtr))) + && (objPtr)->internalRep.longValue >= INT_MIN \ + && (objPtr)->internalRep.longValue <= INT_MAX) \ + ? ((*(idxPtr) = (objPtr)->internalRep.longValue), TCL_OK) \ + : TclGetIntForIndex((interp), (objPtr), (endValue), (idxPtr))) +#endif /* * Macro used to save a function call for common uses of * Tcl_GetWideIntFromObj(). The ANSI C "prototype" is: * * MODULE_SCOPE int TclGetWideIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, * Tcl_WideInt *wideIntPtr); */ +#ifdef TCL_WIDE_INT_IS_LONG #define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ (((objPtr)->typePtr == &tclIntType) \ - ? (*(wideIntPtr) = \ - ((objPtr)->internalRep.wideValue), TCL_OK) : \ + ? (*(wideIntPtr) = (Tcl_WideInt) \ + ((objPtr)->internalRep.longValue), TCL_OK) : \ + Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) +#else /* !TCL_WIDE_INT_IS_LONG */ +#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ + (((objPtr)->typePtr == &tclWideIntType) \ + ? (*(wideIntPtr) = (objPtr)->internalRep.wideValue, TCL_OK) : \ + ((objPtr)->typePtr == &tclIntType) \ + ? (*(wideIntPtr) = (Tcl_WideInt) \ + ((objPtr)->internalRep.longValue), TCL_OK) : \ Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) +#endif /* TCL_WIDE_INT_IS_LONG */ /* * Flag values for TclTraceDictPath(). * * DICT_PATH_READ indicates that all entries on the path must exist but no @@ -2504,11 +2527,11 @@ * more efficiency in 'path' manipulation and usage, and cleaner filesystem * code internally. */ #define TCL_FILESYSTEM_VERSION_2 ((Tcl_FSVersion) 0x2) -typedef void *(TclFSGetCwdProc2)(void *clientData); +typedef ClientData (TclFSGetCwdProc2)(ClientData clientData); typedef int (Tcl_FSLoadFileProc2) (Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr, int flags); /* * The following types are used for getting and storing platform-specific file @@ -2526,19 +2549,10 @@ typedef struct TclFileAttrProcs { TclGetFileAttrProc *getProc;/* The procedure for getting attrs. */ TclSetFileAttrProc *setProc;/* The procedure for setting attrs. */ } TclFileAttrProcs; -/* - * Private flag value which controls Tcl_GetIndexFromObj*() routines - * to instruct them not to cache lookups because the table will not - * live long enough to make it worthwhile. Must not clash with public - * flag value TCL_EXACT. - */ - -#define INDEX_TEMP_TABLE 2 - /* * Opaque handle used in pipeline routines to encapsulate platform-dependent * state. */ @@ -2585,30 +2599,30 @@ *---------------------------------------------------------------- * Data structures for process-global values. *---------------------------------------------------------------- */ -typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, size_t *lengthPtr, +typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, int *lengthPtr, Tcl_Encoding *encodingPtr); /* * A ProcessGlobalValue struct exists for each internal value in Tcl that is * to be shared among several threads. Each thread sees a (Tcl_Obj) copy of - * the value, and the master is kept as a counted string, with epoch and mutex - * control. Each ProcessGlobalValue struct should be a static variable in some - * file. + * the value, and the gobal value is kept as a counted string, with epoch and + * mutex control. Each ProcessGlobalValue struct should be a static variable in + * some file. */ typedef struct ProcessGlobalValue { - size_t epoch; /* Epoch counter to detect changes in the - * master value. */ - size_t numBytes; /* Length of the master string. */ - char *value; /* The master string value. */ - Tcl_Encoding encoding; /* system encoding when master string was + int epoch; /* Epoch counter to detect changes in the + * global value. */ + int 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 master string + /* A procedure to initialize the global string * copy when a "get" request comes in before * any "set" request has been received. */ Tcl_Mutex mutex; /* Enforce orderly access from multiple * threads. */ Tcl_ThreadDataKey key; /* Key for per-thread data holding the @@ -2642,11 +2656,12 @@ *---------------------------------------------------------------------- * Type values TclGetNumberFromObj *---------------------------------------------------------------------- */ -#define TCL_NUMBER_INT 2 +#define TCL_NUMBER_LONG 1 +#define TCL_NUMBER_WIDE 2 #define TCL_NUMBER_BIG 3 #define TCL_NUMBER_DOUBLE 4 #define TCL_NUMBER_NAN 5 /* @@ -2668,11 +2683,11 @@ * Data for the time hooks, if any. */ MODULE_SCOPE Tcl_GetTimeProc *tclGetTimeProcPtr; MODULE_SCOPE Tcl_ScaleTimeProc *tclScaleTimeProcPtr; -MODULE_SCOPE void *tclTimeClientData; +MODULE_SCOPE ClientData tclTimeClientData; /* * Variables denoting the Tcl object types defined in the core. */ @@ -2679,16 +2694,21 @@ MODULE_SCOPE const Tcl_ObjType tclBignumType; MODULE_SCOPE const Tcl_ObjType tclBooleanType; MODULE_SCOPE const Tcl_ObjType tclByteArrayType; MODULE_SCOPE const Tcl_ObjType tclByteCodeType; MODULE_SCOPE const Tcl_ObjType tclDoubleType; +MODULE_SCOPE const Tcl_ObjType tclEndOffsetType; MODULE_SCOPE const Tcl_ObjType tclIntType; MODULE_SCOPE const Tcl_ObjType tclListType; MODULE_SCOPE const Tcl_ObjType tclDictType; MODULE_SCOPE const Tcl_ObjType tclProcBodyType; MODULE_SCOPE const Tcl_ObjType tclStringType; +MODULE_SCOPE const Tcl_ObjType tclArraySearchType; MODULE_SCOPE const Tcl_ObjType tclEnsembleCmdType; +#ifndef TCL_WIDE_INT_IS_LONG +MODULE_SCOPE const Tcl_ObjType tclWideIntType; +#endif MODULE_SCOPE const Tcl_ObjType tclRegexpType; MODULE_SCOPE Tcl_ObjType tclCmdNameType; /* * Variables denoting the hash key types defined in the core. @@ -2705,22 +2725,23 @@ */ MODULE_SCOPE Tcl_Obj * tclFreeObjList; #ifdef TCL_COMPILE_STATS -MODULE_SCOPE size_t tclObjsAlloced; -MODULE_SCOPE size_t tclObjsFreed; +MODULE_SCOPE long tclObjsAlloced; +MODULE_SCOPE long tclObjsFreed; #define TCL_MAX_SHARED_OBJ_STATS 5 -MODULE_SCOPE size_t tclObjsShared[TCL_MAX_SHARED_OBJ_STATS]; +MODULE_SCOPE long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS]; #endif /* TCL_COMPILE_STATS */ /* * Pointer to a heap-allocated string of length zero that the Tcl core uses as * the value of an empty string representation for an object. This value is * shared by all new objects allocated by Tcl_NewObj. */ +MODULE_SCOPE char * tclEmptyStringRep; MODULE_SCOPE char tclEmptyString; enum CheckEmptyStringResult { TCL_EMPTYSTRING_UNKNOWN = -1, TCL_EMPTYSTRING_NO, TCL_EMPTYSTRING_YES }; @@ -2789,11 +2810,11 @@ * typedef in tcl.h */ typedef void* TclFindSymbolProc(Tcl_Interp* interp, Tcl_LoadHandle loadHandle, const char* symbol); struct Tcl_LoadHandle_ { - void *clientData; /* Client data is the load handle in the + ClientData clientData; /* Client data is the load handle in the * native filesystem if a module was loaded * there, or an opaque pointer to a structure * for further bookkeeping on load-from-VFS * and load-from-memory */ TclFindSymbolProc* findSymbolProcPtr; @@ -2805,10 +2826,12 @@ /* Flags for conversion of doubles to digit strings */ #define TCL_DD_SHORTEST 0x4 /* Use the shortest possible string */ +#define TCL_DD_STEELE 0x5 + /* Use the original Steele&White algorithm */ #define TCL_DD_E_FORMAT 0x2 /* Use a fixed-length string of digits, * suitable for E format*/ #define TCL_DD_F_FORMAT 0x3 /* Use a fixed number of digits after the @@ -2820,19 +2843,23 @@ #define TCL_DD_NO_QUICK 0x8 /* Debug flag: forbid quick FP conversion */ #define TCL_DD_CONVERSION_TYPE_MASK 0x3 /* Mask to isolate the conversion type */ +#define TCL_DD_STEELE0 0x1 + /* 'Steele&White' after masking */ +#define TCL_DD_SHORTEST0 0x0 + /* 'Shortest possible' after masking */ /* *---------------------------------------------------------------- * Procedures shared among Tcl modules but not used by the outside world: *---------------------------------------------------------------- */ MODULE_SCOPE void TclAppendBytesToByteArray(Tcl_Obj *objPtr, - const unsigned char *bytes, size_t len); + const unsigned char *bytes, int len); MODULE_SCOPE int TclNREvalCmd(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); MODULE_SCOPE void TclAdvanceContinuations(int *line, int **next, int loc); MODULE_SCOPE void TclAdvanceLines(int *line, const char *start, @@ -2841,78 +2868,85 @@ Tcl_Obj *objv[], int objc, CmdFrame *cf); MODULE_SCOPE void TclArgumentRelease(Tcl_Interp *interp, Tcl_Obj *objv[], int objc); MODULE_SCOPE void TclArgumentBCEnter(Tcl_Interp *interp, Tcl_Obj *objv[], int objc, - void *codePtr, CmdFrame *cfPtr, int cmd, size_t pc); + void *codePtr, CmdFrame *cfPtr, int cmd, int pc); MODULE_SCOPE void TclArgumentBCRelease(Tcl_Interp *interp, CmdFrame *cfPtr); MODULE_SCOPE void TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj, CmdFrame **cfPtrPtr, int *wordPtr); MODULE_SCOPE double TclBignumToDouble(const mp_int *bignum); MODULE_SCOPE int TclByteArrayMatch(const unsigned char *string, - size_t strLen, const unsigned char *pattern, - size_t ptnLen, int flags); + int strLen, const unsigned char *pattern, + int ptnLen, int flags); MODULE_SCOPE double TclCeil(const mp_int *a); MODULE_SCOPE void TclChannelPreserve(Tcl_Channel chan); MODULE_SCOPE void TclChannelRelease(Tcl_Channel chan); MODULE_SCOPE int TclCheckArrayTraces(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *name, int index); +MODULE_SCOPE int TclCheckBadOctal(Tcl_Interp *interp, + const char *value); MODULE_SCOPE int TclCheckEmptyString(Tcl_Obj *objPtr); MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp, Tcl_Channel chan); MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd; MODULE_SCOPE Tcl_NRPostProc TclClearRootEnsemble; -MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr, - Tcl_Obj *value2Ptr); MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, int num, int *loc); MODULE_SCOPE void TclContinuationsEnterDerived(Tcl_Obj *objPtr, int start, int *clNext); MODULE_SCOPE ContLineLoc *TclContinuationsGet(Tcl_Obj *objPtr); MODULE_SCOPE void TclContinuationsCopy(Tcl_Obj *objPtr, Tcl_Obj *originObjPtr); -MODULE_SCOPE size_t TclConvertElement(const char *src, size_t length, +MODULE_SCOPE int TclConvertElement(const char *src, int length, char *dst, int flags); -MODULE_SCOPE Tcl_Command TclCreateObjCommandInNs(Tcl_Interp *interp, - const char *cmdName, Tcl_Namespace *nsPtr, - Tcl_ObjCmdProc *proc, void *clientData, +MODULE_SCOPE Tcl_Command TclCreateObjCommandInNs ( + Tcl_Interp *interp, + const char *cmdName, + Tcl_Namespace *nsPtr, + Tcl_ObjCmdProc *proc, + ClientData clientData, Tcl_CmdDeleteProc *deleteProc); -MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs(Tcl_Interp *interp, - const char *name, Tcl_Namespace *nameNamespacePtr, - Tcl_Namespace *ensembleNamespacePtr, int flags); +MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs( + Tcl_Interp *interp, + const char *name, + Tcl_Namespace *nameNamespacePtr, + Tcl_Namespace *ensembleNamespacePtr, + int flags); MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr); MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp, const char *dict, int dictLength, const char **elementPtr, const char **nextPtr, - size_t *sizePtr, int *literalPtr); -/* TIP #280 - Modified token based evaluation, with line information. */ + int *sizePtr, int *literalPtr); +/* TIP #280 - Modified token based evulation, with line information. */ MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script, - size_t numBytes, int flags, int line, + int numBytes, int flags, int line, int *clNextOuter, const char *outerScript); MODULE_SCOPE Tcl_ObjCmdProc TclFileAttrsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileCopyCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileDeleteCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileLinkCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileMakeDirsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileReadLinkCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileRenameCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclFileTempDirCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileTemporaryCmd; MODULE_SCOPE void TclCreateLateExitHandler(Tcl_ExitProc *proc, - void *clientData); + ClientData clientData); MODULE_SCOPE void TclDeleteLateExitHandler(Tcl_ExitProc *proc, - void *clientData); + ClientData clientData); MODULE_SCOPE char * TclDStringAppendObj(Tcl_DString *dsPtr, Tcl_Obj *objPtr); MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr, Tcl_DString *toAppendPtr); MODULE_SCOPE Tcl_Obj * TclDStringToObj(Tcl_DString *dsPtr); -MODULE_SCOPE Tcl_Obj *const *TclFetchEnsembleRoot(Tcl_Interp *interp, +MODULE_SCOPE Tcl_Obj *const * TclFetchEnsembleRoot(Tcl_Interp *interp, Tcl_Obj *const *objv, int objc, int *objcPtr); -MODULE_SCOPE Tcl_Namespace *TclEnsureNamespace(Tcl_Interp *interp, +MODULE_SCOPE Tcl_Namespace * TclEnsureNamespace( + Tcl_Interp *interp, Tcl_Namespace *namespacePtr); + MODULE_SCOPE void TclFinalizeAllocSubsystem(void); MODULE_SCOPE void TclFinalizeAsync(void); MODULE_SCOPE void TclFinalizeDoubleConversion(void); MODULE_SCOPE void TclFinalizeEncodingSubsystem(void); MODULE_SCOPE void TclFinalizeEnvironment(void); @@ -2926,24 +2960,27 @@ MODULE_SCOPE void TclFinalizeMemorySubsystem(void); MODULE_SCOPE void TclFinalizeNotifier(void); MODULE_SCOPE void TclFinalizeObjects(void); MODULE_SCOPE void TclFinalizePreserve(void); MODULE_SCOPE void TclFinalizeSynchronization(void); -MODULE_SCOPE void TclInitThreadAlloc(void); MODULE_SCOPE void TclFinalizeThreadAlloc(void); MODULE_SCOPE void TclFinalizeThreadAllocThread(void); MODULE_SCOPE void TclFinalizeThreadData(int quick); MODULE_SCOPE void TclFinalizeThreadObjects(void); MODULE_SCOPE double TclFloor(const mp_int *a); MODULE_SCOPE void TclFormatNaN(double value, char *buffer); MODULE_SCOPE int TclFSFileAttrIndex(Tcl_Obj *pathPtr, const char *attributeName, int *indexPtr); -MODULE_SCOPE Tcl_Command TclNRCreateCommandInNs(Tcl_Interp *interp, - const char *cmdName, Tcl_Namespace *nsPtr, - Tcl_ObjCmdProc *proc, Tcl_ObjCmdProc *nreProc, - void *clientData, +MODULE_SCOPE Tcl_Command TclNRCreateCommandInNs ( + Tcl_Interp *interp, + const char *cmdName, + Tcl_Namespace *nsPtr, + Tcl_ObjCmdProc *proc, + Tcl_ObjCmdProc *nreProc, + ClientData clientData, Tcl_CmdDeleteProc *deleteProc); + MODULE_SCOPE int TclNREvalFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *encodingName); MODULE_SCOPE void TclFSUnloadTempFile(Tcl_LoadHandle loadHandle); MODULE_SCOPE int * TclGetAsyncReadyPtr(void); MODULE_SCOPE Tcl_Obj * TclGetBgErrorHandler(Tcl_Interp *interp); @@ -2951,49 +2988,40 @@ Tcl_Obj *objPtr, Tcl_Channel *chanPtr, int *modePtr, int flags); MODULE_SCOPE CmdFrame * TclGetCmdFrameForProcedure(Proc *procPtr); MODULE_SCOPE int TclGetCompletionCodeFromObj(Tcl_Interp *interp, Tcl_Obj *value, int *code); -MODULE_SCOPE Proc * TclGetLambdaFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr, Tcl_Obj **nsObjPtrPtr); MODULE_SCOPE int TclGetNumberFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr, void **clientDataPtr, + Tcl_Obj *objPtr, ClientData *clientDataPtr, int *typePtr); MODULE_SCOPE int TclGetOpenModeEx(Tcl_Interp *interp, const char *modeString, int *seekFlagPtr, int *binaryPtr); MODULE_SCOPE Tcl_Obj * TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr); MODULE_SCOPE Tcl_Obj * TclGetSourceFromFrame(CmdFrame *cfPtr, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE char * TclGetStringStorage(Tcl_Obj *objPtr, - size_t *sizePtr); -MODULE_SCOPE int TclGetLoadedPackagesEx(Tcl_Interp *interp, - const char *targetName, - const char *packageName); -MODULE_SCOPE int TclGetWideBitsFromObj(Tcl_Interp *, Tcl_Obj *, - Tcl_WideInt *); + unsigned int *sizePtr); MODULE_SCOPE int TclGlob(Tcl_Interp *interp, char *pattern, Tcl_Obj *unquotedPrefix, int globFlags, Tcl_GlobTypeData *types); MODULE_SCOPE int TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr, Tcl_Obj *incrPtr); MODULE_SCOPE Tcl_Obj * TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags); -MODULE_SCOPE int TclInfoExistsCmd(void *dummy, Tcl_Interp *interp, +MODULE_SCOPE int TclInfoExistsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclInfoCoroutineCmd(void *dummy, Tcl_Interp *interp, +MODULE_SCOPE int TclInfoCoroutineCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Obj * TclInfoFrame(Tcl_Interp *interp, CmdFrame *framePtr); -MODULE_SCOPE int TclInfoGlobalsCmd(void *dummy, Tcl_Interp *interp, +MODULE_SCOPE int TclInfoGlobalsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclInfoLocalsCmd(void *dummy, Tcl_Interp *interp, +MODULE_SCOPE int TclInfoLocalsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclInfoVarsCmd(void *dummy, Tcl_Interp *interp, +MODULE_SCOPE int TclInfoVarsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE void TclInitAlloc(void); -MODULE_SCOPE void TclInitBignumFromWideInt(mp_int *, Tcl_WideInt); -MODULE_SCOPE void TclInitBignumFromWideUInt(mp_int *, Tcl_WideUInt); MODULE_SCOPE void TclInitDbCkalloc(void); MODULE_SCOPE void TclInitDoubleConversion(void); MODULE_SCOPE void TclInitEmbeddedConfigurationInformation( Tcl_Interp *interp); MODULE_SCOPE void TclInitEncodingSubsystem(void); @@ -3002,11 +3030,10 @@ MODULE_SCOPE void TclInitNamespaceSubsystem(void); MODULE_SCOPE void TclInitNotifier(void); MODULE_SCOPE void TclInitObjSubsystem(void); MODULE_SCOPE void TclInitSubsystems(void); MODULE_SCOPE int TclInterpReady(Tcl_Interp *interp); -MODULE_SCOPE int TclIsSpaceProc(int byte); MODULE_SCOPE int TclIsBareword(int byte); MODULE_SCOPE Tcl_Obj * TclJoinPath(int elements, Tcl_Obj * const objv[], int forceRelative); MODULE_SCOPE int TclJoinThread(Tcl_ThreadId id, int *result); MODULE_SCOPE void TclLimitRemoveAllHandlers(Tcl_Interp *interp); @@ -3016,26 +3043,25 @@ int indexCount, Tcl_Obj *const indexArray[]); /* TIP #280 */ MODULE_SCOPE void TclListLines(Tcl_Obj *listObj, int line, int n, int *lines, Tcl_Obj *const *elems); MODULE_SCOPE Tcl_Obj * TclListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr); -MODULE_SCOPE Tcl_Obj * TclListObjRange(Tcl_Obj *listPtr, int fromIdx, - int toIdx); MODULE_SCOPE Tcl_Obj * TclLsetList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *indexPtr, Tcl_Obj *valuePtr); MODULE_SCOPE Tcl_Obj * TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, int indexCount, Tcl_Obj *const indexArray[], Tcl_Obj *valuePtr); MODULE_SCOPE Tcl_Command TclMakeEnsemble(Tcl_Interp *interp, const char *name, const EnsembleImplMap map[]); -MODULE_SCOPE int TclMaxListLength(const char *bytes, size_t numBytes, +MODULE_SCOPE int TclMaxListLength(const char *bytes, int numBytes, const char **endPtr); MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Tcl_Obj **optionsPtrPtr, int *codePtr, int *levelPtr); MODULE_SCOPE Tcl_Obj * TclNoErrorStack(Tcl_Interp *interp, Tcl_Obj *options); MODULE_SCOPE int TclNokia770Doubles(void); +MODULE_SCOPE void TclNsDecrRefCount(Namespace *nsPtr); MODULE_SCOPE void TclNsDecrRefCount(Namespace *nsPtr); MODULE_SCOPE int TclNamespaceDeleted(Namespace *nsPtr); MODULE_SCOPE void TclObjVarErrMsg(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const char *operation, const char *reason, int index); @@ -3043,26 +3069,24 @@ int objc, Tcl_Obj *const objv[], Tcl_Namespace *nsPtr, int flags); MODULE_SCOPE int TclObjUnsetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); MODULE_SCOPE int TclParseBackslash(const char *src, - size_t numBytes, size_t *readPtr, char *dst); -MODULE_SCOPE int TclParseHex(const char *src, size_t numBytes, - int *resultPtr); + int numBytes, int *readPtr, char *dst); MODULE_SCOPE int TclParseNumber(Tcl_Interp *interp, Tcl_Obj *objPtr, const char *expected, const char *bytes, - size_t numBytes, const char **endPtrPtr, int flags); + int numBytes, const char **endPtrPtr, int flags); MODULE_SCOPE void TclParseInit(Tcl_Interp *interp, const char *string, - size_t numBytes, Tcl_Parse *parsePtr); -MODULE_SCOPE size_t TclParseAllWhiteSpace(const char *src, size_t numBytes); + int numBytes, Tcl_Parse *parsePtr); +MODULE_SCOPE int TclParseAllWhiteSpace(const char *src, int numBytes); MODULE_SCOPE int TclProcessReturn(Tcl_Interp *interp, int code, int level, Tcl_Obj *returnOpts); MODULE_SCOPE int TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); MODULE_SCOPE Tcl_Obj * TclpTempFileName(void); MODULE_SCOPE Tcl_Obj * TclpTempFileNameForLibrary(Tcl_Interp *interp, Tcl_Obj* pathPtr); MODULE_SCOPE Tcl_Obj * TclNewFSPathObj(Tcl_Obj *dirPtr, const char *addStrRep, - size_t len); + int len); MODULE_SCOPE int TclpDeleteFile(const void *path); MODULE_SCOPE void TclpFinalizeCondition(Tcl_Condition *condPtr); MODULE_SCOPE void TclpFinalizeMutex(Tcl_Mutex *mutexPtr); MODULE_SCOPE void TclpFinalizePipes(void); MODULE_SCOPE void TclpFinalizeSockets(void); @@ -3069,21 +3093,21 @@ MODULE_SCOPE int TclCreateSocketAddress(Tcl_Interp *interp, 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); -MODULE_SCOPE size_t TclpFindVariable(const char *name, size_t *lengthPtr); + Tcl_ThreadCreateProc *proc, ClientData clientData, + int stackSize, int flags); +MODULE_SCOPE int TclpFindVariable(const char *name, int *lengthPtr); MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr, - size_t *lengthPtr, Tcl_Encoding *encodingPtr); + int *lengthPtr, Tcl_Encoding *encodingPtr); MODULE_SCOPE void TclpInitLock(void); MODULE_SCOPE void TclpInitPlatform(void); MODULE_SCOPE void TclpInitUnlock(void); MODULE_SCOPE Tcl_Obj * TclpObjListVolumes(void); -MODULE_SCOPE void TclpMasterLock(void); -MODULE_SCOPE void TclpMasterUnlock(void); +MODULE_SCOPE void TclpGlobalLock(void); +MODULE_SCOPE void TclpGlobalUnlock(void); MODULE_SCOPE int TclpMatchFiles(Tcl_Interp *interp, char *separators, Tcl_DString *dirPtr, char *pattern, char *tail); MODULE_SCOPE int TclpObjNormalizePath(Tcl_Interp *interp, Tcl_Obj *pathPtr, int nextCheckpoint); MODULE_SCOPE void TclpNativeJoinPath(Tcl_Obj *prefix, const char *joining); @@ -3093,101 +3117,100 @@ MODULE_SCOPE int TclCrossFilesystemCopy(Tcl_Interp *interp, Tcl_Obj *source, Tcl_Obj *target); MODULE_SCOPE int TclpMatchInDirectory(Tcl_Interp *interp, Tcl_Obj *resultPtr, Tcl_Obj *pathPtr, const char *pattern, Tcl_GlobTypeData *types); -MODULE_SCOPE void *TclpGetNativeCwd(void *clientData); +MODULE_SCOPE ClientData TclpGetNativeCwd(ClientData clientData); MODULE_SCOPE Tcl_FSDupInternalRepProc TclNativeDupInternalRep; MODULE_SCOPE Tcl_Obj * TclpObjLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr, int linkType); MODULE_SCOPE int TclpObjChdir(Tcl_Obj *pathPtr); MODULE_SCOPE Tcl_Channel TclpOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); -MODULE_SCOPE void TclPkgFileSeen(Tcl_Interp *interp, const char *fileName); -MODULE_SCOPE void *TclInitPkgFiles(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclPathPart(Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_PathPart portion); MODULE_SCOPE char * TclpReadlink(const char *fileName, Tcl_DString *linkPtr); MODULE_SCOPE void TclpSetVariables(Tcl_Interp *interp); MODULE_SCOPE void * TclThreadStorageKeyGet(Tcl_ThreadDataKey *keyPtr); MODULE_SCOPE void TclThreadStorageKeySet(Tcl_ThreadDataKey *keyPtr, void *data); -MODULE_SCOPE TCL_NORETURN void TclpThreadExit(int status); +MODULE_SCOPE void TclpThreadExit(int status); MODULE_SCOPE void TclRememberCondition(Tcl_Condition *mutex); MODULE_SCOPE void TclRememberJoinableThread(Tcl_ThreadId id); MODULE_SCOPE void TclRememberMutex(Tcl_Mutex *mutex); MODULE_SCOPE void TclRemoveScriptLimitCallbacks(Tcl_Interp *interp); MODULE_SCOPE int TclReToGlob(Tcl_Interp *interp, const char *reStr, - size_t reStrLen, Tcl_DString *dsPtr, int *flagsPtr, + int reStrLen, Tcl_DString *dsPtr, int *flagsPtr, int *quantifiersFoundPtr); -MODULE_SCOPE size_t TclScanElement(const char *string, size_t length, +MODULE_SCOPE int TclScanElement(const char *string, int length, char *flagPtr); MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp, Tcl_Obj *cmdPrefix); MODULE_SCOPE void TclSetBignumIntRep(Tcl_Obj *objPtr, mp_int *bignumValue); -MODULE_SCOPE int TclSetBooleanFromAny(Tcl_Interp *interp, - Tcl_Obj *objPtr); +MODULE_SCOPE int TclSetBooleanFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); MODULE_SCOPE void TclSetCmdNameObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Command *cmdPtr); MODULE_SCOPE void TclSetDuplicateObj(Tcl_Obj *dupPtr, Tcl_Obj *objPtr); MODULE_SCOPE void TclSetProcessGlobalValue(ProcessGlobalValue *pgvPtr, Tcl_Obj *newValue, Tcl_Encoding encoding); MODULE_SCOPE void TclSignalExitThread(Tcl_ThreadId id, int result); MODULE_SCOPE void TclSpellFix(Tcl_Interp *interp, - Tcl_Obj *const *objv, int objc, size_t subIdx, + Tcl_Obj *const *objv, int objc, int subIdx, Tcl_Obj *bad, Tcl_Obj *fix); MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr, - size_t numBytes); + int 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, size_t reqlength); -MODULE_SCOPE int TclStringCmpOpts(Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[], int *nocase, - int *reqlength); -MODULE_SCOPE int TclStringMatch(const char *str, size_t strLen, +MODULE_SCOPE int TclStringCmp (Tcl_Obj *value1Ptr, Tcl_Obj *value2Ptr, + int checkEq, int nocase, int reqlength); +MODULE_SCOPE int TclStringCmpOpts (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], + int *nocase, int *reqlength); +MODULE_SCOPE int TclStringMatch(const char *str, int strLen, const char *pattern, int ptnLen, int flags); MODULE_SCOPE int TclStringMatchObj(Tcl_Obj *stringObj, Tcl_Obj *patternObj, int flags); +MODULE_SCOPE Tcl_Obj * TclStringReverse(Tcl_Obj *objPtr); MODULE_SCOPE void TclSubstCompile(Tcl_Interp *interp, const char *bytes, - size_t numBytes, int flags, int line, + int numBytes, int flags, int line, struct CompileEnv *envPtr); MODULE_SCOPE int TclSubstOptions(Tcl_Interp *interp, int numOpts, Tcl_Obj *const opts[], int *flagPtr); MODULE_SCOPE void TclSubstParse(Tcl_Interp *interp, const char *bytes, - size_t numBytes, int flags, Tcl_Parse *parsePtr, + int numBytes, int flags, Tcl_Parse *parsePtr, Tcl_InterpState *statePtr); MODULE_SCOPE int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, int *tokensLeftPtr, int line, int *clNextOuter, const char *outerScript); -MODULE_SCOPE size_t TclTrim(const char *bytes, size_t numBytes, - const char *trim, size_t numTrim, size_t *trimRight); -MODULE_SCOPE size_t TclTrimLeft(const char *bytes, size_t numBytes, - const char *trim, size_t numTrim); -MODULE_SCOPE size_t TclTrimRight(const char *bytes, size_t numBytes, - const char *trim, size_t numTrim); -MODULE_SCOPE const char*TclGetCommandTypeName(Tcl_Command command); -MODULE_SCOPE void TclRegisterCommandTypeName( - Tcl_ObjCmdProc *implementationProc, - const char *nameStr); -#if (TCL_UTF_MAX > 4) && (defined(__CYGWIN__) || defined(_WIN32)) -MODULE_SCOPE int TclUtfToWChar(const char *src, WCHAR *chPtr); -MODULE_SCOPE char * TclWCharToUtfDString(const WCHAR *uniStr, - int uniLength, Tcl_DString *dsPtr); -MODULE_SCOPE WCHAR * TclUtfToWCharDString(const char *src, - int length, Tcl_DString *dsPtr); -#else -# define TclUtfToWChar TclUtfToUniChar -# define TclWCharToUtfDString Tcl_UniCharToUtfDString -# define TclUtfToWCharDString Tcl_UtfToUniCharDString -#endif -MODULE_SCOPE int TclUtfCmp(const char *cs, const char *ct); +MODULE_SCOPE int TclTrim(const char *bytes, int numBytes, + const char *trim, int numTrim, int *trimRight); +MODULE_SCOPE int TclTrimLeft(const char *bytes, int numBytes, + const char *trim, int numTrim); +MODULE_SCOPE int TclTrimRight(const char *bytes, int numBytes, + const char *trim, int numTrim); MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct); -MODULE_SCOPE size_t TclUtfCount(int ch); -MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(void *clientData); +MODULE_SCOPE int TclUtfToUCS4(const char *, int *); +MODULE_SCOPE int TclUCS4ToUtf(int, char *); +MODULE_SCOPE int TclUCS4ToLower(int ch); +#if TCL_UTF_MAX == 4 + MODULE_SCOPE int TclGetUCS4(Tcl_Obj *, int); + MODULE_SCOPE int TclUniCharToUCS4(const Tcl_UniChar *, int *); +#else +# define TclGetUCS4 Tcl_GetUniChar +# define TclUniCharToUCS4(src, ptr) (*ptr = *(src),1) +#endif + +/* + * Bytes F0-F4 are start-bytes for 4-byte sequences. + * Byte 0xED can be the start-byte of an upper surrogate. In that case, + * TclUtfToUCS4() might read the lower surrogate following it too. + */ +# define TclUCS4Complete(src, length) (((unsigned)(UCHAR(*(src)) - 0xF0) < 5) \ + ? ((length) >= 4) : (UCHAR(*(src)) == 0xED) ? ((length) >= 6) : Tcl_UtfCharComplete((src), (length))) +MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(ClientData clientData); MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType(Tcl_Obj *pathPtr); MODULE_SCOPE int TclpDlopen(Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_LoadHandle *loadHandle, Tcl_FSUnloadFileProc **unloadProcPtr, int flags); MODULE_SCOPE int TclpUtime(Tcl_Obj *pathPtr, struct utimbuf *tval); @@ -3199,10 +3222,17 @@ #endif MODULE_SCOPE void TclInitThreadStorage(void); MODULE_SCOPE void TclFinalizeThreadDataThread(void); MODULE_SCOPE void TclFinalizeThreadStorage(void); +/* TclWideMUInt -- wide integer used for measurement calculations: */ +#if (!defined(_WIN32) || !defined(_MSC_VER) || (_MSC_VER >= 1400)) +# define TclWideMUInt Tcl_WideUInt +#else +/* older MSVS may not allow conversions between unsigned __int64 and double) */ +# define TclWideMUInt Tcl_WideInt +#endif #ifdef TCL_WIDE_CLICKS MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void); MODULE_SCOPE double TclpWideClicksToNanoseconds(Tcl_WideInt clicks); MODULE_SCOPE double TclpWideClickInMicrosec(void); #else @@ -3217,311 +3247,317 @@ MODULE_SCOPE Tcl_WideInt TclpGetMicroseconds(void); MODULE_SCOPE int TclZlibInit(Tcl_Interp *interp); MODULE_SCOPE void * TclpThreadCreateKey(void); MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr); -MODULE_SCOPE void TclpThreadSetMasterTSD(void *tsdKeyPtr, void *ptr); -MODULE_SCOPE void * TclpThreadGetMasterTSD(void *tsdKeyPtr); -MODULE_SCOPE void TclErrorStackResetIf(Tcl_Interp *interp, - const char *msg, size_t length); -/* Tip 430 */ -MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp); +MODULE_SCOPE void TclpThreadSetGlobalTSD(void *tsdKeyPtr, void *ptr); +MODULE_SCOPE void * TclpThreadGetGlobalTSD(void *tsdKeyPtr); +MODULE_SCOPE void TclErrorStackResetIf(Tcl_Interp *interp, const char *msg, int length); + +/* + * Many parsing tasks need a common definition of whitespace. + * Use this routine and macro to achieve that and place + * optimization (fragile on changes) in one place. + */ + +MODULE_SCOPE int TclIsSpaceProc(int byte); +# define TclIsSpaceProcM(byte) \ + (((byte) > 0x20) ? 0 : TclIsSpaceProc(byte)) /* *---------------------------------------------------------------- * Command procedures in the generic core: *---------------------------------------------------------------- */ -MODULE_SCOPE int Tcl_AfterObjCmd(void *clientData, +MODULE_SCOPE int Tcl_AfterObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_AppendObjCmd(void *clientData, +MODULE_SCOPE int Tcl_AppendObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ApplyObjCmd(void *clientData, +MODULE_SCOPE int Tcl_ApplyObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitArrayCmd(Tcl_Interp *interp); MODULE_SCOPE Tcl_Command TclInitBinaryCmd(Tcl_Interp *interp); -MODULE_SCOPE int Tcl_BreakObjCmd(void *clientData, +MODULE_SCOPE int Tcl_BreakObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_CatchObjCmd(void *clientData, +MODULE_SCOPE int Tcl_CaseObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_CdObjCmd(void *clientData, +MODULE_SCOPE int Tcl_CatchObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_CdObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitChanCmd(Tcl_Interp *interp); -MODULE_SCOPE int TclChanCreateObjCmd(void *clientData, +MODULE_SCOPE int TclChanCreateObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclChanPostEventObjCmd(void *clientData, +MODULE_SCOPE int TclChanPostEventObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclChanPopObjCmd(void *clientData, +MODULE_SCOPE int TclChanPopObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclChanPushObjCmd(void *clientData, +MODULE_SCOPE int TclChanPushObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE void TclClockInit(Tcl_Interp *interp); MODULE_SCOPE int TclClockOldscanObjCmd( - void *clientData, Tcl_Interp *interp, + ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_CloseObjCmd(void *clientData, +MODULE_SCOPE int Tcl_CloseObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ConcatObjCmd(void *clientData, +MODULE_SCOPE int Tcl_ConcatObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ContinueObjCmd(void *clientData, +MODULE_SCOPE int Tcl_ContinueObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_TimerToken TclCreateAbsoluteTimerHandler( Tcl_Time *timePtr, Tcl_TimerProc *proc, - void *clientData); + ClientData clientData); MODULE_SCOPE int TclDefaultBgErrorHandlerObjCmd( - void *clientData, Tcl_Interp *interp, + ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitDictCmd(Tcl_Interp *interp); MODULE_SCOPE int TclDictWithFinish(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int index, int pathc, Tcl_Obj *const pathv[], Tcl_Obj *keysPtr); MODULE_SCOPE Tcl_Obj * TclDictWithInit(Tcl_Interp *interp, Tcl_Obj *dictPtr, int pathc, Tcl_Obj *const pathv[]); -MODULE_SCOPE int Tcl_DisassembleObjCmd(void *clientData, +MODULE_SCOPE int Tcl_DisassembleObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* Assemble command function */ -MODULE_SCOPE int Tcl_AssembleObjCmd(void *clientData, +MODULE_SCOPE int Tcl_AssembleObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclNRAssembleObjCmd(void *clientData, +MODULE_SCOPE int TclNRAssembleObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitEncodingCmd(Tcl_Interp *interp); -MODULE_SCOPE int Tcl_EofObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ErrorObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_EvalObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ExecObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ExitObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ExprObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_FblockedObjCmd(void *clientData, +MODULE_SCOPE int TclMakeEncodingCommandSafe(Tcl_Interp *interp); +MODULE_SCOPE int Tcl_EofObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_ErrorObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_EvalObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_ExecObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_ExitObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_ExprObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_FblockedObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_FconfigureObjCmd( - void *clientData, Tcl_Interp *interp, + ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_FcopyObjCmd(void *dummy, +MODULE_SCOPE int Tcl_FcopyObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitFileCmd(Tcl_Interp *interp); -MODULE_SCOPE int Tcl_FileEventObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_FlushObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ForObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ForeachObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_FormatObjCmd(void *dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_GetsObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_GlobalObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_GlobObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_IfObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_IncrObjCmd(void *clientData, +MODULE_SCOPE int TclMakeFileCommandSafe(Tcl_Interp *interp); +MODULE_SCOPE int Tcl_FileEventObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_FlushObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_ForObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_ForeachObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_FormatObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_GetsObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_GlobalObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_GlobObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_IfObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_IncrObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitInfoCmd(Tcl_Interp *interp); -MODULE_SCOPE int Tcl_InterpObjCmd(void *clientData, +MODULE_SCOPE int Tcl_InterpObjCmd(ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_JoinObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LappendObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LassignObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LindexObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LinsertObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LlengthObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ListObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LmapObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LoadObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LpopObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LrangeObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LremoveObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LrepeatObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LreplaceObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LreverseObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LsearchObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LsetObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LsortObjCmd(void *clientData, +MODULE_SCOPE int Tcl_JoinObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LappendObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LassignObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LindexObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LinsertObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LlengthObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_ListObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LmapObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LoadObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LrangeObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LrepeatObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LreplaceObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LreverseObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LsearchObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LsetObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LsortObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitNamespaceCmd(Tcl_Interp *interp); -MODULE_SCOPE int TclNamespaceEnsembleCmd(void *dummy, +MODULE_SCOPE int TclNamespaceEnsembleCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_OpenObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_OpenObjCmd(void *clientData, +MODULE_SCOPE int Tcl_PackageObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_PackageObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_PidObjCmd(void *clientData, +MODULE_SCOPE int Tcl_PidObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitPrefixCmd(Tcl_Interp *interp); -MODULE_SCOPE int Tcl_PutsObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_PwdObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ReadObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_RegexpObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_RegsubObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_RenameObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_RepresentationCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ReturnObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ScanObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_SeekObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_SetObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_SplitObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_SocketObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_SourceObjCmd(void *clientData, +MODULE_SCOPE int Tcl_PutsObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_PwdObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_ReadObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_RegexpObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_RegsubObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_RenameObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_RepresentationCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_ReturnObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_ScanObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_SeekObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_SetObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_SplitObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_SocketObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_SourceObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitStringCmd(Tcl_Interp *interp); -MODULE_SCOPE int Tcl_SubstObjCmd(void *clientData, +MODULE_SCOPE int Tcl_SubstObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_SwitchObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_SwitchObjCmd(void *clientData, +MODULE_SCOPE int Tcl_TellObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_TellObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ThrowObjCmd(void *dummy, Tcl_Interp *interp, +MODULE_SCOPE int Tcl_ThrowObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_TimeObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_TimeRateObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_TraceObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_TryObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_UnloadObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_UnsetObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_UpdateObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_UplevelObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_UpvarObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_VariableObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_VwaitObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_WhileObjCmd(void *clientData, +MODULE_SCOPE int Tcl_TimeObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_TimeRateObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_TraceObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_TryObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_UnloadObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_UnsetObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_UpdateObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_UplevelObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_UpvarObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_VariableObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_VwaitObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_WhileObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* *---------------------------------------------------------------- @@ -3572,13 +3608,10 @@ Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictGetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileDictGetWithDefaultCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictIncrCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictLappendCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, @@ -3737,13 +3770,10 @@ Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringIndexCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileStringInsertCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringIsCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringLastCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, @@ -3849,107 +3879,107 @@ struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileBasicMin2ArgCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclInvertOpCmd(void *clientData, +MODULE_SCOPE int TclInvertOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileInvertOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclNotOpCmd(void *clientData, +MODULE_SCOPE int TclNotOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileNotOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclAddOpCmd(void *clientData, +MODULE_SCOPE int TclAddOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileAddOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclMulOpCmd(void *clientData, +MODULE_SCOPE int TclMulOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileMulOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclAndOpCmd(void *clientData, +MODULE_SCOPE int TclAndOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileAndOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclOrOpCmd(void *clientData, +MODULE_SCOPE int TclOrOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileOrOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclXorOpCmd(void *clientData, +MODULE_SCOPE int TclXorOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileXorOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclPowOpCmd(void *clientData, +MODULE_SCOPE int TclPowOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompilePowOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclLshiftOpCmd(void *clientData, +MODULE_SCOPE int TclLshiftOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileLshiftOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclRshiftOpCmd(void *clientData, +MODULE_SCOPE int TclRshiftOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileRshiftOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclModOpCmd(void *clientData, +MODULE_SCOPE int TclModOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileModOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclNeqOpCmd(void *clientData, +MODULE_SCOPE int TclNeqOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileNeqOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclStrneqOpCmd(void *clientData, +MODULE_SCOPE int TclStrneqOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileStrneqOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclInOpCmd(void *clientData, +MODULE_SCOPE int TclInOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileInOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclNiOpCmd(void *clientData, +MODULE_SCOPE int TclNiOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileNiOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclMinusOpCmd(void *clientData, +MODULE_SCOPE int TclMinusOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileMinusOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclDivOpCmd(void *clientData, +MODULE_SCOPE int TclDivOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileDivOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); @@ -3969,50 +3999,15 @@ Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStreqOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileStrLtOpCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileStrLeOpCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileStrGtOpCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileStrGeOpCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileAssembleCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -/* - * Routines that provide the [string] ensemble functionality. Possible - * candidates for public interface. - */ - -MODULE_SCOPE Tcl_Obj * TclStringCat(Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[], int flags); -MODULE_SCOPE size_t TclStringFirst(Tcl_Obj *needle, Tcl_Obj *haystack, - size_t start); -MODULE_SCOPE size_t TclStringLast(Tcl_Obj *needle, Tcl_Obj *haystack, - size_t last); -MODULE_SCOPE Tcl_Obj * TclStringRepeat(Tcl_Interp *interp, Tcl_Obj *objPtr, - size_t count, int flags); -MODULE_SCOPE Tcl_Obj * TclStringReplace(Tcl_Interp *interp, Tcl_Obj *objPtr, - size_t first, size_t 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) - /* * 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. */ @@ -4059,72 +4054,31 @@ /* * So tclObj.c and tclDictObj.c can share these implementations. */ MODULE_SCOPE int TclCompareObjKeys(void *keyPtr, Tcl_HashEntry *hPtr); -MODULE_SCOPE void TclFreeObj(Tcl_Obj *objPtr); MODULE_SCOPE void TclFreeObjEntry(Tcl_HashEntry *hPtr); -MODULE_SCOPE TCL_HASH_TYPE TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr); +MODULE_SCOPE unsigned TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr); MODULE_SCOPE int TclFullFinalizationRequested(void); -/* - * Just for the purposes of command-type registration. - */ - -MODULE_SCOPE Tcl_ObjCmdProc TclEnsembleImplementationCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclAliasObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclLocalAliasObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclSlaveObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclInvokeImportedCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclOOPublicObjectCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclOOPrivateObjectCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclOOMyClassObjCmd; - -/* - * TIP #462. - */ - -/* - * The following enum values give the status of a spawned process. - */ - -typedef enum TclProcessWaitStatus { - TCL_PROCESS_ERROR = -1, /* Error waiting for process to exit */ - TCL_PROCESS_UNCHANGED = 0, /* No change since the last call. */ - TCL_PROCESS_EXITED = 1, /* Process has exited. */ - TCL_PROCESS_SIGNALED = 2, /* Child killed because of a signal. */ - TCL_PROCESS_STOPPED = 3, /* Child suspended because of a signal. */ - TCL_PROCESS_UNKNOWN_STATUS = 4 - /* Child wait status didn't make sense. */ -} TclProcessWaitStatus; - -MODULE_SCOPE Tcl_Command TclInitProcessCmd(Tcl_Interp *interp); -MODULE_SCOPE void TclProcessCreated(Tcl_Pid pid); -MODULE_SCOPE TclProcessWaitStatus TclProcessWait(Tcl_Pid pid, int options, - int *codePtr, Tcl_Obj **msgObjPtr, - Tcl_Obj **errorObjPtr); - -/* - * TIP #508: [array default] - */ - -MODULE_SCOPE void TclInitArrayVar(Var *arrayPtr); -MODULE_SCOPE Tcl_Obj * TclGetArrayDefault(Var *arrayPtr); - /* * Utility routines for encoding index values as integers. Used by both * some of the command compilers and by [lsort] and [lsearch]. */ MODULE_SCOPE int TclIndexEncode(Tcl_Interp *interp, Tcl_Obj *objPtr, - size_t before, size_t after, int *indexPtr); -MODULE_SCOPE size_t TclIndexDecode(int encoded, size_t endValue); + int before, int after, int *indexPtr); +MODULE_SCOPE int TclIndexDecode(int encoded, int endValue); + +MODULE_SCOPE void TclBN_s_mp_reverse(unsigned char *s, size_t len); /* Constants used in index value encoding routines. */ -#define TCL_INDEX_END ((size_t)-2) -#define TCL_INDEX_START ((size_t)0) +#define TCL_INDEX_END (-2) +#define TCL_INDEX_BEFORE (-1) +#define TCL_INDEX_START (0) +#define TCL_INDEX_AFTER (INT_MAX) /* *---------------------------------------------------------------- * Macros used by the Tcl core to create and release Tcl objects. * TclNewObj(objPtr) creates a new object denoting an empty string. @@ -4149,11 +4103,10 @@ * DTrace object allocation probe macros. */ #ifdef USE_DTRACE #ifndef _TCLDTRACE_H -typedef const char *TclDTraceStr; #include "tclDTrace.h" #endif #define TCL_DTRACE_OBJ_CREATE(objPtr) TCL_OBJ_CREATE(objPtr) #define TCL_DTRACE_OBJ_FREE(objPtr) TCL_OBJ_FREE(objPtr) #else /* USE_DTRACE */ @@ -4180,42 +4133,38 @@ #ifndef TCL_MEM_DEBUG # define TclNewObj(objPtr) \ TclIncrObjsAllocated(); \ TclAllocObjStorage(objPtr); \ (objPtr)->refCount = 0; \ - (objPtr)->bytes = &tclEmptyString; \ + (objPtr)->bytes = tclEmptyStringRep; \ (objPtr)->length = 0; \ (objPtr)->typePtr = NULL; \ TCL_DTRACE_OBJ_CREATE(objPtr) /* * Invalidate the string rep first so we can use the bytes value for our * pointer chain, and signal an obj deletion (as opposed to shimmering) with - * 'length == TCL_AUTO_LENGTH'. + * 'length == -1'. * Use empty 'if ; else' to handle use in unbraced outer if/else conditions. */ # define TclDecrRefCount(objPtr) \ if ((objPtr)->refCount-- > 1) ; else { \ if (!(objPtr)->typePtr || !(objPtr)->typePtr->freeIntRepProc) { \ TCL_DTRACE_OBJ_FREE(objPtr); \ if ((objPtr)->bytes \ - && ((objPtr)->bytes != &tclEmptyString)) { \ - Tcl_Free((objPtr)->bytes); \ + && ((objPtr)->bytes != tclEmptyStringRep)) { \ + ckfree((char *) (objPtr)->bytes); \ } \ - (objPtr)->length = TCL_AUTO_LENGTH; \ + (objPtr)->length = -1; \ TclFreeObjStorage(objPtr); \ TclIncrObjsFreed(); \ } else { \ TclFreeObj(objPtr); \ } \ } -#if TCL_THREADS && !defined(USE_THREAD_ALLOC) -# define USE_THREAD_ALLOC 1 -#endif - #if defined(PURIFY) /* * The PURIFY mode is like the regular mode, but instead of doing block * Tcl_Obj allocation and keeping a freed list for efficiency, it always @@ -4222,18 +4171,18 @@ * allocates and frees a single Tcl_Obj so that tools like Purify can better * track memory leaks. */ # define TclAllocObjStorageEx(interp, objPtr) \ - (objPtr) = (Tcl_Obj *) Tcl_Alloc(sizeof(Tcl_Obj)) + (objPtr) = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj)) # define TclFreeObjStorageEx(interp, objPtr) \ - Tcl_Free(objPtr) + ckfree((char *) (objPtr)) #undef USE_THREAD_ALLOC #undef USE_TCLALLOC -#elif TCL_THREADS && defined(USE_THREAD_ALLOC) +#elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) /* * The TCL_THREADS mode is like the regular mode but allocates Tcl_Obj's from * per-thread caches. */ @@ -4243,11 +4192,10 @@ MODULE_SCOPE Tcl_Mutex *TclpNewAllocMutex(void); MODULE_SCOPE void TclFreeAllocCache(void *); MODULE_SCOPE void * TclpGetAllocCache(void); MODULE_SCOPE void TclpSetAllocCache(void *); MODULE_SCOPE void TclpFreeAllocMutex(Tcl_Mutex *mutex); -MODULE_SCOPE void TclpInitAllocCache(void); MODULE_SCOPE void TclpFreeAllocCache(void *); /* * These macros need to be kept in sync with the code of TclThreadAllocObj() * and TclThreadFreeObj(). @@ -4294,11 +4242,11 @@ MODULE_SCOPE void TclInitAlloc(); #else # define USE_TCLALLOC 0 #endif -#if TCL_THREADS +#ifdef TCL_THREADS /* declared in tclObj.c */ MODULE_SCOPE Tcl_Mutex tclObjMutex; #endif # define TclAllocObjStorageEx(interp, objPtr) \ @@ -4353,24 +4301,24 @@ * copy of the "len" bytes starting at "bytePtr". This code works even if the * byte array contains NULLs as long as the length is correct. Because "len" * is referenced multiple times, it should be as simple an expression as * possible. The ANSI C "prototype" for this macro is: * - * MODULE_SCOPE void TclInitStringRep(Tcl_Obj *objPtr, char *bytePtr, size_t len); + * MODULE_SCOPE void TclInitStringRep(Tcl_Obj *objPtr, char *bytePtr, int len); * * This macro should only be called on an unshared objPtr where * objPtr->typePtr->freeIntRepProc == NULL *---------------------------------------------------------------- */ #define TclInitStringRep(objPtr, bytePtr, len) \ if ((len) == 0) { \ - (objPtr)->bytes = &tclEmptyString; \ + (objPtr)->bytes = tclEmptyStringRep; \ (objPtr)->length = 0; \ } else { \ - (objPtr)->bytes = Tcl_Alloc((len) + 1); \ - memcpy((objPtr)->bytes, (bytePtr) ? (bytePtr) : &tclEmptyString, (len)); \ + (objPtr)->bytes = (char *) ckalloc((len) + 1); \ + memcpy((objPtr)->bytes, (bytePtr), (len)); \ (objPtr)->bytes[len] = '\0'; \ (objPtr)->length = (len); \ } /* @@ -4384,44 +4332,16 @@ * MODULE_SCOPE char * TclGetString(Tcl_Obj *objPtr); *---------------------------------------------------------------- */ #define TclGetString(objPtr) \ - ((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString(objPtr)) - -#if 0 - static inline char *TclGetStringFromObj(Tcl_Obj *objPtr, size_t *lenPtr) { - char *response = Tcl_GetString(objPtr); - *(lenPtr) = objPtr->length; - return response; - } - static inline Tcl_UniChar *TclGetUnicodeFromObj(Tcl_Obj *objPtr, size_t *lenPtr) { - Tcl_UniChar *response = Tcl_GetUnicodeFromObj(objPtr, NULL); - *(lenPtr) = *((size_t *) (objPtr)->internalRep.twoPtrValue.ptr1); - return response; - } - static inline unsigned char *TclGetByteArrayFromObj(Tcl_Obj *objPtr, size_t *lenPtr) { - unsigned char *response = Tcl_GetByteArrayFromObj(objPtr, NULL); - if (response) { - *(lenPtr) = *((size_t *) (objPtr)->internalRep.twoPtrValue.ptr1); - } - return response; - } -#else + ((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString((objPtr))) + #define TclGetStringFromObj(objPtr, lenPtr) \ - (((objPtr)->bytes \ - ? NULL : Tcl_GetString((objPtr)), \ - *(lenPtr) = (objPtr)->length, (objPtr)->bytes)) -#define TclGetUnicodeFromObj(objPtr, lenPtr) \ - (Tcl_GetUnicodeFromObj((objPtr), NULL), \ - *(lenPtr) = *((size_t *) (objPtr)->internalRep.twoPtrValue.ptr1), \ - Tcl_GetUnicodeFromObj((objPtr), NULL)) -#define TclGetByteArrayFromObj(objPtr, lenPtr) \ - (Tcl_GetByteArrayFromObj((objPtr), NULL) ? \ - (*(lenPtr) = *((size_t *) (objPtr)->internalRep.twoPtrValue.ptr1), \ - (unsigned char *)(((size_t *) (objPtr)->internalRep.twoPtrValue.ptr1) + 2)) : NULL) -#endif + ((objPtr)->bytes \ + ? (*(lenPtr) = (objPtr)->length, (objPtr)->bytes) \ + : Tcl_GetStringFromObj((objPtr), (lenPtr))) /* *---------------------------------------------------------------- * Macro used by the Tcl core to clean out an object's internal * representation. Does not actually reset the rep's bytes. The ANSI C @@ -4447,53 +4367,22 @@ * MODULE_SCOPE void TclInvalidateStringRep(Tcl_Obj *objPtr); *---------------------------------------------------------------- */ #define TclInvalidateStringRep(objPtr) \ - if ((objPtr)->bytes != NULL) { \ - if ((objPtr)->bytes != &tclEmptyString) { \ - Tcl_Free((objPtr)->bytes); \ + do { \ + Tcl_Obj *_isobjPtr = (Tcl_Obj *)(objPtr); \ + if (_isobjPtr->bytes != NULL) { \ + if (_isobjPtr->bytes != tclEmptyStringRep) { \ + ckfree((char *)_isobjPtr->bytes); \ + } \ + _isobjPtr->bytes = NULL; \ } \ - (objPtr)->bytes = NULL; \ - } - -/* - *---------------------------------------------------------------- - * Macro used by the Tcl core to test whether an object has a - * string representation (or is a 'pure' internal value). - * The ANSI C "prototype" for this macro is: - * - * MODULE_SCOPE int TclHasStringRep(Tcl_Obj *objPtr); - *---------------------------------------------------------------- - */ - -#define TclHasStringRep(objPtr) ((objPtr)->bytes != NULL) - -/* - *---------------------------------------------------------------- - * Macro used by the Tcl core to get the bignum out of the bignum - * representation of a Tcl_Obj. - * The ANSI C "prototype" for this macro is: - * - * MODULE_SCOPE void TclUnpackBignum(Tcl_Obj *objPtr, mp_int bignum); - *---------------------------------------------------------------- - */ - -#define TclUnpackBignum(objPtr, bignum) \ - do { \ - register Tcl_Obj *bignumObj = (objPtr); \ - register int bignumPayload = \ - PTR2INT(bignumObj->internalRep.twoPtrValue.ptr2); \ - if (bignumPayload == -1) { \ - (bignum) = *((mp_int *) bignumObj->internalRep.twoPtrValue.ptr1); \ - } else { \ - (bignum).dp = bignumObj->internalRep.twoPtrValue.ptr1; \ - (bignum).sign = bignumPayload >> 30; \ - (bignum).alloc = (bignumPayload >> 15) & 0x7fff; \ - (bignum).used = bignumPayload & 0x7fff; \ - } \ } while (0) + +#define TclHasStringRep(objPtr) \ + ((objPtr)->bytes != NULL) /* *---------------------------------------------------------------- * Macros used by the Tcl core to grow Tcl_Token arrays. They use the same * growth algorithm as used in tclStringObj.c for growing strings. The ANSI C @@ -4538,24 +4427,24 @@ oldPtr = NULL; \ } \ if (allocated > TCL_MAX_TOKENS) { \ allocated = TCL_MAX_TOKENS; \ } \ - newPtr = (Tcl_Token *) Tcl_AttemptRealloc((char *) oldPtr, \ - (allocated * sizeof(Tcl_Token))); \ + newPtr = (Tcl_Token *) attemptckrealloc((char *) oldPtr, \ + (unsigned int) (allocated * sizeof(Tcl_Token))); \ if (newPtr == NULL) { \ allocated = _needed + (append) + TCL_MIN_TOKEN_GROWTH; \ if (allocated > TCL_MAX_TOKENS) { \ allocated = TCL_MAX_TOKENS; \ } \ - newPtr = (Tcl_Token *) Tcl_Realloc((char *) oldPtr, \ - (allocated * sizeof(Tcl_Token))); \ + newPtr = (Tcl_Token *) ckrealloc((char *) oldPtr, \ + (unsigned int) (allocated * sizeof(Tcl_Token))); \ } \ (available) = allocated; \ if (oldPtr == NULL) { \ memcpy(newPtr, staticPtr, \ - ((used) * sizeof(Tcl_Token))); \ + (size_t) ((used) * sizeof(Tcl_Token))); \ } \ (tokenPtr) = newPtr; \ } \ } while (0) @@ -4575,12 +4464,12 @@ * MODULE_SCOPE int TclUtfToUniChar(const char *string, Tcl_UniChar *ch); *---------------------------------------------------------------- */ #define TclUtfToUniChar(str, chPtr) \ - ((((unsigned char) *(str)) < 0x80) ? \ - ((*(chPtr) = (unsigned char) *(str)), 1) \ + (((UCHAR(*(str))) < 0x80) ? \ + ((*(chPtr) = UCHAR(*(str))), 1) \ : Tcl_UtfToUniChar(str, chPtr)) /* *---------------------------------------------------------------- * Macro counterpart of the Tcl_NumUtfChars() function. To be used in speed- @@ -4587,25 +4476,30 @@ * -sensitive points where it pays to avoid a function call in the common case * of counting along a string of all one-byte characters. The ANSI C * "prototype" for this macro is: * * MODULE_SCOPE void TclNumUtfChars(int numChars, const char *bytes, - * size_t numBytes); + * int numBytes); *---------------------------------------------------------------- */ #define TclNumUtfChars(numChars, bytes, numBytes) \ do { \ - size_t _count, _i = (numBytes); \ + int _count, _i = (numBytes); \ unsigned char *_str = (unsigned char *) (bytes); \ while (_i && (*_str < 0xC0)) { _i--; _str++; } \ _count = (numBytes) - _i; \ if (_i) { \ _count += Tcl_NumUtfChars((bytes) + _count, _i); \ } \ (numChars) = _count; \ } while (0); + +#define TclUtfPrev(src, start) \ + (((src) < (start)+2) ? (start) : \ + (UCHAR(*((src) - 1))) < 0x80 ? (src)-1 : \ + Tcl_UtfPrev(src, start)) /* *---------------------------------------------------------------- * Macro that encapsulates the logic that determines when it is safe to * interpret a string as a byte array directly. In summary, the object must be @@ -4618,18 +4512,17 @@ * * MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr); *---------------------------------------------------------------- */ -MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr); +#define TclIsPureByteArray(objPtr) \ + (((objPtr)->typePtr==&tclByteArrayType) && ((objPtr)->bytes==NULL)) #define TclIsPureDict(objPtr) \ (((objPtr)->bytes==NULL) && ((objPtr)->typePtr==&tclDictType)) -#define TclHasIntRep(objPtr, type) \ - ((objPtr)->typePtr == (type)) -#define TclFetchIntRep(objPtr, type) \ - (TclHasIntRep((objPtr), (type)) ? &((objPtr)->internalRep) : NULL) +#define TclIsPureList(objPtr) \ + (((objPtr)->bytes==NULL) && ((objPtr)->typePtr==&tclListType)) /* *---------------------------------------------------------------- * Macro used by the Tcl core to compare Unicode strings. On big-endian * systems we can use the more efficient memcmp, but this would not be @@ -4707,57 +4600,96 @@ * Macros used by the Tcl core to set a Tcl_Obj's numeric representation * avoiding the corresponding function calls in time critical parts of the * core. They should only be called on unshared objects. The ANSI C * "prototypes" for these macros are: * - * MODULE_SCOPE void TclSetIntObj(Tcl_Obj *objPtr, Tcl_WideInt w); + * MODULE_SCOPE void TclSetIntObj(Tcl_Obj *objPtr, int intValue); + * MODULE_SCOPE void TclSetLongObj(Tcl_Obj *objPtr, long longValue); + * MODULE_SCOPE void TclSetBooleanObj(Tcl_Obj *objPtr, long boolValue); + * MODULE_SCOPE void TclSetWideIntObj(Tcl_Obj *objPtr, Tcl_WideInt w); * MODULE_SCOPE void TclSetDoubleObj(Tcl_Obj *objPtr, double d); *---------------------------------------------------------------- */ -#define TclSetIntObj(objPtr, i) \ +#define TclSetLongObj(objPtr, i) \ do { \ - Tcl_ObjIntRep ir; \ - ir.wideValue = (Tcl_WideInt) i; \ TclInvalidateStringRep(objPtr); \ - Tcl_StoreIntRep(objPtr, &tclIntType, &ir); \ + TclFreeIntRep(objPtr); \ + (objPtr)->internalRep.longValue = (long)(i); \ + (objPtr)->typePtr = &tclIntType; \ + } while (0) + +#define TclSetIntObj(objPtr, l) \ + TclSetLongObj(objPtr, l) + +/* + * NOTE: There is to be no such thing as a "pure" boolean. Boolean values set + * programmatically go straight to being "int" Tcl_Obj's, with value 0 or 1. + * The only "boolean" Tcl_Obj's shall be those holding the cached boolean + * value of strings like: "yes", "no", "true", "false", "on", "off". + */ + +#define TclSetBooleanObj(objPtr, b) \ + TclSetLongObj(objPtr, (b)!=0); + +#ifndef TCL_WIDE_INT_IS_LONG +#define TclSetWideIntObj(objPtr, w) \ + do { \ + TclInvalidateStringRep(objPtr); \ + TclFreeIntRep(objPtr); \ + (objPtr)->internalRep.wideValue = (Tcl_WideInt)(w); \ + (objPtr)->typePtr = &tclWideIntType; \ } while (0) +#endif #define TclSetDoubleObj(objPtr, d) \ - do { \ - Tcl_ObjIntRep ir; \ - ir.doubleValue = (double) d; \ - TclInvalidateStringRep(objPtr); \ - Tcl_StoreIntRep(objPtr, &tclDoubleType, &ir); \ + do { \ + TclInvalidateStringRep(objPtr); \ + TclFreeIntRep(objPtr); \ + (objPtr)->internalRep.doubleValue = (double)(d); \ + (objPtr)->typePtr = &tclDoubleType; \ } while (0) /* *---------------------------------------------------------------- * Macros used by the Tcl core to create and initialise objects of standard * types, avoiding the corresponding function calls in time critical parts of * the core. The ANSI C "prototypes" for these macros are: * - * MODULE_SCOPE void TclNewIntObj(Tcl_Obj *objPtr, Tcl_WideInt w); + * MODULE_SCOPE void TclNewIntObj(Tcl_Obj *objPtr, int i); + * MODULE_SCOPE void TclNewLongObj(Tcl_Obj *objPtr, long l); + * MODULE_SCOPE void TclNewBooleanObj(Tcl_Obj *objPtr, int b); + * MODULE_SCOPE void TclNewWideObj(Tcl_Obj *objPtr, Tcl_WideInt w); * MODULE_SCOPE void TclNewDoubleObj(Tcl_Obj *objPtr, double d); - * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, const char *s, size_t len); - * MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, const char *sLiteral); + * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, char *s, int len); + * MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, char*sLiteral); * *---------------------------------------------------------------- */ #ifndef TCL_MEM_DEBUG -#define TclNewIntObj(objPtr, i) \ +#define TclNewLongObj(objPtr, i) \ do { \ TclIncrObjsAllocated(); \ TclAllocObjStorage(objPtr); \ (objPtr)->refCount = 0; \ (objPtr)->bytes = NULL; \ - (objPtr)->internalRep.wideValue = (Tcl_WideInt)(i); \ + (objPtr)->internalRep.longValue = (long)(i); \ (objPtr)->typePtr = &tclIntType; \ TCL_DTRACE_OBJ_CREATE(objPtr); \ } while (0) +#define TclNewIntObj(objPtr, l) \ + TclNewLongObj(objPtr, l) + +/* + * NOTE: There is to be no such thing as a "pure" boolean. + * See comment above TclSetBooleanObj macro above. + */ +#define TclNewBooleanObj(objPtr, b) \ + TclNewLongObj((objPtr), (b)!=0) + #define TclNewDoubleObj(objPtr, d) \ do { \ TclIncrObjsAllocated(); \ TclAllocObjStorage(objPtr); \ (objPtr)->refCount = 0; \ @@ -4776,12 +4708,18 @@ (objPtr)->typePtr = NULL; \ TCL_DTRACE_OBJ_CREATE(objPtr); \ } while (0) #else /* TCL_MEM_DEBUG */ -#define TclNewIntObj(objPtr, w) \ - (objPtr) = Tcl_NewWideIntObj(w) +#define TclNewIntObj(objPtr, i) \ + (objPtr) = Tcl_NewIntObj(i) + +#define TclNewLongObj(objPtr, l) \ + (objPtr) = Tcl_NewLongObj(l) + +#define TclNewBooleanObj(objPtr, b) \ + (objPtr) = Tcl_NewBooleanObj(b) #define TclNewDoubleObj(objPtr, d) \ (objPtr) = Tcl_NewDoubleObj(d) #define TclNewStringObj(objPtr, s, len) \ @@ -4791,11 +4729,11 @@ /* * The sLiteral argument *must* be a string literal; the incantation with * sizeof(sLiteral "") will fail to compile otherwise. */ #define TclNewLiteralStringObj(objPtr, sLiteral) \ - TclNewStringObj((objPtr), (sLiteral), sizeof(sLiteral "") - 1) + TclNewStringObj((objPtr), (sLiteral), (int) (sizeof(sLiteral "") - 1)) /* *---------------------------------------------------------------- * Convenience macros for DStrings. * The ANSI C "prototypes" for these macros are: @@ -4804,11 +4742,11 @@ * const char *sLiteral); * MODULE_SCOPE void TclDStringClear(Tcl_DString *dsPtr); */ #define TclDStringAppendLiteral(dsPtr, sLiteral) \ - Tcl_DStringAppend((dsPtr), (sLiteral), sizeof(sLiteral "") - 1) + Tcl_DStringAppend((dsPtr), (sLiteral), (int) (sizeof(sLiteral "") - 1)) #define TclDStringClear(dsPtr) \ Tcl_DStringSetLength((dsPtr), 0) /* *---------------------------------------------------------------- @@ -4829,13 +4767,20 @@ # else # define TclIsNaN(d) (isnan(d)) # endif #endif -/* Workaround for platforms missing offsetof(), e.g. VC++ 6.0 */ -#ifndef offsetof -# define offsetof(type, field) ((size_t) ((char *) &((type *) 0)->field)) +/* + * ---------------------------------------------------------------------- + * Macro to use to find the offset of a field in a structure. Computes number + * of bytes from beginning of structure to a given field. + */ + +#ifdef offsetof +#define TclOffset(type, field) ((int) offsetof(type, field)) +#else +#define TclOffset(type, field) ((int) ((char *) &((type *) 0)->field)) #endif /* *---------------------------------------------------------------- * Inline version of Tcl_GetCurrentNamespace and Tcl_GetGlobalNamespace. @@ -4853,11 +4798,11 @@ * the internal stubs, but the core can use the macro instead. */ #define TclCleanupCommandMacro(cmdPtr) \ if ((cmdPtr)->refCount-- <= 1) { \ - Tcl_Free(cmdPtr);\ + ckfree((char *) (cmdPtr));\ } /* *---------------------------------------------------------------- * Inline versions of Tcl_LimitReady() and Tcl_LimitExceeded to limit number @@ -4916,27 +4861,27 @@ #define TclSmallAllocEx(interp, nbytes, memPtr) \ do { \ Tcl_Obj *_objPtr; \ TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \ TclIncrObjsAllocated(); \ - TclAllocObjStorageEx((interp), _objPtr); \ - memPtr = (void *)_objPtr; \ + TclAllocObjStorageEx((interp), (_objPtr)); \ + memPtr = (ClientData) (_objPtr); \ } while (0) #define TclSmallFreeEx(interp, memPtr) \ do { \ - TclFreeObjStorageEx((interp), (Tcl_Obj *)memPtr); \ + TclFreeObjStorageEx((interp), (Tcl_Obj *) (memPtr)); \ TclIncrObjsFreed(); \ } while (0) #else /* TCL_MEM_DEBUG */ #define TclSmallAllocEx(interp, nbytes, memPtr) \ do { \ Tcl_Obj *_objPtr; \ TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \ TclNewObj(_objPtr); \ - memPtr = (void *)_objPtr; \ + memPtr = (ClientData) _objPtr; \ } while (0) #define TclSmallFreeEx(interp, memPtr) \ do { \ Tcl_Obj *_objPtr = (Tcl_Obj *) memPtr; \ @@ -4945,25 +4890,10 @@ _objPtr->refCount = 1; \ TclDecrRefCount(_objPtr); \ } while (0) #endif /* TCL_MEM_DEBUG */ -/* - * Macros to convert size_t to wide-int (and wide-int object) considering - * platform-related negative value ((size_t)-1), if wide-int and size_t - * have different dimensions (e. g. 32-bit platform). - */ - -#if (!defined(TCL_WIDE_INT_IS_LONG) || (LONG_MAX > UINT_MAX)) && (SIZE_MAX <= UINT_MAX) -# define TclWideIntFromSize(value) (((Tcl_WideInt)(((size_t)(value))+1))-1) -# define TclNewWideIntObjFromSize(value) \ - Tcl_NewWideIntObj(TclWideIntFromSize(value)) -#else -# define TclWideIntFromSize(value) ((Tcl_WideInt)(value)) -# define TclNewWideIntObjFromSize Tcl_NewWideIntObj -#endif - /* * Support for Clang Static Analyzer */ #if defined(PURIFY) && defined(__clang__) @@ -4996,11 +4926,11 @@ * available. */ typedef struct NRE_callback { Tcl_NRPostProc *procPtr; - void *data[4]; + ClientData data[4]; struct NRE_callback *nextPtr; } NRE_callback; #define TOP_CB(iPtr) (((Interp *)(iPtr))->execEnvPtr->callbackPtr) @@ -5011,14 +4941,14 @@ #define TclNRAddCallback(interp,postProcPtr,data0,data1,data2,data3) \ do { \ NRE_callback *_callbackPtr; \ TCLNR_ALLOC((interp), (_callbackPtr)); \ _callbackPtr->procPtr = (postProcPtr); \ - _callbackPtr->data[0] = (void *)(data0); \ - _callbackPtr->data[1] = (void *)(data1); \ - _callbackPtr->data[2] = (void *)(data2); \ - _callbackPtr->data[3] = (void *)(data3); \ + _callbackPtr->data[0] = (ClientData)(data0); \ + _callbackPtr->data[1] = (ClientData)(data1); \ + _callbackPtr->data[2] = (ClientData)(data2); \ + _callbackPtr->data[3] = (ClientData)(data3); \ _callbackPtr->nextPtr = TOP_CB(interp); \ TOP_CB(interp) = _callbackPtr; \ } while (0) #if NRE_USE_SMALL_ALLOC @@ -5025,12 +4955,12 @@ #define TCLNR_ALLOC(interp, ptr) \ TclSmallAllocEx(interp, sizeof(NRE_callback), (ptr)) #define TCLNR_FREE(interp, ptr) TclSmallFreeEx((interp), (ptr)) #else #define TCLNR_ALLOC(interp, ptr) \ - (ptr = (Tcl_Alloc(sizeof(NRE_callback)))) -#define TCLNR_FREE(interp, ptr) Tcl_Free(ptr) + (ptr = ((ClientData) ckalloc(sizeof(NRE_callback)))) +#define TCLNR_FREE(interp, ptr) ckfree((char *) (ptr)) #endif #if NRE_ENABLE_ASSERTS #define NRE_ASSERT(expr) assert((expr)) #else @@ -5040,13 +4970,13 @@ #include "tclIntDecls.h" #include "tclIntPlatDecls.h" #include "tclTomMathDecls.h" #if !defined(USE_TCL_STUBS) && !defined(TCL_MEM_DEBUG) -#define Tcl_AttemptAlloc TclpAlloc -#define Tcl_AttemptRealloc TclpRealloc -#define Tcl_Free TclpFree +#define Tcl_AttemptAlloc(size) TclpAlloc(size) +#define Tcl_AttemptRealloc(ptr, size) TclpRealloc((ptr), (size)) +#define Tcl_Free(ptr) TclpFree(ptr) #endif #endif /* _TCLINT */ /* Index: generic/tclIntDecls.h ================================================================== --- generic/tclIntDecls.h +++ generic/tclIntDecls.h @@ -25,10 +25,26 @@ # else # define TCL_STORAGE_CLASS DLLIMPORT # endif #endif +/* [Bug #803489] Tcl_FindNamespace problem in the Stubs table */ +#undef Tcl_CreateNamespace +#undef Tcl_DeleteNamespace +#undef Tcl_AppendExportList +#undef Tcl_Export +#undef Tcl_Import +#undef Tcl_ForgetImport +#undef Tcl_GetCurrentNamespace +#undef Tcl_GetGlobalNamespace +#undef Tcl_FindNamespace +#undef Tcl_FindCommand +#undef Tcl_GetCommandFromObj +#undef Tcl_GetCommandFullName +#undef Tcl_SetStartupScript +#undef Tcl_GetStartupScript + /* * WARNING: This file is automatically generated by the tools/genStubs.tcl * script. Any modifications to the function declarations below should be made * in the generic/tclInt.decls script. */ @@ -53,13 +69,16 @@ EXTERN int TclCleanupChildren(Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 6 */ EXTERN void TclCleanupCommand(Command *cmdPtr); /* 7 */ -EXTERN size_t TclCopyAndCollapse(size_t count, const char *src, +EXTERN int TclCopyAndCollapse(int count, const char *src, char *dst); -/* Slot 8 is reserved */ +/* 8 */ +EXTERN int TclCopyChannelOld(Tcl_Interp *interp, + Tcl_Channel inChan, Tcl_Channel outChan, + int toRead, Tcl_Obj *cmdPtr); /* 9 */ EXTERN int TclCreatePipeline(Tcl_Interp *interp, int argc, const char **argv, Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr); @@ -73,11 +92,11 @@ /* 12 */ EXTERN void TclDeleteVars(Interp *iPtr, TclVarHashTable *tablePtr); /* Slot 13 is reserved */ /* 14 */ -EXTERN int TclDumpMemoryInfo(void *clientData, int flags); +EXTERN int TclDumpMemoryInfo(ClientData clientData, int flags); /* Slot 15 is reserved */ /* 16 */ EXTERN void TclExprFloatError(Tcl_Interp *interp, double value); /* Slot 17 is reserved */ /* Slot 18 is reserved */ @@ -86,16 +105,16 @@ /* Slot 21 is reserved */ /* 22 */ EXTERN int TclFindElement(Tcl_Interp *interp, const char *listStr, int listLength, const char **elementPtr, - const char **nextPtr, size_t *sizePtr, + const char **nextPtr, int *sizePtr, int *bracePtr); /* 23 */ EXTERN Proc * TclFindProc(Interp *iPtr, const char *procName); /* 24 */ -EXTERN size_t TclFormatInt(char *buffer, Tcl_WideInt n); +EXTERN int TclFormatInt(char *buffer, long n); /* 25 */ EXTERN void TclFreePackageInfo(Interp *iPtr); /* Slot 26 is reserved */ /* Slot 27 is reserved */ /* 28 */ @@ -106,11 +125,13 @@ EXTERN const char * TclGetExtension(const char *name); /* 32 */ EXTERN int TclGetFrame(Tcl_Interp *interp, const char *str, CallFrame **framePtrPtr); /* Slot 33 is reserved */ -/* Slot 34 is reserved */ +/* 34 */ +EXTERN int TclGetIntForIndex(Tcl_Interp *interp, + Tcl_Obj *objPtr, int endValue, int *indexPtr); /* Slot 35 is reserved */ /* Slot 36 is reserved */ /* 37 */ EXTERN int TclGetLoadedPackages(Tcl_Interp *interp, const char *targetName); @@ -127,11 +148,11 @@ EXTERN int TclGetOpenMode(Tcl_Interp *interp, const char *str, int *seekFlagPtr); /* 41 */ EXTERN Tcl_Command TclGetOriginalCommand(Tcl_Command command); /* 42 */ -EXTERN const char * TclpGetUserHome(const char *name, +EXTERN CONST86 char * TclpGetUserHome(const char *name, Tcl_DString *bufferPtr); /* Slot 43 is reserved */ /* 44 */ EXTERN int TclGuessPackageName(const char *fileName, Tcl_DString *bufPtr); @@ -147,15 +168,15 @@ CallFrame *framePtr, Namespace *nsPtr); /* 51 */ EXTERN int TclInterpInit(Tcl_Interp *interp); /* Slot 52 is reserved */ /* 53 */ -EXTERN int TclInvokeObjectCommand(void *clientData, +EXTERN int TclInvokeObjectCommand(ClientData clientData, Tcl_Interp *interp, int argc, - const char **argv); + CONST84 char **argv); /* 54 */ -EXTERN int TclInvokeStringCommand(void *clientData, +EXTERN int TclInvokeStringCommand(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 55 */ EXTERN Proc * TclIsProc(Command *cmdPtr); /* Slot 56 is reserved */ @@ -171,11 +192,11 @@ /* 61 */ EXTERN Tcl_Obj * TclNewProcBodyObj(Proc *procPtr); /* 62 */ EXTERN int TclObjCommandComplete(Tcl_Obj *cmdPtr); /* 63 */ -EXTERN int TclObjInterpProc(void *clientData, +EXTERN int TclObjInterpProc(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 64 */ EXTERN int TclObjInvoke(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); @@ -182,34 +203,38 @@ /* Slot 65 is reserved */ /* Slot 66 is reserved */ /* Slot 67 is reserved */ /* Slot 68 is reserved */ /* 69 */ -EXTERN void * TclpAlloc(size_t size); +EXTERN char * TclpAlloc(unsigned int size); /* Slot 70 is reserved */ /* Slot 71 is reserved */ /* Slot 72 is reserved */ /* Slot 73 is reserved */ /* 74 */ -EXTERN void TclpFree(void *ptr); +EXTERN void TclpFree(char *ptr); /* 75 */ -EXTERN Tcl_WideUInt TclpGetClicks(void); +EXTERN unsigned long TclpGetClicks(void); /* 76 */ -EXTERN Tcl_WideUInt TclpGetSeconds(void); -/* Slot 77 is reserved */ +EXTERN unsigned long TclpGetSeconds(void); +/* 77 */ +EXTERN void TclpGetTime(Tcl_Time *time); /* Slot 78 is reserved */ /* Slot 79 is reserved */ /* Slot 80 is reserved */ /* 81 */ -EXTERN void * TclpRealloc(void *ptr, size_t size); +EXTERN char * TclpRealloc(char *ptr, unsigned int size); /* Slot 82 is reserved */ /* Slot 83 is reserved */ /* Slot 84 is reserved */ /* Slot 85 is reserved */ /* Slot 86 is reserved */ /* Slot 87 is reserved */ -/* Slot 88 is reserved */ +/* 88 */ +EXTERN char * TclPrecTraceProc(ClientData clientData, + Tcl_Interp *interp, const char *name1, + const char *name2, int flags); /* 89 */ EXTERN int TclPreventAliasLoop(Tcl_Interp *interp, Tcl_Interp *cmdInterp, Tcl_Command cmd); /* Slot 90 is reserved */ /* 91 */ @@ -218,11 +243,11 @@ EXTERN int TclProcCompileProc(Tcl_Interp *interp, Proc *procPtr, Tcl_Obj *bodyPtr, Namespace *nsPtr, const char *description, const char *procName); /* 93 */ -EXTERN void TclProcDeleteProc(void *clientData); +EXTERN void TclProcDeleteProc(ClientData clientData); /* Slot 94 is reserved */ /* Slot 95 is reserved */ /* 96 */ EXTERN int TclRenameCommand(Tcl_Interp *interp, const char *oldName, const char *newName); @@ -232,17 +257,18 @@ /* 98 */ EXTERN int TclServiceIdle(void); /* Slot 99 is reserved */ /* Slot 100 is reserved */ /* 101 */ -EXTERN const char * TclSetPreInitScript(const char *string); +EXTERN CONST86 char * TclSetPreInitScript(const char *string); /* 102 */ EXTERN void TclSetupEnv(Tcl_Interp *interp); /* 103 */ EXTERN int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); -/* Slot 104 is reserved */ +/* 104 */ +EXTERN int TclSockMinimumBuffersOld(int sock, int size); /* Slot 105 is reserved */ /* Slot 106 is reserved */ /* Slot 107 is reserved */ /* 108 */ EXTERN void TclTeardownNamespace(Namespace *nsPtr); @@ -254,16 +280,29 @@ EXTERN void Tcl_AddInterpResolvers(Tcl_Interp *interp, const char *name, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); -/* Slot 112 is reserved */ -/* Slot 113 is reserved */ -/* Slot 114 is reserved */ -/* Slot 115 is reserved */ -/* Slot 116 is reserved */ -/* Slot 117 is reserved */ +/* 112 */ +EXTERN int Tcl_AppendExportList(Tcl_Interp *interp, + Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); +/* 113 */ +EXTERN Tcl_Namespace * Tcl_CreateNamespace(Tcl_Interp *interp, + const char *name, ClientData clientData, + Tcl_NamespaceDeleteProc *deleteProc); +/* 114 */ +EXTERN void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr); +/* 115 */ +EXTERN int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + const char *pattern, int resetListFirst); +/* 116 */ +EXTERN Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name, + Tcl_Namespace *contextNsPtr, int flags); +/* 117 */ +EXTERN Tcl_Namespace * Tcl_FindNamespace(Tcl_Interp *interp, + const char *name, + Tcl_Namespace *contextNsPtr, int flags); /* 118 */ EXTERN int Tcl_GetInterpResolvers(Tcl_Interp *interp, const char *name, Tcl_ResolverInfo *resInfo); /* 119 */ EXTERN int Tcl_GetNamespaceResolvers( @@ -271,19 +310,29 @@ Tcl_ResolverInfo *resInfo); /* 120 */ EXTERN Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); -/* Slot 121 is reserved */ -/* Slot 122 is reserved */ -/* Slot 123 is reserved */ -/* Slot 124 is reserved */ -/* Slot 125 is reserved */ +/* 121 */ +EXTERN int Tcl_ForgetImport(Tcl_Interp *interp, + Tcl_Namespace *nsPtr, const char *pattern); +/* 122 */ +EXTERN Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, + Tcl_Obj *objPtr); +/* 123 */ +EXTERN void Tcl_GetCommandFullName(Tcl_Interp *interp, + Tcl_Command command, Tcl_Obj *objPtr); +/* 124 */ +EXTERN Tcl_Namespace * Tcl_GetCurrentNamespace(Tcl_Interp *interp); +/* 125 */ +EXTERN Tcl_Namespace * Tcl_GetGlobalNamespace(Tcl_Interp *interp); /* 126 */ EXTERN void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr); -/* Slot 127 is reserved */ +/* 127 */ +EXTERN int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + const char *pattern, int allowOverwrite); /* 128 */ EXTERN void Tcl_PopCallFrame(Tcl_Interp *interp); /* 129 */ EXTERN int Tcl_PushCallFrame(Tcl_Interp *interp, Tcl_CallFrame *framePtr, @@ -297,25 +346,28 @@ Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 132 */ EXTERN int TclpHasSockets(Tcl_Interp *interp); -/* Slot 133 is reserved */ +/* 133 */ +EXTERN struct tm * TclpGetDate(const time_t *time, int useGMT); /* Slot 134 is reserved */ /* Slot 135 is reserved */ /* Slot 136 is reserved */ /* Slot 137 is reserved */ /* 138 */ -EXTERN const char * TclGetEnv(const char *name, Tcl_DString *valuePtr); +EXTERN CONST84_RETURN char * TclGetEnv(const char *name, + Tcl_DString *valuePtr); /* Slot 139 is reserved */ /* Slot 140 is reserved */ /* 141 */ -EXTERN const char * TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr); +EXTERN CONST84_RETURN char * TclpGetCwd(Tcl_Interp *interp, + Tcl_DString *cwdPtr); /* 142 */ EXTERN int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, - void *clientData); + ClientData clientData); /* 143 */ EXTERN int TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr); /* 144 */ EXTERN void TclHideLiteral(Tcl_Interp *interp, @@ -331,12 +383,12 @@ /* 149 */ EXTERN void TclHandleRelease(TclHandle handle); /* 150 */ EXTERN int TclRegAbout(Tcl_Interp *interp, Tcl_RegExp re); /* 151 */ -EXTERN void TclRegExpRangeUniChar(Tcl_RegExp re, size_t index, - size_t *startPtr, size_t *endPtr); +EXTERN void TclRegExpRangeUniChar(Tcl_RegExp re, int index, + int *startPtr, int *endPtr); /* 152 */ EXTERN void TclSetLibraryPath(Tcl_Obj *pathPtr); /* 153 */ EXTERN Tcl_Obj * TclGetLibraryPath(void); /* Slot 154 is reserved */ @@ -345,18 +397,20 @@ EXTERN void TclRegError(Tcl_Interp *interp, const char *msg, int status); /* 157 */ EXTERN Var * TclVarTraceExists(Tcl_Interp *interp, const char *varName); -/* Slot 158 is reserved */ -/* Slot 159 is reserved */ +/* 158 */ +EXTERN void TclSetStartupScriptFileName(const char *filename); +/* 159 */ +EXTERN const char * TclGetStartupScriptFileName(void); /* Slot 160 is reserved */ /* 161 */ EXTERN int TclChannelTransform(Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr); /* 162 */ -EXTERN void TclChannelEventScriptInvoker(void *clientData, +EXTERN void TclChannelEventScriptInvoker(ClientData clientData, int flags); /* 163 */ EXTERN const void * TclGetInstructionTable(void); /* 164 */ EXTERN void TclExpandCodeArray(void *envPtr); @@ -364,31 +418,33 @@ EXTERN void TclpSetInitialEncodings(void); /* 166 */ EXTERN int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr); -/* Slot 167 is reserved */ -/* Slot 168 is reserved */ +/* 167 */ +EXTERN void TclSetStartupScriptPath(Tcl_Obj *pathPtr); +/* 168 */ +EXTERN Tcl_Obj * TclGetStartupScriptPath(void); /* 169 */ EXTERN int TclpUtfNcmp2(const char *s1, const char *s2, - size_t n); + unsigned long n); /* 170 */ EXTERN int TclCheckInterpTraces(Tcl_Interp *interp, - const char *command, size_t numChars, + const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 171 */ EXTERN int TclCheckExecutionTraces(Tcl_Interp *interp, - const char *command, size_t numChars, + const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 172 */ EXTERN int TclInThreadExit(void); /* 173 */ EXTERN int TclUniCharMatch(const Tcl_UniChar *string, - size_t strLen, const Tcl_UniChar *pattern, - size_t ptnLen, int flags); + int strLen, const Tcl_UniChar *pattern, + int ptnLen, int flags); /* Slot 174 is reserved */ /* 175 */ EXTERN int TclCallVarTraces(Interp *iPtr, Var *arrayPtr, Var *varPtr, const char *part1, const char *part2, int flags, @@ -397,16 +453,21 @@ EXTERN void TclCleanupVar(Var *varPtr, Var *arrayPtr); /* 177 */ EXTERN void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason); -/* Slot 178 is reserved */ -/* Slot 179 is reserved */ +/* 178 */ +EXTERN void Tcl_SetStartupScript(Tcl_Obj *pathPtr, + const char *encodingName); +/* 179 */ +EXTERN Tcl_Obj * Tcl_GetStartupScript(const char **encodingNamePtr); /* Slot 180 is reserved */ /* Slot 181 is reserved */ -/* Slot 182 is reserved */ -/* Slot 183 is reserved */ +/* 182 */ +EXTERN struct tm * TclpLocaltime(const time_t *clock); +/* 183 */ +EXTERN struct tm * TclpGmtime(const time_t *clock); /* Slot 184 is reserved */ /* Slot 185 is reserved */ /* Slot 186 is reserved */ /* Slot 187 is reserved */ /* Slot 188 is reserved */ @@ -455,11 +516,11 @@ 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, int numBytes); /* 216 */ EXTERN void TclStackFree(Tcl_Interp *interp, void *freePtr); /* 217 */ EXTERN int TclPushStackFrame(Tcl_Interp *interp, Tcl_CallFrame **framePtrPtr, @@ -479,11 +540,11 @@ Tcl_Obj *rootPtr, int keyc, Tcl_Obj *const keyv[], int flags); /* 226 */ EXTERN int TclObjBeingDeleted(Tcl_Obj *objPtr); /* 227 */ -EXTERN void TclSetNsPath(Namespace *nsPtr, size_t pathLength, +EXTERN void TclSetNsPath(Namespace *nsPtr, int pathLength, Tcl_Namespace *pathAry[]); /* Slot 228 is reserved */ /* 229 */ EXTERN int TclPtrMakeUpvar(Tcl_Interp *interp, Var *otherP1Ptr, const char *myName, int myFlags, int index); @@ -505,16 +566,18 @@ EXTERN Var * TclVarHashCreateVar(TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 235 */ EXTERN void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr); -/* Slot 236 is reserved */ +/* 236 */ +EXTERN void TclBackgroundException(Tcl_Interp *interp, int code); /* 237 */ EXTERN int TclResetCancellation(Tcl_Interp *interp, int force); /* 238 */ -EXTERN int TclNRInterpProc(void *clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); +EXTERN int TclNRInterpProc(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); /* 239 */ EXTERN int TclNRInterpProcCore(Tcl_Interp *interp, Tcl_Obj *procNameObj, int skip, ProcErrorProc *errorProc); /* 240 */ @@ -533,11 +596,11 @@ EXTERN Tcl_HashTable * TclGetNamespaceChildTable(Tcl_Namespace *nsPtr); /* 245 */ EXTERN Tcl_HashTable * TclGetNamespaceCommandTable(Tcl_Namespace *nsPtr); /* 246 */ EXTERN int TclInitRewriteEnsemble(Tcl_Interp *interp, - size_t numRemoved, size_t numInserted, + int numRemoved, int numInserted, Tcl_Obj *const *objv); /* 247 */ EXTERN void TclResetRewriteEnsemble(Tcl_Interp *interp, int isRootEnsemble); /* 248 */ @@ -549,12 +612,12 @@ int *decpt, int *signum, char **endPtr); /* 250 */ EXTERN void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags, int force); /* 251 */ -EXTERN int TclRegisterLiteral(void *envPtr, const char *bytes, - size_t length, int flags); +EXTERN int TclRegisterLiteral(void *envPtr, char *bytes, + int length, int flags); /* 252 */ EXTERN Tcl_Obj * TclPtrGetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 253 */ @@ -578,13 +641,14 @@ /* 257 */ EXTERN void TclStaticPackage(Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); -/* 258 */ -EXTERN Tcl_Obj * TclpCreateTemporaryDirectory(Tcl_Obj *dirObj, - Tcl_Obj *basenameObj); +/* Slot 258 is reserved */ +/* Slot 259 is reserved */ +/* 260 */ +EXTERN void TclUnusedStubEntry(void); typedef struct TclIntStubs { int magic; void *hooks; @@ -593,46 +657,46 @@ void (*reserved2)(void); void (*tclAllocateFreeObjects) (void); /* 3 */ void (*reserved4)(void); int (*tclCleanupChildren) (Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 5 */ void (*tclCleanupCommand) (Command *cmdPtr); /* 6 */ - size_t (*tclCopyAndCollapse) (size_t count, const char *src, char *dst); /* 7 */ - void (*reserved8)(void); + int (*tclCopyAndCollapse) (int count, const char *src, char *dst); /* 7 */ + int (*tclCopyChannelOld) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr); /* 8 */ int (*tclCreatePipeline) (Tcl_Interp *interp, int argc, const char **argv, Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr); /* 9 */ int (*tclCreateProc) (Tcl_Interp *interp, Namespace *nsPtr, const char *procName, Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, Proc **procPtrPtr); /* 10 */ void (*tclDeleteCompiledLocalVars) (Interp *iPtr, CallFrame *framePtr); /* 11 */ void (*tclDeleteVars) (Interp *iPtr, TclVarHashTable *tablePtr); /* 12 */ void (*reserved13)(void); - int (*tclDumpMemoryInfo) (void *clientData, int flags); /* 14 */ + int (*tclDumpMemoryInfo) (ClientData clientData, int flags); /* 14 */ void (*reserved15)(void); void (*tclExprFloatError) (Tcl_Interp *interp, double value); /* 16 */ void (*reserved17)(void); void (*reserved18)(void); void (*reserved19)(void); void (*reserved20)(void); void (*reserved21)(void); - int (*tclFindElement) (Tcl_Interp *interp, const char *listStr, int listLength, const char **elementPtr, const char **nextPtr, size_t *sizePtr, int *bracePtr); /* 22 */ + int (*tclFindElement) (Tcl_Interp *interp, const char *listStr, int listLength, const char **elementPtr, const char **nextPtr, int *sizePtr, int *bracePtr); /* 22 */ Proc * (*tclFindProc) (Interp *iPtr, const char *procName); /* 23 */ - size_t (*tclFormatInt) (char *buffer, Tcl_WideInt n); /* 24 */ + int (*tclFormatInt) (char *buffer, long n); /* 24 */ void (*tclFreePackageInfo) (Interp *iPtr); /* 25 */ void (*reserved26)(void); void (*reserved27)(void); Tcl_Channel (*tclpGetDefaultStdChannel) (int type); /* 28 */ void (*reserved29)(void); void (*reserved30)(void); const char * (*tclGetExtension) (const char *name); /* 31 */ int (*tclGetFrame) (Tcl_Interp *interp, const char *str, CallFrame **framePtrPtr); /* 32 */ void (*reserved33)(void); - void (*reserved34)(void); + int (*tclGetIntForIndex) (Tcl_Interp *interp, Tcl_Obj *objPtr, int endValue, int *indexPtr); /* 34 */ void (*reserved35)(void); void (*reserved36)(void); int (*tclGetLoadedPackages) (Tcl_Interp *interp, const char *targetName); /* 37 */ int (*tclGetNamespaceForQualName) (Tcl_Interp *interp, const char *qualName, Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr, Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr, const char **simpleNamePtr); /* 38 */ TclObjCmdProcType (*tclGetObjInterpProc) (void); /* 39 */ int (*tclGetOpenMode) (Tcl_Interp *interp, const char *str, int *seekFlagPtr); /* 40 */ Tcl_Command (*tclGetOriginalCommand) (Tcl_Command command); /* 41 */ - const char * (*tclpGetUserHome) (const char *name, Tcl_DString *bufferPtr); /* 42 */ + CONST86 char * (*tclpGetUserHome) (const char *name, Tcl_DString *bufferPtr); /* 42 */ void (*reserved43)(void); int (*tclGuessPackageName) (const char *fileName, Tcl_DString *bufPtr); /* 44 */ int (*tclHideUnsafeCommands) (Tcl_Interp *interp); /* 45 */ int (*tclInExit) (void); /* 46 */ void (*reserved47)(void); @@ -639,141 +703,141 @@ void (*reserved48)(void); void (*reserved49)(void); void (*tclInitCompiledLocals) (Tcl_Interp *interp, CallFrame *framePtr, Namespace *nsPtr); /* 50 */ int (*tclInterpInit) (Tcl_Interp *interp); /* 51 */ void (*reserved52)(void); - int (*tclInvokeObjectCommand) (void *clientData, Tcl_Interp *interp, int argc, const char **argv); /* 53 */ - int (*tclInvokeStringCommand) (void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 54 */ + int (*tclInvokeObjectCommand) (ClientData clientData, Tcl_Interp *interp, int argc, CONST84 char **argv); /* 53 */ + int (*tclInvokeStringCommand) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 54 */ Proc * (*tclIsProc) (Command *cmdPtr); /* 55 */ void (*reserved56)(void); void (*reserved57)(void); Var * (*tclLookupVar) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, const char *msg, int createPart1, int createPart2, Var **arrayPtrPtr); /* 58 */ void (*reserved59)(void); int (*tclNeedSpace) (const char *start, const char *end); /* 60 */ Tcl_Obj * (*tclNewProcBodyObj) (Proc *procPtr); /* 61 */ int (*tclObjCommandComplete) (Tcl_Obj *cmdPtr); /* 62 */ - int (*tclObjInterpProc) (void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 63 */ + int (*tclObjInterpProc) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 63 */ int (*tclObjInvoke) (Tcl_Interp *interp, int 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 */ + char * (*tclpAlloc) (unsigned int size); /* 69 */ void (*reserved70)(void); void (*reserved71)(void); void (*reserved72)(void); void (*reserved73)(void); - void (*tclpFree) (void *ptr); /* 74 */ - Tcl_WideUInt (*tclpGetClicks) (void); /* 75 */ - Tcl_WideUInt (*tclpGetSeconds) (void); /* 76 */ - void (*reserved77)(void); + void (*tclpFree) (char *ptr); /* 74 */ + unsigned long (*tclpGetClicks) (void); /* 75 */ + unsigned long (*tclpGetSeconds) (void); /* 76 */ + void (*tclpGetTime) (Tcl_Time *time); /* 77 */ void (*reserved78)(void); void (*reserved79)(void); void (*reserved80)(void); - void * (*tclpRealloc) (void *ptr, size_t size); /* 81 */ + char * (*tclpRealloc) (char *ptr, unsigned int size); /* 81 */ void (*reserved82)(void); void (*reserved83)(void); void (*reserved84)(void); void (*reserved85)(void); void (*reserved86)(void); void (*reserved87)(void); - void (*reserved88)(void); + char * (*tclPrecTraceProc) (ClientData clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); /* 88 */ int (*tclPreventAliasLoop) (Tcl_Interp *interp, Tcl_Interp *cmdInterp, Tcl_Command cmd); /* 89 */ void (*reserved90)(void); void (*tclProcCleanupProc) (Proc *procPtr); /* 91 */ int (*tclProcCompileProc) (Tcl_Interp *interp, Proc *procPtr, Tcl_Obj *bodyPtr, Namespace *nsPtr, const char *description, const char *procName); /* 92 */ - void (*tclProcDeleteProc) (void *clientData); /* 93 */ + void (*tclProcDeleteProc) (ClientData clientData); /* 93 */ void (*reserved94)(void); void (*reserved95)(void); int (*tclRenameCommand) (Tcl_Interp *interp, const char *oldName, const char *newName); /* 96 */ void (*tclResetShadowedCmdRefs) (Tcl_Interp *interp, Command *newCmdPtr); /* 97 */ int (*tclServiceIdle) (void); /* 98 */ void (*reserved99)(void); void (*reserved100)(void); - const char * (*tclSetPreInitScript) (const char *string); /* 101 */ + CONST86 char * (*tclSetPreInitScript) (const char *string); /* 101 */ void (*tclSetupEnv) (Tcl_Interp *interp); /* 102 */ int (*tclSockGetPort) (Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); /* 103 */ - void (*reserved104)(void); + int (*tclSockMinimumBuffersOld) (int sock, int size); /* 104 */ void (*reserved105)(void); void (*reserved106)(void); void (*reserved107)(void); void (*tclTeardownNamespace) (Namespace *nsPtr); /* 108 */ int (*tclUpdateReturnInfo) (Interp *iPtr); /* 109 */ int (*tclSockMinimumBuffers) (void *sock, int size); /* 110 */ void (*tcl_AddInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 111 */ - void (*reserved112)(void); - void (*reserved113)(void); - void (*reserved114)(void); - void (*reserved115)(void); - void (*reserved116)(void); - void (*reserved117)(void); + int (*tcl_AppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 112 */ + Tcl_Namespace * (*tcl_CreateNamespace) (Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 113 */ + void (*tcl_DeleteNamespace) (Tcl_Namespace *nsPtr); /* 114 */ + int (*tcl_Export) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 115 */ + Tcl_Command (*tcl_FindCommand) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 116 */ + Tcl_Namespace * (*tcl_FindNamespace) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 117 */ int (*tcl_GetInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolverInfo *resInfo); /* 118 */ int (*tcl_GetNamespaceResolvers) (Tcl_Namespace *namespacePtr, Tcl_ResolverInfo *resInfo); /* 119 */ Tcl_Var (*tcl_FindNamespaceVar) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 120 */ - void (*reserved121)(void); - void (*reserved122)(void); - void (*reserved123)(void); - void (*reserved124)(void); - void (*reserved125)(void); + int (*tcl_ForgetImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 121 */ + Tcl_Command (*tcl_GetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 122 */ + void (*tcl_GetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 123 */ + Tcl_Namespace * (*tcl_GetCurrentNamespace) (Tcl_Interp *interp); /* 124 */ + Tcl_Namespace * (*tcl_GetGlobalNamespace) (Tcl_Interp *interp); /* 125 */ void (*tcl_GetVariableFullName) (Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr); /* 126 */ - void (*reserved127)(void); + int (*tcl_Import) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite); /* 127 */ void (*tcl_PopCallFrame) (Tcl_Interp *interp); /* 128 */ int (*tcl_PushCallFrame) (Tcl_Interp *interp, Tcl_CallFrame *framePtr, Tcl_Namespace *nsPtr, int isProcCallFrame); /* 129 */ int (*tcl_RemoveInterpResolvers) (Tcl_Interp *interp, const char *name); /* 130 */ void (*tcl_SetNamespaceResolvers) (Tcl_Namespace *namespacePtr, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 131 */ int (*tclpHasSockets) (Tcl_Interp *interp); /* 132 */ - void (*reserved133)(void); + struct tm * (*tclpGetDate) (const time_t *time, int useGMT); /* 133 */ void (*reserved134)(void); void (*reserved135)(void); void (*reserved136)(void); void (*reserved137)(void); - const char * (*tclGetEnv) (const char *name, Tcl_DString *valuePtr); /* 138 */ + CONST84_RETURN char * (*tclGetEnv) (const char *name, Tcl_DString *valuePtr); /* 138 */ void (*reserved139)(void); void (*reserved140)(void); - const char * (*tclpGetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 141 */ - int (*tclSetByteCodeFromAny) (Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, void *clientData); /* 142 */ + CONST84_RETURN char * (*tclpGetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 141 */ + int (*tclSetByteCodeFromAny) (Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, ClientData clientData); /* 142 */ int (*tclAddLiteralObj) (struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr); /* 143 */ void (*tclHideLiteral) (Tcl_Interp *interp, struct CompileEnv *envPtr, int index); /* 144 */ const struct AuxDataType * (*tclGetAuxDataType) (const char *typeName); /* 145 */ TclHandle (*tclHandleCreate) (void *ptr); /* 146 */ void (*tclHandleFree) (TclHandle handle); /* 147 */ TclHandle (*tclHandlePreserve) (TclHandle handle); /* 148 */ void (*tclHandleRelease) (TclHandle handle); /* 149 */ int (*tclRegAbout) (Tcl_Interp *interp, Tcl_RegExp re); /* 150 */ - void (*tclRegExpRangeUniChar) (Tcl_RegExp re, size_t index, size_t *startPtr, size_t *endPtr); /* 151 */ + void (*tclRegExpRangeUniChar) (Tcl_RegExp re, int index, int *startPtr, int *endPtr); /* 151 */ void (*tclSetLibraryPath) (Tcl_Obj *pathPtr); /* 152 */ Tcl_Obj * (*tclGetLibraryPath) (void); /* 153 */ void (*reserved154)(void); void (*reserved155)(void); void (*tclRegError) (Tcl_Interp *interp, const char *msg, int status); /* 156 */ Var * (*tclVarTraceExists) (Tcl_Interp *interp, const char *varName); /* 157 */ - void (*reserved158)(void); - void (*reserved159)(void); + void (*tclSetStartupScriptFileName) (const char *filename); /* 158 */ + const char * (*tclGetStartupScriptFileName) (void); /* 159 */ void (*reserved160)(void); int (*tclChannelTransform) (Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr); /* 161 */ - void (*tclChannelEventScriptInvoker) (void *clientData, int flags); /* 162 */ + void (*tclChannelEventScriptInvoker) (ClientData clientData, int flags); /* 162 */ const void * (*tclGetInstructionTable) (void); /* 163 */ void (*tclExpandCodeArray) (void *envPtr); /* 164 */ void (*tclpSetInitialEncodings) (void); /* 165 */ int (*tclListObjSetElement) (Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr); /* 166 */ - void (*reserved167)(void); - void (*reserved168)(void); - int (*tclpUtfNcmp2) (const char *s1, const char *s2, size_t n); /* 169 */ - int (*tclCheckInterpTraces) (Tcl_Interp *interp, const char *command, size_t numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 170 */ - int (*tclCheckExecutionTraces) (Tcl_Interp *interp, const char *command, size_t numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 171 */ + void (*tclSetStartupScriptPath) (Tcl_Obj *pathPtr); /* 167 */ + Tcl_Obj * (*tclGetStartupScriptPath) (void); /* 168 */ + int (*tclpUtfNcmp2) (const char *s1, const char *s2, unsigned long n); /* 169 */ + int (*tclCheckInterpTraces) (Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 170 */ + int (*tclCheckExecutionTraces) (Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 171 */ int (*tclInThreadExit) (void); /* 172 */ - int (*tclUniCharMatch) (const Tcl_UniChar *string, size_t strLen, const Tcl_UniChar *pattern, size_t ptnLen, int flags); /* 173 */ + int (*tclUniCharMatch) (const Tcl_UniChar *string, int strLen, const Tcl_UniChar *pattern, int ptnLen, int flags); /* 173 */ void (*reserved174)(void); int (*tclCallVarTraces) (Interp *iPtr, Var *arrayPtr, Var *varPtr, const char *part1, const char *part2, int flags, int leaveErrMsg); /* 175 */ void (*tclCleanupVar) (Var *varPtr, Var *arrayPtr); /* 176 */ void (*tclVarErrMsg) (Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason); /* 177 */ - void (*reserved178)(void); - void (*reserved179)(void); + void (*tcl_SetStartupScript) (Tcl_Obj *pathPtr, const char *encodingName); /* 178 */ + Tcl_Obj * (*tcl_GetStartupScript) (const char **encodingNamePtr); /* 179 */ void (*reserved180)(void); void (*reserved181)(void); - void (*reserved182)(void); - void (*reserved183)(void); + struct tm * (*tclpLocaltime) (const time_t *clock); /* 182 */ + struct tm * (*tclpGmtime) (const time_t *clock); /* 183 */ void (*reserved184)(void); void (*reserved185)(void); void (*reserved186)(void); void (*reserved187)(void); void (*reserved188)(void); @@ -801,11 +865,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, int 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 */ void (*reserved219)(void); void (*reserved220)(void); @@ -813,42 +877,44 @@ void (*reserved222)(void); void (*reserved223)(void); TclPlatformType * (*tclGetPlatform) (void); /* 224 */ Tcl_Obj * (*tclTraceDictPath) (Tcl_Interp *interp, Tcl_Obj *rootPtr, int keyc, Tcl_Obj *const keyv[], int flags); /* 225 */ int (*tclObjBeingDeleted) (Tcl_Obj *objPtr); /* 226 */ - void (*tclSetNsPath) (Namespace *nsPtr, size_t pathLength, Tcl_Namespace *pathAry[]); /* 227 */ + void (*tclSetNsPath) (Namespace *nsPtr, int pathLength, Tcl_Namespace *pathAry[]); /* 227 */ void (*reserved228)(void); int (*tclPtrMakeUpvar) (Tcl_Interp *interp, Var *otherP1Ptr, const char *myName, int myFlags, int index); /* 229 */ Var * (*tclObjLookupVar) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, const char *part2, int flags, const char *msg, const int createPart1, const int createPart2, Var **arrayPtrPtr); /* 230 */ int (*tclGetNamespaceFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); /* 231 */ int (*tclEvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 232 */ void (*tclGetSrcInfoForPc) (CmdFrame *contextPtr); /* 233 */ Var * (*tclVarHashCreateVar) (TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 234 */ void (*tclInitVarHashTable) (TclVarHashTable *tablePtr, Namespace *nsPtr); /* 235 */ - void (*reserved236)(void); + void (*tclBackgroundException) (Tcl_Interp *interp, int code); /* 236 */ int (*tclResetCancellation) (Tcl_Interp *interp, int force); /* 237 */ - int (*tclNRInterpProc) (void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 238 */ + int (*tclNRInterpProc) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 238 */ int (*tclNRInterpProcCore) (Tcl_Interp *interp, Tcl_Obj *procNameObj, int skip, ProcErrorProc *errorProc); /* 239 */ int (*tclNRRunCallbacks) (Tcl_Interp *interp, int result, struct NRE_callback *rootPtr); /* 240 */ int (*tclNREvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 241 */ int (*tclNREvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags, Command *cmdPtr); /* 242 */ void (*tclDbDumpActiveObjects) (FILE *outFile); /* 243 */ Tcl_HashTable * (*tclGetNamespaceChildTable) (Tcl_Namespace *nsPtr); /* 244 */ Tcl_HashTable * (*tclGetNamespaceCommandTable) (Tcl_Namespace *nsPtr); /* 245 */ - int (*tclInitRewriteEnsemble) (Tcl_Interp *interp, size_t numRemoved, size_t numInserted, Tcl_Obj *const *objv); /* 246 */ + int (*tclInitRewriteEnsemble) (Tcl_Interp *interp, int numRemoved, int numInserted, Tcl_Obj *const *objv); /* 246 */ void (*tclResetRewriteEnsemble) (Tcl_Interp *interp, int isRootEnsemble); /* 247 */ int (*tclCopyChannel) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr); /* 248 */ char * (*tclDoubleDigits) (double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 249 */ void (*tclSetSlaveCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */ - int (*tclRegisterLiteral) (void *envPtr, const char *bytes, size_t length, int flags); /* 251 */ + int (*tclRegisterLiteral) (void *envPtr, char *bytes, int length, int flags); /* 251 */ Tcl_Obj * (*tclPtrGetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 252 */ Tcl_Obj * (*tclPtrSetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, const int flags); /* 253 */ Tcl_Obj * (*tclPtrIncrObjVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, const 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, const int flags); /* 256 */ void (*tclStaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 257 */ - Tcl_Obj * (*tclpCreateTemporaryDirectory) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 258 */ + void (*reserved258)(void); + void (*reserved259)(void); + void (*tclUnusedStubEntry) (void); /* 260 */ } TclIntStubs; extern const TclIntStubs *tclIntStubsPtr; #ifdef __cplusplus @@ -871,11 +937,12 @@ (tclIntStubsPtr->tclCleanupChildren) /* 5 */ #define TclCleanupCommand \ (tclIntStubsPtr->tclCleanupCommand) /* 6 */ #define TclCopyAndCollapse \ (tclIntStubsPtr->tclCopyAndCollapse) /* 7 */ -/* Slot 8 is reserved */ +#define TclCopyChannelOld \ + (tclIntStubsPtr->tclCopyChannelOld) /* 8 */ #define TclCreatePipeline \ (tclIntStubsPtr->tclCreatePipeline) /* 9 */ #define TclCreateProc \ (tclIntStubsPtr->tclCreateProc) /* 10 */ #define TclDeleteCompiledLocalVars \ @@ -910,11 +977,12 @@ #define TclGetExtension \ (tclIntStubsPtr->tclGetExtension) /* 31 */ #define TclGetFrame \ (tclIntStubsPtr->tclGetFrame) /* 32 */ /* Slot 33 is reserved */ -/* Slot 34 is reserved */ +#define TclGetIntForIndex \ + (tclIntStubsPtr->tclGetIntForIndex) /* 34 */ /* Slot 35 is reserved */ /* Slot 36 is reserved */ #define TclGetLoadedPackages \ (tclIntStubsPtr->tclGetLoadedPackages) /* 37 */ #define TclGetNamespaceForQualName \ @@ -977,11 +1045,12 @@ (tclIntStubsPtr->tclpFree) /* 74 */ #define TclpGetClicks \ (tclIntStubsPtr->tclpGetClicks) /* 75 */ #define TclpGetSeconds \ (tclIntStubsPtr->tclpGetSeconds) /* 76 */ -/* Slot 77 is reserved */ +#define TclpGetTime \ + (tclIntStubsPtr->tclpGetTime) /* 77 */ /* Slot 78 is reserved */ /* Slot 79 is reserved */ /* Slot 80 is reserved */ #define TclpRealloc \ (tclIntStubsPtr->tclpRealloc) /* 81 */ @@ -989,11 +1058,12 @@ /* Slot 83 is reserved */ /* Slot 84 is reserved */ /* Slot 85 is reserved */ /* Slot 86 is reserved */ /* Slot 87 is reserved */ -/* Slot 88 is reserved */ +#define TclPrecTraceProc \ + (tclIntStubsPtr->tclPrecTraceProc) /* 88 */ #define TclPreventAliasLoop \ (tclIntStubsPtr->tclPreventAliasLoop) /* 89 */ /* Slot 90 is reserved */ #define TclProcCleanupProc \ (tclIntStubsPtr->tclProcCleanupProc) /* 91 */ @@ -1015,11 +1085,12 @@ (tclIntStubsPtr->tclSetPreInitScript) /* 101 */ #define TclSetupEnv \ (tclIntStubsPtr->tclSetupEnv) /* 102 */ #define TclSockGetPort \ (tclIntStubsPtr->tclSockGetPort) /* 103 */ -/* Slot 104 is reserved */ +#define TclSockMinimumBuffersOld \ + (tclIntStubsPtr->tclSockMinimumBuffersOld) /* 104 */ /* Slot 105 is reserved */ /* Slot 106 is reserved */ /* Slot 107 is reserved */ #define TclTeardownNamespace \ (tclIntStubsPtr->tclTeardownNamespace) /* 108 */ @@ -1027,30 +1098,42 @@ (tclIntStubsPtr->tclUpdateReturnInfo) /* 109 */ #define TclSockMinimumBuffers \ (tclIntStubsPtr->tclSockMinimumBuffers) /* 110 */ #define Tcl_AddInterpResolvers \ (tclIntStubsPtr->tcl_AddInterpResolvers) /* 111 */ -/* Slot 112 is reserved */ -/* Slot 113 is reserved */ -/* Slot 114 is reserved */ -/* Slot 115 is reserved */ -/* Slot 116 is reserved */ -/* Slot 117 is reserved */ +#define Tcl_AppendExportList \ + (tclIntStubsPtr->tcl_AppendExportList) /* 112 */ +#define Tcl_CreateNamespace \ + (tclIntStubsPtr->tcl_CreateNamespace) /* 113 */ +#define Tcl_DeleteNamespace \ + (tclIntStubsPtr->tcl_DeleteNamespace) /* 114 */ +#define Tcl_Export \ + (tclIntStubsPtr->tcl_Export) /* 115 */ +#define Tcl_FindCommand \ + (tclIntStubsPtr->tcl_FindCommand) /* 116 */ +#define Tcl_FindNamespace \ + (tclIntStubsPtr->tcl_FindNamespace) /* 117 */ #define Tcl_GetInterpResolvers \ (tclIntStubsPtr->tcl_GetInterpResolvers) /* 118 */ #define Tcl_GetNamespaceResolvers \ (tclIntStubsPtr->tcl_GetNamespaceResolvers) /* 119 */ #define Tcl_FindNamespaceVar \ (tclIntStubsPtr->tcl_FindNamespaceVar) /* 120 */ -/* Slot 121 is reserved */ -/* Slot 122 is reserved */ -/* Slot 123 is reserved */ -/* Slot 124 is reserved */ -/* Slot 125 is reserved */ +#define Tcl_ForgetImport \ + (tclIntStubsPtr->tcl_ForgetImport) /* 121 */ +#define Tcl_GetCommandFromObj \ + (tclIntStubsPtr->tcl_GetCommandFromObj) /* 122 */ +#define Tcl_GetCommandFullName \ + (tclIntStubsPtr->tcl_GetCommandFullName) /* 123 */ +#define Tcl_GetCurrentNamespace \ + (tclIntStubsPtr->tcl_GetCurrentNamespace) /* 124 */ +#define Tcl_GetGlobalNamespace \ + (tclIntStubsPtr->tcl_GetGlobalNamespace) /* 125 */ #define Tcl_GetVariableFullName \ (tclIntStubsPtr->tcl_GetVariableFullName) /* 126 */ -/* Slot 127 is reserved */ +#define Tcl_Import \ + (tclIntStubsPtr->tcl_Import) /* 127 */ #define Tcl_PopCallFrame \ (tclIntStubsPtr->tcl_PopCallFrame) /* 128 */ #define Tcl_PushCallFrame \ (tclIntStubsPtr->tcl_PushCallFrame) /* 129 */ #define Tcl_RemoveInterpResolvers \ @@ -1057,11 +1140,12 @@ (tclIntStubsPtr->tcl_RemoveInterpResolvers) /* 130 */ #define Tcl_SetNamespaceResolvers \ (tclIntStubsPtr->tcl_SetNamespaceResolvers) /* 131 */ #define TclpHasSockets \ (tclIntStubsPtr->tclpHasSockets) /* 132 */ -/* Slot 133 is reserved */ +#define TclpGetDate \ + (tclIntStubsPtr->tclpGetDate) /* 133 */ /* Slot 134 is reserved */ /* Slot 135 is reserved */ /* Slot 136 is reserved */ /* Slot 137 is reserved */ #define TclGetEnv \ @@ -1098,12 +1182,14 @@ /* Slot 155 is reserved */ #define TclRegError \ (tclIntStubsPtr->tclRegError) /* 156 */ #define TclVarTraceExists \ (tclIntStubsPtr->tclVarTraceExists) /* 157 */ -/* Slot 158 is reserved */ -/* Slot 159 is reserved */ +#define TclSetStartupScriptFileName \ + (tclIntStubsPtr->tclSetStartupScriptFileName) /* 158 */ +#define TclGetStartupScriptFileName \ + (tclIntStubsPtr->tclGetStartupScriptFileName) /* 159 */ /* Slot 160 is reserved */ #define TclChannelTransform \ (tclIntStubsPtr->tclChannelTransform) /* 161 */ #define TclChannelEventScriptInvoker \ (tclIntStubsPtr->tclChannelEventScriptInvoker) /* 162 */ @@ -1113,12 +1199,14 @@ (tclIntStubsPtr->tclExpandCodeArray) /* 164 */ #define TclpSetInitialEncodings \ (tclIntStubsPtr->tclpSetInitialEncodings) /* 165 */ #define TclListObjSetElement \ (tclIntStubsPtr->tclListObjSetElement) /* 166 */ -/* Slot 167 is reserved */ -/* Slot 168 is reserved */ +#define TclSetStartupScriptPath \ + (tclIntStubsPtr->tclSetStartupScriptPath) /* 167 */ +#define TclGetStartupScriptPath \ + (tclIntStubsPtr->tclGetStartupScriptPath) /* 168 */ #define TclpUtfNcmp2 \ (tclIntStubsPtr->tclpUtfNcmp2) /* 169 */ #define TclCheckInterpTraces \ (tclIntStubsPtr->tclCheckInterpTraces) /* 170 */ #define TclCheckExecutionTraces \ @@ -1132,16 +1220,20 @@ (tclIntStubsPtr->tclCallVarTraces) /* 175 */ #define TclCleanupVar \ (tclIntStubsPtr->tclCleanupVar) /* 176 */ #define TclVarErrMsg \ (tclIntStubsPtr->tclVarErrMsg) /* 177 */ -/* Slot 178 is reserved */ -/* Slot 179 is reserved */ +#define Tcl_SetStartupScript \ + (tclIntStubsPtr->tcl_SetStartupScript) /* 178 */ +#define Tcl_GetStartupScript \ + (tclIntStubsPtr->tcl_GetStartupScript) /* 179 */ /* Slot 180 is reserved */ /* Slot 181 is reserved */ -/* Slot 182 is reserved */ -/* Slot 183 is reserved */ +#define TclpLocaltime \ + (tclIntStubsPtr->tclpLocaltime) /* 182 */ +#define TclpGmtime \ + (tclIntStubsPtr->tclpGmtime) /* 183 */ /* Slot 184 is reserved */ /* Slot 185 is reserved */ /* Slot 186 is reserved */ /* Slot 187 is reserved */ /* Slot 188 is reserved */ @@ -1218,11 +1310,12 @@ (tclIntStubsPtr->tclGetSrcInfoForPc) /* 233 */ #define TclVarHashCreateVar \ (tclIntStubsPtr->tclVarHashCreateVar) /* 234 */ #define TclInitVarHashTable \ (tclIntStubsPtr->tclInitVarHashTable) /* 235 */ -/* Slot 236 is reserved */ +#define TclBackgroundException \ + (tclIntStubsPtr->tclBackgroundException) /* 236 */ #define TclResetCancellation \ (tclIntStubsPtr->tclResetCancellation) /* 237 */ #define TclNRInterpProc \ (tclIntStubsPtr->tclNRInterpProc) /* 238 */ #define TclNRInterpProcCore \ @@ -1261,22 +1354,74 @@ (tclIntStubsPtr->tclPtrObjMakeUpvar) /* 255 */ #define TclPtrUnsetVar \ (tclIntStubsPtr->tclPtrUnsetVar) /* 256 */ #define TclStaticPackage \ (tclIntStubsPtr->tclStaticPackage) /* 257 */ -#define TclpCreateTemporaryDirectory \ - (tclIntStubsPtr->tclpCreateTemporaryDirectory) /* 258 */ +/* Slot 258 is reserved */ +/* Slot 259 is reserved */ +#define TclUnusedStubEntry \ + (tclIntStubsPtr->tclUnusedStubEntry) /* 260 */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ -#if defined(USE_TCL_STUBS) -#undef Tcl_StaticPackage -#define Tcl_StaticPackage \ - (tclIntStubsPtr->tclStaticPackage) -#endif /* defined(USE_TCL_STUBS) */ - #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT +#undef TclGetStartupScriptFileName +#undef TclSetStartupScriptFileName +#undef TclGetStartupScriptPath +#undef TclSetStartupScriptPath +#undef TclBackgroundException + +#if defined(USE_TCL_STUBS) && defined(TCL_NO_DEPRECATED) +# undef Tcl_SetStartupScript +# define Tcl_SetStartupScript \ + (tclStubsPtr->tcl_SetStartupScript) /* 622 */ +# undef Tcl_GetStartupScript +# define Tcl_GetStartupScript \ + (tclStubsPtr->tcl_GetStartupScript) /* 623 */ +# undef Tcl_CreateNamespace +# define Tcl_CreateNamespace \ + (tclStubsPtr->tcl_CreateNamespace) /* 506 */ +# undef Tcl_DeleteNamespace +# define Tcl_DeleteNamespace \ + (tclStubsPtr->tcl_DeleteNamespace) /* 507 */ +# undef Tcl_AppendExportList +# define Tcl_AppendExportList \ + (tclStubsPtr->tcl_AppendExportList) /* 508 */ +# undef Tcl_Export +# define Tcl_Export \ + (tclStubsPtr->tcl_Export) /* 509 */ +# undef Tcl_Import +# define Tcl_Import \ + (tclStubsPtr->tcl_Import) /* 510 */ +# undef Tcl_ForgetImport +# define Tcl_ForgetImport \ + (tclStubsPtr->tcl_ForgetImport) /* 511 */ +# undef Tcl_GetCurrentNamespace +# define Tcl_GetCurrentNamespace \ + (tclStubsPtr->tcl_GetCurrentNamespace) /* 512 */ +# undef Tcl_GetGlobalNamespace +# define Tcl_GetGlobalNamespace \ + (tclStubsPtr->tcl_GetGlobalNamespace) /* 513 */ +# undef Tcl_FindNamespace +# define Tcl_FindNamespace \ + (tclStubsPtr->tcl_FindNamespace) /* 514 */ +# undef Tcl_FindCommand +# define Tcl_FindCommand \ + (tclStubsPtr->tcl_FindCommand) /* 515 */ +# undef Tcl_GetCommandFromObj +# define Tcl_GetCommandFromObj \ + (tclStubsPtr->tcl_GetCommandFromObj) /* 516 */ +# undef Tcl_GetCommandFullName +# define Tcl_GetCommandFullName \ + (tclStubsPtr->tcl_GetCommandFullName) /* 517 */ +#endif + +#undef TclCopyChannelOld +#undef TclSockMinimumBuffersOld + +#define TclSetChildCancelFlags TclSetSlaveCancelFlags + #endif /* _TCLINTDECLS */ Index: generic/tclIntPlatDecls.h ================================================================== --- generic/tclIntPlatDecls.h +++ generic/tclIntPlatDecls.h @@ -55,64 +55,95 @@ /* 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 */ +/* 5 */ +EXTERN int TclUnixWaitForFile_(int fd, int mask, int timeout); /* 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); -/* Slot 10 is reserved */ -/* Slot 11 is reserved */ -/* Slot 12 is reserved */ -/* Slot 13 is reserved */ +/* 10 */ +EXTERN Tcl_DirEntry * TclpReaddir(TclDIR *dir); +/* 11 */ +EXTERN struct tm * TclpLocaltime_unix(const time_t *clock); +/* 12 */ +EXTERN struct tm * TclpGmtime_unix(const time_t *clock); +/* 13 */ +EXTERN char * TclpInetNtoa(struct in_addr addr); /* 14 */ EXTERN int TclUnixCopyFile(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); -/* Slot 15 is reserved */ -/* Slot 16 is reserved */ -/* Slot 17 is reserved */ -/* Slot 18 is reserved */ -/* Slot 19 is reserved */ +/* 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 */ +/* 22 */ +EXTERN TclFile TclpCreateTempFile_(const char *contents); /* 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); +EXTERN int TclWinCPUID(unsigned int index, unsigned 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 */ /* 0 */ EXTERN void TclWinConvertError(DWORD errCode); -/* Slot 1 is reserved */ -/* Slot 2 is reserved */ -/* Slot 3 is reserved */ +/* 1 */ +EXTERN void TclWinConvertWSAError(DWORD errCode); +/* 2 */ +EXTERN struct servent * TclWinGetServByName(const char *nm, + const char *proto); +/* 3 */ +EXTERN int TclWinGetSockOpt(SOCKET s, int level, int optname, + char *optval, int *optlen); /* 4 */ EXTERN HINSTANCE TclWinGetTclInstance(void); /* 5 */ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); -/* Slot 6 is reserved */ -/* Slot 7 is reserved */ +/* 6 */ +EXTERN unsigned short TclWinNToHS(unsigned short ns); +/* 7 */ +EXTERN int TclWinSetSockOpt(SOCKET s, int level, int optname, + const char *optval, int optlen); /* 8 */ -EXTERN size_t TclpGetPid(Tcl_Pid pid); -/* Slot 9 is reserved */ -/* Slot 10 is reserved */ +EXTERN int TclpGetPid(Tcl_Pid pid); +/* 9 */ +EXTERN int TclWinGetPlatformId(void); +/* 10 */ +EXTERN Tcl_DirEntry * TclpReaddir(TclDIR *dir); /* 11 */ EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan); /* 12 */ EXTERN int TclpCloseFile(TclFile file); @@ -136,24 +167,27 @@ /* 18 */ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); /* 19 */ EXTERN TclFile TclpOpenFile(const char *fname, int mode); /* 20 */ -EXTERN void TclWinAddProcess(HANDLE hProcess, size_t id); -/* Slot 21 is reserved */ +EXTERN void TclWinAddProcess(HANDLE hProcess, DWORD id); +/* 21 */ +EXTERN char * TclpInetNtoa(struct in_addr addr); /* 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 */ +/* 26 */ +EXTERN void TclWinSetInterfaces(int wide); /* 27 */ EXTERN void TclWinFlushDirtyChannels(void); -/* Slot 28 is reserved */ +/* 28 */ +EXTERN void TclWinResetInterfaces(void); /* 29 */ -EXTERN int TclWinCPUID(int index, int *regs); +EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs); /* 30 */ EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); #endif /* WIN */ @@ -172,23 +206,28 @@ /* 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 */ +/* 5 */ +EXTERN int TclUnixWaitForFile_(int fd, int mask, int timeout); /* 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); -/* Slot 10 is reserved */ -/* Slot 11 is reserved */ -/* Slot 12 is reserved */ -/* Slot 13 is reserved */ +/* 10 */ +EXTERN Tcl_DirEntry * TclpReaddir(TclDIR *dir); +/* 11 */ +EXTERN struct tm * TclpLocaltime_unix(const time_t *clock); +/* 12 */ +EXTERN struct tm * TclpGmtime_unix(const time_t *clock); +/* 13 */ +EXTERN char * TclpInetNtoa(struct in_addr addr); /* 14 */ EXTERN int TclUnixCopyFile(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 15 */ @@ -211,19 +250,20 @@ /* 19 */ EXTERN void TclMacOSXNotifierAddRunLoopMode( const void *runLoopMode); /* Slot 20 is reserved */ /* Slot 21 is reserved */ -/* Slot 22 is reserved */ +/* 22 */ +EXTERN TclFile TclpCreateTempFile_(const char *contents); /* 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); +EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs); /* 30 */ EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); #endif /* MACOSX */ @@ -236,101 +276,101 @@ 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 */ - void (*reserved5)(void); + 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 */ - void (*reserved10)(void); - void (*reserved11)(void); - void (*reserved12)(void); - void (*reserved13)(void); + Tcl_DirEntry * (*tclpReaddir) (TclDIR *dir); /* 10 */ + struct tm * (*tclpLocaltime_unix) (const time_t *clock); /* 11 */ + struct tm * (*tclpGmtime_unix) (const time_t *clock); /* 12 */ + char * (*tclpInetNtoa) (struct in_addr addr); /* 13 */ int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */ - void (*reserved15)(void); - void (*reserved16)(void); - void (*reserved17)(void); - void (*reserved18)(void); - void (*reserved19)(void); + 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); - void (*reserved22)(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 (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */ int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* UNIX */ #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ void (*tclWinConvertError) (DWORD errCode); /* 0 */ - void (*reserved1)(void); - void (*reserved2)(void); - void (*reserved3)(void); + void (*tclWinConvertWSAError) (DWORD errCode); /* 1 */ + struct servent * (*tclWinGetServByName) (const char *nm, const char *proto); /* 2 */ + int (*tclWinGetSockOpt) (SOCKET s, int level, int optname, char *optval, int *optlen); /* 3 */ HINSTANCE (*tclWinGetTclInstance) (void); /* 4 */ int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */ - void (*reserved6)(void); - void (*reserved7)(void); - size_t (*tclpGetPid) (Tcl_Pid pid); /* 8 */ - void (*reserved9)(void); - void (*reserved10)(void); + unsigned short (*tclWinNToHS) (unsigned short ns); /* 6 */ + int (*tclWinSetSockOpt) (SOCKET s, int level, int optname, const char *optval, int optlen); /* 7 */ + int (*tclpGetPid) (Tcl_Pid pid); /* 8 */ + int (*tclWinGetPlatformId) (void); /* 9 */ + Tcl_DirEntry * (*tclpReaddir) (TclDIR *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) (HANDLE hProcess, size_t id); /* 20 */ - void (*reserved21)(void); + void (*tclWinAddProcess) (HANDLE hProcess, DWORD id); /* 20 */ + char * (*tclpInetNtoa) (struct in_addr addr); /* 21 */ TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */ void (*reserved23)(void); char * (*tclWinNoBackslash) (char *path); /* 24 */ void (*reserved25)(void); - void (*reserved26)(void); + void (*tclWinSetInterfaces) (int wide); /* 26 */ void (*tclWinFlushDirtyChannels) (void); /* 27 */ - void (*reserved28)(void); - int (*tclWinCPUID) (int index, int *regs); /* 29 */ + void (*tclWinResetInterfaces) (void); /* 28 */ + int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */ int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */ 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 */ - void (*reserved5)(void); + 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 */ - void (*reserved10)(void); - void (*reserved11)(void); - void (*reserved12)(void); - void (*reserved13)(void); + Tcl_DirEntry * (*tclpReaddir) (TclDIR *dir); /* 10 */ + struct tm * (*tclpLocaltime_unix) (const time_t *clock); /* 11 */ + struct tm * (*tclpGmtime_unix) (const time_t *clock); /* 12 */ + char * (*tclpInetNtoa) (struct in_addr addr); /* 13 */ 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); - void (*reserved22)(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 (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */ int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* MACOSX */ } TclIntPlatStubs; extern const TclIntPlatStubs *tclIntPlatStubsPtr; @@ -354,33 +394,44 @@ (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ #define TclpCreatePipe \ (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ #define TclpCreateProcess \ (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ -/* Slot 5 is reserved */ +#define TclUnixWaitForFile_ \ + (tclIntPlatStubsPtr->tclUnixWaitForFile_) /* 5 */ #define TclpMakeFile \ (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ #define TclpOpenFile \ (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */ #define TclUnixWaitForFile \ (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */ #define TclpCreateTempFile \ (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ -/* Slot 10 is reserved */ -/* Slot 11 is reserved */ -/* Slot 12 is reserved */ -/* Slot 13 is reserved */ +#define TclpReaddir \ + (tclIntPlatStubsPtr->tclpReaddir) /* 10 */ +#define TclpLocaltime_unix \ + (tclIntPlatStubsPtr->tclpLocaltime_unix) /* 11 */ +#define TclpGmtime_unix \ + (tclIntPlatStubsPtr->tclpGmtime_unix) /* 12 */ +#define TclpInetNtoa \ + (tclIntPlatStubsPtr->tclpInetNtoa) /* 13 */ #define TclUnixCopyFile \ (tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */ -/* Slot 15 is reserved */ -/* Slot 16 is reserved */ -/* Slot 17 is reserved */ -/* Slot 18 is reserved */ -/* Slot 19 is reserved */ +#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 */ +#define TclpCreateTempFile_ \ + (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 22 */ /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ /* Slot 26 is reserved */ /* Slot 27 is reserved */ @@ -391,23 +442,30 @@ (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* UNIX */ #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ #define TclWinConvertError \ (tclIntPlatStubsPtr->tclWinConvertError) /* 0 */ -/* Slot 1 is reserved */ -/* Slot 2 is reserved */ -/* Slot 3 is reserved */ +#define TclWinConvertWSAError \ + (tclIntPlatStubsPtr->tclWinConvertWSAError) /* 1 */ +#define TclWinGetServByName \ + (tclIntPlatStubsPtr->tclWinGetServByName) /* 2 */ +#define TclWinGetSockOpt \ + (tclIntPlatStubsPtr->tclWinGetSockOpt) /* 3 */ #define TclWinGetTclInstance \ (tclIntPlatStubsPtr->tclWinGetTclInstance) /* 4 */ #define TclUnixWaitForFile \ (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 5 */ -/* Slot 6 is reserved */ -/* Slot 7 is reserved */ +#define TclWinNToHS \ + (tclIntPlatStubsPtr->tclWinNToHS) /* 6 */ +#define TclWinSetSockOpt \ + (tclIntPlatStubsPtr->tclWinSetSockOpt) /* 7 */ #define TclpGetPid \ (tclIntPlatStubsPtr->tclpGetPid) /* 8 */ -/* Slot 9 is reserved */ -/* Slot 10 is reserved */ +#define TclWinGetPlatformId \ + (tclIntPlatStubsPtr->tclWinGetPlatformId) /* 9 */ +#define TclpReaddir \ + (tclIntPlatStubsPtr->tclpReaddir) /* 10 */ #define TclGetAndDetachPids \ (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 11 */ #define TclpCloseFile \ (tclIntPlatStubsPtr->tclpCloseFile) /* 12 */ #define TclpCreateCommandChannel \ @@ -424,21 +482,24 @@ (tclIntPlatStubsPtr->tclpMakeFile) /* 18 */ #define TclpOpenFile \ (tclIntPlatStubsPtr->tclpOpenFile) /* 19 */ #define TclWinAddProcess \ (tclIntPlatStubsPtr->tclWinAddProcess) /* 20 */ -/* Slot 21 is reserved */ +#define TclpInetNtoa \ + (tclIntPlatStubsPtr->tclpInetNtoa) /* 21 */ #define TclpCreateTempFile \ (tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */ /* Slot 23 is reserved */ #define TclWinNoBackslash \ (tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */ /* Slot 25 is reserved */ -/* Slot 26 is reserved */ +#define TclWinSetInterfaces \ + (tclIntPlatStubsPtr->tclWinSetInterfaces) /* 26 */ #define TclWinFlushDirtyChannels \ (tclIntPlatStubsPtr->tclWinFlushDirtyChannels) /* 27 */ -/* Slot 28 is reserved */ +#define TclWinResetInterfaces \ + (tclIntPlatStubsPtr->tclWinResetInterfaces) /* 28 */ #define TclWinCPUID \ (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ #define TclUnixOpenTemporaryFile \ (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* WIN */ @@ -451,23 +512,28 @@ (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ #define TclpCreatePipe \ (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ #define TclpCreateProcess \ (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ -/* Slot 5 is reserved */ +#define TclUnixWaitForFile_ \ + (tclIntPlatStubsPtr->tclUnixWaitForFile_) /* 5 */ #define TclpMakeFile \ (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ #define TclpOpenFile \ (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */ #define TclUnixWaitForFile \ (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */ #define TclpCreateTempFile \ (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ -/* Slot 10 is reserved */ -/* Slot 11 is reserved */ -/* Slot 12 is reserved */ -/* Slot 13 is reserved */ +#define TclpReaddir \ + (tclIntPlatStubsPtr->tclpReaddir) /* 10 */ +#define TclpLocaltime_unix \ + (tclIntPlatStubsPtr->tclpLocaltime_unix) /* 11 */ +#define TclpGmtime_unix \ + (tclIntPlatStubsPtr->tclpGmtime_unix) /* 12 */ +#define TclpInetNtoa \ + (tclIntPlatStubsPtr->tclpInetNtoa) /* 13 */ #define TclUnixCopyFile \ (tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */ #define TclMacOSXGetFileAttribute \ (tclIntPlatStubsPtr->tclMacOSXGetFileAttribute) /* 15 */ #define TclMacOSXSetFileAttribute \ @@ -478,11 +544,12 @@ (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */ #define TclMacOSXNotifierAddRunLoopMode \ (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ /* Slot 20 is reserved */ /* Slot 21 is reserved */ -/* Slot 22 is reserved */ +#define TclpCreateTempFile_ \ + (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 22 */ /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ /* Slot 26 is reserved */ /* Slot 27 is reserved */ @@ -497,13 +564,37 @@ /* !END!: Do not edit above this line. */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT +#undef TclpLocaltime_unix +#undef TclpGmtime_unix +#undef TclWinConvertWSAError #define TclWinConvertWSAError TclWinConvertError +#undef TclpInetNtoa +#define TclpInetNtoa inet_ntoa + +#undef TclpCreateTempFile_ +#undef TclUnixWaitForFile_ +#ifndef MAC_OSX_TCL /* not accessable on Win32/UNIX */ +#undef TclMacOSXGetFileAttribute /* 15 */ +#undef TclMacOSXSetFileAttribute /* 16 */ +#undef TclMacOSXCopyFileAttributes /* 17 */ +#undef TclMacOSXMatchType /* 18 */ +#undef TclMacOSXNotifierAddRunLoopMode /* 19 */ +#endif -#if !defined(_WIN32) +#if defined(_WIN32) +# undef TclWinNToHS +# undef TclWinGetServByName +# undef TclWinGetSockOpt +# undef TclWinSetSockOpt +# define TclWinNToHS ntohs +# define TclWinGetServByName getservbyname +# define TclWinGetSockOpt getsockopt +# define TclWinSetSockOpt setsockopt +#else # undef TclpGetPid -# define TclpGetPid(pid) ((size_t) (pid)) +# define TclpGetPid(pid) ((unsigned long) (pid)) #endif #endif /* _TCLINTPLATDECLS */ Index: generic/tclInterp.c ================================================================== --- generic/tclInterp.c +++ generic/tclInterp.c @@ -23,40 +23,40 @@ /* Forward declaration */ struct Target; /* - * Alias: + * struct Alias: * - * Stores information about an alias. Is stored in the slave interpreter and - * used by the source command to find the target command in the master when + * Stores information about an alias. Is stored in the child interpreter and + * used by the source command to find the target command in the parent when * the source command is invoked. */ -typedef struct { - Tcl_Obj *token; /* Token for the alias command in the slave +typedef struct Alias { + Tcl_Obj *token; /* Token for the alias command in the child * interp. This used to be the command name in - * the slave when the alias was first + * the child when the alias was first * created. */ Tcl_Interp *targetInterp; /* Interp in which target command will be * invoked. */ - Tcl_Command slaveCmd; /* Source command in slave interpreter, bound + Tcl_Command childCmd; /* Source command in child interpreter, bound * to command that invokes the target command * in the target interpreter. */ Tcl_HashEntry *aliasEntryPtr; - /* Entry for the alias hash table in slave. + /* Entry for the alias hash table in child. * This is used by alias deletion to remove - * the alias from the slave interpreter alias + * the alias from the child interpreter alias * table. */ - struct Target *targetPtr; /* Entry for target command in master. This is - * used in the master interpreter to map back + struct Target *targetPtr; /* Entry for target command in parent. This is + * used in the parent interpreter to map back * from the target command to aliases * redirecting to it. */ int objc; /* Count of Tcl_Obj in the prefix of the * target command to be invoked in the target * interpreter. Additional arguments specified - * when calling the alias in the slave interp + * when calling the alias in the child interp * will be appended to the prefix before the * command is invoked. */ Tcl_Obj *objPtr; /* The first actual prefix object - the target * command name; this has to be at the end of * the structure, which will be extended to @@ -64,103 +64,103 @@ * prefix. */ } Alias; /* * - * Slave: + * struct Child: * - * Used by the "interp" command to record and find information about slave - * interpreters. Maps from a command name in the master to information about a - * slave interpreter, e.g. what aliases are defined in it. + * Used by the "interp" command to record and find information about child + * interpreters. Maps from a command name in the parent to information about a + * child interpreter, e.g. what aliases are defined in it. */ -typedef struct { - Tcl_Interp *masterInterp; /* Master interpreter for this slave. */ - Tcl_HashEntry *slaveEntryPtr; - /* Hash entry in masters slave table for this - * slave interpreter. Used to find this - * record, and used when deleting the slave - * interpreter to delete it from the master's +typedef struct Child { + Tcl_Interp *parentInterp; /* Parent interpreter for this child. */ + Tcl_HashEntry *childEntryPtr; + /* Hash entry in parents child table for this + * child interpreter. Used to find this + * record, and used when deleting the child + * interpreter to delete it from the parent's * table. */ - Tcl_Interp *slaveInterp; /* The slave interpreter. */ + Tcl_Interp *childInterp; /* The child interpreter. */ Tcl_Command interpCmd; /* Interpreter object command. */ Tcl_HashTable aliasTable; /* Table which maps from names of commands in - * slave interpreter to struct Alias defined + * child interpreter to struct Alias defined * below. */ -} Slave; +} Child; /* * struct Target: * - * Maps from master interpreter commands back to the source commands in slave + * Maps from parent interpreter commands back to the source commands in child * interpreters. This is needed because aliases can be created between sibling * interpreters and must be deleted when the target interpreter is deleted. In * case they would not be deleted the source interpreter would be left with a - * "dangling pointer". One such record is stored in the Master record of the - * master interpreter with the master for each alias which directs to a - * command in the master. These records are used to remove the source command - * for an from a slave if/when the master is deleted. They are organized in a - * doubly-linked list attached to the master interpreter. + * "dangling pointer". One such record is stored in the Parent record of the + * parent interpreter with the parent for each alias which directs to a + * command in the parent. These records are used to remove the source command + * for an from a child if/when the parent is deleted. They are organized in a + * doubly-linked list attached to the parent interpreter. */ typedef struct Target { - Tcl_Command slaveCmd; /* Command for alias in slave interp. */ - Tcl_Interp *slaveInterp; /* Slave Interpreter. */ + Tcl_Command childCmd; /* Command for alias in child interp. */ + Tcl_Interp *childInterp; /* Child Interpreter. */ struct Target *nextPtr; /* Next in list of target records, or NULL if * at the end of the list of targets. */ struct Target *prevPtr; /* Previous in list of target records, or NULL * if at the start of the list of targets. */ } Target; /* - * Master: + * struct Parent: * - * This record is used for two purposes: First, slaveTable (a hashtable) maps - * from names of commands to slave interpreters. This hashtable is used to - * store information about slave interpreters of this interpreter, to map over - * all slaves, etc. The second purpose is to store information about all - * aliases in slaves (or siblings) which direct to target commands in this + * This record is used for two purposes: First, childTable (a hashtable) maps + * from names of commands to child interpreters. This hashtable is used to + * store information about child interpreters of this interpreter, to map over + * all children, etc. The second purpose is to store information about all + * aliases in children (or siblings) which direct to target commands in this * interpreter (using the targetsPtr doubly-linked list). * * NB: the flags field in the interp structure, used with SAFE_INTERP mask * denotes whether the interpreter is safe or not. Safe interpreters have - * restricted functionality, can only create safe slave interpreters and can + * restricted functionality, can only create safe interpreters and can * only load safe extensions. */ -typedef struct { - Tcl_HashTable slaveTable; /* Hash table for slave interpreters. Maps - * from command names to Slave records. */ +typedef struct Parent { + Tcl_HashTable childTable; /* Hash table for child interpreters. Maps + * from command names to Child records. */ Target *targetsPtr; /* The head of a doubly-linked list of all the * target records which denote aliases from - * slaves or sibling interpreters that direct + * children or sibling interpreters that direct * to commands in this interpreter. This list * is used to remove dangling pointers from - * the slave (or sibling) interpreters when + * the child (or sibling) interpreters when * this interpreter is deleted. */ -} Master; +} Parent; /* - * The following structure keeps track of all the Master and Slave information + * The following structure keeps track of all the Parent and Child information * on a per-interp basis. */ -typedef struct { - Master master; /* Keeps track of all interps for which this - * interp is the Master. */ - Slave slave; /* Information necessary for this interp to - * function as a slave. */ +typedef struct InterpInfo { + Parent parent; /* Keeps track of all interps for which this + * interp is the Parent. */ + Child child; /* Information necessary for this interp to + * function as a child. */ } InterpInfo; /* * Limit callbacks handled by scripts are modelled as structures which are * stored in hashes indexed by a two-word key. Note that the type of the * 'type' field in the key is not int; this is to make sure that things are * likely to work properly on 64-bit architectures. */ -typedef struct { +typedef struct ScriptLimitCallback { Tcl_Interp *interp; /* The interpreter in which to execute the * callback. */ Tcl_Obj *scriptObj; /* The script to execute to perform the * user-defined part of the callback. */ int type; /* What kind of callback is this. */ @@ -169,11 +169,11 @@ * callback record, or NULL if the entry has * already been deleted from that hash * table. */ } ScriptLimitCallback; -typedef struct { +typedef struct ScriptLimitCallbackKey { Tcl_Interp *interp; /* The interpreter that the limit callback was * attached to. This is not the interpreter * that the callback runs in! */ long type; /* The type of callback that this is. */ } ScriptLimitCallbackKey; @@ -212,62 +212,67 @@ /* * Prototypes for local static functions: */ static int AliasCreate(Tcl_Interp *interp, - Tcl_Interp *slaveInterp, Tcl_Interp *masterInterp, + Tcl_Interp *childInterp, Tcl_Interp *parentInterp, Tcl_Obj *namePtr, Tcl_Obj *targetPtr, int objc, Tcl_Obj *const objv[]); static int AliasDelete(Tcl_Interp *interp, - Tcl_Interp *slaveInterp, Tcl_Obj *namePtr); + Tcl_Interp *childInterp, Tcl_Obj *namePtr); static int AliasDescribe(Tcl_Interp *interp, - Tcl_Interp *slaveInterp, Tcl_Obj *objPtr); -static int AliasList(Tcl_Interp *interp, Tcl_Interp *slaveInterp); + Tcl_Interp *childInterp, Tcl_Obj *objPtr); +static int AliasList(Tcl_Interp *interp, Tcl_Interp *childInterp); +static int AliasObjCmd(ClientData dummy, + Tcl_Interp *currentInterp, int objc, + Tcl_Obj *const objv[]); static int AliasNRCmd(ClientData dummy, Tcl_Interp *currentInterp, int objc, Tcl_Obj *const objv[]); static void AliasObjCmdDeleteProc(ClientData clientData); static Tcl_Interp * GetInterp(Tcl_Interp *interp, Tcl_Obj *pathPtr); static Tcl_Interp * GetInterp2(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static void InterpInfoDeleteProc(ClientData clientData, Tcl_Interp *interp); -static int SlaveBgerror(Tcl_Interp *interp, - Tcl_Interp *slaveInterp, int objc, - Tcl_Obj *const objv[]); -static Tcl_Interp * SlaveCreate(Tcl_Interp *interp, Tcl_Obj *pathPtr, - int safe); -static int SlaveDebugCmd(Tcl_Interp *interp, - Tcl_Interp *slaveInterp, - int objc, Tcl_Obj *const objv[]); -static int SlaveEval(Tcl_Interp *interp, Tcl_Interp *slaveInterp, - int objc, Tcl_Obj *const objv[]); -static int SlaveExpose(Tcl_Interp *interp, - Tcl_Interp *slaveInterp, int objc, - Tcl_Obj *const objv[]); -static int SlaveHide(Tcl_Interp *interp, Tcl_Interp *slaveInterp, - int objc, Tcl_Obj *const objv[]); -static int SlaveHidden(Tcl_Interp *interp, - Tcl_Interp *slaveInterp); -static int SlaveInvokeHidden(Tcl_Interp *interp, - Tcl_Interp *slaveInterp, +static int ChildBgerror(Tcl_Interp *interp, + Tcl_Interp *childInterp, int objc, + Tcl_Obj *const objv[]); +static Tcl_Interp * ChildCreate(Tcl_Interp *interp, Tcl_Obj *pathPtr, + int safe); +static int ChildDebugCmd(Tcl_Interp *interp, + Tcl_Interp *childInterp, + int objc, Tcl_Obj *const objv[]); +static int ChildEval(Tcl_Interp *interp, Tcl_Interp *childInterp, + int objc, Tcl_Obj *const objv[]); +static int ChildExpose(Tcl_Interp *interp, + Tcl_Interp *childInterp, int objc, + Tcl_Obj *const objv[]); +static int ChildHide(Tcl_Interp *interp, Tcl_Interp *childInterp, + int objc, Tcl_Obj *const objv[]); +static int ChildHidden(Tcl_Interp *interp, + Tcl_Interp *childInterp); +static int ChildInvokeHidden(Tcl_Interp *interp, + Tcl_Interp *childInterp, const char *namespaceName, int objc, Tcl_Obj *const objv[]); -static int SlaveMarkTrusted(Tcl_Interp *interp, - Tcl_Interp *slaveInterp); -static void SlaveObjCmdDeleteProc(ClientData clientData); -static int SlaveRecursionLimit(Tcl_Interp *interp, - Tcl_Interp *slaveInterp, int objc, +static int ChildMarkTrusted(Tcl_Interp *interp, + Tcl_Interp *childInterp); +static int ChildObjCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static void ChildObjCmdDeleteProc(ClientData clientData); +static int ChildRecursionLimit(Tcl_Interp *interp, + Tcl_Interp *childInterp, int objc, Tcl_Obj *const objv[]); -static int SlaveCommandLimitCmd(Tcl_Interp *interp, - Tcl_Interp *slaveInterp, int consumedObjc, - int objc, Tcl_Obj *const objv[]); -static int SlaveTimeLimitCmd(Tcl_Interp *interp, - Tcl_Interp *slaveInterp, int consumedObjc, - int objc, Tcl_Obj *const objv[]); -static void InheritLimitsFromMaster(Tcl_Interp *slaveInterp, - Tcl_Interp *masterInterp); +static int ChildCommandLimitCmd(Tcl_Interp *interp, + Tcl_Interp *childInterp, int consumedObjc, + int objc, Tcl_Obj *const objv[]); +static int ChildTimeLimitCmd(Tcl_Interp *interp, + Tcl_Interp *childInterp, int consumedObjc, + int objc, Tcl_Obj *const objv[]); +static void InheritLimitsFromParent(Tcl_Interp *childInterp, + Tcl_Interp *parentInterp); static void SetScriptLimitCallback(Tcl_Interp *interp, int type, Tcl_Interp *targetInterp, Tcl_Obj *scriptObj); static void CallScriptLimitCallback(ClientData clientData, Tcl_Interp *interp); static void DeleteScriptLimitCallback(ClientData clientData); @@ -276,11 +281,11 @@ static void TimeLimitCallback(ClientData clientData); /* NRE enabling */ static Tcl_NRPostProc NRPostInvokeHidden; static Tcl_ObjCmdProc NRInterpCmd; -static Tcl_ObjCmdProc NRSlaveCmd; +static Tcl_ObjCmdProc NRChildCmd; /* *---------------------------------------------------------------------- * @@ -324,28 +329,17 @@ * Depends on what's in the init.tcl script. * *---------------------------------------------------------------------- */ -typedef struct PkgName { - struct PkgName *nextPtr; /* Next in list of package names being initialized. */ - char name[4]; -} PkgName; - int Tcl_Init( Tcl_Interp *interp) /* Interpreter to initialize. */ { - PkgName pkgName = {NULL, "Tcl"}; - PkgName **names = TclInitPkgFiles(interp); - int result = TCL_ERROR; - - pkgName.nextPtr = *names; - *names = &pkgName; if (tclPreInitScript != NULL) { - if (Tcl_EvalEx(interp, tclPreInitScript, -1, 0) == TCL_ERROR) { - goto end; + if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) { + return TCL_ERROR; } } /* * In order to find init.tcl during initialization, the following script @@ -386,11 +380,11 @@ * * Note that this entire search mechanism can be bypassed by defining an * alternate tclInit command before calling Tcl_Init(). */ - result = Tcl_EvalEx(interp, + return Tcl_Eval(interp, "if {[namespace which -command tclInit] eq \"\"} {\n" " proc tclInit {} {\n" " global tcl_libPath tcl_library env tclDefaultLibrary\n" " rename tclInit {}\n" " if {[info exists tcl_library]} {\n" @@ -407,19 +401,17 @@ " if {[info exists tclDefaultLibrary]} {\n" " lappend scripts {set tclDefaultLibrary}\n" " } else {\n" " lappend scripts {::tcl::pkgconfig get scriptdir,runtime}\n" " }\n" -" lappend scripts {::tcl::zipfs::tcl_library_init}\n" " lappend scripts {\n" "set parentDir [file dirname [file dirname [info nameofexecutable]]]\n" "set grandParentDir [file dirname $parentDir]\n" "file join $parentDir lib tcl[info tclversion]} \\\n" " {file join $grandParentDir lib tcl[info tclversion]} \\\n" " {file join $parentDir library} \\\n" " {file join $grandParentDir library} \\\n" -" {file join $grandParentDir tcl[info tclversion] library} \\\n" " {file join $grandParentDir tcl[info patchlevel] library} \\\n" " {\n" "file join [file dirname $grandParentDir] tcl[info patchlevel] library}\n" " if {[info exists tcl_libPath]\n" " && [catch {llength $tcl_libPath} len] == 0} {\n" @@ -450,23 +442,19 @@ " append msg \"$errors\n\n\"\n" " append msg \"This probably means that Tcl wasn't installed properly.\n\"\n" " error $msg\n" " }\n" "}\n" -"tclInit", -1, 0); - -end: - *names = (*names)->nextPtr; - return result; +"tclInit"); } /* *--------------------------------------------------------------------------- * * TclInterpInit -- * - * Initializes the invoking interpreter for using the master, slave and + * Initializes the invoking interpreter for using the parent, child and * safe interp facilities. This is called from inside Tcl_CreateInterp(). * * Results: * Always returns TCL_OK for backwards compatibility. * @@ -480,26 +468,26 @@ int TclInterpInit( Tcl_Interp *interp) /* Interpreter to initialize. */ { InterpInfo *interpInfoPtr; - Master *masterPtr; - Slave *slavePtr; + Parent *parentPtr; + Child *childPtr; - interpInfoPtr = Tcl_Alloc(sizeof(InterpInfo)); + interpInfoPtr = ckalloc(sizeof(InterpInfo)); ((Interp *) interp)->interpInfo = interpInfoPtr; - masterPtr = &interpInfoPtr->master; - Tcl_InitHashTable(&masterPtr->slaveTable, TCL_STRING_KEYS); - masterPtr->targetsPtr = NULL; - - slavePtr = &interpInfoPtr->slave; - slavePtr->masterInterp = NULL; - slavePtr->slaveEntryPtr = NULL; - slavePtr->slaveInterp = interp; - slavePtr->interpCmd = NULL; - Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); + parentPtr = &interpInfoPtr->parent; + Tcl_InitHashTable(&parentPtr->childTable, TCL_STRING_KEYS); + parentPtr->targetsPtr = NULL; + + childPtr = &interpInfoPtr->child; + childPtr->parentInterp = NULL; + childPtr->childEntryPtr = NULL; + childPtr->childInterp = interp; + childPtr->interpCmd = NULL; + Tcl_InitHashTable(&childPtr->aliasTable, TCL_STRING_KEYS); Tcl_NRCreateCommand(interp, "interp", Tcl_InterpObjCmd, NRInterpCmd, NULL, NULL); Tcl_CallWhenDeleted(interp, InterpInfoDeleteProc, NULL); @@ -510,11 +498,11 @@ *--------------------------------------------------------------------------- * * InterpInfoDeleteProc -- * * Invoked when an interpreter is being deleted. It releases all storage - * used by the master/slave/safe interpreter facilities. + * used by the parent/child/safe interpreter facilities. * * Results: * None. * * Side effects: @@ -525,66 +513,66 @@ static void InterpInfoDeleteProc( ClientData clientData, /* Ignored. */ Tcl_Interp *interp) /* Interp being deleted. All commands for - * slave interps should already be deleted. */ + * child interps should already be deleted. */ { InterpInfo *interpInfoPtr; - Slave *slavePtr; - Master *masterPtr; + Child *childPtr; + Parent *parentPtr; Target *targetPtr; interpInfoPtr = (InterpInfo *) ((Interp *) interp)->interpInfo; /* * There shouldn't be any commands left. */ - masterPtr = &interpInfoPtr->master; - if (masterPtr->slaveTable.numEntries != 0) { + parentPtr = &interpInfoPtr->parent; + if (parentPtr->childTable.numEntries != 0) { Tcl_Panic("InterpInfoDeleteProc: still exist commands"); } - Tcl_DeleteHashTable(&masterPtr->slaveTable); + Tcl_DeleteHashTable(&parentPtr->childTable); /* * Tell any interps that have aliases to this interp that they should * delete those aliases. If the other interp was already dead, it would * have removed the target record already. */ - for (targetPtr = masterPtr->targetsPtr; targetPtr != NULL; ) { + for (targetPtr = parentPtr->targetsPtr; targetPtr != NULL; ) { Target *tmpPtr = targetPtr->nextPtr; - Tcl_DeleteCommandFromToken(targetPtr->slaveInterp, - targetPtr->slaveCmd); + Tcl_DeleteCommandFromToken(targetPtr->childInterp, + targetPtr->childCmd); targetPtr = tmpPtr; } - slavePtr = &interpInfoPtr->slave; - if (slavePtr->interpCmd != NULL) { + childPtr = &interpInfoPtr->child; + if (childPtr->interpCmd != NULL) { /* * Tcl_DeleteInterp() was called on this interpreter, rather "interp - * delete" or the equivalent deletion of the command in the master. + * delete" or the equivalent deletion of the command in the parent. * First ensure that the cleanup callback doesn't try to delete the * interp again. */ - slavePtr->slaveInterp = NULL; - Tcl_DeleteCommandFromToken(slavePtr->masterInterp, - slavePtr->interpCmd); + childPtr->childInterp = NULL; + Tcl_DeleteCommandFromToken(childPtr->parentInterp, + childPtr->interpCmd); } /* * There shouldn't be any aliases left. */ - if (slavePtr->aliasTable.numEntries != 0) { + if (childPtr->aliasTable.numEntries != 0) { Tcl_Panic("InterpInfoDeleteProc: still exist aliases"); } - Tcl_DeleteHashTable(&slavePtr->aliasTable); + Tcl_DeleteHashTable(&childPtr->aliasTable); - Tcl_Free(interpInfoPtr); + ckfree(interpInfoPtr); } /* *---------------------------------------------------------------------- * @@ -617,24 +605,24 @@ ClientData clientData, /* Unused. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Interp *slaveInterp; + Tcl_Interp *childInterp; int index; static const char *const options[] = { "alias", "aliases", "bgerror", "cancel", - "create", "debug", "delete", + "children", "create", "debug", "delete", "eval", "exists", "expose", "hide", "hidden", "issafe", "invokehidden", "limit", "marktrusted", "recursionlimit", "slaves", "share", "target", "transfer", NULL }; enum option { OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_CANCEL, - OPT_CREATE, OPT_DEBUG, OPT_DELETE, + OPT_CHILDREN, OPT_CREATE, OPT_DEBUG, OPT_DELETE, OPT_EVAL, OPT_EXISTS, OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID, OPT_LIMIT, OPT_MARKTRUSTED,OPT_RECLIMIT, OPT_SLAVES, OPT_SHARE, OPT_TARGET, OPT_TRANSFER }; @@ -647,55 +635,55 @@ &index) != TCL_OK) { return TCL_ERROR; } switch ((enum option) index) { case OPT_ALIAS: { - Tcl_Interp *masterInterp; + Tcl_Interp *parentInterp; if (objc < 4) { aliasArgs: Tcl_WrongNumArgs(interp, 2, objv, "slavePath slaveCmd ?masterPath masterCmd? ?arg ...?"); return TCL_ERROR; } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[2]); + if (childInterp == NULL) { return TCL_ERROR; } if (objc == 4) { - return AliasDescribe(interp, slaveInterp, objv[3]); + return AliasDescribe(interp, childInterp, objv[3]); } if ((objc == 5) && (TclGetString(objv[4])[0] == '\0')) { - return AliasDelete(interp, slaveInterp, objv[3]); + return AliasDelete(interp, childInterp, objv[3]); } if (objc > 5) { - masterInterp = GetInterp(interp, objv[4]); - if (masterInterp == NULL) { + parentInterp = GetInterp(interp, objv[4]); + if (parentInterp == NULL) { return TCL_ERROR; } - return AliasCreate(interp, slaveInterp, masterInterp, objv[3], + return AliasCreate(interp, childInterp, parentInterp, objv[3], objv[5], objc - 6, objv + 6); } goto aliasArgs; } case OPT_ALIASES: - slaveInterp = GetInterp2(interp, objc, objv); - if (slaveInterp == NULL) { + childInterp = GetInterp2(interp, objc, objv); + if (childInterp == NULL) { return TCL_ERROR; } - return AliasList(interp, slaveInterp); + return AliasList(interp, childInterp); case OPT_BGERROR: if (objc != 3 && objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "path ?cmdPrefix?"); return TCL_ERROR; } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[2]); + if (childInterp == NULL) { return TCL_ERROR; } - return SlaveBgerror(interp, slaveInterp, objc - 3, objv + 3); + return ChildBgerror(interp, childInterp, objc - 3, objv + 3); case OPT_CANCEL: { int i, flags; Tcl_Obj *resultObjPtr; static const char *const cancelOptions[] = { "-unwind", "--", NULL @@ -735,22 +723,22 @@ "?-unwind? ?--? ?path? ?result?"); return TCL_ERROR; } /* - * Did they specify a slave interp to cancel the script in progress + * Did they specify a child interp to cancel the script in progress * in? If not, use the current interp. */ if (i < objc) { - slaveInterp = GetInterp(interp, objv[i]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[i]); + if (childInterp == NULL) { return TCL_ERROR; } i++; } else { - slaveInterp = interp; + childInterp = interp; } if (i < objc) { resultObjPtr = objv[i]; @@ -762,15 +750,15 @@ i++; } else { resultObjPtr = NULL; } - return Tcl_CancelEval(slaveInterp, resultObjPtr, 0, flags); + return Tcl_CancelEval(childInterp, resultObjPtr, 0, flags); } case OPT_CREATE: { int i, last, safe; - Tcl_Obj *slavePtr; + Tcl_Obj *childPtr; char buf[16 + TCL_INTEGER_SPACE]; static const char *const createOptions[] = { "-safe", "--", NULL }; enum option { @@ -781,14 +769,14 @@ /* * Weird historical rules: "-safe" is accepted at the end, too. */ - slavePtr = NULL; + childPtr = NULL; last = 0; for (i = 2; i < objc; i++) { - if ((last == 0) && (TclGetString(objv[i])[0] == '-')) { + if ((last == 0) && (Tcl_GetString(objv[i])[0] == '-')) { if (Tcl_GetIndexFromObj(interp, objv[i], createOptions, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } if (index == OPT_SAFE) { @@ -796,25 +784,25 @@ continue; } i++; last = 1; } - if (slavePtr != NULL) { + if (childPtr != NULL) { Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?"); return TCL_ERROR; } if (i < objc) { - slavePtr = objv[i]; + childPtr = objv[i]; } } buf[0] = '\0'; - if (slavePtr == NULL) { + if (childPtr == NULL) { /* * Create an anonymous interpreter -- we choose its name and the * name of the command. We check that the command name that we use * for the interpreter does not collide with an existing command - * in the master interpreter. + * in the parent interpreter. */ for (i = 0; ; i++) { Tcl_CmdInfo cmdInfo; @@ -821,19 +809,19 @@ sprintf(buf, "interp%d", i); if (Tcl_GetCommandInfo(interp, buf, &cmdInfo) == 0) { break; } } - slavePtr = Tcl_NewStringObj(buf, -1); + childPtr = Tcl_NewStringObj(buf, -1); } - if (SlaveCreate(interp, slavePtr, safe) == NULL) { + if (ChildCreate(interp, childPtr, safe) == NULL) { if (buf[0] != '\0') { - Tcl_DecrRefCount(slavePtr); + Tcl_DecrRefCount(childPtr); } return TCL_ERROR; } - Tcl_SetObjResult(interp, slavePtr); + Tcl_SetObjResult(interp, childPtr); return TCL_OK; } case OPT_DEBUG: /* TIP #378 */ /* * Currently only -frame supported, otherwise ?-option ?value?? @@ -841,51 +829,51 @@ if (objc < 3 || objc > 5) { Tcl_WrongNumArgs(interp, 2, objv, "path ?-frame ?bool??"); return TCL_ERROR; } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[2]); + if (childInterp == NULL) { return TCL_ERROR; } - return SlaveDebugCmd(interp, slaveInterp, objc - 3, objv + 3); + return ChildDebugCmd(interp, childInterp, objc - 3, objv + 3); case OPT_DELETE: { int i; InterpInfo *iiPtr; for (i = 2; i < objc; i++) { - slaveInterp = GetInterp(interp, objv[i]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[i]); + if (childInterp == NULL) { return TCL_ERROR; - } else if (slaveInterp == interp) { + } else if (childInterp == interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot delete the current interpreter", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "DELETESELF", NULL); return TCL_ERROR; } - iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; - Tcl_DeleteCommandFromToken(iiPtr->slave.masterInterp, - iiPtr->slave.interpCmd); + iiPtr = (InterpInfo *) ((Interp *) childInterp)->interpInfo; + Tcl_DeleteCommandFromToken(iiPtr->child.parentInterp, + iiPtr->child.interpCmd); } return TCL_OK; } case OPT_EVAL: if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?"); return TCL_ERROR; } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[2]); + if (childInterp == NULL) { return TCL_ERROR; } - return SlaveEval(interp, slaveInterp, objc - 3, objv + 3); + return ChildEval(interp, childInterp, objc - 3, objv + 3); case OPT_EXISTS: { int exists = 1; - slaveInterp = GetInterp2(interp, objc, objv); - if (slaveInterp == NULL) { + childInterp = GetInterp2(interp, objc, objv); + if (childInterp == NULL) { if (objc > 3) { return TCL_ERROR; } Tcl_ResetResult(interp); exists = 0; @@ -896,37 +884,37 @@ case OPT_EXPOSE: if ((objc < 4) || (objc > 5)) { Tcl_WrongNumArgs(interp, 2, objv, "path hiddenCmdName ?cmdName?"); return TCL_ERROR; } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[2]); + if (childInterp == NULL) { return TCL_ERROR; } - return SlaveExpose(interp, slaveInterp, objc - 3, objv + 3); + return ChildExpose(interp, childInterp, objc - 3, objv + 3); case OPT_HIDE: if ((objc < 4) || (objc > 5)) { Tcl_WrongNumArgs(interp, 2, objv, "path cmdName ?hiddenCmdName?"); return TCL_ERROR; } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[2]); + if (childInterp == NULL) { return TCL_ERROR; } - return SlaveHide(interp, slaveInterp, objc - 3, objv + 3); + return ChildHide(interp, childInterp, objc - 3, objv + 3); case OPT_HIDDEN: - slaveInterp = GetInterp2(interp, objc, objv); - if (slaveInterp == NULL) { + childInterp = GetInterp2(interp, objc, objv); + if (childInterp == NULL) { return TCL_ERROR; } - return SlaveHidden(interp, slaveInterp); + return ChildHidden(interp, childInterp); case OPT_ISSAFE: - slaveInterp = GetInterp2(interp, objc, objv); - if (slaveInterp == NULL) { + childInterp = GetInterp2(interp, objc, objv); + if (childInterp == NULL) { return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp))); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(childInterp))); return TCL_OK; case OPT_INVOKEHID: { int i; const char *namespaceName; static const char *const hiddenOptions[] = { @@ -961,15 +949,15 @@ if (objc - i < 1) { Tcl_WrongNumArgs(interp, 2, objv, "path ?-namespace ns? ?-global? ?--? cmd ?arg ..?"); return TCL_ERROR; } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[2]); + if (childInterp == NULL) { return TCL_ERROR; } - return SlaveInvokeHidden(interp, slaveInterp, namespaceName, objc - i, + return ChildInvokeHidden(interp, childInterp, namespaceName, objc - i, objv + i); } case OPT_LIMIT: { static const char *const limitTypes[] = { "commands", "time", NULL @@ -982,98 +970,100 @@ if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, "path limitType ?-option value ...?"); return TCL_ERROR; } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[2]); + if (childInterp == NULL) { return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[3], limitTypes, "limit type", 0, &limitType) != TCL_OK) { return TCL_ERROR; } switch ((enum LimitTypes) limitType) { case LIMIT_TYPE_COMMANDS: - return SlaveCommandLimitCmd(interp, slaveInterp, 4, objc,objv); + return ChildCommandLimitCmd(interp, childInterp, 4, objc,objv); case LIMIT_TYPE_TIME: - return SlaveTimeLimitCmd(interp, slaveInterp, 4, objc, objv); + return ChildTimeLimitCmd(interp, childInterp, 4, objc, objv); } } + break; case OPT_MARKTRUSTED: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "path"); return TCL_ERROR; } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[2]); + if (childInterp == NULL) { return TCL_ERROR; } - return SlaveMarkTrusted(interp, slaveInterp); + return ChildMarkTrusted(interp, childInterp); case OPT_RECLIMIT: if (objc != 3 && objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "path ?newlimit?"); return TCL_ERROR; } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[2]); + if (childInterp == NULL) { return TCL_ERROR; } - return SlaveRecursionLimit(interp, slaveInterp, objc - 3, objv + 3); + return ChildRecursionLimit(interp, childInterp, objc - 3, objv + 3); + case OPT_CHILDREN: case OPT_SLAVES: { InterpInfo *iiPtr; Tcl_Obj *resultPtr; Tcl_HashEntry *hPtr; Tcl_HashSearch hashSearch; char *string; - slaveInterp = GetInterp2(interp, objc, objv); - if (slaveInterp == NULL) { + childInterp = GetInterp2(interp, objc, objv); + if (childInterp == NULL) { return TCL_ERROR; } - iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; + iiPtr = (InterpInfo *) ((Interp *) childInterp)->interpInfo; resultPtr = Tcl_NewObj(); - hPtr = Tcl_FirstHashEntry(&iiPtr->master.slaveTable, &hashSearch); + hPtr = Tcl_FirstHashEntry(&iiPtr->parent.childTable, &hashSearch); for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) { - string = Tcl_GetHashKey(&iiPtr->master.slaveTable, hPtr); + string = Tcl_GetHashKey(&iiPtr->parent.childTable, hPtr); Tcl_ListObjAppendElement(NULL, resultPtr, Tcl_NewStringObj(string, -1)); } Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } case OPT_TRANSFER: case OPT_SHARE: { - Tcl_Interp *masterInterp; /* The master of the slave. */ + Tcl_Interp *parentInterp; /* The parent of the child. */ Tcl_Channel chan; if (objc != 5) { Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath"); return TCL_ERROR; } - masterInterp = GetInterp(interp, objv[2]); - if (masterInterp == NULL) { + parentInterp = GetInterp(interp, objv[2]); + if (parentInterp == NULL) { return TCL_ERROR; } - chan = Tcl_GetChannel(masterInterp, TclGetString(objv[3]), NULL); + chan = Tcl_GetChannel(parentInterp, TclGetString(objv[3]), NULL); if (chan == NULL) { - Tcl_TransferResult(masterInterp, TCL_OK, interp); + Tcl_TransferResult(parentInterp, TCL_OK, interp); return TCL_ERROR; } - slaveInterp = GetInterp(interp, objv[4]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[4]); + if (childInterp == NULL) { return TCL_ERROR; } - Tcl_RegisterChannel(slaveInterp, chan); + Tcl_RegisterChannel(childInterp, chan); if (index == OPT_TRANSFER) { /* * When transferring, as opposed to sharing, we must unhitch the * channel from the interpreter where it started. */ - if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) { - Tcl_TransferResult(masterInterp, TCL_OK, interp); + if (Tcl_UnregisterChannel(parentInterp, chan) != TCL_OK) { + Tcl_TransferResult(parentInterp, TCL_OK, interp); return TCL_ERROR; } } return TCL_OK; } @@ -1086,32 +1076,32 @@ if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "path alias"); return TCL_ERROR; } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[2]); + if (childInterp == NULL) { return TCL_ERROR; } aliasName = TclGetString(objv[3]); - iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; - hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); + iiPtr = (InterpInfo *) ((Interp *) childInterp)->interpInfo; + hPtr = Tcl_FindHashEntry(&iiPtr->child.aliasTable, aliasName); if (hPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "alias \"%s\" in path \"%s\" not found", - aliasName, TclGetString(objv[2]))); + aliasName, Tcl_GetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL); return TCL_ERROR; } aliasPtr = Tcl_GetHashValue(hPtr); if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "target interpreter for alias \"%s\" in path \"%s\" is " - "not my descendant", aliasName, TclGetString(objv[2]))); + "not my descendant", aliasName, Tcl_GetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "TARGETSHROUDED", NULL); return TCL_ERROR; } return TCL_OK; @@ -1167,50 +1157,50 @@ * * Results: * A standard Tcl result. * * Side effects: - * Creates a new alias, manipulates the result field of slaveInterp. + * Creates a new alias, manipulates the result field of childInterp. * *---------------------------------------------------------------------- */ int Tcl_CreateAlias( - Tcl_Interp *slaveInterp, /* Interpreter for source command. */ - const char *slaveCmd, /* Command to install in slave. */ + Tcl_Interp *childInterp, /* Interpreter for source command. */ + const char *childCmd, /* Command to install in child. */ Tcl_Interp *targetInterp, /* Interpreter for target command. */ const char *targetCmd, /* Name of target command. */ int argc, /* How many additional arguments? */ const char *const *argv) /* These are the additional args. */ { - Tcl_Obj *slaveObjPtr, *targetObjPtr; + Tcl_Obj *childObjPtr, *targetObjPtr; Tcl_Obj **objv; int i; int result; - objv = TclStackAlloc(slaveInterp, sizeof(Tcl_Obj *) * argc); + objv = TclStackAlloc(childInterp, (unsigned) sizeof(Tcl_Obj *) * argc); for (i = 0; i < argc; i++) { objv[i] = Tcl_NewStringObj(argv[i], -1); Tcl_IncrRefCount(objv[i]); } - slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1); - Tcl_IncrRefCount(slaveObjPtr); + childObjPtr = Tcl_NewStringObj(childCmd, -1); + Tcl_IncrRefCount(childObjPtr); targetObjPtr = Tcl_NewStringObj(targetCmd, -1); Tcl_IncrRefCount(targetObjPtr); - result = AliasCreate(slaveInterp, slaveInterp, targetInterp, slaveObjPtr, + result = AliasCreate(childInterp, childInterp, targetInterp, childObjPtr, targetObjPtr, argc, objv); for (i = 0; i < argc; i++) { Tcl_DecrRefCount(objv[i]); } - TclStackFree(slaveInterp, objv); + TclStackFree(childInterp, objv); Tcl_DecrRefCount(targetObjPtr); - Tcl_DecrRefCount(slaveObjPtr); + Tcl_DecrRefCount(childObjPtr); return result; } /* @@ -1229,30 +1219,30 @@ *---------------------------------------------------------------------- */ int Tcl_CreateAliasObj( - Tcl_Interp *slaveInterp, /* Interpreter for source command. */ - const char *slaveCmd, /* Command to install in slave. */ + Tcl_Interp *childInterp, /* Interpreter for source command. */ + const char *childCmd, /* Command to install in child. */ Tcl_Interp *targetInterp, /* Interpreter for target command. */ const char *targetCmd, /* Name of target command. */ int objc, /* How many additional arguments? */ Tcl_Obj *const objv[]) /* Argument vector. */ { - Tcl_Obj *slaveObjPtr, *targetObjPtr; + Tcl_Obj *childObjPtr, *targetObjPtr; int result; - slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1); - Tcl_IncrRefCount(slaveObjPtr); + childObjPtr = Tcl_NewStringObj(childCmd, -1); + Tcl_IncrRefCount(childObjPtr); targetObjPtr = Tcl_NewStringObj(targetCmd, -1); Tcl_IncrRefCount(targetObjPtr); - result = AliasCreate(slaveInterp, slaveInterp, targetInterp, slaveObjPtr, + result = AliasCreate(childInterp, childInterp, targetInterp, childObjPtr, targetObjPtr, objc, objv); - Tcl_DecrRefCount(slaveObjPtr); + Tcl_DecrRefCount(childObjPtr); Tcl_DecrRefCount(targetObjPtr); return result; } /* @@ -1285,11 +1275,11 @@ Tcl_HashEntry *hPtr; Alias *aliasPtr; int i, objc; Tcl_Obj **objv; - hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); + hPtr = Tcl_FindHashEntry(&iiPtr->child.aliasTable, aliasName); if (hPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "alias \"%s\" not found", aliasName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL); return TCL_ERROR; @@ -1307,11 +1297,11 @@ if (argcPtr != NULL) { *argcPtr = objc - 1; } if (argvPtr != NULL) { *argvPtr = (const char **) - Tcl_Alloc(sizeof(const char *) * (objc - 1)); + ckalloc(sizeof(const char *) * (objc - 1)); for (i = 1; i < objc; i++) { (*argvPtr)[i - 1] = TclGetString(objv[i]); } } return TCL_OK; @@ -1347,11 +1337,11 @@ Tcl_HashEntry *hPtr; Alias *aliasPtr; int objc; Tcl_Obj **objv; - hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); + hPtr = Tcl_FindHashEntry(&iiPtr->child.aliasTable, aliasName); if (hPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "alias \"%s\" not found", aliasName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL); return TCL_ERROR; @@ -1412,12 +1402,11 @@ /* * If we are not creating or renaming an alias, then it is always OK to * create or rename the command. */ - if (cmdPtr->objProc != TclAliasObjCmd - && cmdPtr->objProc != TclLocalAliasObjCmd) { + if (cmdPtr->objProc != AliasObjCmd) { return TCL_OK; } /* * OK, we are dealing with an alias, so traverse the chain of aliases. If @@ -1435,11 +1424,11 @@ * source alias, we have a loop. */ if (Tcl_InterpDeleted(nextAliasPtr->targetInterp)) { /* - * The slave interpreter can be deleted while creating the alias. + * The child interpreter can be deleted while creating the alias. * [Bug #641195] */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "cannot define or rename alias \"%s\": interpreter deleted", @@ -1468,12 +1457,11 @@ * Otherwise, follow the chain one step further. See if the target * command is an alias - if so, follow the loop to its target command. * Otherwise we do not have a loop. */ - if (aliasCmdPtr->objProc != TclAliasObjCmd - && aliasCmdPtr->objProc != TclLocalAliasObjCmd) { + if (aliasCmdPtr->objProc != AliasObjCmd) { return TCL_OK; } nextAliasPtr = aliasCmdPtr->objClientData; } @@ -1490,39 +1478,39 @@ * Results: * A standard Tcl result. * * Side effects: * An alias command is created and entered into the alias table for the - * slave interpreter. + * child interpreter. * *---------------------------------------------------------------------- */ static int AliasCreate( Tcl_Interp *interp, /* Interp for error reporting. */ - Tcl_Interp *slaveInterp, /* Interp where alias cmd will live or from + Tcl_Interp *childInterp, /* Interp where alias cmd will live or from * which alias will be deleted. */ - Tcl_Interp *masterInterp, /* Interp in which target command will be + Tcl_Interp *parentInterp, /* Interp in which target command will be * invoked. */ Tcl_Obj *namePtr, /* Name of alias cmd. */ Tcl_Obj *targetNamePtr, /* Name of target cmd. */ int objc, /* Additional arguments to store */ Tcl_Obj *const objv[]) /* with alias. */ { Alias *aliasPtr; Tcl_HashEntry *hPtr; Target *targetPtr; - Slave *slavePtr; - Master *masterPtr; + Child *childPtr; + Parent *parentPtr; Tcl_Obj **prefv; int isNew, i; - aliasPtr = Tcl_Alloc(sizeof(Alias) + objc * sizeof(Tcl_Obj *)); + aliasPtr = ckalloc(sizeof(Alias) + objc * sizeof(Tcl_Obj *)); aliasPtr->token = namePtr; Tcl_IncrRefCount(aliasPtr->token); - aliasPtr->targetInterp = masterInterp; + aliasPtr->targetInterp = parentInterp; aliasPtr->objc = objc + 1; prefv = &aliasPtr->objPtr; *prefv = targetNamePtr; @@ -1530,25 +1518,25 @@ for (i = 0; i < objc; i++) { *(++prefv) = objv[i]; Tcl_IncrRefCount(objv[i]); } - Tcl_Preserve(slaveInterp); - Tcl_Preserve(masterInterp); - - if (slaveInterp == masterInterp) { - aliasPtr->slaveCmd = Tcl_NRCreateCommand(slaveInterp, - TclGetString(namePtr), TclLocalAliasObjCmd, AliasNRCmd, - aliasPtr, AliasObjCmdDeleteProc); - } else { - aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp, - TclGetString(namePtr), TclAliasObjCmd, aliasPtr, + Tcl_Preserve(childInterp); + Tcl_Preserve(parentInterp); + + if (childInterp == parentInterp) { + aliasPtr->childCmd = Tcl_NRCreateCommand(childInterp, + TclGetString(namePtr), AliasObjCmd, AliasNRCmd, aliasPtr, AliasObjCmdDeleteProc); + } else { + aliasPtr->childCmd = Tcl_CreateObjCommand(childInterp, + TclGetString(namePtr), AliasObjCmd, aliasPtr, + AliasObjCmdDeleteProc); } - if (TclPreventAliasLoop(interp, slaveInterp, - aliasPtr->slaveCmd) != TCL_OK) { + if (TclPreventAliasLoop(interp, childInterp, + aliasPtr->childCmd) != TCL_OK) { /* * Found an alias loop! The last call to Tcl_CreateObjCommand made the * alias point to itself. Delete the command and its alias record. Be * careful to wipe out its client data first, so the command doesn't * try to delete itself. @@ -1560,38 +1548,38 @@ Tcl_DecrRefCount(targetNamePtr); for (i = 0; i < objc; i++) { Tcl_DecrRefCount(objv[i]); } - cmdPtr = (Command *) aliasPtr->slaveCmd; + cmdPtr = (Command *) aliasPtr->childCmd; cmdPtr->clientData = NULL; cmdPtr->deleteProc = NULL; cmdPtr->deleteData = NULL; - Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd); + Tcl_DeleteCommandFromToken(childInterp, aliasPtr->childCmd); - Tcl_Free(aliasPtr); + ckfree(aliasPtr); /* * The result was already set by TclPreventAliasLoop. */ - Tcl_Release(slaveInterp); - Tcl_Release(masterInterp); + Tcl_Release(childInterp); + Tcl_Release(parentInterp); return TCL_ERROR; } /* * Make an entry in the alias table. If it already exists, retry. */ - slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; + childPtr = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->child; while (1) { Tcl_Obj *newToken; const char *string; string = TclGetString(aliasPtr->token); - hPtr = Tcl_CreateHashEntry(&slavePtr->aliasTable, string, &isNew); + hPtr = Tcl_CreateHashEntry(&childPtr->aliasTable, string, &isNew); if (isNew != 0) { break; } /* @@ -1623,73 +1611,73 @@ * interp alias {} foo {} bar # Create an alias "foo" * rename foo zop # Now rename the alias * interp alias {} foo {} zop # Now recreate "foo"... */ - targetPtr = Tcl_Alloc(sizeof(Target)); - targetPtr->slaveCmd = aliasPtr->slaveCmd; - targetPtr->slaveInterp = slaveInterp; + targetPtr = ckalloc(sizeof(Target)); + targetPtr->childCmd = aliasPtr->childCmd; + targetPtr->childInterp = childInterp; - masterPtr = &((InterpInfo*) ((Interp*) masterInterp)->interpInfo)->master; - targetPtr->nextPtr = masterPtr->targetsPtr; + parentPtr = &((InterpInfo*) ((Interp*) parentInterp)->interpInfo)->parent; + targetPtr->nextPtr = parentPtr->targetsPtr; targetPtr->prevPtr = NULL; - if (masterPtr->targetsPtr != NULL) { - masterPtr->targetsPtr->prevPtr = targetPtr; + if (parentPtr->targetsPtr != NULL) { + parentPtr->targetsPtr->prevPtr = targetPtr; } - masterPtr->targetsPtr = targetPtr; + parentPtr->targetsPtr = targetPtr; aliasPtr->targetPtr = targetPtr; Tcl_SetObjResult(interp, aliasPtr->token); - Tcl_Release(slaveInterp); - Tcl_Release(masterInterp); + Tcl_Release(childInterp); + Tcl_Release(parentInterp); return TCL_OK; } /* *---------------------------------------------------------------------- * * AliasDelete -- * - * Deletes the given alias from the slave interpreter given. + * Deletes the given alias from the child interpreter given. * * Results: * A standard Tcl result. * * Side effects: - * Deletes the alias from the slave interpreter. + * Deletes the alias from the child interpreter. * *---------------------------------------------------------------------- */ static int AliasDelete( Tcl_Interp *interp, /* Interpreter for result & errors. */ - Tcl_Interp *slaveInterp, /* Interpreter containing alias. */ + Tcl_Interp *childInterp, /* Interpreter containing alias. */ Tcl_Obj *namePtr) /* Name of alias to delete. */ { - Slave *slavePtr; + Child *childPtr; Alias *aliasPtr; Tcl_HashEntry *hPtr; /* - * If the alias has been renamed in the slave, the master can still use + * If the alias has been renamed in the child, the parent can still use * the original name (with which it was created) to find the alias to * delete it. */ - slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; - hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, TclGetString(namePtr)); + childPtr = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->child; + hPtr = Tcl_FindHashEntry(&childPtr->aliasTable, TclGetString(namePtr)); if (hPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "alias \"%s\" not found", TclGetString(namePtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", TclGetString(namePtr), NULL); return TCL_ERROR; } aliasPtr = Tcl_GetHashValue(hPtr); - Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd); + Tcl_DeleteCommandFromToken(childInterp, aliasPtr->childCmd); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -1710,26 +1698,26 @@ */ static int AliasDescribe( Tcl_Interp *interp, /* Interpreter for result & errors. */ - Tcl_Interp *slaveInterp, /* Interpreter containing alias. */ + Tcl_Interp *childInterp, /* Interpreter containing alias. */ Tcl_Obj *namePtr) /* Name of alias to describe. */ { - Slave *slavePtr; + Child *childPtr; Tcl_HashEntry *hPtr; Alias *aliasPtr; Tcl_Obj *prefixPtr; /* - * If the alias has been renamed in the slave, the master can still use + * If the alias has been renamed in the child, the parent can still use * the original name (with which it was created) to find the alias to * describe it. */ - slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; - hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, TclGetString(namePtr)); + childPtr = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->child; + hPtr = Tcl_FindHashEntry(&childPtr->aliasTable, Tcl_GetString(namePtr)); if (hPtr == NULL) { return TCL_OK; } aliasPtr = Tcl_GetHashValue(hPtr); prefixPtr = Tcl_NewListObj(aliasPtr->objc, &aliasPtr->objPtr); @@ -1740,11 +1728,11 @@ /* *---------------------------------------------------------------------- * * AliasList -- * - * Computes a list of aliases defined in a slave interpreter. + * Computes a list of aliases defined in a child interpreter. * * Results: * A standard Tcl result. * * Side effects: @@ -1754,21 +1742,21 @@ */ static int AliasList( Tcl_Interp *interp, /* Interp for data return. */ - Tcl_Interp *slaveInterp) /* Interp whose aliases to compute. */ + Tcl_Interp *childInterp) /* Interp whose aliases to compute. */ { Tcl_HashEntry *entryPtr; Tcl_HashSearch hashSearch; Tcl_Obj *resultPtr = Tcl_NewObj(); Alias *aliasPtr; - Slave *slavePtr; + Child *childPtr; - slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; + childPtr = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->child; - entryPtr = Tcl_FirstHashEntry(&slavePtr->aliasTable, &hashSearch); + entryPtr = Tcl_FirstHashEntry(&childPtr->aliasTable, &hashSearch); for ( ; entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&hashSearch)) { aliasPtr = Tcl_GetHashValue(entryPtr); Tcl_ListObjAppendElement(NULL, resultPtr, aliasPtr->token); } Tcl_SetObjResult(interp, resultPtr); @@ -1776,23 +1764,18 @@ } /* *---------------------------------------------------------------------- * - * TclAliasObjCmd, TclLocalAliasObjCmd -- + * AliasObjCmd -- * - * This is the function that services invocations of aliases in a slave + * This is the function that services invocations of aliases in a child * interpreter. One such command exists for each alias. When invoked, * this function redirects the invocation to the target command in the - * master interpreter as designated by the Alias record associated with + * parent interpreter as designated by the Alias record associated with * this command. * - * TclLocalAliasObjCmd is a stripped down version used when the source - * and target interpreters of the alias are the same. That lets a number - * of safety precautions be avoided: the state is much more precisely - * known. - * * Results: * A standard Tcl result. * * Side effects: * Causes forwarding of the invocation; all possible side effects may @@ -1824,17 +1807,17 @@ prefc = aliasPtr->objc; prefv = &aliasPtr->objPtr; cmdc = prefc + objc - 1; listPtr = Tcl_NewListObj(cmdc, NULL); - listRep = ListRepPtr(listPtr); + listRep = listPtr->internalRep.twoPtrValue.ptr1; listRep->elemCount = cmdc; cmdv = &listRep->elements; prefv = &aliasPtr->objPtr; - memcpy(cmdv, prefv, (prefc * sizeof(Tcl_Obj *))); - memcpy(cmdv+prefc, objv+1, ((objc-1) * sizeof(Tcl_Obj *))); + memcpy(cmdv, prefv, prefc * sizeof(Tcl_Obj *)); + memcpy(cmdv+prefc, objv+1, (objc-1) * sizeof(Tcl_Obj *)); for (i=0; iobjc; - prefv = &aliasPtr->objPtr; - cmdc = prefc + objc - 1; - if (cmdc <= ALIAS_CMDV_PREALLOC) { - cmdv = cmdArr; - } else { - cmdv = TclStackAlloc(interp, cmdc * sizeof(Tcl_Obj *)); - } - - memcpy(cmdv, prefv, prefc * sizeof(Tcl_Obj *)); - memcpy(cmdv+prefc, objv+1, (objc-1) * sizeof(Tcl_Obj *)); - - for (i=0; ialiasEntryPtr); /* - * Splice the target record out of the target interpreter's master list. + * Splice the target record out of the target interpreter's parent list. */ targetPtr = aliasPtr->targetPtr; if (targetPtr->prevPtr != NULL) { targetPtr->prevPtr->nextPtr = targetPtr->nextPtr; } else { - Master *masterPtr = &((InterpInfo *) ((Interp *) - aliasPtr->targetInterp)->interpInfo)->master; + Parent *parentPtr = &((InterpInfo *) ((Interp *) + aliasPtr->targetInterp)->interpInfo)->parent; - masterPtr->targetsPtr = targetPtr->nextPtr; + parentPtr->targetsPtr = targetPtr->nextPtr; } if (targetPtr->nextPtr != NULL) { targetPtr->nextPtr->prevPtr = targetPtr->prevPtr; } - Tcl_Free(targetPtr); - Tcl_Free(aliasPtr); + ckfree(targetPtr); + ckfree(aliasPtr); } /* *---------------------------------------------------------------------- * - * Tcl_CreateSlave -- + * Tcl_CreateChild -- * - * Creates a slave interpreter. The slavePath argument denotes the name - * of the new slave relative to the current interpreter; the slave is a + * Creates a child interpreter. The childPath argument denotes the name + * of the new child relative to the current interpreter; the child is a * direct descendant of the one-before-last component of the path, - * e.g. it is a descendant of the current interpreter if the slavePath - * argument contains only one component. Optionally makes the slave + * e.g. it is a descendant of the current interpreter if the childPath + * argument contains only one component. Optionally makes the child * interpreter safe. * * Results: * Returns the interpreter structure created, or NULL if an error * occurred. * * Side effects: * Creates a new interpreter and a new interpreter object command in the - * interpreter indicated by the slavePath argument. + * interpreter indicated by the childPath argument. * *---------------------------------------------------------------------- */ Tcl_Interp * -Tcl_CreateSlave( +Tcl_CreateChild( Tcl_Interp *interp, /* Interpreter to start search at. */ - const char *slavePath, /* Name of slave to create. */ - int isSafe) /* Should new slave be "safe" ? */ + const char *childPath, /* Name of child to create. */ + int isSafe) /* Should new child be "safe" ? */ { Tcl_Obj *pathPtr; - Tcl_Interp *slaveInterp; + Tcl_Interp *childInterp; - pathPtr = Tcl_NewStringObj(slavePath, -1); - slaveInterp = SlaveCreate(interp, pathPtr, isSafe); + pathPtr = Tcl_NewStringObj(childPath, -1); + childInterp = ChildCreate(interp, pathPtr, isSafe); Tcl_DecrRefCount(pathPtr); - return slaveInterp; + return childInterp; } /* *---------------------------------------------------------------------- * - * Tcl_GetSlave -- + * Tcl_GetChild -- * - * Finds a slave interpreter by its path name. + * Finds a child interpreter by its path name. * * Results: * Returns a Tcl_Interp * for the named interpreter or NULL if not found. * * Side effects: @@ -2117,59 +2033,59 @@ * *---------------------------------------------------------------------- */ Tcl_Interp * -Tcl_GetSlave( +Tcl_GetChild( Tcl_Interp *interp, /* Interpreter to start search from. */ - const char *slavePath) /* Path of slave to find. */ + const char *childPath) /* Path of child to find. */ { Tcl_Obj *pathPtr; - Tcl_Interp *slaveInterp; + Tcl_Interp *childInterp; - pathPtr = Tcl_NewStringObj(slavePath, -1); - slaveInterp = GetInterp(interp, pathPtr); + pathPtr = Tcl_NewStringObj(childPath, -1); + childInterp = GetInterp(interp, pathPtr); Tcl_DecrRefCount(pathPtr); - return slaveInterp; + return childInterp; } /* *---------------------------------------------------------------------- * - * Tcl_GetMaster -- + * Tcl_GetParent -- * - * Finds the master interpreter of a slave interpreter. + * Finds the parent interpreter of a child interpreter. * * Results: - * Returns a Tcl_Interp * for the master interpreter or NULL if none. + * Returns a Tcl_Interp * for the parent interpreter or NULL if none. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_Interp * -Tcl_GetMaster( - Tcl_Interp *interp) /* Get the master of this interpreter. */ +Tcl_GetParent( + Tcl_Interp *interp) /* Get the parent of this interpreter. */ { - Slave *slavePtr; /* Slave record of this interpreter. */ + Child *childPtr; /* Child record of this interpreter. */ if (interp == NULL) { return NULL; } - slavePtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->slave; - return slavePtr->masterInterp; + childPtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->child; + return childPtr->parentInterp; } /* *---------------------------------------------------------------------- * - * TclSetSlaveCancelFlags -- + * TclSetChildCancelFlags -- * - * This function marks all slave interpreters belonging to a given + * This function marks all child interpreters belonging to a given * interpreter as being canceled or not canceled, depending on the * provided flags. * * Results: * None. @@ -2179,37 +2095,37 @@ * *---------------------------------------------------------------------- */ void -TclSetSlaveCancelFlags( +TclSetChildCancelFlags( Tcl_Interp *interp, /* Set cancel flags of this interpreter. */ int flags, /* Collection of OR-ed bits that control * the cancellation of the script. Only * TCL_CANCEL_UNWIND is currently * supported. */ int force) /* Non-zero to ignore numLevels for the purpose * of resetting the cancellation flags. */ { - Master *masterPtr; /* Master record of given interpreter. */ + Parent *parentPtr; /* Parent record of given interpreter. */ Tcl_HashEntry *hPtr; /* Search element. */ Tcl_HashSearch hashSearch; /* Search variable. */ - Slave *slavePtr; /* Slave record of interpreter. */ + Child *childPtr; /* Child record of interpreter. */ Interp *iPtr; if (interp == NULL) { return; } flags &= (CANCELED | TCL_CANCEL_UNWIND); - masterPtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->master; + parentPtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->parent; - hPtr = Tcl_FirstHashEntry(&masterPtr->slaveTable, &hashSearch); + hPtr = Tcl_FirstHashEntry(&parentPtr->childTable, &hashSearch); for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) { - slavePtr = Tcl_GetHashValue(hPtr); - iPtr = (Interp *) slavePtr->slaveInterp; + childPtr = Tcl_GetHashValue(hPtr); + iPtr = (Interp *) childPtr->childInterp; if (iPtr == NULL) { continue; } @@ -2218,15 +2134,15 @@ } else { TclSetCancelFlags(iPtr, flags); } /* - * Now, recursively handle this for the slaves of this slave + * Now, recursively handle this for the children of this child * interpreter. */ - TclSetSlaveCancelFlags((Tcl_Interp *) iPtr, flags, force); + TclSetChildCancelFlags((Tcl_Interp *) iPtr, flags, force); } } /* *---------------------------------------------------------------------- @@ -2234,11 +2150,11 @@ * Tcl_GetInterpPath -- * * Sets the result of the asking interpreter to a proper Tcl list * containing the names of interpreters between the asking and target * interpreters. The target interpreter must be either the same as the - * asking interpreter or one of its slaves (including recursively). + * asking interpreter or one of its children (including recursively). * * Results: * TCL_OK if the target interpreter is the same as, or a descendant of, * the asking interpreter; TCL_ERROR else. This way one can distinguish * between the case where the asking and target interps are the same (an @@ -2252,41 +2168,41 @@ *---------------------------------------------------------------------- */ int Tcl_GetInterpPath( - Tcl_Interp *askingInterp, /* Interpreter to start search from. */ + Tcl_Interp *interp, /* Interpreter to start search from. */ Tcl_Interp *targetInterp) /* Interpreter to find. */ { InterpInfo *iiPtr; - if (targetInterp == askingInterp) { - Tcl_SetObjResult(askingInterp, Tcl_NewObj()); + if (targetInterp == interp) { + Tcl_SetObjResult(interp, Tcl_NewObj()); return TCL_OK; } if (targetInterp == NULL) { return TCL_ERROR; } iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo; - if (Tcl_GetInterpPath(askingInterp, iiPtr->slave.masterInterp) != TCL_OK){ + if (Tcl_GetInterpPath(interp, iiPtr->child.parentInterp) != TCL_OK){ return TCL_ERROR; } - Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(askingInterp), - Tcl_NewStringObj(Tcl_GetHashKey(&iiPtr->master.slaveTable, - iiPtr->slave.slaveEntryPtr), -1)); + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), + Tcl_NewStringObj(Tcl_GetHashKey(&iiPtr->parent.childTable, + iiPtr->child.childEntryPtr), -1)); return TCL_OK; } /* *---------------------------------------------------------------------- * * GetInterp -- * - * Helper function to find a slave interpreter given a pathname. + * Helper function to find a child interpreter given a pathname. * * Results: - * Returns the slave interpreter known by that name in the calling + * Returns the child interpreter known by that name in the calling * interpreter, or NULL if no interpreter known by that name exists. * * Side effects: * Assigns to the pointer variable passed in, if not NULL. * @@ -2298,31 +2214,31 @@ Tcl_Interp *interp, /* Interp. to start search from. */ Tcl_Obj *pathPtr) /* List object containing name of interp. to * be found. */ { Tcl_HashEntry *hPtr; /* Search element. */ - Slave *slavePtr; /* Interim slave record. */ + Child *childPtr; /* Interim child record. */ Tcl_Obj **objv; int objc, i; Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */ - InterpInfo *masterInfoPtr; + InterpInfo *parentInfoPtr; if (TclListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) { return NULL; } searchInterp = interp; for (i = 0; i < objc; i++) { - masterInfoPtr = (InterpInfo *) ((Interp *) searchInterp)->interpInfo; - hPtr = Tcl_FindHashEntry(&masterInfoPtr->master.slaveTable, + parentInfoPtr = (InterpInfo *) ((Interp *) searchInterp)->interpInfo; + hPtr = Tcl_FindHashEntry(&parentInfoPtr->parent.childTable, TclGetString(objv[i])); if (hPtr == NULL) { searchInterp = NULL; break; } - slavePtr = Tcl_GetHashValue(hPtr); - searchInterp = slavePtr->slaveInterp; + childPtr = Tcl_GetHashValue(hPtr); + searchInterp = childPtr->childInterp; if (searchInterp == NULL) { break; } } if (searchInterp == NULL) { @@ -2335,29 +2251,29 @@ } /* *---------------------------------------------------------------------- * - * SlaveBgerror -- + * ChildBgerror -- * * Helper function to set/query the background error handling command * prefix of an interp * * Results: * A standard Tcl result. * * Side effects: - * When (objc == 1), slaveInterp will be set to a new background handler + * When (objc == 1), childInterp will be set to a new background handler * of objv[0]. * *---------------------------------------------------------------------- */ static int -SlaveBgerror( +ChildBgerror( Tcl_Interp *interp, /* Interp for error return. */ - Tcl_Interp *slaveInterp, /* Interp in which limit is set/queried. */ + Tcl_Interp *childInterp, /* Interp in which limit is set/queried. */ int objc, /* Set or Query. */ Tcl_Obj *const objv[]) /* Argument strings. */ { if (objc) { int length; @@ -2368,158 +2284,158 @@ "cmdPrefix must be list of length >= 1", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BGERRORFORMAT", NULL); return TCL_ERROR; } - TclSetBgErrorHandler(slaveInterp, objv[0]); + TclSetBgErrorHandler(childInterp, objv[0]); } - Tcl_SetObjResult(interp, TclGetBgErrorHandler(slaveInterp)); + Tcl_SetObjResult(interp, TclGetBgErrorHandler(childInterp)); return TCL_OK; } /* *---------------------------------------------------------------------- * - * SlaveCreate -- + * ChildCreate -- * - * Helper function to do the actual work of creating a slave interp and - * new object command. Also optionally makes the new slave interpreter + * Helper function to do the actual work of creating a child interp and + * new object command. Also optionally makes the new child interpreter * "safe". * * Results: * Returns the new Tcl_Interp * if successful or NULL if not. If failed, * the result of the invoking interpreter contains an error message. * * Side effects: - * Creates a new slave interpreter and a new object command. + * Creates a new child interpreter and a new object command. * *---------------------------------------------------------------------- */ static Tcl_Interp * -SlaveCreate( +ChildCreate( Tcl_Interp *interp, /* Interp. to start search from. */ - Tcl_Obj *pathPtr, /* Path (name) of slave to create. */ + Tcl_Obj *pathPtr, /* Path (name) of child to create. */ int safe) /* Should we make it "safe"? */ { - Tcl_Interp *masterInterp, *slaveInterp; - Slave *slavePtr; - InterpInfo *masterInfoPtr; + Tcl_Interp *parentInterp, *childInterp; + Child *childPtr; + InterpInfo *parentInfoPtr; Tcl_HashEntry *hPtr; const char *path; int isNew, objc; Tcl_Obj **objv; if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) { return NULL; } if (objc < 2) { - masterInterp = interp; + parentInterp = interp; path = TclGetString(pathPtr); } else { Tcl_Obj *objPtr; objPtr = Tcl_NewListObj(objc - 1, objv); - masterInterp = GetInterp(interp, objPtr); + parentInterp = GetInterp(interp, objPtr); Tcl_DecrRefCount(objPtr); - if (masterInterp == NULL) { + if (parentInterp == NULL) { return NULL; } path = TclGetString(objv[objc - 1]); } if (safe == 0) { - safe = Tcl_IsSafe(masterInterp); + safe = Tcl_IsSafe(parentInterp); } - masterInfoPtr = (InterpInfo *) ((Interp *) masterInterp)->interpInfo; - hPtr = Tcl_CreateHashEntry(&masterInfoPtr->master.slaveTable, path, + parentInfoPtr = (InterpInfo *) ((Interp *) parentInterp)->interpInfo; + hPtr = Tcl_CreateHashEntry(&parentInfoPtr->parent.childTable, path, &isNew); if (isNew == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "interpreter named \"%s\" already exists, cannot create", path)); return NULL; } - slaveInterp = Tcl_CreateInterp(); - slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; - slavePtr->masterInterp = masterInterp; - slavePtr->slaveEntryPtr = hPtr; - slavePtr->slaveInterp = slaveInterp; - slavePtr->interpCmd = Tcl_NRCreateCommand(masterInterp, path, - TclSlaveObjCmd, NRSlaveCmd, slaveInterp, SlaveObjCmdDeleteProc); - Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); - Tcl_SetHashValue(hPtr, slavePtr); - Tcl_SetVar2(slaveInterp, "tcl_interactive", NULL, "0", TCL_GLOBAL_ONLY); + childInterp = Tcl_CreateInterp(); + childPtr = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->child; + childPtr->parentInterp = parentInterp; + childPtr->childEntryPtr = hPtr; + childPtr->childInterp = childInterp; + childPtr->interpCmd = Tcl_NRCreateCommand(parentInterp, path, + ChildObjCmd, NRChildCmd, childInterp, ChildObjCmdDeleteProc); + Tcl_InitHashTable(&childPtr->aliasTable, TCL_STRING_KEYS); + Tcl_SetHashValue(hPtr, childPtr); + Tcl_SetVar(childInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); /* * Inherit the recursion limit. */ - ((Interp *) slaveInterp)->maxNestingDepth = - ((Interp *) masterInterp)->maxNestingDepth; + ((Interp *) childInterp)->maxNestingDepth = + ((Interp *) parentInterp)->maxNestingDepth; if (safe) { - if (Tcl_MakeSafe(slaveInterp) == TCL_ERROR) { + if (Tcl_MakeSafe(childInterp) == TCL_ERROR) { goto error; } } else { - if (Tcl_Init(slaveInterp) == TCL_ERROR) { + if (Tcl_Init(childInterp) == TCL_ERROR) { goto error; } /* - * This will create the "memory" command in slave interpreters if we + * This will create the "memory" command in child interpreters if we * compiled with TCL_MEM_DEBUG, otherwise it does nothing. */ - Tcl_InitMemory(slaveInterp); + Tcl_InitMemory(childInterp); } /* * Inherit the TIP#143 limits. */ - InheritLimitsFromMaster(slaveInterp, masterInterp); + InheritLimitsFromParent(childInterp, parentInterp); /* * The [clock] command presents a safe API, but uses unsafe features in * its implementation. This means it has to be implemented in safe interps - * as an alias to a version in the (trusted) master. + * as an alias to a version in the (trusted) parent. */ if (safe) { Tcl_Obj *clockObj; int status; TclNewLiteralStringObj(clockObj, "clock"); Tcl_IncrRefCount(clockObj); - status = AliasCreate(interp, slaveInterp, masterInterp, clockObj, + status = AliasCreate(interp, childInterp, parentInterp, clockObj, clockObj, 0, NULL); Tcl_DecrRefCount(clockObj); if (status != TCL_OK) { goto error2; } } - return slaveInterp; + return childInterp; error: - Tcl_TransferResult(slaveInterp, TCL_ERROR, interp); + Tcl_TransferResult(childInterp, TCL_ERROR, interp); error2: - Tcl_DeleteInterp(slaveInterp); + Tcl_DeleteInterp(childInterp); return NULL; } /* *---------------------------------------------------------------------- * - * TclSlaveObjCmd -- + * ChildObjCmd -- * * Command to manipulate an interpreter, e.g. to send commands to it to - * be evaluated. One such command exists for each slave interpreter. + * be evaluated. One such command exists for each child interpreter. * * Results: * A standard Tcl result. * * Side effects: @@ -2526,28 +2442,28 @@ * See user documentation for details. * *---------------------------------------------------------------------- */ -int -TclSlaveObjCmd( - ClientData clientData, /* Slave interpreter. */ +static int +ChildObjCmd( + ClientData clientData, /* Child interpreter. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - return Tcl_NRCallObjProc(interp, NRSlaveCmd, clientData, objc, objv); + return Tcl_NRCallObjProc(interp, NRChildCmd, clientData, objc, objv); } static int -NRSlaveCmd( - ClientData clientData, /* Slave interpreter. */ +NRChildCmd( + ClientData clientData, /* Child interpreter. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Interp *slaveInterp = clientData; + Tcl_Interp *childInterp = clientData; int index; static const char *const options[] = { "alias", "aliases", "bgerror", "debug", "eval", "expose", "hide", "hidden", "issafe", "invokehidden", "limit", "marktrusted", @@ -2558,12 +2474,12 @@ OPT_EVAL, OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHIDDEN, OPT_LIMIT, OPT_MARKTRUSTED, OPT_RECLIMIT }; - if (slaveInterp == NULL) { - Tcl_Panic("TclSlaveObjCmd: interpreter has been deleted"); + if (childInterp == NULL) { + Tcl_Panic("ChildObjCmd: interpreter has been deleted"); } if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?"); return TCL_ERROR; @@ -2575,18 +2491,18 @@ switch ((enum options) index) { case OPT_ALIAS: if (objc > 2) { if (objc == 3) { - return AliasDescribe(interp, slaveInterp, objv[2]); + return AliasDescribe(interp, childInterp, objv[2]); } if (TclGetString(objv[3])[0] == '\0') { if (objc == 4) { - return AliasDelete(interp, slaveInterp, objv[2]); + return AliasDelete(interp, childInterp, objv[2]); } } else { - return AliasCreate(interp, slaveInterp, interp, objv[2], + return AliasCreate(interp, childInterp, interp, objv[2], objv[3], objc - 4, objv + 4); } } Tcl_WrongNumArgs(interp, 2, objv, "aliasName ?targetName? ?arg ...?"); return TCL_ERROR; @@ -2593,57 +2509,57 @@ case OPT_ALIASES: if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } - return AliasList(interp, slaveInterp); + return AliasList(interp, childInterp); case OPT_BGERROR: if (objc != 2 && objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "?cmdPrefix?"); return TCL_ERROR; } - return SlaveBgerror(interp, slaveInterp, objc - 2, objv + 2); + return ChildBgerror(interp, childInterp, objc - 2, objv + 2); case OPT_DEBUG: /* * TIP #378 * Currently only -frame supported, otherwise ?-option ?value? ...? */ if (objc > 4) { Tcl_WrongNumArgs(interp, 2, objv, "?-frame ?bool??"); return TCL_ERROR; } - return SlaveDebugCmd(interp, slaveInterp, objc - 2, objv + 2); + return ChildDebugCmd(interp, childInterp, objc - 2, objv + 2); case OPT_EVAL: if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?"); return TCL_ERROR; } - return SlaveEval(interp, slaveInterp, objc - 2, objv + 2); + return ChildEval(interp, childInterp, objc - 2, objv + 2); case OPT_EXPOSE: if ((objc < 3) || (objc > 4)) { Tcl_WrongNumArgs(interp, 2, objv, "hiddenCmdName ?cmdName?"); return TCL_ERROR; } - return SlaveExpose(interp, slaveInterp, objc - 2, objv + 2); + return ChildExpose(interp, childInterp, objc - 2, objv + 2); case OPT_HIDE: if ((objc < 3) || (objc > 4)) { Tcl_WrongNumArgs(interp, 2, objv, "cmdName ?hiddenCmdName?"); return TCL_ERROR; } - return SlaveHide(interp, slaveInterp, objc - 2, objv + 2); + return ChildHide(interp, childInterp, objc - 2, objv + 2); case OPT_HIDDEN: if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } - return SlaveHidden(interp, slaveInterp); + return ChildHidden(interp, childInterp); case OPT_ISSAFE: if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp))); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(childInterp))); return TCL_OK; case OPT_INVOKEHIDDEN: { int i; const char *namespaceName; static const char *const hiddenOptions[] = { @@ -2678,11 +2594,11 @@ if (objc - i < 1) { Tcl_WrongNumArgs(interp, 2, objv, "?-namespace ns? ?-global? ?--? cmd ?arg ..?"); return TCL_ERROR; } - return SlaveInvokeHidden(interp, slaveInterp, namespaceName, + return ChildInvokeHidden(interp, childInterp, namespaceName, objc - i, objv + i); } case OPT_LIMIT: { static const char *const limitTypes[] = { "commands", "time", NULL @@ -2700,100 +2616,101 @@ &limitType) != TCL_OK) { return TCL_ERROR; } switch ((enum LimitTypes) limitType) { case LIMIT_TYPE_COMMANDS: - return SlaveCommandLimitCmd(interp, slaveInterp, 3, objc,objv); + return ChildCommandLimitCmd(interp, childInterp, 3, objc,objv); case LIMIT_TYPE_TIME: - return SlaveTimeLimitCmd(interp, slaveInterp, 3, objc, objv); + return ChildTimeLimitCmd(interp, childInterp, 3, objc, objv); } } + break; case OPT_MARKTRUSTED: if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } - return SlaveMarkTrusted(interp, slaveInterp); + return ChildMarkTrusted(interp, childInterp); case OPT_RECLIMIT: if (objc != 2 && objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "?newlimit?"); return TCL_ERROR; } - return SlaveRecursionLimit(interp, slaveInterp, objc - 2, objv + 2); + return ChildRecursionLimit(interp, childInterp, objc - 2, objv + 2); } return TCL_ERROR; } /* *---------------------------------------------------------------------- * - * SlaveObjCmdDeleteProc -- + * ChildObjCmdDeleteProc -- * - * Invoked when an object command for a slave interpreter is deleted; - * cleans up all state associated with the slave interpreter and destroys - * the slave interpreter. + * Invoked when an object command for a child interpreter is deleted; + * cleans up all state associated with the child interpreter and destroys + * the child interpreter. * * Results: * None. * * Side effects: - * Cleans up all state associated with the slave interpreter and destroys - * the slave interpreter. + * Cleans up all state associated with the child interpreter and destroys + * the child interpreter. * *---------------------------------------------------------------------- */ static void -SlaveObjCmdDeleteProc( - ClientData clientData) /* The SlaveRecord for the command. */ -{ - Slave *slavePtr; /* Interim storage for Slave record. */ - Tcl_Interp *slaveInterp = clientData; - /* And for a slave interp. */ - - slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; +ChildObjCmdDeleteProc( + ClientData clientData) /* The ChildRecord for the command. */ +{ + Child *childPtr; /* Interim storage for Child record. */ + Tcl_Interp *childInterp = clientData; + /* And for a child interp. */ + + childPtr = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->child; /* - * Unlink the slave from its master interpreter. + * Unlink the child from its parent interpreter. */ - Tcl_DeleteHashEntry(slavePtr->slaveEntryPtr); + Tcl_DeleteHashEntry(childPtr->childEntryPtr); /* - * Set to NULL so that when the InterpInfo is cleaned up in the slave it + * Set to NULL so that when the InterpInfo is cleaned up in the child it * does not try to delete the command causing all sorts of grief. See - * SlaveRecordDeleteProc(). + * ChildRecordDeleteProc(). */ - slavePtr->interpCmd = NULL; + childPtr->interpCmd = NULL; - if (slavePtr->slaveInterp != NULL) { - Tcl_DeleteInterp(slavePtr->slaveInterp); + if (childPtr->childInterp != NULL) { + Tcl_DeleteInterp(childPtr->childInterp); } } /* *---------------------------------------------------------------------- * - * SlaveDebugCmd -- TIP #378 + * ChildDebugCmd -- TIP #378 * - * Helper function to handle 'debug' command in a slave interpreter. + * Helper function to handle 'debug' command in a child interpreter. * * Results: * A standard Tcl result. * * Side effects: - * May modify INTERP_DEBUG_FRAME flag in the slave. + * May modify INTERP_DEBUG_FRAME flag in the child. * *---------------------------------------------------------------------- */ static int -SlaveDebugCmd( +ChildDebugCmd( Tcl_Interp *interp, /* Interp for error return. */ - Tcl_Interp *slaveInterp, /* The slave interpreter in which command + Tcl_Interp *childInterp, /* The child interpreter in which command * will be evaluated. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { static const char *const debugTypes[] = { @@ -2804,11 +2721,11 @@ }; int debugType; Interp *iPtr; Tcl_Obj *resultPtr; - iPtr = (Interp *) slaveInterp; + iPtr = (Interp *) childInterp; if (objc == 0) { resultPtr = Tcl_NewObj(); Tcl_ListObjAppendElement(NULL, resultPtr, Tcl_NewStringObj("-frame", -1)); Tcl_ListObjAppendElement(NULL, resultPtr, @@ -2844,13 +2761,13 @@ } /* *---------------------------------------------------------------------- * - * SlaveEval -- + * ChildEval -- * - * Helper function to evaluate a command in a slave interpreter. + * Helper function to evaluate a command in a child interpreter. * * Results: * A standard Tcl result. * * Side effects: @@ -2858,31 +2775,31 @@ * *---------------------------------------------------------------------- */ static int -SlaveEval( +ChildEval( Tcl_Interp *interp, /* Interp for error return. */ - Tcl_Interp *slaveInterp, /* The slave interpreter in which command + Tcl_Interp *childInterp, /* The child interpreter in which command * will be evaluated. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int result; /* - * TIP #285: If necessary, reset the cancellation flags for the slave - * interpreter now; otherwise, canceling a script in a master interpreter - * can result in a situation where a slave interpreter can no longer + * TIP #285: If necessary, reset the cancellation flags for the child + * interpreter now; otherwise, canceling a script in a parent interpreter + * can result in a situation where a child interpreter can no longer * evaluate any scripts unless somebody calls the TclResetCancellation * function for that particular Tcl_Interp. */ - TclSetSlaveCancelFlags(slaveInterp, 0, 0); + TclSetChildCancelFlags(childInterp, 0, 0); - Tcl_Preserve(slaveInterp); - Tcl_AllowExceptions(slaveInterp); + Tcl_Preserve(childInterp); + Tcl_AllowExceptions(childInterp); if (objc == 1) { /* * TIP #280: Make actual argument location available to eval'd script. */ @@ -2891,44 +2808,44 @@ CmdFrame *invoker = iPtr->cmdFramePtr; int word = 0; TclArgumentGet(interp, objv[0], &invoker, &word); - result = TclEvalObjEx(slaveInterp, objv[0], 0, invoker, word); + result = TclEvalObjEx(childInterp, objv[0], 0, invoker, word); } else { Tcl_Obj *objPtr = Tcl_ConcatObj(objc, objv); Tcl_IncrRefCount(objPtr); - result = Tcl_EvalObjEx(slaveInterp, objPtr, 0); + result = Tcl_EvalObjEx(childInterp, objPtr, 0); Tcl_DecrRefCount(objPtr); } - Tcl_TransferResult(slaveInterp, result, interp); + Tcl_TransferResult(childInterp, result, interp); - Tcl_Release(slaveInterp); + Tcl_Release(childInterp); return result; } /* *---------------------------------------------------------------------- * - * SlaveExpose -- + * ChildExpose -- * - * Helper function to expose a command in a slave interpreter. + * Helper function to expose a command in a child interpreter. * * Results: * A standard Tcl result. * * Side effects: - * After this call scripts in the slave will be able to invoke the newly + * After this call scripts in the child will be able to invoke the newly * exposed command. * *---------------------------------------------------------------------- */ static int -SlaveExpose( +ChildExpose( Tcl_Interp *interp, /* Interp for error return. */ - Tcl_Interp *slaveInterp, /* Interp in which command will be exposed. */ + Tcl_Interp *childInterp, /* Interp in which command will be exposed. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument strings. */ { const char *name; @@ -2940,39 +2857,39 @@ NULL); return TCL_ERROR; } name = TclGetString(objv[(objc == 1) ? 0 : 1]); - if (Tcl_ExposeCommand(slaveInterp, TclGetString(objv[0]), + if (Tcl_ExposeCommand(childInterp, TclGetString(objv[0]), name) != TCL_OK) { - Tcl_TransferResult(slaveInterp, TCL_ERROR, interp); + Tcl_TransferResult(childInterp, TCL_ERROR, interp); return TCL_ERROR; } return TCL_OK; } /* *---------------------------------------------------------------------- * - * SlaveRecursionLimit -- + * ChildRecursionLimit -- * * Helper function to set/query the Recursion limit of an interp * * Results: * A standard Tcl result. * * Side effects: - * When (objc == 1), slaveInterp will be set to a new recursion limit of + * When (objc == 1), childInterp will be set to a new recursion limit of * objv[0]. * *---------------------------------------------------------------------- */ static int -SlaveRecursionLimit( +ChildRecursionLimit( Tcl_Interp *interp, /* Interp for error return. */ - Tcl_Interp *slaveInterp, /* Interp in which limit is set/queried. */ + Tcl_Interp *childInterp, /* Interp in which limit is set/queried. */ int objc, /* Set or Query. */ Tcl_Obj *const objv[]) /* Argument strings. */ { Interp *iPtr; int limit; @@ -2993,48 +2910,48 @@ "recursion limit must be > 0", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADLIMIT", NULL); return TCL_ERROR; } - Tcl_SetRecursionLimit(slaveInterp, limit); - iPtr = (Interp *) slaveInterp; - if (interp == slaveInterp && iPtr->numLevels > limit) { + Tcl_SetRecursionLimit(childInterp, limit); + iPtr = (Interp *) childInterp; + if (interp == childInterp && iPtr->numLevels > limit) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "falling back due to new recursion limit", -1)); Tcl_SetErrorCode(interp, "TCL", "RECURSION", NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, objv[0]); return TCL_OK; } else { - limit = Tcl_SetRecursionLimit(slaveInterp, 0); - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(limit)); + limit = Tcl_SetRecursionLimit(childInterp, 0); + Tcl_SetObjResult(interp, Tcl_NewIntObj(limit)); return TCL_OK; } } /* *---------------------------------------------------------------------- * - * SlaveHide -- + * ChildHide -- * - * Helper function to hide a command in a slave interpreter. + * Helper function to hide a command in a child interpreter. * * Results: * A standard Tcl result. * * Side effects: - * After this call scripts in the slave will no longer be able to invoke + * After this call scripts in the child will no longer be able to invoke * the named command. * *---------------------------------------------------------------------- */ static int -SlaveHide( +ChildHide( Tcl_Interp *interp, /* Interp for error return. */ - Tcl_Interp *slaveInterp, /* Interp in which command will be exposed. */ + Tcl_Interp *childInterp, /* Interp in which command will be exposed. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument strings. */ { const char *name; @@ -3046,23 +2963,23 @@ NULL); return TCL_ERROR; } name = TclGetString(objv[(objc == 1) ? 0 : 1]); - if (Tcl_HideCommand(slaveInterp, TclGetString(objv[0]), name) != TCL_OK) { - Tcl_TransferResult(slaveInterp, TCL_ERROR, interp); + if (Tcl_HideCommand(childInterp, TclGetString(objv[0]), name) != TCL_OK) { + Tcl_TransferResult(childInterp, TCL_ERROR, interp); return TCL_ERROR; } return TCL_OK; } /* *---------------------------------------------------------------------- * - * SlaveHidden -- + * ChildHidden -- * - * Helper function to compute list of hidden commands in a slave + * Helper function to compute list of hidden commands in a child * interpreter. * * Results: * A standard Tcl result. * @@ -3071,20 +2988,20 @@ * *---------------------------------------------------------------------- */ static int -SlaveHidden( +ChildHidden( Tcl_Interp *interp, /* Interp for data return. */ - Tcl_Interp *slaveInterp) /* Interp whose hidden commands to query. */ + Tcl_Interp *childInterp) /* Interp whose hidden commands to query. */ { Tcl_Obj *listObjPtr = Tcl_NewObj(); /* Local object pointer. */ Tcl_HashTable *hTblPtr; /* For local searches. */ Tcl_HashEntry *hPtr; /* For local searches. */ Tcl_HashSearch hSearch; /* For local searches. */ - hTblPtr = ((Interp *) slaveInterp)->hiddenCmdTablePtr; + hTblPtr = ((Interp *) childInterp)->hiddenCmdTablePtr; if (hTblPtr != NULL) { for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { Tcl_ListObjAppendElement(NULL, listObjPtr, @@ -3096,13 +3013,13 @@ } /* *---------------------------------------------------------------------- * - * SlaveInvokeHidden -- + * ChildInvokeHidden -- * - * Helper function to invoke a hidden command in a slave interpreter. + * Helper function to invoke a hidden command in a child interpreter. * * Results: * A standard Tcl result. * * Side effects: @@ -3110,13 +3027,13 @@ * *---------------------------------------------------------------------- */ static int -SlaveInvokeHidden( +ChildInvokeHidden( Tcl_Interp *interp, /* Interp for error return. */ - Tcl_Interp *slaveInterp, /* The slave interpreter in which command will + Tcl_Interp *childInterp, /* The child interpreter in which command will * be invoked. */ const char *namespaceName, /* The namespace to use, if any. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { @@ -3129,76 +3046,76 @@ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE", NULL); return TCL_ERROR; } - Tcl_Preserve(slaveInterp); - Tcl_AllowExceptions(slaveInterp); + Tcl_Preserve(childInterp); + Tcl_AllowExceptions(childInterp); if (namespaceName == NULL) { - NRE_callback *rootPtr = TOP_CB(slaveInterp); + NRE_callback *rootPtr = TOP_CB(childInterp); - Tcl_NRAddCallback(interp, NRPostInvokeHidden, slaveInterp, + Tcl_NRAddCallback(interp, NRPostInvokeHidden, childInterp, rootPtr, NULL, NULL); - return TclNRInvoke(NULL, slaveInterp, objc, objv); + return TclNRInvoke(NULL, childInterp, objc, objv); } else { Namespace *nsPtr, *dummy1, *dummy2; const char *tail; - result = TclGetNamespaceForQualName(slaveInterp, namespaceName, NULL, + result = TclGetNamespaceForQualName(childInterp, namespaceName, NULL, TCL_FIND_ONLY_NS | TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG | TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); if (result == TCL_OK) { - result = TclObjInvokeNamespace(slaveInterp, objc, objv, + result = TclObjInvokeNamespace(childInterp, objc, objv, (Tcl_Namespace *) nsPtr, TCL_INVOKE_HIDDEN); } } - Tcl_TransferResult(slaveInterp, result, interp); + Tcl_TransferResult(childInterp, result, interp); - Tcl_Release(slaveInterp); + Tcl_Release(childInterp); return result; } static int NRPostInvokeHidden( ClientData data[], Tcl_Interp *interp, int result) { - Tcl_Interp *slaveInterp = (Tcl_Interp *)data[0]; + Tcl_Interp *childInterp = (Tcl_Interp *)data[0]; NRE_callback *rootPtr = (NRE_callback *)data[1]; - if (interp != slaveInterp) { - result = TclNRRunCallbacks(slaveInterp, result, rootPtr); - Tcl_TransferResult(slaveInterp, result, interp); + if (interp != childInterp) { + result = TclNRRunCallbacks(childInterp, result, rootPtr); + Tcl_TransferResult(childInterp, result, interp); } - Tcl_Release(slaveInterp); + Tcl_Release(childInterp); return result; } /* *---------------------------------------------------------------------- * - * SlaveMarkTrusted -- + * ChildMarkTrusted -- * - * Helper function to mark a slave interpreter as trusted (unsafe). + * Helper function to mark a child interpreter as trusted (unsafe). * * Results: * A standard Tcl result. * * Side effects: * After this call the hard-wired security checks in the core no longer - * prevent the slave from performing certain operations. + * prevent the child from performing certain operations. * *---------------------------------------------------------------------- */ static int -SlaveMarkTrusted( +ChildMarkTrusted( Tcl_Interp *interp, /* Interp for error return. */ - Tcl_Interp *slaveInterp) /* The slave interpreter which will be marked + Tcl_Interp *childInterp) /* The child interpreter which will be marked * trusted. */ { if (Tcl_IsSafe(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "permission denied: safe interpreter cannot mark trusted", @@ -3205,11 +3122,11 @@ -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE", NULL); return TCL_ERROR; } - ((Interp *) slaveInterp)->flags &= ~SAFE_INTERP; + ((Interp *) childInterp)->flags &= ~SAFE_INTERP; return TCL_OK; } /* *---------------------------------------------------------------------- @@ -3262,24 +3179,28 @@ Tcl_MakeSafe( Tcl_Interp *interp) /* Interpreter to be made safe. */ { Tcl_Channel chan; /* Channel to remove from safe interpreter. */ Interp *iPtr = (Interp *) interp; - Tcl_Interp *master = ((InterpInfo*) iPtr->interpInfo)->slave.masterInterp; + Tcl_Interp *parent = ((InterpInfo*) iPtr->interpInfo)->child.parentInterp; TclHideUnsafeCommands(interp); - if (master != NULL) { + if (parent != NULL) { /* - * Alias these function implementations in the slave to those in the - * master; the overall implementations are safe, but they're normally + * Alias these function implementations in the child to those in the + * parent; the overall implementations are safe, but they're normally * defined by init.tcl which is not sourced by safe interpreters. * Assume these functions all work. [Bug 2895741] */ - (void) Tcl_EvalEx(interp, - "namespace eval ::tcl {namespace eval mathfunc {}}", -1, 0); + (void) Tcl_Eval(interp, + "namespace eval ::tcl {namespace eval mathfunc {}}"); + (void) Tcl_CreateAlias(interp, "::tcl::mathfunc::min", parent, + "::tcl::mathfunc::min", 0, NULL); + (void) Tcl_CreateAlias(interp, "::tcl::mathfunc::max", parent, + "::tcl::mathfunc::max", 0, NULL); } iPtr->flags |= SAFE_INTERP; /* @@ -3286,11 +3207,11 @@ * Unsetting variables : (which should not have been set in the first * place, but...) */ /* - * No env array in a safe slave. + * No env array in a safe interpreter. */ Tcl_UnsetVar(interp, "env", TCL_GLOBAL_ONLY); /* @@ -3558,11 +3479,11 @@ if (handlerPtr->flags & LIMIT_HANDLER_DELETED) { if (handlerPtr->deleteProc != NULL) { handlerPtr->deleteProc(handlerPtr->clientData); } - Tcl_Free(handlerPtr); + ckfree(handlerPtr); } } } /* @@ -3595,18 +3516,21 @@ /* * Convert everything into a real deletion callback. */ if (deleteProc == (Tcl_LimitHandlerDeleteProc *) TCL_DYNAMIC) { - deleteProc = (Tcl_LimitHandlerDeleteProc *) TclpFree; + deleteProc = (Tcl_LimitHandlerDeleteProc *) Tcl_Free; + } + if (deleteProc == (Tcl_LimitHandlerDeleteProc *) TCL_STATIC) { + deleteProc = NULL; } /* * Allocate a handler record. */ - handlerPtr = Tcl_Alloc(sizeof(LimitHandler)); + handlerPtr = ckalloc(sizeof(LimitHandler)); handlerPtr->flags = 0; handlerPtr->handlerProc = handlerProc; handlerPtr->clientData = clientData; handlerPtr->deleteProc = deleteProc; handlerPtr->prevPtr = NULL; @@ -3721,11 +3645,11 @@ if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) { if (handlerPtr->deleteProc != NULL) { handlerPtr->deleteProc(handlerPtr->clientData); } - Tcl_Free(handlerPtr); + ckfree(handlerPtr); } return; } } @@ -3781,11 +3705,11 @@ if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) { if (handlerPtr->deleteProc != NULL) { handlerPtr->deleteProc(handlerPtr->clientData); } - Tcl_Free(handlerPtr); + ckfree(handlerPtr); } } /* * Delete all time-limit handlers. @@ -3814,11 +3738,11 @@ if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) { if (handlerPtr->deleteProc != NULL) { handlerPtr->deleteProc(handlerPtr->clientData); } - Tcl_Free(handlerPtr); + ckfree(handlerPtr); } } /* * Delete the timer callback that is used to trap limits that occur in @@ -4187,11 +4111,11 @@ *---------------------------------------------------------------------- * * DeleteScriptLimitCallback -- * * Callback for when a script limit (a limit callback implemented as a - * Tcl script in a master interpreter, as set up from Tcl) is deleted. + * Tcl script in a parent interpreter, as set up from Tcl) is deleted. * * Results: * None. * * Side effects: @@ -4209,11 +4133,11 @@ Tcl_DecrRefCount(limitCBPtr->scriptObj); if (limitCBPtr->entryPtr != NULL) { Tcl_DeleteHashEntry(limitCBPtr->entryPtr); } - Tcl_Free(limitCBPtr); + ckfree(limitCBPtr); } /* *---------------------------------------------------------------------- * @@ -4309,11 +4233,11 @@ limitCBPtr->entryPtr = NULL; Tcl_LimitRemoveHandler(targetInterp, type, CallScriptLimitCallback, limitCBPtr); } - limitCBPtr = Tcl_Alloc(sizeof(ScriptLimitCallback)); + limitCBPtr = ckalloc(sizeof(ScriptLimitCallback)); limitCBPtr->interp = interp; limitCBPtr->scriptObj = scriptObj; limitCBPtr->entryPtr = hashPtr; limitCBPtr->type = type; Tcl_IncrRefCount(scriptObj); @@ -4400,52 +4324,52 @@ } /* *---------------------------------------------------------------------- * - * InheritLimitsFromMaster -- + * InheritLimitsFromParent -- * - * Derive the interpreter limit configuration for a slave interpreter - * from the limit config for the master. + * Derive the interpreter limit configuration for a child interpreter + * from the limit config for the parent. * * Results: * None. * * Side effects: - * The slave interpreter limits are set so that if the master has a - * limit, it may not exceed it by handing off work to slave interpreters. - * Note that this does not transfer limit callbacks from the master to - * the slave. + * The child interpreter limits are set so that if the parent has a + * limit, it may not exceed it by handing off work to child interpreters. + * Note that this does not transfer limit callbacks from the parent to + * the child. * *---------------------------------------------------------------------- */ static void -InheritLimitsFromMaster( - Tcl_Interp *slaveInterp, - Tcl_Interp *masterInterp) -{ - Interp *slavePtr = (Interp *) slaveInterp; - Interp *masterPtr = (Interp *) masterInterp; - - if (masterPtr->limit.active & TCL_LIMIT_COMMANDS) { - slavePtr->limit.active |= TCL_LIMIT_COMMANDS; - slavePtr->limit.cmdCount = 0; - slavePtr->limit.cmdGranularity = masterPtr->limit.cmdGranularity; - } - if (masterPtr->limit.active & TCL_LIMIT_TIME) { - slavePtr->limit.active |= TCL_LIMIT_TIME; - memcpy(&slavePtr->limit.time, &masterPtr->limit.time, - sizeof(Tcl_Time)); - slavePtr->limit.timeGranularity = masterPtr->limit.timeGranularity; +InheritLimitsFromParent( + Tcl_Interp *childInterp, + Tcl_Interp *parentInterp) +{ + Interp *childPtr = (Interp *) childInterp; + Interp *parentPtr = (Interp *) parentInterp; + + if (parentPtr->limit.active & TCL_LIMIT_COMMANDS) { + childPtr->limit.active |= TCL_LIMIT_COMMANDS; + childPtr->limit.cmdCount = 0; + childPtr->limit.cmdGranularity = parentPtr->limit.cmdGranularity; + } + if (parentPtr->limit.active & TCL_LIMIT_TIME) { + childPtr->limit.active |= TCL_LIMIT_TIME; + memcpy(&childPtr->limit.time, &parentPtr->limit.time, + sizeof(Tcl_Time)); + childPtr->limit.timeGranularity = parentPtr->limit.timeGranularity; } } /* *---------------------------------------------------------------------- * - * SlaveCommandLimitCmd -- + * ChildCommandLimitCmd -- * * Implementation of the [interp limit $i commands] and [$i limit * commands] subcommands. See the interp manual page for a full * description. * @@ -4457,13 +4381,13 @@ * *---------------------------------------------------------------------- */ static int -SlaveCommandLimitCmd( +ChildCommandLimitCmd( Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Interp *slaveInterp, /* Interpreter being adjusted. */ + Tcl_Interp *childInterp, /* Interpreter being adjusted. */ int consumedObjc, /* Number of args already parsed. */ int objc, /* Total number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { static const char *const options[] = { @@ -4483,11 +4407,11 @@ * interpreter's limits; it may only manipulate its children. Note that * the low level API enforces this with Tcl_Panic, which we want to * avoid. [Bug 3398794] */ - if (interp == slaveInterp) { + if (interp == childInterp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "limits on current interpreter inaccessible", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL); return TCL_ERROR; } @@ -4494,11 +4418,11 @@ if (objc == consumedObjc) { Tcl_Obj *dictPtr; TclNewObj(dictPtr); - key.interp = slaveInterp; + key.interp = childInterp; key.type = TCL_LIMIT_COMMANDS; hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); if (hPtr != NULL) { limitCBPtr = Tcl_GetHashValue(hPtr); if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { @@ -4514,16 +4438,16 @@ TclNewObj(empty); Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1), empty); } Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1), - Tcl_NewWideIntObj(Tcl_LimitGetGranularity(slaveInterp, + Tcl_NewIntObj(Tcl_LimitGetGranularity(childInterp, TCL_LIMIT_COMMANDS))); - if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_COMMANDS)) { + if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_COMMANDS)) { Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1), - Tcl_NewWideIntObj(Tcl_LimitGetCommands(slaveInterp))); + Tcl_NewIntObj(Tcl_LimitGetCommands(childInterp))); } else { Tcl_Obj *empty; TclNewObj(empty); Tcl_DictObjPut(NULL, dictPtr, @@ -4536,11 +4460,11 @@ 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum Options) index) { case OPT_CMD: - key.interp = slaveInterp; + key.interp = childInterp; key.type = TCL_LIMIT_COMMANDS; hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); if (hPtr != NULL) { limitCBPtr = Tcl_GetHashValue(hPtr); if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { @@ -4547,27 +4471,26 @@ Tcl_SetObjResult(interp, limitCBPtr->scriptObj); } } break; case OPT_GRAN: - Tcl_SetObjResult(interp, Tcl_NewWideIntObj( - Tcl_LimitGetGranularity(slaveInterp, TCL_LIMIT_COMMANDS))); + Tcl_SetObjResult(interp, Tcl_NewIntObj( + Tcl_LimitGetGranularity(childInterp, TCL_LIMIT_COMMANDS))); break; case OPT_VAL: - if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_COMMANDS)) { + if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_COMMANDS)) { Tcl_SetObjResult(interp, - Tcl_NewWideIntObj(Tcl_LimitGetCommands(slaveInterp))); + Tcl_NewIntObj(Tcl_LimitGetCommands(childInterp))); } break; } return TCL_OK; } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) { Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?"); return TCL_ERROR; } else { - int i; - size_t scriptLen = 0, limitLen = 0; + int i, scriptLen = 0, limitLen = 0; Tcl_Obj *scriptObj = NULL, *granObj = NULL, *limitObj = NULL; int gran = 0, limit = 0; for (i=consumedObjc ; i 0 ? scriptObj : NULL)); } if (granObj != NULL) { - Tcl_LimitSetGranularity(slaveInterp, TCL_LIMIT_COMMANDS, gran); + Tcl_LimitSetGranularity(childInterp, TCL_LIMIT_COMMANDS, gran); } if (limitObj != NULL) { if (limitLen > 0) { - Tcl_LimitSetCommands(slaveInterp, limit); - Tcl_LimitTypeSet(slaveInterp, TCL_LIMIT_COMMANDS); + Tcl_LimitSetCommands(childInterp, limit); + Tcl_LimitTypeSet(childInterp, TCL_LIMIT_COMMANDS); } else { - Tcl_LimitTypeReset(slaveInterp, TCL_LIMIT_COMMANDS); + Tcl_LimitTypeReset(childInterp, TCL_LIMIT_COMMANDS); } } return TCL_OK; } } /* *---------------------------------------------------------------------- * - * SlaveTimeLimitCmd -- + * ChildTimeLimitCmd -- * * Implementation of the [interp limit $i time] and [$i limit time] * subcommands. See the interp manual page for a full description. * * Results: @@ -4646,13 +4569,13 @@ * *---------------------------------------------------------------------- */ static int -SlaveTimeLimitCmd( +ChildTimeLimitCmd( Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Interp *slaveInterp, /* Interpreter being adjusted. */ + Tcl_Interp *childInterp, /* Interpreter being adjusted. */ int consumedObjc, /* Number of args already parsed. */ int objc, /* Total number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { static const char *const options[] = { @@ -4672,11 +4595,11 @@ * interpreter's limits; it may only manipulate its children. Note that * the low level API enforces this with Tcl_Panic, which we want to * avoid. [Bug 3398794] */ - if (interp == slaveInterp) { + if (interp == childInterp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "limits on current interpreter inaccessible", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL); return TCL_ERROR; } @@ -4683,11 +4606,11 @@ if (objc == consumedObjc) { Tcl_Obj *dictPtr; TclNewObj(dictPtr); - key.interp = slaveInterp; + key.interp = childInterp; key.type = TCL_LIMIT_TIME; hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); if (hPtr != NULL) { limitCBPtr = Tcl_GetHashValue(hPtr); if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { @@ -4702,21 +4625,21 @@ TclNewObj(empty); Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1), empty); } Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1), - Tcl_NewWideIntObj(Tcl_LimitGetGranularity(slaveInterp, + Tcl_NewIntObj(Tcl_LimitGetGranularity(childInterp, TCL_LIMIT_TIME))); - if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_TIME)) { + if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_TIME)) { Tcl_Time limitMoment; - Tcl_LimitGetTime(slaveInterp, &limitMoment); + Tcl_LimitGetTime(childInterp, &limitMoment); Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1), - Tcl_NewWideIntObj(limitMoment.usec/1000)); + Tcl_NewLongObj(limitMoment.usec/1000)); Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[3], -1), - Tcl_NewWideIntObj(limitMoment.sec)); + Tcl_NewLongObj(limitMoment.sec)); } else { Tcl_Obj *empty; TclNewObj(empty); Tcl_DictObjPut(NULL, dictPtr, @@ -4731,11 +4654,11 @@ 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum Options) index) { case OPT_CMD: - key.interp = slaveInterp; + key.interp = childInterp; key.type = TCL_LIMIT_TIME; hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); if (hPtr != NULL) { limitCBPtr = Tcl_GetHashValue(hPtr); if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { @@ -4742,54 +4665,53 @@ Tcl_SetObjResult(interp, limitCBPtr->scriptObj); } } break; case OPT_GRAN: - Tcl_SetObjResult(interp, Tcl_NewWideIntObj( - Tcl_LimitGetGranularity(slaveInterp, TCL_LIMIT_TIME))); + Tcl_SetObjResult(interp, Tcl_NewIntObj( + Tcl_LimitGetGranularity(childInterp, TCL_LIMIT_TIME))); break; case OPT_MILLI: - if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_TIME)) { + if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_TIME)) { Tcl_Time limitMoment; - Tcl_LimitGetTime(slaveInterp, &limitMoment); + Tcl_LimitGetTime(childInterp, &limitMoment); Tcl_SetObjResult(interp, - Tcl_NewWideIntObj(limitMoment.usec/1000)); + Tcl_NewLongObj(limitMoment.usec/1000)); } break; case OPT_SEC: - if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_TIME)) { + if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_TIME)) { Tcl_Time limitMoment; - Tcl_LimitGetTime(slaveInterp, &limitMoment); - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(limitMoment.sec)); + Tcl_LimitGetTime(childInterp, &limitMoment); + Tcl_SetObjResult(interp, Tcl_NewLongObj(limitMoment.sec)); } break; } return TCL_OK; } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) { Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?"); return TCL_ERROR; } else { - int i; - size_t scriptLen = 0, milliLen = 0, secLen = 0; + int i, scriptLen = 0, milliLen = 0, secLen = 0; Tcl_Obj *scriptObj = NULL, *granObj = NULL; Tcl_Obj *milliObj = NULL, *secObj = NULL; int gran = 0; Tcl_Time limitMoment; int tmp; - Tcl_LimitGetTime(slaveInterp, &limitMoment); + Tcl_LimitGetTime(childInterp, &limitMoment); for (i=consumedObjc ; i 0 ? scriptObj : NULL)); } if (granObj != NULL) { - Tcl_LimitSetGranularity(slaveInterp, TCL_LIMIT_TIME, gran); + Tcl_LimitSetGranularity(childInterp, TCL_LIMIT_TIME, gran); } return TCL_OK; } } Index: generic/tclLink.c ================================================================== --- generic/tclLink.c +++ generic/tclLink.c @@ -6,69 +6,45 @@ * Andreas Stolcke and this implementation is based heavily on a * prototype implementation provided by him. * * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. - * Copyright (c) 2008 Rene Zaumseil - * Copyright (c) 2019 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" -#include "tommath.h" -#include /* * For each linked variable there is a data structure of the following type, * which describes the link and is the clientData for the trace set on the Tcl * variable. */ -typedef struct { +typedef struct Link { Tcl_Interp *interp; /* Interpreter containing Tcl variable. */ Namespace *nsPtr; /* Namespace containing Tcl variable */ Tcl_Obj *varName; /* Name of variable (must be global). This is * needed during trace callbacks, since the * actual variable may be aliased at that time * via upvar. */ - void *addr; /* Location of C variable. */ - size_t bytes; /* Size of C variable array. This is 0 when - * single variables, and >0 used for array - * variables. */ - size_t numElems; /* Number of elements in C variable array. - * Zero for single variables. */ + char *addr; /* Location of C variable. */ int type; /* Type of link (TCL_LINK_INT, etc.). */ union { char c; unsigned char uc; int i; unsigned int ui; short s; unsigned short us; -#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) long l; unsigned long ul; -#endif Tcl_WideInt w; Tcl_WideUInt uw; float f; double d; - void *aryPtr; /* Generic array. */ - char *cPtr; /* char array */ - unsigned char *ucPtr; /* unsigned char array */ - short *sPtr; /* short array */ - unsigned short *usPtr; /* unsigned short array */ - int *iPtr; /* int array */ - unsigned int *uiPtr; /* unsigned int array */ - long *lPtr; /* long array */ - unsigned long *ulPtr; /* unsigned long array */ - Tcl_WideInt *wPtr; /* wide (long long) array */ - Tcl_WideUInt *uwPtr; /* unsigned wide (long long) array */ - float *fPtr; /* float array */ - double *dPtr; /* double array */ } lastValue; /* Last known value of C variable; used to * avoid string conversions. */ int flags; /* Miscellaneous one-bit values; see below for * definitions. */ } Link; @@ -78,46 +54,25 @@ * LINK_READ_ONLY - 1 means errors should be generated if Tcl * script attempts to write variable. * LINK_BEING_UPDATED - 1 means that a call to Tcl_UpdateLinkedVar is * in progress for this variable, so trace * callbacks on the variable should be ignored. - * LINK_ALLOC_ADDR - 1 means linkPtr->addr was allocated on the - * heap. - * LINK_ALLOC_LAST - 1 means linkPtr->valueLast.p was allocated on - * the heap. */ #define LINK_READ_ONLY 1 #define LINK_BEING_UPDATED 2 -#define LINK_ALLOC_ADDR 4 -#define LINK_ALLOC_LAST 8 /* * Forward references to functions defined later in this file: */ static char * LinkTraceProc(ClientData clientData,Tcl_Interp *interp, const char *name1, const char *name2, int flags); static Tcl_Obj * ObjValue(Link *linkPtr); -static void LinkFree(Link *linkPtr); static int GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr); -static int GetInvalidDoubleFromObj(Tcl_Obj *objPtr, - double *doublePtr); -static int SetInvalidRealFromAny(Tcl_Interp *interp, - Tcl_Obj *objPtr); - -/* - * A marker type used to flag weirdnesses so we can pass them around right. - */ - -static Tcl_ObjType invalidRealType = { - "invalidReal", /* name */ - NULL, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - NULL, /* updateStringProc */ - NULL /* setFromAnyProc */ -}; +static int GetInvalidWideFromObj(Tcl_Obj *objPtr, Tcl_WideInt *widePtr); +static int GetInvalidDoubleFromObj(Tcl_Obj *objPtr, double *doublePtr); /* * Convenience macro for accessing the value of the C variable pointed to by a * link. Note that this macro produces something that may be regarded as an * lvalue or rvalue; it may be assigned to as well as read. Also note that @@ -150,11 +105,11 @@ int Tcl_LinkVar( Tcl_Interp *interp, /* Interpreter in which varName exists. */ const char *varName, /* Name of a global variable in interp. */ - void *addr, /* Address of a C variable to be linked to + char *addr, /* Address of a C variable to be linked to * varName. */ int type) /* Type of C variable: TCL_LINK_INT, etc. Also * may have TCL_LINK_READ_ONLY OR'ed in. */ { Tcl_Obj *objPtr; @@ -169,37 +124,27 @@ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "variable '%s' is already linked", varName)); return TCL_ERROR; } - linkPtr = Tcl_Alloc(sizeof(Link)); + linkPtr = ckalloc(sizeof(Link)); linkPtr->interp = interp; linkPtr->nsPtr = NULL; linkPtr->varName = Tcl_NewStringObj(varName, -1); Tcl_IncrRefCount(linkPtr->varName); linkPtr->addr = addr; linkPtr->type = type & ~TCL_LINK_READ_ONLY; -#if !defined(TCL_NO_DEPRECATED) && (defined(TCL_WIDE_INT_IS_LONG) \ - || defined(_WIN32) || defined(__CYGWIN__)) - if (linkPtr->type == 11 /* legacy TCL_LINK_LONG */) { - linkPtr->type = TCL_LINK_LONG; - } else if (linkPtr->type == 12 /* legacy TCL_LINK_ULONG */) { - linkPtr->type = TCL_LINK_ULONG; - } -#endif if (type & TCL_LINK_READ_ONLY) { linkPtr->flags = LINK_READ_ONLY; } else { linkPtr->flags = 0; } - linkPtr->bytes = 0; - linkPtr->numElems = 0; objPtr = ObjValue(linkPtr); if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr, TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { Tcl_DecrRefCount(linkPtr->varName); - LinkFree(linkPtr); + ckfree(linkPtr); return TCL_ERROR; } TclGetNamespaceForQualName(interp, varName, NULL, TCL_GLOBAL_ONLY, &(linkPtr->nsPtr), &dummy, &dummy, &name); @@ -208,192 +153,12 @@ code = Tcl_TraceVar2(interp, varName, NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, linkPtr); if (code != TCL_OK) { Tcl_DecrRefCount(linkPtr->varName); - LinkFree(linkPtr); - } - return code; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_LinkArray -- - * - * Link a C variable array to a Tcl variable so that changes to either - * one causes the other to change. - * - * Results: - * The return value is TCL_OK if everything went well or TCL_ERROR if an - * error occurred (the interp's result is also set after errors). - * - * Side effects: - * The value at *addr is linked to the Tcl variable "varName", using - * "type" to convert between string values for Tcl and binary values for - * *addr. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_LinkArray( - Tcl_Interp *interp, /* Interpreter in which varName exists. */ - const char *varName, /* Name of a global variable in interp. */ - void *addr, /* Address of a C variable to be linked to - * varName. If NULL then the necessary space - * will be allocated and returned as the - * interpreter result. */ - int type, /* Type of C variable: TCL_LINK_INT, etc. Also - * may have TCL_LINK_READ_ONLY OR'ed in. */ - size_t size) /* Size of C variable array, >1 if array */ -{ - Tcl_Obj *objPtr; - Link *linkPtr; - Namespace *dummy; - const char *name; - int code; - - if (size < 1) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "wrong array size given", -1)); - return TCL_ERROR; - } - - linkPtr = Tcl_Alloc(sizeof(Link)); - linkPtr->type = type & ~TCL_LINK_READ_ONLY; - linkPtr->numElems = size; - if (type & TCL_LINK_READ_ONLY) { - linkPtr->flags = LINK_READ_ONLY; - } else { - linkPtr->flags = 0; - } - - switch (linkPtr->type) { - case TCL_LINK_INT: - case TCL_LINK_BOOLEAN: - linkPtr->bytes = size * sizeof(int); - break; - case TCL_LINK_DOUBLE: - linkPtr->bytes = size * sizeof(double); - break; - case TCL_LINK_WIDE_INT: - linkPtr->bytes = size * sizeof(Tcl_WideInt); - break; - case TCL_LINK_WIDE_UINT: - linkPtr->bytes = size * sizeof(Tcl_WideUInt); - break; - case TCL_LINK_CHAR: - linkPtr->bytes = size * sizeof(char); - break; - case TCL_LINK_UCHAR: - linkPtr->bytes = size * sizeof(unsigned char); - break; - case TCL_LINK_SHORT: - linkPtr->bytes = size * sizeof(short); - break; - case TCL_LINK_USHORT: - linkPtr->bytes = size * sizeof(unsigned short); - break; - case TCL_LINK_UINT: - linkPtr->bytes = size * sizeof(unsigned int); - break; -#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) - case TCL_LINK_LONG: - linkPtr->bytes = size * sizeof(long); - break; - case TCL_LINK_ULONG: - linkPtr->bytes = size * sizeof(unsigned long); - break; -#endif - case TCL_LINK_FLOAT: - linkPtr->bytes = size * sizeof(float); - break; - case TCL_LINK_STRING: - linkPtr->bytes = size * sizeof(char); - size = 1; /* This is a variable length string, no need - * to check last value. */ - - /* - * If no address is given create one and use as address the - * not needed linkPtr->lastValue - */ - - if (addr == NULL) { - linkPtr->lastValue.aryPtr = Tcl_Alloc(linkPtr->bytes); - linkPtr->flags |= LINK_ALLOC_LAST; - addr = (char *) &linkPtr->lastValue.cPtr; - } - break; - case TCL_LINK_CHARS: - case TCL_LINK_BINARY: - linkPtr->bytes = size * sizeof(char); - break; - default: - LinkFree(linkPtr); - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "bad linked array variable type", -1)); - return TCL_ERROR; - } - - /* - * Allocate C variable space in case no address is given - */ - - if (addr == NULL) { - linkPtr->addr = Tcl_Alloc(linkPtr->bytes); - linkPtr->flags |= LINK_ALLOC_ADDR; - } else { - linkPtr->addr = addr; - } - - /* - * If necessary create space for last used value. - */ - - if (size > 1) { - linkPtr->lastValue.aryPtr = Tcl_Alloc(linkPtr->bytes); - linkPtr->flags |= LINK_ALLOC_LAST; - } - - /* - * Initialize allocated space. - */ - - if (linkPtr->flags & LINK_ALLOC_ADDR) { - memset(linkPtr->addr, 0, linkPtr->bytes); - } - if (linkPtr->flags & LINK_ALLOC_LAST) { - memset(linkPtr->lastValue.aryPtr, 0, linkPtr->bytes); - } - - /* - * Set common structure values. - */ - - linkPtr->interp = interp; - linkPtr->varName = Tcl_NewStringObj(varName, -1); - Tcl_IncrRefCount(linkPtr->varName); - - TclGetNamespaceForQualName(interp, varName, NULL, TCL_GLOBAL_ONLY, - &(linkPtr->nsPtr), &dummy, &dummy, &name); - linkPtr->nsPtr->refCount++; - - objPtr = ObjValue(linkPtr); - if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr, - TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { - Tcl_DecrRefCount(linkPtr->varName); - LinkFree(linkPtr); - return TCL_ERROR; - } - - code = Tcl_TraceVar2(interp, varName, NULL, - TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - LinkTraceProc, linkPtr); - if (code != TCL_OK) { - Tcl_DecrRefCount(linkPtr->varName); - LinkFree(linkPtr); + TclNsDecrRefCount(linkPtr->nsPtr); + ckfree(linkPtr); } return code; } /* @@ -427,11 +192,14 @@ } Tcl_UntraceVar2(interp, varName, NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, linkPtr); Tcl_DecrRefCount(linkPtr->varName); - LinkFree(linkPtr); + if (linkPtr->nsPtr) { + TclNsDecrRefCount(linkPtr->nsPtr); + } + ckfree(linkPtr); } /* *---------------------------------------------------------------------- * @@ -478,246 +246,10 @@ } /* *---------------------------------------------------------------------- * - * GetInt, GetWide, GetUWide, GetDouble, EqualDouble, IsSpecial -- - * - * Helper functions for LinkTraceProc and ObjValue. These are all - * factored out here to make those functions simpler. - * - *---------------------------------------------------------------------- - */ - -static inline int -GetInt( - Tcl_Obj *objPtr, - int *intPtr) -{ - return (Tcl_GetIntFromObj(NULL, objPtr, intPtr) != TCL_OK - && GetInvalidIntFromObj(objPtr, intPtr) != TCL_OK); -} - -static inline int -GetWide( - Tcl_Obj *objPtr, - Tcl_WideInt *widePtr) -{ - if (Tcl_GetWideIntFromObj(NULL, objPtr, widePtr) != TCL_OK) { - int intValue; - - if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) { - return 1; - } - *widePtr = intValue; - } - return 0; -} - -static inline int -GetUWide( - Tcl_Obj *objPtr, - Tcl_WideUInt *uwidePtr) -{ - Tcl_WideInt *widePtr = (Tcl_WideInt *) uwidePtr; - ClientData clientData; - int type, intValue; - - if (TclGetNumberFromObj(NULL, objPtr, &clientData, &type) == TCL_OK) { - if (type == TCL_NUMBER_INT) { - *widePtr = *((const Tcl_WideInt *) clientData); - return (*widePtr < 0); - } else if (type == TCL_NUMBER_BIG) { - mp_int *numPtr = clientData; - Tcl_WideUInt value = 0; - union { - Tcl_WideUInt value; - unsigned char bytes[sizeof(Tcl_WideUInt)]; - } scratch; - unsigned long numBytes = sizeof(Tcl_WideUInt); - unsigned char *bytes = scratch.bytes; - - if (numPtr->sign || (MP_OKAY != mp_to_unsigned_bin_n(numPtr, - bytes, &numBytes))) { - /* - * If the sign bit is set (a negative value) or if the value - * can't possibly fit in the bits of an unsigned wide, there's - * no point in doing further conversion. - */ - return 1; - } -#ifdef WORDS_BIGENDIAN - while (numBytes-- > 0) { - value = (value << CHAR_BIT) | *bytes++; - } -#else /* !WORDS_BIGENDIAN */ - /* - * Little-endian can read the value directly. - */ - value = scratch.value; -#endif /* WORDS_BIGENDIAN */ - *uwidePtr = value; - return 0; - } - } - - /* - * Evil edge case fallback. - */ - - if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) { - return 1; - } - *uwidePtr = intValue; - return 0; -} - -static inline int -GetDouble( - Tcl_Obj *objPtr, - double *dblPtr) -{ - if (Tcl_GetDoubleFromObj(NULL, objPtr, dblPtr) == TCL_OK) { - return 0; - } else { -#ifdef ACCEPT_NAN - Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &tclDoubleType); - - if (irPtr != NULL) { - *dblPtr = irPtr->doubleValue; - return 0; - } -#endif /* ACCEPT_NAN */ - return GetInvalidDoubleFromObj(objPtr, dblPtr) != TCL_OK; - } -} - -static inline int -EqualDouble( - double a, - double b) -{ - return (a == b) -#ifdef ACCEPT_NAN - || (TclIsNaN(a) && TclIsNaN(b)) -#endif /* ACCEPT_NAN */ - ; -} - -static inline int -IsSpecial( - double a) -{ - return TclIsInfinite(a) -#ifdef ACCEPT_NAN - || TclIsNaN(a) -#endif /* ACCEPT_NAN */ - ; -} - -/* - * Mark an object as holding a weird double. - */ - -static int -SetInvalidRealFromAny( - Tcl_Interp *interp, - Tcl_Obj *objPtr) -{ - size_t length; - const char *str, *endPtr; - - str = TclGetStringFromObj(objPtr, &length); - if ((length == 1) && (str[0] == '.')) { - objPtr->typePtr = &invalidRealType; - objPtr->internalRep.doubleValue = 0.0; - return TCL_OK; - } - if (TclParseNumber(NULL, objPtr, NULL, str, length, &endPtr, - TCL_PARSE_DECIMAL_ONLY) == TCL_OK) { - /* - * If number is followed by [eE][+-]?, then it is an invalid double, - * but it could be the start of a valid double. - */ - - if (*endPtr == 'e' || *endPtr == 'E') { - ++endPtr; - if (*endPtr == '+' || *endPtr == '-') { - ++endPtr; - } - if (*endPtr == 0) { - double doubleValue = 0.0; - - Tcl_GetDoubleFromObj(NULL, objPtr, &doubleValue); - TclFreeIntRep(objPtr); - objPtr->typePtr = &invalidRealType; - objPtr->internalRep.doubleValue = doubleValue; - return TCL_OK; - } - } - } - return TCL_ERROR; -} - -/* - * This function checks for integer representations, which are valid when - * linking with C variables, but which are invalid in other contexts in Tcl. - * Handled are "+", "-", "", "0x", "0b", "0d" and "0o" (upper- and - * lower-case). See bug [39f6304c2e]. - */ - -static int -GetInvalidIntFromObj( - Tcl_Obj *objPtr, - int *intPtr) -{ - size_t length; - const char *str = TclGetStringFromObj(objPtr, &length); - - if ((length == 0) || - ((length == 2) && (str[0] == '0') && strchr("xXbBoOdD", str[1]))) { - *intPtr = 0; - return TCL_OK; - } else if ((length == 1) && strchr("+-", str[0])) { - *intPtr = (str[0] == '+'); - return TCL_OK; - } - return TCL_ERROR; -} - -/* - * This function checks for double representations, which are valid when - * linking with C variables, but which are invalid in other contexts in Tcl. - * Handled are "+", "-", "", ".", "0x", "0b" and "0o" (upper- and lower-case) - * and sequences like "1e-". See bug [39f6304c2e]. - */ - -static int -GetInvalidDoubleFromObj( - Tcl_Obj *objPtr, - double *doublePtr) -{ - int intValue; - - if (TclHasIntRep(objPtr, &invalidRealType)) { - goto gotdouble; - } - if (GetInvalidIntFromObj(objPtr, &intValue) == TCL_OK) { - *doublePtr = (double) intValue; - return TCL_OK; - } - if (SetInvalidRealFromAny(NULL, objPtr) == TCL_OK) { - gotdouble: - *doublePtr = objPtr->internalRep.doubleValue; - return TCL_OK; - } - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * * LinkTraceProc -- * * This function is invoked when a linked Tcl variable is read, written, * or unset from Tcl. It's responsible for keeping the C variable in sync * with the Tcl variable. @@ -742,35 +274,34 @@ const char *name2, /* Second part of variable name. */ int flags) /* Miscellaneous additional information. */ { Link *linkPtr = clientData; int changed; - size_t valueLength = 0; + size_t valueLength; const char *value; char **pp; Tcl_Obj *valueObj; int valueInt; Tcl_WideInt valueWide; - Tcl_WideUInt valueUWide; double valueDouble; - int objc; - Tcl_Obj **objv; - int i; /* * If the variable is being unset, then just re-create it (with a trace) * unless the whole interpreter is going away. */ if (flags & TCL_TRACE_UNSETS) { if (Tcl_InterpDeleted(interp) || TclNamespaceDeleted(linkPtr->nsPtr)) { Tcl_DecrRefCount(linkPtr->varName); - LinkFree(linkPtr); + if (linkPtr->nsPtr) { + TclNsDecrRefCount(linkPtr->nsPtr); + } + ckfree(linkPtr); } else if (flags & TCL_TRACE_DESTROYED) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); - Tcl_TraceVar2(interp, TclGetString(linkPtr->varName), NULL, + Tcl_TraceVar2(interp, Tcl_GetString(linkPtr->varName), NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES |TCL_TRACE_UNSETS, LinkTraceProc, linkPtr); } return NULL; } @@ -789,68 +320,53 @@ * For read accesses, update the Tcl variable if the C variable has * changed since the last time we updated the Tcl variable. */ if (flags & TCL_TRACE_READS) { - /* - * Variable arrays - */ - - if (linkPtr->flags & LINK_ALLOC_LAST) { - changed = memcmp(linkPtr->addr, linkPtr->lastValue.aryPtr, - linkPtr->bytes); - } else { - /* single variables */ - switch (linkPtr->type) { - case TCL_LINK_INT: - case TCL_LINK_BOOLEAN: - changed = (LinkedVar(int) != linkPtr->lastValue.i); - break; - case TCL_LINK_DOUBLE: - changed = !EqualDouble(LinkedVar(double), linkPtr->lastValue.d); - break; - case TCL_LINK_WIDE_INT: - changed = (LinkedVar(Tcl_WideInt) != linkPtr->lastValue.w); - break; - case TCL_LINK_WIDE_UINT: - changed = (LinkedVar(Tcl_WideUInt) != linkPtr->lastValue.uw); - break; - case TCL_LINK_CHAR: - changed = (LinkedVar(char) != linkPtr->lastValue.c); - break; - case TCL_LINK_UCHAR: - changed = (LinkedVar(unsigned char) != linkPtr->lastValue.uc); - break; - case TCL_LINK_SHORT: - changed = (LinkedVar(short) != linkPtr->lastValue.s); - break; - case TCL_LINK_USHORT: - changed = (LinkedVar(unsigned short) != linkPtr->lastValue.us); - break; - case TCL_LINK_UINT: - changed = (LinkedVar(unsigned int) != linkPtr->lastValue.ui); - break; -#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) - case TCL_LINK_LONG: - changed = (LinkedVar(long) != linkPtr->lastValue.l); - break; - case TCL_LINK_ULONG: - changed = (LinkedVar(unsigned long) != linkPtr->lastValue.ul); - break; -#endif - case TCL_LINK_FLOAT: - changed = !EqualDouble(LinkedVar(float), linkPtr->lastValue.f); - break; - case TCL_LINK_STRING: - case TCL_LINK_CHARS: - case TCL_LINK_BINARY: - changed = 1; - break; - default: - changed = 0; - /* return (char *) "internal error: bad linked variable type"; */ - } + switch (linkPtr->type) { + case TCL_LINK_INT: + case TCL_LINK_BOOLEAN: + changed = (LinkedVar(int) != linkPtr->lastValue.i); + break; + case TCL_LINK_DOUBLE: + changed = (LinkedVar(double) != linkPtr->lastValue.d); + break; + case TCL_LINK_WIDE_INT: + changed = (LinkedVar(Tcl_WideInt) != linkPtr->lastValue.w); + break; + case TCL_LINK_WIDE_UINT: + changed = (LinkedVar(Tcl_WideUInt) != linkPtr->lastValue.uw); + break; + case TCL_LINK_CHAR: + changed = (LinkedVar(char) != linkPtr->lastValue.c); + break; + case TCL_LINK_UCHAR: + changed = (LinkedVar(unsigned char) != linkPtr->lastValue.uc); + break; + case TCL_LINK_SHORT: + changed = (LinkedVar(short) != linkPtr->lastValue.s); + break; + case TCL_LINK_USHORT: + changed = (LinkedVar(unsigned short) != linkPtr->lastValue.us); + break; + case TCL_LINK_UINT: + changed = (LinkedVar(unsigned int) != linkPtr->lastValue.ui); + break; + case TCL_LINK_LONG: + changed = (LinkedVar(long) != linkPtr->lastValue.l); + break; + case TCL_LINK_ULONG: + changed = (LinkedVar(unsigned long) != linkPtr->lastValue.ul); + break; + case TCL_LINK_FLOAT: + changed = (LinkedVar(float) != linkPtr->lastValue.f); + break; + case TCL_LINK_STRING: + changed = 1; + break; + default: + return (char *) "internal error: bad linked variable type"; } if (changed) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); } @@ -878,380 +394,171 @@ */ return (char *) "internal error: linked variable couldn't be read"; } - /* - * Special cases. - */ - - switch (linkPtr->type) { - case TCL_LINK_STRING: - value = TclGetStringFromObj(valueObj, &valueLength); - pp = (char **) linkPtr->addr; - - *pp = Tcl_Realloc(*pp, ++valueLength); - memcpy(*pp, value, valueLength); - return NULL; - - case TCL_LINK_CHARS: - value = (char *) TclGetStringFromObj(valueObj, &valueLength); - valueLength++; /* include end of string char */ - if (valueLength > linkPtr->bytes) { - return (char *) "wrong size of char* value"; - } - if (linkPtr->flags & LINK_ALLOC_LAST) { - memcpy(linkPtr->lastValue.aryPtr, value, (size_t) valueLength); - memcpy(linkPtr->addr, value, (size_t) valueLength); - } else { - linkPtr->lastValue.c = '\0'; - LinkedVar(char) = linkPtr->lastValue.c; - } - return NULL; - - case TCL_LINK_BINARY: - value = (char *) TclGetByteArrayFromObj(valueObj, &valueLength); - if (valueLength != linkPtr->bytes) { - return (char *) "wrong size of binary value"; - } - if (linkPtr->flags & LINK_ALLOC_LAST) { - memcpy(linkPtr->lastValue.aryPtr, value, (size_t) valueLength); - memcpy(linkPtr->addr, value, (size_t) valueLength); - } else { - linkPtr->lastValue.uc = (unsigned char) *value; - LinkedVar(unsigned char) = linkPtr->lastValue.uc; - } - return NULL; - } - - /* - * A helper macro. Writing this as a function is messy because of type - * variance. - */ - -#define InRange(lowerLimit, value, upperLimit) \ - ((value) >= (lowerLimit) && (value) <= (upperLimit)) - - /* - * If we're working with an array of numbers, extract the Tcl list. - */ - - if (linkPtr->flags & LINK_ALLOC_LAST) { - if (Tcl_ListObjGetElements(NULL, (valueObj), &objc, &objv) == TCL_ERROR - || (size_t)objc != linkPtr->numElems) { - return (char *) "wrong dimension"; - } - } - switch (linkPtr->type) { case TCL_LINK_INT: - if (linkPtr->flags & LINK_ALLOC_LAST) { - for (i=0; i < objc; i++) { - int *varPtr = &linkPtr->lastValue.iPtr[i]; - - if (GetInt(objv[i], varPtr)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable array must have integer values"; - } - } - } else { - int *varPtr = &linkPtr->lastValue.i; - - if (GetInt(valueObj, varPtr)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable must have integer value"; - } - LinkedVar(int) = *varPtr; - } + if (Tcl_GetIntFromObj(NULL, valueObj, &linkPtr->lastValue.i) != TCL_OK + && GetInvalidIntFromObj(valueObj, &linkPtr->lastValue.i) != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have integer value"; + } + LinkedVar(int) = linkPtr->lastValue.i; break; case TCL_LINK_WIDE_INT: - if (linkPtr->flags & LINK_ALLOC_LAST) { - for (i=0; i < objc; i++) { - Tcl_WideInt *varPtr = &linkPtr->lastValue.wPtr[i]; - - if (GetWide(objv[i], varPtr)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) - "variable array must have wide integer value"; - } - } - } else { - Tcl_WideInt *varPtr = &linkPtr->lastValue.w; - - if (GetWide(valueObj, varPtr)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable must have wide integer value"; - } - LinkedVar(Tcl_WideInt) = *varPtr; - } + if (Tcl_GetWideIntFromObj(NULL, valueObj, &linkPtr->lastValue.w) != TCL_OK + && GetInvalidWideFromObj(valueObj, &linkPtr->lastValue.w) != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have integer value"; + } + LinkedVar(Tcl_WideInt) = linkPtr->lastValue.w; break; case TCL_LINK_DOUBLE: - if (linkPtr->flags & LINK_ALLOC_LAST) { - for (i=0; i < objc; i++) { - if (GetDouble(objv[i], &linkPtr->lastValue.dPtr[i])) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable array must have real value"; - } - } - } else { - double *varPtr = &linkPtr->lastValue.d; - - if (GetDouble(valueObj, varPtr)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable must have real value"; - } - LinkedVar(double) = *varPtr; - } + if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d) != TCL_OK) { +#ifdef ACCEPT_NAN + if (valueObj->typePtr != &tclDoubleType) { +#endif + if (GetInvalidDoubleFromObj(valueObj, &linkPtr->lastValue.d) != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have real value"; + } +#ifdef ACCEPT_NAN + } + linkPtr->lastValue.d = valueObj->internalRep.doubleValue; +#endif + } + LinkedVar(double) = linkPtr->lastValue.d; break; case TCL_LINK_BOOLEAN: - if (linkPtr->flags & LINK_ALLOC_LAST) { - for (i=0; i < objc; i++) { - int *varPtr = &linkPtr->lastValue.iPtr[i]; - - if (Tcl_GetBooleanFromObj(NULL, objv[i], varPtr) != TCL_OK) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable array must have boolean value"; - } - } - } else { - int *varPtr = &linkPtr->lastValue.i; - - if (Tcl_GetBooleanFromObj(NULL, valueObj, varPtr) != TCL_OK) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable must have boolean value"; - } - LinkedVar(int) = *varPtr; - } + if (Tcl_GetBooleanFromObj(NULL, valueObj, &linkPtr->lastValue.i) != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have boolean value"; + } + LinkedVar(int) = linkPtr->lastValue.i; break; case TCL_LINK_CHAR: - if (linkPtr->flags & LINK_ALLOC_LAST) { - for (i=0; i < objc; i++) { - if (GetInt(objv[i], &valueInt) - || !InRange(SCHAR_MIN, valueInt, SCHAR_MAX)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable array must have char value"; - } - linkPtr->lastValue.cPtr[i] = (char) valueInt; - } - } else { - if (GetInt(valueObj, &valueInt) - || !InRange(SCHAR_MIN, valueInt, SCHAR_MAX)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable must have char value"; - } - LinkedVar(char) = linkPtr->lastValue.c = (char) valueInt; - } + if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK + && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) + || valueInt < SCHAR_MIN || valueInt > SCHAR_MAX) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have char value"; + } + LinkedVar(char) = linkPtr->lastValue.c = (char)valueInt; break; case TCL_LINK_UCHAR: - if (linkPtr->flags & LINK_ALLOC_LAST) { - for (i=0; i < objc; i++) { - if (GetInt(objv[i], &valueInt) - || !InRange(0, valueInt, UCHAR_MAX)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) - "variable array must have unsigned char value"; - } - linkPtr->lastValue.ucPtr[i] = (unsigned char) valueInt; - } - } else { - if (GetInt(valueObj, &valueInt) - || !InRange(0, valueInt, UCHAR_MAX)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable must have unsigned char value"; - } - LinkedVar(unsigned char) = linkPtr->lastValue.uc = - (unsigned char) valueInt; - } + if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK + && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) + || valueInt < 0 || valueInt > UCHAR_MAX) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have unsigned char value"; + } + LinkedVar(unsigned char) = linkPtr->lastValue.uc = (unsigned char) valueInt; break; case TCL_LINK_SHORT: - if (linkPtr->flags & LINK_ALLOC_LAST) { - for (i=0; i < objc; i++) { - if (GetInt(objv[i], &valueInt) - || !InRange(SHRT_MIN, valueInt, SHRT_MAX)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable array must have short value"; - } - linkPtr->lastValue.sPtr[i] = (short) valueInt; - } - } else { - if (GetInt(valueObj, &valueInt) - || !InRange(SHRT_MIN, valueInt, SHRT_MAX)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable must have short value"; - } - LinkedVar(short) = linkPtr->lastValue.s = (short) valueInt; - } + if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK + && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) + || valueInt < SHRT_MIN || valueInt > SHRT_MAX) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have short value"; + } + LinkedVar(short) = linkPtr->lastValue.s = (short)valueInt; break; case TCL_LINK_USHORT: - if (linkPtr->flags & LINK_ALLOC_LAST) { - for (i=0; i < objc; i++) { - if (GetInt(objv[i], &valueInt) - || !InRange(0, valueInt, USHRT_MAX)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) - "variable array must have unsigned short value"; - } - linkPtr->lastValue.usPtr[i] = (unsigned short) valueInt; - } - } else { - if (GetInt(valueObj, &valueInt) - || !InRange(0, valueInt, USHRT_MAX)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable must have unsigned short value"; - } - LinkedVar(unsigned short) = linkPtr->lastValue.us = - (unsigned short) valueInt; - } + if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK + && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) + || valueInt < 0 || valueInt > USHRT_MAX) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have unsigned short value"; + } + LinkedVar(unsigned short) = linkPtr->lastValue.us = (unsigned short)valueInt; break; case TCL_LINK_UINT: - if (linkPtr->flags & LINK_ALLOC_LAST) { - for (i=0; i < objc; i++) { - if (GetWide(objv[i], &valueWide) - || !InRange(0, valueWide, UINT_MAX)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) - "variable array must have unsigned int value"; - } - linkPtr->lastValue.uiPtr[i] = (unsigned int) valueWide; - } - } else { - if (GetWide(valueObj, &valueWide) - || !InRange(0, valueWide, UINT_MAX)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable must have unsigned int value"; - } - LinkedVar(unsigned int) = linkPtr->lastValue.ui = - (unsigned int) valueWide; - } + if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK + && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) + || valueWide < 0 || valueWide > UINT_MAX) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have unsigned int value"; + } + LinkedVar(unsigned int) = linkPtr->lastValue.ui = (unsigned int)valueWide; break; -#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) case TCL_LINK_LONG: - if (linkPtr->flags & LINK_ALLOC_LAST) { - for (i=0; i < objc; i++) { - if (GetWide(objv[i], &valueWide) - || !InRange(LONG_MIN, valueWide, LONG_MAX)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable array must have long value"; - } - linkPtr->lastValue.lPtr[i] = (long) valueWide; - } - } else { - if (GetWide(valueObj, &valueWide) - || !InRange(LONG_MIN, valueWide, LONG_MAX)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable must have long value"; - } - LinkedVar(long) = linkPtr->lastValue.l = (long) valueWide; - } + if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK + && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) + || valueWide < LONG_MIN || valueWide > LONG_MAX) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have long value"; + } + LinkedVar(long) = linkPtr->lastValue.l = (long)valueWide; break; case TCL_LINK_ULONG: - if (linkPtr->flags & LINK_ALLOC_LAST) { - for (i=0; i < objc; i++) { - if (GetUWide(objv[i], &valueUWide) - || !InRange(0, valueUWide, ULONG_MAX)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) - "variable array must have unsigned long value"; - } - linkPtr->lastValue.ulPtr[i] = (unsigned long) valueUWide; - } - } else { - if (GetUWide(valueObj, &valueUWide) - || !InRange(0, valueUWide, ULONG_MAX)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable must have unsigned long value"; - } - LinkedVar(unsigned long) = linkPtr->lastValue.ul = - (unsigned long) valueUWide; - } - break; -#endif + if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK + && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) + || valueWide < 0 || (Tcl_WideUInt) valueWide > ULONG_MAX) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have unsigned long value"; + } + LinkedVar(unsigned long) = linkPtr->lastValue.ul = (unsigned long)valueWide; + break; case TCL_LINK_WIDE_UINT: - if (linkPtr->flags & LINK_ALLOC_LAST) { - for (i=0; i < objc; i++) { - if (GetUWide(objv[i], &valueUWide)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) - "variable array must have unsigned wide int value"; - } - linkPtr->lastValue.uwPtr[i] = valueUWide; - } - } else { - if (GetUWide(valueObj, &valueUWide)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable must have unsigned wide int value"; - } - LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw = valueUWide; - } + /* + * FIXME: represent as a bignum. + */ + if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK + && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have unsigned wide int value"; + } + LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw = (Tcl_WideUInt)valueWide; break; case TCL_LINK_FLOAT: - if (linkPtr->flags & LINK_ALLOC_LAST) { - for (i=0; i < objc; i++) { - if (GetDouble(objv[i], &valueDouble) - && !InRange(FLT_MIN, fabs(valueDouble), FLT_MAX) - && !IsSpecial(valueDouble)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable array must have float value"; - } - linkPtr->lastValue.fPtr[i] = (float) valueDouble; - } - } else { - if (GetDouble(valueObj, &valueDouble) - && !InRange(FLT_MIN, fabs(valueDouble), FLT_MAX) - && !IsSpecial(valueDouble)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable must have float value"; - } - LinkedVar(float) = linkPtr->lastValue.f = (float) valueDouble; - } + if ((Tcl_GetDoubleFromObj(NULL, valueObj, &valueDouble) != TCL_OK + && GetInvalidDoubleFromObj(valueObj, &valueDouble) != TCL_OK) + || valueDouble < -FLT_MAX || valueDouble > FLT_MAX) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have float value"; + } + LinkedVar(float) = linkPtr->lastValue.f = (float)valueDouble; + break; + + case TCL_LINK_STRING: + value = TclGetString(valueObj); + valueLength = valueObj->length + 1; + pp = (char **) linkPtr->addr; + + *pp = ckrealloc(*pp, valueLength); + memcpy(*pp, value, valueLength); break; default: return (char *) "internal error: bad linked variable type"; } - - if (linkPtr->flags & LINK_ALLOC_LAST) { - memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); - } return NULL; } /* *---------------------------------------------------------------------- @@ -1274,214 +581,63 @@ static Tcl_Obj * ObjValue( Link *linkPtr) /* Structure describing linked variable. */ { char *p; - Tcl_Obj *resultObj, **objv; - size_t i; + Tcl_Obj *resultObj; switch (linkPtr->type) { case TCL_LINK_INT: - if (linkPtr->flags & LINK_ALLOC_LAST) { - memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); - for (i=0; i < linkPtr->numElems; i++) { - objv[i] = Tcl_NewIntObj(linkPtr->lastValue.iPtr[i]); - } - resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - Tcl_Free(objv); - return resultObj; - } linkPtr->lastValue.i = LinkedVar(int); return Tcl_NewIntObj(linkPtr->lastValue.i); case TCL_LINK_WIDE_INT: - if (linkPtr->flags & LINK_ALLOC_LAST) { - memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); - for (i=0; i < linkPtr->numElems; i++) { - objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.wPtr[i]); - } - resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - Tcl_Free(objv); - return resultObj; - } linkPtr->lastValue.w = LinkedVar(Tcl_WideInt); return Tcl_NewWideIntObj(linkPtr->lastValue.w); case TCL_LINK_DOUBLE: - if (linkPtr->flags & LINK_ALLOC_LAST) { - memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); - for (i=0; i < linkPtr->numElems; i++) { - objv[i] = Tcl_NewDoubleObj(linkPtr->lastValue.dPtr[i]); - } - resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - Tcl_Free(objv); - return resultObj; - } linkPtr->lastValue.d = LinkedVar(double); return Tcl_NewDoubleObj(linkPtr->lastValue.d); case TCL_LINK_BOOLEAN: - if (linkPtr->flags & LINK_ALLOC_LAST) { - memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); - for (i=0; i < linkPtr->numElems; i++) { - objv[i] = Tcl_NewBooleanObj(linkPtr->lastValue.iPtr[i] != 0); - } - resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - Tcl_Free(objv); - return resultObj; - } linkPtr->lastValue.i = LinkedVar(int); - return Tcl_NewBooleanObj(linkPtr->lastValue.i); + return Tcl_NewBooleanObj(linkPtr->lastValue.i != 0); case TCL_LINK_CHAR: - if (linkPtr->flags & LINK_ALLOC_LAST) { - memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); - for (i=0; i < linkPtr->numElems; i++) { - objv[i] = Tcl_NewIntObj(linkPtr->lastValue.cPtr[i]); - } - resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - Tcl_Free(objv); - return resultObj; - } linkPtr->lastValue.c = LinkedVar(char); return Tcl_NewIntObj(linkPtr->lastValue.c); case TCL_LINK_UCHAR: - if (linkPtr->flags & LINK_ALLOC_LAST) { - memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); - for (i=0; i < linkPtr->numElems; i++) { - objv[i] = Tcl_NewIntObj(linkPtr->lastValue.ucPtr[i]); - } - resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - Tcl_Free(objv); - return resultObj; - } linkPtr->lastValue.uc = LinkedVar(unsigned char); return Tcl_NewIntObj(linkPtr->lastValue.uc); case TCL_LINK_SHORT: - if (linkPtr->flags & LINK_ALLOC_LAST) { - memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); - for (i=0; i < linkPtr->numElems; i++) { - objv[i] = Tcl_NewIntObj(linkPtr->lastValue.sPtr[i]); - } - resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - Tcl_Free(objv); - return resultObj; - } linkPtr->lastValue.s = LinkedVar(short); return Tcl_NewIntObj(linkPtr->lastValue.s); case TCL_LINK_USHORT: - if (linkPtr->flags & LINK_ALLOC_LAST) { - memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); - for (i=0; i < linkPtr->numElems; i++) { - objv[i] = Tcl_NewIntObj(linkPtr->lastValue.usPtr[i]); - } - resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - Tcl_Free(objv); - return resultObj; - } linkPtr->lastValue.us = LinkedVar(unsigned short); return Tcl_NewIntObj(linkPtr->lastValue.us); case TCL_LINK_UINT: - if (linkPtr->flags & LINK_ALLOC_LAST) { - memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); - for (i=0; i < linkPtr->numElems; i++) { - objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.uiPtr[i]); - } - resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - Tcl_Free(objv); - return resultObj; - } linkPtr->lastValue.ui = LinkedVar(unsigned int); return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ui); -#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) case TCL_LINK_LONG: - if (linkPtr->flags & LINK_ALLOC_LAST) { - memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); - for (i=0; i < linkPtr->numElems; i++) { - objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.lPtr[i]); - } - resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - Tcl_Free(objv); - return resultObj; - } linkPtr->lastValue.l = LinkedVar(long); return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.l); case TCL_LINK_ULONG: - if (linkPtr->flags & LINK_ALLOC_LAST) { - memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); - for (i=0; i < linkPtr->numElems; i++) { - objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.ulPtr[i]); - } - resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - Tcl_Free(objv); - return resultObj; - } linkPtr->lastValue.ul = LinkedVar(unsigned long); return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ul); -#endif case TCL_LINK_FLOAT: - if (linkPtr->flags & LINK_ALLOC_LAST) { - memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); - for (i=0; i < linkPtr->numElems; i++) { - objv[i] = Tcl_NewDoubleObj(linkPtr->lastValue.fPtr[i]); - } - resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - Tcl_Free(objv); - return resultObj; - } linkPtr->lastValue.f = LinkedVar(float); return Tcl_NewDoubleObj(linkPtr->lastValue.f); case TCL_LINK_WIDE_UINT: - if (linkPtr->flags & LINK_ALLOC_LAST) { - memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); - for (i=0; i < linkPtr->numElems; i++) { - objv[i] = Tcl_NewWideIntObj((Tcl_WideInt) - linkPtr->lastValue.uwPtr[i]); - } - resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - Tcl_Free(objv); - return resultObj; - } linkPtr->lastValue.uw = LinkedVar(Tcl_WideUInt); + /* + * FIXME: represent as a bignum. + */ return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.uw); - case TCL_LINK_STRING: p = LinkedVar(char *); if (p == NULL) { TclNewLiteralStringObj(resultObj, "NULL"); return resultObj; } return Tcl_NewStringObj(p, -1); - case TCL_LINK_CHARS: - if (linkPtr->flags & LINK_ALLOC_LAST) { - memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - linkPtr->lastValue.cPtr[linkPtr->bytes-1] = '\0'; - /* take care of proper string end */ - return Tcl_NewStringObj(linkPtr->lastValue.cPtr, linkPtr->bytes); - } - linkPtr->lastValue.c = '\0'; - return Tcl_NewStringObj(&linkPtr->lastValue.c, 1); - - case TCL_LINK_BINARY: - if (linkPtr->flags & LINK_ALLOC_LAST) { - memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - return Tcl_NewByteArrayObj((unsigned char *) linkPtr->addr, - linkPtr->bytes); - } - linkPtr->lastValue.uc = LinkedVar(unsigned char); - return Tcl_NewByteArrayObj(&linkPtr->lastValue.uc, 1); - /* * This code only gets executed if the link type is unknown (shouldn't * ever happen). */ @@ -1488,45 +644,118 @@ default: TclNewLiteralStringObj(resultObj, "??"); return resultObj; } } - + +static int SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); + +static Tcl_ObjType invalidRealType = { + "invalidReal", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + NULL, /* updateStringProc */ + NULL /* setFromAnyProc */ +}; + +static int +SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) { + int length; + const char *str; + const char *endPtr; + + str = TclGetStringFromObj(objPtr, &length); + if ((length == 1) && (str[0] == '.')){ + objPtr->typePtr = &invalidRealType; + objPtr->internalRep.doubleValue = 0.0; + return TCL_OK; + } + if (TclParseNumber(NULL, objPtr, NULL, str, length, &endPtr, + TCL_PARSE_DECIMAL_ONLY) == TCL_OK) { + /* If number is followed by [eE][+-]?, then it is an invalid + * double, but it could be the start of a valid double. */ + if (*endPtr == 'e' || *endPtr == 'E') { + ++endPtr; + if (*endPtr == '+' || *endPtr == '-') ++endPtr; + if (*endPtr == 0) { + double doubleValue = 0.0; + Tcl_GetDoubleFromObj(NULL, objPtr, &doubleValue); + if (objPtr->typePtr->freeIntRepProc) objPtr->typePtr->freeIntRepProc(objPtr); + objPtr->typePtr = &invalidRealType; + objPtr->internalRep.doubleValue = doubleValue; + return TCL_OK; + } + } + } + return TCL_ERROR; +} + + +/* + * This function checks for integer representations, which are valid + * when linking with C variables, but which are invalid in other + * contexts in Tcl. Handled are "+", "-", "", "0x", "0b" and "0o" + * (upperand lowercase). See bug [39f6304c2e]. + */ +int +GetInvalidIntFromObj(Tcl_Obj *objPtr, + int *intPtr) +{ + const char *str = TclGetString(objPtr); + + if ((objPtr->length == 0) || + ((objPtr->length == 2) && (str[0] == '0') && strchr("xXbBoO", str[1]))) { + *intPtr = 0; + return TCL_OK; + } else if ((objPtr->length == 1) && strchr("+-", str[0])) { + *intPtr = (str[0] == '+'); + return TCL_OK; + } + return TCL_ERROR; +} + +int +GetInvalidWideFromObj(Tcl_Obj *objPtr, Tcl_WideInt *widePtr) +{ + int intValue; + + if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) { + return TCL_ERROR; + } + *widePtr = intValue; + return TCL_OK; +} + /* - *---------------------------------------------------------------------- - * - * LinkFree -- - * - * Free's allocated space of given link and link structure. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- + * This function checks for double representations, which are valid + * when linking with C variables, but which are invalid in other + * contexts in Tcl. Handled are "+", "-", "", ".", "0x", "0b" and "0o" + * (upper- and lowercase) and sequences like "1e-". See bug [39f6304c2e]. */ - -static void -LinkFree( - Link *linkPtr) /* Structure describing linked variable. */ -{ - if (linkPtr->nsPtr) { - TclNsDecrRefCount(linkPtr->nsPtr); - } - if (linkPtr->flags & LINK_ALLOC_ADDR) { - Tcl_Free(linkPtr->addr); - } - if (linkPtr->flags & LINK_ALLOC_LAST) { - Tcl_Free(linkPtr->lastValue.aryPtr); - } - Tcl_Free(linkPtr); +int +GetInvalidDoubleFromObj(Tcl_Obj *objPtr, + double *doublePtr) +{ + int intValue; + + if (objPtr->typePtr == &invalidRealType) { + goto gotdouble; + } + if (GetInvalidIntFromObj(objPtr, &intValue) == TCL_OK) { + *doublePtr = (double) intValue; + return TCL_OK; + } + if (SetInvalidRealFromAny(NULL, objPtr) == TCL_OK) { + gotdouble: + *doublePtr = objPtr->internalRep.doubleValue; + return TCL_OK; + } + return TCL_ERROR; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: generic/tclListObj.c ================================================================== --- generic/tclListObj.c +++ generic/tclListObj.c @@ -10,11 +10,10 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" -#include /* * Prototypes for functions defined later in this file: */ @@ -45,31 +44,10 @@ DupListInternalRep, /* dupIntRepProc */ UpdateStringOfList, /* updateStringProc */ SetListFromAny /* setFromAnyProc */ }; -/* Macros to manipulate the List internal rep */ - -#define ListSetIntRep(objPtr, listRepPtr) \ - do { \ - Tcl_ObjIntRep ir; \ - ir.twoPtrValue.ptr1 = (listRepPtr); \ - ir.twoPtrValue.ptr2 = NULL; \ - (listRepPtr)->refCount++; \ - Tcl_StoreIntRep((objPtr), &tclListType, &ir); \ - } while (0) - -#define ListGetIntRep(objPtr, listRepPtr) \ - do { \ - const Tcl_ObjIntRep *irPtr; \ - irPtr = TclFetchIntRep((objPtr), &tclListType); \ - (listRepPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ - } while (0) - -#define ListResetIntRep(objPtr, listRepPtr) \ - TclFetchIntRep((objPtr), &tclListType)->twoPtrValue.ptr1 = (listRepPtr) - #ifndef TCL_MIN_ELEMENT_GROWTH #define TCL_MIN_ELEMENT_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Obj *) #endif /* @@ -122,14 +100,14 @@ LIST_MAX); } return NULL; } - listRepPtr = Tcl_AttemptAlloc(LIST_SIZE(objc)); + listRepPtr = attemptckalloc(LIST_SIZE(objc)); if (listRepPtr == NULL) { if (p) { - Tcl_Panic("list creation failed: unable to alloc %" TCL_Z_MODIFIER "u bytes", + Tcl_Panic("list creation failed: unable to alloc %u bytes", LIST_SIZE(objc)); } return NULL; } @@ -176,11 +154,11 @@ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "max length of a Tcl list (%d elements) exceeded", LIST_MAX)); } else { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "list creation failed: unable to alloc %" TCL_Z_MODIFIER "u bytes", + "list creation failed: unable to alloc %u bytes", LIST_SIZE(objc))); } Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); } return listRepPtr; @@ -356,11 +334,12 @@ if (objc > 0) { listRepPtr = NewListIntRep(objc, objv, 1); ListSetIntRep(objPtr, listRepPtr); } else { - Tcl_InitStringRep(objPtr, NULL, 0); + objPtr->bytes = tclEmptyStringRep; + objPtr->length = 0; } } /* *---------------------------------------------------------------------- @@ -390,14 +369,12 @@ Tcl_Interp *interp, /* Used to report errors if not NULL. */ Tcl_Obj *listPtr) /* List object for which an element array is * to be returned. */ { Tcl_Obj *copyPtr; - List *listRepPtr; - ListGetIntRep(listPtr, listRepPtr); - if (NULL == listRepPtr) { + if (listPtr->typePtr != &tclListType) { if (SetListFromAny(interp, listPtr) != TCL_OK) { return NULL; } } @@ -404,91 +381,10 @@ TclNewObj(copyPtr); TclInvalidateStringRep(copyPtr); DupListInternalRep(listPtr, copyPtr); return copyPtr; } - -/* - *---------------------------------------------------------------------- - * - * TclListObjRange -- - * - * Makes a slice of a list value. - * *listPtr must be known to be a valid list. - * - * Results: - * Returns a pointer to the sliced list. - * This may be a new object or the same object if not shared. - * - * Side effects: - * The possible conversion of the object referenced by listPtr - * to a list object. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclListObjRange( - Tcl_Obj *listPtr, /* List object to take a range from. */ - int fromIdx, /* Index of first element to include. */ - int toIdx) /* Index of last element to include. */ -{ - Tcl_Obj **elemPtrs; - int listLen, i, newLen; - List *listRepPtr; - - TclListObjGetElements(NULL, listPtr, &listLen, &elemPtrs); - - if (fromIdx < 0) { - fromIdx = 0; - } - if (toIdx >= listLen) { - toIdx = listLen-1; - } - if (fromIdx > toIdx) { - return Tcl_NewObj(); - } - - newLen = toIdx - fromIdx + 1; - - if (Tcl_IsShared(listPtr) || - ((ListRepPtr(listPtr)->refCount > 1))) { - return Tcl_NewListObj(newLen, &elemPtrs[fromIdx]); - } - - /* - * In-place is possible. - */ - - /* - * Even if nothing below cause any changes, we still want the - * string-canonizing effect of [lrange 0 end]. - */ - - TclInvalidateStringRep(listPtr); - - /* - * Delete elements that should not be included. - */ - - for (i = 0; i < fromIdx; i++) { - TclDecrRefCount(elemPtrs[i]); - } - for (i = toIdx + 1; i < listLen; i++) { - TclDecrRefCount(elemPtrs[i]); - } - - if (fromIdx > 0) { - memmove(elemPtrs, &elemPtrs[fromIdx], - (size_t) newLen * sizeof(Tcl_Obj*)); - } - - listRepPtr = ListRepPtr(listPtr); - listRepPtr->elemCount = newLen; - - return listPtr; -} /* *---------------------------------------------------------------------- * * Tcl_ListObjGetElements -- @@ -522,37 +418,33 @@ */ int Tcl_ListObjGetElements( Tcl_Interp *interp, /* Used to report errors if not NULL. */ - register Tcl_Obj *listPtr, /* List object for which an element array is + Tcl_Obj *listPtr, /* List object for which an element array is * to be returned. */ int *objcPtr, /* Where to store the count of objects * referenced by objv. */ Tcl_Obj ***objvPtr) /* Where to store the pointer to an array of * pointers to the list's objects. */ { - register List *listRepPtr; + List *listRepPtr; - ListGetIntRep(listPtr, listRepPtr); - - if (listRepPtr == NULL) { + if (listPtr->typePtr != &tclListType) { int result; - size_t length; - (void) TclGetStringFromObj(listPtr, &length); - if (length == 0) { + if (listPtr->bytes == tclEmptyStringRep) { *objcPtr = 0; *objvPtr = NULL; return TCL_OK; } result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } - ListGetIntRep(listPtr, listRepPtr); } + listRepPtr = ListRepPtr(listPtr); *objcPtr = listRepPtr->elemCount; *objvPtr = &listRepPtr->elements; return TCL_OK; } @@ -587,11 +479,11 @@ */ int Tcl_ListObjAppendList( Tcl_Interp *interp, /* Used to report errors if not NULL. */ - register Tcl_Obj *listPtr, /* List object to append elements to. */ + Tcl_Obj *listPtr, /* List object to append elements to. */ Tcl_Obj *elemListPtr) /* List obj with elements to append. */ { int objc; Tcl_Obj **objv; @@ -649,34 +541,30 @@ Tcl_ListObjAppendElement( Tcl_Interp *interp, /* Used to report errors if not NULL. */ Tcl_Obj *listPtr, /* List object to append objPtr to. */ Tcl_Obj *objPtr) /* Object to append to listPtr's list. */ { - register List *listRepPtr, *newPtr = NULL; + List *listRepPtr, *newPtr = NULL; int numElems, numRequired, needGrow, isShared, attempt; if (Tcl_IsShared(listPtr)) { Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendElement"); } - - ListGetIntRep(listPtr, listRepPtr); - if (listRepPtr == NULL) { + if (listPtr->typePtr != &tclListType) { int result; - size_t length; - (void) TclGetStringFromObj(listPtr, &length); - if (length == 0) { + if (listPtr->bytes == tclEmptyStringRep) { Tcl_SetListObj(listPtr, 1, &objPtr); return TCL_OK; } result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } - ListGetIntRep(listPtr, listRepPtr); } + listRepPtr = ListRepPtr(listPtr); numElems = listRepPtr->elemCount; numRequired = numElems + 1 ; needGrow = (numRequired > listRepPtr->maxElemCount); isShared = (listRepPtr->refCount > 1); @@ -695,22 +583,22 @@ * Need to grow + unshared intrep => try to realloc */ attempt = 2 * numRequired; if (attempt <= LIST_MAX) { - newPtr = Tcl_AttemptRealloc(listRepPtr, LIST_SIZE(attempt)); + newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt)); } if (newPtr == NULL) { attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH; if (attempt > LIST_MAX) { attempt = LIST_MAX; } - newPtr = Tcl_AttemptRealloc(listRepPtr, LIST_SIZE(attempt)); + newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt)); } if (newPtr == NULL) { attempt = numRequired; - newPtr = Tcl_AttemptRealloc(listRepPtr, LIST_SIZE(attempt)); + newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt)); } if (newPtr) { listRepPtr = newPtr; listRepPtr->maxElemCount = attempt; needGrow = 0; @@ -764,19 +652,15 @@ /* * Old intrep to be freed, re-use refCounts. */ memcpy(dst, src, numElems * sizeof(Tcl_Obj *)); - Tcl_Free(listRepPtr); + ckfree(listRepPtr); } listRepPtr = newPtr; } - ListResetIntRep(listPtr, listRepPtr); - listRepPtr->refCount++; - TclFreeIntRep(listPtr); - ListSetIntRep(listPtr, listRepPtr); - listRepPtr->refCount--; + listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr; /* * Add objPtr to the end of listPtr's array of element pointers. Increment * the ref count for the (now shared) objPtr. */ @@ -825,33 +709,30 @@ */ int Tcl_ListObjIndex( Tcl_Interp *interp, /* Used to report errors if not NULL. */ - register Tcl_Obj *listPtr, /* List object to index into. */ - register int index, /* Index of element to return. */ + Tcl_Obj *listPtr, /* List object to index into. */ + int index, /* Index of element to return. */ Tcl_Obj **objPtrPtr) /* The resulting Tcl_Obj* is stored here. */ { - register List *listRepPtr; + List *listRepPtr; - ListGetIntRep(listPtr, listRepPtr); - if (listRepPtr == NULL) { + if (listPtr->typePtr != &tclListType) { int result; - size_t length; - (void) TclGetStringFromObj(listPtr, &length); - if (length == 0) { + if (listPtr->bytes == tclEmptyStringRep) { *objPtrPtr = NULL; return TCL_OK; } result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } - ListGetIntRep(listPtr, listRepPtr); } + listRepPtr = ListRepPtr(listPtr); if ((index < 0) || (index >= listRepPtr->elemCount)) { *objPtrPtr = NULL; } else { *objPtrPtr = (&listRepPtr->elements)[index]; } @@ -883,32 +764,29 @@ */ int Tcl_ListObjLength( Tcl_Interp *interp, /* Used to report errors if not NULL. */ - register Tcl_Obj *listPtr, /* List object whose #elements to return. */ - register int *intPtr) /* The resulting int is stored here. */ + Tcl_Obj *listPtr, /* List object whose #elements to return. */ + int *intPtr) /* The resulting int is stored here. */ { - register List *listRepPtr; + List *listRepPtr; - ListGetIntRep(listPtr, listRepPtr); - if (listRepPtr == NULL) { + if (listPtr->typePtr != &tclListType) { int result; - size_t length; - (void) TclGetStringFromObj(listPtr, &length); - if (length == 0) { + if (listPtr->bytes == tclEmptyStringRep) { *intPtr = 0; return TCL_OK; } result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } - ListGetIntRep(listPtr, listRepPtr); } + listRepPtr = ListRepPtr(listPtr); *intPtr = listRepPtr->elemCount; return TCL_OK; } /* @@ -959,24 +837,19 @@ int objc, /* Number of objects to insert. */ Tcl_Obj *const objv[]) /* An array of objc pointers to Tcl objects to * insert. */ { List *listRepPtr; - register Tcl_Obj **elemPtrs; + Tcl_Obj **elemPtrs; int needGrow, numElems, numRequired, numAfterLast, start, i, j, isShared; if (Tcl_IsShared(listPtr)) { Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace"); } - - ListGetIntRep(listPtr, listRepPtr); - if (listRepPtr == NULL) { - size_t length; - - (void) TclGetStringFromObj(listPtr, &length); - if (length == 0) { - if (objc == 0) { + if (listPtr->typePtr != &tclListType) { + if (listPtr->bytes == tclEmptyStringRep) { + if (!objc) { return TCL_OK; } Tcl_SetListObj(listPtr, objc, NULL); } else { int result = SetListFromAny(interp, listPtr); @@ -983,11 +856,10 @@ if (result != TCL_OK) { return result; } } - ListGetIntRep(listPtr, listRepPtr); } /* * Note that when count == 0 and objc == 0, this routine is logically a * no-op, removing and adding no elements to the list. However, by flowing @@ -994,10 +866,11 @@ * through this routine anyway, we get the important side effect that the * resulting listPtr is a list in canoncial form. This is important. * Resist any temptation to optimize this case. */ + listRepPtr = ListRepPtr(listPtr); elemPtrs = &listRepPtr->elements; numElems = listRepPtr->elemCount; if (first < 0) { first = 0; @@ -1032,26 +905,26 @@ if (needGrow && !isShared) { /* Try to use realloc */ List *newPtr = NULL; int attempt = 2 * numRequired; if (attempt <= LIST_MAX) { - newPtr = Tcl_AttemptRealloc(listRepPtr, LIST_SIZE(attempt)); + newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt)); } if (newPtr == NULL) { attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH; if (attempt > LIST_MAX) { attempt = LIST_MAX; } - newPtr = Tcl_AttemptRealloc(listRepPtr, LIST_SIZE(attempt)); + newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt)); } if (newPtr == NULL) { attempt = numRequired; - newPtr = Tcl_AttemptRealloc(listRepPtr, LIST_SIZE(attempt)); + newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt)); } if (newPtr) { listRepPtr = newPtr; - ListResetIntRep(listPtr, listRepPtr); + listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr; elemPtrs = &listRepPtr->elements; listRepPtr->maxElemCount = attempt; needGrow = numRequired > listRepPtr->maxElemCount; } } @@ -1090,11 +963,11 @@ List *oldListRepPtr = listRepPtr; Tcl_Obj **oldPtrs = elemPtrs; int newMax; - if (needGrow) { + if (needGrow){ newMax = 2 * numRequired; } else { newMax = listRepPtr->maxElemCount; } @@ -1109,18 +982,22 @@ if (listRepPtr == NULL) { listRepPtr = AttemptNewList(interp, numRequired, NULL); if (listRepPtr == NULL) { for (i = 0; i < objc; i++) { /* See bug 3598580 */ +#if TCL_MAJOR_VERSION > 8 Tcl_DecrRefCount(objv[i]); +#else + objv[i]->refCount--; +#endif } return TCL_ERROR; } } } - ListResetIntRep(listPtr, listRepPtr); + listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr; listRepPtr->refCount++; elemPtrs = &listRepPtr->elements; if (isShared) { @@ -1170,11 +1047,11 @@ if (numAfterLast > 0) { memcpy(elemPtrs + first + objc, oldPtrs + start, (size_t) numAfterLast * sizeof(Tcl_Obj *)); } - Tcl_Free(oldListRepPtr); + ckfree(oldListRepPtr); } } /* * Insert the new elements into elemPtrs before "first". @@ -1189,19 +1066,14 @@ */ listRepPtr->elemCount = numRequired; /* - * Invalidate and free any old representations that may not agree - * with the revised list's internal representation. + * Invalidate and free any old string representation since it no longer + * reflects the list's internal representation. */ - listRepPtr->refCount++; - TclFreeIntRep(listPtr); - ListSetIntRep(listPtr, listRepPtr); - listRepPtr->refCount--; - TclInvalidateStringRep(listPtr); return TCL_OK; } /* @@ -1231,23 +1103,21 @@ Tcl_Interp *interp, /* Tcl interpreter. */ Tcl_Obj *listPtr, /* List being unpacked. */ Tcl_Obj *argPtr) /* Index or index list. */ { - size_t index; /* Index into the list. */ + int index; /* Index into the list. */ Tcl_Obj *indexListCopy; - List *listRepPtr; /* * Determine whether argPtr designates a list or a single index. We have * to be careful about the order of the checks to avoid repeated * shimmering; see TIP#22 and TIP#33 for the details. */ - ListGetIntRep(argPtr, listRepPtr); - if ((listRepPtr == NULL) - && TclGetIntForIndexM(NULL , argPtr, TCL_INDEX_START, &index) == TCL_OK) { + if (argPtr->typePtr != &tclListType + && TclGetIntForIndexM(NULL , argPtr, 0, &index) == TCL_OK) { /* * argPtr designates a single index. */ return TclLindexFlat(interp, listPtr, 1, &argPtr); @@ -1273,16 +1143,17 @@ */ return TclLindexFlat(interp, listPtr, 1, &argPtr); } - ListGetIntRep(indexListCopy, listRepPtr); + { + int indexCount = -1; /* Size of the array of list indices. */ + Tcl_Obj **indices = NULL; /* Array of list indices. */ - assert(listRepPtr != NULL); - - listPtr = TclLindexFlat(interp, listPtr, listRepPtr->elemCount, - &listRepPtr->elements); + TclListObjGetElements(NULL, indexListCopy, &indexCount, &indices); + listPtr = TclLindexFlat(interp, listPtr, indexCount, indices); + } Tcl_DecrRefCount(indexListCopy); return listPtr; } /* @@ -1317,12 +1188,11 @@ int i; Tcl_IncrRefCount(listPtr); for (i=0 ; i= (size_t)listLen) { + if (index<0 || index>=listLen) { /* * Index is out of range. Break out of loop with empty result. * First check remaining indices for validity */ while (++i < indexCount) { - if (TclGetIntForIndexM(interp, indexArray[i], TCL_INDEX_NONE, &index) + if (TclGetIntForIndexM(interp, indexArray[i], -1, &index) != TCL_OK) { Tcl_DecrRefCount(sublistCopy); return NULL; } } - listPtr = Tcl_NewObj(); + TclNewObj(listPtr); } else { /* * Extract the pointer to the appropriate element. */ @@ -1378,11 +1248,10 @@ * * TclLsetList -- * * The core of [lset] when objc == 4. Objv[2] may be either a * scalar index or a list of indices. - * It also handles 'lpop' when given a NULL value. * * Implemented entirely as a wrapper around 'TclLindexFlat', as described * for 'TclLindexList'. * * Value @@ -1396,28 +1265,26 @@ Tcl_Obj * TclLsetList( Tcl_Interp *interp, /* Tcl interpreter. */ Tcl_Obj *listPtr, /* Pointer to the list being modified. */ Tcl_Obj *indexArgPtr, /* Index or index-list arg to 'lset'. */ - Tcl_Obj *valuePtr) /* Value arg to 'lset' or NULL to 'lpop'. */ + Tcl_Obj *valuePtr) /* Value arg to 'lset'. */ { int indexCount = 0; /* Number of indices in the index list. */ Tcl_Obj **indices = NULL; /* Vector of indices in the index list. */ Tcl_Obj *retValuePtr; /* Pointer to the list to be returned. */ - size_t index; /* Current index in the list - discarded. */ + int index; /* Current index in the list - discarded. */ Tcl_Obj *indexListCopy; - List *listRepPtr; /* * 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 * shimmering; see TIP #22 and #23 for details. */ - ListGetIntRep(indexArgPtr, listRepPtr); - if (listRepPtr == NULL - && TclGetIntForIndexM(NULL, indexArgPtr, TCL_INDEX_START, &index) == TCL_OK) { + if (indexArgPtr->typePtr != &tclListType + && TclGetIntForIndexM(NULL, indexArgPtr, 0, &index) == TCL_OK) { /* * indexArgPtr designates a single index. */ return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr); @@ -1449,11 +1316,10 @@ *---------------------------------------------------------------------- * * TclLsetFlat -- * * Core engine of the 'lset' command. - * It also handles 'lpop' when given a NULL value. * * Value * * The resulting list * @@ -1497,27 +1363,22 @@ Tcl_Interp *interp, /* Tcl interpreter. */ Tcl_Obj *listPtr, /* Pointer to the list being modified. */ int indexCount, /* Number of index args. */ Tcl_Obj *const indexArray[], /* Index args. */ - Tcl_Obj *valuePtr) /* Value arg to 'lset' or NULL to 'lpop'. */ + Tcl_Obj *valuePtr) /* Value arg to 'lset'. */ { - size_t index; - int result, len; + int index, result, len; Tcl_Obj *subListPtr, *retValuePtr, *chainPtr; - Tcl_ObjIntRep *irPtr; /* * If there are no indices, simply return the new value. (Without * indices, [lset] is a synonym for [set]. - * [lpop] does not use this but protect for NULL valuePtr just in case. */ if (indexCount == 0) { - if (valuePtr != NULL) { - Tcl_IncrRefCount(valuePtr); - } + Tcl_IncrRefCount(valuePtr); return valuePtr; } /* * If the list is shared, make a copy we can modify (copy-on-write). We @@ -1573,18 +1434,16 @@ indexArray++; break; } indexArray++; - if (index > (size_t)elemCount - || (valuePtr == NULL && index >= (size_t)elemCount)) { + if (index < 0 || index > elemCount) { /* ...the index points outside the sublist. */ if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("list index out of range", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", - valuePtr == NULL ? "LPOP" : "LSET", + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", "BADINDEX", NULL); } result = TCL_ERROR; break; } @@ -1596,12 +1455,12 @@ * modify it. */ if (--indexCount) { parentList = subListPtr; - if (index == (size_t)elemCount) { - subListPtr = Tcl_NewObj(); + if (index == elemCount) { + TclNewObj(subListPtr); } else { subListPtr = elemPtrs[index]; } if (Tcl_IsShared(subListPtr)) { subListPtr = Tcl_DuplicateObj(subListPtr); @@ -1614,11 +1473,11 @@ * Tcl_Obj's. Dealing with the shared intrep case can cause * subListPtr to become shared again, so detect that case and make * and store another copy. */ - if (index == (size_t)elemCount) { + if (index == elemCount) { Tcl_ListObjAppendElement(NULL, parentList, subListPtr); } else { TclListObjSetElement(NULL, parentList, index, subListPtr); } if (Tcl_IsShared(subListPtr)) { @@ -1638,12 +1497,11 @@ * will need their string reps spoiled. We maintain a list of all * those Tcl_Obj's (via a little intrep surgery) so we can spoil * them at that time. */ - irPtr = TclFetchIntRep(parentList, &tclListType); - irPtr->twoPtrValue.ptr2 = chainPtr; + parentList->internalRep.twoPtrValue.ptr2 = chainPtr; chainPtr = parentList; } } while (indexCount > 0); /* @@ -1653,36 +1511,26 @@ * string spoiling list of Tcl_Obj's. */ while (chainPtr) { Tcl_Obj *objPtr = chainPtr; - List *listRepPtr; - - /* - * Clear away our intrep surgery mess. - */ - - irPtr = TclFetchIntRep(objPtr, &tclListType); - listRepPtr = irPtr->twoPtrValue.ptr1; - chainPtr = irPtr->twoPtrValue.ptr2; if (result == TCL_OK) { - /* * We're going to store valuePtr, so spoil string reps of all * containing lists. */ - listRepPtr->refCount++; - TclFreeIntRep(objPtr); - ListSetIntRep(objPtr, listRepPtr); - listRepPtr->refCount--; - TclInvalidateStringRep(objPtr); - } else { - irPtr->twoPtrValue.ptr2 = NULL; } + + /* + * Clear away our intrep surgery mess. + */ + + chainPtr = objPtr->internalRep.twoPtrValue.ptr2; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; } if (result != TCL_OK) { /* * Error return; message is already in interp. Clean up any excess @@ -1701,18 +1549,16 @@ * proper list - or something convertible to one - above). */ len = -1; TclListObjLength(NULL, subListPtr, &len); - if (valuePtr == NULL) { - Tcl_ListObjReplace(NULL, subListPtr, index, 1, 0, NULL); - } else if (index == (size_t)len) { + if (index == len) { Tcl_ListObjAppendElement(NULL, subListPtr, valuePtr); } else { TclListObjSetElement(NULL, subListPtr, index, valuePtr); - TclInvalidateStringRep(subListPtr); } + TclInvalidateStringRep(subListPtr); Tcl_IncrRefCount(retValuePtr); return retValuePtr; } /* @@ -1776,18 +1622,14 @@ */ if (Tcl_IsShared(listPtr)) { Tcl_Panic("%s called with shared object", "TclListObjSetElement"); } - - ListGetIntRep(listPtr, listRepPtr); - if (listRepPtr == NULL) { + if (listPtr->typePtr != &tclListType) { int result; - size_t length; - (void) TclGetStringFromObj(listPtr, &length); - if (length == 0) { + if (listPtr->bytes == tclEmptyStringRep) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("list index out of range", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", "BADINDEX", NULL); @@ -1796,13 +1638,13 @@ } result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } - ListGetIntRep(listPtr, listRepPtr); } + listRepPtr = ListRepPtr(listPtr); elemCount = listRepPtr->elemCount; /* * Ensure that the index is in bounds. */ @@ -1841,12 +1683,11 @@ Tcl_IncrRefCount(*dst++); } listRepPtr->refCount--; - listRepPtr = newPtr; - ListResetIntRep(listPtr, listRepPtr); + listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr = newPtr; } elemPtrs = &listRepPtr->elements; /* * Add a reference to the new list element. @@ -1864,22 +1705,10 @@ * Stash the new object in the list. */ elemPtrs[index] = valuePtr; - /* - * Invalidate outdated intreps. - */ - - ListGetIntRep(listPtr, listRepPtr); - listRepPtr->refCount++; - TclFreeIntRep(listPtr); - ListSetIntRep(listPtr, listRepPtr); - listRepPtr->refCount--; - - TclInvalidateStringRep(listPtr); - return TCL_OK; } /* *---------------------------------------------------------------------- @@ -1889,34 +1718,34 @@ * Deallocate the storage associated with the internal representation of a * a list object. * * Effect * - * Frees listPtr's List* internal representation, if no longer shared. - * May decrement the ref counts of element objects, which may free them. + * The storage for the internal 'List' pointer of 'listPtr' is freed, the + * 'internalRep.twoPtrValue.ptr1' of 'listPtr' is set to NULL, and the 'refCount' + * of each element of the list is decremented. * *---------------------------------------------------------------------- */ static void FreeListInternalRep( Tcl_Obj *listPtr) /* List object with internal rep to free. */ { - List *listRepPtr; - - ListGetIntRep(listPtr, listRepPtr); - assert(listRepPtr != NULL); + List *listRepPtr = ListRepPtr(listPtr); if (listRepPtr->refCount-- <= 1) { Tcl_Obj **elemPtrs = &listRepPtr->elements; int i, numElems = listRepPtr->elemCount; for (i = 0; i < numElems; i++) { Tcl_DecrRefCount(elemPtrs[i]); } - Tcl_Free(listRepPtr); + ckfree(listRepPtr); } + + listPtr->typePtr = NULL; } /* *---------------------------------------------------------------------- * @@ -1935,14 +1764,12 @@ static void DupListInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - List *listRepPtr; + List *listRepPtr = ListRepPtr(srcPtr); - ListGetIntRep(srcPtr, listRepPtr); - assert(listRepPtr != NULL); ListSetIntRep(copyPtr, listRepPtr); } /* *---------------------------------------------------------------------- @@ -1981,11 +1808,11 @@ * more directly. Only do this when there's no existing string rep; if * there is, it is the string rep that's authoritative (because it could * describe duplicate keys). */ - if (!TclHasStringRep(objPtr) && TclHasIntRep(objPtr, &tclDictType)) { + if (objPtr->typePtr == &tclDictType && !objPtr->bytes) { Tcl_Obj *keyPtr, *valuePtr; Tcl_DictSearch search; int done, size; /* @@ -2016,12 +1843,11 @@ Tcl_IncrRefCount(keyPtr); Tcl_IncrRefCount(valuePtr); Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done); } } else { - int estCount; - size_t length; + int estCount, length; const char *limit, *nextElem = TclGetStringFromObj(objPtr, &length); /* * Allocate enough space to hold a (Tcl_Obj *) for each * (possible) list element. @@ -2040,56 +1866,47 @@ * Each iteration, parse and store a list element. */ while (nextElem < limit) { const char *elemStart; - char *check; - size_t elemSize; - int literal; + int elemSize, literal; if (TCL_OK != TclFindElement(interp, nextElem, limit - nextElem, &elemStart, &nextElem, &elemSize, &literal)) { - fail: while (--elemPtrs >= &listRepPtr->elements) { Tcl_DecrRefCount(*elemPtrs); } - Tcl_Free(listRepPtr); + ckfree((char *) listRepPtr); return TCL_ERROR; } if (elemStart == limit) { break; } - TclNewObj(*elemPtrs); - TclInvalidateStringRep(*elemPtrs); - check = Tcl_InitStringRep(*elemPtrs, literal ? elemStart : NULL, - elemSize); - if (elemSize && check == NULL) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot construct list, out of memory", -1)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - } - goto fail; - } - if (!literal) { - Tcl_InitStringRep(*elemPtrs, NULL, - TclCopyAndCollapse(elemSize, elemStart, check)); + /* TODO: replace panic with error on alloc failure? */ + if (literal) { + TclNewStringObj(*elemPtrs, elemStart, elemSize); + } else { + TclNewObj(*elemPtrs); + (*elemPtrs)->bytes = ckalloc((unsigned) elemSize + 1); + (*elemPtrs)->length = TclCopyAndCollapse(elemSize, elemStart, + (*elemPtrs)->bytes); } Tcl_IncrRefCount(*elemPtrs++);/* Since list now holds ref to it. */ } listRepPtr->elemCount = elemPtrs - &listRepPtr->elements; } /* - * Store the new internalRep. We do this as late + * Free the old internalRep before setting the new one. We do this as late * as possible to allow the conversion code, in particular - * Tcl_GetStringFromObj, to use the old internalRep. + * Tcl_GetStringFromObj, to use that old internalRep. */ + TclFreeIntRep(objPtr); ListSetIntRep(objPtr, listRepPtr); return TCL_OK; } /* @@ -2115,22 +1932,16 @@ UpdateStringOfList( Tcl_Obj *listPtr) /* List object with string rep to update. */ { # define LOCAL_SIZE 64 char localFlags[LOCAL_SIZE], *flagPtr = NULL; - int numElems, i; - size_t length, bytesNeeded = 0; - const char *elem, *start; + List *listRepPtr = ListRepPtr(listPtr); + int numElems = listRepPtr->elemCount; + int i, length, bytesNeeded = 0; + const char *elem; char *dst; Tcl_Obj **elemPtrs; - List *listRepPtr; - - ListGetIntRep(listPtr, listRepPtr); - - assert(listRepPtr != NULL); - - numElems = listRepPtr->elemCount; /* * Mark the list as being canonical; although it will now have a string * rep, it is one we derived through proper "canonical" quoting and so * it's known to be free from nasties relating to [concat] and [eval]. @@ -2141,11 +1952,12 @@ /* * Handle empty list case first, so rest of the routine is simpler. */ if (numElems == 0) { - Tcl_InitStringRep(listPtr, NULL, 0); + listPtr->bytes = tclEmptyStringRep; + listPtr->length = 0; return; } /* * Pass 1: estimate space, gather flags. @@ -2156,38 +1968,60 @@ } else { /* * We know numElems <= LIST_MAX, so this is safe. */ - flagPtr = Tcl_Alloc(numElems); + flagPtr = ckalloc(numElems); } elemPtrs = &listRepPtr->elements; for (i = 0; i < numElems; i++) { flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0); elem = TclGetStringFromObj(elemPtrs[i], &length); bytesNeeded += TclScanElement(elem, length, flagPtr+i); + if (bytesNeeded < 0) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } + } + if (bytesNeeded > INT_MAX - numElems + 1) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } - bytesNeeded += numElems - 1; + bytesNeeded += numElems; /* * Pass 2: copy into string rep buffer. */ - start = dst = Tcl_InitStringRep(listPtr, NULL, bytesNeeded); - TclOOM(dst, bytesNeeded); + /* + * We used to set the string length here, relying on a presumed + * guarantee that the number of bytes TclScanElement() calls reported + * to be needed was a precise count and not an over-estimate, so long + * as the same flag values were passed to TclConvertElement(). + * + * Then we saw [35a8f1c04a], where a bug in TclScanElement() caused + * that guarantee to fail. Rather than trust there are no more bugs, + * we set the length after the loop based on what was actually written, + * an not on what was predicted. + * + listPtr->length = bytesNeeded - 1; + * + */ + + listPtr->bytes = ckalloc(bytesNeeded); + dst = listPtr->bytes; for (i = 0; i < numElems; i++) { flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0); elem = TclGetStringFromObj(elemPtrs[i], &length); dst += TclConvertElement(elem, length, dst, flagPtr[i]); *dst++ = ' '; } + dst[-1] = '\0'; - /* Set the string length to what was actually written, the safe choice */ - (void) Tcl_InitStringRep(listPtr, NULL, dst - 1 - start); + /* Here is the safe setting of the string length. */ + listPtr->length = dst - 1 - listPtr->bytes; if (flagPtr != localFlags) { - Tcl_Free(flagPtr); + ckfree(flagPtr); } } /* * Local Variables: Index: generic/tclLiteral.c ================================================================== --- generic/tclLiteral.c +++ generic/tclLiteral.c @@ -29,11 +29,11 @@ */ static int AddLocalLiteralEntry(CompileEnv *envPtr, Tcl_Obj *objPtr, int localHash); static void ExpandLocalLiteralArray(CompileEnv *envPtr); -static size_t HashString(const char *string, size_t length); +static unsigned HashString(const char *string, int length); #ifdef TCL_COMPILE_DEBUG static LiteralEntry * LookupLiteralEntry(Tcl_Interp *interp, Tcl_Obj *objPtr); #endif static void RebuildLiteralTable(LiteralTable *tablePtr); @@ -56,11 +56,11 @@ *---------------------------------------------------------------------- */ void TclInitLiteralTable( - register LiteralTable *tablePtr) + 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", @@ -102,11 +102,11 @@ * referenced by the table to delete. */ LiteralTable *tablePtr) /* Points to the literal table to delete. */ { LiteralEntry *entryPtr, *nextPtr; Tcl_Obj *objPtr; - size_t i; + int i; /* * Release remaining literals in the table. Note that releasing a literal * might release other literals, modifying the table, so we restart the * search from the bucket chain we last found an entry. @@ -129,21 +129,21 @@ entryPtr = tablePtr->buckets[i]; while (entryPtr != NULL) { objPtr = entryPtr->objPtr; TclDecrRefCount(objPtr); nextPtr = entryPtr->nextPtr; - Tcl_Free(entryPtr); + ckfree(entryPtr); entryPtr = nextPtr; } } /* * Free up the table's bucket array if it was dynamically allocated. */ if (tablePtr->buckets != tablePtr->staticBuckets) { - Tcl_Free(tablePtr->buckets); + ckfree(tablePtr->buckets); } } /* *---------------------------------------------------------------------- @@ -172,30 +172,30 @@ */ Tcl_Obj * TclCreateLiteral( Interp *iPtr, - const char *bytes, /* The start of the string. Note that this is + char *bytes, /* The start of the string. Note that this is * not a NUL-terminated string. */ - size_t length, /* Number of bytes in the string. */ - size_t hash, /* The string's hash. If -1, it will be + int length, /* Number of bytes in the string. */ + unsigned hash, /* The string's hash. If -1, it will be * computed here. */ int *newPtr, Namespace *nsPtr, int flags, LiteralEntry **globalPtrPtr) { LiteralTable *globalTablePtr = &iPtr->literalTable; LiteralEntry *globalPtr; - size_t globalHash; + int globalHash; Tcl_Obj *objPtr; /* * Is it in the interpreter's global literal table? */ - if (hash == TCL_AUTO_LENGTH) { + if (hash == (unsigned) -1) { hash = HashString(bytes, length); } globalHash = (hash & globalTablePtr->mask); for (globalPtr=globalTablePtr->buckets[globalHash] ; globalPtr!=NULL; globalPtr = globalPtr->nextPtr) { @@ -206,11 +206,11 @@ * is not guaranteed so we need to be careful anyway. * * https://stackoverflow.com/q/54337750/301832 */ - size_t objLength; + int objLength; char *objBytes = TclGetStringFromObj(objPtr, &objLength); if ((objLength == length) && ((length == 0) || ((objBytes[0] == bytes[0]) && (memcmp(objBytes, bytes, length) == 0)))) { @@ -223,62 +223,55 @@ } if (globalPtrPtr) { *globalPtrPtr = globalPtr; } if (flags & LITERAL_ON_HEAP) { - Tcl_Free((void *)bytes); + ckfree(bytes); } - if (globalPtr->refCount != TCL_AUTO_LENGTH) { - globalPtr->refCount++; - } + globalPtr->refCount++; return objPtr; } } } if (!newPtr) { if ((flags & LITERAL_ON_HEAP)) { - Tcl_Free((void *)bytes); + ckfree(bytes); } return NULL; } /* - * The literal is new to the interpreter. + * The literal is new to the interpreter. Add it to the global literal + * table. */ TclNewObj(objPtr); if ((flags & LITERAL_ON_HEAP)) { - objPtr->bytes = (char *) bytes; + objPtr->bytes = bytes; objPtr->length = length; } else { TclInitStringRep(objPtr, bytes, length); } - /* Should the new literal be shared globally? */ - if ((flags & LITERAL_UNSHARED)) { /* - * No, do *not* add it the global literal table * Make clear, that no global value is returned */ if (globalPtrPtr != NULL) { *globalPtrPtr = NULL; } return objPtr; } - /* - * Yes, add it to the global literal table. - */ #ifdef TCL_COMPILE_DEBUG if (LookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) { Tcl_Panic("%s: literal \"%.*s\" found globally but shouldn't be", - "TclRegisterLiteral", (length>60? 60 : (int)length), bytes); + "TclRegisterLiteral", (length>60? 60 : length), bytes); } #endif - globalPtr = Tcl_Alloc(sizeof(LiteralEntry)); + globalPtr = (LiteralEntry *)ckalloc(sizeof(LiteralEntry)); globalPtr->objPtr = objPtr; Tcl_IncrRefCount(objPtr); globalPtr->refCount = 1; globalPtr->nsPtr = nsPtr; globalPtr->nextPtr = globalTablePtr->buckets[globalHash]; @@ -296,12 +289,11 @@ #ifdef TCL_COMPILE_DEBUG TclVerifyGlobalLiteralTable(iPtr); { LiteralEntry *entryPtr; - int found; - size_t i; + int found, i; found = 0; for (i=0 ; inumBuckets ; i++) { for (entryPtr=globalTablePtr->buckets[i]; entryPtr!=NULL ; entryPtr=entryPtr->nextPtr) { @@ -310,11 +302,11 @@ } } } if (!found) { Tcl_Panic("%s: literal \"%.*s\" wasn't global", - "TclRegisterLiteral", (length>60? 60 : (int)length), bytes); + "TclRegisterLiteral", (length>60? 60 : length), bytes); } } #endif /*TCL_COMPILE_DEBUG*/ #ifdef TCL_COMPILE_STATS @@ -347,14 +339,14 @@ Tcl_Obj * TclFetchLiteral( CompileEnv *envPtr, /* Points to the CompileEnv from which to * fetch the registered literal value. */ - size_t index) /* Index of the desired literal, as returned + unsigned int index) /* Index of the desired literal, as returned * by prior call to TclRegisterLiteral() */ { - if (index >= (size_t) envPtr->literalArrayNext) { + if (index >= (unsigned int) envPtr->literalArrayNext) { return NULL; } return envPtr->literalArrayPtr[index].objPtr; } @@ -387,14 +379,14 @@ int TclRegisterLiteral( void *ePtr, /* Points to the CompileEnv in whose object * array an object is found or created. */ - register const char *bytes, /* Points to string for which to find or + char *bytes, /* Points to string for which to find or * create an object in CompileEnv's object * array. */ - size_t length, /* Number of bytes in the string. If -1, the + int length, /* Number of bytes in the string. If < 0, 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 @@ -404,15 +396,15 @@ CompileEnv *envPtr = ePtr; Interp *iPtr = envPtr->iPtr; LiteralTable *localTablePtr = &envPtr->localLitTable; LiteralEntry *globalPtr, *localPtr; Tcl_Obj *objPtr; - size_t hash, localHash, objIndex; - int new; + unsigned hash; + int localHash, objIndex, new; Namespace *nsPtr; - if (length == TCL_AUTO_LENGTH) { + if (length < 0) { length = (bytes ? strlen(bytes) : 0); } hash = HashString(bytes, length); /* @@ -426,11 +418,11 @@ objPtr = localPtr->objPtr; if ((objPtr->length == length) && ((length == 0) || ((objPtr->bytes[0] == bytes[0]) && (memcmp(objPtr->bytes, bytes, length) == 0)))) { if ((flags & LITERAL_ON_HEAP)) { - Tcl_Free((void *)bytes); + ckfree(bytes); } objIndex = (localPtr - envPtr->literalArrayPtr); #ifdef TCL_COMPILE_DEBUG TclVerifyLocalLiteralTable(envPtr); #endif /*TCL_COMPILE_DEBUG*/ @@ -464,13 +456,13 @@ objPtr = TclCreateLiteral(iPtr, bytes, length, hash, &new, nsPtr, flags, &globalPtr); objIndex = AddLocalLiteralEntry(envPtr, objPtr, localHash); #ifdef TCL_COMPILE_DEBUG - if (globalPtr != NULL && (globalPtr->refCount + 1 < 2)) { - Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %" TCL_Z_MODIFIER "u", - "TclRegisterLiteral", (length>60? 60 : (int)length), bytes, + if (globalPtr != NULL && globalPtr->refCount < 1) { + Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d", + "TclRegisterLiteral", (length>60? 60 : length), bytes, globalPtr->refCount); } TclVerifyLocalLiteralTable(envPtr); #endif /*TCL_COMPILE_DEBUG*/ return objIndex; @@ -496,19 +488,19 @@ static LiteralEntry * LookupLiteralEntry( Tcl_Interp *interp, /* Interpreter for which objPtr was created to * hold a literal. */ - register Tcl_Obj *objPtr) /* Points to a Tcl object holding a literal + Tcl_Obj *objPtr) /* Points to a Tcl object holding a literal * that was previously created by a call to * TclRegisterLiteral. */ { Interp *iPtr = (Interp *) interp; LiteralTable *globalTablePtr = &iPtr->literalTable; - register LiteralEntry *entryPtr; + LiteralEntry *entryPtr; const char *bytes; - size_t globalHash, length; + int length, globalHash; bytes = TclGetStringFromObj(objPtr, &length); globalHash = (HashString(bytes, length) & globalTablePtr->mask); for (entryPtr=globalTablePtr->buckets[globalHash] ; entryPtr!=NULL; entryPtr=entryPtr->nextPtr) { @@ -542,18 +534,18 @@ void TclHideLiteral( Tcl_Interp *interp, /* Interpreter for which objPtr was created to * hold a literal. */ - register CompileEnv *envPtr,/* Points to CompileEnv whose literal array + CompileEnv *envPtr,/* Points to CompileEnv whose literal array * contains the entry being hidden. */ int index) /* The index of the entry in the literal * array. */ { LiteralEntry **nextPtrPtr, *entryPtr, *lPtr; LiteralTable *localTablePtr = &envPtr->localLitTable; - size_t localHash, length; + int localHash, length; const char *bytes; Tcl_Obj *newObjPtr; lPtr = &envPtr->literalArrayPtr[index]; @@ -568,11 +560,11 @@ Tcl_IncrRefCount(newObjPtr); TclReleaseLiteral(interp, lPtr->objPtr); lPtr->objPtr = newObjPtr; bytes = TclGetStringFromObj(newObjPtr, &length); - localHash = HashString(bytes, length) & localTablePtr->mask; + localHash = (HashString(bytes, length) & localTablePtr->mask); nextPtrPtr = &localTablePtr->buckets[localHash]; for (entryPtr=*nextPtrPtr ; entryPtr!=NULL ; entryPtr=*nextPtrPtr) { if (entryPtr == lPtr) { *nextPtrPtr = lPtr->nextPtr; @@ -605,18 +597,18 @@ *---------------------------------------------------------------------- */ int TclAddLiteralObj( - register CompileEnv *envPtr,/* Points to CompileEnv in whose literal array + CompileEnv *envPtr,/* Points to CompileEnv in whose literal array * the object is to be inserted. */ Tcl_Obj *objPtr, /* The object to insert into the array. */ LiteralEntry **litPtrPtr) /* The location where the pointer to the new * literal entry should be stored. May be * NULL. */ { - register LiteralEntry *lPtr; + LiteralEntry *lPtr; int objIndex; if (envPtr->literalArrayNext >= envPtr->literalArrayEnd) { ExpandLocalLiteralArray(envPtr); } @@ -624,11 +616,11 @@ envPtr->literalArrayNext++; lPtr = &envPtr->literalArrayPtr[objIndex]; lPtr->objPtr = objPtr; Tcl_IncrRefCount(objPtr); - lPtr->refCount = TCL_AUTO_LENGTH; /* i.e., unused */ + lPtr->refCount = -1; /* i.e., unused */ lPtr->nextPtr = NULL; if (litPtrPtr) { *litPtrPtr = lPtr; } @@ -654,16 +646,16 @@ *---------------------------------------------------------------------- */ static int AddLocalLiteralEntry( - register CompileEnv *envPtr,/* Points to CompileEnv in whose literal array + CompileEnv *envPtr,/* Points to CompileEnv in whose literal array * the object is to be inserted. */ Tcl_Obj *objPtr, /* The literal to add to the CompileEnv. */ int localHash) /* Hash value for the literal's string. */ { - register LiteralTable *localTablePtr = &envPtr->localLitTable; + LiteralTable *localTablePtr = &envPtr->localLitTable; LiteralEntry *localPtr; int objIndex; objIndex = TclAddLiteralObj(envPtr, objPtr, &localPtr); @@ -686,12 +678,11 @@ #ifdef TCL_COMPILE_DEBUG TclVerifyLocalLiteralTable(envPtr); { char *bytes; - int found; - size_t length, i; + int length, found, i; found = 0; for (i=0 ; inumBuckets ; i++) { for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL ; localPtr=localPtr->nextPtr) { @@ -700,13 +691,13 @@ } } } if (!found) { - bytes = TclGetStringFromObj(objPtr, &length); + bytes = Tcl_GetStringFromObj(objPtr, &length); Tcl_Panic("%s: literal \"%.*s\" wasn't found locally", - "AddLocalLiteralEntry", (length>60? 60 : (int)length), bytes); + "AddLocalLiteralEntry", (length>60? 60 : length), bytes); } } #endif /*TCL_COMPILE_DEBUG*/ return objIndex; @@ -732,40 +723,40 @@ *---------------------------------------------------------------------- */ static void ExpandLocalLiteralArray( - register CompileEnv *envPtr)/* Points to the CompileEnv whose object array + CompileEnv *envPtr)/* Points to the CompileEnv whose object array * must be enlarged. */ { /* * The current allocated local literal entries are stored between elements * 0 and (envPtr->literalArrayNext - 1) [inclusive]. */ LiteralTable *localTablePtr = &envPtr->localLitTable; - size_t currElems = envPtr->literalArrayNext; + int currElems = envPtr->literalArrayNext; size_t currBytes = (currElems * sizeof(LiteralEntry)); LiteralEntry *currArrayPtr = envPtr->literalArrayPtr; LiteralEntry *newArrayPtr; - size_t i; - size_t newSize = (currBytes <= UINT_MAX / 2) ? 2*currBytes : UINT_MAX; + int i; + unsigned int newSize = (currBytes <= UINT_MAX / 2) ? 2*currBytes : UINT_MAX; if (currBytes == newSize) { - Tcl_Panic("max size of Tcl literal array (%" TCL_Z_MODIFIER "u literals) exceeded", + Tcl_Panic("max size of Tcl literal array (%d literals) exceeded", currElems); } if (envPtr->mallocedLiteralArray) { - newArrayPtr = Tcl_Realloc(currArrayPtr, newSize); + newArrayPtr = (LiteralEntry *)ckrealloc(currArrayPtr, newSize); } else { /* - * envPtr->literalArrayPtr isn't a Tcl_Alloc'd pointer, so we must - * code a Tcl_Realloc equivalent for ourselves. + * envPtr->literalArrayPtr isn't a ckalloc'd pointer, so we must + * code a ckrealloc equivalent for ourselves. */ - newArrayPtr = Tcl_Alloc(newSize); + newArrayPtr = (LiteralEntry *)ckalloc(newSize); memcpy(newArrayPtr, currArrayPtr, currBytes); envPtr->mallocedLiteralArray = 1; } /* @@ -814,27 +805,27 @@ void TclReleaseLiteral( Tcl_Interp *interp, /* Interpreter for which objPtr was created to * hold a literal. */ - register Tcl_Obj *objPtr) /* Points to a literal object that was + Tcl_Obj *objPtr) /* Points to a literal object that was * previously created by a call to * TclRegisterLiteral. */ { Interp *iPtr = (Interp *) interp; LiteralTable *globalTablePtr; - register LiteralEntry *entryPtr, *prevPtr; + LiteralEntry *entryPtr, *prevPtr; const char *bytes; - size_t length, index; + int length, index; if (iPtr == NULL) { goto done; } globalTablePtr = &iPtr->literalTable; bytes = TclGetStringFromObj(objPtr, &length); - index = HashString(bytes, length) & globalTablePtr->mask; + index = (HashString(bytes, length) & globalTablePtr->mask); /* * Check to see if the object is in the global literal table and remove * this reference. The object may not be in the table if it is a hidden * local literal. @@ -841,23 +832,25 @@ */ for (prevPtr=NULL, entryPtr=globalTablePtr->buckets[index]; entryPtr!=NULL ; prevPtr=entryPtr, entryPtr=entryPtr->nextPtr) { if (entryPtr->objPtr == objPtr) { + entryPtr->refCount--; + /* * If the literal is no longer being used by any ByteCode, delete * the entry then remove the reference corresponding to the global * literal table entry (decrement the ref count of the object). */ - if ((entryPtr->refCount != TCL_AUTO_LENGTH) && (entryPtr->refCount-- <= 1)) { + if (entryPtr->refCount == 0) { if (prevPtr == NULL) { globalTablePtr->buckets[index] = entryPtr->nextPtr; } else { prevPtr->nextPtr = entryPtr->nextPtr; } - Tcl_Free(entryPtr); + ckfree(entryPtr); globalTablePtr->numEntries--; TclDecrRefCount(objPtr); #ifdef TCL_COMPILE_STATS @@ -891,16 +884,16 @@ * None. * *---------------------------------------------------------------------- */ -static size_t +static unsigned HashString( - register const char *string, /* String for which to compute hash value. */ - size_t length) /* Number of bytes in the string. */ + const char *string, /* String for which to compute hash value. */ + int length) /* Number of bytes in the string. */ { - register size_t result = 0; + unsigned int result = 0; /* * I tried a zillion different hash functions and asked many other people * for advice. Many people had their own favorite functions, all * different, but no-one had much idea why they were good ones. I chose @@ -957,19 +950,20 @@ *---------------------------------------------------------------------- */ static void RebuildLiteralTable( - register LiteralTable *tablePtr) + LiteralTable *tablePtr) /* Local or global table to enlarge. */ { LiteralEntry **oldBuckets; - register LiteralEntry **oldChainPtr, **newChainPtr; - register LiteralEntry *entryPtr; + LiteralEntry **oldChainPtr, **newChainPtr; + LiteralEntry *entryPtr; LiteralEntry **bucketPtr; const char *bytes; - size_t oldSize, count, index, length; + unsigned int oldSize; + int count, index, length; oldSize = tablePtr->numBuckets; oldBuckets = tablePtr->buckets; /* @@ -986,11 +980,12 @@ return; } tablePtr->numBuckets *= 4; - tablePtr->buckets = Tcl_Alloc(tablePtr->numBuckets * sizeof(LiteralEntry*)); + tablePtr->buckets = (LiteralEntry **)ckalloc( + tablePtr->numBuckets * sizeof(LiteralEntry *)); for (count=tablePtr->numBuckets, newChainPtr=tablePtr->buckets; count>0 ; count--, newChainPtr++) { *newChainPtr = NULL; } tablePtr->rebuildSize *= 4; @@ -1015,11 +1010,11 @@ /* * Free up the old bucket array, if it was dynamically allocated. */ if (oldBuckets != tablePtr->staticBuckets) { - Tcl_Free(oldBuckets); + ckfree(oldBuckets); } } /* *---------------------------------------------------------------------- @@ -1051,15 +1046,15 @@ * name. */ Namespace *nsPtr) /* The namespace for which to lookup and * invalidate a cmd literal. */ { Interp *iPtr = (Interp *) interp; - Tcl_Obj *literalObjPtr = TclCreateLiteral(iPtr, name, + Tcl_Obj *literalObjPtr = TclCreateLiteral(iPtr, (char *) name, strlen(name), -1, NULL, nsPtr, 0, NULL); if (literalObjPtr != NULL) { - if (TclHasIntRep(literalObjPtr, &tclCmdNameType)) { + if (literalObjPtr->typePtr == &tclCmdNameType) { TclFreeIntRep(literalObjPtr); } /* Balance the refcount effects of TclCreateLiteral() above */ Tcl_IncrRefCount(literalObjPtr); TclReleaseLiteral(interp, literalObjPtr); @@ -1088,13 +1083,13 @@ char * TclLiteralStats( LiteralTable *tablePtr) /* Table for which to produce stats. */ { #define NUM_COUNTERS 10 - size_t count[NUM_COUNTERS], overflow, i, j; + int count[NUM_COUNTERS], overflow, i, j; double average, tmp; - register LiteralEntry *entryPtr; + LiteralEntry *entryPtr; char *result, *p; /* * Compute a histogram of bucket usage. For each bucket chain i, j is the * number of entries in the chain. @@ -1122,20 +1117,20 @@ /* * Print out the histogram and a few other pieces of information. */ - result = Tcl_Alloc(NUM_COUNTERS*60 + 300); - sprintf(result, "%" TCL_Z_MODIFIER "u entries in table, %" TCL_Z_MODIFIER "u buckets\n", + result = (char *)ckalloc(NUM_COUNTERS*60 + 300); + sprintf(result, "%d entries in table, %d buckets\n", tablePtr->numEntries, tablePtr->numBuckets); p = result + strlen(result); for (i=0 ; ilocalLitTable; - register LiteralEntry *localPtr; + LiteralTable *localTablePtr = &envPtr->localLitTable; + LiteralEntry *localPtr; char *bytes; - size_t i, length, count = 0; + int i; + int length, count; + count = 0; for (i=0 ; inumBuckets ; i++) { for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL; localPtr=localPtr->nextPtr) { count++; - if (localPtr->refCount != TCL_AUTO_LENGTH) { - bytes = TclGetStringFromObj(localPtr->objPtr, &length); - Tcl_Panic("%s: local literal \"%.*s\" had bad refCount %" TCL_Z_MODIFIER "u", + if (localPtr->refCount != -1) { + bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length); + Tcl_Panic("%s: local literal \"%.*s\" had bad refCount %d", "TclVerifyLocalLiteralTable", - (length>60? 60 : (int) length), bytes, localPtr->refCount); + (length>60? 60 : length), bytes, localPtr->refCount); } if (localPtr->objPtr->bytes == NULL) { Tcl_Panic("%s: literal has NULL string rep", "TclVerifyLocalLiteralTable"); } } } if (count != localTablePtr->numEntries) { - Tcl_Panic("%s: local literal table had %" TCL_Z_MODIFIER "u entries, should be %" TCL_Z_MODIFIER "u", + Tcl_Panic("%s: local literal table had %d entries, should be %d", "TclVerifyLocalLiteralTable", count, localTablePtr->numEntries); } } @@ -1210,33 +1207,35 @@ void TclVerifyGlobalLiteralTable( Interp *iPtr) /* Points to interpreter whose global literal * table is to be validated. */ { - register LiteralTable *globalTablePtr = &iPtr->literalTable; - register LiteralEntry *globalPtr; + LiteralTable *globalTablePtr = &iPtr->literalTable; + LiteralEntry *globalPtr; char *bytes; - size_t i, length, count = 0; + int i; + int length, count; + count = 0; for (i=0 ; inumBuckets ; i++) { for (globalPtr=globalTablePtr->buckets[i] ; globalPtr!=NULL; globalPtr=globalPtr->nextPtr) { count++; - if (globalPtr->refCount + 1 < 2) { - bytes = TclGetStringFromObj(globalPtr->objPtr, &length); - Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %" TCL_Z_MODIFIER "u", + if (globalPtr->refCount < 1) { + bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length); + Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d", "TclVerifyGlobalLiteralTable", - (length>60? 60 : (int)length), bytes, globalPtr->refCount); + (length>60? 60 : length), bytes, globalPtr->refCount); } if (globalPtr->objPtr->bytes == NULL) { Tcl_Panic("%s: literal has NULL string rep", "TclVerifyGlobalLiteralTable"); } } } if (count != globalTablePtr->numEntries) { - Tcl_Panic("%s: global literal table had %" TCL_Z_MODIFIER "u entries, should be %" TCL_Z_MODIFIER "u", + Tcl_Panic("%s: global literal table had %d entries, should be %d", "TclVerifyGlobalLiteralTable", count, globalTablePtr->numEntries); } } #endif /*TCL_COMPILE_DEBUG*/ Index: generic/tclLoad.c ================================================================== --- generic/tclLoad.c +++ generic/tclLoad.c @@ -129,11 +129,11 @@ const char *symbols[2]; Tcl_PackageInitProc *initProc; const char *p, *fullFileName, *packageName; Tcl_LoadHandle loadHandle; Tcl_UniChar ch = 0; - size_t len; + unsigned len; int index, flags = 0; Tcl_Obj *const *savedobjv = objv; static const char *const options[] = { "-global", "-lazy", "--", NULL }; @@ -163,11 +163,11 @@ return TCL_ERROR; } if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) { return TCL_ERROR; } - fullFileName = TclGetString(objv[1]); + fullFileName = Tcl_GetString(objv[1]); Tcl_DStringInit(&pkgName); Tcl_DStringInit(&initName); Tcl_DStringInit(&safeInitName); Tcl_DStringInit(&unloadName); @@ -174,11 +174,11 @@ Tcl_DStringInit(&safeUnloadName); Tcl_DStringInit(&tmp); packageName = NULL; if (objc >= 3) { - packageName = TclGetString(objv[2]); + packageName = Tcl_GetString(objv[2]); if (packageName[0] == '\0') { packageName = NULL; } } if ((fullFileName[0] == 0) && (packageName == NULL)) { @@ -194,13 +194,13 @@ * Figure out which interpreter we're going to load the package into. */ target = interp; if (objc == 4) { - const char *slaveIntName = TclGetString(objv[3]); + const char *childIntName = Tcl_GetString(objv[3]); - target = Tcl_GetSlave(interp, slaveIntName); + target = Tcl_GetChild(interp, childIntName); if (target == NULL) { code = TCL_ERROR; goto done; } } @@ -322,11 +322,11 @@ * that. */ splitPtr = Tcl_FSSplitPath(objv[1], &pElements); Tcl_ListObjIndex(NULL, splitPtr, pElements -1, &pkgGuessPtr); - pkgGuess = TclGetString(pkgGuessPtr); + pkgGuess = Tcl_GetString(pkgGuessPtr); if ((pkgGuess[0] == 'l') && (pkgGuess[1] == 'i') && (pkgGuess[2] == 'b')) { pkgGuess += 3; } #ifdef __CYGWIN__ @@ -399,16 +399,16 @@ /* * Create a new record to describe this package. */ - pkgPtr = Tcl_Alloc(sizeof(LoadedPackage)); + pkgPtr = ckalloc(sizeof(LoadedPackage)); len = strlen(fullFileName) + 1; - pkgPtr->fileName = Tcl_Alloc(len); + pkgPtr->fileName = ckalloc(len); memcpy(pkgPtr->fileName, fullFileName, len); - len = Tcl_DStringLength(&pkgName) + 1; - pkgPtr->packageName = Tcl_Alloc(len); + len = (unsigned) Tcl_DStringLength(&pkgName) + 1; + pkgPtr->packageName = ckalloc(len); memcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName), len); pkgPtr->loadHandle = loadHandle; pkgPtr->initProc = initProc; pkgPtr->safeInitProc = (Tcl_PackageInitProc *) Tcl_FindSymbol(interp, loadHandle, @@ -468,21 +468,10 @@ * Test for whether the initialization failed. If so, transfer the error * from the target interpreter to the originating one. */ if (code != TCL_OK) { - Interp *iPtr = (Interp *) target; - if (iPtr->legacyResult && *(iPtr->legacyResult) && !iPtr->legacyFreeProc) { - /* - * A call to Tcl_InitStubs() determined the caller extension and - * this interp are incompatible in their stubs mechanisms, and - * recorded the error in the oldest legacy place we have to do so. - */ - Tcl_SetObjResult(target, Tcl_NewStringObj(iPtr->legacyResult, -1)); - iPtr->legacyResult = NULL; - iPtr->legacyFreeProc = (void (*) (void))-1; - } Tcl_TransferResult(target, code, interp); goto done; } /* @@ -504,11 +493,11 @@ * Refetch ipFirstPtr: loading the package may have introduced additional * static packages at the head of the linked list! */ ipFirstPtr = Tcl_GetAssocData(target, "tclLoad", NULL); - ipPtr = Tcl_Alloc(sizeof(InterpPackage)); + ipPtr = ckalloc(sizeof(InterpPackage)); ipPtr->pkgPtr = pkgPtr; ipPtr->nextPtr = ipFirstPtr; Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipPtr); done: @@ -562,11 +551,11 @@ }; for (i = 1; i < objc; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) != TCL_OK) { - fullFileName = TclGetString(objv[i]); + fullFileName = Tcl_GetString(objv[i]); if (fullFileName[0] == '-') { /* * It looks like the command contains an option so signal an * error */ @@ -602,17 +591,17 @@ } if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) { return TCL_ERROR; } - fullFileName = TclGetString(objv[i]); + fullFileName = Tcl_GetString(objv[i]); Tcl_DStringInit(&pkgName); Tcl_DStringInit(&tmp); packageName = NULL; if (objc - i >= 2) { - packageName = TclGetString(objv[i+1]); + packageName = Tcl_GetString(objv[i+1]); if (packageName[0] == '\0') { packageName = NULL; } } if ((fullFileName[0] == 0) && (packageName == NULL)) { @@ -628,13 +617,13 @@ * Figure out which interpreter we're going to load the package into. */ target = interp; if (objc - i == 3) { - const char *slaveIntName = TclGetString(objv[i + 2]); + const char *childIntName = Tcl_GetString(objv[i + 2]); - target = Tcl_GetSlave(interp, slaveIntName); + target = Tcl_GetChild(interp, childIntName); if (target == NULL) { return TCL_ERROR; } } @@ -880,22 +869,22 @@ } else { InterpPackage *ipPrevPtr; for (ipPrevPtr = ipPtr; ipPtr != NULL; ipPrevPtr = ipPtr, ipPtr = ipPtr->nextPtr) { - if (ipPtr->pkgPtr == pkgPtr) { + if (ipPtr->pkgPtr == defaultPtr) { ipPrevPtr->nextPtr = ipPtr->nextPtr; break; } } } Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipFirstPtr); - Tcl_Free(defaultPtr->fileName); - Tcl_Free(defaultPtr->packageName); - Tcl_Free(defaultPtr); - Tcl_Free(ipPtr); + ckfree(defaultPtr->fileName); + ckfree(defaultPtr->packageName); + ckfree(defaultPtr); + ckfree(ipPtr); Tcl_MutexUnlock(&packageMutex); } else { code = TCL_ERROR; } } @@ -978,14 +967,14 @@ * If the package is not yet recorded as being loaded statically, add it * to the list now. */ if (pkgPtr == NULL) { - pkgPtr = Tcl_Alloc(sizeof(LoadedPackage)); - pkgPtr->fileName = Tcl_Alloc(1); + pkgPtr = ckalloc(sizeof(LoadedPackage)); + pkgPtr->fileName = ckalloc(1); pkgPtr->fileName[0] = 0; - pkgPtr->packageName = Tcl_Alloc(strlen(pkgName) + 1); + pkgPtr->packageName = ckalloc(strlen(pkgName) + 1); strcpy(pkgPtr->packageName, pkgName); pkgPtr->loadHandle = NULL; pkgPtr->initProc = initProc; pkgPtr->safeInitProc = safeInitProc; Tcl_MutexLock(&packageMutex); @@ -1007,28 +996,28 @@ return; } } /* - * Package isn't loaded in the current interp yet. Mark it as now being + * Package isn't loade in the current interp yet. Mark it as now being * loaded. */ - ipPtr = Tcl_Alloc(sizeof(InterpPackage)); + ipPtr = ckalloc(sizeof(InterpPackage)); ipPtr->pkgPtr = pkgPtr; ipPtr->nextPtr = ipFirstPtr; Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc, ipPtr); } } /* *---------------------------------------------------------------------- * - * TclGetLoadedPackages, TclGetLoadedPackagesEx -- + * TclGetLoadedPackages -- * * This function returns information about all of the files that are - * loaded (either in a particular interpreter, or for all interpreters). + * loaded (either in a particular intepreter, or for all interpreters). * * Results: * The return value is a standard Tcl completion code. If successful, a * list of lists is placed in the interp's result. Each sublist * corresponds to one loaded file; its first element is the name of the @@ -1048,32 +1037,21 @@ const char *targetName) /* Name of target interpreter or NULL. If * NULL, return info about all interps; * otherwise, just return info about this * interpreter. */ { - return TclGetLoadedPackagesEx(interp, targetName, NULL); -} - -int -TclGetLoadedPackagesEx( - Tcl_Interp *interp, /* Interpreter in which to return information - * or error message. */ - const char *targetName, /* Name of target interpreter or NULL. If - * NULL, return info about all interps; - * otherwise, just return info about this - * interpreter. */ - const char *packageName) /* Package name or NULL. If NULL, return info - * for all packages. - */ -{ Tcl_Interp *target; LoadedPackage *pkgPtr; InterpPackage *ipPtr; Tcl_Obj *resultObj, *pkgDesc[2]; if (targetName == NULL) { - resultObj = Tcl_NewObj(); + /* + * Return information about all of the available packages. + */ + + TclNewObj(resultObj); Tcl_MutexLock(&packageMutex); for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { pkgDesc[0] = Tcl_NewStringObj(pkgPtr->fileName, -1); pkgDesc[1] = Tcl_NewStringObj(pkgPtr->packageName, -1); @@ -1083,43 +1061,21 @@ Tcl_MutexUnlock(&packageMutex); Tcl_SetObjResult(interp, resultObj); return TCL_OK; } - target = Tcl_GetSlave(interp, targetName); - if (target == NULL) { - return TCL_ERROR; - } - ipPtr = Tcl_GetAssocData(target, "tclLoad", NULL); - - /* - * Return information about all of the available packages. - */ - if (packageName) { - resultObj = NULL; - - for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { - pkgPtr = ipPtr->pkgPtr; - - if (!strcmp(packageName, pkgPtr->packageName)) { - resultObj = Tcl_NewStringObj(pkgPtr->fileName, -1); - break; - } - } - - if (resultObj) { - Tcl_SetObjResult(interp, resultObj); - } - return TCL_OK; - } - /* * Return information about only the packages that are loaded in a given * interpreter. */ - resultObj = Tcl_NewObj(); + target = Tcl_GetChild(interp, targetName); + if (target == NULL) { + return TCL_ERROR; + } + ipPtr = Tcl_GetAssocData(target, "tclLoad", NULL); + TclNewObj(resultObj); for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { pkgPtr = ipPtr->pkgPtr; pkgDesc[0] = Tcl_NewStringObj(pkgPtr->fileName, -1); pkgDesc[1] = Tcl_NewStringObj(pkgPtr->packageName, -1); Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewListObj(2, pkgDesc)); @@ -1155,11 +1111,11 @@ InterpPackage *ipPtr, *nextPtr; ipPtr = clientData; while (ipPtr != NULL) { nextPtr = ipPtr->nextPtr; - Tcl_Free(ipPtr); + ckfree(ipPtr); ipPtr = nextPtr; } } /* @@ -1206,13 +1162,13 @@ if (pkgPtr->fileName[0] != '\0') { Tcl_FSUnloadFile(NULL, pkgPtr->loadHandle); } #endif - Tcl_Free(pkgPtr->fileName); - Tcl_Free(pkgPtr->packageName); - Tcl_Free(pkgPtr); + ckfree(pkgPtr->fileName); + ckfree(pkgPtr->packageName); + ckfree(pkgPtr); } } /* * Local Variables: Index: generic/tclMain.c ================================================================== --- generic/tclMain.c +++ generic/tclMain.c @@ -15,25 +15,15 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* - * On Windows, this file needs to be compiled twice, once with TCL_ASCII_MAIN - * defined. This way both Tcl_MainEx and Tcl_MainExW can be implemented, sharing - * the same source code. + * On Windows, this file needs to be compiled twice, once with UNICODE and + * _UNICODE defined. This way both Tcl_Main and Tcl_MainExW can be + * implemented, sharing the same source code. */ -#if defined(TCL_ASCII_MAIN) -# ifdef UNICODE -# undef UNICODE -# undef _UNICODE -# else -# define UNICODE -# define _UNICODE -# endif -#endif - #include "tclInt.h" /* * The default prompt used when the user has not overridden it. */ @@ -51,37 +41,23 @@ # define TCHAR char # define TEXT(arg) arg # define _tcscmp strcmp #endif -/* - * Further on, in UNICODE mode we just use Tcl_NewUnicodeObj, otherwise - * NewNativeObj is needed (which provides proper conversion from native - * encoding to UTF-8). - */ - -#if defined(UNICODE) && (TCL_UTF_MAX <= 4) -# define NewNativeObj Tcl_NewUnicodeObj -#else /* !UNICODE || (TCL_UTF_MAX > 4) */ static inline Tcl_Obj * NewNativeObj( - TCHAR *string, - size_t length) + TCHAR *string) { Tcl_DString ds; #ifdef UNICODE - if (length > 0) { - length *= sizeof(WCHAR); - } - Tcl_WinTCharToUtf(string, length, &ds); + Tcl_WinTCharToUtf(string, -1, &ds); #else - Tcl_ExternalToUtfDString(NULL, (char *) string, length, &ds); + Tcl_ExternalToUtfDString(NULL, (char *) string, -1, &ds); #endif return TclDStringToObj(&ds); } -#endif /* !UNICODE || (TCL_UTF_MAX > 4) */ /* * Declarations for various library functions and variables (don't want to * include tclPort.h here, because people might copy this file out of the Tcl * source directory to make their own modified versions). @@ -117,11 +93,11 @@ PROMPT_NONE, /* Print no prompt */ PROMPT_START, /* Print prompt for command start */ PROMPT_CONTINUE /* Print prompt for command continuation */ } PromptType; -typedef struct { +typedef struct InteractiveState { Tcl_Channel input; /* The standard input channel from which lines * are read. */ int tty; /* Non-zero means standard input is a * terminal-like device. Zero means it's a * file. */ @@ -139,11 +115,11 @@ MODULE_SCOPE Tcl_MainLoopProc *TclGetMainLoop(void); static void Prompt(Tcl_Interp *interp, InteractiveState *isPtr); static void StdinProc(ClientData clientData, int mask); static void FreeMainInterp(ClientData clientData); -#ifndef TCL_ASCII_MAIN +#if !defined(_WIN32) || defined(UNICODE) && !defined(TCL_ASCII_MAIN) static Tcl_ThreadDataKey dataKey; /* *---------------------------------------------------------------------- * @@ -220,11 +196,11 @@ if (encodingPtr != NULL) { if (tsdPtr->encoding == NULL) { *encodingPtr = NULL; } else { - *encodingPtr = TclGetString(tsdPtr->encoding); + *encodingPtr = Tcl_GetString(tsdPtr->encoding); } } return tsdPtr->path; } @@ -251,11 +227,11 @@ { Tcl_DString temp; const char *fileName; Tcl_Channel chan; - fileName = Tcl_GetVar2(interp, "tcl_rcFileName", NULL, TCL_GLOBAL_ONLY); + fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY); if (fileName != NULL) { Tcl_Channel c; const char *fullName; Tcl_DStringInit(&temp); @@ -284,15 +260,15 @@ } } Tcl_DStringFree(&temp); } } -#endif /* !TCL_ASCII_MAIN */ +#endif /* !UNICODE */ /*---------------------------------------------------------------------- * - * Tcl_MainEx -- + * Tcl_Main, Tcl_MainEx -- * * Main program for tclsh and most other Tcl-based applications. * * Results: * None. This function never returns (it exits the process when it's @@ -304,11 +280,11 @@ * interpreted. * *---------------------------------------------------------------------- */ -TCL_NORETURN void +void Tcl_MainEx( int argc, /* Number of arguments. */ TCHAR **argv, /* Array of argument strings. */ Tcl_AppInitProc *appInitProc, /* Application-specific initialization @@ -328,11 +304,11 @@ Tcl_InitMemory(interp); is.interp = interp; is.prompt = PROMPT_START; - is.commandPtr = Tcl_NewObj(); + TclNewObj(is.commandPtr); /* * If the application has not already set a startup script, parse the * first few command line arguments to determine the script path and * encoding. @@ -346,26 +322,26 @@ * FILENAME */ if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1])) && ('-' != argv[3][0])) { - Tcl_Obj *value = NewNativeObj(argv[2], -1); - Tcl_SetStartupScript(NewNativeObj(argv[3], -1), - TclGetString(value)); + Tcl_Obj *value = NewNativeObj(argv[2]); + Tcl_SetStartupScript(NewNativeObj(argv[3]), + Tcl_GetString(value)); Tcl_DecrRefCount(value); argc -= 3; argv += 3; } else if ((argc > 1) && ('-' != argv[1][0])) { - Tcl_SetStartupScript(NewNativeObj(argv[1], -1), NULL); + Tcl_SetStartupScript(NewNativeObj(argv[1]), NULL); argc--; argv++; } } path = Tcl_GetStartupScript(&encodingName); if (path == NULL) { - appName = NewNativeObj(argv[0], -1); + appName = NewNativeObj(argv[0]); } else { appName = path; } Tcl_SetVar2Ex(interp, "argv0", NULL, appName, TCL_GLOBAL_ONLY); argc--; @@ -373,11 +349,11 @@ Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc), TCL_GLOBAL_ONLY); argvPtr = Tcl_NewListObj(0, NULL); while (argc--) { - Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(*argv++, -1)); + Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(*argv++)); } Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY); /* * Set the "tcl_interactive" variable. @@ -472,11 +448,11 @@ Tcl_LinkVar(interp, "tcl_interactive", (char *) &is.tty, TCL_LINK_BOOLEAN); is.input = Tcl_GetStdChannel(TCL_STDIN); while ((is.input != NULL) && !Tcl_InterpDeleted(interp)) { mainLoopProc = TclGetMainLoop(); if (mainLoopProc == NULL) { - size_t length; + int length; if (is.tty) { Prompt(interp, &is); if (Tcl_InterpDeleted(interp)) { break; @@ -493,11 +469,11 @@ Tcl_DecrRefCount(is.commandPtr); is.commandPtr = Tcl_DuplicateObj(is.commandPtr); Tcl_IncrRefCount(is.commandPtr); } length = Tcl_GetsObj(is.input, is.commandPtr); - if (length == TCL_AUTO_LENGTH) { + if (length < 0) { if (Tcl_InputBlocked(is.input)) { /* * This can only happen if stdin has been set to * non-blocking. In that case cycle back and try again. * This sets up a tight polling loop (since we have no @@ -537,17 +513,17 @@ /* * The final newline is syntactically redundant, and causes some * error messages troubles deeper in, so lop it back off. */ - (void)TclGetStringFromObj(is.commandPtr, &length); + Tcl_GetStringFromObj(is.commandPtr, &length); Tcl_SetObjLength(is.commandPtr, --length); code = Tcl_RecordAndEvalObj(interp, is.commandPtr, TCL_EVAL_GLOBAL); is.input = Tcl_GetStdChannel(TCL_STDIN); Tcl_DecrRefCount(is.commandPtr); - is.commandPtr = Tcl_NewObj(); + TclNewObj(is.commandPtr); Tcl_IncrRefCount(is.commandPtr); if (code != TCL_OK) { chan = Tcl_GetStdChannel(TCL_STDERR); if (chan) { Tcl_WriteObj(chan, Tcl_GetObjResult(interp)); @@ -554,11 +530,11 @@ Tcl_WriteChars(chan, "\n", 1); } } else if (is.tty) { resultPtr = Tcl_GetObjResult(interp); Tcl_IncrRefCount(resultPtr); - (void)TclGetStringFromObj(resultPtr, &length); + Tcl_GetStringFromObj(resultPtr, &length); chan = Tcl_GetStdChannel(TCL_STDOUT); if ((length > 0) && chan) { Tcl_WriteObj(chan, resultPtr); Tcl_WriteChars(chan, "\n", 1); } @@ -639,12 +615,27 @@ * cleanup and exit. */ Tcl_Exit(exitCode); } + +#if (TCL_MAJOR_VERSION == 8) && !defined(UNICODE) +#undef Tcl_Main +extern DLLEXPORT void +Tcl_Main( + int argc, /* Number of arguments. */ + char **argv, /* Array of argument strings. */ + Tcl_AppInitProc *appInitProc) + /* Application-specific initialization + * function to call after most initialization + * but before starting to execute commands. */ +{ + Tcl_MainEx(argc, argv, appInitProc, Tcl_CreateInterp()); +} +#endif /* TCL_MAJOR_VERSION == 8 && !UNICODE */ -#ifndef TCL_ASCII_MAIN +#if !defined(_WIN32) || defined(UNICODE) /* *--------------------------------------------------------------- * * Tcl_SetMainLoop -- @@ -731,11 +722,11 @@ Tcl_DStringFree(&ds); } return finalize; #endif /* PURIFY */ } -#endif /* !TCL_ASCII_MAIN */ +#endif /* UNICODE */ /* *---------------------------------------------------------------------- * * StdinProc -- @@ -758,12 +749,11 @@ static void StdinProc( ClientData clientData, /* The state of interactive cmd line */ int mask) /* Not used. */ { - int code; - size_t length; + int code, length; InteractiveState *isPtr = clientData; Tcl_Channel chan = isPtr->input; Tcl_Obj *commandPtr = isPtr->commandPtr; Tcl_Interp *interp = isPtr->interp; @@ -771,11 +761,11 @@ Tcl_DecrRefCount(commandPtr); commandPtr = Tcl_DuplicateObj(commandPtr); Tcl_IncrRefCount(commandPtr); } length = Tcl_GetsObj(chan, commandPtr); - if (length == TCL_AUTO_LENGTH) { + if (length < 0) { if (Tcl_InputBlocked(chan)) { return; } if (isPtr->tty) { /* @@ -799,11 +789,11 @@ if (!TclObjCommandComplete(commandPtr)) { isPtr->prompt = PROMPT_CONTINUE; goto prompt; } isPtr->prompt = PROMPT_START; - (void)TclGetStringFromObj(commandPtr, &length); + Tcl_GetStringFromObj(commandPtr, &length); Tcl_SetObjLength(commandPtr, --length); /* * Disable the stdin channel handler while evaluating the command; * otherwise if the command re-enters the event loop we might process @@ -813,11 +803,12 @@ Tcl_CreateChannelHandler(chan, 0, StdinProc, isPtr); code = Tcl_RecordAndEvalObj(interp, commandPtr, TCL_EVAL_GLOBAL); isPtr->input = chan = Tcl_GetStdChannel(TCL_STDIN); Tcl_DecrRefCount(commandPtr); - isPtr->commandPtr = commandPtr = Tcl_NewObj(); + TclNewObj(commandPtr); + isPtr->commandPtr = commandPtr; Tcl_IncrRefCount(commandPtr); if (chan != NULL) { Tcl_CreateChannelHandler(chan, TCL_READABLE, StdinProc, isPtr); } if (code != TCL_OK) { @@ -830,11 +821,11 @@ } else if (isPtr->tty) { Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); chan = Tcl_GetStdChannel(TCL_STDOUT); Tcl_IncrRefCount(resultPtr); - (void)TclGetStringFromObj(resultPtr, &length); + Tcl_GetStringFromObj(resultPtr, &length); if ((length > 0) && (chan != NULL)) { Tcl_WriteObj(chan, resultPtr); Tcl_WriteChars(chan, "\n", 1); } Tcl_DecrRefCount(resultPtr); Index: generic/tclNamesp.c ================================================================== --- generic/tclNamesp.c +++ generic/tclNamesp.c @@ -23,19 +23,18 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclCompile.h" /* for TclLogCommandInfo visibility */ -#include /* * Thread-local storage used to avoid having a global lock on data that is not * limited to a single interpreter. */ -typedef struct { - size_t numNsCreated; /* Count of the number of namespaces created +typedef struct ThreadSpecificData { + long numNsCreated; /* Count of the number of namespaces created * within the thread. This value is used as a * unique id for each namespace. Cannot be * per-interp because the nsId is used to * distinguish objects which can be passed * around between interps in the same thread, @@ -51,18 +50,18 @@ * of resolving the namespace's name in some other namespace. It is the * internal representation for a nsName object. It contains the pointer along * with some information that is used to check the cached pointer's validity. */ -typedef struct { +typedef struct ResolvedNsName { Namespace *nsPtr; /* A cached pointer to the Namespace that the * name resolved to. */ Namespace *refNsPtr; /* Points to the namespace context in which * the name was resolved. NULL if the name is * fully qualified and thus the resolution * does not depend on the context. */ - size_t refCount; /* Reference count: 1 for each nsName object + int refCount; /* Reference count: 1 for each nsName object * that has a pointer to this ResolvedNsName * structure as its internal rep. This * structure can be freed when refCount * becomes zero. */ } ResolvedNsName; @@ -88,10 +87,12 @@ Tcl_Interp *interp, const char *name1, const char *name2, int flags); static void FreeNsNameInternalRep(Tcl_Obj *objPtr); static int GetNamespaceFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); +static int InvokeImportedCmd(ClientData clientData, + Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int InvokeImportedNRCmd(ClientData clientData, Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int NamespaceChildrenCmd(ClientData dummy, Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int NamespaceCodeCmd(ClientData dummy, Tcl_Interp *interp, @@ -151,26 +152,10 @@ DupNsNameInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ SetNsNameFromAny /* setFromAnyProc */ }; -#define NsNameSetIntRep(objPtr, nnPtr) \ - do { \ - Tcl_ObjIntRep ir; \ - (nnPtr)->refCount++; \ - ir.twoPtrValue.ptr1 = (nnPtr); \ - ir.twoPtrValue.ptr2 = NULL; \ - Tcl_StoreIntRep((objPtr), &nsNameType, &ir); \ - } while (0) - -#define NsNameGetIntRep(objPtr, nnPtr) \ - do { \ - const Tcl_ObjIntRep *irPtr; \ - irPtr = TclFetchIntRep((objPtr), &nsNameType); \ - (nnPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ - } while (0) - /* * Array of values describing how to implement each standard subcommand of the * "namespace" command. */ @@ -238,11 +223,11 @@ *---------------------------------------------------------------------- */ Tcl_Namespace * Tcl_GetCurrentNamespace( - register Tcl_Interp *interp)/* Interpreter whose current namespace is + Tcl_Interp *interp)/* Interpreter whose current namespace is * being queried. */ { return TclGetCurrentNamespace(interp); } @@ -262,11 +247,11 @@ *---------------------------------------------------------------------- */ Tcl_Namespace * Tcl_GetGlobalNamespace( - register Tcl_Interp *interp)/* Interpreter whose global namespace should + Tcl_Interp *interp)/* Interpreter whose global namespace should * be returned. */ { return TclGetGlobalNamespace(interp); } @@ -314,12 +299,12 @@ * inscope" command and var references are * treated as references to namespace * variables. */ { Interp *iPtr = (Interp *) interp; - register CallFrame *framePtr = (CallFrame *) callFramePtr; - register Namespace *nsPtr; + CallFrame *framePtr = (CallFrame *) callFramePtr; + Namespace *nsPtr; if (namespacePtr == NULL) { nsPtr = (Namespace *) TclGetCurrentNamespace(interp); } else { nsPtr = (Namespace *) namespacePtr; @@ -391,12 +376,12 @@ void Tcl_PopCallFrame( Tcl_Interp *interp) /* Interpreter with call frame to pop. */ { - register Interp *iPtr = (Interp *) interp; - register CallFrame *framePtr = iPtr->framePtr; + Interp *iPtr = (Interp *) interp; + CallFrame *framePtr = iPtr->framePtr; Namespace *nsPtr; /* * It's important to remove the call frame from the interpreter's stack of * call frames before deleting local variables, so that traces invoked by @@ -410,16 +395,16 @@ /* Tcl_PopCallFrame: trying to pop rootCallFrame! */ } if (framePtr->varTablePtr != NULL) { TclDeleteVars(iPtr, framePtr->varTablePtr); - Tcl_Free(framePtr->varTablePtr); + ckfree(framePtr->varTablePtr); framePtr->varTablePtr = NULL; } if (framePtr->numCompiledLocals > 0) { TclDeleteCompiledLocalVars(iPtr, framePtr); - if (framePtr->localCachePtr->refCount-- <= 1) { + if (--framePtr->localCachePtr->refCount == 0) { TclFreeLocalCache(interp, framePtr->localCachePtr); } framePtr->localCachePtr = NULL; } @@ -428,12 +413,13 @@ * is "dying" and there are no more active call frames, call * Tcl_DeleteNamespace to destroy it. */ nsPtr = framePtr->nsPtr; - if ((--nsPtr->activationCount <= (unsigned)(nsPtr == iPtr->globalNsPtr)) - && (nsPtr->flags & NS_DYING)) { + nsPtr->activationCount--; + if ((nsPtr->flags & NS_DYING) + && (nsPtr->activationCount - (nsPtr == iPtr->globalNsPtr) == 0)) { Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr); } framePtr->nsPtr = NULL; if (framePtr->tailcallPtr) { @@ -676,19 +662,18 @@ /* Function called to delete client data when * the namespace is deleted. NULL if no * function should be called. */ { Interp *iPtr = (Interp *) interp; - register Namespace *nsPtr, *ancestorPtr; + Namespace *nsPtr, *ancestorPtr; Namespace *parentPtr, *dummy1Ptr, *dummy2Ptr; Namespace *globalNsPtr = iPtr->globalNsPtr; const char *simpleName; Tcl_HashEntry *entryPtr; Tcl_DString buffer1, buffer2; Tcl_DString *namePtr, *buffPtr; - int newEntry; - size_t nameLen; + int newEntry, nameLen; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); const char *nameStr; Tcl_DString tmpBuffer; Tcl_DStringInit(&tmpBuffer); @@ -783,13 +768,13 @@ * Create the new namespace and root it in its parent. Increment the count * of namespaces created. */ doCreate: - nsPtr = Tcl_Alloc(sizeof(Namespace)); + nsPtr = ckalloc(sizeof(Namespace)); nameLen = strlen(simpleName) + 1; - nsPtr->name = Tcl_Alloc(nameLen); + nsPtr->name = ckalloc(nameLen); memcpy(nsPtr->name, simpleName, nameLen); nsPtr->fullName = NULL; /* Set below. */ nsPtr->clientData = clientData; nsPtr->deleteProc = deleteProc; nsPtr->parentPtr = parentPtr; @@ -846,11 +831,11 @@ namePtr = &buffer1; buffPtr = &buffer2; for (ancestorPtr = nsPtr; ancestorPtr != NULL; ancestorPtr = ancestorPtr->parentPtr) { if (ancestorPtr != globalNsPtr) { - register Tcl_DString *tempPtr = namePtr; + Tcl_DString *tempPtr = namePtr; TclDStringAppendLiteral(buffPtr, "::"); Tcl_DStringAppend(buffPtr, ancestorPtr->name, -1); TclDStringAppendDString(buffPtr, namePtr); @@ -873,11 +858,11 @@ } } name = Tcl_DStringValue(namePtr); nameLen = Tcl_DStringLength(namePtr); - nsPtr->fullName = Tcl_Alloc(nameLen + 1); + nsPtr->fullName = ckalloc(nameLen + 1); memcpy(nsPtr->fullName, name, nameLen + 1); Tcl_DStringFree(&buffer1); Tcl_DStringFree(&buffer2); Tcl_DStringFree(&tmpBuffer); @@ -920,11 +905,11 @@ void Tcl_DeleteNamespace( Tcl_Namespace *namespacePtr)/* Points to the namespace to delete. */ { - register Namespace *nsPtr = (Namespace *) namespacePtr; + Namespace *nsPtr = (Namespace *) namespacePtr; Interp *iPtr = (Interp *) nsPtr->interp; Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace((Tcl_Interp *) iPtr); Tcl_HashEntry *entryPtr; Tcl_HashSearch search; @@ -1021,11 +1006,11 @@ * namespace resolution code to recognize that the namespace is "deleted". * The structure's storage is freed by FreeNsNameInternalRep when its * refCount reaches 0. */ - if (nsPtr->activationCount > (unsigned)(nsPtr == globalNsPtr)) { + if (nsPtr->activationCount - (nsPtr == globalNsPtr) > 0) { nsPtr->flags |= NS_DYING; if (nsPtr->parentPtr != NULL) { entryPtr = Tcl_FindHashEntry( TclGetNamespaceChildTable((Tcl_Namespace *) nsPtr->parentPtr), nsPtr->name); @@ -1060,11 +1045,11 @@ #ifndef BREAK_NAMESPACE_COMPAT Tcl_DeleteHashTable(&nsPtr->childTable); #else if (nsPtr->childTablePtr != NULL) { Tcl_DeleteHashTable(nsPtr->childTablePtr); - Tcl_Free(nsPtr->childTablePtr); + ckfree(nsPtr->childTablePtr); } #endif Tcl_DeleteHashTable(&nsPtr->cmdTable); nsPtr ->flags |= NS_DEAD; @@ -1116,17 +1101,17 @@ *---------------------------------------------------------------------- */ void TclTeardownNamespace( - register Namespace *nsPtr) /* Points to the namespace to be dismantled + Namespace *nsPtr) /* Points to the namespace to be dismantled * and unlinked from its parent. */ { Interp *iPtr = (Interp *) nsPtr->interp; - register Tcl_HashEntry *entryPtr; + Tcl_HashEntry *entryPtr; Tcl_HashSearch search; - size_t i; + int i; /* * Start by destroying the namespace's variable table, since variables * might trigger traces. Variable table should be cleared but not freed! * TclDeleteNamespaceVars frees it, so we reinitialize it afterwards. @@ -1143,11 +1128,11 @@ * f97d4ee020]) we copy to a temporary array and then delete all those * commands. */ while (nsPtr->cmdTable.numEntries > 0) { - size_t length = nsPtr->cmdTable.numEntries; + int length = nsPtr->cmdTable.numEntries; Command **cmds = TclStackAlloc((Tcl_Interp *) iPtr, sizeof(Command *) * length); i = 0; for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); @@ -1215,11 +1200,11 @@ * Important: leave the hash table itself still live. */ #ifndef BREAK_NAMESPACE_COMPAT while (nsPtr->childTable.numEntries > 0) { - size_t length = nsPtr->childTable.numEntries; + int length = nsPtr->childTable.numEntries; Namespace **children = TclStackAlloc((Tcl_Interp *) iPtr, sizeof(Namespace *) * length); i = 0; for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); @@ -1236,11 +1221,11 @@ TclStackFree((Tcl_Interp *) iPtr, children); } #else if (nsPtr->childTablePtr != NULL) { while (nsPtr->childTablePtr->numEntries > 0) { - size_t length = nsPtr->childTablePtr->numEntries; + int length = nsPtr->childTablePtr->numEntries; Namespace **children = TclStackAlloc((Tcl_Interp *) iPtr, sizeof(Namespace *) * length); i = 0; for (entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search); @@ -1263,13 +1248,13 @@ * Free the namespace's export pattern array. */ if (nsPtr->exportArrayPtr != NULL) { for (i = 0; i < nsPtr->numExportPatterns; i++) { - Tcl_Free(nsPtr->exportArrayPtr[i]); + ckfree(nsPtr->exportArrayPtr[i]); } - Tcl_Free(nsPtr->exportArrayPtr); + ckfree(nsPtr->exportArrayPtr); nsPtr->exportArrayPtr = NULL; nsPtr->numExportPatterns = 0; nsPtr->maxExportPatterns = 0; } @@ -1309,21 +1294,21 @@ *---------------------------------------------------------------------- */ static void NamespaceFree( - register Namespace *nsPtr) /* Points to the namespace to free. */ + Namespace *nsPtr) /* Points to the namespace to free. */ { /* * Most of the namespace's contents are freed when the namespace is * deleted by Tcl_DeleteNamespace. All that remains is to free its names * (for error messages), and the structure itself. */ - Tcl_Free(nsPtr->name); - Tcl_Free(nsPtr->fullName); - Tcl_Free(nsPtr); + ckfree(nsPtr->name); + ckfree(nsPtr->fullName); + ckfree(nsPtr); } /* *---------------------------------------------------------------------- * @@ -1343,11 +1328,12 @@ void TclNsDecrRefCount( Namespace *nsPtr) { - if ((nsPtr->refCount-- <= 1) && (nsPtr->flags & NS_DEAD)) { + nsPtr->refCount--; + if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) { NamespaceFree(nsPtr); } } /* @@ -1388,11 +1374,11 @@ #define INIT_EXPORT_PATTERNS 5 Namespace *nsPtr, *exportNsPtr, *dummyPtr; Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); const char *simplePattern; char *patternCpy; - size_t neededElems, len, i; + int neededElems, len, i; /* * If the specified namespace is NULL, use the current namespace. */ @@ -1408,13 +1394,13 @@ */ if (resetListFirst) { if (nsPtr->exportArrayPtr != NULL) { for (i = 0; i < nsPtr->numExportPatterns; i++) { - Tcl_Free(nsPtr->exportArrayPtr[i]); + ckfree(nsPtr->exportArrayPtr[i]); } - Tcl_Free(nsPtr->exportArrayPtr); + ckfree(nsPtr->exportArrayPtr); nsPtr->exportArrayPtr = NULL; TclInvalidateNsCmdLookup(nsPtr); nsPtr->numExportPatterns = 0; nsPtr->maxExportPatterns = 0; } @@ -1457,20 +1443,20 @@ neededElems = nsPtr->numExportPatterns + 1; if (neededElems > nsPtr->maxExportPatterns) { nsPtr->maxExportPatterns = nsPtr->maxExportPatterns ? 2 * nsPtr->maxExportPatterns : INIT_EXPORT_PATTERNS; - nsPtr->exportArrayPtr = Tcl_Realloc(nsPtr->exportArrayPtr, + nsPtr->exportArrayPtr = ckrealloc(nsPtr->exportArrayPtr, sizeof(char *) * nsPtr->maxExportPatterns); } /* * Add the pattern to the namespace's array of export patterns. */ len = strlen(pattern); - patternCpy = Tcl_Alloc(len + 1); + patternCpy = ckalloc(len + 1); memcpy(patternCpy, pattern, len + 1); nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy; nsPtr->numExportPatterns++; @@ -1515,12 +1501,11 @@ * for the current namespace. */ Tcl_Obj *objPtr) /* Points to the Tcl object onto which the * export pattern list is appended. */ { Namespace *nsPtr; - size_t i; - int result; + int i, result; /* * If the specified namespace is NULL, use the current namespace. */ @@ -1585,11 +1570,11 @@ * return an error if an imported cmd * conflicts with an existing one. */ { Namespace *nsPtr, *importNsPtr, *dummyPtr; const char *simplePattern; - register Tcl_HashEntry *hPtr; + Tcl_HashEntry *hPtr; Tcl_HashSearch search; /* * If the specified namespace is NULL, use the current namespace. */ @@ -1718,11 +1703,11 @@ const char *cmdName, const char *pattern, Namespace *importNsPtr, int allowOverwrite) { - size_t i = 0, exported = 0; + int i = 0, exported = 0; Tcl_HashEntry *found; /* * The command cmdName in the source namespace matches the pattern. Check * whether it was exported. If it wasn't, we ignore it. @@ -1785,13 +1770,13 @@ return TCL_ERROR; } } } - dataPtr = Tcl_Alloc(sizeof(ImportedCmdData)); + dataPtr = ckalloc(sizeof(ImportedCmdData)); importedCmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), - TclInvokeImportedCmd, InvokeImportedNRCmd, dataPtr, + InvokeImportedCmd, InvokeImportedNRCmd, dataPtr, DeleteImportedCmd); dataPtr->realCmdPtr = cmdPtr; dataPtr->selfPtr = (Command *) importedCmd; dataPtr->selfPtr->compileProc = cmdPtr->compileProc; Tcl_DStringFree(&ds); @@ -1799,11 +1784,11 @@ /* * Create an ImportRef structure describing this new import command * and add it to the import ref list in the "real" command. */ - refPtr = Tcl_Alloc(sizeof(ImportRef)); + refPtr = ckalloc(sizeof(ImportRef)); refPtr->importedCmdPtr = (Command *) importedCmd; refPtr->nextPtr = cmdPtr->importRefPtr; cmdPtr->importRefPtr = refPtr; } else { Command *overwrite = Tcl_GetHashValue(found); @@ -1864,11 +1849,11 @@ * commands to remove. */ { Namespace *nsPtr, *sourceNsPtr, *dummyPtr; const char *simplePattern; char *cmdName; - register Tcl_HashEntry *hPtr; + Tcl_HashEntry *hPtr; Tcl_HashSearch search; /* * If the specified namespace is NULL, use the current namespace. */ @@ -1991,11 +1976,11 @@ Tcl_Command TclGetOriginalCommand( Tcl_Command command) /* The imported command for which the original * command should be returned. */ { - register Command *cmdPtr = (Command *) command; + Command *cmdPtr = (Command *) command; ImportedCmdData *dataPtr; if (cmdPtr->deleteProc != DeleteImportedCmd) { return NULL; } @@ -2008,11 +1993,11 @@ } /* *---------------------------------------------------------------------- * - * TclInvokeImportedCmd -- + * InvokeImportedCmd -- * * Invoked by Tcl whenever the user calls an imported command that was * created by Tcl_Import. Finds the "real" command (in another * namespace), and passes control to it. * @@ -2039,12 +2024,12 @@ TclSkipTailcall(interp); return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR, realCmdPtr); } -int -TclInvokeImportedCmd( +static int +InvokeImportedCmd( ClientData clientData, /* Points to the imported command's * ImportedCmdData structure. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -2080,11 +2065,11 @@ * ImportedCmdData structure. */ { ImportedCmdData *dataPtr = clientData; Command *realCmdPtr = dataPtr->realCmdPtr; Command *selfPtr = dataPtr->selfPtr; - register ImportRef *refPtr, *prevPtr; + ImportRef *refPtr, *prevPtr; prevPtr = NULL; for (refPtr = realCmdPtr->importRefPtr; refPtr != NULL; refPtr = refPtr->nextPtr) { if (refPtr->importedCmdPtr == selfPtr) { @@ -2096,12 +2081,12 @@ if (prevPtr == NULL) { /* refPtr is first in list. */ realCmdPtr->importRefPtr = refPtr->nextPtr; } else { prevPtr->nextPtr = refPtr->nextPtr; } - Tcl_Free(refPtr); - Tcl_Free(dataPtr); + ckfree(refPtr); + ckfree(dataPtr); return; } prevPtr = refPtr; } @@ -2500,11 +2485,11 @@ Tcl_Namespace *contextNsPtr,/* Ignored if TCL_GLOBAL_ONLY flag is set or * if the name starts with "::". Otherwise, * points to namespace in which to resolve * name; if NULL, look up name in the current * namespace. */ - register int flags) /* Flags controlling namespace lookup: an OR'd + int flags) /* Flags controlling namespace lookup: an OR'd * combination of TCL_GLOBAL_ONLY and * TCL_LEAVE_ERR_MSG flags. */ { Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; const char *dummy; @@ -2571,12 +2556,12 @@ * and TCL_NAMESPACE_ONLY are given, * TCL_GLOBAL_ONLY is ignored. */ { Interp *iPtr = (Interp *) interp; Namespace *cxtNsPtr; - register Tcl_HashEntry *entryPtr; - register Command *cmdPtr; + Tcl_HashEntry *entryPtr; + Command *cmdPtr; const char *simpleName; int result; /* * If this namespace has a command resolver, then give it first crack at @@ -2627,11 +2612,11 @@ */ cmdPtr = NULL; if (cxtNsPtr->commandPathLength!=0 && strncmp(name, "::", 2) && !(flags & TCL_NAMESPACE_ONLY)) { - size_t i; + int i; Namespace *pathNsPtr, *realNsPtr, *dummyNsPtr; (void) TclGetNamespaceForQualName(interp, name, cxtNsPtr, TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr, &simpleName); @@ -2683,11 +2668,11 @@ } } } } else { Namespace *nsPtr[2]; - register int search; + int search; TclGetNamespaceForQualName(interp, name, cxtNsPtr, flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); /* @@ -2757,11 +2742,11 @@ Tcl_Interp *interp, /* Interpreter containing the new command. */ Command *newCmdPtr) /* Points to the new command. */ { char *cmdName; Tcl_HashEntry *hPtr; - register Namespace *nsPtr; + Namespace *nsPtr; Namespace *trailNsPtr, *shadowNsPtr; Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace(interp); int found, i; int trailFront = -1; int trailSize = 5; /* Formerly NUM_TRAIL_ELEMS. */ @@ -2921,33 +2906,30 @@ Tcl_Obj *objPtr, /* The object to be resolved as the name of a * namespace. */ Tcl_Namespace **nsPtrPtr) /* Result namespace pointer goes here. */ { ResolvedNsName *resNamePtr; + Namespace *nsPtr, *refNsPtr; - NsNameGetIntRep(objPtr, resNamePtr); - if (resNamePtr) { - Namespace *nsPtr, *refNsPtr; - + if (objPtr->typePtr == &nsNameType) { /* * Check that the ResolvedNsName is still valid; avoid letting the ref * cross interps. */ + resNamePtr = objPtr->internalRep.twoPtrValue.ptr1; nsPtr = resNamePtr->nsPtr; refNsPtr = resNamePtr->refNsPtr; - if (!(nsPtr->flags & NS_DYING) && (interp == nsPtr->interp) - && (!refNsPtr || (refNsPtr == - (Namespace *) TclGetCurrentNamespace(interp)))) { + if (!(nsPtr->flags & NS_DYING) && (interp == nsPtr->interp) && + (!refNsPtr || ((interp == refNsPtr->interp) && + (refNsPtr== (Namespace *) Tcl_GetCurrentNamespace(interp))))){ *nsPtrPtr = (Tcl_Namespace *) nsPtr; return TCL_OK; } - Tcl_StoreIntRep(objPtr, &nsNameType, NULL); } if (SetNsNameFromAny(interp, objPtr) == TCL_OK) { - NsNameGetIntRep(objPtr, resNamePtr); - assert(resNamePtr != NULL); + resNamePtr = objPtr->internalRep.twoPtrValue.ptr1; *nsPtrPtr = (Tcl_Namespace *) resNamePtr->nsPtr; return TCL_OK; } return TCL_ERROR; } @@ -3007,11 +2989,11 @@ Tcl_Namespace *namespacePtr; Namespace *nsPtr, *childNsPtr; Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace(interp); const char *pattern = NULL; Tcl_DString buffer; - register Tcl_HashEntry *entryPtr; + Tcl_HashEntry *entryPtr; Tcl_HashSearch search; Tcl_Obj *listPtr, *elemPtr; /* * Get a pointer to the specified namespace, or the current namespace. @@ -3054,11 +3036,11 @@ * names match the specified pattern, if any. */ listPtr = Tcl_NewListObj(0, NULL); if ((pattern != NULL) && TclMatchIsTrivial(pattern)) { - size_t length = strlen(nsPtr->fullName); + unsigned int length = strlen(nsPtr->fullName); if (strncmp(pattern, nsPtr->fullName, length) != 0) { goto searchDone; } if ( @@ -3133,12 +3115,12 @@ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Namespace *currNsPtr; Tcl_Obj *listPtr, *objPtr; - register const char *arg; - size_t length; + const char *arg; + int length; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "arg"); return TCL_ERROR; } @@ -3212,11 +3194,11 @@ ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - register Namespace *currNsPtr; + Namespace *currNsPtr; if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } @@ -3277,11 +3259,11 @@ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Namespace *namespacePtr; const char *name; - register int i; + int i; if (objc < 1) { Tcl_WrongNumArgs(interp, 1, objv, "?name name...?"); return TCL_ERROR; } @@ -3447,19 +3429,19 @@ int result) { Tcl_Namespace *namespacePtr = data[0]; if (result == TCL_ERROR) { - size_t length = strlen(namespacePtr->fullName); - unsigned limit = 200; + int length = strlen(namespacePtr->fullName); + int limit = 200; int overflow = (length > limit); char *cmd = data[1]; Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (in namespace %s \"%.*s%s\" script line %d)", cmd, - (overflow ? limit : (unsigned)length), namespacePtr->fullName, + (overflow ? limit : length), namespacePtr->fullName, (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } /* * Restore the previous "current" namespace. @@ -3563,12 +3545,13 @@ * If no pattern arguments are given, and "-clear" isn't specified, return * the namespace's current export pattern list. */ if (objc == 1) { - Tcl_Obj *listPtr = Tcl_NewObj(); + Tcl_Obj *listPtr; + TclNewObj(listPtr); (void) Tcl_AppendExportList(interp, NULL, listPtr); Tcl_SetObjResult(interp, listPtr); return TCL_OK; } @@ -3575,11 +3558,11 @@ /* * Process the optional "-clear" argument. */ firstArg = 1; - if (strcmp("-clear", TclGetString(objv[firstArg])) == 0) { + if (strcmp("-clear", Tcl_GetString(objv[firstArg])) == 0) { Tcl_Export(interp, NULL, "::", 1); Tcl_ResetResult(interp); firstArg++; } @@ -3586,11 +3569,11 @@ /* * Add each pattern to the namespace's export pattern list. */ for (i = firstArg; i < objc; i++) { - int result = Tcl_Export(interp, NULL, TclGetString(objv[i]), 0); + int result = Tcl_Export(interp, NULL, Tcl_GetString(objv[i]), 0); if (result != TCL_OK) { return result; } } return TCL_OK; @@ -3632,11 +3615,11 @@ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *pattern; - register int i, result; + int i, result; if (objc < 1) { Tcl_WrongNumArgs(interp, 1, objv, "?pattern pattern...?"); return TCL_ERROR; } @@ -3698,11 +3681,11 @@ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int allowOverwrite = 0; const char *string, *pattern; - register int i, result; + int i, result; int firstArg; if (objc < 1) { Tcl_WrongNumArgs(interp, 1, objv, "?-force? ?pattern pattern...?"); return TCL_ERROR; @@ -3851,11 +3834,11 @@ if (objc == 3) { cmdObjPtr = objv[2]; } else { Tcl_Obj *concatObjv[2]; - register Tcl_Obj *listPtr; + Tcl_Obj *listPtr; listPtr = Tcl_NewListObj(0, NULL); for (i = 3; i < objc; i++) { if (Tcl_ListObjAppendElement(interp, listPtr, objv[i]) != TCL_OK){ Tcl_DecrRefCount(listPtr); /* Free unneeded obj. */ @@ -4028,12 +4011,11 @@ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp); - size_t i; - int nsObjc, result = TCL_ERROR; + int i, nsObjc, result = TCL_ERROR; Tcl_Obj **nsObjv; Tcl_Namespace **namespaceList = NULL; if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "?pathList?"); @@ -4043,12 +4025,13 @@ /* * If no path is given, return the current path. */ if (objc == 1) { - Tcl_Obj *resultObj = Tcl_NewObj(); + Tcl_Obj *resultObj; + TclNewObj(resultObj); for (i=0 ; icommandPathLength ; i++) { if (nsPtr->commandPathArray[i].nsPtr != NULL) { Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj( nsPtr->commandPathArray[i].nsPtr->fullName, -1)); } @@ -4066,11 +4049,11 @@ } if (nsObjc != 0) { namespaceList = TclStackAlloc(interp, sizeof(Tcl_Namespace *) * nsObjc); - for (i=0 ; i<(size_t)nsObjc ; i++) { + for (i=0 ; icommandPathLength ; i++) { NamespacePathEntry *nsPathPtr = &nsPtr->commandPathArray[i]; if (nsPathPtr->prevPtr != NULL) { nsPathPtr->prevPtr->nextPtr = nsPathPtr->nextPtr; @@ -4184,11 +4167,11 @@ if (nsPathPtr->nsPtr->commandPathSourceList == nsPathPtr) { nsPathPtr->nsPtr->commandPathSourceList = nsPathPtr->nextPtr; } } } - Tcl_Free(nsPtr->commandPathArray); + ckfree(nsPtr->commandPathArray); } /* *---------------------------------------------------------------------- * @@ -4253,12 +4236,12 @@ ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - register const char *name, *p; - size_t length; + const char *name, *p; + int length; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "string"); return TCL_ERROR; } @@ -4508,11 +4491,11 @@ ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - register const char *name, *p; + const char *name, *p; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "string"); return TCL_ERROR; } @@ -4711,33 +4694,32 @@ *---------------------------------------------------------------------- */ static void FreeNsNameInternalRep( - register Tcl_Obj *objPtr) /* nsName object with internal representation + Tcl_Obj *objPtr) /* nsName object with internal representation * to free. */ { - ResolvedNsName *resNamePtr; - - NsNameGetIntRep(objPtr, resNamePtr); - assert(resNamePtr != NULL); + ResolvedNsName *resNamePtr = objPtr->internalRep.twoPtrValue.ptr1; /* * Decrement the reference count of the namespace. If there are no more * references, free it up. */ - if (resNamePtr->refCount-- <= 1) { + resNamePtr->refCount--; + if (resNamePtr->refCount == 0) { /* * Decrement the reference count for the cached namespace. If the * namespace is dead, and there are no more references to it, free * it. */ TclNsDecrRefCount(resNamePtr->nsPtr); - Tcl_Free(resNamePtr); + ckfree(resNamePtr); } + objPtr->typePtr = NULL; } /* *---------------------------------------------------------------------- * @@ -4758,17 +4740,17 @@ */ static void DupNsNameInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ - register Tcl_Obj *copyPtr) /* Object with internal rep to set. */ + Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - ResolvedNsName *resNamePtr; + ResolvedNsName *resNamePtr = srcPtr->internalRep.twoPtrValue.ptr1; - NsNameGetIntRep(srcPtr, resNamePtr); - assert(resNamePtr != NULL); - NsNameSetIntRep(copyPtr, resNamePtr); + copyPtr->internalRep.twoPtrValue.ptr1 = resNamePtr; + resNamePtr->refCount++; + copyPtr->typePtr = &nsNameType; } /* *---------------------------------------------------------------------- * @@ -4794,15 +4776,15 @@ static int SetNsNameFromAny( Tcl_Interp *interp, /* Points to the namespace in which to resolve * name. Also used for error reporting if not * NULL. */ - register Tcl_Obj *objPtr) /* The object to convert. */ + Tcl_Obj *objPtr) /* The object to convert. */ { const char *dummy; Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; - register ResolvedNsName *resNamePtr; + ResolvedNsName *resNamePtr; const char *name; if (interp == NULL) { return TCL_ERROR; } @@ -4809,29 +4791,40 @@ name = TclGetString(objPtr); TclGetNamespaceForQualName(interp, name, NULL, TCL_FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); - if ((nsPtr == NULL) || (nsPtr->flags & NS_DYING)) { - return TCL_ERROR; - } - /* * If we found a namespace, then create a new ResolvedNsName structure * that holds a reference to it. */ + + if ((nsPtr == NULL) || (nsPtr->flags & NS_DYING)) { + /* + * Our failed lookup proves any previously cached nsName intrep is no + * longer valid. Get rid of it so we no longer waste memory storing + * it, nor time determining its invalidity again and again. + */ + + if (objPtr->typePtr == &nsNameType) { + TclFreeIntRep(objPtr); + } + return TCL_ERROR; + } nsPtr->refCount++; - resNamePtr = Tcl_Alloc(sizeof(ResolvedNsName)); + resNamePtr = ckalloc(sizeof(ResolvedNsName)); resNamePtr->nsPtr = nsPtr; if ((name[0] == ':') && (name[1] == ':')) { resNamePtr->refNsPtr = NULL; } else { - resNamePtr->refNsPtr = (Namespace *) TclGetCurrentNamespace(interp); + resNamePtr->refNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); } - resNamePtr->refCount = 0; - NsNameSetIntRep(objPtr, resNamePtr); + resNamePtr->refCount = 1; + TclFreeIntRep(objPtr); + objPtr->internalRep.twoPtrValue.ptr1 = resNamePtr; + objPtr->typePtr = &nsNameType; return TCL_OK; } /* *---------------------------------------------------------------------- @@ -4879,11 +4872,11 @@ Namespace *nPtr = (Namespace *) nsPtr; #ifndef BREAK_NAMESPACE_COMPAT return &nPtr->childTable; #else if (nPtr->childTablePtr == NULL) { - nPtr->childTablePtr = Tcl_Alloc(sizeof(Tcl_HashTable)); + nPtr->childTablePtr = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(nPtr->childTablePtr, TCL_STRING_KEYS); } return nPtr->childTablePtr; #endif } @@ -4915,17 +4908,17 @@ Tcl_Interp *interp, /* Interpreter in which to log information. */ const char *script, /* First character in script containing * command (must be <= command). */ const char *command, /* First character in command that generated * the error. */ - size_t length, /* Number of bytes in command (-1 means - * use all bytes up to first null byte). */ + int length, /* Number of bytes in command (-1 means use + * all bytes up to first null byte). */ const unsigned char *pc, /* Current pc of bytecode execution context */ Tcl_Obj **tosPtr) /* Current stack of bytecode execution * context */ { - register const char *p; + const char *p; Interp *iPtr = (Interp *) interp; int overflow, limit = 150; Var *varPtr, *arrayPtr; if (iPtr->flags & ERR_ALREADY_LOGGED) { @@ -4947,18 +4940,18 @@ if (*p == '\n') { iPtr->errorLine++; } } - if (length == TCL_AUTO_LENGTH) { + if (length < 0) { length = strlen(command); } - overflow = (length > (size_t)limit); + overflow = (length > limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n %s\n\"%.*s%s\"", ((iPtr->errorInfo == NULL) ? "while executing" : "invoked from within"), - (overflow ? limit : (int)length), command, + (overflow ? limit : length), command, (overflow ? "..." : ""))); varPtr = TclObjLookupVarEx(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY, NULL, 0, 0, &arrayPtr); if ((varPtr == NULL) || !TclIsVarTraced(varPtr)) { @@ -5072,11 +5065,11 @@ void TclErrorStackResetIf( Tcl_Interp *interp, const char *msg, - size_t length) + int length) { Interp *iPtr = (Interp *) interp; if (Tcl_IsShared(iPtr->errorStack)) { Tcl_Obj *newObj; @@ -5127,11 +5120,11 @@ Tcl_Interp *interp, /* Interpreter in which to log information. */ const char *script, /* First character in script containing * command (must be <= command). */ const char *command, /* First character in command that generated * the error. */ - size_t length) /* Number of bytes in command (-1 means use + int length) /* Number of bytes in command (-1 means use * all bytes up to first null byte). */ { TclLogCommandInfo(interp, script, command, length, NULL, NULL); } Index: generic/tclNotify.c ================================================================== --- generic/tclNotify.c +++ generic/tclNotify.c @@ -179,11 +179,11 @@ Tcl_MutexLock(&(tsdPtr->queueMutex)); for (evPtr = tsdPtr->firstEventPtr; evPtr != NULL; ) { hold = evPtr; evPtr = evPtr->nextPtr; - Tcl_Free(hold); + ckfree(hold); } tsdPtr->firstEventPtr = NULL; tsdPtr->lastEventPtr = NULL; Tcl_MutexUnlock(&(tsdPtr->queueMutex)); @@ -274,11 +274,11 @@ * happened. */ ClientData clientData) /* One-word argument to pass to setupProc and * checkProc. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - EventSource *sourcePtr = Tcl_Alloc(sizeof(EventSource)); + EventSource *sourcePtr = ckalloc(sizeof(EventSource)); sourcePtr->setupProc = setupProc; sourcePtr->checkProc = checkProc; sourcePtr->clientData = clientData; sourcePtr->nextPtr = tsdPtr->firstEventSourcePtr; @@ -328,11 +328,11 @@ if (prevPtr == NULL) { tsdPtr->firstEventSourcePtr = sourcePtr->nextPtr; } else { prevPtr->nextPtr = sourcePtr->nextPtr; } - Tcl_Free(sourcePtr); + ckfree(sourcePtr); return; } } /* @@ -353,11 +353,11 @@ void Tcl_QueueEvent( 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 + * malloc (ckalloc), and it becomes the * property of the event queue. It will be * freed after the event has been handled. */ Tcl_QueuePosition position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, * TCL_QUEUE_MARK. */ { @@ -385,11 +385,11 @@ void Tcl_ThreadQueueEvent( Tcl_ThreadId threadId, /* Identifier for thread to use. */ 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 + * malloc (ckalloc), and it becomes the * property of the event queue. It will be * freed after the event has been handled. */ Tcl_QueuePosition position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, * TCL_QUEUE_MARK. */ { @@ -410,11 +410,11 @@ */ if (tsdPtr) { QueueEvent(tsdPtr, evPtr, position); } else { - Tcl_Free(evPtr); + ckfree(evPtr); } Tcl_MutexUnlock(&listLock); } /* @@ -442,11 +442,11 @@ QueueEvent( ThreadSpecificData *tsdPtr, /* Handle to thread local data that indicates * which event queue to use. */ 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 + * malloc (ckalloc), and it becomes the * property of the event queue. It will be * freed after the event has been handled. */ Tcl_QueuePosition position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, * TCL_QUEUE_MARK. */ { @@ -561,11 +561,11 @@ * Delete the event data structure. */ hold = evPtr; evPtr = evPtr->nextPtr; - Tcl_Free(hold); + ckfree(hold); } else { /* * Event is to be retained. */ @@ -700,11 +700,11 @@ } else { evPtr = NULL; } } if (evPtr) { - Tcl_Free(evPtr); + ckfree(evPtr); } Tcl_MutexUnlock(&(tsdPtr->queueMutex)); return 1; } else { /* Index: generic/tclOO.c ================================================================== --- generic/tclOO.c +++ generic/tclOO.c @@ -24,17 +24,15 @@ const char *name; Tcl_ObjCmdProc *objProc; int flag; } defineCmds[] = { {"constructor", TclOODefineConstructorObjCmd, 0}, - {"definitionnamespace", TclOODefineDefnNsObjCmd, 0}, {"deletemethod", TclOODefineDeleteMethodObjCmd, 0}, {"destructor", TclOODefineDestructorObjCmd, 0}, {"export", TclOODefineExportObjCmd, 0}, {"forward", TclOODefineForwardObjCmd, 0}, {"method", TclOODefineMethodObjCmd, 0}, - {"private", TclOODefinePrivateObjCmd, 0}, {"renamemethod", TclOODefineRenameMethodObjCmd, 0}, {"self", TclOODefineSelfObjCmd, 0}, {"unexport", TclOODefineUnexportObjCmd, 0}, {NULL, NULL, 0} }, objdefCmds[] = { @@ -41,13 +39,11 @@ {"class", TclOODefineClassObjCmd, 1}, {"deletemethod", TclOODefineDeleteMethodObjCmd, 1}, {"export", TclOODefineExportObjCmd, 1}, {"forward", TclOODefineForwardObjCmd, 1}, {"method", TclOODefineMethodObjCmd, 1}, - {"private", TclOODefinePrivateObjCmd, 1}, {"renamemethod", TclOODefineRenameMethodObjCmd, 1}, - {"self", TclOODefineObjSelfObjCmd, 0}, {"unexport", TclOODefineUnexportObjCmd, 1}, {NULL, NULL, 0} }; /* @@ -71,35 +67,35 @@ static void DeletedObjdefNamespace(ClientData clientData); static void DeletedHelpersNamespace(ClientData clientData); static Tcl_NRPostProc FinalizeAlloc; static Tcl_NRPostProc FinalizeNext; static Tcl_NRPostProc FinalizeObjectCall; -static inline void InitClassPath(Tcl_Interp * interp, Class *clsPtr); -static void InitClassSystemRoots(Tcl_Interp *interp, - Foundation *fPtr); +static void initClassPath(Tcl_Interp * interp, Class *clsPtr); static int InitFoundation(Tcl_Interp *interp); static void KillFoundation(ClientData clientData, Tcl_Interp *interp); static void MyDeleted(ClientData clientData); static void ObjectNamespaceDeleted(ClientData clientData); static void ObjectRenamedTrace(ClientData clientData, Tcl_Interp *interp, const char *oldName, const char *newName, int flags); -static inline void RemoveClass(Class **list, int num, int idx); -static inline void RemoveObject(Object **list, int num, int idx); static inline void SquelchCachedName(Object *oPtr); +static int PublicObjectCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); static int PublicNRObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); +static int PrivateObjectCmd(ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int PrivateNRObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -static int MyClassNRObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -static void MyClassDeleted(ClientData clientData); +static void RemoveClass(Class ** list, int num, int idx); +static void RemoveObject(Object ** list, int num, int idx); /* * Methods in the oo::object and oo::class classes. First, we define a helper * macro that makes building the method type declaration structure a lot * easier. No point in making life harder than it has to be! @@ -134,11 +130,11 @@ "oo::class constructor", TclOO_Class_Constructor, NULL, NULL }; /* - * Scripted parts of TclOO. First, the master script (cannot be outside this + * Scripted parts of TclOO. First, the main script (cannot be outside this * file). */ static const char *initScript = "package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};" @@ -146,14 +142,69 @@ "namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };"; /* "tcl_findLibrary tcloo $oo::version $oo::version" */ /* " tcloo.tcl OO_LIBRARY oo::library;"; */ /* - * The scripted part of the definitions of TclOO. + * The scripted part of the definitions of slots. + */ + +static const char *slotScript = +"::oo::define ::oo::Slot {\n" +" method Get {} {error unimplemented}\n" +" method Set list {error unimplemented}\n" +" method -set args {\n" +" uplevel 1 [list [namespace which my] Set $args]\n" +" }\n" +" method -append args {\n" +" uplevel 1 [list [namespace which my] Set [list" +" {*}[uplevel 1 [list [namespace which my] Get]] {*}$args]]\n" +" }\n" +" method -clear {} {uplevel 1 [list [namespace which my] Set {}]}\n" +" forward --default-operation my -append\n" +" method unknown {args} {\n" +" set def --default-operation\n" +" if {[llength $args] == 0} {\n" +" return [uplevel 1 [list [namespace which my] $def]]\n" +" } elseif {![string match -* [lindex $args 0]]} {\n" +" return [uplevel 1 [list [namespace which my] $def {*}$args]]\n" +" }\n" +" next {*}$args\n" +" }\n" +" export -set -append -clear\n" +" unexport unknown destroy\n" +"}\n" +"::oo::objdefine ::oo::define::superclass forward --default-operation my -set\n" +"::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n" +"::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n"; + +/* + * The body of the method of oo::object. */ -#include "tclOOScript.h" +static const char *clonedBody = +"foreach p [info procs [info object namespace $originObject]::*] {" +" set args [info args $p];" +" set idx -1;" +" foreach a $args {" +" lset args [incr idx] " +" [if {[info default $p $a d]} {list $a $d} {list $a}]" +" };" +" set b [info body $p];" +" set p [namespace tail $p];" +" proc $p $args $b;" +"};" +"foreach v [info vars [info object namespace $originObject]::*] {" +" upvar 0 $v vOrigin;" +" namespace upvar [namespace current] [namespace tail $v] vNew;" +" if {[info exists vOrigin]} {" +" if {[array exists vOrigin]} {" +" array set vNew [array get vOrigin];" +" } else {" +" set vNew $vOrigin;" +" }" +" }" +"}"; /* * The actual definition of the variable holding the TclOO stub table. */ @@ -173,56 +224,20 @@ * either an oPtr or a classPtr. Note that the roots oo::object and oo::class * have _both_ their object and class flags tagged with ROOT_OBJECT and * ROOT_CLASS respectively. */ -#define Deleted(oPtr) ((oPtr)->flags & OBJECT_DELETED) +#define Destructing(oPtr) ((oPtr)->flags & OBJECT_DESTRUCTING) #define IsRootObject(ocPtr) ((ocPtr)->flags & ROOT_OBJECT) #define IsRootClass(ocPtr) ((ocPtr)->flags & ROOT_CLASS) #define IsRoot(ocPtr) ((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS)) #define RemoveItem(type, lst, i) \ - do { \ - Remove ## type ((lst).list, (lst).num, i); \ - (lst).num--; \ + do { \ + Remove ## type ((lst).list, (lst).num, i); \ + (lst).num--; \ } while (0) - -/* - * ---------------------------------------------------------------------- - * - * RemoveClass, RemoveObject -- - * - * Helpers for the RemoveItem macro for deleting a class or object from a - * list. Setting the "empty" location to NULL makes debugging a little - * easier. - * - * ---------------------------------------------------------------------- - */ - -static inline void -RemoveClass( - Class **list, - int num, - int idx) -{ - for (; idx < num - 1; idx++) { - list[idx] = list[idx + 1]; - } - list[idx] = NULL; -} - -static inline void -RemoveObject( - Object **list, - int num, - int idx) -{ - for (; idx < num - 1; idx++) { - list[idx] = list[idx + 1]; - } - list[idx] = NULL; -} /* * ---------------------------------------------------------------------- * * TclOOInit -- @@ -254,11 +269,11 @@ /* * Run our initialization script and, if that works, declare the package * to be fully provided. */ - if (Tcl_EvalEx(interp, initScript, -1, 0) != TCL_OK) { + if (Tcl_Eval(interp, initScript) != TCL_OK) { return TCL_ERROR; } return Tcl_PkgProvideEx(interp, "TclOO", TCLOO_PATCHLEVEL, (ClientData) &tclOOStubs); @@ -298,12 +313,16 @@ Tcl_Interp *interp) { static Tcl_ThreadDataKey tsdKey; ThreadLocalData *tsdPtr = Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData)); - Foundation *fPtr = Tcl_Alloc(sizeof(Foundation)); - Tcl_Obj *namePtr; + Foundation *fPtr = ckalloc(sizeof(Foundation)); + Tcl_Obj *namePtr, *argsPtr, *bodyPtr; + + Class fakeCls; + Object fakeObject; + Tcl_DString buffer; Command *cmdPtr; int i; /* @@ -321,11 +340,11 @@ DeletedDefineNamespace); fPtr->objdefNs = Tcl_CreateNamespace(interp, "::oo::objdefine", fPtr, DeletedObjdefNamespace); fPtr->helpersNs = Tcl_CreateNamespace(interp, "::oo::Helpers", fPtr, DeletedHelpersNamespace); - fPtr->epoch = 1; + fPtr->epoch = 0; fPtr->tsdPtr = tsdPtr; TclNewLiteralStringObj(fPtr->unknownMethodNameObj, "unknown"); TclNewLiteralStringObj(fPtr->constructorName, ""); TclNewLiteralStringObj(fPtr->destructorName, ""); TclNewLiteralStringObj(fPtr->clonedName, ""); @@ -362,14 +381,88 @@ } Tcl_CallWhenDeleted(interp, KillFoundation, NULL); /* - * Create the special objects at the core of the object system. + * Create the objects at the core of the object system. These need to be + * spliced manually. */ - InitClassSystemRoots(interp, fPtr); + /* + * Stand up a phony class for bootstrapping. + */ + + fPtr->objectCls = &fakeCls; + + /* + * Referenced in TclOOAllocClass to increment the refCount. + */ + + fakeCls.thisPtr = &fakeObject; + + fPtr->objectCls = TclOOAllocClass(interp, + AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL)); + /* + * Corresponding TclOODecrRefCount in KillFoudation. + */ + + AddRef(fPtr->objectCls->thisPtr); + + /* + * This is why it is unnecessary in this routine to replace the + * incremented reference count of fPtr->objectCls that was swallowed by + * fakeObject. + */ + + fPtr->objectCls->superclasses.num = 0; + ckfree(fPtr->objectCls->superclasses.list); + fPtr->objectCls->superclasses.list = NULL; + + /* + * Special initialization for the primordial objects. + */ + + fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT; + fPtr->objectCls->flags |= ROOT_OBJECT; + + fPtr->classCls = TclOOAllocClass(interp, + AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL)); + + /* + * Corresponding TclOODecrRefCount in KillFoudation. + */ + + AddRef(fPtr->classCls->thisPtr); + + /* + * Increment reference counts for each reference because these + * relationships can be dynamically changed. + * + * Corresponding TclOODecrRefCount for all incremented refcounts is in + * KillFoundation. + */ + + /* + * Rewire bootstrapped objects. + */ + + fPtr->objectCls->thisPtr->selfCls = fPtr->classCls; + AddRef(fPtr->classCls->thisPtr); + TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls); + + fPtr->classCls->thisPtr->selfCls = fPtr->classCls; + AddRef(fPtr->classCls->thisPtr); + TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls); + + fPtr->classCls->thisPtr->flags |= ROOT_CLASS; + fPtr->classCls->flags |= ROOT_CLASS; + + /* + * Standard initialization for new Objects. + */ + + TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls); /* * Basic method declarations for the core classes. */ @@ -378,10 +471,22 @@ } for (i = 0 ; clsMethods[i].name ; i++) { TclOONewBasicMethod(interp, fPtr->classCls, &clsMethods[i]); } + /* + * Create the default method implementation, used when 'oo::copy' + * is called to finish the copying of one object to another. + */ + + TclNewLiteralStringObj(argsPtr, "originObject"); + Tcl_IncrRefCount(argsPtr); + bodyPtr = Tcl_NewStringObj(clonedBody, -1); + TclOONewProcMethod(interp, fPtr->objectCls, 0, fPtr->clonedName, argsPtr, + bodyPtr, NULL); + TclDecrRefCount(argsPtr); + /* * Finish setting up the class of classes by marking the 'new' method as * private; classes, unlike general objects, must have explicit names. We * also need to create the constructor for classes. */ @@ -418,106 +523,11 @@ */ if (TclOODefineSlots(fPtr) != TCL_OK) { return TCL_ERROR; } - - /* - * Evaluate the remaining definitions, which are a compiled-in Tcl script. - */ - - return Tcl_EvalEx(interp, tclOOSetupScript, -1, 0); -} - -/* - * ---------------------------------------------------------------------- - * - * InitClassSystemRoots -- - * - * Creates the objects at the core of the object system. These need to be - * spliced manually. - * - * ---------------------------------------------------------------------- - */ - -static void -InitClassSystemRoots( - Tcl_Interp *interp, - Foundation *fPtr) -{ - Class fakeCls; - Object fakeObject; - Tcl_Obj *defNsName; - - /* Stand up a phony class for bootstrapping. */ - fPtr->objectCls = &fakeCls; - /* referenced in TclOOAllocClass to increment the refCount. */ - fakeCls.thisPtr = &fakeObject; - - fPtr->objectCls = TclOOAllocClass(interp, - AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL)); - /* Corresponding TclOODecrRefCount in KillFoudation */ - AddRef(fPtr->objectCls->thisPtr); - - /* - * This is why it is unnecessary in this routine to replace the - * incremented reference count of fPtr->objectCls that was swallowed by - * fakeObject. - */ - - fPtr->objectCls->superclasses.num = 0; - Tcl_Free(fPtr->objectCls->superclasses.list); - fPtr->objectCls->superclasses.list = NULL; - - /* - * Special initialization for the primordial objects. - */ - - fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT; - fPtr->objectCls->flags |= ROOT_OBJECT; - TclNewLiteralStringObj(defNsName, "::oo::objdefine"); - fPtr->objectCls->objDefinitionNs = defNsName; - Tcl_IncrRefCount(defNsName); - - fPtr->classCls = TclOOAllocClass(interp, - AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL)); - /* Corresponding TclOODecrRefCount in KillFoudation */ - AddRef(fPtr->classCls->thisPtr); - - /* - * Increment reference counts for each reference because these - * relationships can be dynamically changed. - * - * Corresponding TclOODecrRefCount for all incremented refcounts is in - * KillFoundation. - */ - - /* - * Rewire bootstrapped objects. - */ - - fPtr->objectCls->thisPtr->selfCls = fPtr->classCls; - AddRef(fPtr->classCls->thisPtr); - TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls); - - fPtr->classCls->thisPtr->selfCls = fPtr->classCls; - AddRef(fPtr->classCls->thisPtr); - TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls); - - fPtr->classCls->thisPtr->flags |= ROOT_CLASS; - fPtr->classCls->flags |= ROOT_CLASS; - TclNewLiteralStringObj(defNsName, "::oo::define"); - fPtr->classCls->clsDefinitionNs = defNsName; - Tcl_IncrRefCount(defNsName); - - /* Standard initialization for new Objects */ - TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls); - - /* - * THIS IS THE ONLY FUNCTION THAT DOES NON-STANDARD CLASS SPLICING. - * Everything else is careful to prohibit looping. - */ + return Tcl_Eval(interp, slotScript); } /* * ---------------------------------------------------------------------- * @@ -582,11 +592,11 @@ TclDecrRefCount(fPtr->clonedName); TclDecrRefCount(fPtr->defineName); TclOODecrRefCount(fPtr->objectCls->thisPtr); TclOODecrRefCount(fPtr->classCls->thisPtr); - Tcl_Free(fPtr); + ckfree(fPtr); } /* * ---------------------------------------------------------------------- * @@ -608,12 +618,12 @@ * object. */ const char *nameStr, /* The name of the object to create, or NULL * if the OO system should pick the object * name itself (equal to the namespace * name). */ - Namespace *nsPtr, /* The namespace to create the object in, or - * NULL if *nameStr is NULL */ + Namespace *nsPtr, /* The namespace to create the object in, + or NULL if *nameStr is NULL */ const char *nsNameStr) /* The name of the namespace to create, or * NULL if the OO system should pick a unique * name itself. If this is non-NULL but names * a namespace that already exists, the effect * will be the same as if this was NULL. */ @@ -620,13 +630,13 @@ { Foundation *fPtr = GetFoundation(interp); Object *oPtr; Command *cmdPtr; CommandTrace *tracePtr; - size_t creationEpoch; + int creationEpoch; - oPtr = Tcl_Alloc(sizeof(Object)); + oPtr = ckalloc(sizeof(Object)); memset(oPtr, 0, sizeof(Object)); /* * Every object has a namespace; make one. Note that this also normally * computes the creation epoch value for the object, a sequence number @@ -649,11 +659,11 @@ } while (1) { char objName[10 + TCL_INTEGER_SPACE]; - sprintf(objName, "::oo::Obj%" TCL_Z_MODIFIER "u", ++fPtr->tsdPtr->nsCount); + sprintf(objName, "::oo::Obj%d", ++fPtr->tsdPtr->nsCount); oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr, NULL); if (oPtr->namespacePtr != NULL) { creationEpoch = fPtr->tsdPtr->nsCount; break; } @@ -706,12 +716,12 @@ /* * An object starts life with a refCount of 2 to mark the two stages of * destruction it occur: A call to ObjectRenamedTrace(), and a call to * ObjectNamespaceDeleted(). */ - oPtr->refCount = 2; + oPtr->flags = USE_CLASS_CACHE; /* * Finally, create the object commands and initialize the trace on the * public command (so that the object structures are deleted when the @@ -722,33 +732,31 @@ nameStr = oPtr->namespacePtr->name; nsPtr = (Namespace *)oPtr->namespacePtr; if (nsPtr->parentPtr != NULL) { nsPtr = nsPtr->parentPtr; } + } oPtr->command = TclCreateObjCommandInNs(interp, nameStr, - (Tcl_Namespace *)nsPtr, TclOOPublicObjectCmd, oPtr, NULL); + (Tcl_Namespace *)nsPtr, PublicObjectCmd, oPtr, NULL); /* * Add the NRE command and trace directly. While this breaks a number of * abstractions, it is faster and we're inside Tcl here so we're allowed. */ cmdPtr = (Command *) oPtr->command; cmdPtr->nreProc = PublicNRObjectCmd; - cmdPtr->tracePtr = tracePtr = Tcl_Alloc(sizeof(CommandTrace)); + cmdPtr->tracePtr = tracePtr = ckalloc(sizeof(CommandTrace)); tracePtr->traceProc = ObjectRenamedTrace; tracePtr->clientData = oPtr; tracePtr->flags = TCL_TRACE_RENAME|TCL_TRACE_DELETE; tracePtr->nextPtr = NULL; tracePtr->refCount = 1; oPtr->myCommand = TclNRCreateCommandInNs(interp, "my", oPtr->namespacePtr, - TclOOPrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted); - oPtr->myclassCommand = TclNRCreateCommandInNs(interp, "myclass", - oPtr->namespacePtr, TclOOMyClassObjCmd, MyClassNRObjCmd, oPtr, - MyClassDeleted); + PrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted); return oPtr; } /* * ---------------------------------------------------------------------- @@ -772,16 +780,16 @@ } /* * ---------------------------------------------------------------------- * - * MyDeleted, MyClassDeleted -- + * MyDeleted -- * - * These callbacks are triggered when the object's [my] or [myclass] - * commands are deleted by any mechanism. They just mark the object as - * not having a [my] command or [myclass] command, and so prevent cleanup - * of those commands when the object itself is deleted. + * This callback is triggered when the object's [my] command is deleted + * by any mechanism. It just marks the object as not having a [my] + * command, and so prevents cleanup of that when the object itself is + * deleted. * * ---------------------------------------------------------------------- */ static void @@ -791,18 +799,10 @@ { register Object *oPtr = clientData; oPtr->myCommand = NULL; } - -static void -MyClassDeleted( - ClientData clientData) -{ - Object *oPtr = clientData; - oPtr->myclassCommand = NULL; -} /* * ---------------------------------------------------------------------- * * ObjectRenamedTrace -- @@ -822,11 +822,10 @@ const char *oldName, /* What the object was (last) called. */ const char *newName, /* What it's getting renamed to. (unused) */ int flags) /* Why was the object deleted? */ { Object *oPtr = clientData; - /* * If this is a rename and not a delete of the object, we just flush the * cache of the object name. */ @@ -838,11 +837,11 @@ /* * The namespace is only deleted if it hasn't already been deleted. [Bug * 2950259]. */ - if (!Deleted(oPtr)) { + if (!Destructing(oPtr)) { Tcl_DeleteNamespace(oPtr->namespacePtr); } oPtr->command = NULL; TclOODecrRefCount(oPtr); return; @@ -878,40 +877,39 @@ /* * This condition also covers the case where mixinSubclassPtr == * clsPtr */ - if (!Deleted(mixinSubclassPtr->thisPtr) + if (!Destructing(mixinSubclassPtr->thisPtr) && !(mixinSubclassPtr->thisPtr->flags & DONT_DELETE)) { Tcl_DeleteCommandFromToken(interp, mixinSubclassPtr->thisPtr->command); } TclOORemoveFromMixinSubs(mixinSubclassPtr, clsPtr); } } if (clsPtr->mixinSubs.size > 0) { - Tcl_Free(clsPtr->mixinSubs.list); + ckfree(clsPtr->mixinSubs.list); clsPtr->mixinSubs.size = 0; } - /* * Squelch subclasses of this class. */ if (clsPtr->subclasses.num > 0) { while (clsPtr->subclasses.num > 0) { subclassPtr = clsPtr->subclasses.list[clsPtr->subclasses.num - 1]; - if (!Deleted(subclassPtr->thisPtr) && !IsRoot(subclassPtr) + if (!Destructing(subclassPtr->thisPtr) && !IsRoot(subclassPtr) && !(subclassPtr->thisPtr->flags & DONT_DELETE)) { Tcl_DeleteCommandFromToken(interp, subclassPtr->thisPtr->command); } TclOORemoveFromSubclasses(subclassPtr, clsPtr); } } if (clsPtr->subclasses.size > 0) { - Tcl_Free(clsPtr->subclasses.list); + ckfree(clsPtr->subclasses.list); clsPtr->subclasses.list = NULL; clsPtr->subclasses.size = 0; } /* @@ -924,19 +922,19 @@ /* * This condition also covers the case where instancePtr == oPtr */ - if (!Deleted(instancePtr) && !IsRoot(instancePtr) && + if (!Destructing(instancePtr) && !IsRoot(instancePtr) && !(instancePtr->flags & DONT_DELETE)) { Tcl_DeleteCommandFromToken(interp, instancePtr->command); } TclOORemoveFromInstances(instancePtr, clsPtr); } } if (clsPtr->instances.size > 0) { - Tcl_Free(clsPtr->instances.list); + ckfree(clsPtr->instances.list); clsPtr->instances.list = NULL; clsPtr->instances.size = 0; } } @@ -960,39 +958,25 @@ int i; Class *clsPtr = oPtr->classPtr, *tmpClsPtr; Method *mPtr; Foundation *fPtr = oPtr->fPtr; Tcl_Obj *variableObj; - PrivateVariableMapping *privateVariable; /* * Sanity check! */ - if (!Deleted(oPtr)) { + if (!Destructing(oPtr)) { if (IsRootClass(oPtr)) { Tcl_Panic("deleting class structure for non-deleted %s", "::oo::class"); } else if (IsRootObject(oPtr)) { Tcl_Panic("deleting class structure for non-deleted %s", "::oo::object"); } } - /* - * Stop using the class for definition information. - */ - - if (clsPtr->clsDefinitionNs) { - Tcl_DecrRefCount(clsPtr->clsDefinitionNs); - clsPtr->clsDefinitionNs = NULL; - } - if (clsPtr->objDefinitionNs) { - Tcl_DecrRefCount(clsPtr->objDefinitionNs); - clsPtr->objDefinitionNs = NULL; - } - /* * Squelch method implementation chain caches. */ if (clsPtr->constructorChainPtr) { @@ -1008,11 +992,11 @@ FOREACH_HASH_VALUE(callPtr, clsPtr->classChainCache) { TclOODeleteChain(callPtr); } Tcl_DeleteHashTable(clsPtr->classChainCache); - Tcl_Free(clsPtr->classChainCache); + ckfree(clsPtr->classChainCache); clsPtr->classChainCache = NULL; } /* * Squelch our filter list. @@ -1022,11 +1006,11 @@ Tcl_Obj *filterObj; FOREACH(filterObj, clsPtr->filters) { TclDecrRefCount(filterObj); } - Tcl_Free(clsPtr->filters.list); + ckfree(clsPtr->filters.list); clsPtr->filters.list = NULL; clsPtr->filters.num = 0; } /* @@ -1039,30 +1023,30 @@ FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) { metadataTypePtr->deleteProc(value); } Tcl_DeleteHashTable(clsPtr->metadataPtr); - Tcl_Free(clsPtr->metadataPtr); + ckfree(clsPtr->metadataPtr); clsPtr->metadataPtr = NULL; } if (clsPtr->mixins.num) { FOREACH(tmpClsPtr, clsPtr->mixins) { TclOORemoveFromMixinSubs(clsPtr, tmpClsPtr); TclOODecrRefCount(tmpClsPtr->thisPtr); } - Tcl_Free(clsPtr->mixins.list); + ckfree(clsPtr->mixins.list); clsPtr->mixins.list = NULL; clsPtr->mixins.num = 0; } if (clsPtr->superclasses.num > 0) { FOREACH(tmpClsPtr, clsPtr->superclasses) { TclOORemoveFromSubclasses(clsPtr, tmpClsPtr); TclOODecrRefCount(tmpClsPtr->thisPtr); } - Tcl_Free(clsPtr->superclasses.list); + ckfree(clsPtr->superclasses.list); clsPtr->superclasses.num = 0; clsPtr->superclasses.list = NULL; } FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) { @@ -1074,22 +1058,14 @@ FOREACH(variableObj, clsPtr->variables) { TclDecrRefCount(variableObj); } if (i) { - Tcl_Free(clsPtr->variables.list); + ckfree(clsPtr->variables.list); } - FOREACH_STRUCT(privateVariable, clsPtr->privateVariables) { - TclDecrRefCount(privateVariable->variableObj); - TclDecrRefCount(privateVariable->fullNameObj); - } - if (i) { - Tcl_Free(clsPtr->privateVariables.list); - } - - if (IsRootClass(oPtr) && !Deleted(fPtr->objectCls->thisPtr)) { + if (IsRootClass(oPtr) && !Destructing(fPtr->objectCls->thisPtr)) { Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command); } } /* @@ -1114,30 +1090,27 @@ Foundation *fPtr = oPtr->fPtr; FOREACH_HASH_DECLS; Class *mixinPtr; Method *mPtr; Tcl_Obj *filterObj, *variableObj; - PrivateVariableMapping *privateVariable; Tcl_Interp *interp = oPtr->fPtr->interp; int i; - if (Deleted(oPtr)) { + if (Destructing(oPtr)) { /* * TODO: Can ObjectNamespaceDeleted ever be called twice? If not, * this guard could be removed. */ - return; } /* * One rule for the teardown routines is that if an object is in the * process of being deleted, nothing else may modify its bookeeping * records. This is the flag that */ - - oPtr->flags |= OBJECT_DELETED; + oPtr->flags |= OBJECT_DESTRUCTING; /* * Let the dominoes fall! */ @@ -1152,11 +1125,11 @@ * of it have gone. [Bug 2949397] */ if (!Tcl_InterpDeleted(interp) && !(oPtr->flags & DESTRUCTOR_CALLED)) { CallContext *contextPtr = - TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL, NULL); + TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL); int result; Tcl_InterpState state; oPtr->flags |= DESTRUCTOR_CALLED; @@ -1193,13 +1166,10 @@ */ Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command); } - if (oPtr->myclassCommand) { - Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myclassCommand); - } if (oPtr->myCommand) { Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand); } /* @@ -1214,42 +1184,34 @@ FOREACH(mixinPtr, oPtr->mixins) { TclOORemoveFromInstances(oPtr, mixinPtr); TclOODecrRefCount(mixinPtr->thisPtr); } if (oPtr->mixins.list != NULL) { - Tcl_Free(oPtr->mixins.list); + ckfree(oPtr->mixins.list); } } FOREACH(filterObj, oPtr->filters) { TclDecrRefCount(filterObj); } if (i) { - Tcl_Free(oPtr->filters.list); + ckfree(oPtr->filters.list); } if (oPtr->methodsPtr) { FOREACH_HASH_VALUE(mPtr, oPtr->methodsPtr) { TclOODelMethodRef(mPtr); } Tcl_DeleteHashTable(oPtr->methodsPtr); - Tcl_Free(oPtr->methodsPtr); + ckfree(oPtr->methodsPtr); } FOREACH(variableObj, oPtr->variables) { TclDecrRefCount(variableObj); } if (i) { - Tcl_Free(oPtr->variables.list); - } - - FOREACH_STRUCT(privateVariable, oPtr->privateVariables) { - TclDecrRefCount(privateVariable->variableObj); - TclDecrRefCount(privateVariable->fullNameObj); - } - if (i) { - Tcl_Free(oPtr->privateVariables.list); + ckfree(oPtr->variables.list); } if (oPtr->chainCache) { TclOODeleteChainCache(oPtr->chainCache); } @@ -1262,11 +1224,11 @@ FOREACH_HASH(metadataTypePtr, value, oPtr->metadataPtr) { metadataTypePtr->deleteProc(value); } Tcl_DeleteHashTable(oPtr->metadataPtr); - Tcl_Free(oPtr->metadataPtr); + ckfree(oPtr->metadataPtr); oPtr->metadataPtr = NULL; } /* * Because an object can be a class that is an instance of itself, the @@ -1278,12 +1240,13 @@ * class of classes now as well. Due to the incestuous nature of those two * classes, if one goes the other must too and yet the tangle can * sometimes not go away automatically; we force it here. [Bug 2962664] */ - if (IsRootObject(oPtr) && !Deleted(fPtr->classCls->thisPtr) + if (IsRootObject(oPtr) && !Destructing(fPtr->classCls->thisPtr) && !Tcl_InterpDeleted(interp)) { + Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command); } if (oPtr->classPtr != NULL) { TclOOReleaseClassContents(interp, oPtr); @@ -1302,34 +1265,58 @@ } /* * ---------------------------------------------------------------------- * - * TclOODecrRefCount -- + * TclOODecrRef -- * * Decrement the refcount of an object and deallocate storage then object * is no longer referenced. Returns 1 if storage was deallocated, and 0 * otherwise. * * ---------------------------------------------------------------------- */ - -int -TclOODecrRefCount( - Object *oPtr) -{ +int TclOODecrRefCount(Object *oPtr) { if (oPtr->refCount-- <= 1) { - if (oPtr->classPtr != NULL) { - Tcl_Free(oPtr->classPtr); + ckfree(oPtr->classPtr); } - Tcl_Free(oPtr); + ckfree(oPtr); return 1; } return 0; } +/* + * ---------------------------------------------------------------------- + * + * TclOOObjectDestroyed -- + * + * Returns TCL_OK if an object is entirely deleted, i.e. the destruction + * sequence has completed. + * + * ---------------------------------------------------------------------- + */ +int TclOOObjectDestroyed(Object *oPtr) { + return (oPtr->namespacePtr == NULL); +} + +/* + * Setting the "empty" location to NULL makes debugging a little easier. + */ + +#define REMOVEBODY { \ + for (; idx < num - 1; idx++) { \ + list[idx] = list[idx + 1]; \ + } \ + list[idx] = NULL; \ + return; \ +} +void RemoveClass(Class **list, int num, int idx) REMOVEBODY + +void RemoveObject(Object **list, int num, int idx) REMOVEBODY + /* * ---------------------------------------------------------------------- * * TclOORemoveFromInstances -- * @@ -1378,13 +1365,13 @@ * present as an instance in the class. */ { if (clsPtr->instances.num >= clsPtr->instances.size) { clsPtr->instances.size += ALLOC_CHUNK; if (clsPtr->instances.size == ALLOC_CHUNK) { - clsPtr->instances.list = Tcl_Alloc(sizeof(Object *) * ALLOC_CHUNK); + clsPtr->instances.list = ckalloc(sizeof(Object *) * ALLOC_CHUNK); } else { - clsPtr->instances.list = Tcl_Realloc(clsPtr->instances.list, + clsPtr->instances.list = ckrealloc(clsPtr->instances.list, sizeof(Object *) * clsPtr->instances.size); } } clsPtr->instances.list[clsPtr->instances.num++] = oPtr; AddRef(oPtr); @@ -1417,11 +1404,11 @@ res++; break; } } if (oPtr->mixins.num == 0) { - Tcl_Free(oPtr->mixins.list); + ckfree(oPtr->mixins.list); oPtr->mixins.list = NULL; } return res; } @@ -1471,19 +1458,19 @@ Class *subPtr, /* The subclass to add. */ Class *superPtr) /* The superclass to add the subclass to. It * is assumed that the class is not already * present as a subclass in the superclass. */ { - if (Deleted(superPtr->thisPtr)) { + if (Destructing(superPtr->thisPtr)) { return; } if (superPtr->subclasses.num >= superPtr->subclasses.size) { superPtr->subclasses.size += ALLOC_CHUNK; if (superPtr->subclasses.size == ALLOC_CHUNK) { - superPtr->subclasses.list = Tcl_Alloc(sizeof(Class *) * ALLOC_CHUNK); + superPtr->subclasses.list = ckalloc(sizeof(Class *) * ALLOC_CHUNK); } else { - superPtr->subclasses.list = Tcl_Realloc(superPtr->subclasses.list, + superPtr->subclasses.list = ckrealloc(superPtr->subclasses.list, sizeof(Class *) * superPtr->subclasses.size); } } superPtr->subclasses.list[superPtr->subclasses.num++] = subPtr; AddRef(subPtr->thisPtr); @@ -1536,19 +1523,19 @@ Class *subPtr, /* The subclass to add. */ Class *superPtr) /* The superclass to add the subclass to. It * is assumed that the class is not already * present as a subclass in the superclass. */ { - if (Deleted(superPtr->thisPtr)) { + if (Destructing(superPtr->thisPtr)) { return; } if (superPtr->mixinSubs.num >= superPtr->mixinSubs.size) { superPtr->mixinSubs.size += ALLOC_CHUNK; if (superPtr->mixinSubs.size == ALLOC_CHUNK) { - superPtr->mixinSubs.list = Tcl_Alloc(sizeof(Class *) * ALLOC_CHUNK); + superPtr->mixinSubs.list = ckalloc(sizeof(Class *) * ALLOC_CHUNK); } else { - superPtr->mixinSubs.list = Tcl_Realloc(superPtr->mixinSubs.list, + superPtr->mixinSubs.list = ckrealloc(superPtr->mixinSubs.list, sizeof(Class *) * superPtr->mixinSubs.size); } } superPtr->mixinSubs.list[superPtr->mixinSubs.num++] = subPtr; AddRef(subPtr->thisPtr); @@ -1563,55 +1550,35 @@ * list. * * ---------------------------------------------------------------------- */ -static inline void -InitClassPath( - Tcl_Interp *interp, - Class *clsPtr) -{ - Foundation *fPtr = GetFoundation(interp); - - if (fPtr->helpersNs != NULL) { - Tcl_Namespace *path[2]; - - path[0] = fPtr->helpersNs; - path[1] = fPtr->ooNs; - TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 2, path); - } else { - TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 1, - &fPtr->ooNs); - } -} - Class * TclOOAllocClass( Tcl_Interp *interp, /* Interpreter within which to allocate the * class. */ Object *useThisObj) /* Object that is to act as the class * representation. */ { Foundation *fPtr = GetFoundation(interp); - Class *clsPtr = Tcl_Alloc(sizeof(Class)); + Class *clsPtr = ckalloc(sizeof(Class)); memset(clsPtr, 0, sizeof(Class)); clsPtr->thisPtr = useThisObj; /* * Configure the namespace path for the class's object. */ - - InitClassPath(interp, clsPtr); + initClassPath(interp, clsPtr); /* * Classes are subclasses of oo::object, i.e. the objects they create are * objects. */ clsPtr->superclasses.num = 1; - clsPtr->superclasses.list = Tcl_Alloc(sizeof(Class *)); + clsPtr->superclasses.list = ckalloc(sizeof(Class *)); clsPtr->superclasses.list[0] = fPtr->objectCls; AddRef(fPtr->objectCls->thisPtr); /* * Finish connecting the class structure to the object structure. @@ -1624,10 +1591,23 @@ * fields. */ Tcl_InitObjHashTable(&clsPtr->classMethods); return clsPtr; +} +static void +initClassPath(Tcl_Interp *interp, Class *clsPtr) { + Foundation *fPtr = GetFoundation(interp); + if (fPtr->helpersNs != NULL) { + Tcl_Namespace *path[2]; + path[0] = fPtr->helpersNs; + path[1] = fPtr->ooNs; + TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 2, path); + } else { + TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 1, + &fPtr->ooNs); + } } /* * ---------------------------------------------------------------------- * @@ -1655,22 +1635,20 @@ register Class *classPtr = (Class *) cls; Object *oPtr; ClientData clientData[4]; oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr); - if (oPtr == NULL) { - return NULL; - } + if (oPtr == NULL) {return NULL;} /* * Run constructors, except when objc < 0, which is a special flag case * used for object cloning only. */ if (objc >= 0) { CallContext *contextPtr = - TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL); + TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL); if (contextPtr != NULL) { int isRoot, result; Tcl_InterpState state; @@ -1726,13 +1704,11 @@ CallContext *contextPtr; Tcl_InterpState state; Object *oPtr; oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr); - if (oPtr == NULL) { - return TCL_ERROR; - } + if (oPtr == NULL) {return TCL_ERROR;} /* * Run constructors, except when objc < 0 (a special flag case used for * object cloning only). If there aren't any constructors, we do nothing. */ @@ -1739,11 +1715,11 @@ if (objc < 0) { *objectPtr = (Tcl_Object) oPtr; return TCL_OK; } - contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL); + contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL); if (contextPtr == NULL) { *objectPtr = (Tcl_Object) oPtr; return TCL_OK; } @@ -1778,12 +1754,12 @@ { Tcl_HashEntry *hPtr; Foundation *fPtr = GetFoundation(interp); Object *oPtr; const char *simpleName = NULL; - Namespace *nsPtr = NULL, *dummy; - Namespace *inNsPtr = (Namespace *) TclGetCurrentNamespace(interp); + Namespace *nsPtr = NULL, *dummy, + *inNsPtr = (Namespace *)TclGetCurrentNamespace(interp); if (nameStr) { TclGetNamespaceForQualName(interp, nameStr, inNsPtr, TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy, &dummy, &simpleName); @@ -1841,15 +1817,15 @@ Object *oPtr = data[1]; Tcl_InterpState state = data[2]; Tcl_Object *objectPtr = data[3]; /* - * Ensure an error if the object was deleted in the constructor. Don't - * want to lose errors by accident. [Bug 2903011] + * Ensure an error if the object was deleted in the constructor. + * Don't want to lose errors by accident. [Bug 2903011] */ - if (result != TCL_ERROR && Deleted(oPtr)) { + if (result != TCL_ERROR && Destructing(oPtr)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "object deleted in constructor", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL); result = TCL_ERROR; } @@ -1860,11 +1836,11 @@ * Take care to not delete a deleted object; that would be bad. [Bug * 2903011] Also take care to make sure that we have the name of the * command before we delete it. [Bug 9dd1bd7a74] */ - if (!Deleted(oPtr)) { + if (!Destructing(oPtr)) { (void) TclOOObjectName(interp, oPtr); Tcl_DeleteCommandFromToken(interp, oPtr->command); } /* @@ -1908,11 +1884,10 @@ FOREACH_HASH_DECLS; Method *mPtr; Class *mixinPtr; CallContext *contextPtr; Tcl_Obj *keyPtr, *filterObj, *variableObj, *args[3]; - PrivateVariableMapping *privateVariable; int i, result; /* * Sanity check. */ @@ -1957,11 +1932,11 @@ if (mixinPtr && mixinPtr != o2Ptr->selfCls) { TclOORemoveFromInstances(o2Ptr, mixinPtr); } TclOODecrRefCount(mixinPtr->thisPtr); } - Tcl_Free(o2Ptr->mixins.list); + ckfree(o2Ptr->mixins.list); } DUPLICATE(o2Ptr->mixins, oPtr->mixins, Class *); FOREACH(mixinPtr, o2Ptr->mixins) { if (mixinPtr && mixinPtr != o2Ptr->selfCls) { TclOOAddToInstances(o2Ptr, mixinPtr); @@ -1982,34 +1957,27 @@ FOREACH(filterObj, o2Ptr->filters) { Tcl_IncrRefCount(filterObj); } /* - * Copy the object's variable resolution lists to the new object. + * Copy the object's variable resolution list to the new object. */ DUPLICATE(o2Ptr->variables, oPtr->variables, Tcl_Obj *); FOREACH(variableObj, o2Ptr->variables) { Tcl_IncrRefCount(variableObj); } - DUPLICATE(o2Ptr->privateVariables, oPtr->privateVariables, - PrivateVariableMapping); - FOREACH_STRUCT(privateVariable, o2Ptr->privateVariables) { - Tcl_IncrRefCount(privateVariable->variableObj); - Tcl_IncrRefCount(privateVariable->fullNameObj); - } - /* * Copy the object's flags to the new object, clearing those that must be * kept object-local. The duplicate is never deleted at this point, nor is * it the root of the object system or in the midst of processing a filter * call. */ o2Ptr->flags = oPtr->flags & ~( - OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING); + OBJECT_DESTRUCTING | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING); /* * Copy the object's metadata. */ @@ -2058,15 +2026,15 @@ FOREACH(superPtr, cls2Ptr->superclasses) { TclOORemoveFromSubclasses(cls2Ptr, superPtr); TclOODecrRefCount(superPtr->thisPtr); } if (cls2Ptr->superclasses.num) { - cls2Ptr->superclasses.list = Tcl_Realloc(cls2Ptr->superclasses.list, + cls2Ptr->superclasses.list = ckrealloc(cls2Ptr->superclasses.list, sizeof(Class *) * clsPtr->superclasses.num); } else { cls2Ptr->superclasses.list = - Tcl_Alloc(sizeof(Class *) * clsPtr->superclasses.num); + ckalloc(sizeof(Class *) * clsPtr->superclasses.num); } memcpy(cls2Ptr->superclasses.list, clsPtr->superclasses.list, sizeof(Class *) * clsPtr->superclasses.num); cls2Ptr->superclasses.num = clsPtr->superclasses.num; FOREACH(superPtr, cls2Ptr->superclasses) { @@ -2088,25 +2056,18 @@ FOREACH(filterObj, cls2Ptr->filters) { Tcl_IncrRefCount(filterObj); } /* - * Copy the source class's variable resolution lists. + * Copy the source class's variable resolution list. */ DUPLICATE(cls2Ptr->variables, clsPtr->variables, Tcl_Obj *); FOREACH(variableObj, cls2Ptr->variables) { Tcl_IncrRefCount(variableObj); } - DUPLICATE(cls2Ptr->privateVariables, clsPtr->privateVariables, - PrivateVariableMapping); - FOREACH_STRUCT(privateVariable, cls2Ptr->privateVariables) { - Tcl_IncrRefCount(privateVariable->variableObj); - Tcl_IncrRefCount(privateVariable->fullNameObj); - } - /* * Duplicate the source class's mixins (which cannot be circular * references to the duplicate). */ @@ -2113,11 +2074,11 @@ if (cls2Ptr->mixins.num != 0) { FOREACH(mixinPtr, cls2Ptr->mixins) { TclOORemoveFromMixinSubs(cls2Ptr, mixinPtr); TclOODecrRefCount(mixinPtr->thisPtr); } - Tcl_Free(clsPtr->mixins.list); + ckfree(clsPtr->mixins.list); } DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *); FOREACH(mixinPtr, cls2Ptr->mixins) { TclOOAddToMixinSubs(cls2Ptr, mixinPtr); @@ -2179,12 +2140,11 @@ } } } TclResetRewriteEnsemble(interp, 1); - contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL, - NULL, NULL); + contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL); if (contextPtr) { args[0] = TclOOObjectName(interp, o2Ptr); args[1] = oPtr->fPtr->clonedName; args[2] = TclOOObjectName(interp, oPtr); Tcl_IncrRefCount(args[0]); @@ -2356,11 +2316,11 @@ if (clsPtr->metadataPtr == NULL) { if (metadata == NULL) { return; } - clsPtr->metadataPtr = Tcl_Alloc(sizeof(Tcl_HashTable)); + clsPtr->metadataPtr = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(clsPtr->metadataPtr, TCL_ONE_WORD_KEYS); } /* * If the metadata is NULL, we're deleting the metadata for the type. @@ -2436,11 +2396,11 @@ if (oPtr->metadataPtr == NULL) { if (metadata == NULL) { return; } - oPtr->metadataPtr = Tcl_Alloc(sizeof(Tcl_HashTable)); + oPtr->metadataPtr = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(oPtr->metadataPtr, TCL_ONE_WORD_KEYS); } /* * If the metadata is NULL, we're deleting the metadata for the type. @@ -2468,22 +2428,22 @@ } /* * ---------------------------------------------------------------------- * - * TclOOPublicObjectCmd, TclOOPrivateObjectCmd, TclOOInvokeObject -- + * PublicObjectCmd, PrivateObjectCmd, TclOOInvokeObject -- * * Main entry point for object invocations. The Public* and Private* * wrapper functions (implementations of both object instance commands * and [my]) are just thin wrappers round the main TclOOObjectCmdCore * function. Note that the core is function is NRE-aware. * * ---------------------------------------------------------------------- */ -int -TclOOPublicObjectCmd( +static int +PublicObjectCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { @@ -2499,12 +2459,12 @@ { return TclOOObjectCmdCore(clientData, interp, objc, objv, PUBLIC_METHOD, NULL); } -int -TclOOPrivateObjectCmd( +static int +PrivateObjectCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { @@ -2553,47 +2513,10 @@ } /* * ---------------------------------------------------------------------- * - * TclOOMyClassObjCmd, MyClassNRObjCmd -- - * - * Special trap door to allow an object to delegate simply to its class. - * - * ---------------------------------------------------------------------- - */ - -int -TclOOMyClassObjCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - return Tcl_NRCallObjProc(interp, MyClassNRObjCmd, clientData, objc, objv); -} - -static int -MyClassNRObjCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = clientData; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "methodName ?arg ...?"); - return TCL_ERROR; - } - return TclOOObjectCmdCore(oPtr->selfCls->thisPtr, interp, objc, objv, 0, - NULL); -} - -/* - * ---------------------------------------------------------------------- - * * TclOOObjectCmdCore, FinalizeObjectCall -- * * Main function for object invocations. Does call chain creation, * management and invocation. The function FinalizeObjectCall exists to * clean up after the non-recursive processing of TclOOObjectCmdCore. @@ -2614,13 +2537,10 @@ * filters and the object's methods (which is * the normal case). */ { CallContext *contextPtr; Tcl_Obj *methodNamePtr; - CallFrame *framePtr = ((Interp *) interp)->varFramePtr; - Object *callerObjPtr = NULL; - Class *callerClsPtr = NULL; int result; /* * If we've no method name, throw this directly into the unknown * processing. @@ -2628,28 +2548,10 @@ if (objc < 2) { flags |= FORCE_UNKNOWN; methodNamePtr = NULL; goto noMapping; - } - - /* - * Determine if we're in a context that can see the extra, private methods - * in this class. - */ - - if (framePtr->isProcCallFrame & FRAME_IS_METHOD) { - CallContext *callerContextPtr = framePtr->clientData; - Method *callerMethodPtr = - callerContextPtr->callPtr->chain[callerContextPtr->index].mPtr; - - if (callerMethodPtr->declaringObjectPtr) { - callerObjPtr = callerMethodPtr->declaringObjectPtr; - } - if (callerMethodPtr->declaringClassPtr) { - callerClsPtr = callerMethodPtr->declaringClassPtr; - } } /* * Give plugged in code a chance to remap the method name. */ @@ -2675,12 +2577,11 @@ * Get the call chain for the remapped name. */ Tcl_IncrRefCount(mappedMethodName); contextPtr = TclOOGetCallContext(oPtr, mappedMethodName, - flags | (oPtr->flags & FILTER_HANDLING), callerObjPtr, - callerClsPtr, methodNamePtr); + flags | (oPtr->flags & FILTER_HANDLING), methodNamePtr); TclDecrRefCount(mappedMethodName); if (contextPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "impossible to invoke method \"%s\": no defined method or" " unknown method", TclGetString(methodNamePtr))); @@ -2693,12 +2594,11 @@ * Get the call chain. */ noMapping: contextPtr = TclOOGetCallContext(oPtr, methodNamePtr, - flags | (oPtr->flags & FILTER_HANDLING), callerObjPtr, - callerClsPtr, NULL); + flags | (oPtr->flags & FILTER_HANDLING), NULL); if (contextPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "impossible to invoke method \"%s\": no defined method or" " unknown method", TclGetString(methodNamePtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", @@ -2944,13 +2844,13 @@ Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objPtr); if (cmdPtr == NULL) { goto notAnObject; } - if (cmdPtr->objProc != TclOOPublicObjectCmd) { + if (cmdPtr->objProc != PublicObjectCmd) { cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); - if (cmdPtr == NULL || cmdPtr->objProc != TclOOPublicObjectCmd) { + if (cmdPtr == NULL || cmdPtr->objProc != PublicObjectCmd) { goto notAnObject; } } return cmdPtr->objClientData; Index: generic/tclOO.decls ================================================================== --- generic/tclOO.decls +++ generic/tclOO.decls @@ -49,24 +49,24 @@ declare 8 { int Tcl_MethodIsPublic(Tcl_Method method) } declare 9 { int Tcl_MethodIsType(Tcl_Method method, const Tcl_MethodType *typePtr, - void **clientDataPtr) + ClientData *clientDataPtr) } declare 10 { Tcl_Obj *Tcl_MethodName(Tcl_Method method) } declare 11 { Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object, - Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, - void *clientData) + Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, + ClientData clientData) } declare 12 { Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, - Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, - void *clientData) + Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, + ClientData clientData) } declare 13 { Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, int objc, Tcl_Obj *const *objv, int skip) @@ -85,24 +85,24 @@ } declare 18 { int Tcl_ObjectContextSkippedArgs(Tcl_ObjectContext context) } declare 19 { - void *Tcl_ClassGetMetadata(Tcl_Class clazz, + ClientData Tcl_ClassGetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr) } declare 20 { void Tcl_ClassSetMetadata(Tcl_Class clazz, - const Tcl_ObjectMetadataType *typePtr, void *metadata) + const Tcl_ObjectMetadataType *typePtr, ClientData metadata) } declare 21 { - void *Tcl_ObjectGetMetadata(Tcl_Object object, + ClientData Tcl_ObjectGetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr) } declare 22 { void Tcl_ObjectSetMetadata(Tcl_Object object, - const Tcl_ObjectMetadataType *typePtr, void *metadata) + const Tcl_ObjectMetadataType *typePtr, ClientData metadata) } declare 23 { int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv, int skip) @@ -124,13 +124,10 @@ Tcl_Method method) } declare 28 { Tcl_Obj *Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object) } -declare 29 { - int Tcl_MethodIsPrivate(Tcl_Method method) -} ###################################################################### # Private API, exposed to support advanced OO systems that plug in on top of # TclOO; not intended for general use and does not have any commitment to # long-term support. @@ -142,18 +139,18 @@ Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp) } declare 1 { Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, - const Tcl_MethodType *typePtr, void *clientData, + const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr) } declare 2 { Tcl_Method TclOOMakeProcMethod(Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, const char *namePtr, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, - void *clientData, Proc **procPtrPtr) + ClientData clientData, Proc **procPtrPtr) } declare 3 { Method *TclOONewProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr) @@ -180,17 +177,17 @@ } declare 9 { Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, - void *clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, + ClientData clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr) } declare 10 { Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Class clsPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, - ProcErrorProc *errProc, void *clientData, Tcl_Obj *nameObj, + ProcErrorProc *errProc, ClientData clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr) } declare 11 { int TclOOInvokeObject(Tcl_Interp *interp, Tcl_Object object, Index: generic/tclOO.h ================================================================== --- generic/tclOO.h +++ generic/tclOO.h @@ -22,11 +22,11 @@ * tests/ooNext2.test * unix/tclooConfig.sh * win/tclooConfig.sh */ -#define TCLOO_VERSION "1.2.0" +#define TCLOO_VERSION "1.1.0" #define TCLOO_PATCHLEVEL TCLOO_VERSION #include "tcl.h" /* @@ -58,16 +58,16 @@ * Public datatypes for callbacks and structures used in the TIP#257 (OO) * implementation. These are used to implement custom types of method calls * and to allow the attachment of arbitrary data to objects and classes. */ -typedef int (Tcl_MethodCallProc)(void *clientData, Tcl_Interp *interp, +typedef int (Tcl_MethodCallProc)(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext objectContext, int objc, Tcl_Obj *const *objv); -typedef void (Tcl_MethodDeleteProc)(void *clientData); -typedef int (Tcl_CloneProc)(Tcl_Interp *interp, void *oldClientData, - void **newClientData); -typedef void (Tcl_ObjectMetadataDeleteProc)(void *clientData); +typedef void (Tcl_MethodDeleteProc)(ClientData clientData); +typedef int (Tcl_CloneProc)(Tcl_Interp *interp, ClientData oldClientData, + ClientData *newClientData); +typedef void (Tcl_ObjectMetadataDeleteProc)(ClientData clientData); typedef int (Tcl_ObjectMapMethodNameProc)(Tcl_Interp *interp, Tcl_Object object, Tcl_Class *startClsPtr, Tcl_Obj *methodNameObj); /* * The type of a method implementation. This describes how to call the method @@ -93,23 +93,14 @@ } Tcl_MethodType; /* * 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. + * binary compatability. */ #define TCL_OO_METHOD_VERSION_CURRENT 1 - -/* - * Visibility constants for the flags parameter to Tcl_NewMethod and - * Tcl_NewInstanceMethod. - */ - -#define TCL_OO_METHOD_PUBLIC 1 -#define TCL_OO_METHOD_UNEXPORTED 0 -#define TCL_OO_METHOD_PRIVATE 0x20 /* * The type of some object (or class) metadata. This describes how to delete * the metadata (when the object or class is deleted) and how to create a * clone of it (when the object or class is copied). @@ -129,11 +120,11 @@ } Tcl_ObjectMetadataType; /* * The correct value for the version field of the Tcl_ObjectMetadataType * structure. This allows new versions of the structure to be introduced - * without breaking binary compatibility. + * without breaking binary compatability. */ #define TCL_OO_METADATA_VERSION_CURRENT 1 /* Index: generic/tclOOBasic.c ================================================================== --- generic/tclOOBasic.c +++ generic/tclOOBasic.c @@ -81,36 +81,25 @@ Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); - Tcl_Obj **invoke, *nameObj; + Tcl_Obj **invoke; if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "?definitionScript?"); return TCL_ERROR; } else if (objc == Tcl_ObjectContextSkippedArgs(context)) { return TCL_OK; } - /* - * Make the class definition delegate. This is special; it doesn't reenter - * here (and the class definition delegate doesn't run any constructors). - */ - - nameObj = Tcl_NewStringObj(oPtr->namespacePtr->fullName, -1); - Tcl_AppendToObj(nameObj, ":: oo ::delegate", -1); - Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->fPtr->classCls, - TclGetString(nameObj), NULL, -1, NULL, -1); - Tcl_DecrRefCount(nameObj); - /* * Delegate to [oo::define] to do the work. */ - invoke = Tcl_Alloc(3 * sizeof(Tcl_Obj *)); + invoke = ckalloc(3 * sizeof(Tcl_Obj *)); invoke[0] = oPtr->fPtr->defineName; invoke[1] = TclOOObjectName(interp, oPtr); invoke[2] = objv[objc-1]; /* @@ -120,11 +109,11 @@ Tcl_IncrRefCount(invoke[0]); Tcl_IncrRefCount(invoke[1]); Tcl_IncrRefCount(invoke[2]); TclNRAddCallback(interp, DecrRefsPostClassConstructor, - invoke, oPtr, NULL, NULL); + invoke, NULL, NULL, NULL); /* * Tricky point: do not want the extra reported level in the Tcl stack * trace, so use TCL_EVAL_NOERR. */ @@ -137,31 +126,16 @@ ClientData data[], Tcl_Interp *interp, int result) { Tcl_Obj **invoke = data[0]; - Object *oPtr = data[1]; - Tcl_InterpState saved; - int code; TclDecrRefCount(invoke[0]); TclDecrRefCount(invoke[1]); TclDecrRefCount(invoke[2]); - invoke[0] = Tcl_NewStringObj("::oo::MixinClassDelegates", -1); - invoke[1] = TclOOObjectName(interp, oPtr); - Tcl_IncrRefCount(invoke[0]); - Tcl_IncrRefCount(invoke[1]); - saved = Tcl_SaveInterpState(interp, result); - code = Tcl_EvalObjv(interp, 2, invoke, 0); - TclDecrRefCount(invoke[0]); - TclDecrRefCount(invoke[1]); - Tcl_Free(invoke); - if (code != TCL_OK) { - Tcl_DiscardInterpState(saved); - return code; - } - return Tcl_RestoreInterpState(interp, saved); + ckfree(invoke); + return result; } /* * ---------------------------------------------------------------------- * @@ -181,11 +155,11 @@ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* The actual arguments. */ { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); const char *objName; - size_t len; + int len; /* * Sanity check; should not be possible to invoke this method on a * non-class. */ @@ -206,11 +180,11 @@ if (objc - Tcl_ObjectContextSkippedArgs(context) < 1) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "objectName ?arg ...?"); return TCL_ERROR; } - objName = TclGetStringFromObj( + objName = Tcl_GetStringFromObj( objv[Tcl_ObjectContextSkippedArgs(context)], &len); if (len == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "object name must not be empty", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL); @@ -246,11 +220,11 @@ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* The actual arguments. */ { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); const char *objName, *nsName; - size_t len; + int len; /* * Sanity check; should not be possible to invoke this method on a * non-class. */ @@ -271,19 +245,19 @@ if (objc - Tcl_ObjectContextSkippedArgs(context) < 2) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "objectName namespaceName ?arg ...?"); return TCL_ERROR; } - objName = TclGetStringFromObj( + objName = Tcl_GetStringFromObj( objv[Tcl_ObjectContextSkippedArgs(context)], &len); if (len == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "object name must not be empty", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL); return TCL_ERROR; } - nsName = TclGetStringFromObj( + nsName = Tcl_GetStringFromObj( objv[Tcl_ObjectContextSkippedArgs(context)+1], &len); if (len == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "namespace name must not be empty", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL); @@ -371,12 +345,11 @@ NULL); return TCL_ERROR; } if (!(oPtr->flags & DESTRUCTOR_CALLED)) { oPtr->flags |= DESTRUCTOR_CALLED; - contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL, - NULL); + contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL); if (contextPtr != NULL) { contextPtr->callPtr->flags |= DESTRUCTOR; contextPtr->skip = 0; TclNRAddCallback(interp, AfterNRDestructor, contextPtr, NULL, NULL, NULL); @@ -524,16 +497,13 @@ Tcl_ObjectContext context, /* The object/call context. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* The actual arguments. */ { CallContext *contextPtr = (CallContext *) context; - Object *callerObj = NULL; - Class *callerCls = NULL; Object *oPtr = contextPtr->oPtr; const char **methodNames; int numMethodNames, i, skip = Tcl_ObjectContextSkippedArgs(context); - CallFrame *framePtr = ((Interp *) interp)->varFramePtr; Tcl_Obj *errorMsg; /* * If no method name, generate an error asking for a method name. (Only by * overriding *this* method can an object handle the absence of a method @@ -543,36 +513,15 @@ if (objc < skip+1) { Tcl_WrongNumArgs(interp, skip, objv, "method ?arg ...?"); return TCL_ERROR; } - /* - * Determine if the calling context should know about extra private - * methods, and if so, which. - */ - - if (framePtr->isProcCallFrame & FRAME_IS_METHOD) { - CallContext *callerContext = framePtr->clientData; - Method *mPtr = callerContext->callPtr->chain[ - callerContext->index].mPtr; - - if (mPtr->declaringObjectPtr) { - if (oPtr == mPtr->declaringObjectPtr) { - callerObj = mPtr->declaringObjectPtr; - } - } else { - if (TclOOIsReachable(mPtr->declaringClassPtr, oPtr->selfCls)) { - callerCls = mPtr->declaringClassPtr; - } - } - } - /* * Get the list of methods that we want to know about. */ - numMethodNames = TclOOGetSortedMethodList(oPtr, callerObj, callerCls, + numMethodNames = TclOOGetSortedMethodList(oPtr, contextPtr->callPtr->flags & PUBLIC_METHOD, &methodNames); /* * Special message when there are no visible methods at all. */ @@ -603,11 +552,11 @@ } if (i) { Tcl_AppendToObj(errorMsg, " or ", -1); } Tcl_AppendToObj(errorMsg, methodNames[i], -1); - Tcl_Free((void *)methodNames); + ckfree(methodNames); Tcl_SetObjResult(interp, errorMsg); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[skip]), NULL); return TCL_ERROR; } @@ -733,20 +682,19 @@ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* The actual arguments. */ { Var *varPtr, *aryVar; Tcl_Obj *varNamePtr, *argPtr; - CallFrame *framePtr = ((Interp *) interp)->varFramePtr; const char *arg; if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "varName"); return TCL_ERROR; } argPtr = objv[objc-1]; - arg = TclGetString(argPtr); + arg = Tcl_GetString(argPtr); /* * Convert the variable name to fully-qualified form if it wasn't already. * This has to be done prior to lookup because we can run into problems * with resolvers otherwise. [Bug 3603695] @@ -759,62 +707,10 @@ varNamePtr = argPtr; } else { Tcl_Namespace *namespacePtr = Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context)); - /* - * Private method handling. [TIP 500] - * - * If we're in a context that can see some private methods of an - * object, we may need to precede a variable name with its prefix. - * This is a little tricky as we need to check through the inheritance - * hierarchy when the method was declared by a class to see if the - * current object is an instance of that class. - */ - - if (framePtr->isProcCallFrame & FRAME_IS_METHOD) { - Object *oPtr = (Object *) Tcl_ObjectContextObject(context); - CallContext *callerContext = framePtr->clientData; - Method *mPtr = callerContext->callPtr->chain[ - callerContext->index].mPtr; - PrivateVariableMapping *pvPtr; - int i; - - if (mPtr->declaringObjectPtr == oPtr) { - FOREACH_STRUCT(pvPtr, oPtr->privateVariables) { - if (!strcmp(TclGetString(pvPtr->variableObj), - TclGetString(argPtr))) { - argPtr = pvPtr->fullNameObj; - break; - } - } - } else if (mPtr->declaringClassPtr && - mPtr->declaringClassPtr->privateVariables.num) { - Class *clsPtr = mPtr->declaringClassPtr; - int isInstance = TclOOIsReachable(clsPtr, oPtr->selfCls); - Class *mixinCls; - - if (!isInstance) { - FOREACH(mixinCls, oPtr->mixins) { - if (TclOOIsReachable(clsPtr, mixinCls)) { - isInstance = 1; - break; - } - } - } - if (isInstance) { - FOREACH_STRUCT(pvPtr, clsPtr->privateVariables) { - if (!strcmp(TclGetString(pvPtr->variableObj), - TclGetString(argPtr))) { - argPtr = pvPtr->fullNameObj; - break; - } - } - } - } - } - varNamePtr = Tcl_NewStringObj(namespacePtr->fullName, -1); Tcl_AppendToObj(varNamePtr, "::", 2); Tcl_AppendObjToObj(varNamePtr, argPtr); } Tcl_IncrRefCount(varNamePtr); @@ -831,20 +727,30 @@ * (including traversing variable links), convert back to a name. */ varNamePtr = Tcl_NewObj(); if (aryVar != NULL) { + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Tcl_GetVariableFullName(interp, (Tcl_Var) aryVar, varNamePtr); /* * WARNING! This code pokes inside the implementation of hash tables! */ - Tcl_AppendToObj(varNamePtr, "(", -1); - Tcl_AppendObjToObj(varNamePtr, ((VarInHash *) - varPtr)->entry.key.objPtr); - Tcl_AppendToObj(varNamePtr, ")", -1); + hPtr = Tcl_FirstHashEntry((Tcl_HashTable *) aryVar->value.tablePtr, + &search); + while (hPtr != NULL) { + if (varPtr == Tcl_GetHashValue(hPtr)) { + Tcl_AppendToObj(varNamePtr, "(", -1); + Tcl_AppendObjToObj(varNamePtr, hPtr->key.objPtr); + Tcl_AppendToObj(varNamePtr, ")", -1); + break; + } + hPtr = Tcl_NextHashEntry(&search); + } } else { Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, varNamePtr); } Tcl_SetObjResult(interp, varNamePtr); return TCL_OK; @@ -1247,11 +1153,11 @@ Tcl_SetObjResult(interp, Tcl_NewListObj(2, result)); return TCL_OK; } case SELF_CALL: result[0] = TclOORenderCallChain(interp, contextPtr->callPtr); - result[1] = Tcl_NewIntObj(contextPtr->index); + TclNewIntObj(result[1], contextPtr->index); Tcl_SetObjResult(interp, Tcl_NewListObj(2, result)); return TCL_OK; } return TCL_ERROR; } Index: generic/tclOOCall.c ================================================================== --- generic/tclOOCall.c +++ generic/tclOOCall.c @@ -13,11 +13,10 @@ #ifdef HAVE_CONFIG_H #include "config.h" #endif #include "tclInt.h" #include "tclOOInt.h" -#include /* * Structure containing a CallContext and any other values needed only during * the construction of the CallContext. */ @@ -29,26 +28,10 @@ * main call chain. */ Object *oPtr; /* The object that we are building the chain * for. */ }; -/* - * Structures used for traversing the class hierarchy to find out where - * definitions are supposed to be done. - */ - -typedef struct { - Class *definerCls; - Tcl_Obj *namespaceName; -} DefineEntry; - -typedef struct { - DefineEntry *list; - int num; - int size; -} DefineChain; - /* * Extra flags used for call chain management. */ #define DEFINITE_PROTECTED 0x100000 @@ -60,32 +43,10 @@ #define OBJECT_MIXIN 0x1000000 #define MIXIN_CONSISTENT(flags) \ (((flags) & OBJECT_MIXIN) || \ !((flags) & BUILDING_MIXINS) == !((flags) & TRAVERSED_MIXIN)) -/* - * Note that the flag bit PRIVATE_METHOD has a confusing name; it's just for - * Itcl's special type of private. - */ - -#define IS_PUBLIC(mPtr) \ - (((mPtr)->flags & PUBLIC_METHOD) != 0) -#define IS_UNEXPORTED(mPtr) \ - (((mPtr)->flags & SCOPE_FLAGS) == 0) -#define IS_ITCLPRIVATE(mPtr) \ - (((mPtr)->flags & PRIVATE_METHOD) != 0) -#define IS_PRIVATE(mPtr) \ - (((mPtr)->flags & TRUE_PRIVATE_METHOD) != 0) -#define WANT_PUBLIC(flags) \ - (((flags) & PUBLIC_METHOD) != 0) -#define WANT_UNEXPORTED(flags) \ - (((flags) & (PRIVATE_METHOD | TRUE_PRIVATE_METHOD)) == 0) -#define WANT_ITCLPRIVATE(flags) \ - (((flags) & PRIVATE_METHOD) != 0) -#define WANT_PRIVATE(flags) \ - (((flags) & TRUE_PRIVATE_METHOD) != 0) - /* * Function declarations for things defined in this file. */ static void AddClassFiltersToCallContext(Object *const oPtr, @@ -92,55 +53,32 @@ Class *clsPtr, struct ChainBuilder *const cbPtr, Tcl_HashTable *const doneFilters, int flags); static void AddClassMethodNames(Class *clsPtr, const int flags, Tcl_HashTable *const namesPtr, Tcl_HashTable *const examinedClassesPtr); -static inline void AddDefinitionNamespaceToChain(Class *const definerCls, - Tcl_Obj *const namespaceName, - DefineChain *const definePtr, int flags); -static inline void AddMethodToCallChain(Method *const mPtr, - struct ChainBuilder *const cbPtr, - Tcl_HashTable *const doneFilters, - Class *const filterDecl, int flags); -static inline int AddInstancePrivateToCallContext(Object *const oPtr, - Tcl_Obj *const methodNameObj, - struct ChainBuilder *const cbPtr, int flags); -static inline void AddStandardMethodName(int flags, Tcl_Obj *namePtr, - Method *mPtr, Tcl_HashTable *namesPtr); -static inline void AddPrivateMethodNames(Tcl_HashTable *methodsTablePtr, - Tcl_HashTable *namesPtr); -static inline int AddSimpleChainToCallContext(Object *const oPtr, - Class *const contextCls, - Tcl_Obj *const methodNameObj, - struct ChainBuilder *const cbPtr, - Tcl_HashTable *const doneFilters, int flags, - Class *const filterDecl); -static int AddPrivatesFromClassChainToCallContext(Class *classPtr, - Class *const contextCls, - Tcl_Obj *const methodNameObj, - struct ChainBuilder *const cbPtr, - Tcl_HashTable *const doneFilters, int flags, - Class *const filterDecl); -static int AddSimpleClassChainToCallContext(Class *classPtr, - Tcl_Obj *const methodNameObj, - struct ChainBuilder *const cbPtr, - Tcl_HashTable *const doneFilters, int flags, - Class *const filterDecl); -static void AddSimpleClassDefineNamespaces(Class *classPtr, - DefineChain *const definePtr, int flags); -static inline void AddSimpleDefineNamespaces(Object *const oPtr, - DefineChain *const definePtr, int flags); +static inline void AddMethodToCallChain(Method *const mPtr, + struct ChainBuilder *const cbPtr, + Tcl_HashTable *const doneFilters, + Class *const filterDecl, int flags); +static inline void AddSimpleChainToCallContext(Object *const oPtr, + Tcl_Obj *const methodNameObj, + struct ChainBuilder *const cbPtr, + Tcl_HashTable *const doneFilters, int flags, + Class *const filterDecl); +static void AddSimpleClassChainToCallContext(Class *classPtr, + Tcl_Obj *const methodNameObj, + struct ChainBuilder *const cbPtr, + Tcl_HashTable *const doneFilters, int flags, + Class *const filterDecl); static int CmpStr(const void *ptr1, const void *ptr2); static void DupMethodNameRep(Tcl_Obj *srcPtr, Tcl_Obj *dstPtr); static Tcl_NRPostProc FinalizeMethodRefs; static void FreeMethodNameRep(Tcl_Obj *objPtr); static inline int IsStillValid(CallChain *callPtr, Object *oPtr, int flags, int reuseMask); static Tcl_NRPostProc ResetFilterFlags; static Tcl_NRPostProc SetFilterFlags; -static int SortMethodNames(Tcl_HashTable *namesPtr, int flags, - const char ***stringsPtr); static inline void StashCallChain(Tcl_Obj *objPtr, CallChain *callPtr); /* * Object type used to manage type caches attached to method names. */ @@ -150,11 +88,10 @@ FreeMethodNameRep, DupMethodNameRep, NULL, NULL }; - /* * ---------------------------------------------------------------------- * * TclOODeleteContext -- @@ -166,11 +103,11 @@ void TclOODeleteContext( CallContext *contextPtr) { - register Object *oPtr = contextPtr->oPtr; + Object *oPtr = contextPtr->oPtr; TclOODeleteChain(contextPtr->callPtr); if (oPtr != NULL) { TclStackFree(oPtr->fPtr->interp, contextPtr); @@ -203,11 +140,11 @@ if (callPtr) { TclOODeleteChain(callPtr); } } Tcl_DeleteHashTable(tablePtr); - Tcl_Free(tablePtr); + ckfree(tablePtr); } /* * ---------------------------------------------------------------------- * @@ -224,13 +161,13 @@ { if (callPtr == NULL || callPtr->refCount-- > 1) { return; } if (callPtr->chain != callPtr->staticChain) { - Tcl_Free(callPtr->chain); + ckfree(callPtr->chain); } - Tcl_Free(callPtr); + ckfree(callPtr); } /* * ---------------------------------------------------------------------- * @@ -245,16 +182,15 @@ static inline void StashCallChain( Tcl_Obj *objPtr, CallChain *callPtr) { - Tcl_ObjIntRep ir; - callPtr->refCount++; TclGetString(objPtr); - ir.twoPtrValue.ptr1 = callPtr; - Tcl_StoreIntRep(objPtr, &methodNameType, &ir); + TclFreeIntRep(objPtr); + objPtr->typePtr = &methodNameType; + objPtr->internalRep.twoPtrValue.ptr1 = callPtr; } void TclOOStashContext( Tcl_Obj *objPtr, @@ -277,20 +213,25 @@ static void DupMethodNameRep( Tcl_Obj *srcPtr, Tcl_Obj *dstPtr) { - StashCallChain(dstPtr, - TclFetchIntRep(srcPtr, &methodNameType)->twoPtrValue.ptr1); + CallChain *callPtr = srcPtr->internalRep.twoPtrValue.ptr1; + + dstPtr->typePtr = &methodNameType; + dstPtr->internalRep.twoPtrValue.ptr1 = callPtr; + callPtr->refCount++; } static void FreeMethodNameRep( Tcl_Obj *objPtr) { - TclOODeleteChain( - TclFetchIntRep(objPtr, &methodNameType)->twoPtrValue.ptr1); + CallChain *callPtr = objPtr->internalRep.twoPtrValue.ptr1; + + TclOODeleteChain(callPtr); + objPtr->typePtr = NULL; } /* * ---------------------------------------------------------------------- * @@ -312,11 +253,11 @@ * commands, variables) depending on method * implementation. */ int objc, /* The number of arguments. */ Tcl_Obj *const objv[]) /* The arguments as actually seen. */ { - register CallContext *const contextPtr = clientData; + CallContext *const contextPtr = clientData; Method *const mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; const int isFilter = contextPtr->callPtr->chain[contextPtr->index].isFilter; /* @@ -423,18 +364,10 @@ */ int TclOOGetSortedMethodList( Object *oPtr, /* The object to get the method names for. */ - Object *contextObj, /* From what context object we are inquiring. - * NULL when the context shouldn't see - * object-level private methods. Note that - * flags can override this. */ - Class *contextCls, /* From what context class we are inquiring. - * NULL when the context shouldn't see - * class-level private methods. Note that - * flags can override this. */ int flags, /* Whether we just want the public method * names. */ const char ***stringsPtr) /* Where to write a pointer to the array of * strings to. */ { @@ -443,14 +376,16 @@ Tcl_HashTable examinedClasses; /* Used to track what classes have been looked * at. Is set-like in nature and keyed by * pointer to class. */ FOREACH_HASH_DECLS; - int i, numStrings; + int i; Class *mixinPtr; Tcl_Obj *namePtr; Method *mPtr; + int isWantedIn; + void *isWanted; Tcl_InitObjHashTable(&names); Tcl_InitHashTable(&examinedClasses, TCL_ONE_WORD_KEYS); /* @@ -463,64 +398,107 @@ * Process method names due to the object. */ if (oPtr->methodsPtr) { FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) { - if (IS_PRIVATE(mPtr)) { + int isNew; + + if ((mPtr->flags & PRIVATE_METHOD) && !(flags & PRIVATE_METHOD)) { continue; } - if (IS_UNEXPORTED(mPtr) && !WANT_UNEXPORTED(flags)) { - continue; + hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew); + if (isNew) { + isWantedIn = ((!(flags & PUBLIC_METHOD) + || mPtr->flags & PUBLIC_METHOD) ? IN_LIST : 0); + isWantedIn |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0); + Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn)); } - AddStandardMethodName(flags, namePtr, mPtr, &names); } } /* * Process method names due to private methods on the object's class. */ - if (WANT_UNEXPORTED(flags)) { + if (flags & PRIVATE_METHOD) { FOREACH_HASH(namePtr, mPtr, &oPtr->selfCls->classMethods) { - if (IS_UNEXPORTED(mPtr)) { - AddStandardMethodName(flags, namePtr, mPtr, &names); - } - } - } - - /* - * Process method names due to private methods on the context's object or - * class. Which must be correct if either are not NULL. - */ - - if (contextObj && contextObj->methodsPtr) { - AddPrivateMethodNames(contextObj->methodsPtr, &names); - } - if (contextCls) { - AddPrivateMethodNames(&contextCls->classMethods, &names); + if (mPtr->flags & PRIVATE_METHOD) { + int isNew; + + hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew); + if (isNew) { + isWantedIn = IN_LIST; + if (mPtr->typePtr == NULL) { + isWantedIn |= NO_IMPLEMENTATION; + } + Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn)); + } else if (mPtr->typePtr != NULL) { + isWantedIn = PTR2INT(Tcl_GetHashValue(hPtr)); + if (isWantedIn & NO_IMPLEMENTATION) { + isWantedIn &= ~NO_IMPLEMENTATION; + Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn)); + } + } + } + } } /* * Process (normal) method names from the class hierarchy and the mixin * hierarchy. */ AddClassMethodNames(oPtr->selfCls, flags, &names, &examinedClasses); FOREACH(mixinPtr, oPtr->mixins) { - AddClassMethodNames(mixinPtr, flags | TRAVERSED_MIXIN, &names, + AddClassMethodNames(mixinPtr, flags|TRAVERSED_MIXIN, &names, &examinedClasses); } - /* - * Tidy up, sort the names and resolve finally whether we really want - * them (processing export layering). - */ - Tcl_DeleteHashTable(&examinedClasses); - numStrings = SortMethodNames(&names, flags, stringsPtr); + + /* + * See how many (visible) method names there are. If none, we do not (and + * should not) try to sort the list of them. + */ + + i = 0; + if (names.numEntries != 0) { + const char **strings; + + /* + * We need to build the list of methods to sort. We will be using + * qsort() for this, because it is very unlikely that the list will be + * heavily sorted when it is long enough to matter. + */ + + strings = ckalloc(sizeof(char *) * names.numEntries); + FOREACH_HASH(namePtr, isWanted, &names) { + if (!(flags & PUBLIC_METHOD) || (PTR2INT(isWanted) & IN_LIST)) { + if (PTR2INT(isWanted) & NO_IMPLEMENTATION) { + continue; + } + strings[i++] = TclGetString(namePtr); + } + } + + /* + * Note that 'i' may well be less than names.numEntries when we are + * dealing with public method names. + */ + + if (i > 0) { + if (i > 1) { + qsort((void *) strings, i, sizeof(char *), CmpStr); + } + *stringsPtr = strings; + } else { + ckfree(strings); + } + } + Tcl_DeleteHashTable(&names); - return numStrings; + return i; } int TclOOGetSortedClassMethodList( Class *clsPtr, /* The class to get the method names for. */ @@ -533,11 +511,14 @@ * mapping. */ Tcl_HashTable examinedClasses; /* Used to track what classes have been looked * at. Is set-like in nature and keyed by * pointer to class. */ - int numStrings; + FOREACH_HASH_DECLS; + int i; + Tcl_Obj *namePtr; + void *isWanted; Tcl_InitObjHashTable(&names); Tcl_InitHashTable(&examinedClasses, TCL_ONE_WORD_KEYS); /* @@ -545,106 +526,56 @@ */ AddClassMethodNames(clsPtr, flags, &names, &examinedClasses); Tcl_DeleteHashTable(&examinedClasses); - /* - * Process private method names if we should. [TIP 500] - */ - - if (WANT_PRIVATE(flags)) { - AddPrivateMethodNames(&clsPtr->classMethods, &names); - flags &= ~TRUE_PRIVATE_METHOD; - } - - /* - * Tidy up, sort the names and resolve finally whether we really want - * them (processing export layering). - */ - - numStrings = SortMethodNames(&names, flags, stringsPtr); - Tcl_DeleteHashTable(&names); - return numStrings; -} - -/* - * ---------------------------------------------------------------------- - * - * SortMethodNames -- - * - * Shared helper for TclOOGetSortedMethodList etc. that knows the method - * sorting rules. - * - * Returns: - * The length of the sorted list. - * - * ---------------------------------------------------------------------- - */ - -static int -SortMethodNames( - Tcl_HashTable *namesPtr, /* The table of names; unsorted, but contains - * whether the names are wanted and under what - * circumstances. */ - int flags, /* Whether we are looking for unexported - * methods. Full private methods are handled - * on insertion to the table. */ - const char ***stringsPtr) /* Where to store the sorted list of strings - * that we produce. Tcl_Alloced() */ -{ - const char **strings; - FOREACH_HASH_DECLS; - Tcl_Obj *namePtr; - void *isWanted; - size_t i = 0; - /* * See how many (visible) method names there are. If none, we do not (and * should not) try to sort the list of them. */ - if (namesPtr->numEntries == 0) { - *stringsPtr = NULL; - return 0; - } - - /* - * We need to build the list of methods to sort. We will be using qsort() - * for this, because it is very unlikely that the list will be heavily - * sorted when it is long enough to matter. - */ - - strings = Tcl_Alloc(sizeof(char *) * namesPtr->numEntries); - FOREACH_HASH(namePtr, isWanted, namesPtr) { - if (!WANT_PUBLIC(flags) || (PTR2INT(isWanted) & IN_LIST)) { - if (PTR2INT(isWanted) & NO_IMPLEMENTATION) { - continue; - } - strings[i++] = TclGetString(namePtr); - } - } - - /* - * Note that 'i' may well be less than names.numEntries when we are - * dealing with public method names. We don't sort unless there's at least - * two method names. - */ - - if (i > 0) { - if (i > 1) { - qsort((void *) strings, i, sizeof(char *), CmpStr); - } - *stringsPtr = strings; - } else { - Tcl_Free((void *)strings); - *stringsPtr = NULL; - } + i = 0; + if (names.numEntries != 0) { + const char **strings; + + /* + * We need to build the list of methods to sort. We will be using + * qsort() for this, because it is very unlikely that the list will be + * heavily sorted when it is long enough to matter. + */ + + strings = ckalloc(sizeof(char *) * names.numEntries); + FOREACH_HASH(namePtr, isWanted, &names) { + if (!(flags & PUBLIC_METHOD) || (PTR2INT(isWanted) & IN_LIST)) { + if (PTR2INT(isWanted) & NO_IMPLEMENTATION) { + continue; + } + strings[i++] = TclGetString(namePtr); + } + } + + /* + * Note that 'i' may well be less than names.numEntries when we are + * dealing with public method names. + */ + + if (i > 0) { + if (i > 1) { + qsort((void *) strings, i, sizeof(char *), CmpStr); + } + *stringsPtr = strings; + } else { + ckfree(strings); + } + } + + Tcl_DeleteHashTable(&names); return i; } /* - * Comparator for SortMethodNames + * Comparator for GetSortedMethodList */ static int CmpStr( const void *ptr1, @@ -684,12 +615,10 @@ /* Hash table that tracks what classes have * already been looked at. The keys are the * pointers to the classes, and the values are * immaterial. */ { - int i; - /* * If we've already started looking at this class, stop working on it now * to prevent repeated work. */ @@ -716,10 +645,11 @@ break; } if (clsPtr->mixins.num != 0) { Class *mixinPtr; + int i; FOREACH(mixinPtr, clsPtr->mixins) { if (mixinPtr != clsPtr) { AddClassMethodNames(mixinPtr, flags|TRAVERSED_MIXIN, namesPtr, examinedClassesPtr); @@ -726,20 +656,34 @@ } } } FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) { - AddStandardMethodName(flags, namePtr, mPtr, namesPtr); + hPtr = Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew); + if (isNew) { + int isWanted = (!(flags & PUBLIC_METHOD) + || (mPtr->flags & PUBLIC_METHOD)) ? IN_LIST : 0; + + isWanted |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0); + Tcl_SetHashValue(hPtr, INT2PTR(isWanted)); + } else if ((PTR2INT(Tcl_GetHashValue(hPtr)) & NO_IMPLEMENTATION) + && mPtr->typePtr != NULL) { + int isWanted = PTR2INT(Tcl_GetHashValue(hPtr)); + + isWanted &= ~NO_IMPLEMENTATION; + Tcl_SetHashValue(hPtr, INT2PTR(isWanted)); + } } if (clsPtr->superclasses.num != 1) { break; } clsPtr = clsPtr->superclasses.list[0]; } if (clsPtr->superclasses.num != 0) { Class *superPtr; + int i; FOREACH(superPtr, clsPtr->superclasses) { AddClassMethodNames(superPtr, flags, namesPtr, examinedClassesPtr); } @@ -747,125 +691,23 @@ } /* * ---------------------------------------------------------------------- * - * AddPrivateMethodNames, AddStandardMethodName -- - * - * Factored-out helpers for the sorted name list production functions. - * - * ---------------------------------------------------------------------- - */ - -static inline void -AddPrivateMethodNames( - Tcl_HashTable *methodsTablePtr, - Tcl_HashTable *namesPtr) -{ - FOREACH_HASH_DECLS; - Method *mPtr; - Tcl_Obj *namePtr; - - FOREACH_HASH(namePtr, mPtr, methodsTablePtr) { - if (IS_PRIVATE(mPtr)) { - int isNew; - - hPtr = Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew); - Tcl_SetHashValue(hPtr, INT2PTR(IN_LIST)); - } - } -} - -static inline void -AddStandardMethodName( - int flags, - Tcl_Obj *namePtr, - Method *mPtr, - Tcl_HashTable *namesPtr) -{ - if (!IS_PRIVATE(mPtr)) { - int isNew; - Tcl_HashEntry *hPtr = - Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew); - - if (isNew) { - int isWanted = (!WANT_PUBLIC(flags) || IS_PUBLIC(mPtr)) - ? IN_LIST : 0; - - isWanted |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0); - Tcl_SetHashValue(hPtr, INT2PTR(isWanted)); - } else if ((PTR2INT(Tcl_GetHashValue(hPtr)) & NO_IMPLEMENTATION) - && mPtr->typePtr != NULL) { - int isWanted = PTR2INT(Tcl_GetHashValue(hPtr)); - - isWanted &= ~NO_IMPLEMENTATION; - Tcl_SetHashValue(hPtr, INT2PTR(isWanted)); - } - } -} - -#undef IN_LIST -#undef NO_IMPLEMENTATION - -/* - * ---------------------------------------------------------------------- - * - * AddInstancePrivateToCallContext -- - * - * Add private methods from the instance. Called when the calling Tcl - * context is a TclOO method declared by an object that is the same as - * the current object. Returns true iff a private method was actually - * found and added to the call chain (as this suppresses caching). - * - * ---------------------------------------------------------------------- - */ - -static inline int -AddInstancePrivateToCallContext( - Object *const oPtr, /* Object to add call chain entries for. */ - Tcl_Obj *const methodName, /* Name of method to add the call chain - * entries for. */ - struct ChainBuilder *const cbPtr, - /* Where to add the call chain entries. */ - int flags) /* What sort of call chain are we building. */ -{ - Tcl_HashEntry *hPtr; - Method *mPtr; - int donePrivate = 0; - - if (oPtr->methodsPtr) { - hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodName); - if (hPtr != NULL) { - mPtr = Tcl_GetHashValue(hPtr); - if (IS_PRIVATE(mPtr)) { - AddMethodToCallChain(mPtr, cbPtr, NULL, NULL, flags); - donePrivate = 1; - } - } - } - return donePrivate; -} - -/* - * ---------------------------------------------------------------------- - * - * AddSimpleChainToCallContext -- - * - * The core of the call-chain construction engine, this handles calling a - * particular method on a particular object. Note that filters and - * unknown handling are already handled by the logic that uses this - * function. Returns true if a private method was one of those found. - * - * ---------------------------------------------------------------------- - */ - -static inline int -AddSimpleChainToCallContext( - Object *const oPtr, /* Object to add call chain entries for. */ - Class *const contextCls, /* Context class; the currently considered - * class is equal to this, private methods may - * also be added. [TIP 500] */ + * AddSimpleChainToCallContext -- + * + * The core of the call-chain construction engine, this handles calling a + * particular method on a particular object. Note that filters and + * unknown handling are already handled by the logic that uses this + * function. + * + * ---------------------------------------------------------------------- + */ + +static inline void +AddSimpleChainToCallContext( + Object *const oPtr, /* Object to add call chain entries for. */ Tcl_Obj *const methodNameObj, /* Name of method to add the call chain * entries for. */ struct ChainBuilder *const cbPtr, /* Where to add the call chain entries. */ @@ -875,66 +717,48 @@ int flags, /* What sort of call chain are we building. */ Class *const filterDecl) /* The class that declared the filter. If * NULL, either the filter was declared by the * object or this isn't a filter. */ { - int i, foundPrivate = 0, blockedUnexported = 0; - Tcl_HashEntry *hPtr; - Method *mPtr; + int i; if (!(flags & (KNOWN_STATE | SPECIAL)) && oPtr->methodsPtr) { - hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodNameObj); + Tcl_HashEntry *hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, + (char *) methodNameObj); if (hPtr != NULL) { - mPtr = Tcl_GetHashValue(hPtr); - if (!IS_PRIVATE(mPtr)) { - if (WANT_PUBLIC(flags)) { - if (!IS_PUBLIC(mPtr)) { - blockedUnexported = 1; - } else { - flags |= DEFINITE_PUBLIC; - } - } else { - flags |= DEFINITE_PROTECTED; - } + Method *mPtr = Tcl_GetHashValue(hPtr); + + if (flags & PUBLIC_METHOD) { + if (!(mPtr->flags & PUBLIC_METHOD)) { + return; + } else { + flags |= DEFINITE_PUBLIC; + } + } else { + flags |= DEFINITE_PROTECTED; } } } if (!(flags & SPECIAL)) { + Tcl_HashEntry *hPtr; Class *mixinPtr; FOREACH(mixinPtr, oPtr->mixins) { - if (contextCls) { - foundPrivate |= AddPrivatesFromClassChainToCallContext( - mixinPtr, contextCls, methodNameObj, cbPtr, - doneFilters, flags|TRAVERSED_MIXIN, filterDecl); - } - foundPrivate |= AddSimpleClassChainToCallContext(mixinPtr, - methodNameObj, cbPtr, doneFilters, - flags | TRAVERSED_MIXIN, filterDecl); - } - if (oPtr->methodsPtr && !blockedUnexported) { + AddSimpleClassChainToCallContext(mixinPtr, methodNameObj, cbPtr, + doneFilters, flags|TRAVERSED_MIXIN, filterDecl); + } + if (oPtr->methodsPtr) { hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char*) methodNameObj); if (hPtr != NULL) { - mPtr = Tcl_GetHashValue(hPtr); - if (!IS_PRIVATE(mPtr)) { - AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, - flags); - } + AddMethodToCallChain(Tcl_GetHashValue(hPtr), cbPtr, + doneFilters, filterDecl, flags); } } } - if (contextCls) { - foundPrivate |= AddPrivatesFromClassChainToCallContext(oPtr->selfCls, - contextCls, methodNameObj, cbPtr, doneFilters, flags, - filterDecl); - } - if (!blockedUnexported) { - foundPrivate |= AddSimpleClassChainToCallContext(oPtr->selfCls, - methodNameObj, cbPtr, doneFilters, flags, filterDecl); - } - return foundPrivate; + AddSimpleClassChainToCallContext(oPtr->selfCls, methodNameObj, cbPtr, + doneFilters, flags, filterDecl); } /* * ---------------------------------------------------------------------- * @@ -966,11 +790,11 @@ * we're looking to add things from a mixin * and we have passed a mixin, or we're not * looking to add things from a mixin and have * not passed a mixin. */ { - register CallChain *callPtr = cbPtr->callChainPtr; + CallChain *callPtr = cbPtr->callChainPtr; int i; /* * Return if this is just an entry used to record whether this is a public * method. If so, there's nothing real to call and so nothing to add to @@ -993,12 +817,12 @@ * * This does mean that only classes really handle private methods. This * should be sufficient for [incr Tcl] support though. */ - if (!WANT_UNEXPORTED(callPtr->flags) - && IS_UNEXPORTED(mPtr) + if (!(callPtr->flags & PRIVATE_METHOD) + && (mPtr->flags & PRIVATE_METHOD) && (mPtr->declaringClassPtr != NULL) && (mPtr->declaringClassPtr != cbPtr->oPtr->selfCls)) { return; } @@ -1035,15 +859,15 @@ * realloc-ing if the chain gets long. */ if (callPtr->numChain == CALL_CHAIN_STATIC_SIZE) { callPtr->chain = - Tcl_Alloc(sizeof(struct MInvoke) * (callPtr->numChain + 1)); + ckalloc(sizeof(struct MInvoke) * (callPtr->numChain + 1)); memcpy(callPtr->chain, callPtr->staticChain, sizeof(struct MInvoke) * callPtr->numChain); } else if (callPtr->numChain > CALL_CHAIN_STATIC_SIZE) { - callPtr->chain = Tcl_Realloc(callPtr->chain, + callPtr->chain = ckrealloc(callPtr->chain, sizeof(struct MInvoke) * (callPtr->numChain + 1)); } callPtr->chain[i].mPtr = mPtr; callPtr->chain[i].isFilter = (doneFilters != NULL); callPtr->chain[i].filterDeclarer = filterDecl; @@ -1082,11 +906,10 @@ /* * ---------------------------------------------------------------------- * * IsStillValid -- - * * Calculates whether the given call chain can be used for executing a * method for the given object. The condition on a chain from a cached * location being reusable is: * - Refers to the same object (same creation epoch), and * - Still across the same class structure (same global epoch), and @@ -1134,24 +957,18 @@ * destructor chain. */ int flags, /* What sort of context are we looking for. * Only the bits PUBLIC_METHOD, CONSTRUCTOR, * PRIVATE_METHOD, DESTRUCTOR and * FILTER_HANDLING are useful. */ - Object *contextObj, /* Context object; when equal to oPtr, it - * means that private methods may also be - * added. [TIP 500] */ - Class *contextCls, /* Context class; the currently considered - * class is equal to this, private methods may - * also be added. [TIP 500] */ Tcl_Obj *cacheInThisObj) /* What object to cache in, or NULL if it is * to be in the same object as the * methodNameObj. */ { CallContext *contextPtr; CallChain *callPtr; struct ChainBuilder cb; - int i, count, doFilters, donePrivate = 0; + int i, count, doFilters; Tcl_HashEntry *hPtr; Tcl_HashTable doneFilters; if (cacheInThisObj == NULL) { cacheInThisObj = methodNameObj; @@ -1187,20 +1004,19 @@ * of the cache. This is made a bit more complex by the fact that * there are multiple different layers of cache (in the Tcl_Obj, in * the object, and in the class). */ - const Tcl_ObjIntRep *irPtr; - const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD); + const int reuseMask = ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD); - if ((irPtr = TclFetchIntRep(cacheInThisObj, &methodNameType))) { - callPtr = irPtr->twoPtrValue.ptr1; + if (cacheInThisObj->typePtr == &methodNameType) { + callPtr = cacheInThisObj->internalRep.twoPtrValue.ptr1; if (IsStillValid(callPtr, oPtr, flags, reuseMask)) { callPtr->refCount++; goto returnContext; } - Tcl_StoreIntRep(cacheInThisObj, &methodNameType, NULL); + FreeMethodNameRep(cacheInThisObj); } if (oPtr->flags & USE_CLASS_CACHE) { if (oPtr->selfCls->classChainCache != NULL) { hPtr = Tcl_FindHashEntry(oPtr->selfCls->classChainCache, @@ -1228,11 +1044,11 @@ } doFilters = 1; } - callPtr = Tcl_Alloc(sizeof(CallChain)); + callPtr = ckalloc(sizeof(CallChain)); InitCallChain(callPtr, oPtr, flags); cb.callChainPtr = callPtr; cb.filterLength = 0; cb.oPtr = oPtr; @@ -1240,17 +1056,16 @@ /* * If we're working with a forced use of unknown, do that now. */ if (flags & FORCE_UNKNOWN) { - AddSimpleChainToCallContext(oPtr, NULL, - oPtr->fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS, - NULL); - AddSimpleChainToCallContext(oPtr, NULL, - oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); + AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj, + &cb, NULL, BUILDING_MIXINS, NULL); + AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj, + &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; - callPtr->epoch = 0; + callPtr->epoch = -1; if (callPtr->numChain == 0) { TclOODeleteChain(callPtr); return NULL; } goto returnContext; @@ -1273,14 +1088,14 @@ TRAVERSED_MIXIN|BUILDING_MIXINS|OBJECT_MIXIN); AddClassFiltersToCallContext(oPtr, mixinPtr, &cb, &doneFilters, OBJECT_MIXIN); } FOREACH(filterObj, oPtr->filters) { - donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls, - filterObj, &cb, &doneFilters, BUILDING_MIXINS, NULL); - donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls, - filterObj, &cb, &doneFilters, 0, NULL); + AddSimpleChainToCallContext(oPtr, filterObj, &cb, &doneFilters, + BUILDING_MIXINS, NULL); + AddSimpleChainToCallContext(oPtr, filterObj, &cb, &doneFilters, 0, + NULL); } AddClassFiltersToCallContext(oPtr, oPtr->selfCls, &cb, &doneFilters, BUILDING_MIXINS); AddClassFiltersToCallContext(oPtr, oPtr->selfCls, &cb, &doneFilters, 0); @@ -1291,19 +1106,13 @@ /* * Add the actual method implementations. We have to do this twice to * handle class mixins right. */ - if (oPtr == contextObj) { - donePrivate |= AddInstancePrivateToCallContext(oPtr, methodNameObj, - &cb, flags); - donePrivate |= (contextObj->flags & HAS_PRIVATE_METHODS); - } - donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls, - methodNameObj, &cb, NULL, flags|BUILDING_MIXINS, NULL); - donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls, - methodNameObj, &cb, NULL, flags, NULL); + AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL, + flags|BUILDING_MIXINS, NULL); + AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL, flags, NULL); /* * Check to see if the method has no implementation. If so, we probably * need to add in a call to the unknown method. Otherwise, set up the * cacheing of the method implementation (if relevant). @@ -1317,35 +1126,34 @@ if (flags & SPECIAL) { TclOODeleteChain(callPtr); return NULL; } - AddSimpleChainToCallContext(oPtr, NULL, - oPtr->fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS, - NULL); - AddSimpleChainToCallContext(oPtr, NULL, - oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); + AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj, + &cb, NULL, BUILDING_MIXINS, NULL); + AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj, + &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; - callPtr->epoch = 0; + callPtr->epoch = -1; if (count == callPtr->numChain) { TclOODeleteChain(callPtr); return NULL; } - } else if (doFilters && !donePrivate) { + } else if (doFilters) { if (hPtr == NULL) { if (oPtr->flags & USE_CLASS_CACHE) { if (oPtr->selfCls->classChainCache == NULL) { oPtr->selfCls->classChainCache = - Tcl_Alloc(sizeof(Tcl_HashTable)); + ckalloc(sizeof(Tcl_HashTable)); Tcl_InitObjHashTable(oPtr->selfCls->classChainCache); } hPtr = Tcl_CreateHashEntry(oPtr->selfCls->classChainCache, (char *) methodNameObj, &i); } else { if (oPtr->chainCache == NULL) { - oPtr->chainCache = Tcl_Alloc(sizeof(Tcl_HashTable)); + oPtr->chainCache = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitObjHashTable(oPtr->chainCache); } hPtr = Tcl_CreateHashEntry(oPtr->chainCache, (char *) methodNameObj, &i); @@ -1434,11 +1242,12 @@ if (clsPtr->classChainCache != NULL) { hPtr = Tcl_FindHashEntry(clsPtr->classChainCache, (char *) methodNameObj); if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) { - const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD); + const int reuseMask = + ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD); callPtr = Tcl_GetHashValue(hPtr); if (IsStillValid(callPtr, &obj, flags, reuseMask)) { callPtr->refCount++; return callPtr; @@ -1448,11 +1257,11 @@ } } else { hPtr = NULL; } - callPtr = Tcl_Alloc(sizeof(CallChain)); + callPtr = ckalloc(sizeof(CallChain)); memset(callPtr, 0, sizeof(CallChain)); callPtr->flags = flags & (PUBLIC_METHOD|PRIVATE_METHOD|FILTER_HANDLING); callPtr->epoch = fPtr->epoch; callPtr->objectCreationEpoch = fPtr->tsdPtr->nsCount; callPtr->objectEpoch = clsPtr->thisPtr->epoch; @@ -1478,36 +1287,35 @@ /* * Add the actual method implementations. */ - AddSimpleChainToCallContext(&obj, NULL, methodNameObj, &cb, NULL, + AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL, flags|BUILDING_MIXINS, NULL); - AddSimpleChainToCallContext(&obj, NULL, methodNameObj, &cb, NULL, flags, - NULL); + AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL, flags, NULL); /* * Check to see if the method has no implementation. If so, we probably * need to add in a call to the unknown method. Otherwise, set up the * cacheing of the method implementation (if relevant). */ if (count == callPtr->numChain) { - AddSimpleChainToCallContext(&obj, NULL, fPtr->unknownMethodNameObj, - &cb, NULL, BUILDING_MIXINS, NULL); - AddSimpleChainToCallContext(&obj, NULL, fPtr->unknownMethodNameObj, - &cb, NULL, 0, NULL); + AddSimpleChainToCallContext(&obj, fPtr->unknownMethodNameObj, &cb, + NULL, BUILDING_MIXINS, NULL); + AddSimpleChainToCallContext(&obj, fPtr->unknownMethodNameObj, &cb, + NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; - callPtr->epoch = 0; + callPtr->epoch = -1; if (count == callPtr->numChain) { TclOODeleteChain(callPtr); return NULL; } } else { if (hPtr == NULL) { if (clsPtr->classChainCache == NULL) { - clsPtr->classChainCache = Tcl_Alloc(sizeof(Tcl_HashTable)); + clsPtr->classChainCache = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitObjHashTable(clsPtr->classChainCache); } hPtr = Tcl_CreateHashEntry(clsPtr->classChainCache, (char *) methodNameObj, &i); } @@ -1573,13 +1381,13 @@ int isNew; (void) Tcl_CreateHashEntry(doneFilters, (char *) filterObj, &isNew); if (isNew) { - AddSimpleChainToCallContext(oPtr, NULL, filterObj, cbPtr, + AddSimpleChainToCallContext(oPtr, filterObj, cbPtr, doneFilters, clearedFlags|BUILDING_MIXINS, clsPtr); - AddSimpleChainToCallContext(oPtr, NULL, filterObj, cbPtr, + AddSimpleChainToCallContext(oPtr, filterObj, cbPtr, doneFilters, clearedFlags, clsPtr); } } } @@ -1602,26 +1410,22 @@ } /* * ---------------------------------------------------------------------- * - * AddPrivatesFromClassChainToCallContext -- + * AddSimpleClassChainToCallContext -- * - * Helper for AddSimpleChainToCallContext that is used to find private - * methds and add them to the call chain. Returns true when a private - * method is found and added. [TIP 500] + * Construct a call-chain from a class hierarchy. * * ---------------------------------------------------------------------- */ -static int -AddPrivatesFromClassChainToCallContext( +static void +AddSimpleClassChainToCallContext( Class *classPtr, /* Class to add the call chain entries for. */ - Class *const contextCls, /* Context class; the currently considered - * class is equal to this, private methods may - * also be added. */ - Tcl_Obj *const methodName, /* Name of method to add the call chain + Tcl_Obj *const methodNameObj, + /* Name of method to add the call chain * entries for. */ struct ChainBuilder *const cbPtr, /* Where to add the call chain entries. */ Tcl_HashTable *const doneFilters, /* Where to record what call chain entries @@ -1642,90 +1446,12 @@ * [Bug 1998221] */ tailRecurse: FOREACH(superPtr, classPtr->mixins) { - if (AddPrivatesFromClassChainToCallContext(superPtr, contextCls, - methodName, cbPtr, doneFilters, flags|TRAVERSED_MIXIN, - filterDecl)) { - return 1; - } - } - - if (classPtr == contextCls) { - Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods, - (char *) methodName); - - if (hPtr != NULL) { - register Method *mPtr = Tcl_GetHashValue(hPtr); - - if (IS_PRIVATE(mPtr)) { - AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, - flags); - return 1; - } - } - } - - switch (classPtr->superclasses.num) { - case 1: - classPtr = classPtr->superclasses.list[0]; - goto tailRecurse; - default: - FOREACH(superPtr, classPtr->superclasses) { - if (AddPrivatesFromClassChainToCallContext(superPtr, contextCls, - methodName, cbPtr, doneFilters, flags, filterDecl)) { - return 1; - } - } - case 0: - return 0; - } -} - -/* - * ---------------------------------------------------------------------- - * - * AddSimpleClassChainToCallContext -- - * - * Construct a call-chain from a class hierarchy. - * - * ---------------------------------------------------------------------- - */ - -static int -AddSimpleClassChainToCallContext( - Class *classPtr, /* Class to add the call chain entries for. */ - Tcl_Obj *const methodNameObj, - /* Name of method to add the call chain - * entries for. */ - struct ChainBuilder *const cbPtr, - /* Where to add the call chain entries. */ - Tcl_HashTable *const doneFilters, - /* Where to record what call chain entries - * have been processed. */ - int flags, /* What sort of call chain are we building. */ - Class *const filterDecl) /* The class that declared the filter. If - * NULL, either the filter was declared by the - * object or this isn't a filter. */ -{ - int i, privateDanger = 0; - Class *superPtr; - - /* - * We hard-code the tail-recursive form. It's by far the most common case - * *and* it is much more gentle on the stack. - * - * Note that mixins must be processed before the main class hierarchy. - * [Bug 1998221] - */ - - tailRecurse: - FOREACH(superPtr, classPtr->mixins) { - privateDanger |= AddSimpleClassChainToCallContext(superPtr, - methodNameObj, cbPtr, doneFilters, flags | TRAVERSED_MIXIN, - filterDecl); + AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr, + doneFilters, flags|TRAVERSED_MIXIN, filterDecl); } if (flags & CONSTRUCTOR) { AddMethodToCallChain(classPtr->constructorPtr, cbPtr, doneFilters, filterDecl, flags); @@ -1734,44 +1460,39 @@ filterDecl, flags); } else { Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods, (char *) methodNameObj); - if (classPtr->flags & HAS_PRIVATE_METHODS) { - privateDanger |= 1; - } if (hPtr != NULL) { - register Method *mPtr = Tcl_GetHashValue(hPtr); - - if (!IS_PRIVATE(mPtr)) { - if (!(flags & KNOWN_STATE)) { - if (flags & PUBLIC_METHOD) { - if (!IS_PUBLIC(mPtr)) { - return privateDanger; - } + Method *mPtr = Tcl_GetHashValue(hPtr); + + if (!(flags & KNOWN_STATE)) { + if (flags & PUBLIC_METHOD) { + if (mPtr->flags & PUBLIC_METHOD) { flags |= DEFINITE_PUBLIC; } else { - flags |= DEFINITE_PROTECTED; + return; } + } else { + flags |= DEFINITE_PROTECTED; } - AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, - flags); } + AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, flags); } } switch (classPtr->superclasses.num) { case 1: classPtr = classPtr->superclasses.list[0]; goto tailRecurse; default: FOREACH(superPtr, classPtr->superclasses) { - privateDanger |= AddSimpleClassChainToCallContext(superPtr, - methodNameObj, cbPtr, doneFilters, flags, filterDecl); + AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr, + doneFilters, flags, filterDecl); } case 0: - return privateDanger; + return; } } /* * ---------------------------------------------------------------------- @@ -1787,27 +1508,25 @@ Tcl_Obj * TclOORenderCallChain( Tcl_Interp *interp, CallChain *callPtr) { - Tcl_Obj *filterLiteral, *methodLiteral, *objectLiteral, *privateLiteral; + Tcl_Obj *filterLiteral, *methodLiteral, *objectLiteral; Tcl_Obj *resultObj, *descObjs[4], **objv; Foundation *fPtr = TclOOGetFoundation(interp); int i; /* * Allocate the literals (potentially) used in our description. */ - TclNewLiteralStringObj(filterLiteral, "filter"); + filterLiteral = Tcl_NewStringObj("filter", -1); Tcl_IncrRefCount(filterLiteral); - TclNewLiteralStringObj(methodLiteral, "method"); + methodLiteral = Tcl_NewStringObj("method", -1); Tcl_IncrRefCount(methodLiteral); - TclNewLiteralStringObj(objectLiteral, "object"); + objectLiteral = Tcl_NewStringObj("object", -1); Tcl_IncrRefCount(objectLiteral); - TclNewLiteralStringObj(privateLiteral, "private"); - Tcl_IncrRefCount(privateLiteral); /* * Do the actual construction of the descriptions. They consist of a list * of triples that describe the details of how a method is understood. For * each triple, the first word is the type of invocation ("method" is @@ -1821,19 +1540,20 @@ objv = TclStackAlloc(interp, callPtr->numChain * sizeof(Tcl_Obj *)); for (i = 0 ; i < callPtr->numChain ; i++) { struct MInvoke *miPtr = &callPtr->chain[i]; - descObjs[0] = - miPtr->isFilter ? filterLiteral : - callPtr->flags & OO_UNKNOWN_METHOD ? fPtr->unknownMethodNameObj : - IS_PRIVATE(miPtr->mPtr) ? privateLiteral : - methodLiteral; - descObjs[1] = - callPtr->flags & CONSTRUCTOR ? fPtr->constructorName : - callPtr->flags & DESTRUCTOR ? fPtr->destructorName : - miPtr->mPtr->namePtr; + descObjs[0] = miPtr->isFilter + ? filterLiteral + : callPtr->flags & OO_UNKNOWN_METHOD + ? fPtr->unknownMethodNameObj + : methodLiteral; + descObjs[1] = callPtr->flags & CONSTRUCTOR + ? fPtr->constructorName + : callPtr->flags & DESTRUCTOR + ? fPtr->destructorName + : miPtr->mPtr->namePtr; descObjs[2] = miPtr->mPtr->declaringClassPtr ? Tcl_GetObjectName(interp, (Tcl_Object) miPtr->mPtr->declaringClassPtr->thisPtr) : objectLiteral; descObjs[3] = Tcl_NewStringObj(miPtr->mPtr->typePtr->name, -1); @@ -1847,263 +1567,22 @@ */ Tcl_DecrRefCount(filterLiteral); Tcl_DecrRefCount(methodLiteral); Tcl_DecrRefCount(objectLiteral); - Tcl_DecrRefCount(privateLiteral); /* * Finish building the description and return it. */ resultObj = Tcl_NewListObj(callPtr->numChain, objv); TclStackFree(interp, objv); return resultObj; } - -/* - * ---------------------------------------------------------------------- - * - * TclOOGetDefineContextNamespace -- - * - * Responsible for determining which namespace to use for definitions. - * This is done by building a define chain, which models (strongly!) the - * way that a call chain works but with a different internal model. - * - * Then it walks the chain to find the first namespace name that actually - * resolves to an existing namespace. - * - * Returns: - * Name of namespace, or NULL if none can be found. Note that this - * function does *not* set an error message in the interpreter on failure. - * - * ---------------------------------------------------------------------- - */ - -#define DEFINE_CHAIN_STATIC_SIZE 4 /* Enough space to store most cases. */ - -Tcl_Namespace * -TclOOGetDefineContextNamespace( - Tcl_Interp *interp, /* In what interpreter should namespace names - * actually be resolved. */ - Object *oPtr, /* The object to get the context for. */ - int forClass) /* What sort of context are we looking for. - * If true, we are going to use this for - * [oo::define], otherwise, we are going to - * use this for [oo::objdefine]. */ -{ - DefineChain define; - DefineEntry staticSpace[DEFINE_CHAIN_STATIC_SIZE]; - DefineEntry *entryPtr; - Tcl_Namespace *nsPtr = NULL; - int i; - - define.list = staticSpace; - define.num = 0; - define.size = DEFINE_CHAIN_STATIC_SIZE; - - /* - * Add the actual define locations. We have to do this twice to handle - * class mixins right. - */ - - AddSimpleDefineNamespaces(oPtr, &define, forClass | BUILDING_MIXINS); - AddSimpleDefineNamespaces(oPtr, &define, forClass); - - /* - * Go through the list until we find a namespace whose name we can - * resolve. - */ - - FOREACH_STRUCT(entryPtr, define) { - if (TclGetNamespaceFromObj(interp, entryPtr->namespaceName, - &nsPtr) == TCL_OK) { - break; - } - Tcl_ResetResult(interp); - } - if (define.list != staticSpace) { - Tcl_Free(define.list); - } - return nsPtr; -} - -/* - * ---------------------------------------------------------------------- - * - * AddSimpleDefineNamespaces -- - * - * Adds to the definition chain all the definitions provided by an - * object's class and its mixins, taking into account everything they - * inherit from. - * - * ---------------------------------------------------------------------- - */ - -static inline void -AddSimpleDefineNamespaces( - Object *const oPtr, /* Object to add define chain entries for. */ - DefineChain *const definePtr, - /* Where to add the define chain entries. */ - int flags) /* What sort of define chain are we - * building. */ -{ - Class *mixinPtr; - int i; - - FOREACH(mixinPtr, oPtr->mixins) { - AddSimpleClassDefineNamespaces(mixinPtr, definePtr, - flags | TRAVERSED_MIXIN); - } - - AddSimpleClassDefineNamespaces(oPtr->selfCls, definePtr, flags); -} - -/* - * ---------------------------------------------------------------------- - * - * AddSimpleClassDefineNamespaces -- - * - * Adds to the definition chain all the definitions provided by a class - * and its superclasses and its class mixins. - * - * ---------------------------------------------------------------------- - */ - -static void -AddSimpleClassDefineNamespaces( - Class *classPtr, /* Class to add the define chain entries for. */ - DefineChain *const definePtr, - /* Where to add the define chain entries. */ - int flags) /* What sort of define chain are we - * building. */ -{ - int i; - Class *superPtr; - - /* - * We hard-code the tail-recursive form. It's by far the most common case - * *and* it is much more gentle on the stack. - */ - - tailRecurse: - FOREACH(superPtr, classPtr->mixins) { - AddSimpleClassDefineNamespaces(superPtr, definePtr, - flags | TRAVERSED_MIXIN); - } - - if (flags & ~(TRAVERSED_MIXIN | BUILDING_MIXINS)) { - AddDefinitionNamespaceToChain(classPtr, classPtr->clsDefinitionNs, - definePtr, flags); - } else { - AddDefinitionNamespaceToChain(classPtr, classPtr->objDefinitionNs, - definePtr, flags); - } - - switch (classPtr->superclasses.num) { - case 1: - classPtr = classPtr->superclasses.list[0]; - goto tailRecurse; - default: - FOREACH(superPtr, classPtr->superclasses) { - AddSimpleClassDefineNamespaces(superPtr, definePtr, flags); - } - case 0: - return; - } -} - -/* - * ---------------------------------------------------------------------- - * - * AddDefinitionNamespaceToChain -- - * - * Adds a single item to the definition chain (if it is meaningful), - * reallocating the space for the chain if necessary. - * - * ---------------------------------------------------------------------- - */ - -static inline void -AddDefinitionNamespaceToChain( - Class *const definerCls, /* What class defines this entry. */ - Tcl_Obj *const namespaceName, /* The name for this entry (or NULL, a - * no-op). */ - DefineChain *const definePtr, - /* The define chain to add the method - * implementation to. */ - int flags) /* Used to check if we're mixin-consistent - * only. Mixin-consistent means that either - * we're looking to add things from a mixin - * and we have passed a mixin, or we're not - * looking to add things from a mixin and have - * not passed a mixin. */ -{ - int i; - - /* - * Return if this entry is blank. This is also where we enforce - * mixin-consistency. - */ - - if (namespaceName == NULL || !MIXIN_CONSISTENT(flags)) { - return; - } - - /* - * First test whether the method is already in the call chain. - */ - - for (i=0 ; inum ; i++) { - if (definePtr->list[i].definerCls == definerCls) { - /* - * Call chain semantics states that methods come as *late* in the - * call chain as possible. This is done by copying down the - * following methods. Note that this does not change the number of - * method invocations in the call chain; it just rearranges them. - * - * We skip changing anything if the place we found was already at - * the end of the list. - */ - - if (i < definePtr->num - 1) { - memmove(&definePtr->list[i], &definePtr->list[i + 1], - sizeof(DefineEntry) * (definePtr->num - i - 1)); - definePtr->list[i].definerCls = definerCls; - definePtr->list[i].namespaceName = namespaceName; - } - return; - } - } - - /* - * Need to really add the define. This is made a bit more complex by the - * fact that we are using some "static" space initially, and only start - * realloc-ing if the chain gets long. - */ - - if (definePtr->num == definePtr->size) { - definePtr->size *= 2; - if (definePtr->num == DEFINE_CHAIN_STATIC_SIZE) { - DefineEntry *staticList = definePtr->list; - - definePtr->list = - Tcl_Alloc(sizeof(DefineEntry) * definePtr->size); - memcpy(definePtr->list, staticList, - sizeof(DefineEntry) * definePtr->num); - } else { - definePtr->list = Tcl_Realloc(definePtr->list, - sizeof(DefineEntry) * definePtr->size); - } - } - definePtr->list[i].definerCls = definerCls; - definePtr->list[i].namespaceName = namespaceName; - definePtr->num++; -} /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: generic/tclOODecls.h ================================================================== --- generic/tclOODecls.h +++ generic/tclOODecls.h @@ -51,23 +51,23 @@ /* 8 */ TCLAPI int Tcl_MethodIsPublic(Tcl_Method method); /* 9 */ TCLAPI int Tcl_MethodIsType(Tcl_Method method, const Tcl_MethodType *typePtr, - void **clientDataPtr); + ClientData *clientDataPtr); /* 10 */ TCLAPI Tcl_Obj * Tcl_MethodName(Tcl_Method method); /* 11 */ TCLAPI Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, - int flags, const Tcl_MethodType *typePtr, - void *clientData); + int isPublic, const Tcl_MethodType *typePtr, + ClientData clientData); /* 12 */ TCLAPI Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, - Tcl_Obj *nameObj, int flags, + Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, - void *clientData); + ClientData clientData); /* 13 */ TCLAPI Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, int objc, Tcl_Obj *const *objv, int skip); @@ -82,23 +82,23 @@ TCLAPI Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context); /* 18 */ TCLAPI int Tcl_ObjectContextSkippedArgs( Tcl_ObjectContext context); /* 19 */ -TCLAPI void * Tcl_ClassGetMetadata(Tcl_Class clazz, +TCLAPI ClientData Tcl_ClassGetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr); /* 20 */ TCLAPI void Tcl_ClassSetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr, - void *metadata); + ClientData metadata); /* 21 */ -TCLAPI void * Tcl_ObjectGetMetadata(Tcl_Object object, +TCLAPI ClientData Tcl_ObjectGetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr); /* 22 */ TCLAPI void Tcl_ObjectSetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr, - void *metadata); + ClientData metadata); /* 23 */ TCLAPI int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv, int skip); /* 24 */ @@ -114,12 +114,10 @@ TCLAPI void Tcl_ClassSetDestructor(Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 28 */ TCLAPI Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object); -/* 29 */ -TCLAPI int Tcl_MethodIsPrivate(Tcl_Method method); typedef struct { const struct TclOOIntStubs *tclOOIntStubs; } TclOOStubHooks; @@ -134,31 +132,30 @@ Tcl_Object (*tcl_GetObjectFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 4 */ Tcl_Namespace * (*tcl_GetObjectNamespace) (Tcl_Object object); /* 5 */ Tcl_Class (*tcl_MethodDeclarerClass) (Tcl_Method method); /* 6 */ Tcl_Object (*tcl_MethodDeclarerObject) (Tcl_Method method); /* 7 */ int (*tcl_MethodIsPublic) (Tcl_Method method); /* 8 */ - int (*tcl_MethodIsType) (Tcl_Method method, const Tcl_MethodType *typePtr, void **clientDataPtr); /* 9 */ + int (*tcl_MethodIsType) (Tcl_Method method, const Tcl_MethodType *typePtr, ClientData *clientDataPtr); /* 9 */ Tcl_Obj * (*tcl_MethodName) (Tcl_Method method); /* 10 */ - Tcl_Method (*tcl_NewInstanceMethod) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, void *clientData); /* 11 */ - Tcl_Method (*tcl_NewMethod) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, void *clientData); /* 12 */ + Tcl_Method (*tcl_NewInstanceMethod) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 11 */ + Tcl_Method (*tcl_NewMethod) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */ Tcl_Object (*tcl_NewObjectInstance) (Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, int objc, Tcl_Obj *const *objv, int skip); /* 13 */ int (*tcl_ObjectDeleted) (Tcl_Object object); /* 14 */ int (*tcl_ObjectContextIsFiltering) (Tcl_ObjectContext context); /* 15 */ Tcl_Method (*tcl_ObjectContextMethod) (Tcl_ObjectContext context); /* 16 */ Tcl_Object (*tcl_ObjectContextObject) (Tcl_ObjectContext context); /* 17 */ int (*tcl_ObjectContextSkippedArgs) (Tcl_ObjectContext context); /* 18 */ - void * (*tcl_ClassGetMetadata) (Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr); /* 19 */ - void (*tcl_ClassSetMetadata) (Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr, void *metadata); /* 20 */ - void * (*tcl_ObjectGetMetadata) (Tcl_Object object, const Tcl_ObjectMetadataType *typePtr); /* 21 */ - void (*tcl_ObjectSetMetadata) (Tcl_Object object, const Tcl_ObjectMetadataType *typePtr, void *metadata); /* 22 */ + ClientData (*tcl_ClassGetMetadata) (Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr); /* 19 */ + void (*tcl_ClassSetMetadata) (Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 20 */ + ClientData (*tcl_ObjectGetMetadata) (Tcl_Object object, const Tcl_ObjectMetadataType *typePtr); /* 21 */ + void (*tcl_ObjectSetMetadata) (Tcl_Object object, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 22 */ int (*tcl_ObjectContextInvokeNext) (Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv, int skip); /* 23 */ Tcl_ObjectMapMethodNameProc * (*tcl_ObjectGetMethodNameMapper) (Tcl_Object object); /* 24 */ void (*tcl_ObjectSetMethodNameMapper) (Tcl_Object object, Tcl_ObjectMapMethodNameProc *mapMethodNameProc); /* 25 */ void (*tcl_ClassSetConstructor) (Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 26 */ void (*tcl_ClassSetDestructor) (Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 27 */ Tcl_Obj * (*tcl_GetObjectName) (Tcl_Interp *interp, Tcl_Object object); /* 28 */ - int (*tcl_MethodIsPrivate) (Tcl_Method method); /* 29 */ } TclOOStubs; extern const TclOOStubs *tclOOStubsPtr; #ifdef __cplusplus @@ -227,13 +224,11 @@ (tclOOStubsPtr->tcl_ClassSetConstructor) /* 26 */ #define Tcl_ClassSetDestructor \ (tclOOStubsPtr->tcl_ClassSetDestructor) /* 27 */ #define Tcl_GetObjectName \ (tclOOStubsPtr->tcl_GetObjectName) /* 28 */ -#define Tcl_MethodIsPrivate \ - (tclOOStubsPtr->tcl_MethodIsPrivate) /* 29 */ #endif /* defined(USE_TCLOO_STUBS) */ /* !END!: Do not edit above this line. */ #endif /* _TCLOODECLS */ Index: generic/tclOODefineCmds.c ================================================================== --- generic/tclOODefineCmds.c +++ generic/tclOODefineCmds.c @@ -14,16 +14,10 @@ #include "config.h" #endif #include "tclInt.h" #include "tclOOInt.h" -/* - * The actual value used to mark private declaration frames. - */ - -#define PRIVATE_FRAME (FRAME_IS_OO_DEFINE | FRAME_IS_PRIVATE_DEFINE) - /* * The maximum length of fully-qualified object name to use in an errorinfo * message. Longer than this will be curtailed. */ @@ -35,21 +29,18 @@ struct DeclaredSlot { const char *name; const Tcl_MethodType getterType; const Tcl_MethodType setterType; - const Tcl_MethodType resolverType; }; -#define SLOT(name,getter,setter,resolver) \ +#define SLOT(name,getter,setter) \ {"::oo::" name, \ {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Getter", \ getter, NULL, NULL}, \ {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \ - setter, NULL, NULL}, \ - {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Resolver", \ - resolver, NULL, NULL}} + setter, NULL, NULL}} /* * A [string match] pattern used to determine if a method should be exported. */ @@ -67,12 +58,10 @@ static inline int MagicDefinitionInvoke(Tcl_Interp *interp, Tcl_Namespace *nsPtr, int cmdIndex, int objc, Tcl_Obj *const *objv); static inline Class * GetClassInOuterContext(Tcl_Interp *interp, Tcl_Obj *className, const char *errMsg); -static inline Tcl_Namespace *GetNamespaceInOuterContext(Tcl_Interp *interp, - Tcl_Obj *namespaceName); static inline int InitDefineContext(Tcl_Interp *interp, Tcl_Namespace *namespacePtr, Object *oPtr, int objc, Tcl_Obj *const objv[]); static inline void RecomputeClassCacheFlag(Object *oPtr); static int RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr, @@ -118,63 +107,30 @@ Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); static int ObjVarsSet(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); -static int ResolveClass(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); /* * Now define the slots used in declarations. */ static const struct DeclaredSlot slots[] = { - SLOT("define::filter", ClassFilterGet, ClassFilterSet, NULL), - SLOT("define::mixin", ClassMixinGet, ClassMixinSet, ResolveClass), - SLOT("define::superclass", ClassSuperGet, ClassSuperSet, ResolveClass), - SLOT("define::variable", ClassVarsGet, ClassVarsSet, NULL), - SLOT("objdefine::filter", ObjFilterGet, ObjFilterSet, NULL), - SLOT("objdefine::mixin", ObjMixinGet, ObjMixinSet, ResolveClass), - SLOT("objdefine::variable", ObjVarsGet, ObjVarsSet, NULL), - {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}} + SLOT("define::filter", ClassFilterGet, ClassFilterSet), + SLOT("define::mixin", ClassMixinGet, ClassMixinSet), + SLOT("define::superclass", ClassSuperGet, ClassSuperSet), + SLOT("define::variable", ClassVarsGet, ClassVarsSet), + SLOT("objdefine::filter", ObjFilterGet, ObjFilterSet), + SLOT("objdefine::mixin", ObjMixinGet, ObjMixinSet), + SLOT("objdefine::variable", ObjVarsGet, ObjVarsSet), + {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}} }; - -/* - * How to build the in-namespace name of a private variable. This is a pattern - * used with Tcl_ObjPrintf(). - */ - -#define PRIVATE_VARIABLE_PATTERN "%d : %s" - -/* - * ---------------------------------------------------------------------- - * - * IsPrivateDefine -- - * - * Extracts whether the current context is handling private definitions. - * - * ---------------------------------------------------------------------- - */ - -static inline int -IsPrivateDefine( - Tcl_Interp *interp) -{ - Interp *iPtr = (Interp *) interp; - - if (!iPtr->varFramePtr) { - return 0; - } - return iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME; -} /* * ---------------------------------------------------------------------- * * BumpGlobalEpoch -- - * * Utility that ensures that call chains that are invalid will get thrown * away at an appropriate time. Note that exactly which epoch gets * advanced will depend on exactly what the class is tangled up in; in * the worst case, the simplest option is to advance the global epoch, * causing *everything* to be thrown away on next usage. @@ -215,11 +171,10 @@ /* * ---------------------------------------------------------------------- * * RecomputeClassCacheFlag -- - * * Determine whether the object is prototypical of its class, and hence * able to use the class's method chain cache. * * ---------------------------------------------------------------------- */ @@ -238,11 +193,10 @@ /* * ---------------------------------------------------------------------- * * TclOOObjectSetFilters -- - * * Install a list of filter method names into an object. * * ---------------------------------------------------------------------- */ @@ -265,11 +219,11 @@ if (numFilters == 0) { /* * No list of filters was supplied, so we're deleting filters. */ - Tcl_Free(oPtr->filters.list); + ckfree(oPtr->filters.list); oPtr->filters.list = NULL; oPtr->filters.num = 0; RecomputeClassCacheFlag(oPtr); } else { /* @@ -278,13 +232,13 @@ Tcl_Obj **filtersList; int size = sizeof(Tcl_Obj *) * numFilters; /* should be size_t */ if (oPtr->filters.num == 0) { - filtersList = Tcl_Alloc(size); + filtersList = ckalloc(size); } else { - filtersList = Tcl_Realloc(oPtr->filters.list, size); + filtersList = ckrealloc(oPtr->filters.list, size); } for (i = 0 ; i < numFilters ; i++) { filtersList[i] = filters[i]; Tcl_IncrRefCount(filters[i]); } @@ -297,11 +251,10 @@ /* * ---------------------------------------------------------------------- * * TclOOClassSetFilters -- - * * Install a list of filter method names into a class. * * ---------------------------------------------------------------------- */ @@ -325,11 +278,11 @@ if (numFilters == 0) { /* * No list of filters was supplied, so we're deleting filters. */ - Tcl_Free(classPtr->filters.list); + ckfree(classPtr->filters.list); classPtr->filters.list = NULL; classPtr->filters.num = 0; } else { /* * We've got a list of filters, so we're creating filters. @@ -337,13 +290,13 @@ Tcl_Obj **filtersList; int size = sizeof(Tcl_Obj *) * numFilters; /* should be size_t */ if (classPtr->filters.num == 0) { - filtersList = Tcl_Alloc(size); + filtersList = ckalloc(size); } else { - filtersList = Tcl_Realloc(classPtr->filters.list, size); + filtersList = ckrealloc(classPtr->filters.list, size); } for (i = 0 ; i < numFilters ; i++) { filtersList[i] = filters[i]; Tcl_IncrRefCount(filters[i]); } @@ -360,11 +313,10 @@ /* * ---------------------------------------------------------------------- * * TclOOObjectSetMixins -- - * * Install a list of mixin classes into an object. * * ---------------------------------------------------------------------- */ @@ -381,11 +333,11 @@ if (oPtr->mixins.num != 0) { FOREACH(mixinPtr, oPtr->mixins) { TclOORemoveFromInstances(oPtr, mixinPtr); TclOODecrRefCount(mixinPtr->thisPtr); } - Tcl_Free(oPtr->mixins.list); + ckfree(oPtr->mixins.list); oPtr->mixins.num = 0; } RecomputeClassCacheFlag(oPtr); } else { if (oPtr->mixins.num != 0) { @@ -393,14 +345,14 @@ if (mixinPtr && mixinPtr != oPtr->selfCls) { TclOORemoveFromInstances(oPtr, mixinPtr); } TclOODecrRefCount(mixinPtr->thisPtr); } - oPtr->mixins.list = Tcl_Realloc(oPtr->mixins.list, + oPtr->mixins.list = ckrealloc(oPtr->mixins.list, sizeof(Class *) * numMixins); } else { - oPtr->mixins.list = Tcl_Alloc(sizeof(Class *) * numMixins); + oPtr->mixins.list = ckalloc(sizeof(Class *) * numMixins); oPtr->flags &= ~USE_CLASS_CACHE; } oPtr->mixins.num = numMixins; memcpy(oPtr->mixins.list, mixins, sizeof(Class *) * numMixins); FOREACH(mixinPtr, oPtr->mixins) { @@ -420,11 +372,10 @@ /* * ---------------------------------------------------------------------- * * TclOOClassSetMixins -- - * * Install a list of mixin classes into a class. * * ---------------------------------------------------------------------- */ @@ -442,23 +393,23 @@ if (classPtr->mixins.num != 0) { FOREACH(mixinPtr, classPtr->mixins) { TclOORemoveFromMixinSubs(classPtr, mixinPtr); TclOODecrRefCount(mixinPtr->thisPtr); } - Tcl_Free(classPtr->mixins.list); + ckfree(classPtr->mixins.list); classPtr->mixins.num = 0; } } else { if (classPtr->mixins.num != 0) { FOREACH(mixinPtr, classPtr->mixins) { TclOORemoveFromMixinSubs(classPtr, mixinPtr); TclOODecrRefCount(mixinPtr->thisPtr); } - classPtr->mixins.list = Tcl_Realloc(classPtr->mixins.list, + classPtr->mixins.list = ckrealloc(classPtr->mixins.list, sizeof(Class *) * numMixins); } else { - classPtr->mixins.list = Tcl_Alloc(sizeof(Class *) * numMixins); + classPtr->mixins.list = ckalloc(sizeof(Class *) * numMixins); } classPtr->mixins.num = numMixins; memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins); FOREACH(mixinPtr, classPtr->mixins) { TclOOAddToMixinSubs(classPtr, mixinPtr); @@ -474,129 +425,11 @@ } /* * ---------------------------------------------------------------------- * - * InstallStandardVariableMapping, InstallPrivateVariableMapping -- - * - * Helpers for installing standard and private variable maps. - * - * ---------------------------------------------------------------------- - */ -static inline void -InstallStandardVariableMapping( - VariableNameList *vnlPtr, - int varc, - Tcl_Obj *const *varv) -{ - Tcl_Obj *variableObj; - int i, n, created; - Tcl_HashTable uniqueTable; - - for (i=0 ; ilist); - } else if (i) { - vnlPtr->list = Tcl_Realloc(vnlPtr->list, sizeof(Tcl_Obj *) * varc); - } else { - vnlPtr->list = Tcl_Alloc(sizeof(Tcl_Obj *) * varc); - } - } - vnlPtr->num = 0; - if (varc > 0) { - Tcl_InitObjHashTable(&uniqueTable); - for (i=n=0 ; ilist[n++] = varv[i]; - } else { - Tcl_DecrRefCount(varv[i]); - } - } - vnlPtr->num = n; - - /* - * Shouldn't be necessary, but maintain num/list invariant. - */ - - if (n != varc) { - vnlPtr->list = Tcl_Realloc(vnlPtr->list, sizeof(Tcl_Obj *) * n); - } - Tcl_DeleteHashTable(&uniqueTable); - } -} - -static inline void -InstallPrivateVariableMapping( - PrivateVariableList *pvlPtr, - int varc, - Tcl_Obj *const *varv, - int creationEpoch) -{ - PrivateVariableMapping *privatePtr; - int i, n, created; - Tcl_HashTable uniqueTable; - - for (i=0 ; ivariableObj); - Tcl_DecrRefCount(privatePtr->fullNameObj); - } - if (i != varc) { - if (varc == 0) { - Tcl_Free(pvlPtr->list); - } else if (i) { - pvlPtr->list = Tcl_Realloc(pvlPtr->list, - sizeof(PrivateVariableMapping) * varc); - } else { - pvlPtr->list = Tcl_Alloc(sizeof(PrivateVariableMapping) * varc); - } - } - - pvlPtr->num = 0; - if (varc > 0) { - Tcl_InitObjHashTable(&uniqueTable); - for (i=n=0 ; ilist[n++]); - privatePtr->variableObj = varv[i]; - privatePtr->fullNameObj = Tcl_ObjPrintf( - PRIVATE_VARIABLE_PATTERN, - creationEpoch, TclGetString(varv[i])); - Tcl_IncrRefCount(privatePtr->fullNameObj); - } else { - Tcl_DecrRefCount(varv[i]); - } - } - pvlPtr->num = n; - - /* - * Shouldn't be necessary, but maintain num/list invariant. - */ - - if (n != varc) { - pvlPtr->list = Tcl_Realloc(pvlPtr->list, - sizeof(PrivateVariableMapping) * n); - } - Tcl_DeleteHashTable(&uniqueTable); - } -} - -/* - * ---------------------------------------------------------------------- - * * RenameDeleteMethod -- - * * Core of the code to rename and delete methods. * * ---------------------------------------------------------------------- */ @@ -682,11 +515,10 @@ /* * ---------------------------------------------------------------------- * * TclOOUnknownDefinition -- - * * Handles what happens when an unknown command is encountered during the * processing of a definition script. Works by finding a command in the * operating definition namespace that the requested command is a unique * prefix of. * @@ -701,11 +533,11 @@ Tcl_Obj *const *objv) { Namespace *nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); Tcl_HashSearch search; Tcl_HashEntry *hPtr; - size_t soughtLen; + int soughtLen; const char *soughtStr, *matchedStr = NULL; if (objc < 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad call of unknown handler", -1)); @@ -714,11 +546,11 @@ } if (TclOOGetDefineCmdContext(interp) == NULL) { return TCL_ERROR; } - soughtStr = TclGetStringFromObj(objv[1], &soughtLen); + soughtStr = Tcl_GetStringFromObj(objv[1], &soughtLen); if (soughtLen == 0) { goto noMatch; } hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); while (hPtr != NULL) { @@ -762,11 +594,10 @@ /* * ---------------------------------------------------------------------- * * FindCommand -- - * * Specialized version of Tcl_FindCommand that handles command prefixes * and disallows namespace magic. * * ---------------------------------------------------------------------- */ @@ -775,12 +606,12 @@ FindCommand( Tcl_Interp *interp, Tcl_Obj *stringObj, Tcl_Namespace *const namespacePtr) { - size_t length; - const char *nameStr, *string = TclGetStringFromObj(stringObj, &length); + int length; + const char *nameStr, *string = Tcl_GetStringFromObj(stringObj, &length); register Namespace *const nsPtr = (Namespace *) namespacePtr; FOREACH_HASH_DECLS; Tcl_Command cmd, cmd2; /* @@ -823,11 +654,10 @@ /* * ---------------------------------------------------------------------- * * InitDefineContext -- - * * Does the magic incantations necessary to push the special stack frame * used when processing object definitions. It is up to the caller to * dispose of the frame (with TclPopStackFrame) when finished. * * ---------------------------------------------------------------------- @@ -843,11 +673,12 @@ { CallFrame *framePtr, **framePtrPtr = &framePtr; if (namespacePtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "no definition namespace available", -1)); + "cannot process definitions; support namespace deleted", + -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } /* @@ -865,11 +696,10 @@ /* * ---------------------------------------------------------------------- * * TclOOGetDefineCmdContext -- - * * Extracts the magic token from the current stack frame, or returns NULL * (and leaves an error message) otherwise. * * ---------------------------------------------------------------------- */ @@ -880,12 +710,11 @@ { Interp *iPtr = (Interp *) interp; Tcl_Object object; if ((iPtr->varFramePtr == NULL) - || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE - && iPtr->varFramePtr->isProcCallFrame != PRIVATE_FRAME)) { + || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "this command may only be called from within the context of" " an ::oo::define or ::oo::objdefine command", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return NULL; @@ -902,16 +731,15 @@ } /* * ---------------------------------------------------------------------- * - * GetClassInOuterContext, GetNamespaceInOuterContext -- - * - * Wrappers round Tcl_GetObjectFromObj and TclGetNamespaceFromObj to - * perform the lookup in the context that called oo::define (or - * equivalent). Note that this may have to go up multiple levels to get - * the level that we started doing definitions at. + * GetClassInOuterContext -- + * Wrapper round Tcl_GetObjectFromObj to perform the lookup in the + * context that called oo::define (or equivalent). Note that this may + * have to go up multiple levels to get the level that we started doing + * definitions at. * * ---------------------------------------------------------------------- */ static inline Class * @@ -922,12 +750,11 @@ { Interp *iPtr = (Interp *) interp; Object *oPtr; CallFrame *savedFramePtr = iPtr->varFramePtr; - while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE - || iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME) { + while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE) { if (iPtr->varFramePtr->callerVarPtr == NULL) { Tcl_Panic("getting outer context when already in global context"); } iPtr->varFramePtr = iPtr->varFramePtr->callerVarPtr; } @@ -942,41 +769,15 @@ TclGetString(className), NULL); return NULL; } return oPtr->classPtr; } - -static inline Tcl_Namespace * -GetNamespaceInOuterContext( - Tcl_Interp *interp, - Tcl_Obj *namespaceName) -{ - Interp *iPtr = (Interp *) interp; - Tcl_Namespace *nsPtr; - int result; - CallFrame *savedFramePtr = iPtr->varFramePtr; - - while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE - || iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME) { - if (iPtr->varFramePtr->callerVarPtr == NULL) { - Tcl_Panic("getting outer context when already in global context"); - } - iPtr->varFramePtr = iPtr->varFramePtr->callerVarPtr; - } - result = TclGetNamespaceFromObj(interp, namespaceName, &nsPtr); - iPtr->varFramePtr = savedFramePtr; - if (result != TCL_OK) { - return NULL; - } - return nsPtr; -} /* * ---------------------------------------------------------------------- * * GenerateErrorInfo -- - * * Factored out code to generate part of the error trace messages. * * ---------------------------------------------------------------------- */ @@ -994,28 +795,27 @@ * could have been renamed... */ const char *typeOfSubject) /* Part of the message, saying whether it was * an object, class or class-as-object that * was being configured. */ { - size_t length; + int length; Tcl_Obj *realNameObj = Tcl_ObjectDeleted((Tcl_Object) oPtr) ? savedNameObj : TclOOObjectName(interp, oPtr); - const char *objName = TclGetStringFromObj(realNameObj, &length); - unsigned limit = OBJNAME_LENGTH_IN_ERRORINFO_LIMIT; + const char *objName = Tcl_GetStringFromObj(realNameObj, &length); + int limit = OBJNAME_LENGTH_IN_ERRORINFO_LIMIT; int overflow = (length > limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (in definition script for %s \"%.*s%s\" line %d)", - typeOfSubject, (overflow ? limit : (unsigned)length), objName, + typeOfSubject, (overflow ? limit : length), objName, (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } /* * ---------------------------------------------------------------------- * * MagicDefinitionInvoke -- - * * Part of the implementation of the "oo::define" and "oo::objdefine" * commands that is used to implement the more-than-one-argument case, * applying ensemble-like tricks with dispatch so that error messages are * clearer. Doesn't handle the management of the stack frame. * @@ -1078,11 +878,10 @@ /* * ---------------------------------------------------------------------- * * TclOODefineObjCmd -- - * * Implementation of the "oo::define" command. Works by effectively doing * the same as 'namespace eval', but with extra magic applied so that the * object to be modified is known to the commands in the target * namespace. Also does ensemble-like tricks with dispatch so that error * messages are clearer. @@ -1095,11 +894,11 @@ ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { - Tcl_Namespace *nsPtr; + Foundation *fPtr = TclOOGetFoundation(interp); Object *oPtr; int result; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "className arg ?arg ...?"); @@ -1110,11 +909,11 @@ if (oPtr == NULL) { return TCL_ERROR; } if (oPtr->classPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%s does not refer to a class", TclGetString(objv[1]))); + "%s does not refer to a class",TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", TclGetString(objv[1]), NULL); return TCL_ERROR; } @@ -1121,12 +920,11 @@ /* * Make the oo::define namespace the current namespace and evaluate the * command(s). */ - nsPtr = TclOOGetDefineContextNamespace(interp, oPtr, 1); - if (InitDefineContext(interp, nsPtr, oPtr, objc, objv) != TCL_OK) { + if (InitDefineContext(interp, fPtr->defineNs, oPtr, objc,objv) != TCL_OK){ return TCL_ERROR; } AddRef(oPtr); if (objc == 3) { @@ -1138,11 +936,11 @@ if (result == TCL_ERROR) { GenerateErrorInfo(interp, oPtr, objNameObj, "class"); } TclDecrRefCount(objNameObj); } else { - result = MagicDefinitionInvoke(interp, nsPtr, 2, objc, objv); + result = MagicDefinitionInvoke(interp, fPtr->defineNs, 2, objc, objv); } TclOODecrRefCount(oPtr); /* * Restore the previous "current" namespace. @@ -1154,11 +952,10 @@ /* * ---------------------------------------------------------------------- * * TclOOObjDefObjCmd -- - * * Implementation of the "oo::objdefine" command. Works by effectively * doing the same as 'namespace eval', but with extra magic applied so * that the object to be modified is known to the commands in the target * namespace. Also does ensemble-like tricks with dispatch so that error * messages are clearer. @@ -1171,11 +968,11 @@ ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { - Tcl_Namespace *nsPtr; + Foundation *fPtr = TclOOGetFoundation(interp); Object *oPtr; int result; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "objectName arg ?arg ...?"); @@ -1190,12 +987,11 @@ /* * Make the oo::objdefine namespace the current namespace and evaluate the * command(s). */ - nsPtr = TclOOGetDefineContextNamespace(interp, oPtr, 0); - if (InitDefineContext(interp, nsPtr, oPtr, objc, objv) != TCL_OK) { + if (InitDefineContext(interp, fPtr->objdefNs, oPtr, objc,objv) != TCL_OK){ return TCL_ERROR; } AddRef(oPtr); if (objc == 3) { @@ -1207,11 +1003,11 @@ if (result == TCL_ERROR) { GenerateErrorInfo(interp, oPtr, objNameObj, "object"); } TclDecrRefCount(objNameObj); } else { - result = MagicDefinitionInvoke(interp, nsPtr, 2, objc, objv); + result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 2, objc, objv); } TclOODecrRefCount(oPtr); /* * Restore the previous "current" namespace. @@ -1223,11 +1019,10 @@ /* * ---------------------------------------------------------------------- * * TclOODefineSelfObjCmd -- - * * Implementation of the "self" subcommand of the "oo::define" command. * Works by effectively doing the same as 'namespace eval', but with * extra magic applied so that the object to be modified is known to the * commands in the target namespace. Also does ensemble-like tricks with * dispatch so that error messages are clearer. @@ -1240,52 +1035,46 @@ ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { - Tcl_Namespace *nsPtr; + Foundation *fPtr = TclOOGetFoundation(interp); Object *oPtr; - int result, private; - - oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { - return TCL_ERROR; - } + int result; if (objc < 2) { - Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr)); - return TCL_OK; + Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?"); + return TCL_ERROR; } - private = IsPrivateDefine(interp); + oPtr = (Object *) TclOOGetDefineCmdContext(interp); + if (oPtr == NULL) { + return TCL_ERROR; + } /* * Make the oo::objdefine namespace the current namespace and evaluate the * command(s). */ - nsPtr = TclOOGetDefineContextNamespace(interp, oPtr, 0); - if (InitDefineContext(interp, nsPtr, oPtr, objc, objv) != TCL_OK) { + if (InitDefineContext(interp, fPtr->objdefNs, oPtr, objc,objv) != TCL_OK){ return TCL_ERROR; } - if (private) { - ((Interp *) interp)->varFramePtr->isProcCallFrame = PRIVATE_FRAME; - } AddRef(oPtr); if (objc == 2) { Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr); Tcl_IncrRefCount(objNameObj); result = TclEvalObjEx(interp, objv[1], 0, - ((Interp *)interp)->cmdFramePtr, 1); + ((Interp *)interp)->cmdFramePtr, 2); if (result == TCL_ERROR) { GenerateErrorInfo(interp, oPtr, objNameObj, "class object"); } TclDecrRefCount(objNameObj); } else { - result = MagicDefinitionInvoke(interp, nsPtr, 1, objc, objv); + result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 1, objc, objv); } TclOODecrRefCount(oPtr); /* * Restore the previous "current" namespace. @@ -1296,119 +1085,11 @@ } /* * ---------------------------------------------------------------------- * - * TclOODefineObjSelfObjCmd -- - * - * Implementation of the "self" subcommand of the "oo::objdefine" - * command. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineObjSelfObjCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr; - - if (objc != 1) { - Tcl_WrongNumArgs(interp, 1, objv, NULL); - return TCL_ERROR; - } - - oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { - return TCL_ERROR; - } - - Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr)); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODefinePrivateObjCmd -- - * - * Implementation of the "private" subcommand of the "oo::define" - * and "oo::objdefine" commands. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefinePrivateObjCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - int isInstancePrivate = (clientData != NULL); - /* Just so that we can generate the correct - * error message depending on the context of - * usage of this function. */ - Interp *iPtr = (Interp *) interp; - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int saved; /* The saved flag. We restore it on exit so - * that [private private ...] doesn't make - * things go weird. */ - int result; - - if (oPtr == NULL) { - return TCL_ERROR; - } - if (objc == 1) { - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(IsPrivateDefine(interp))); - return TCL_OK; - } - - /* - * Change the frame type flag while evaluating the body. - */ - - saved = iPtr->varFramePtr->isProcCallFrame; - iPtr->varFramePtr->isProcCallFrame = PRIVATE_FRAME; - - /* - * Evaluate the body; standard pattern. - */ - - AddRef(oPtr); - if (objc == 2) { - Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr); - - Tcl_IncrRefCount(objNameObj); - result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1); - if (result == TCL_ERROR) { - GenerateErrorInfo(interp, oPtr, objNameObj, - isInstancePrivate ? "object" : "class"); - } - TclDecrRefCount(objNameObj); - } else { - result = MagicDefinitionInvoke(interp, TclGetCurrentNamespace(interp), - 1, objc, objv); - } - TclOODecrRefCount(oPtr); - - /* - * Restore the frame type flag to what it was previously. - */ - - iPtr->varFramePtr->isProcCallFrame = saved; - return result; -} - -/* - * ---------------------------------------------------------------------- - * * TclOODefineClassObjCmd -- - * * Implementation of the "class" subcommand of the "oo::objdefine" * command. * * ---------------------------------------------------------------------- */ @@ -1494,12 +1175,12 @@ oPtr->fPtr->epoch++; oPtr->flags |= DONT_DELETE; TclOODeleteDescendants(interp, oPtr); oPtr->flags &= ~DONT_DELETE; TclOOReleaseClassContents(interp, oPtr); - Tcl_Free(oPtr->classPtr); - oPtr->classPtr = NULL; + ckfree(oPtr->classPtr); + oPtr->classPtr = NULL; } else if (!wasClass && willBeClass) { TclOOAllocClass(interp, oPtr); } if (oPtr->classPtr != NULL) { @@ -1513,11 +1194,10 @@ /* * ---------------------------------------------------------------------- * * TclOODefineConstructorObjCmd -- - * * Implementation of the "constructor" subcommand of the "oo::define" * command. * * ---------------------------------------------------------------------- */ @@ -1530,11 +1210,11 @@ Tcl_Obj *const *objv) { Object *oPtr; Class *clsPtr; Tcl_Method method; - size_t bodyLength; + int bodyLength; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "arguments body"); return TCL_ERROR; } @@ -1548,11 +1228,11 @@ if (oPtr == NULL) { return TCL_ERROR; } clsPtr = oPtr->classPtr; - (void)TclGetStringFromObj(objv[2], &bodyLength); + Tcl_GetStringFromObj(objv[2], &bodyLength); if (bodyLength > 0) { /* * Create the method structure. */ @@ -1581,97 +1261,11 @@ } /* * ---------------------------------------------------------------------- * - * TclOODefineDefnNsObjCmd -- - * - * Implementation of the "definitionnamespace" subcommand of the - * "oo::define" command. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineDefnNsObjCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - static const char *kindList[] = { - "-class", - "-instance", - NULL - }; - int kind = 0; - Object *oPtr; - Tcl_Namespace *nsPtr; - Tcl_Obj *nsNamePtr, **storagePtr; - - oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { - return TCL_ERROR; - } - if (!oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); - return TCL_ERROR; - } - if (oPtr->flags & (ROOT_OBJECT | ROOT_CLASS)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "may not modify the definition namespace of the root classes", - -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); - return TCL_ERROR; - } - - /* - * Parse the arguments and work out what the user wants to do. - */ - - if (objc != 2 && objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "?kind? namespace"); - return TCL_ERROR; - } - if (objc == 3 && Tcl_GetIndexFromObj(interp, objv[1], kindList, "kind", 0, - &kind) != TCL_OK) { - return TCL_ERROR; - } - if (!TclGetString(objv[objc - 1])[0]) { - nsNamePtr = NULL; - } else { - nsPtr = GetNamespaceInOuterContext(interp, objv[objc - 1]); - if (nsPtr == NULL) { - return TCL_ERROR; - } - nsNamePtr = Tcl_NewStringObj(nsPtr->fullName, -1); - Tcl_IncrRefCount(nsNamePtr); - } - - /* - * Update the correct field of the class definition. - */ - - if (kind) { - storagePtr = &oPtr->classPtr->objDefinitionNs; - } else { - storagePtr = &oPtr->classPtr->clsDefinitionNs; - } - if (*storagePtr != NULL) { - Tcl_DecrRefCount(*storagePtr); - } - *storagePtr = nsNamePtr; - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * * TclOODefineDeleteMethodObjCmd -- - * * Implementation of the "deletemethod" subcommand of the "oo::define" * and "oo::objdefine" commands. * * ---------------------------------------------------------------------- */ @@ -1724,11 +1318,10 @@ /* * ---------------------------------------------------------------------- * * TclOODefineDestructorObjCmd -- - * * Implementation of the "destructor" subcommand of the "oo::define" * command. * * ---------------------------------------------------------------------- */ @@ -1741,11 +1334,11 @@ Tcl_Obj *const *objv) { Object *oPtr; Class *clsPtr; Tcl_Method method; - size_t bodyLength; + int bodyLength; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "body"); return TCL_ERROR; } @@ -1754,11 +1347,11 @@ if (oPtr == NULL) { return TCL_ERROR; } clsPtr = oPtr->classPtr; - (void)TclGetStringFromObj(objv[1], &bodyLength); + Tcl_GetStringFromObj(objv[1], &bodyLength); if (bodyLength > 0) { /* * Create the method structure. */ @@ -1789,11 +1382,10 @@ /* * ---------------------------------------------------------------------- * * TclOODefineExportObjCmd -- - * * Implementation of the "export" subcommand of the "oo::define" and * "oo::objdefine" commands. * * ---------------------------------------------------------------------- */ @@ -1839,11 +1431,11 @@ * their flags member. */ if (isInstanceExport) { if (!oPtr->methodsPtr) { - oPtr->methodsPtr = Tcl_Alloc(sizeof(Tcl_HashTable)); + oPtr->methodsPtr = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitObjHashTable(oPtr->methodsPtr); oPtr->flags &= ~USE_CLASS_CACHE; } hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) objv[i], &isNew); @@ -1851,22 +1443,21 @@ hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char*) objv[i], &isNew); } if (isNew) { - mPtr = Tcl_Alloc(sizeof(Method)); + mPtr = ckalloc(sizeof(Method)); memset(mPtr, 0, sizeof(Method)); mPtr->refCount = 1; mPtr->namePtr = objv[i]; Tcl_IncrRefCount(objv[i]); Tcl_SetHashValue(hPtr, mPtr); } else { mPtr = Tcl_GetHashValue(hPtr); } - if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) { + if (isNew || !(mPtr->flags & PUBLIC_METHOD)) { mPtr->flags |= PUBLIC_METHOD; - mPtr->flags &= ~TRUE_PRIVATE_METHOD; changed = 1; } } /* @@ -1885,11 +1476,10 @@ /* * ---------------------------------------------------------------------- * * TclOODefineForwardObjCmd -- - * * Implementation of the "forward" subcommand of the "oo::define" and * "oo::objdefine" commands. * * ---------------------------------------------------------------------- */ @@ -1922,13 +1512,10 @@ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN) ? PUBLIC_METHOD : 0; - if (IsPrivateDefine(interp)) { - isPublic = TRUE_PRIVATE_METHOD; - } /* * Create the method structure. */ @@ -1949,11 +1536,10 @@ /* * ---------------------------------------------------------------------- * * TclOODefineMethodObjCmd -- - * * Implementation of the "method" subcommand of the "oo::define" and * "oo::objdefine" commands. * * ---------------------------------------------------------------------- */ @@ -1963,32 +1549,16 @@ ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { - /* - * Table of export modes for methods and their corresponding enum. - */ - - static const char *const exportModes[] = { - "-export", - "-private", - "-unexport", - NULL - }; - enum ExportMode { - MODE_EXPORT, - MODE_PRIVATE, - MODE_UNEXPORT - } exportMode; - int isInstanceMethod = (clientData != NULL); Object *oPtr; - int isPublic = 0; + int isPublic; - if (objc < 4 || objc > 5) { - Tcl_WrongNumArgs(interp, 1, objv, "name ?option? args body"); + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "name args body"); return TCL_ERROR; } oPtr = (Object *) TclOOGetDefineCmdContext(interp); if (oPtr == NULL) { @@ -1998,47 +1568,25 @@ Tcl_SetObjResult(interp, Tcl_NewStringObj( "attempt to misuse API", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } - if (objc == 5) { - if (Tcl_GetIndexFromObj(interp, objv[2], exportModes, "export flag", - 0, (int *) &exportMode) != TCL_OK) { - return TCL_ERROR; - } - switch (exportMode) { - case MODE_EXPORT: - isPublic = PUBLIC_METHOD; - break; - case MODE_PRIVATE: - isPublic = TRUE_PRIVATE_METHOD; - break; - case MODE_UNEXPORT: - isPublic = 0; - break; - } - } else { - if (IsPrivateDefine(interp)) { - isPublic = TRUE_PRIVATE_METHOD; - } else { - isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN) - ? PUBLIC_METHOD : 0; - } - } + isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN) + ? PUBLIC_METHOD : 0; /* * Create the method by using the right back-end API. */ if (isInstanceMethod) { if (TclOONewProcInstanceMethod(interp, oPtr, isPublic, objv[1], - objv[objc - 2], objv[objc - 1], NULL) == NULL) { + objv[2], objv[3], NULL) == NULL) { return TCL_ERROR; } } else { if (TclOONewProcMethod(interp, oPtr->classPtr, isPublic, objv[1], - objv[objc - 2], objv[objc - 1], NULL) == NULL) { + objv[2], objv[3], NULL) == NULL) { return TCL_ERROR; } } return TCL_OK; } @@ -2045,11 +1593,10 @@ /* * ---------------------------------------------------------------------- * * TclOODefineRenameMethodObjCmd -- - * * Implementation of the "renamemethod" subcommand of the "oo::define" * and "oo::objdefine" commands. * * ---------------------------------------------------------------------- */ @@ -2102,11 +1649,10 @@ /* * ---------------------------------------------------------------------- * * TclOODefineUnexportObjCmd -- - * * Implementation of the "unexport" subcommand of the "oo::define" and * "oo::objdefine" commands. * * ---------------------------------------------------------------------- */ @@ -2152,11 +1698,11 @@ * their flags member. */ if (isInstanceUnexport) { if (!oPtr->methodsPtr) { - oPtr->methodsPtr = Tcl_Alloc(sizeof(Tcl_HashTable)); + oPtr->methodsPtr = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitObjHashTable(oPtr->methodsPtr); oPtr->flags &= ~USE_CLASS_CACHE; } hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) objv[i], &isNew); @@ -2164,21 +1710,21 @@ hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char*) objv[i], &isNew); } if (isNew) { - mPtr = Tcl_Alloc(sizeof(Method)); + mPtr = ckalloc(sizeof(Method)); memset(mPtr, 0, sizeof(Method)); mPtr->refCount = 1; mPtr->namePtr = objv[i]; Tcl_IncrRefCount(objv[i]); Tcl_SetHashValue(hPtr, mPtr); } else { mPtr = Tcl_GetHashValue(hPtr); } - if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) { - mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD); + if (isNew || mPtr->flags & PUBLIC_METHOD) { + mPtr->flags &= ~PUBLIC_METHOD; changed = 1; } } /* @@ -2197,11 +1743,10 @@ /* * ---------------------------------------------------------------------- * * Tcl_ClassSetConstructor, Tcl_ClassSetDestructor -- - * * How to install a constructor or destructor into a class; API to call * from C. * * ---------------------------------------------------------------------- */ @@ -2252,11 +1797,10 @@ /* * ---------------------------------------------------------------------- * * TclOODefineSlots -- - * * Create the "::oo::Slot" class and its standard instances. Class * definition is empty at the stage (added by scripting). * * ---------------------------------------------------------------------- */ @@ -2266,21 +1810,19 @@ Foundation *fPtr) { const struct DeclaredSlot *slotInfoPtr; Tcl_Obj *getName = Tcl_NewStringObj("Get", -1); Tcl_Obj *setName = Tcl_NewStringObj("Set", -1); - Tcl_Obj *resolveName = Tcl_NewStringObj("Resolve", -1); Class *slotCls; slotCls = ((Object *) Tcl_NewObjectInstance(fPtr->interp, (Tcl_Class) fPtr->classCls, "::oo::Slot", NULL, -1, NULL, 0))->classPtr; if (slotCls == NULL) { return TCL_ERROR; } Tcl_IncrRefCount(getName); Tcl_IncrRefCount(setName); - Tcl_IncrRefCount(resolveName); for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) { Tcl_Object slotObject = Tcl_NewObjectInstance(fPtr->interp, (Tcl_Class) slotCls, slotInfoPtr->name, NULL, -1, NULL, 0); if (slotObject == NULL) { @@ -2288,26 +1830,20 @@ } Tcl_NewInstanceMethod(fPtr->interp, slotObject, getName, 0, &slotInfoPtr->getterType, NULL); Tcl_NewInstanceMethod(fPtr->interp, slotObject, setName, 0, &slotInfoPtr->setterType, NULL); - if (slotInfoPtr->resolverType.callProc) { - Tcl_NewInstanceMethod(fPtr->interp, slotObject, resolveName, 0, - &slotInfoPtr->resolverType, NULL); - } } Tcl_DecrRefCount(getName); Tcl_DecrRefCount(setName); - Tcl_DecrRefCount(resolveName); return TCL_OK; } /* * ---------------------------------------------------------------------- * * ClassFilterGet, ClassFilterSet -- - * * Implementation of the "filter" slot accessors of the "oo::define" * command. * * ---------------------------------------------------------------------- */ @@ -2383,11 +1919,10 @@ /* * ---------------------------------------------------------------------- * * ClassMixinGet, ClassMixinSet -- - * * Implementation of the "mixin" slot accessors of the "oo::define" * command. * * ---------------------------------------------------------------------- */ @@ -2489,11 +2024,10 @@ /* * ---------------------------------------------------------------------- * * ClassSuperGet, ClassSuperSet -- - * * Implementation of the "superclass" slot accessors of the "oo::define" * command. * * ---------------------------------------------------------------------- */ @@ -2573,21 +2107,21 @@ /* * Allocate some working space. */ - superclasses = (Class **) Tcl_Alloc(sizeof(Class *) * superc); + superclasses = (Class **) ckalloc(sizeof(Class *) * superc); /* * Parse the arguments to get the class to use as superclasses. * * Note that zero classes is special, as it is equivalent to just the * class of objects. [Bug 9d61624b3d] */ if (superc == 0) { - superclasses = Tcl_Realloc(superclasses, sizeof(Class *)); + superclasses = ckrealloc(superclasses, sizeof(Class *)); if (TclOOIsReachable(oPtr->fPtr->classCls, oPtr->classPtr)) { superclasses[0] = oPtr->fPtr->classCls; } else { superclasses[0] = oPtr->fPtr->objectCls; } @@ -2596,11 +2130,10 @@ } else { for (i = 0; i < superc; i++) { superclasses[i] = GetClassInOuterContext(interp, superv[i], "only a class can be a superclass"); if (superclasses[i] == NULL) { - i--; goto failedAfterAlloc; } for (j = 0; j < i; j++) { if (superclasses[j] == superclasses[i]) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -2613,14 +2146,14 @@ if (TclOOIsReachable(oPtr->classPtr, superclasses[i])) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "attempt to form circular dependency graph", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL); failedAfterAlloc: - for (; i > 0; i--) { + for (; i-- > 0 ;) { TclOODecrRefCount(superclasses[i]->thisPtr); } - Tcl_Free(superclasses); + ckfree(superclasses); return TCL_ERROR; } /* * Corresponding TclOODecrRefCount() is near the end of this @@ -2641,11 +2174,11 @@ if (oPtr->classPtr->superclasses.num != 0) { FOREACH(superPtr, oPtr->classPtr->superclasses) { TclOORemoveFromSubclasses(oPtr->classPtr, superPtr); TclOODecrRefCount(superPtr->thisPtr); } - Tcl_Free(oPtr->classPtr->superclasses.list); + ckfree((char *) oPtr->classPtr->superclasses.list); } oPtr->classPtr->superclasses.list = superclasses; oPtr->classPtr->superclasses.num = superc; FOREACH(superPtr, oPtr->classPtr->superclasses) { TclOOAddToSubclasses(oPtr->classPtr, superPtr); @@ -2657,11 +2190,10 @@ /* * ---------------------------------------------------------------------- * * ClassVarsGet, ClassVarsSet -- - * * Implementation of the "variable" slot accessors of the "oo::define" * command. * * ---------------------------------------------------------------------- */ @@ -2673,11 +2205,11 @@ Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Obj *resultObj; + Tcl_Obj *resultObj, *variableObj; int i; if (Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, NULL); @@ -2691,22 +2223,12 @@ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } resultObj = Tcl_NewObj(); - if (IsPrivateDefine(interp)) { - PrivateVariableMapping *privatePtr; - - FOREACH_STRUCT(privatePtr, oPtr->classPtr->privateVariables) { - Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj); - } - } else { - Tcl_Obj *variableObj; - - FOREACH(variableObj, oPtr->classPtr->variables) { - Tcl_ListObjAppendElement(NULL, resultObj, variableObj); - } + FOREACH(variableObj, oPtr->classPtr->variables) { + Tcl_ListObjAppendElement(NULL, resultObj, variableObj); } Tcl_SetObjResult(interp, resultObj); return TCL_OK; } @@ -2718,11 +2240,11 @@ int objc, Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); int varc; - Tcl_Obj **varv; + Tcl_Obj **varv, *variableObj; int i; if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "filterList"); @@ -2741,11 +2263,11 @@ &varv) != TCL_OK) { return TCL_ERROR; } for (i = 0; i < varc; i++) { - const char *varName = TclGetString(varv[i]); + const char *varName = Tcl_GetString(varv[i]); if (strstr(varName, "::") != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid declared variable name \"%s\": must not %s", varName, "contain namespace separators")); @@ -2759,24 +2281,61 @@ Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL); return TCL_ERROR; } } - if (IsPrivateDefine(interp)) { - InstallPrivateVariableMapping(&oPtr->classPtr->privateVariables, - varc, varv, oPtr->classPtr->thisPtr->creationEpoch); - } else { - InstallStandardVariableMapping(&oPtr->classPtr->variables, varc, varv); + for (i = 0; i < varc; i++) { + Tcl_IncrRefCount(varv[i]); + } + FOREACH(variableObj, oPtr->classPtr->variables) { + Tcl_DecrRefCount(variableObj); + } + if (i != varc) { + if (varc == 0) { + ckfree((char *) oPtr->classPtr->variables.list); + } else if (i) { + oPtr->classPtr->variables.list = (Tcl_Obj **) + ckrealloc((char *) oPtr->classPtr->variables.list, + sizeof(Tcl_Obj *) * varc); + } else { + oPtr->classPtr->variables.list = (Tcl_Obj **) + ckalloc(sizeof(Tcl_Obj *) * varc); + } + } + + oPtr->classPtr->variables.num = 0; + if (varc > 0) { + int created, n; + Tcl_HashTable uniqueTable; + + Tcl_InitObjHashTable(&uniqueTable); + for (i = n = 0; i < varc; i++) { + Tcl_CreateHashEntry(&uniqueTable, varv[i], &created); + if (created) { + oPtr->classPtr->variables.list[n++] = varv[i]; + } else { + Tcl_DecrRefCount(varv[i]); + } + } + oPtr->classPtr->variables.num = n; + + /* + * Shouldn't be necessary, but maintain num/list invariant. + */ + + oPtr->classPtr->variables.list = (Tcl_Obj **) + ckrealloc((char *) oPtr->classPtr->variables.list, + sizeof(Tcl_Obj *) * n); + Tcl_DeleteHashTable(&uniqueTable); } return TCL_OK; } /* * ---------------------------------------------------------------------- * * ObjectFilterGet, ObjectFilterSet -- - * * Implementation of the "filter" slot accessors of the "oo::objdefine" * command. * * ---------------------------------------------------------------------- */ @@ -2840,11 +2399,10 @@ /* * ---------------------------------------------------------------------- * * ObjectMixinGet, ObjectMixinSet -- - * * Implementation of the "mixin" slot accessors of the "oo::objdefine" * command. * * ---------------------------------------------------------------------- */ @@ -2926,11 +2484,10 @@ /* * ---------------------------------------------------------------------- * * ObjectVarsGet, ObjectVarsSet -- - * * Implementation of the "variable" slot accessors of the "oo::objdefine" * command. * * ---------------------------------------------------------------------- */ @@ -2942,11 +2499,11 @@ Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Obj *resultObj; + Tcl_Obj *resultObj, *variableObj; int i; if (Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, NULL); @@ -2954,22 +2511,12 @@ } else if (oPtr == NULL) { return TCL_ERROR; } resultObj = Tcl_NewObj(); - if (IsPrivateDefine(interp)) { - PrivateVariableMapping *privatePtr; - - FOREACH_STRUCT(privatePtr, oPtr->privateVariables) { - Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj); - } - } else { - Tcl_Obj *variableObj; - - FOREACH(variableObj, oPtr->variables) { - Tcl_ListObjAppendElement(NULL, resultObj, variableObj); - } + FOREACH(variableObj, oPtr->variables) { + Tcl_ListObjAppendElement(NULL, resultObj, variableObj); } Tcl_SetObjResult(interp, resultObj); return TCL_OK; } @@ -2981,11 +2528,11 @@ int objc, Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); int varc, i; - Tcl_Obj **varv; + Tcl_Obj **varv, *variableObj; if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "variableList"); return TCL_ERROR; @@ -2997,11 +2544,11 @@ &varv) != TCL_OK) { return TCL_ERROR; } for (i = 0; i < varc; i++) { - const char *varName = TclGetString(varv[i]); + const char *varName = Tcl_GetString(varv[i]); if (strstr(varName, "::") != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid declared variable name \"%s\": must not %s", varName, "contain namespace separators")); @@ -3014,70 +2561,54 @@ varName, "refer to an array element")); Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL); return TCL_ERROR; } } - - if (IsPrivateDefine(interp)) { - InstallPrivateVariableMapping(&oPtr->privateVariables, varc, varv, - oPtr->creationEpoch); - } else { - InstallStandardVariableMapping(&oPtr->variables, varc, varv); - } - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * ResolveClass -- - * - * Implementation of the "Resolve" support method for some slots (those - * that are slots around a list of classes). This resolves possible class - * names to their fully-qualified names if possible. - * - * ---------------------------------------------------------------------- - */ - -static int -ResolveClass( - ClientData clientData, - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - int idx = Tcl_ObjectContextSkippedArgs(context); - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Class *clsPtr; - - /* - * Check if were called wrongly. The definition context isn't used... - * except that GetClassInOuterContext() assumes that it is there. - */ - - if (oPtr == NULL) { - return TCL_ERROR; - } else if (objc != idx + 1) { - Tcl_WrongNumArgs(interp, idx, objv, "slotElement"); - return TCL_ERROR; - } - - /* - * Resolve the class if possible. If not, remove any resolution error and - * return what we've got anyway as the failure might not be fatal overall. - */ - - clsPtr = GetClassInOuterContext(interp, objv[idx], - "USER SHOULD NOT SEE THIS MESSAGE"); - if (clsPtr == NULL) { - Tcl_ResetResult(interp); - Tcl_SetObjResult(interp, objv[idx]); - } else { - Tcl_SetObjResult(interp, TclOOObjectName(interp, clsPtr->thisPtr)); - } - + for (i = 0; i < varc; i++) { + Tcl_IncrRefCount(varv[i]); + } + + FOREACH(variableObj, oPtr->variables) { + Tcl_DecrRefCount(variableObj); + } + if (i != varc) { + if (varc == 0) { + ckfree((char *) oPtr->variables.list); + } else if (i) { + oPtr->variables.list = (Tcl_Obj **) + ckrealloc((char *) oPtr->variables.list, + sizeof(Tcl_Obj *) * varc); + } else { + oPtr->variables.list = (Tcl_Obj **) + ckalloc(sizeof(Tcl_Obj *) * varc); + } + } + oPtr->variables.num = 0; + if (varc > 0) { + int created, n; + Tcl_HashTable uniqueTable; + + Tcl_InitObjHashTable(&uniqueTable); + for (i = n = 0; i < varc; i++) { + Tcl_CreateHashEntry(&uniqueTable, varv[i], &created); + if (created) { + oPtr->variables.list[n++] = varv[i]; + } else { + Tcl_DecrRefCount(varv[i]); + } + } + oPtr->variables.num = n; + + /* + * Shouldn't be necessary, but maintain num/list invariant. + */ + + oPtr->variables.list = (Tcl_Obj **) + ckrealloc((char *) oPtr->variables.list, + sizeof(Tcl_Obj *) * n); + Tcl_DeleteHashTable(&uniqueTable); + } return TCL_OK; } /* * Local Variables: Index: generic/tclOOInfo.c ================================================================== --- generic/tclOOInfo.c +++ generic/tclOOInfo.c @@ -20,11 +20,10 @@ static Tcl_ObjCmdProc InfoObjectCallCmd; static Tcl_ObjCmdProc InfoObjectClassCmd; static Tcl_ObjCmdProc InfoObjectDefnCmd; static Tcl_ObjCmdProc InfoObjectFiltersCmd; static Tcl_ObjCmdProc InfoObjectForwardCmd; -static Tcl_ObjCmdProc InfoObjectIdCmd; static Tcl_ObjCmdProc InfoObjectIsACmd; static Tcl_ObjCmdProc InfoObjectMethodsCmd; static Tcl_ObjCmdProc InfoObjectMethodTypeCmd; static Tcl_ObjCmdProc InfoObjectMixinsCmd; static Tcl_ObjCmdProc InfoObjectNsCmd; @@ -31,11 +30,10 @@ static Tcl_ObjCmdProc InfoObjectVarsCmd; static Tcl_ObjCmdProc InfoObjectVariablesCmd; static Tcl_ObjCmdProc InfoClassCallCmd; static Tcl_ObjCmdProc InfoClassConstrCmd; static Tcl_ObjCmdProc InfoClassDefnCmd; -static Tcl_ObjCmdProc InfoClassDefnNsCmd; static Tcl_ObjCmdProc InfoClassDestrCmd; static Tcl_ObjCmdProc InfoClassFiltersCmd; static Tcl_ObjCmdProc InfoClassForwardCmd; static Tcl_ObjCmdProc InfoClassInstancesCmd; static Tcl_ObjCmdProc InfoClassMethodsCmd; @@ -50,20 +48,19 @@ */ static const EnsembleImplMap infoObjectCmds[] = { {"call", InfoObjectCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"class", InfoObjectClassCmd, TclCompileInfoObjectClassCmd, NULL, NULL, 0}, - {"creationid", InfoObjectIdCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"definition", InfoObjectDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"filters", InfoObjectFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"forward", InfoObjectForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"isa", InfoObjectIsACmd, TclCompileInfoObjectIsACmd, NULL, NULL, 0}, {"methods", InfoObjectMethodsCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, {"methodtype", InfoObjectMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"mixins", InfoObjectMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"namespace", InfoObjectNsCmd, TclCompileInfoObjectNamespaceCmd, NULL, NULL, 0}, - {"variables", InfoObjectVariablesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, + {"variables", InfoObjectVariablesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"vars", InfoObjectVarsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} }; /* @@ -72,21 +69,20 @@ static const EnsembleImplMap infoClassCmds[] = { {"call", InfoClassCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"constructor", InfoClassConstrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"definition", InfoClassDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"definitionnamespace", InfoClassDefnNsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {"destructor", InfoClassDestrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"filters", InfoClassFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"forward", InfoClassForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"instances", InfoClassInstancesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {"methods", InfoClassMethodsCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, {"methodtype", InfoClassMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"mixins", InfoClassMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"subclasses", InfoClassSubsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {"superclasses", InfoClassSupersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"variables", InfoClassVariablesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, + {"variables", InfoClassVariablesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} }; /* * ---------------------------------------------------------------------- @@ -112,11 +108,11 @@ TclMakeEnsemble(interp, "::oo::InfoObject", infoObjectCmds); TclMakeEnsemble(interp, "::oo::InfoClass", infoClassCmds); /* - * Install into the master [info] ensemble. + * Install into the [info] ensemble. */ infoCmd = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY); if (infoCmd) { Tcl_GetEnsembleMappingDict(NULL, infoCmd, &mapDict); @@ -521,26 +517,19 @@ Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Object *oPtr; - int flag = PUBLIC_METHOD, recurse = 0, scope = -1; + int flag = PUBLIC_METHOD, recurse = 0; FOREACH_HASH_DECLS; Tcl_Obj *namePtr, *resultObj; Method *mPtr; static const char *const options[] = { - "-all", "-localprivate", "-private", "-scope", NULL + "-all", "-localprivate", "-private", NULL }; enum Options { - OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE - }; - static const char *const scopes[] = { - "private", "public", "unexported" - }; - enum Scopes { - SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED, - SCOPE_LOCALPRIVATE + OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "objName ?-option value ...?"); return TCL_ERROR; @@ -565,60 +554,29 @@ flag = PRIVATE_METHOD; break; case OPT_PRIVATE: flag = 0; break; - case OPT_SCOPE: - if (++i >= objc) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "missing option for -scope")); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", - NULL); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[i], scopes, "scope", 0, - &scope) != TCL_OK) { - return TCL_ERROR; - } - break; - } - } - } - if (scope != -1) { - recurse = 0; - switch (scope) { - case SCOPE_PRIVATE: - flag = TRUE_PRIVATE_METHOD; - break; - case SCOPE_PUBLIC: - flag = PUBLIC_METHOD; - break; - case SCOPE_LOCALPRIVATE: - flag = PRIVATE_METHOD; - break; - case SCOPE_UNEXPORTED: - flag = 0; - break; + } } } resultObj = Tcl_NewObj(); if (recurse) { const char **names; - int i, numNames = TclOOGetSortedMethodList(oPtr, NULL, NULL, flag, - &names); + int i, numNames = TclOOGetSortedMethodList(oPtr, flag, &names); for (i=0 ; i 0) { - Tcl_Free((void *)names); + ckfree(names); } } else if (oPtr->methodsPtr) { FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) { - if (mPtr->typePtr && (mPtr->flags & SCOPE_FLAGS) == flag) { + if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) { Tcl_ListObjAppendElement(NULL, resultObj, namePtr); } } } Tcl_SetObjResult(interp, resultObj); @@ -726,42 +684,10 @@ } /* * ---------------------------------------------------------------------- * - * InfoObjectIdCmd -- - * - * Implements [info object creationid $objName] - * - * ---------------------------------------------------------------------- - */ - -static int -InfoObjectIdCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Object *oPtr; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "objName"); - return TCL_ERROR; - } - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); - if (oPtr == NULL) { - return TCL_ERROR; - } - - Tcl_SetObjResult(interp, Tcl_NewIntObj(oPtr->creationEpoch)); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * * InfoObjectNsCmd -- * * Implements [info object namespace $objName] * * ---------------------------------------------------------------------- @@ -793,11 +719,11 @@ /* * ---------------------------------------------------------------------- * * InfoObjectVariablesCmd -- * - * Implements [info object variables $objName ?-private?] + * Implements [info object variables $objName] * * ---------------------------------------------------------------------- */ static int @@ -806,41 +732,25 @@ Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Object *oPtr; - Tcl_Obj *resultObj; - int i, private = 0; - - if (objc != 2 && objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "objName ?-private?"); - return TCL_ERROR; - } - if (objc == 3) { - if (strcmp("-private", TclGetString(objv[2])) != 0) { - return TCL_ERROR; - } - private = 1; + Tcl_Obj *variableObj, *resultObj; + int i; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "objName"); + return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); if (oPtr == NULL) { return TCL_ERROR; } resultObj = Tcl_NewObj(); - if (private) { - PrivateVariableMapping *privatePtr; - - FOREACH_STRUCT(privatePtr, oPtr->privateVariables) { - Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj); - } - } else { - Tcl_Obj *variableObj; - - FOREACH(variableObj, oPtr->variables) { - Tcl_ListObjAppendElement(NULL, resultObj, variableObj); - } + FOREACH(variableObj, oPtr->variables) { + Tcl_ListObjAppendElement(NULL, resultObj, variableObj); } Tcl_SetObjResult(interp, resultObj); return TCL_OK; } @@ -1035,60 +945,10 @@ } /* * ---------------------------------------------------------------------- * - * InfoClassDefnNsCmd -- - * - * Implements [info class definitionnamespace $clsName ?$kind?] - * - * ---------------------------------------------------------------------- - */ - -static int -InfoClassDefnNsCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - static const char *kindList[] = { - "-class", - "-instance", - NULL - }; - int kind = 0; - Tcl_Obj *nsNamePtr; - Class *clsPtr; - - if (objc != 2 && objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "className ?kind?"); - return TCL_ERROR; - } - clsPtr = GetClassFromObj(interp, objv[1]); - if (clsPtr == NULL) { - return TCL_ERROR; - } - if (objc == 3 && Tcl_GetIndexFromObj(interp, objv[2], kindList, "kind", 0, - &kind) != TCL_OK) { - return TCL_ERROR; - } - - if (kind) { - nsNamePtr = clsPtr->objDefinitionNs; - } else { - nsNamePtr = clsPtr->clsDefinitionNs; - } - if (nsNamePtr) { - Tcl_SetObjResult(interp, nsNamePtr); - } - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * * InfoClassDestrCmd -- * * Implements [info class destructor $clsName] * * ---------------------------------------------------------------------- @@ -1268,11 +1128,11 @@ /* * ---------------------------------------------------------------------- * * InfoClassMethodsCmd -- * - * Implements [info class methods $clsName ?options...?] + * Implements [info class methods $clsName ?-private?] * * ---------------------------------------------------------------------- */ static int @@ -1280,25 +1140,19 @@ ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - int flag = PUBLIC_METHOD, recurse = 0, scope = -1; + int flag = PUBLIC_METHOD, recurse = 0; Tcl_Obj *namePtr, *resultObj; Method *mPtr; Class *clsPtr; static const char *const options[] = { - "-all", "-localprivate", "-private", "-scope", NULL + "-all", "-localprivate", "-private", NULL }; enum Options { - OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE - }; - static const char *const scopes[] = { - "private", "public", "unexported" - }; - enum Scopes { - SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED + OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "className ?-option value ...?"); return TCL_ERROR; @@ -1323,38 +1177,11 @@ flag = PRIVATE_METHOD; break; case OPT_PRIVATE: flag = 0; break; - case OPT_SCOPE: - if (++i >= objc) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "missing option for -scope")); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", - NULL); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[i], scopes, "scope", 0, - &scope) != TCL_OK) { - return TCL_ERROR; - } - break; - } - } - } - if (scope != -1) { - recurse = 0; - switch (scope) { - case SCOPE_PRIVATE: - flag = TRUE_PRIVATE_METHOD; - break; - case SCOPE_PUBLIC: - flag = PUBLIC_METHOD; - break; - case SCOPE_UNEXPORTED: - flag = 0; - break; + } } } resultObj = Tcl_NewObj(); if (recurse) { @@ -1364,17 +1191,17 @@ for (i=0 ; i 0) { - Tcl_Free((void *)names); + ckfree(names); } } else { FOREACH_HASH_DECLS; FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) { - if (mPtr->typePtr && (mPtr->flags & SCOPE_FLAGS) == flag) { + if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) { Tcl_ListObjAppendElement(NULL, resultObj, namePtr); } } } Tcl_SetObjResult(interp, resultObj); @@ -1572,11 +1399,11 @@ /* * ---------------------------------------------------------------------- * * InfoClassVariablesCmd -- * - * Implements [info class variables $clsName ?-private?] + * Implements [info class variables $clsName] * * ---------------------------------------------------------------------- */ static int @@ -1585,41 +1412,25 @@ Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Class *clsPtr; - Tcl_Obj *resultObj; - int i, private = 0; - - if (objc != 2 && objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "className ?-private?"); - return TCL_ERROR; - } - if (objc == 3) { - if (strcmp("-private", TclGetString(objv[2])) != 0) { - return TCL_ERROR; - } - private = 1; + Tcl_Obj *variableObj, *resultObj; + int i; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "className"); + return TCL_ERROR; } clsPtr = GetClassFromObj(interp, objv[1]); if (clsPtr == NULL) { return TCL_ERROR; } resultObj = Tcl_NewObj(); - if (private) { - PrivateVariableMapping *privatePtr; - - FOREACH_STRUCT(privatePtr, clsPtr->privateVariables) { - Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj); - } - } else { - Tcl_Obj *variableObj; - - FOREACH(variableObj, clsPtr->variables) { - Tcl_ListObjAppendElement(NULL, resultObj, variableObj); - } + FOREACH(variableObj, clsPtr->variables) { + Tcl_ListObjAppendElement(NULL, resultObj, variableObj); } Tcl_SetObjResult(interp, resultObj); return TCL_OK; } @@ -1654,12 +1465,11 @@ /* * Get the call context and render its call chain. */ - contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL, NULL, - NULL); + contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL); if (contextPtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot construct any call chain", -1)); return TCL_ERROR; } Index: generic/tclOOInt.h ================================================================== --- generic/tclOOInt.h +++ generic/tclOOInt.h @@ -44,12 +44,12 @@ typedef struct Method { const Tcl_MethodType *typePtr; /* The type of method. If NULL, this is a * special flag record which is just used for * the setting of the flags field. */ - size_t refCount; - void *clientData; /* Type-specific data. */ + int refCount; + ClientData clientData; /* Type-specific data. */ Tcl_Obj *namePtr; /* Name of the method. */ struct Object *declaringObjectPtr; /* The object that declares this method, or * NULL if it was declared by a class. */ struct Class *declaringClassPtr; @@ -63,16 +63,16 @@ /* * Pre- and post-call callbacks, to allow procedure-like methods to be fine * tuned in their behaviour. */ -typedef int (TclOO_PreCallProc)(void *clientData, Tcl_Interp *interp, +typedef int (TclOO_PreCallProc)(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, Tcl_CallFrame *framePtr, int *isFinished); -typedef int (TclOO_PostCallProc)(void *clientData, Tcl_Interp *interp, +typedef int (TclOO_PostCallProc)(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, Tcl_Namespace *namespacePtr, int result); -typedef void (TclOO_PmCDDeleteProc)(void *clientData); -typedef void *(TclOO_PmCDCloneProc)(void *clientData); +typedef void (TclOO_PmCDDeleteProc)(ClientData clientData); +typedef ClientData (TclOO_PmCDCloneProc)(ClientData clientData); /* * Procedure-like methods have the following extra information. */ @@ -81,12 +81,12 @@ * be 0. */ Proc *procPtr; /* Core of the implementation of the method; * includes the argument definition and the * body bytecodes. */ int flags; /* Flags to control features. */ - size_t refCount; - void *clientData; + int refCount; + ClientData clientData; TclOO_PmCDDeleteProc *deleteClientdataProc; TclOO_PmCDCloneProc *cloneClientdataProc; ProcErrorProc *errProc; /* Replacement error handler. */ TclOO_PreCallProc *preCallProc; /* Callback to allow for additional setup @@ -122,22 +122,10 @@ Tcl_Obj *prefixObj; /* The list of values to use to replace the * object and method name with. Will be a * non-empty list. */ } ForwardMethod; -/* - * Structure used in private variable mappings. Describes the mapping of a - * single variable from the user's local name to the system's storage name. - * [TIP #500] - */ - -typedef struct { - Tcl_Obj *variableObj; /* Name used within methods. This is the part - * that is properly under user control. */ - Tcl_Obj *fullNameObj; /* Name used at the instance namespace level. */ -} PrivateVariableMapping; - /* * Helper definitions that declare a "list" array. The two varieties are * either optimized for simplicity (in the case that the whole array is * typically assigned at once) or efficiency (in the case that the array is * expected to be expanded over time). These lists are designed to be iterated @@ -151,17 +139,10 @@ #define LIST_STATIC(listType_t) \ struct { int num; listType_t *list; } #define LIST_DYNAMIC(listType_t) \ struct { int num, size; listType_t *list; } -/* - * These types are needed in function arguments. - */ - -typedef LIST_STATIC(Tcl_Obj *) VariableNameList; -typedef LIST_STATIC(PrivateVariableMapping) PrivateVariableList; - /* * Now, the definition of what an object actually is. */ typedef struct Object { @@ -182,47 +163,39 @@ LIST_STATIC(Tcl_Obj *) filters; /* List of filter names. */ struct Class *classPtr; /* This is non-NULL for all classes, and NULL * for everything else. It points to the class * structure. */ - size_t refCount; /* Number of strong references to this object. + int refCount; /* Number of strong references to this object. * Note that there may be many more weak * references; this mechanism exists to * avoid Tcl_Preserve. */ int flags; - size_t creationEpoch; /* Unique value to make comparisons of objects + int creationEpoch; /* Unique value to make comparisons of objects * easier. */ - size_t epoch; /* Per-object epoch, incremented when the way + int epoch; /* Per-object epoch, incremented when the way * an object should resolve call chains is * changed. */ Tcl_HashTable *metadataPtr; /* Mapping from pointers to metadata type to - * the void *values that are the values + * the ClientData values that are the values * of each piece of attached metadata. This * field starts out as NULL and is only * allocated if metadata is attached. */ Tcl_Obj *cachedNameObj; /* Cache of the name of the object. */ Tcl_HashTable *chainCache; /* Place to keep unused contexts. This table * is indexed by method name as Tcl_Obj. */ Tcl_ObjectMapMethodNameProc *mapMethodNameProc; /* Function to allow remapping of method * names. For itcl-ng. */ - VariableNameList variables; - PrivateVariableList privateVariables; - /* Configurations for the variable resolver - * used inside methods. */ - Tcl_Command myclassCommand; /* Reference to this object's class dispatcher - * command. */ + LIST_STATIC(Tcl_Obj *) variables; } Object; -#define OBJECT_DELETED 1 /* Flag to say that an object has been - * destroyed. */ -#define DESTRUCTOR_CALLED 2 /* Flag to say that the destructor has been - * called. */ -#define CLASS_GONE 4 /* Obsolete. Indicates that the class of this - * object has been deleted, and so the object - * should not attempt to remove itself from its - * class. */ +#define OBJECT_DESTRUCTING 1 /* Indicates that an object is being or has + * been destroyed */ +#define DESTRUCTOR_CALLED 2 /* Indicates that evaluation of destructor script for the + object has began */ +#define OO_UNUSED_4 4 /* No longer used. */ #define ROOT_OBJECT 0x1000 /* Flag to say that this object is the root of * the class hierarchy and should be treated * specially during teardown. */ #define FILTER_HANDLING 0x2000 /* Flag set when the object is processing a * filter; when set, filters are *not* @@ -236,18 +209,11 @@ * class of classes, and should be treated * specially during teardown (and in a few * other spots). */ #define FORCE_UNKNOWN 0x10000 /* States that we are *really* looking up the * unknown method handler at that point. */ -#define HAS_PRIVATE_METHODS 0x20000 - /* Object/class has (or had) private methods, - * and so shouldn't be cached so - * aggressively. */ -#define DONT_DELETE 0x40000 /* Inhibit deletion of this object. Used - * during fundamental object type mutation to - * make sure that the object actually survives - * to the end of the operation. */ +#define DONT_DELETE 0x20000 /* Inhibit deletion of this object. */ /* * And the definition of a class. Note that every class also has an associated * object, through which it is manipulated. */ @@ -284,11 +250,11 @@ Method *constructorPtr; /* Method record of the class constructor (if * any). */ Method *destructorPtr; /* Method record of the class destructor (if * any). */ Tcl_HashTable *metadataPtr; /* Mapping from pointers to metadata type to - * the void *values that are the values + * the ClientData values that are the values * of each piece of attached metadata. This * field starts out as NULL and is only * allocated if metadata is attached. */ struct CallChain *constructorChainPtr; struct CallChain *destructorChainPtr; @@ -298,32 +264,11 @@ * used. For destructors and ordinary methods, * the class chain is only used when the * object doesn't override with its own mixins * (and filters and method implementations for * when getting method chains). */ - VariableNameList variables; - PrivateVariableList privateVariables; - /* Configurations for the variable resolver - * used inside methods. */ - Tcl_Obj *clsDefinitionNs; /* Name of the namespace to use for - * definitions commands of instances of this - * class in when those instances are defined - * as classes. If NULL, use the value from the - * class hierarchy. It's an error at - * [oo::define] call time if this namespace is - * defined but doesn't exist; we also check at - * setting time but don't check between - * times. */ - Tcl_Obj *objDefinitionNs; /* Name of the namespace to use for - * definitions commands of instances of this - * class in when those instances are defined - * as instances. If NULL, use the value from - * the class hierarchy. It's an error at - * [oo::objdefine]/[self] call time if this - * namespace is defined but doesn't exist; we - * also check at setting time but don't check - * between times. */ + LIST_STATIC(Tcl_Obj *) variables; } Class; /* * The foundation of the object system within an interpreter contains * references to the key classes and namespaces, together with a few other @@ -330,11 +275,11 @@ * useful bits and pieces. Probably ought to eventually go in the Interp * structure itself. */ typedef struct ThreadLocalData { - size_t nsCount; /* Master epoch counter is used for keeping + int nsCount; /* Epoch counter is used for keeping * the values used in Tcl_Obj internal * representations sane. Must be thread-local * because Tcl_Objs can cross interpreter * boundaries within a thread (objects don't * generally cross threads). */ @@ -342,11 +287,11 @@ typedef struct Foundation { Tcl_Interp *interp; Class *objectCls; /* The root of the object system. */ Class *classCls; /* The class of all classes. */ - Tcl_Namespace *ooNs; /* Master ::oo namespace. */ + Tcl_Namespace *ooNs; /* ::oo namespace. */ Tcl_Namespace *defineNs; /* Namespace containing special commands for * manipulating objects and classes. The * "oo::define" command acts as a special kind * of ensemble for this namespace. */ Tcl_Namespace *objdefNs; /* Namespace containing special commands for @@ -354,11 +299,11 @@ * "oo::objdefine" command acts as a special * kind of ensemble for this namespace. */ Tcl_Namespace *helpersNs; /* Namespace containing the commands that are * only valid when executing inside a * procedural method. */ - size_t epoch; /* Used to invalidate method chains when the + int epoch; /* Used to invalidate method chains when the * class structure changes. */ ThreadLocalData *tsdPtr; /* Counter so we can allocate a unique * namespace to each object. */ Tcl_Obj *unknownMethodNameObj; /* Shared object containing the name of the @@ -388,19 +333,19 @@ Class *filterDeclarer; /* What class decided to add the filter; if * NULL, it was added by the object. */ }; typedef struct CallChain { - size_t objectCreationEpoch; /* The object's creation epoch. Note that the + int objectCreationEpoch; /* The object's creation epoch. Note that the * object reference is not stored in the call * chain; it is in the call context. */ - size_t objectEpoch; /* Local (object structure) epoch counter + int objectEpoch; /* Local (object structure) epoch counter * snapshot. */ - size_t epoch; /* Global (class structure) epoch counter + int epoch; /* Global (class structure) epoch counter * snapshot. */ int flags; /* Assorted flags, see below. */ - size_t refCount; /* Reference count. */ + int refCount; /* Reference count. */ int numChain; /* Size of the call chain. */ struct MInvoke *chain; /* Array of call chain entries. May point to * staticChain if the number of entries is * small. */ struct MInvoke staticChain[CALL_CHAIN_STATIC_SIZE]; @@ -421,19 +366,14 @@ * Bits for the 'flags' field of the call chain. */ #define PUBLIC_METHOD 0x01 /* This is a public (exported) method. */ #define PRIVATE_METHOD 0x02 /* This is a private (class's direct instances - * only) method. Supports itcl. */ + * only) method. */ #define OO_UNKNOWN_METHOD 0x04 /* This is an unknown method. */ #define CONSTRUCTOR 0x08 /* This is a constructor. */ #define DESTRUCTOR 0x10 /* This is a destructor. */ -#define TRUE_PRIVATE_METHOD 0x20 - /* This is a private method only accessible - * from other methods defined on this class - * or instance. [TIP #500] */ -#define SCOPE_FLAGS (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD) /* * Structure containing definition information about basic class methods. */ @@ -448,124 +388,91 @@ * Commands relating to OO support. *---------------------------------------------------------------- */ MODULE_SCOPE int TclOOInit(Tcl_Interp *interp); -MODULE_SCOPE int TclOODefineObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOOObjDefObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineConstructorObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineDeleteMethodObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineDestructorObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineExportObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineForwardObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineMethodObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineRenameMethodObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineUnexportObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineClassObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineSelfObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineObjSelfObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOOUnknownDefinition(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOOCopyObjectCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOONextObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOONextToObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineUnexportObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineClassObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineSelfObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineObjSelfObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefinePrivateObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOOUnknownDefinition(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOOCopyObjectCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineDefnNsObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOONextObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOONextToObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOOSelfObjCmd(void *clientData, +MODULE_SCOPE int TclOODefineObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); +MODULE_SCOPE int TclOOObjDefObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); +MODULE_SCOPE int TclOODefineConstructorObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); +MODULE_SCOPE int TclOODefineDeleteMethodObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); +MODULE_SCOPE int TclOODefineDestructorObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); +MODULE_SCOPE int TclOODefineExportObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); +MODULE_SCOPE int TclOODefineForwardObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); +MODULE_SCOPE int TclOODefineMethodObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); +MODULE_SCOPE int TclOODefineRenameMethodObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); +MODULE_SCOPE int TclOODefineUnexportObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); +MODULE_SCOPE int TclOODefineClassObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); +MODULE_SCOPE int TclOODefineSelfObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); +MODULE_SCOPE int TclOOUnknownDefinition(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); +MODULE_SCOPE int TclOOCopyObjectCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); +MODULE_SCOPE int TclOONextObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); +MODULE_SCOPE int TclOONextToObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); +MODULE_SCOPE int TclOOSelfObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); /* * Method implementations (in tclOOBasic.c). */ -MODULE_SCOPE int TclOO_Class_Constructor(void *clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Class_Create(void *clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Class_CreateNs(void *clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Class_New(void *clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Object_Destroy(void *clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Object_Eval(void *clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Object_LinkVar(void *clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Object_Unknown(void *clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Object_VarName(void *clientData, +MODULE_SCOPE int TclOO_Class_Constructor(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +MODULE_SCOPE int TclOO_Class_Create(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +MODULE_SCOPE int TclOO_Class_CreateNs(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +MODULE_SCOPE int TclOO_Class_New(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +MODULE_SCOPE int TclOO_Object_Destroy(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +MODULE_SCOPE int TclOO_Object_Eval(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +MODULE_SCOPE int TclOO_Object_LinkVar(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +MODULE_SCOPE int TclOO_Object_Unknown(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +MODULE_SCOPE int TclOO_Object_VarName(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); /* * Private definitions, some of which perhaps ought to be exposed properly or @@ -585,37 +492,34 @@ MODULE_SCOPE Object * TclNewObjectInstanceCommon(Tcl_Interp *interp, Class *classPtr, const char *nameStr, const char *nsNameStr); MODULE_SCOPE int TclOODecrRefCount(Object *oPtr); +MODULE_SCOPE int TclOOObjectDestroyed(Object *oPtr); MODULE_SCOPE int TclOODefineSlots(Foundation *fPtr); MODULE_SCOPE void TclOODeleteChain(CallChain *callPtr); MODULE_SCOPE void TclOODeleteChainCache(Tcl_HashTable *tablePtr); MODULE_SCOPE void TclOODeleteContext(CallContext *contextPtr); MODULE_SCOPE void TclOODeleteDescendants(Tcl_Interp *interp, Object *oPtr); MODULE_SCOPE void TclOODelMethodRef(Method *method); MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr, Tcl_Obj *methodNameObj, int flags, - Object *contextObjPtr, Class *contextClsPtr, Tcl_Obj *cacheInThisObj); -MODULE_SCOPE Tcl_Namespace *TclOOGetDefineContextNamespace( - Tcl_Interp *interp, Object *oPtr, int forClass); MODULE_SCOPE CallChain *TclOOGetStereotypeCallChain(Class *clsPtr, Tcl_Obj *methodNameObj, int flags); MODULE_SCOPE Foundation *TclOOGetFoundation(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclOOGetFwdFromMethod(Method *mPtr); MODULE_SCOPE Proc * TclOOGetProcFromMethod(Method *mPtr); MODULE_SCOPE Tcl_Obj * TclOOGetMethodBody(Method *mPtr); MODULE_SCOPE int TclOOGetSortedClassMethodList(Class *clsPtr, int flags, const char ***stringsPtr); -MODULE_SCOPE int TclOOGetSortedMethodList(Object *oPtr, - Object *contextObj, Class *contextCls, int flags, +MODULE_SCOPE int TclOOGetSortedMethodList(Object *oPtr, int flags, const char ***stringsPtr); MODULE_SCOPE int TclOOInit(Tcl_Interp *interp); MODULE_SCOPE void TclOOInitInfo(Tcl_Interp *interp); -MODULE_SCOPE int TclOOInvokeContext(void *clientData, +MODULE_SCOPE int TclOOInvokeContext(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclNRObjectContextInvokeNext(Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv, int skip); @@ -657,26 +561,15 @@ #define FOREACH(var,ary) \ 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 - * possible NULLs; every element of the array will be iterated over and the - * varable set to a pointer to each of those elements in turn. - * REQUIRES DECLARATION: int i; - */ - -#define FOREACH_STRUCT(var,ary) \ - for(i=0 ; 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_VALUE is a restricted version that * only iterates over values. - * REQUIRES DECLARATION: FOREACH_HASH_DECLS; */ #define FOREACH_HASH_DECLS \ Tcl_HashEntry *hPtr;Tcl_HashSearch search #define FOREACH_HASH(key,val,tablePtr) \ @@ -693,13 +586,13 @@ */ #undef DUPLICATE /* prevent possible conflict with definition in WINAPI nb30.h */ #define DUPLICATE(target,source,type) \ do { \ - register size_t len = sizeof(type) * ((target).num=(source).num);\ + size_t len = sizeof(type) * ((target).num=(source).num);\ if (len != 0) { \ - memcpy(((target).list=(type*)Tcl_Alloc(len)), (source).list, len); \ + memcpy(((target).list=(type*)ckalloc(len)), (source).list, len); \ } else { \ (target).list = NULL; \ } \ } while(0) Index: generic/tclOOIntDecls.h ================================================================== --- generic/tclOOIntDecls.h +++ generic/tclOOIntDecls.h @@ -20,18 +20,18 @@ /* 1 */ TCLAPI Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, - void *clientData, Proc **procPtrPtr); + ClientData clientData, Proc **procPtrPtr); /* 2 */ TCLAPI Tcl_Method TclOOMakeProcMethod(Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, const char *namePtr, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, - void *clientData, Proc **procPtrPtr); + ClientData clientData, Proc **procPtrPtr); /* 3 */ TCLAPI Method * TclOONewProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); @@ -57,23 +57,23 @@ /* 9 */ TCLAPI Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, - ProcErrorProc *errProc, void *clientData, - Tcl_Obj *nameObj, Tcl_Obj *argsObj, - Tcl_Obj *bodyObj, int flags, - void **internalTokenPtr); + ProcErrorProc *errProc, + ClientData clientData, Tcl_Obj *nameObj, + Tcl_Obj *argsObj, Tcl_Obj *bodyObj, + int flags, void **internalTokenPtr); /* 10 */ TCLAPI Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Class clsPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, - ProcErrorProc *errProc, void *clientData, - Tcl_Obj *nameObj, Tcl_Obj *argsObj, - Tcl_Obj *bodyObj, int flags, - void **internalTokenPtr); + ProcErrorProc *errProc, + ClientData clientData, Tcl_Obj *nameObj, + Tcl_Obj *argsObj, Tcl_Obj *bodyObj, + int flags, void **internalTokenPtr); /* 11 */ TCLAPI int TclOOInvokeObject(Tcl_Interp *interp, Tcl_Object object, Tcl_Class startCls, int publicPrivate, int objc, Tcl_Obj *const *objv); @@ -95,20 +95,20 @@ typedef struct TclOOIntStubs { int magic; void *hooks; Tcl_Object (*tclOOGetDefineCmdContext) (Tcl_Interp *interp); /* 0 */ - Tcl_Method (*tclOOMakeProcInstanceMethod) (Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, void *clientData, Proc **procPtrPtr); /* 1 */ - Tcl_Method (*tclOOMakeProcMethod) (Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, const char *namePtr, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, void *clientData, Proc **procPtrPtr); /* 2 */ + Tcl_Method (*tclOOMakeProcInstanceMethod) (Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 1 */ + Tcl_Method (*tclOOMakeProcMethod) (Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, const char *namePtr, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 2 */ Method * (*tclOONewProcInstanceMethod) (Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 3 */ Method * (*tclOONewProcMethod) (Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 4 */ int (*tclOOObjectCmdCore) (Object *oPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv, int publicOnly, Class *startCls); /* 5 */ int (*tclOOIsReachable) (Class *targetPtr, Class *startPtr); /* 6 */ Method * (*tclOONewForwardMethod) (Tcl_Interp *interp, Class *clsPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 7 */ Method * (*tclOONewForwardInstanceMethod) (Tcl_Interp *interp, Object *oPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 8 */ - Tcl_Method (*tclOONewProcInstanceMethodEx) (Tcl_Interp *interp, Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, void *clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 9 */ - Tcl_Method (*tclOONewProcMethodEx) (Tcl_Interp *interp, Tcl_Class clsPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, void *clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 10 */ + Tcl_Method (*tclOONewProcInstanceMethodEx) (Tcl_Interp *interp, Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, ClientData clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 9 */ + Tcl_Method (*tclOONewProcMethodEx) (Tcl_Interp *interp, Tcl_Class clsPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, ClientData clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 10 */ int (*tclOOInvokeObject) (Tcl_Interp *interp, Tcl_Object object, Tcl_Class startCls, int publicPrivate, int objc, Tcl_Obj *const *objv); /* 11 */ void (*tclOOObjectSetFilters) (Object *oPtr, int numFilters, Tcl_Obj *const *filters); /* 12 */ void (*tclOOClassSetFilters) (Tcl_Interp *interp, Class *classPtr, int numFilters, Tcl_Obj *const *filters); /* 13 */ void (*tclOOObjectSetMixins) (Object *oPtr, int numMixins, Class *const *mixins); /* 14 */ void (*tclOOClassSetMixins) (Tcl_Interp *interp, Class *classPtr, int numMixins, Class *const *mixins); /* 15 */ Index: generic/tclOOMethod.c ================================================================== --- generic/tclOOMethod.c +++ generic/tclOOMethod.c @@ -65,36 +65,36 @@ static Tcl_Obj ** InitEnsembleRewrite(Tcl_Interp *interp, int objc, Tcl_Obj *const *objv, int toRewrite, int rewriteLength, Tcl_Obj *const *rewriteObjs, int *lengthPtr); -static int InvokeProcedureMethod(void *clientData, +static int InvokeProcedureMethod(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); static Tcl_NRPostProc FinalizeForwardCall; static Tcl_NRPostProc FinalizePMCall; static int PushMethodCallFrame(Tcl_Interp *interp, CallContext *contextPtr, ProcedureMethod *pmPtr, int objc, Tcl_Obj *const *objv, PMFrameData *fdPtr); static void DeleteProcedureMethodRecord(ProcedureMethod *pmPtr); -static void DeleteProcedureMethod(void *clientData); +static void DeleteProcedureMethod(ClientData clientData); static int CloneProcedureMethod(Tcl_Interp *interp, - void *clientData, void **newClientData); + ClientData clientData, ClientData *newClientData); static void MethodErrorHandler(Tcl_Interp *interp, Tcl_Obj *procNameObj); static void ConstructorErrorHandler(Tcl_Interp *interp, Tcl_Obj *procNameObj); static void DestructorErrorHandler(Tcl_Interp *interp, Tcl_Obj *procNameObj); -static Tcl_Obj * RenderDeclarerName(void *clientData); -static int InvokeForwardMethod(void *clientData, +static Tcl_Obj * RenderDeclarerName(ClientData clientData); +static int InvokeForwardMethod(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); -static void DeleteForwardMethod(void *clientData); +static void DeleteForwardMethod(ClientData clientData); static int CloneForwardMethod(Tcl_Interp *interp, - void *clientData, void **newClientData); + ClientData clientData, ClientData *newClientData); static int ProcedureMethodVarResolver(Tcl_Interp *interp, const char *varName, Tcl_Namespace *contextNs, int flags, Tcl_Var *varPtr); static int ProcedureMethodCompiledVarResolver(Tcl_Interp *interp, const char *varName, int length, @@ -119,11 +119,11 @@ */ #define TclVarTable(contextNs) \ ((Tcl_HashTable *) (&((Namespace *) (contextNs))->varTable)) #define TclVarHashGetValue(hPtr) \ - ((Tcl_Var) ((char *)hPtr - offsetof(VarInHash, entry))) + ((Tcl_Var) ((char *)hPtr - TclOffset(VarInHash, entry))) /* * ---------------------------------------------------------------------- * * Tcl_NewInstanceMethod -- @@ -144,32 +144,32 @@ int flags, /* Whether this is a public method. */ const Tcl_MethodType *typePtr, /* The type of method this is, which defines * how to invoke, delete and clone the * method. */ - void *clientData) /* Some data associated with the particular + ClientData clientData) /* Some data associated with the particular * method to be created. */ { register Object *oPtr = (Object *) object; register Method *mPtr; Tcl_HashEntry *hPtr; int isNew; if (nameObj == NULL) { - mPtr = Tcl_Alloc(sizeof(Method)); + mPtr = ckalloc(sizeof(Method)); mPtr->namePtr = NULL; mPtr->refCount = 1; goto populate; } if (!oPtr->methodsPtr) { - oPtr->methodsPtr = Tcl_Alloc(sizeof(Tcl_HashTable)); + oPtr->methodsPtr = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitObjHashTable(oPtr->methodsPtr); oPtr->flags &= ~USE_CLASS_CACHE; } hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) nameObj, &isNew); if (isNew) { - mPtr = Tcl_Alloc(sizeof(Method)); + mPtr = ckalloc(sizeof(Method)); mPtr->namePtr = nameObj; mPtr->refCount = 1; Tcl_IncrRefCount(nameObj); Tcl_SetHashValue(hPtr, mPtr); } else { @@ -184,15 +184,11 @@ mPtr->clientData = clientData; mPtr->flags = 0; mPtr->declaringObjectPtr = oPtr; mPtr->declaringClassPtr = NULL; if (flags) { - mPtr->flags |= flags & - (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD); - if (flags & TRUE_PRIVATE_METHOD) { - oPtr->flags |= HAS_PRIVATE_METHODS; - } + mPtr->flags |= flags & (PUBLIC_METHOD | PRIVATE_METHOD); } oPtr->epoch++; return (Tcl_Method) mPtr; } @@ -216,27 +212,27 @@ int flags, /* Whether this is a public method. */ const Tcl_MethodType *typePtr, /* The type of method this is, which defines * how to invoke, delete and clone the * method. */ - void *clientData) /* Some data associated with the particular + ClientData clientData) /* Some data associated with the particular * method to be created. */ { register Class *clsPtr = (Class *) cls; register Method *mPtr; Tcl_HashEntry *hPtr; int isNew; if (nameObj == NULL) { - mPtr = Tcl_Alloc(sizeof(Method)); + mPtr = ckalloc(sizeof(Method)); mPtr->namePtr = NULL; mPtr->refCount = 1; goto populate; } hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char *)nameObj,&isNew); if (isNew) { - mPtr = Tcl_Alloc(sizeof(Method)); + mPtr = ckalloc(sizeof(Method)); mPtr->refCount = 1; mPtr->namePtr = nameObj; Tcl_IncrRefCount(nameObj); Tcl_SetHashValue(hPtr, mPtr); } else { @@ -252,15 +248,11 @@ mPtr->clientData = clientData; mPtr->flags = 0; mPtr->declaringObjectPtr = NULL; mPtr->declaringClassPtr = clsPtr; if (flags) { - mPtr->flags |= flags & - (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD); - if (flags & TRUE_PRIVATE_METHOD) { - clsPtr->flags |= HAS_PRIVATE_METHODS; - } + mPtr->flags |= flags & (PUBLIC_METHOD | PRIVATE_METHOD); } return (Tcl_Method) mPtr; } @@ -284,11 +276,11 @@ } if (mPtr->namePtr != NULL) { Tcl_DecrRefCount(mPtr->namePtr); } - Tcl_Free(mPtr); + ckfree(mPtr); } } /* * ---------------------------------------------------------------------- @@ -348,20 +340,20 @@ Tcl_Method method; if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) { return NULL; } - pmPtr = Tcl_Alloc(sizeof(ProcedureMethod)); + pmPtr = ckalloc(sizeof(ProcedureMethod)); memset(pmPtr, 0, sizeof(ProcedureMethod)); pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION; pmPtr->flags = flags & USE_DECLARER_NS; pmPtr->refCount = 1; method = TclOOMakeProcInstanceMethod(interp, oPtr, flags, nameObj, argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr); if (method == NULL) { - Tcl_Free(pmPtr); + ckfree(pmPtr); } else if (pmPtrPtr != NULL) { *pmPtrPtr = pmPtr; } return (Method *) method; } @@ -409,11 +401,11 @@ return NULL; } else { procName = (nameObj==NULL ? "" : TclGetString(nameObj)); } - pmPtr = Tcl_Alloc(sizeof(ProcedureMethod)); + pmPtr = ckalloc(sizeof(ProcedureMethod)); memset(pmPtr, 0, sizeof(ProcedureMethod)); pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION; pmPtr->flags = flags & USE_DECLARER_NS; pmPtr->refCount = 1; @@ -422,11 +414,11 @@ if (argsLen == -1) { Tcl_DecrRefCount(argsObj); } if (method == NULL) { - Tcl_Free(pmPtr); + ckfree(pmPtr); } else if (pmPtrPtr != NULL) { *pmPtrPtr = pmPtr; } return (Method *) method; @@ -456,11 +448,11 @@ * which _must not_ be NULL. */ Tcl_Obj *bodyObj, /* The body of the method, which _must not_ be * NULL. */ const Tcl_MethodType *typePtr, /* The type of the method to create. */ - void *clientData, /* The per-method type-specific data. */ + ClientData clientData, /* The per-method type-specific data. */ Proc **procPtrPtr) /* A pointer to the variable in which to write * the procedure record reference. Presumably * inside the structure indicated by the * pointer in clientData. */ { @@ -503,16 +495,16 @@ */ if (context.line && (context.nline >= 4) && (context.line[3] >= 0)) { int isNew; - CmdFrame *cfPtr = Tcl_Alloc(sizeof(CmdFrame)); + CmdFrame *cfPtr = ckalloc(sizeof(CmdFrame)); Tcl_HashEntry *hPtr; cfPtr->level = -1; cfPtr->type = context.type; - cfPtr->line = Tcl_Alloc(sizeof(int)); + cfPtr->line = ckalloc(sizeof(int)); cfPtr->line[0] = context.line[3]; cfPtr->nline = 1; cfPtr->framePtr = NULL; cfPtr->nextPtr = NULL; @@ -569,11 +561,11 @@ * which _must not_ be NULL. */ Tcl_Obj *bodyObj, /* The body of the method, which _must not_ be * NULL. */ const Tcl_MethodType *typePtr, /* The type of the method to create. */ - void *clientData, /* The per-method type-specific data. */ + ClientData clientData, /* The per-method type-specific data. */ Proc **procPtrPtr) /* A pointer to the variable in which to write * the procedure record reference. Presumably * inside the structure indicated by the * pointer in clientData. */ { @@ -616,16 +608,16 @@ */ if (context.line && (context.nline >= 4) && (context.line[3] >= 0)) { int isNew; - CmdFrame *cfPtr = Tcl_Alloc(sizeof(CmdFrame)); + CmdFrame *cfPtr = ckalloc(sizeof(CmdFrame)); Tcl_HashEntry *hPtr; cfPtr->level = -1; cfPtr->type = context.type; - cfPtr->line = Tcl_Alloc(sizeof(int)); + cfPtr->line = ckalloc(sizeof(int)); cfPtr->line[0] = context.line[3]; cfPtr->nline = 1; cfPtr->framePtr = NULL; cfPtr->nextPtr = NULL; @@ -664,11 +656,11 @@ * ---------------------------------------------------------------------- */ static int InvokeProcedureMethod( - void *clientData, /* Pointer to some per-method context. */ + ClientData clientData, /* Pointer to some per-method context. */ Tcl_Interp *interp, Tcl_ObjectContext context, /* The method calling context. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Arguments as actually seen. */ { @@ -677,15 +669,17 @@ PMFrameData *fdPtr; /* Important data that has to have a lifetime * matched by this function (or rather, by the * call frame's lifetime). */ /* - * If the interpreter was deleted, we just skip to the next thing in the - * chain. + * If the object namespace (or interpreter) were deleted, we just skip to + * the next thing in the chain. */ - if (Tcl_InterpDeleted(interp)) { + if (TclOOObjectDestroyed(((CallContext *)context)->oPtr) || + Tcl_InterpDeleted(interp) + ) { return TclNRObjectContextInvokeNext(interp, context, objc, objv, Tcl_ObjectContextSkippedArgs(context)); } /* @@ -743,11 +737,11 @@ Tcl_ObjectContextSkippedArgs(context), fdPtr->errProc); } static int FinalizePMCall( - void *data[], + ClientData data[], Tcl_Interp *interp, int result) { ProcedureMethod *pmPtr = data[0]; Tcl_ObjectContext context = data[1]; @@ -797,11 +791,10 @@ { Namespace *nsPtr = (Namespace *) contextPtr->oPtr->namespacePtr; register int result; const char *namePtr; CallFrame **framePtrPtr = &fdPtr->framePtr; - ByteCode *codePtr; /* * Compute basic information on the basis of the type of method it is. */ @@ -863,12 +856,14 @@ * that we have bytecode, but also that it remains valid. Note that we set * the namespace of the code here directly; this is a hack, but the * alternative is *so* slow... */ - ByteCodeGetIntRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, codePtr); - if (codePtr) { + if (pmPtr->procPtr->bodyPtr->typePtr == &tclByteCodeType) { + ByteCode *codePtr = + pmPtr->procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; + codePtr->nsPtr = nsPtr; } result = TclProcCompileProc(interp, pmPtr->procPtr, pmPtr->procPtr->bodyPtr, nsPtr, "body of method", namePtr); if (result != TCL_OK) { @@ -933,11 +928,11 @@ * * Variable resolution engine used to connect declared variables to local * variables used in methods. The compiled variable resolver is more * important, but both are needed as it is possible to have a variable * that is only referred to in ways that aren't compilable and we can't - * force LVT presence. [TIP #320, #500] + * force LVT presence. [TIP #320] * * ---------------------------------------------------------------------- */ void @@ -989,14 +984,12 @@ OOResVarInfo *infoPtr = (OOResVarInfo *) rPtr; Interp *iPtr = (Interp *) interp; CallFrame *framePtr = iPtr->varFramePtr; CallContext *contextPtr; Tcl_Obj *variableObj; - PrivateVariableMapping *privateVar; Tcl_HashEntry *hPtr; - int i, isNew, cacheIt; - size_t varLen, len; + int i, isNew, cacheIt, varLen, len; const char *match, *varName; /* * Check that the variable is being requested in a context that is also a * method call; if not (i.e. we're evaluating in the object's namespace or @@ -1024,36 +1017,19 @@ */ varName = TclGetStringFromObj(infoPtr->variableObj, &varLen); if (contextPtr->callPtr->chain[contextPtr->index] .mPtr->declaringClassPtr != NULL) { - FOREACH_STRUCT(privateVar, contextPtr->callPtr->chain[contextPtr->index] - .mPtr->declaringClassPtr->privateVariables) { - match = TclGetStringFromObj(privateVar->variableObj, &len); - if ((len == varLen) && !memcmp(match, varName, len)) { - variableObj = privateVar->fullNameObj; - cacheIt = 0; - goto gotMatch; - } - } FOREACH(variableObj, contextPtr->callPtr->chain[contextPtr->index] .mPtr->declaringClassPtr->variables) { match = TclGetStringFromObj(variableObj, &len); if ((len == varLen) && !memcmp(match, varName, len)) { cacheIt = 0; goto gotMatch; } } } else { - FOREACH_STRUCT(privateVar, contextPtr->oPtr->privateVariables) { - match = TclGetStringFromObj(privateVar->variableObj, &len); - if ((len == varLen) && !memcmp(match, varName, len)) { - variableObj = privateVar->fullNameObj; - cacheIt = 1; - goto gotMatch; - } - } FOREACH(variableObj, contextPtr->oPtr->variables) { match = TclGetStringFromObj(variableObj, &len); if ((len == varLen) && !memcmp(match, varName, len)) { cacheIt = 1; goto gotMatch; @@ -1099,11 +1075,11 @@ if (infoPtr->cachedObjectVar) { VarHashRefCount(infoPtr->cachedObjectVar)--; TclCleanupVar((Var *) infoPtr->cachedObjectVar, NULL); } Tcl_DecrRefCount(infoPtr->variableObj); - Tcl_Free(infoPtr); + ckfree(infoPtr); } static int ProcedureMethodCompiledVarResolver( Tcl_Interp *interp, @@ -1118,17 +1094,17 @@ /* * Do not create resolvers for cases that contain namespace separators or * which look like array accesses. Both will lead us astray. */ - if (strstr(TclGetString(variableObj), "::") != NULL || - Tcl_StringMatch(TclGetString(variableObj), "*(*)")) { + if (strstr(Tcl_GetString(variableObj), "::") != NULL || + Tcl_StringMatch(Tcl_GetString(variableObj), "*(*)")) { Tcl_DecrRefCount(variableObj); return TCL_CONTINUE; } - infoPtr = Tcl_Alloc(sizeof(OOResVarInfo)); + infoPtr = ckalloc(sizeof(OOResVarInfo)); infoPtr->info.fetchProc = ProcedureMethodCompiledVarConnect; infoPtr->info.deleteProc = ProcedureMethodCompiledVarDelete; infoPtr->cachedObjectVar = NULL; infoPtr->variableObj = variableObj; Tcl_IncrRefCount(variableObj); @@ -1149,11 +1125,11 @@ * ---------------------------------------------------------------------- */ static Tcl_Obj * RenderDeclarerName( - void *clientData) + ClientData clientData) { struct PNI *pni = clientData; Tcl_Object object = Tcl_MethodDeclarerObject(pni->method); if (object == NULL) { @@ -1177,22 +1153,22 @@ * ---------------------------------------------------------------------- */ #define LIMIT 60 #define ELLIPSIFY(str,len) \ - ((len) > LIMIT ? LIMIT : (int)(len)), (str), ((len) > LIMIT ? "..." : "") + ((len) > LIMIT ? LIMIT : (len)), (str), ((len) > LIMIT ? "..." : "") static void MethodErrorHandler( Tcl_Interp *interp, Tcl_Obj *methodNameObj) { - size_t nameLen, objectNameLen; + int nameLen, objectNameLen; CallContext *contextPtr = ((Interp *) interp)->varFramePtr->clientData; Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; const char *objectName, *kindName, *methodName = - TclGetStringFromObj(mPtr->namePtr, &nameLen); + Tcl_GetStringFromObj(mPtr->namePtr, &nameLen); Object *declarerPtr; if (mPtr->declaringObjectPtr != NULL) { declarerPtr = mPtr->declaringObjectPtr; kindName = "object"; @@ -1202,11 +1178,11 @@ } declarerPtr = mPtr->declaringClassPtr->thisPtr; kindName = "class"; } - objectName = TclGetStringFromObj(TclOOObjectName(interp, declarerPtr), + objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr), &objectNameLen); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (%s \"%.*s%s\" method \"%.*s%s\" line %d)", kindName, ELLIPSIFY(objectName, objectNameLen), ELLIPSIFY(methodName, nameLen), Tcl_GetErrorLine(interp))); @@ -1219,11 +1195,11 @@ { CallContext *contextPtr = ((Interp *) interp)->varFramePtr->clientData; Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; Object *declarerPtr; const char *objectName, *kindName; - size_t objectNameLen; + int objectNameLen; if (mPtr->declaringObjectPtr != NULL) { declarerPtr = mPtr->declaringObjectPtr; kindName = "object"; } else { @@ -1232,11 +1208,11 @@ } declarerPtr = mPtr->declaringClassPtr->thisPtr; kindName = "class"; } - objectName = TclGetStringFromObj(TclOOObjectName(interp, declarerPtr), + objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr), &objectNameLen); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (%s \"%.*s%s\" constructor line %d)", kindName, ELLIPSIFY(objectName, objectNameLen), Tcl_GetErrorLine(interp))); } @@ -1248,11 +1224,11 @@ { CallContext *contextPtr = ((Interp *) interp)->varFramePtr->clientData; Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; Object *declarerPtr; const char *objectName, *kindName; - size_t objectNameLen; + int objectNameLen; if (mPtr->declaringObjectPtr != NULL) { declarerPtr = mPtr->declaringObjectPtr; kindName = "object"; } else { @@ -1261,11 +1237,11 @@ } declarerPtr = mPtr->declaringClassPtr->thisPtr; kindName = "class"; } - objectName = TclGetStringFromObj(TclOOObjectName(interp, declarerPtr), + objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr), &objectNameLen); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (%s \"%.*s%s\" destructor line %d)", kindName, ELLIPSIFY(objectName, objectNameLen), Tcl_GetErrorLine(interp))); } @@ -1286,16 +1262,16 @@ { TclProcDeleteProc(pmPtr->procPtr); if (pmPtr->deleteClientdataProc) { pmPtr->deleteClientdataProc(pmPtr->clientData); } - Tcl_Free(pmPtr); + ckfree(pmPtr); } static void DeleteProcedureMethod( - void *clientData) + ClientData clientData) { register ProcedureMethod *pmPtr = clientData; if (pmPtr->refCount-- <= 1) { DeleteProcedureMethodRecord(pmPtr); @@ -1303,12 +1279,12 @@ } static int CloneProcedureMethod( Tcl_Interp *interp, - void *clientData, - void **newClientData) + ClientData clientData, + ClientData *newClientData) { ProcedureMethod *pmPtr = clientData; ProcedureMethod *pm2Ptr; Tcl_Obj *bodyObj, *argsObj; CompiledLocal *localPtr; @@ -1336,28 +1312,28 @@ * Must strip the internal representation in order to ensure that any * bound references to instance variables are removed. [Bug 3609693] */ bodyObj = Tcl_DuplicateObj(pmPtr->procPtr->bodyPtr); - TclGetString(bodyObj); - Tcl_StoreIntRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, NULL); + Tcl_GetString(bodyObj); + TclFreeIntRep(bodyObj); /* * Create the actual copy of the method record, manufacturing a new proc * record. */ - pm2Ptr = Tcl_Alloc(sizeof(ProcedureMethod)); + pm2Ptr = ckalloc(sizeof(ProcedureMethod)); memcpy(pm2Ptr, pmPtr, sizeof(ProcedureMethod)); pm2Ptr->refCount = 1; Tcl_IncrRefCount(argsObj); Tcl_IncrRefCount(bodyObj); if (TclCreateProc(interp, NULL, "", argsObj, bodyObj, &pm2Ptr->procPtr) != TCL_OK) { Tcl_DecrRefCount(argsObj); Tcl_DecrRefCount(bodyObj); - Tcl_Free(pm2Ptr); + ckfree(pm2Ptr); return TCL_ERROR; } Tcl_DecrRefCount(argsObj); Tcl_DecrRefCount(bodyObj); @@ -1398,11 +1374,11 @@ "method forward prefix must be non-empty", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL); return NULL; } - fmPtr = Tcl_Alloc(sizeof(ForwardMethod)); + fmPtr = ckalloc(sizeof(ForwardMethod)); fmPtr->prefixObj = prefixObj; Tcl_IncrRefCount(prefixObj); return (Method *) Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, nameObj, flags, &fwdMethodType, fmPtr); } @@ -1437,11 +1413,11 @@ "method forward prefix must be non-empty", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL); return NULL; } - fmPtr = Tcl_Alloc(sizeof(ForwardMethod)); + fmPtr = ckalloc(sizeof(ForwardMethod)); fmPtr->prefixObj = prefixObj; Tcl_IncrRefCount(prefixObj); return (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj, flags, &fwdMethodType, fmPtr); } @@ -1457,11 +1433,11 @@ * ---------------------------------------------------------------------- */ static int InvokeForwardMethod( - void *clientData, /* Pointer to some per-method context. */ + ClientData clientData, /* Pointer to some per-method context. */ Tcl_Interp *interp, Tcl_ObjectContext context, /* The method calling context. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Arguments as actually seen. */ { @@ -1491,11 +1467,11 @@ return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_NOERR, NULL); } static int FinalizeForwardCall( - void *data[], + ClientData data[], Tcl_Interp *interp, int result) { Tcl_Obj **argObjs = data[0]; @@ -1513,26 +1489,26 @@ * ---------------------------------------------------------------------- */ static void DeleteForwardMethod( - void *clientData) + ClientData clientData) { ForwardMethod *fmPtr = clientData; Tcl_DecrRefCount(fmPtr->prefixObj); - Tcl_Free(fmPtr); + ckfree(fmPtr); } static int CloneForwardMethod( Tcl_Interp *interp, - void *clientData, - void **newClientData) + ClientData clientData, + ClientData *newClientData) { ForwardMethod *fmPtr = clientData; - ForwardMethod *fm2Ptr = Tcl_Alloc(sizeof(ForwardMethod)); + ForwardMethod *fm2Ptr = ckalloc(sizeof(ForwardMethod)); fm2Ptr->prefixObj = fmPtr->prefixObj; Tcl_IncrRefCount(fm2Ptr->prefixObj); *newClientData = fm2Ptr; return TCL_OK; @@ -1566,11 +1542,13 @@ Method *mPtr) { if (mPtr->typePtr == &procMethodType) { ProcedureMethod *pmPtr = mPtr->clientData; - (void) TclGetString(pmPtr->procPtr->bodyPtr); + if (pmPtr->procPtr->bodyPtr->bytes == NULL) { + (void) Tcl_GetString(pmPtr->procPtr->bodyPtr); + } return pmPtr->procPtr->bodyPtr; } return NULL; } @@ -1674,11 +1652,11 @@ int Tcl_MethodIsType( Tcl_Method method, const Tcl_MethodType *typePtr, - void **clientDataPtr) + ClientData *clientDataPtr) { Method *mPtr = (Method *) method; if (mPtr->typePtr == typePtr) { if (clientDataPtr != NULL) { @@ -1693,17 +1671,10 @@ Tcl_MethodIsPublic( Tcl_Method method) { return (((Method *)method)->flags & PUBLIC_METHOD) ? 1 : 0; } - -int -Tcl_MethodIsPrivate( - Tcl_Method method) -{ - return (((Method *)method)->flags & TRUE_PRIVATE_METHOD) ? 1 : 0; -} /* * Extended method construction for itcl-ng. */ @@ -1712,11 +1683,11 @@ Tcl_Interp *interp, /* The interpreter containing the object. */ Tcl_Object oPtr, /* The object to modify. */ TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, - void *clientData, + ClientData clientData, Tcl_Obj *nameObj, /* The name of the method, which must not be * NULL. */ Tcl_Obj *argsObj, /* The formal argument list for the method, * which must not be NULL. */ Tcl_Obj *bodyObj, /* The body of the method, which must not be @@ -1749,11 +1720,11 @@ Tcl_Interp *interp, /* The interpreter containing the class. */ Tcl_Class clsPtr, /* The class to modify. */ TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, - void *clientData, + ClientData clientData, Tcl_Obj *nameObj, /* The name of the method, which may be NULL; * if so, up to caller to manage storage * (e.g., because it is a constructor or * destructor). */ Tcl_Obj *argsObj, /* The formal argument list for the method, DELETED generic/tclOOScript.h Index: generic/tclOOScript.h ================================================================== --- generic/tclOOScript.h +++ /dev/null @@ -1,263 +0,0 @@ -/* - * tclOOScript.h -- - * - * This file contains support scripts for TclOO. They are defined here so - * that the code can be definitely run even in safe interpreters; TclOO's - * core setup is safe. - * - * Copyright (c) 2012-2018 Donal K. Fellows - * Copyright (c) 2013 Andreas Kupries - * Copyright (c) 2017 Gerald Lester - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#ifndef TCL_OO_SCRIPT_H -#define TCL_OO_SCRIPT_H - -/* - * The scripted part of the definitions of TclOO. - * - * Compiled from generic/tclOOScript.tcl by tools/makeHeader.tcl, which - * contains the commented version of everything; *this* file is automatically - * generated. - */ - -static const char *tclOOSetupScript = -/* !BEGIN!: Do not edit below this line. */ -"::namespace eval ::oo {\n" -"\t::namespace path {}\n" -"\tnamespace eval Helpers {\n" -"\t\t::namespace path {}\n" -"\t\tproc callback {method args} {\n" -"\t\t\tlist [uplevel 1 {::namespace which my}] $method {*}$args\n" -"\t\t}\n" -"\t\tnamespace export callback\n" -"\t\tnamespace eval tmp {namespace import ::oo::Helpers::callback}\n" -"\t\tnamespace export -clear\n" -"\t\trename tmp::callback mymethod\n" -"\t\tnamespace delete tmp\n" -"\t\tproc classvariable {name args} {\n" -"\t\t\tset ns [info object namespace [uplevel 1 {self class}]]\n" -"\t\t\tforeach v [list $name {*}$args] {\n" -"\t\t\t\tif {[string match *(*) $v]} {\n" -"\t\t\t\t\tset reason \"can\'t create a scalar variable that looks like an array element\"\n" -"\t\t\t\t\treturn -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \\\n" -"\t\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n" -"\t\t\t\t}\n" -"\t\t\t\tif {[string match *::* $v]} {\n" -"\t\t\t\t\tset reason \"can\'t create a local variable with a namespace separator in it\"\n" -"\t\t\t\t\treturn -code error -errorcode {TCL UPVAR INVERTED} \\\n" -"\t\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n" -"\t\t\t\t}\n" -"\t\t\t\tlappend vs $v $v\n" -"\t\t\t}\n" -"\t\t\ttailcall namespace upvar $ns {*}$vs\n" -"\t\t}\n" -"\t\tproc link {args} {\n" -"\t\t\tset ns [uplevel 1 {::namespace current}]\n" -"\t\t\tforeach link $args {\n" -"\t\t\t\tif {[llength $link] == 2} {\n" -"\t\t\t\t\tlassign $link src dst\n" -"\t\t\t\t} elseif {[llength $link] == 1} {\n" -"\t\t\t\t\tlassign $link src\n" -"\t\t\t\t\tset dst $src\n" -"\t\t\t\t} else {\n" -"\t\t\t\t\treturn -code error -errorcode {TCLOO CMDLINK FORMAT} \\\n" -"\t\t\t\t\t\t\"bad link description; must only have one or two elements\"\n" -"\t\t\t\t}\n" -"\t\t\t\tif {![string match ::* $src]} {\n" -"\t\t\t\t\tset src [string cat $ns :: $src]\n" -"\t\t\t\t}\n" -"\t\t\t\tinterp alias {} $src {} ${ns}::my $dst\n" -"\t\t\t\ttrace add command ${ns}::my delete [list \\\n" -"\t\t\t\t\t::oo::UnlinkLinkedCommand $src]\n" -"\t\t\t}\n" -"\t\t\treturn\n" -"\t\t}\n" -"\t}\n" -"\tproc UnlinkLinkedCommand {cmd args} {\n" -"\t\tif {[namespace which $cmd] ne {}} {\n" -"\t\t\trename $cmd {}\n" -"\t\t}\n" -"\t}\n" -"\tproc DelegateName {class} {\n" -"\t\tstring cat [info object namespace $class] {:: oo ::delegate}\n" -"\t}\n" -"\tproc MixinClassDelegates {class} {\n" -"\t\tif {![info object isa class $class]} {\n" -"\t\t\treturn\n" -"\t\t}\n" -"\t\tset delegate [DelegateName $class]\n" -"\t\tif {![info object isa class $delegate]} {\n" -"\t\t\treturn\n" -"\t\t}\n" -"\t\tforeach c [info class superclass $class] {\n" -"\t\t\tset d [DelegateName $c]\n" -"\t\t\tif {![info object isa class $d]} {\n" -"\t\t\t\tcontinue\n" -"\t\t\t}\n" -"\t\t\tdefine $delegate ::oo::define::superclass -append $d\n" -"\t\t}\n" -"\t\tobjdefine $class ::oo::objdefine::mixin -append $delegate\n" -"\t}\n" -"\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n" -"\t\tset originDelegate [DelegateName $originObject]\n" -"\t\tset targetDelegate [DelegateName $targetObject]\n" -"\t\tif {\n" -"\t\t\t[info object isa class $originDelegate]\n" -"\t\t\t&& ![info object isa class $targetDelegate]\n" -"\t\t} then {\n" -"\t\t\tcopy $originDelegate $targetDelegate\n" -"\t\t\tobjdefine $targetObject mixin -set \\\n" -"\t\t\t\t{*}[lmap c [info object mixin $targetObject] {\n" -"\t\t\t\t\tif {$c eq $originDelegate} {set targetDelegate} {set c}\n" -"\t\t\t\t}]\n" -"\t\t}\n" -"\t}\n" -"\tproc define::classmethod {name {args {}} {body {}}} {\n" -"\t\t::set argc [::llength [::info level 0]]\n" -"\t\t::if {$argc == 3} {\n" -"\t\t\t::return -code error -errorcode {TCL WRONGARGS} [::format \\\n" -"\t\t\t\t{wrong # args: should be \"%s name \?args body\?\"} \\\n" -"\t\t\t\t[::lindex [::info level 0] 0]]\n" -"\t\t}\n" -"\t\t::set cls [::uplevel 1 self]\n" -"\t\t::if {$argc == 4} {\n" -"\t\t\t::oo::define [::oo::DelegateName $cls] method $name $args $body\n" -"\t\t}\n" -"\t\t::tailcall forward $name myclass $name\n" -"\t}\n" -"\tproc define::initialise {body} {\n" -"\t\t::set clsns [::info object namespace [::uplevel 1 self]]\n" -"\t\t::tailcall apply [::list {} $body $clsns]\n" -"\t}\n" -"\tnamespace eval define {\n" -"\t\t::namespace export initialise\n" -"\t\t::namespace eval tmp {::namespace import ::oo::define::initialise}\n" -"\t\t::namespace export -clear\n" -"\t\t::rename tmp::initialise initialize\n" -"\t\t::namespace delete tmp\n" -"\t}\n" -"\tdefine Slot {\n" -"\t\tmethod Get {} {\n" -"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n" -"\t\t}\n" -"\t\tmethod Set list {\n" -"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n" -"\t\t}\n" -"\t\tmethod Resolve list {\n" -"\t\t\treturn $list\n" -"\t\t}\n" -"\t\tmethod -set args {\n" -"\t\t\tset my [namespace which my]\n" -"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" -"\t\t\ttailcall my Set $args\n" -"\t\t}\n" -"\t\tmethod -append args {\n" -"\t\t\tset my [namespace which my]\n" -"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" -"\t\t\tset current [uplevel 1 [list $my Get]]\n" -"\t\t\ttailcall my Set [list {*}$current {*}$args]\n" -"\t\t}\n" -"\t\tmethod -clear {} {tailcall my Set {}}\n" -"\t\tmethod -prepend args {\n" -"\t\t\tset my [namespace which my]\n" -"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" -"\t\t\tset current [uplevel 1 [list $my Get]]\n" -"\t\t\ttailcall my Set [list {*}$args {*}$current]\n" -"\t\t}\n" -"\t\tmethod -remove args {\n" -"\t\t\tset my [namespace which my]\n" -"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" -"\t\t\tset current [uplevel 1 [list $my Get]]\n" -"\t\t\ttailcall my Set [lmap val $current {\n" -"\t\t\t\tif {$val in $args} continue else {set val}\n" -"\t\t\t}]\n" -"\t\t}\n" -"\t\tforward --default-operation my -append\n" -"\t\tmethod unknown {args} {\n" -"\t\t\tset def --default-operation\n" -"\t\t\tif {[llength $args] == 0} {\n" -"\t\t\t\ttailcall my $def\n" -"\t\t\t} elseif {![string match -* [lindex $args 0]]} {\n" -"\t\t\t\ttailcall my $def {*}$args\n" -"\t\t\t}\n" -"\t\t\tnext {*}$args\n" -"\t\t}\n" -"\t\texport -set -append -clear -prepend -remove\n" -"\t\tunexport unknown destroy\n" -"\t}\n" -"\tobjdefine define::superclass forward --default-operation my -set\n" -"\tobjdefine define::mixin forward --default-operation my -set\n" -"\tobjdefine objdefine::mixin forward --default-operation my -set\n" -"\tdefine object method {originObject} {\n" -"\t\tforeach p [info procs [info object namespace $originObject]::*] {\n" -"\t\t\tset args [info args $p]\n" -"\t\t\tset idx -1\n" -"\t\t\tforeach a $args {\n" -"\t\t\t\tif {[info default $p $a d]} {\n" -"\t\t\t\t\tlset args [incr idx] [list $a $d]\n" -"\t\t\t\t} else {\n" -"\t\t\t\t\tlset args [incr idx] [list $a]\n" -"\t\t\t\t}\n" -"\t\t\t}\n" -"\t\t\tset b [info body $p]\n" -"\t\t\tset p [namespace tail $p]\n" -"\t\t\tproc $p $args $b\n" -"\t\t}\n" -"\t\tforeach v [info vars [info object namespace $originObject]::*] {\n" -"\t\t\tupvar 0 $v vOrigin\n" -"\t\t\tnamespace upvar [namespace current] [namespace tail $v] vNew\n" -"\t\t\tif {[info exists vOrigin]} {\n" -"\t\t\t\tif {[array exists vOrigin]} {\n" -"\t\t\t\t\tarray set vNew [array get vOrigin]\n" -"\t\t\t\t} else {\n" -"\t\t\t\t\tset vNew $vOrigin\n" -"\t\t\t\t}\n" -"\t\t\t}\n" -"\t\t}\n" -"\t}\n" -"\tdefine class method {originObject} {\n" -"\t\tnext $originObject\n" -"\t\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\n" -"\t}\n" -"\tclass create singleton {\n" -"\t\tsuperclass class\n" -"\t\tvariable object\n" -"\t\tunexport create createWithNamespace\n" -"\t\tmethod new args {\n" -"\t\t\tif {![info exists object] || ![info object isa object $object]} {\n" -"\t\t\t\tset object [next {*}$args]\n" -"\t\t\t\t::oo::objdefine $object {\n" -"\t\t\t\t\tmethod destroy {} {\n" -"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n" -"\t\t\t\t\t\t\t\"may not destroy a singleton object\"\n" -"\t\t\t\t\t}\n" -"\t\t\t\t\tmethod {originObject} {\n" -"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n" -"\t\t\t\t\t\t\t\"may not clone a singleton object\"\n" -"\t\t\t\t\t}\n" -"\t\t\t\t}\n" -"\t\t\t}\n" -"\t\t\treturn $object\n" -"\t\t}\n" -"\t}\n" -"\tclass create abstract {\n" -"\t\tsuperclass class\n" -"\t\tunexport create createWithNamespace new\n" -"\t}\n" -"}\n" -/* !END!: Do not edit above this line. */ -; - -#endif /* TCL_OO_SCRIPT_H */ - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ DELETED generic/tclOOScript.tcl Index: generic/tclOOScript.tcl ================================================================== --- generic/tclOOScript.tcl +++ /dev/null @@ -1,456 +0,0 @@ -# tclOOScript.h -- -# -# This file contains support scripts for TclOO. They are defined here so -# that the code can be definitely run even in safe interpreters; TclOO's -# core setup is safe. -# -# Copyright (c) 2012-2018 Donal K. Fellows -# Copyright (c) 2013 Andreas Kupries -# Copyright (c) 2017 Gerald Lester -# -# See the file "license.terms" for information on usage and redistribution of -# this file, and for a DISCLAIMER OF ALL WARRANTIES. - -::namespace eval ::oo { - ::namespace path {} - - # - # Commands that are made available to objects by default. - # - namespace eval Helpers { - ::namespace path {} - - # ------------------------------------------------------------------ - # - # callback, mymethod -- - # - # Create a script prefix that calls a method on the current - # object. Same operation, two names. - # - # ------------------------------------------------------------------ - - proc callback {method args} { - list [uplevel 1 {::namespace which my}] $method {*}$args - } - - # Make the [callback] command appear as [mymethod] too. - namespace export callback - namespace eval tmp {namespace import ::oo::Helpers::callback} - namespace export -clear - rename tmp::callback mymethod - namespace delete tmp - - # ------------------------------------------------------------------ - # - # classvariable -- - # - # Link to a variable in the class of the current object. - # - # ------------------------------------------------------------------ - - proc classvariable {name args} { - # Get a reference to the class's namespace - set ns [info object namespace [uplevel 1 {self class}]] - # Double up the list of variable names - foreach v [list $name {*}$args] { - if {[string match *(*) $v]} { - set reason "can't create a scalar variable that looks like an array element" - return -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \ - [format {bad variable name "%s": %s} $v $reason] - } - if {[string match *::* $v]} { - set reason "can't create a local variable with a namespace separator in it" - return -code error -errorcode {TCL UPVAR INVERTED} \ - [format {bad variable name "%s": %s} $v $reason] - } - lappend vs $v $v - } - # Lastly, link the caller's local variables to the class's variables - tailcall namespace upvar $ns {*}$vs - } - - # ------------------------------------------------------------------ - # - # link -- - # - # Make a command that invokes a method on the current object. - # The name of the command and the name of the method match by - # default. - # - # ------------------------------------------------------------------ - - proc link {args} { - set ns [uplevel 1 {::namespace current}] - foreach link $args { - if {[llength $link] == 2} { - lassign $link src dst - } elseif {[llength $link] == 1} { - lassign $link src - set dst $src - } else { - return -code error -errorcode {TCLOO CMDLINK FORMAT} \ - "bad link description; must only have one or two elements" - } - if {![string match ::* $src]} { - set src [string cat $ns :: $src] - } - interp alias {} $src {} ${ns}::my $dst - trace add command ${ns}::my delete [list \ - ::oo::UnlinkLinkedCommand $src] - } - return - } - } - - # ---------------------------------------------------------------------- - # - # UnlinkLinkedCommand -- - # - # Callback used to remove linked command when the underlying mechanism - # that supports it is deleted. - # - # ---------------------------------------------------------------------- - - proc UnlinkLinkedCommand {cmd args} { - if {[namespace which $cmd] ne {}} { - rename $cmd {} - } - } - - # ---------------------------------------------------------------------- - # - # DelegateName -- - # - # Utility that gets the name of the class delegate for a class. It's - # trivial, but makes working with them much easier as delegate names are - # intentionally hard to create by accident. - # - # ---------------------------------------------------------------------- - - proc DelegateName {class} { - string cat [info object namespace $class] {:: oo ::delegate} - } - - # ---------------------------------------------------------------------- - # - # MixinClassDelegates -- - # - # Support code called *after* [oo::define] inside the constructor of a - # class that patches in the appropriate class delegates. - # - # ---------------------------------------------------------------------- - - proc MixinClassDelegates {class} { - if {![info object isa class $class]} { - return - } - set delegate [DelegateName $class] - if {![info object isa class $delegate]} { - return - } - foreach c [info class superclass $class] { - set d [DelegateName $c] - if {![info object isa class $d]} { - continue - } - define $delegate ::oo::define::superclass -append $d - } - objdefine $class ::oo::objdefine::mixin -append $delegate - } - - # ---------------------------------------------------------------------- - # - # UpdateClassDelegatesAfterClone -- - # - # Support code that is like [MixinClassDelegates] except for when a - # class is cloned. - # - # ---------------------------------------------------------------------- - - proc UpdateClassDelegatesAfterClone {originObject targetObject} { - # Rebuild the class inheritance delegation class - set originDelegate [DelegateName $originObject] - set targetDelegate [DelegateName $targetObject] - if { - [info object isa class $originDelegate] - && ![info object isa class $targetDelegate] - } then { - copy $originDelegate $targetDelegate - objdefine $targetObject ::oo::objdefine::mixin -set \ - {*}[lmap c [info object mixin $targetObject] { - if {$c eq $originDelegate} {set targetDelegate} {set c} - }] - } - } - - # ---------------------------------------------------------------------- - # - # oo::define::classmethod -- - # - # Defines a class method. See define(n) for details. - # - # Note that the ::oo::define namespace is semi-public and a bit weird - # anyway, so we don't regard the namespace path as being under control: - # fully qualified names are used for everything. - # - # ---------------------------------------------------------------------- - - proc define::classmethod {name {args {}} {body {}}} { - # Create the method on the class if the caller gave arguments and body - ::set argc [::llength [::info level 0]] - ::if {$argc == 3} { - ::return -code error -errorcode {TCL WRONGARGS} [::format \ - {wrong # args: should be "%s name ?args body?"} \ - [::lindex [::info level 0] 0]] - } - ::set cls [::uplevel 1 self] - ::if {$argc == 4} { - ::oo::define [::oo::DelegateName $cls] method $name $args $body - } - # Make the connection by forwarding - ::tailcall forward $name myclass $name - } - - # ---------------------------------------------------------------------- - # - # oo::define::initialise, oo::define::initialize -- - # - # Do specific initialisation for a class. See define(n) for details. - # - # Note that the ::oo::define namespace is semi-public and a bit weird - # anyway, so we don't regard the namespace path as being under control: - # fully qualified names are used for everything. - # - # ---------------------------------------------------------------------- - - proc define::initialise {body} { - ::set clsns [::info object namespace [::uplevel 1 self]] - ::tailcall apply [::list {} $body $clsns] - } - - # Make the [initialise] definition appear as [initialize] too - namespace eval define { - ::namespace export initialise - ::namespace eval tmp {::namespace import ::oo::define::initialise} - ::namespace export -clear - ::rename tmp::initialise initialize - ::namespace delete tmp - } - - # ---------------------------------------------------------------------- - # - # Slot -- - # - # The class of slot operations, which are basically lists at the low - # level of TclOO; this provides a more consistent interface to them. - # - # ---------------------------------------------------------------------- - - define Slot { - # ------------------------------------------------------------------ - # - # Slot Get -- - # - # Basic slot getter. Retrieves the contents of the slot. - # Particular slots must provide concrete non-erroring - # implementation. - # - # ------------------------------------------------------------------ - - method Get {} { - return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented" - } - - # ------------------------------------------------------------------ - # - # Slot Set -- - # - # Basic slot setter. Sets the contents of the slot. Particular - # slots must provide concrete non-erroring implementation. - # - # ------------------------------------------------------------------ - - method Set list { - return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented" - } - - # ------------------------------------------------------------------ - # - # Slot Resolve -- - # - # Helper that lets a slot convert a list of arguments of a - # particular type to their canonical forms. Defaults to doing - # nothing (suitable for simple strings). - # - # ------------------------------------------------------------------ - - method Resolve list { - return $list - } - - # ------------------------------------------------------------------ - # - # Slot -set, -append, -clear, --default-operation -- - # - # Standard public slot operations. If a slot can't figure out - # what method to call directly, it uses --default-operation. - # - # ------------------------------------------------------------------ - - method -set args { - set my [namespace which my] - set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] - tailcall my Set $args - } - method -append args { - set my [namespace which my] - set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] - set current [uplevel 1 [list $my Get]] - tailcall my Set [list {*}$current {*}$args] - } - method -clear {} {tailcall my Set {}} - method -prepend args { - set my [namespace which my] - set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] - set current [uplevel 1 [list $my Get]] - tailcall my Set [list {*}$args {*}$current] - } - method -remove args { - set my [namespace which my] - set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] - set current [uplevel 1 [list $my Get]] - tailcall my Set [lmap val $current { - if {$val in $args} continue else {set val} - }] - } - - # Default handling - forward --default-operation my -append - method unknown {args} { - set def --default-operation - if {[llength $args] == 0} { - tailcall my $def - } elseif {![string match -* [lindex $args 0]]} { - tailcall my $def {*}$args - } - next {*}$args - } - - # Set up what is exported and what isn't - export -set -append -clear -prepend -remove - unexport unknown destroy - } - - # Set the default operation differently for these slots - objdefine define::superclass forward --default-operation my -set - objdefine define::mixin forward --default-operation my -set - objdefine objdefine::mixin forward --default-operation my -set - - # ---------------------------------------------------------------------- - # - # oo::object -- - # - # Handler for cloning objects that clones basic bits (only!) of the - # object's namespace. Non-procedures, traces, sub-namespaces, etc. need - # more complex (and class-specific) handling. - # - # ---------------------------------------------------------------------- - - define object method {originObject} { - # Copy over the procedures from the original namespace - foreach p [info procs [info object namespace $originObject]::*] { - set args [info args $p] - set idx -1 - foreach a $args { - if {[info default $p $a d]} { - lset args [incr idx] [list $a $d] - } else { - lset args [incr idx] [list $a] - } - } - set b [info body $p] - set p [namespace tail $p] - proc $p $args $b - } - # Copy over the variables from the original namespace - foreach v [info vars [info object namespace $originObject]::*] { - upvar 0 $v vOrigin - namespace upvar [namespace current] [namespace tail $v] vNew - if {[info exists vOrigin]} { - if {[array exists vOrigin]} { - array set vNew [array get vOrigin] - } else { - set vNew $vOrigin - } - } - } - # General commands, sub-namespaces and advancd variable config (traces, - # etc) are *not* copied over. Classes that want that should do it - # themselves. - } - - # ---------------------------------------------------------------------- - # - # oo::class -- - # - # Handler for cloning classes, which fixes up the delegates. - # - # ---------------------------------------------------------------------- - - define class method {originObject} { - next $originObject - # Rebuild the class inheritance delegation class - ::oo::UpdateClassDelegatesAfterClone $originObject [self] - } - - # ---------------------------------------------------------------------- - # - # oo::singleton -- - # - # A metaclass that is used to make classes that only permit one instance - # of them to exist. See singleton(n). - # - # ---------------------------------------------------------------------- - - class create singleton { - superclass class - variable object - unexport create createWithNamespace - method new args { - if {![info exists object] || ![info object isa object $object]} { - set object [next {*}$args] - ::oo::objdefine $object { - method destroy {} { - ::return -code error -errorcode {TCLOO SINGLETON} \ - "may not destroy a singleton object" - } - method {originObject} { - ::return -code error -errorcode {TCLOO SINGLETON} \ - "may not clone a singleton object" - } - } - } - return $object - } - } - - # ---------------------------------------------------------------------- - # - # oo::abstract -- - # - # A metaclass that is used to make classes that can't be directly - # instantiated. See abstract(n). - # - # ---------------------------------------------------------------------- - - class create abstract { - superclass class - unexport create createWithNamespace new - } -} - -# Local Variables: -# mode: tcl -# c-basic-offset: 4 -# fill-column: 78 -# End: Index: generic/tclOOStubInit.c ================================================================== --- generic/tclOOStubInit.c +++ generic/tclOOStubInit.c @@ -71,9 +71,8 @@ Tcl_ObjectGetMethodNameMapper, /* 24 */ Tcl_ObjectSetMethodNameMapper, /* 25 */ Tcl_ClassSetConstructor, /* 26 */ Tcl_ClassSetDestructor, /* 27 */ Tcl_GetObjectName, /* 28 */ - Tcl_MethodIsPrivate, /* 29 */ }; /* !END!: Do not edit above this line. */ Index: generic/tclObj.c ================================================================== --- generic/tclObj.c +++ generic/tclObj.c @@ -15,11 +15,10 @@ */ #include "tclInt.h" #include "tommath.h" #include -#include /* * Table of all object types. */ @@ -36,11 +35,11 @@ /* * The object allocator is single threaded. This mutex is referenced by the * TclNewObj macro, however, so must be visible. */ -#if TCL_THREADS +#ifdef TCL_THREADS MODULE_SCOPE Tcl_Mutex tclObjMutex; Tcl_Mutex tclObjMutex; #endif /* @@ -48,19 +47,20 @@ * the value of an empty string representation for an object. This value is * shared by all new objects allocated by Tcl_NewObj. */ char tclEmptyString = '\0'; +char *tclEmptyStringRep = &tclEmptyString; -#if TCL_THREADS && defined(TCL_MEM_DEBUG) +#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) /* * Structure for tracking the source file and line number where a given * Tcl_Obj was allocated. We also track the pointer to the Tcl_Obj itself, * for sanity checking purposes. */ -typedef struct { +typedef struct ObjData { Tcl_Obj *objPtr; /* The pointer to the allocated Tcl_Obj. */ const char *file; /* The name of the source file calling this * function; used for debugging. */ int line; /* Line number in the source file; used for * debugging. */ @@ -74,11 +74,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 { +typedef struct ThreadSpecificData { 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 occured in it, if * any. I.e. this table keeps track of @@ -86,11 +86,11 @@ * Its keys are Tcl_Obj pointers, the values * are ContLineLoc pointers. See the file * tclCompile.h for the definition of this * structure, and for references to all * related places in the core. */ -#if TCL_THREADS && defined(TCL_MEM_DEBUG) +#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) Tcl_HashTable *objThreadMap;/* Thread local table that is used to check * that a Tcl_Obj was not allocated by some * other thread. */ #endif /* TCL_MEM_DEBUG && TCL_THREADS */ } ThreadSpecificData; @@ -143,54 +143,65 @@ */ #define ObjDeletionLock(contextPtr) ((contextPtr)->deletionCount++) #define ObjDeletionUnlock(contextPtr) ((contextPtr)->deletionCount--) #define ObjDeletePending(contextPtr) ((contextPtr)->deletionCount > 0) #define ObjOnStack(contextPtr) ((contextPtr)->deletionStack != NULL) -#define PushObjToDelete(contextPtr,objPtr) \ +#define PushObjToDelete(contextPtr,objPtr) \ /* The string rep is already invalidated so we can use the bytes value \ * for our pointer chain: push onto the head of the stack. */ \ (objPtr)->bytes = (char *) ((contextPtr)->deletionStack); \ (contextPtr)->deletionStack = (objPtr) -#define PopObjToDelete(contextPtr,objPtrVar) \ +#define PopObjToDelete(contextPtr,objPtrVar) \ (objPtrVar) = (contextPtr)->deletionStack; \ (contextPtr)->deletionStack = (Tcl_Obj *) (objPtrVar)->bytes /* * Macro to set up the local reference to the deletion context. */ -#if !TCL_THREADS +#ifndef TCL_THREADS static PendingObjData pendingObjData; #define ObjInitDeletionContext(contextPtr) \ PendingObjData *const contextPtr = &pendingObjData -#elif HAVE_FAST_TSD +#elif defined(HAVE_FAST_TSD) static __thread PendingObjData pendingObjData; #define ObjInitDeletionContext(contextPtr) \ PendingObjData *const contextPtr = &pendingObjData #else static Tcl_ThreadDataKey pendingObjDataKey; #define ObjInitDeletionContext(contextPtr) \ - PendingObjData *const contextPtr = \ + PendingObjData *const contextPtr = \ Tcl_GetThreadData(&pendingObjDataKey, sizeof(PendingObjData)) #endif /* * Macros to pack/unpack a bignum's fields in a Tcl_Obj internal rep */ #define PACK_BIGNUM(bignum, objPtr) \ - if ((bignum).used > 0x7fff) { \ - mp_int *temp = (void *) Tcl_Alloc(sizeof(mp_int)); \ + if ((bignum).used > 0x7FFF) { \ + mp_int *temp = (mp_int *)ckalloc(sizeof(mp_int)); \ *temp = bignum; \ - (objPtr)->internalRep.twoPtrValue.ptr1 = temp; \ - (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(-1); \ - } else { \ - if ((bignum).alloc > 0x7fff) { \ + (objPtr)->internalRep.twoPtrValue.ptr1 = temp; \ + (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(-1); \ + } else { \ + if ((bignum).alloc > 0x7FFF) { \ mp_shrink(&(bignum)); \ } \ - (objPtr)->internalRep.twoPtrValue.ptr1 = (bignum).dp; \ - (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR( ((bignum).sign << 30) \ - | ((bignum).alloc << 15) | ((bignum).used)); \ + (objPtr)->internalRep.twoPtrValue.ptr1 = (void *)(bignum).dp; \ + (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(((bignum).sign << 30) \ + | ((bignum).alloc << 15) | ((bignum).used)); \ + } + +#define UNPACK_BIGNUM(objPtr, bignum) \ + if ((objPtr)->internalRep.twoPtrValue.ptr2 == INT2PTR(-1)) { \ + (bignum) = *((mp_int *) ((objPtr)->internalRep.twoPtrValue.ptr1)); \ + } else { \ + (bignum).dp = (objPtr)->internalRep.twoPtrValue.ptr1; \ + (bignum).sign = PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) >> 30; \ + (bignum).alloc = \ + (PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) >> 15) & 0x7FFF; \ + (bignum).used = PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) & 0x7FFF; \ } /* * Prototypes for functions defined later in this file: */ @@ -198,10 +209,14 @@ static int ParseBoolean(Tcl_Obj *objPtr); static int SetDoubleFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static int SetIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfDouble(Tcl_Obj *objPtr); static void UpdateStringOfInt(Tcl_Obj *objPtr); +#ifndef TCL_WIDE_INT_IS_LONG +static void UpdateStringOfWideInt(Tcl_Obj *objPtr); +static int SetWideIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); +#endif static void FreeBignum(Tcl_Obj *objPtr); static void DupBignum(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static void UpdateStringOfBignum(Tcl_Obj *objPtr); static int GetBignumFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int copy, mp_int *bignumValue); @@ -226,13 +241,20 @@ * means of functions that can be invoked by generic object code. See also * tclStringObj.c, tclListObj.c, tclByteCode.c for other type manager * implementations. */ -const Tcl_ObjType tclBooleanType = { +static const Tcl_ObjType oldBooleanType = { "boolean", /* name */ NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + NULL, /* updateStringProc */ + TclSetBooleanFromAny /* setFromAnyProc */ +}; +const Tcl_ObjType tclBooleanType = { + "booleanString", /* name */ + NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ TclSetBooleanFromAny /* setFromAnyProc */ }; const Tcl_ObjType tclDoubleType = { @@ -247,10 +269,19 @@ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ UpdateStringOfInt, /* updateStringProc */ SetIntFromAny /* setFromAnyProc */ }; +#ifndef TCL_WIDE_INT_IS_LONG +const Tcl_ObjType tclWideIntType = { + "wideInt", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + UpdateStringOfWideInt, /* updateStringProc */ + SetWideIntFromAny /* setFromAnyProc */ +}; +#endif const Tcl_ObjType tclBignumType = { "bignum", /* name */ FreeBignum, /* freeIntRepProc */ DupBignum, /* dupIntRepProc */ UpdateStringOfBignum, /* updateStringProc */ @@ -312,27 +343,27 @@ Command *cmdPtr; /* A cached Command pointer. */ Namespace *refNsPtr; /* Points to the namespace containing the * reference (not the namespace that contains * the referenced command). NULL if the name * is fully qualified.*/ - size_t refNsId; /* refNsPtr's unique namespace id. Used to + long refNsId; /* refNsPtr's unique namespace id. Used to * verify that refNsPtr is still valid (e.g., * it's possible that the cmd's containing * namespace was deleted and a new one created * at the same address). */ - size_t refNsCmdEpoch; /* Value of the referencing namespace's + int refNsCmdEpoch; /* Value of the referencing namespace's * cmdRefEpoch when the pointer was cached. * Before using the cached pointer, we check * if the namespace's epoch was incremented; * if so, this cached pointer is invalid. */ - size_t cmdEpoch; /* Value of the command's cmdEpoch when this + int cmdEpoch; /* Value of the command's cmdEpoch when this * pointer was cached. Before using the cached * pointer, we check if the cmd's epoch was * incremented; if so, the cmd was renamed, * deleted, hidden, or exposed, and so the * pointer is invalid. */ - size_t refCount; /* Reference count: 1 for each cmdName object + int refCount; /* Reference count: 1 for each cmdName object * that has a pointer to this ResolvedCmdName * structure as its internal rep. This * structure can be freed when refCount * becomes zero. */ } ResolvedCmdName; @@ -363,17 +394,26 @@ Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS); Tcl_MutexUnlock(&tableMutex); Tcl_RegisterObjType(&tclByteArrayType); Tcl_RegisterObjType(&tclDoubleType); + Tcl_RegisterObjType(&tclEndOffsetType); + Tcl_RegisterObjType(&tclIntType); Tcl_RegisterObjType(&tclStringType); Tcl_RegisterObjType(&tclListType); Tcl_RegisterObjType(&tclDictType); Tcl_RegisterObjType(&tclByteCodeType); + Tcl_RegisterObjType(&tclArraySearchType); Tcl_RegisterObjType(&tclCmdNameType); Tcl_RegisterObjType(&tclRegexpType); Tcl_RegisterObjType(&tclProcBodyType); + + /* For backward compatibility only ... */ + Tcl_RegisterObjType(&oldBooleanType); +#ifndef TCL_WIDE_INT_IS_LONG + Tcl_RegisterObjType(&tclWideIntType); +#endif #ifdef TCL_COMPILE_STATS Tcl_MutexLock(&tclObjMutex); tclObjsAlloced = 0; tclObjsFreed = 0; @@ -406,11 +446,11 @@ */ void TclFinalizeThreadObjects(void) { -#if TCL_THREADS && defined(TCL_MEM_DEBUG) +#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) Tcl_HashEntry *hPtr; Tcl_HashSearch hSearch; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); Tcl_HashTable *tablePtr = tsdPtr->objThreadMap; @@ -418,16 +458,16 @@ for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { ObjData *objData = Tcl_GetHashValue(hPtr); if (objData != NULL) { - Tcl_Free(objData); + ckfree(objData); } } Tcl_DeleteHashTable(tablePtr); - Tcl_Free(tablePtr); + ckfree(tablePtr); tsdPtr->objThreadMap = NULL; } #endif } @@ -499,11 +539,11 @@ */ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!tsdPtr->lineCLPtr) { - tsdPtr->lineCLPtr = Tcl_Alloc(sizeof(Tcl_HashTable)); + tsdPtr->lineCLPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(tsdPtr->lineCLPtr, TCL_ONE_WORD_KEYS); Tcl_CreateThreadExitHandler(TclThreadFinalizeContLines,NULL); } return tsdPtr; } @@ -534,11 +574,11 @@ { int newEntry; ThreadSpecificData *tsdPtr = TclGetContLineTable(); Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(tsdPtr->lineCLPtr, objPtr, &newEntry); - ContLineLoc *clLocPtr = Tcl_Alloc(sizeof(ContLineLoc) + num*sizeof(int)); + ContLineLoc *clLocPtr = (ContLineLoc *)ckalloc(TclOffset(ContLineLoc, loc) + (num + 1) *sizeof(int)); if (!newEntry) { /* * We're entering ContLineLoc data for the same value more than one * time. Taking care not to leak the old entry. @@ -558,11 +598,11 @@ * returning the stored entry would rebase them a second time, or * more, hosing the data. It is easier to simply replace, as we are * doing. */ - Tcl_Free(Tcl_GetHashValue(hPtr)); + ckfree(Tcl_GetHashValue(hPtr)); } clLocPtr->num = num; memcpy(&clLocPtr->loc, loc, num*sizeof(int)); clLocPtr->loc[num] = CLL_END; /* Sentinel */ @@ -594,12 +634,11 @@ TclContinuationsEnterDerived( Tcl_Obj *objPtr, int start, int *clNext) { - size_t length; - int end, num; + int length, end, num; int *wordCLLast = clNext; /* * We have to handle invisible continuations lines here as well, despite * the code we have in TclSubstTokens (TST) for that. Why ? Nesting. If @@ -622,11 +661,11 @@ /* * First compute the range of the word within the script. (Is there a * better way which doesn't shimmer?) */ - (void)TclGetStringFromObj(objPtr, &length); + TclGetStringFromObj(objPtr, &length); end = start + length; /* First char after the word */ /* * Then compute the table slice covering the range of the word. */ @@ -763,15 +802,15 @@ Tcl_HashEntry *hPtr; Tcl_HashSearch hSearch; for (hPtr = Tcl_FirstHashEntry(tsdPtr->lineCLPtr, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { - Tcl_Free(Tcl_GetHashValue(hPtr)); + ckfree(Tcl_GetHashValue(hPtr)); Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(tsdPtr->lineCLPtr); - Tcl_Free(tsdPtr->lineCLPtr); + ckfree(tsdPtr->lineCLPtr); tsdPtr->lineCLPtr = NULL; } /* *-------------------------------------------------------------- @@ -835,11 +874,11 @@ Tcl_Interp *interp, /* Interpreter used for error reporting. */ Tcl_Obj *objPtr) /* Points to the Tcl object onto which the * name of each registered type is appended as * a list element. */ { - register Tcl_HashEntry *hPtr; + Tcl_HashEntry *hPtr; Tcl_HashSearch search; int numElems; /* * Get the test for a valid list out of the way first. @@ -883,11 +922,11 @@ const Tcl_ObjType * Tcl_GetObjType( const char *typeName) /* Name of Tcl object type to look up. */ { - register Tcl_HashEntry *hPtr; + Tcl_HashEntry *hPtr; const Tcl_ObjType *typePtr = NULL; Tcl_MutexLock(&tableMutex); hPtr = Tcl_FindHashEntry(&typeTable, typeName); if (hPtr != NULL) { @@ -964,20 +1003,20 @@ void TclDbDumpActiveObjects( FILE *outFile) { -#if TCL_THREADS && defined(TCL_MEM_DEBUG) +#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) Tcl_HashSearch hSearch; Tcl_HashEntry *hPtr; Tcl_HashTable *tablePtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); tablePtr = tsdPtr->objThreadMap; if (tablePtr != NULL) { - fprintf(outFile, "total objects: %" TCL_Z_MODIFIER "u\n", tablePtr->numEntries); + fprintf(outFile, "total objects: %d\n", tablePtr->numEntries); for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { ObjData *objData = Tcl_GetHashValue(hPtr); if (objData != NULL) { @@ -1013,21 +1052,22 @@ */ #ifdef TCL_MEM_DEBUG void TclDbInitNewObj( - register Tcl_Obj *objPtr, - register const char *file, /* The name of the source file calling this + Tcl_Obj *objPtr, + const char *file, /* The name of the source file calling this * function; used for debugging. */ - register 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->bytes = tclEmptyStringRep; + objPtr->length = 0; objPtr->typePtr = NULL; - TclInitStringRep(objPtr, NULL, 0); -#if TCL_THREADS +#ifdef TCL_THREADS /* * Add entry to a thread local map used to check if a Tcl_Obj was * allocated by the currently executing thread. */ @@ -1037,11 +1077,11 @@ int isNew; ObjData *objData; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (tsdPtr->objThreadMap == NULL) { - tsdPtr->objThreadMap = Tcl_Alloc(sizeof(Tcl_HashTable)); + tsdPtr->objThreadMap = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(tsdPtr->objThreadMap, TCL_ONE_WORD_KEYS); } tablePtr = tsdPtr->objThreadMap; hPtr = Tcl_CreateHashEntry(tablePtr, objPtr, &isNew); if (!isNew) { @@ -1050,11 +1090,11 @@ /* * Record the debugging information. */ - objData = Tcl_Alloc(sizeof(ObjData)); + objData = (ObjData *)ckalloc(sizeof(ObjData)); objData->objPtr = objPtr; objData->file = file; objData->line = line; Tcl_SetHashValue(hPtr, objData); } @@ -1100,11 +1140,11 @@ #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_NewObj(void) { - register Tcl_Obj *objPtr; + Tcl_Obj *objPtr; /* * Use the macro defined in tclInt.h - it will use the correct allocator. */ @@ -1142,16 +1182,16 @@ #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewObj( - register 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. */ - register int line) /* Line number in the source file; used for + int line) /* Line number in the source file; used for * debugging. */ { - register Tcl_Obj *objPtr; + Tcl_Obj *objPtr; /* * Use the macro defined in tclInt.h - it will use the correct allocator. */ @@ -1175,11 +1215,11 @@ *---------------------------------------------------------------------- * * TclAllocateFreeObjects -- * * Function to allocate a number of free Tcl_Objs. This is done using a - * single Tcl_Alloc to reduce the overhead for Tcl_Obj allocation. + * single ckalloc to reduce the overhead for Tcl_Obj allocation. * * Assumes mutex is held. * * Results: * None. @@ -1197,23 +1237,23 @@ void TclAllocateFreeObjects(void) { size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * sizeof(Tcl_Obj)); char *basePtr; - register Tcl_Obj *prevPtr, *objPtr; - register int i; + Tcl_Obj *prevPtr, *objPtr; + int i; /* * This has been noted by Purify to be a potential leak. The problem is * that Tcl, when not TCL_MEM_DEBUG compiled, keeps around all allocated * Tcl_Obj's, pointed to by tclFreeObjList, when freed instead of actually - * freeing the memory. TclFinalizeObjects() does not Tcl_Free() this memory, + * freeing the memory. TclFinalizeObjects() does not ckfree() this memory, * but leaves it to Tcl's memory subsystem finalization to release it. * Purify apparently can't figure that out, and fires a false alarm. */ - basePtr = Tcl_Alloc(bytesToAlloc); + basePtr = (char *)ckalloc(bytesToAlloc); prevPtr = NULL; objPtr = (Tcl_Obj *) basePtr; for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) { objPtr->internalRep.twoPtrValue.ptr1 = prevPtr; @@ -1249,21 +1289,21 @@ */ #ifdef TCL_MEM_DEBUG void TclFreeObj( - register Tcl_Obj *objPtr) /* The object to be freed. */ + Tcl_Obj *objPtr) /* The object to be freed. */ { - register const Tcl_ObjType *typePtr = objPtr->typePtr; + const Tcl_ObjType *typePtr = objPtr->typePtr; /* * This macro declares a variable, so must come here... */ ObjInitDeletionContext(context); -#if TCL_THREADS +# ifdef TCL_THREADS /* * Check to make sure that the Tcl_Obj was allocated by the current * thread. Don't do this check when shutting down since thread local * storage can be finalized before the last Tcl_Obj is freed. */ @@ -1284,11 +1324,11 @@ */ ObjData *objData = Tcl_GetHashValue(hPtr); if (objData != NULL) { - Tcl_Free(objData); + ckfree(objData); } Tcl_DeleteHashEntry(hPtr); } } @@ -1298,28 +1338,28 @@ * Check for a double free of the same value. This is slightly tricky * because it is customary to free a Tcl_Obj when its refcount falls * either from 1 to 0, or from 0 to -1. Falling from -1 to -2, though, * and so on, is always a sign of a botch in the caller. */ - if (objPtr->refCount == (size_t)-2) { + if (objPtr->refCount < -1) { Tcl_Panic("Reference count for %p was negative", objPtr); } /* * Now, in case we just approved drop from 1 to 0 as acceptable, make * sure we do not accept a second free when falling from 0 to -1. * Skip that possibility so any double free will trigger the panic. */ - objPtr->refCount = TCL_AUTO_LENGTH; + objPtr->refCount = -1; /* * Invalidate the string rep first so we can use the bytes value for our * pointer chain, and signal an obj deletion (as opposed to shimmering) - * with 'length == TCL_AUTO_LENGTH'. + * with 'length == -1'. */ TclInvalidateStringRep(objPtr); - objPtr->length = TCL_AUTO_LENGTH; + objPtr->length = -1; if (ObjDeletePending(context)) { PushObjToDelete(context, objPtr); } else { TCL_DTRACE_OBJ_FREE(objPtr); @@ -1328,11 +1368,11 @@ typePtr->freeIntRepProc(objPtr); ObjDeletionUnlock(context); } Tcl_MutexLock(&tclObjMutex); - Tcl_Free(objPtr); + ckfree(objPtr); Tcl_MutexUnlock(&tclObjMutex); TclIncrObjsFreed(); ObjDeletionLock(context); while (ObjOnStack(context)) { Tcl_Obj *objToFree; @@ -1340,11 +1380,11 @@ PopObjToDelete(context, objToFree); TCL_DTRACE_OBJ_FREE(objToFree); TclFreeIntRep(objToFree); Tcl_MutexLock(&tclObjMutex); - Tcl_Free(objToFree); + ckfree(objToFree); Tcl_MutexUnlock(&tclObjMutex); TclIncrObjsFreed(); } ObjDeletionUnlock(context); } @@ -1364,30 +1404,30 @@ Tcl_HashEntry *hPtr; if (tsdPtr->lineCLPtr) { hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); if (hPtr) { - Tcl_Free(Tcl_GetHashValue(hPtr)); + ckfree(Tcl_GetHashValue(hPtr)); Tcl_DeleteHashEntry(hPtr); } } } } #else /* TCL_MEM_DEBUG */ void TclFreeObj( - register Tcl_Obj *objPtr) /* The object to be freed. */ + Tcl_Obj *objPtr) /* The object to be freed. */ { /* * Invalidate the string rep first so we can use the bytes value for our * pointer chain, and signal an obj deletion (as opposed to shimmering) * with 'length == -1'. */ TclInvalidateStringRep(objPtr); - objPtr->length = TCL_AUTO_LENGTH; + objPtr->length = -1; if (!objPtr->typePtr || !objPtr->typePtr->freeIntRepProc) { /* * objPtr can be freed safely, as it will not attempt to free any * other objects: it will not cause recursive calls to this function. @@ -1455,11 +1495,11 @@ Tcl_HashEntry *hPtr; if (tsdPtr->lineCLPtr) { hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); if (hPtr) { - Tcl_Free(Tcl_GetHashValue(hPtr)); + ckfree(Tcl_GetHashValue(hPtr)); Tcl_DeleteHashEntry(hPtr); } } } } @@ -1485,11 +1525,11 @@ int TclObjBeingDeleted( Tcl_Obj *objPtr) { - return (objPtr->length == TCL_AUTO_LENGTH); + return (objPtr->length == -1); } /* *---------------------------------------------------------------------- * @@ -1583,37 +1623,39 @@ *---------------------------------------------------------------------- */ char * Tcl_GetString( - register Tcl_Obj *objPtr) /* Object whose string rep byte pointer should + Tcl_Obj *objPtr) /* Object whose string rep byte pointer should * be returned. */ { - if (objPtr->bytes == NULL) { - /* - * Note we do not check for objPtr->typePtr == NULL. An invariant - * of a properly maintained Tcl_Obj is that at least one of - * objPtr->bytes and objPtr->typePtr must not be NULL. If broken - * extensions fail to maintain that invariant, we can crash here. - */ - - if (objPtr->typePtr->updateStringProc == NULL) { - /* - * Those Tcl_ObjTypes which choose not to define an - * updateStringProc must be written in such a way that - * (objPtr->bytes) never becomes NULL. - */ - Tcl_Panic("UpdateStringProc should not be invoked for type %s", - objPtr->typePtr->name); - } - objPtr->typePtr->updateStringProc(objPtr); - if (objPtr->bytes == NULL || objPtr->length == TCL_AUTO_LENGTH - || objPtr->bytes[objPtr->length] != '\0') { - Tcl_Panic("UpdateStringProc for type '%s' " - "failed to create a valid string rep", - objPtr->typePtr->name); - } + if (objPtr->bytes != NULL) { + return objPtr->bytes; + } + + /* + * Note we do not check for objPtr->typePtr == NULL. An invariant of + * a properly maintained Tcl_Obj is that at least one of objPtr->bytes + * and objPtr->typePtr must not be NULL. If broken extensions fail to + * maintain that invariant, we can crash here. + */ + + if (objPtr->typePtr->updateStringProc == NULL) { + /* + * Those Tcl_ObjTypes which choose not to define an updateStringProc + * must be written in such a way that (objPtr->bytes) never becomes + * NULL. This panic was added in Tcl 8.1. + */ + + Tcl_Panic("UpdateStringProc should not be invoked for type %s", + objPtr->typePtr->name); + } + objPtr->typePtr->updateStringProc(objPtr); + if (objPtr->bytes == NULL || objPtr->length < 0 + || objPtr->bytes[objPtr->length] != '\0') { + Tcl_Panic("UpdateStringProc for type '%s' " + "failed to create a valid string rep", objPtr->typePtr->name); } return objPtr->bytes; } /* @@ -1639,125 +1681,21 @@ *---------------------------------------------------------------------- */ char * Tcl_GetStringFromObj( - register Tcl_Obj *objPtr, /* Object whose string rep byte pointer should + Tcl_Obj *objPtr, /* Object whose string rep byte pointer should * be returned. */ - register int *lengthPtr) /* If non-NULL, the location where the string + int *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) { - /* - * Note we do not check for objPtr->typePtr == NULL. An invariant - * of a properly maintained Tcl_Obj is that at least one of - * objPtr->bytes and objPtr->typePtr must not be NULL. If broken - * extensions fail to maintain that invariant, we can crash here. - */ - - if (objPtr->typePtr->updateStringProc == NULL) { - /* - * Those Tcl_ObjTypes which choose not to define an - * updateStringProc must be written in such a way that - * (objPtr->bytes) never becomes NULL. - */ - Tcl_Panic("UpdateStringProc should not be invoked for type %s", - objPtr->typePtr->name); - } - objPtr->typePtr->updateStringProc(objPtr); - if (objPtr->bytes == NULL || objPtr->length == TCL_AUTO_LENGTH - || objPtr->bytes[objPtr->length] != '\0') { - Tcl_Panic("UpdateStringProc for type '%s' " - "failed to create a valid string rep", - objPtr->typePtr->name); - } - } + (void) TclGetString(objPtr); + if (lengthPtr != NULL) { - *lengthPtr = (objPtr->length < INT_MAX)? objPtr->length: INT_MAX; - } - return objPtr->bytes; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_InitStringRep -- - * - * This function is called in several configurations to provide all - * the tools needed to set an object's string representation. The - * function is determined by the arguments. - * - * (objPtr->bytes != NULL && bytes != NULL) || (numBytes == -1) - * Invalid call -- panic! - * - * objPtr->bytes == NULL && bytes == NULL && numBytes != -1 - * Allocation only - allocate space for (numBytes+1) chars. - * store in objPtr->bytes and return. Also sets - * objPtr->length to 0 and objPtr->bytes[0] to NUL. - * - * objPtr->bytes == NULL && bytes != NULL && numBytes != -1 - * Allocate and copy. bytes is assumed to point to chars to - * copy into the string rep. objPtr->length = numBytes. Allocate - * array of (numBytes + 1) chars. store in objPtr->bytes. Copy - * numBytes chars from bytes to objPtr->bytes; Set - * objPtr->bytes[numBytes] to NUL and return objPtr->bytes. - * Caller must guarantee there are numBytes chars at bytes to - * be copied. - * - * objPtr->bytes != NULL && bytes == NULL && numBytes != -1 - * Truncate. Set objPtr->length to numBytes and - * objPr->bytes[numBytes] to NUL. Caller has to guarantee - * that a prior allocating call allocated enough bytes for - * this to be valid. Return objPtr->bytes. - * - * Caller is expected to ascertain that the bytes copied into - * the string rep make up complete valid UTF-8 characters. - * - * Results: - * A pointer to the string rep of objPtr. - * - * Side effects: - * As described above. - * - *---------------------------------------------------------------------- - */ - -char * -Tcl_InitStringRep( - Tcl_Obj *objPtr, /* Object whose string rep is to be set */ - const char *bytes, - size_t numBytes) -{ - assert(objPtr->bytes == NULL || bytes == NULL); - - /* Allocate */ - if (objPtr->bytes == NULL) { - /* Allocate only as empty - extend later if bytes copied */ - objPtr->length = 0; - if (numBytes) { - objPtr->bytes = Tcl_AttemptAlloc(numBytes + 1); - if (objPtr->bytes == NULL) { - return NULL; - } - if (bytes) { - /* Copy */ - memcpy(objPtr->bytes, bytes, numBytes); - objPtr->length = numBytes; - } - } else { - TclInitStringRep(objPtr, NULL, 0); - } - } else { - /* objPtr->bytes != NULL bytes == NULL - Truncate */ - objPtr->bytes = Tcl_Realloc(objPtr->bytes, numBytes + 1); - objPtr->length = numBytes; - } - - /* Terminate */ - objPtr->bytes[objPtr->length] = '\0'; - + *lengthPtr = objPtr->length; + } return objPtr->bytes; } /* *---------------------------------------------------------------------- @@ -1777,125 +1715,152 @@ *---------------------------------------------------------------------- */ void Tcl_InvalidateStringRep( - register Tcl_Obj *objPtr) /* Object whose string rep byte pointer should + Tcl_Obj *objPtr) /* Object whose string rep byte pointer should * be freed. */ { TclInvalidateStringRep(objPtr); } /* *---------------------------------------------------------------------- * - * Tcl_HasStringRep -- - * - * This function reports whether object has a string representation. - * - * Results: - * Boolean. - *---------------------------------------------------------------------- - */ - -int -Tcl_HasStringRep( - Tcl_Obj *objPtr) /* Object to test */ -{ - return TclHasStringRep(objPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_StoreIntRep -- - * - * This function is called to set the object's internal - * representation to match a particular type. - * - * It is the caller's responsibility to guarantee that - * the value of the submitted IntRep is in agreement with - * the value of any existing string rep. - * - * Results: - * None. - * - * Side effects: - * Calls the freeIntRepProc of the current Tcl_ObjType, if any. - * Sets the internalRep and typePtr fields to the submitted values. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_StoreIntRep( - Tcl_Obj *objPtr, /* Object whose internal rep should be set. */ - const Tcl_ObjType *typePtr, /* New type for the object */ - const Tcl_ObjIntRep *irPtr) /* New IntRep for the object */ -{ - /* Clear out any existing IntRep ( "shimmer" ) */ - TclFreeIntRep(objPtr); - - /* When irPtr == NULL, just leave objPtr with no IntRep for typePtr */ - if (irPtr) { - /* Copy the new IntRep into place */ - objPtr->internalRep = *irPtr; - - /* Set the type to match */ - objPtr->typePtr = typePtr; - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_FetchIntRep -- - * - * This function is called to retrieve the object's internal - * representation matching a requested type, if any. - * - * Results: - * A read-only pointer to the associated Tcl_ObjIntRep, or - * NULL if no such internal representation exists. - * - * Side effects: - * Calls the freeIntRepProc of the current Tcl_ObjType, if any. - * Sets the internalRep and typePtr fields to the submitted values. - * - *---------------------------------------------------------------------- - */ - -Tcl_ObjIntRep * -Tcl_FetchIntRep( - Tcl_Obj *objPtr, /* Object to fetch from. */ - const Tcl_ObjType *typePtr) /* Requested type */ -{ - return TclFetchIntRep(objPtr, typePtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_FreeIntRep -- - * - * This function is called to free an object's internal representation. - * - * Results: - * None. - * - * Side effects: - * Calls the freeIntRepProc of the current Tcl_ObjType, if any. - * Sets typePtr field to NULL. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_FreeIntRep( - Tcl_Obj *objPtr) /* Object whose internal rep should be freed. */ -{ - TclFreeIntRep(objPtr); + * Tcl_NewBooleanObj -- + * + * This function is normally called when not debugging: i.e., when + * TCL_MEM_DEBUG is not defined. It creates a new Tcl_Obj and + * initializes it from the argument boolean value. A nonzero "boolValue" + * is coerced to 1. + * + * When TCL_MEM_DEBUG is defined, this function just returns the result + * of calling the debugging version Tcl_DbNewBooleanObj. + * + * Results: + * The newly created object is returned. This object will have an invalid + * string representation. The returned object has ref count 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_NewBooleanObj +#ifdef TCL_MEM_DEBUG + +Tcl_Obj * +Tcl_NewBooleanObj( + int boolValue) /* Boolean used to initialize new object. */ +{ + return Tcl_DbNewBooleanObj(boolValue, "unknown", 0); +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_NewBooleanObj( + int boolValue) /* Boolean used to initialize new object. */ +{ + Tcl_Obj *objPtr; + + TclNewBooleanObj(objPtr, boolValue); + return objPtr; +} +#endif /* TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_DbNewBooleanObj -- + * + * This function is normally called when debugging: i.e., when + * TCL_MEM_DEBUG is defined. It creates new boolean objects. It is the + * same as the Tcl_NewBooleanObj function above except that it calls + * Tcl_DbCkalloc directly with the file name and line number from its + * caller. This simplifies debugging since then the [memory active] + * command will report the correct file name and line number when + * reporting objects that haven't been freed. + * + * When TCL_MEM_DEBUG is not defined, this function just returns the + * result of calling Tcl_NewBooleanObj. + * + * Results: + * The newly created object is returned. This object will have an invalid + * string representation. The returned object has ref count 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_DbNewBooleanObj +#ifdef TCL_MEM_DEBUG + +Tcl_Obj * +Tcl_DbNewBooleanObj( + int boolValue, /* Boolean used to initialize new object. */ + const char *file, /* The name of the source file calling this + * function; used for debugging. */ + int line) /* Line number in the source file; used for + * debugging. */ +{ + Tcl_Obj *objPtr; + + TclDbNewObj(objPtr, file, line); + objPtr->bytes = NULL; + + objPtr->internalRep.longValue = (boolValue? 1 : 0); + objPtr->typePtr = &tclIntType; + return objPtr; +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_DbNewBooleanObj( + int boolValue, /* Boolean used to initialize new object. */ + const char *file, /* The name of the source file calling this + * function; used for debugging. */ + int line) /* Line number in the source file; used for + * debugging. */ +{ + return Tcl_NewBooleanObj(boolValue); +} +#endif /* TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetBooleanObj -- + * + * Modify an object to be a boolean object and to have the specified + * boolean value. A nonzero "boolValue" is coerced to 1. + * + * Results: + * None. + * + * Side effects: + * The object's old string rep, if any, is freed. Also, any old internal + * rep is freed. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_SetBooleanObj +void +Tcl_SetBooleanObj( + Tcl_Obj *objPtr, /* Object whose internal rep to init. */ + int boolValue) /* Boolean used to set object's value. */ +{ + if (Tcl_IsShared(objPtr)) { + Tcl_Panic("%s called with shared object", "Tcl_SetBooleanObj"); + } + + TclSetBooleanObj(objPtr, boolValue); } /* *---------------------------------------------------------------------- * @@ -1916,16 +1881,20 @@ */ int Tcl_GetBooleanFromObj( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr, /* The object from which to get boolean. */ - register int *boolPtr) /* Place to store resulting boolean. */ + Tcl_Obj *objPtr, /* The object from which to get boolean. */ + int *boolPtr) /* Place to store resulting boolean. */ { do { - if (objPtr->typePtr == &tclIntType || objPtr->typePtr == &tclBooleanType) { - *boolPtr = (objPtr->internalRep.wideValue != 0); + if (objPtr->typePtr == &tclIntType) { + *boolPtr = (objPtr->internalRep.longValue != 0); + return TCL_OK; + } + if (objPtr->typePtr == &tclBooleanType) { + *boolPtr = (int) objPtr->internalRep.longValue; return TCL_OK; } if (objPtr->typePtr == &tclDoubleType) { /* * Caution: Don't be tempted to check directly for the "double" @@ -1945,10 +1914,16 @@ } if (objPtr->typePtr == &tclBignumType) { *boolPtr = 1; return TCL_OK; } +#ifndef TCL_WIDE_INT_IS_LONG + if (objPtr->typePtr == &tclWideIntType) { + *boolPtr = (objPtr->internalRep.wideValue != 0); + return TCL_OK; + } +#endif } while ((ParseBoolean(objPtr) == TCL_OK) || (TCL_OK == TclParseNumber(interp, objPtr, "boolean value", NULL,-1,NULL,0))); return TCL_ERROR; } @@ -1965,37 +1940,44 @@ * conversion, an error message is left in the interpreter's result * unless "interp" is NULL. * * Side effects: * If no error occurs, an integer 1 or 0 is stored as "objPtr"s internal - * representation and the type of "objPtr" is set to boolean or int. + * representation and the type of "objPtr" is set to boolean. * *---------------------------------------------------------------------- */ int TclSetBooleanFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - register 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. */ if (objPtr->bytes == NULL) { if (objPtr->typePtr == &tclIntType) { - if ((Tcl_WideUInt)objPtr->internalRep.wideValue < 2) { + switch (objPtr->internalRep.longValue) { + case 0L: case 1L: return TCL_OK; } goto badBoolean; } if (objPtr->typePtr == &tclBignumType) { goto badBoolean; } + +#ifndef TCL_WIDE_INT_IS_LONG + if (objPtr->typePtr == &tclWideIntType) { + goto badBoolean; + } +#endif if (objPtr->typePtr == &tclDoubleType) { goto badBoolean; } } @@ -2004,11 +1986,11 @@ return TCL_OK; } badBoolean: if (interp != NULL) { - size_t length; + int length; const char *str = TclGetStringFromObj(objPtr, &length); Tcl_Obj *msg; TclNewLiteralStringObj(msg, "expected boolean value but got \""); Tcl_AppendLimitedToObj(msg, str, length, 50, ""); @@ -2019,15 +2001,14 @@ return TCL_ERROR; } static int ParseBoolean( - register Tcl_Obj *objPtr) /* The object to parse/convert. */ + Tcl_Obj *objPtr) /* The object to parse/convert. */ { - int newBool; + int i, length, newBool; char lowerCase[6]; - size_t i, length; const char *str = TclGetStringFromObj(objPtr, &length); if ((length == 0) || (length > 5)) { /* * Longest valid boolean string rep. is "false". @@ -2123,17 +2104,17 @@ * Tcl_GetStringFromObj, to use that old internalRep. */ goodBoolean: TclFreeIntRep(objPtr); - objPtr->internalRep.wideValue = newBool; + objPtr->internalRep.longValue = newBool; objPtr->typePtr = &tclBooleanType; return TCL_OK; numericBoolean: TclFreeIntRep(objPtr); - objPtr->internalRep.wideValue = newBool; + objPtr->internalRep.longValue = newBool; objPtr->typePtr = &tclIntType; return TCL_OK; } /* @@ -2161,22 +2142,22 @@ #ifdef TCL_MEM_DEBUG #undef Tcl_NewDoubleObj Tcl_Obj * Tcl_NewDoubleObj( - register 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( - register double dblValue) /* Double used to initialize the object. */ + double dblValue) /* Double used to initialize the object. */ { - register Tcl_Obj *objPtr; + Tcl_Obj *objPtr; TclNewDoubleObj(objPtr, dblValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ @@ -2209,20 +2190,19 @@ #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewDoubleObj( - register 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. */ { - register Tcl_Obj *objPtr; + Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); - /* Optimized TclInvalidateStringRep() */ objPtr->bytes = NULL; objPtr->internalRep.doubleValue = dblValue; objPtr->typePtr = &tclDoubleType; return objPtr; @@ -2230,11 +2210,11 @@ #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_DbNewDoubleObj( - register 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. */ { @@ -2260,12 +2240,12 @@ *---------------------------------------------------------------------- */ void Tcl_SetDoubleObj( - register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ - register double dblValue) /* Double used to set the object's value. */ + Tcl_Obj *objPtr, /* Object whose internal rep to init. */ + double dblValue) /* Double used to set the object's value. */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetDoubleObj"); } @@ -2293,12 +2273,12 @@ */ int Tcl_GetDoubleFromObj( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr, /* The object from which to get a double. */ - register double *dblPtr) /* Place to store resulting double. */ + Tcl_Obj *objPtr, /* The object from which to get a double. */ + double *dblPtr) /* Place to store resulting double. */ { do { if (objPtr->typePtr == &tclDoubleType) { if (TclIsNaN(objPtr->internalRep.doubleValue)) { if (interp != NULL) { @@ -2311,20 +2291,26 @@ } *dblPtr = (double) objPtr->internalRep.doubleValue; return TCL_OK; } if (objPtr->typePtr == &tclIntType) { - *dblPtr = (double) objPtr->internalRep.wideValue; + *dblPtr = objPtr->internalRep.longValue; return TCL_OK; } if (objPtr->typePtr == &tclBignumType) { mp_int big; - TclUnpackBignum(objPtr, big); + UNPACK_BIGNUM(objPtr, big); *dblPtr = TclBignumToDouble(&big); return TCL_OK; } +#ifndef TCL_WIDE_INT_IS_LONG + if (objPtr->typePtr == &tclWideIntType) { + *dblPtr = (double) objPtr->internalRep.wideValue; + return TCL_OK; + } +#endif } while (SetDoubleFromAny(interp, objPtr) == TCL_OK); return TCL_ERROR; } /* @@ -2348,11 +2334,11 @@ */ static int SetDoubleFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr) /* The object to convert. */ + Tcl_Obj *objPtr) /* The object to convert. */ { return TclParseNumber(interp, objPtr, "floating-point number", NULL, -1, NULL, 0); } @@ -2360,11 +2346,12 @@ *---------------------------------------------------------------------- * * UpdateStringOfDouble -- * * Update the string representation for a double-precision floating point - * object. Note: This function does not free an + * object. This must obey the current tcl_precision value for + * double-to-string conversions. Note: This function does not free an * existing old string rep so storage will be lost if this has not * already been done. * * Results: * None. @@ -2376,18 +2363,105 @@ *---------------------------------------------------------------------- */ static void UpdateStringOfDouble( - register Tcl_Obj *objPtr) /* Double obj with string rep to update. */ -{ - char *dst = Tcl_InitStringRep(objPtr, NULL, TCL_DOUBLE_SPACE); - - TclOOM(dst, TCL_DOUBLE_SPACE + 1); - - Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, dst); - (void) Tcl_InitStringRep(objPtr, NULL, strlen(dst)); + Tcl_Obj *objPtr) /* Double obj with string rep to update. */ +{ + char buffer[TCL_DOUBLE_SPACE]; + int len; + + Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, buffer); + len = strlen(buffer); + + objPtr->bytes = (char *)ckalloc(len + 1); + memcpy(objPtr->bytes, buffer, len + 1); + objPtr->length = len; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_NewIntObj -- + * + * If a client is compiled with TCL_MEM_DEBUG defined, calls to + * Tcl_NewIntObj to create a new integer object end up calling the + * debugging function Tcl_DbNewLongObj instead. + * + * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, + * calls to Tcl_NewIntObj result in a call to one of the two + * Tcl_NewIntObj implementations below. We provide two implementations so + * that the Tcl core can be compiled to do memory debugging of the core + * even if a client does not request it for itself. + * + * Integer and long integer objects share the same "integer" type + * implementation. We store all integers as longs and Tcl_GetIntFromObj + * checks whether the current value of the long can be represented by an + * int. + * + * Results: + * The newly created object is returned. This object will have an invalid + * string representation. The returned object has ref count 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_NewIntObj +#ifdef TCL_MEM_DEBUG + +Tcl_Obj * +Tcl_NewIntObj( + int intValue) /* Int used to initialize the new object. */ +{ + return Tcl_DbNewLongObj((long)intValue, "unknown", 0); +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_NewIntObj( + int intValue) /* Int used to initialize the new object. */ +{ + Tcl_Obj *objPtr; + + TclNewIntObj(objPtr, intValue); + return objPtr; +} +#endif /* if TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetIntObj -- + * + * Modify an object to be an integer and to have the specified integer + * value. + * + * Results: + * None. + * + * Side effects: + * The object's old string rep, if any, is freed. Also, any old internal + * rep is freed. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_SetIntObj +void +Tcl_SetIntObj( + Tcl_Obj *objPtr, /* Object whose internal rep to init. */ + int intValue) /* Integer used to set object's value. */ +{ + if (Tcl_IsShared(objPtr)) { + Tcl_Panic("%s called with shared object", "Tcl_SetIntObj"); + } + + TclSetIntObj(objPtr, intValue); } /* *---------------------------------------------------------------------- * @@ -2418,22 +2492,22 @@ */ int Tcl_GetIntFromObj( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr, /* The object from which to get a int. */ - register int *intPtr) /* Place to store resulting int. */ + 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; if (TclGetLongFromObj(interp, objPtr, &l) != TCL_OK) { return TCL_ERROR; } - if ((ULONG_MAX > UINT_MAX) && ((l > UINT_MAX) || (l < INT_MIN))) { + if ((ULONG_MAX > UINT_MAX) && ((l > UINT_MAX) || (l < -(long)UINT_MAX))) { if (interp != NULL) { const char *s = "integer value too large to represent as non-long integer"; Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); @@ -2464,12 +2538,13 @@ static int SetIntFromAny( Tcl_Interp *interp, /* Tcl interpreter */ Tcl_Obj *objPtr) /* Pointer to the object to convert */ { - Tcl_WideInt w; - return Tcl_GetWideIntFromObj(interp, objPtr, &w); + long l; + + return TclGetLongFromObj(interp, objPtr, &l); } /* *---------------------------------------------------------------------- * @@ -2489,17 +2564,20 @@ *---------------------------------------------------------------------- */ static void UpdateStringOfInt( - register 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); + char buffer[TCL_INTEGER_SPACE]; + int len; - TclOOM(dst, TCL_INTEGER_SPACE + 1); - (void) Tcl_InitStringRep(objPtr, NULL, - TclFormatInt(dst, objPtr->internalRep.wideValue)); + len = TclFormatInt(buffer, objPtr->internalRep.longValue); + + objPtr->bytes = (char *)ckalloc(len + 1); + memcpy(objPtr->bytes, buffer, len + 1); + objPtr->length = len; } /* *---------------------------------------------------------------------- * @@ -2528,36 +2606,34 @@ * None. * *---------------------------------------------------------------------- */ -#ifndef TCL_NO_DEPRECATED -#undef Tcl_NewLongObj #ifdef TCL_MEM_DEBUG +#undef Tcl_NewLongObj Tcl_Obj * Tcl_NewLongObj( - register long longValue) /* Long integer used to initialize the + long longValue) /* Long integer used to initialize the * new object. */ { - return Tcl_DbNewWideIntObj(longValue, "unknown", 0); + return Tcl_DbNewLongObj(longValue, "unknown", 0); } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_NewLongObj( - register long longValue) /* Long integer used to initialize the + long longValue) /* Long integer used to initialize the * new object. */ { - register Tcl_Obj *objPtr; + Tcl_Obj *objPtr; - TclNewIntObj(objPtr, longValue); + TclNewLongObj(objPtr, longValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ -#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- * * Tcl_DbNewLongObj -- @@ -2587,49 +2663,76 @@ * Allocates memory. * *---------------------------------------------------------------------- */ -#ifndef TCL_NO_DEPRECATED -#undef Tcl_DbNewLongObj #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewLongObj( - register long longValue, /* Long integer used to initialize the new + long longValue, /* Long 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. */ { - register Tcl_Obj *objPtr; + Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); - /* Optimized TclInvalidateStringRep */ objPtr->bytes = NULL; - objPtr->internalRep.wideValue = longValue; + objPtr->internalRep.longValue = longValue; objPtr->typePtr = &tclIntType; return objPtr; } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_DbNewLongObj( - register long longValue, /* Long integer used to initialize the new + long longValue, /* Long 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. */ { - return Tcl_NewWideIntObj(longValue); + return Tcl_NewLongObj(longValue); } #endif /* TCL_MEM_DEBUG */ -#endif /* TCL_NO_DEPRECATED */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetLongObj -- + * + * Modify an object to be an integer object and to have the specified + * long integer value. + * + * Results: + * None. + * + * Side effects: + * The object's old string rep, if any, is freed. Also, any old internal + * rep is freed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetLongObj( + Tcl_Obj *objPtr, /* Object whose internal rep to init. */ + long longValue) /* Long integer used to initialize the + * object's value. */ +{ + if (Tcl_IsShared(objPtr)) { + Tcl_Panic("%s called with shared object", "Tcl_SetLongObj"); + } + + TclSetLongObj(objPtr, longValue); +} /* *---------------------------------------------------------------------- * * Tcl_GetLongFromObj -- @@ -2651,34 +2754,33 @@ */ int Tcl_GetLongFromObj( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr, /* The object from which to get a long. */ - register long *longPtr) /* Place to store resulting long. */ + Tcl_Obj *objPtr, /* The object from which to get a long. */ + long *longPtr) /* Place to store resulting long. */ { do { -#ifdef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclIntType) { - *longPtr = objPtr->internalRep.wideValue; - return TCL_OK; - } -#else - if (objPtr->typePtr == &tclIntType) { - /* - * We return any integer in the range LONG_MIN to ULONG_MAX + if (objPtr->typePtr == &tclIntType) { + *longPtr = objPtr->internalRep.longValue; + return TCL_OK; + } +#ifndef TCL_WIDE_INT_IS_LONG + if (objPtr->typePtr == &tclWideIntType) { + /* + * We return any integer in the range -ULONG_MAX to ULONG_MAX * converted to a long, ignoring overflow. The rule preserves * existing semantics for conversion of integers on input, but * avoids inadvertent demotion of wide integers to 32-bit ones in * the internal rep. */ Tcl_WideInt w = objPtr->internalRep.wideValue; - if (w >= (Tcl_WideInt)(LONG_MIN) + if (w >= -(Tcl_WideInt)(ULONG_MAX) && w <= (Tcl_WideInt)(ULONG_MAX)) { - *longPtr = (long) w; + *longPtr = Tcl_WideAsLong(w); return TCL_OK; } goto tooLarge; } #endif @@ -2698,28 +2800,29 @@ * long range get auto-narrowed to tclIntType, while all the * values in the unsigned long range will fit in a long. */ mp_int big; - unsigned long scratch, value = 0, numBytes = sizeof(unsigned long); - unsigned char *bytes = (unsigned char *) &scratch; - TclUnpackBignum(objPtr, big); - if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) { - while (numBytes-- > 0) { + UNPACK_BIGNUM(objPtr, big); + if ((size_t) big.used <= (CHAR_BIT * sizeof(long) + MP_DIGIT_BIT - 1) + / MP_DIGIT_BIT) { + unsigned long value = 0; + size_t numBytes; + long scratch; + unsigned char *bytes = (unsigned char *) &scratch; + + if (mp_to_ubin(&big, bytes, sizeof(long), &numBytes) == MP_OKAY) { + while (numBytes-- > 0) { value = (value << CHAR_BIT) | *bytes++; - } - if (big.sign) { - if (value <= 1 + (unsigned long)LONG_MAX) { + } + if (big.sign) { *longPtr = - (long) value; - return TCL_OK; + } else { + *longPtr = (long) value; } - } else { - if (value <= (unsigned long)ULONG_MAX) { - *longPtr = (long) value; - return TCL_OK; - } + return TCL_OK; } } #ifndef TCL_WIDE_INT_IS_LONG tooLarge: #endif @@ -2734,10 +2837,53 @@ } } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } +#ifndef TCL_WIDE_INT_IS_LONG + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfWideInt -- + * + * Update the string representation for a wide integer object. Note: this + * function does not free an existing old string rep so storage will be + * lost if this has not already been done. + * + * Results: + * None. + * + * Side effects: + * The object's string is set to a valid string that results from the + * wideInt-to-string conversion. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateStringOfWideInt( + Tcl_Obj *objPtr) /* Int object whose string rep to update. */ +{ + char buffer[TCL_INTEGER_SPACE+2]; + unsigned len; + Tcl_WideInt wideVal = objPtr->internalRep.wideValue; + + /* + * Note that sprintf will generate a compiler warning under Mingw claiming + * %I64 is an unknown format specifier. Just ignore this warning. We can't + * use %L as the format specifier since that gets printed as a 32 bit + * value. + */ + + sprintf(buffer, "%" TCL_LL_MODIFIER "d", wideVal); + len = strlen(buffer); + objPtr->bytes = (char *)ckalloc(len + 1); + memcpy(objPtr->bytes, buffer, len + 1); + objPtr->length = len; +} +#endif /* !TCL_WIDE_INT_IS_LONG */ /* *---------------------------------------------------------------------- * * Tcl_NewWideIntObj -- @@ -2765,11 +2911,11 @@ #ifdef TCL_MEM_DEBUG #undef Tcl_NewWideIntObj Tcl_Obj * Tcl_NewWideIntObj( - register Tcl_WideInt wideValue) + Tcl_WideInt wideValue) /* Wide integer used to initialize the new * object. */ { return Tcl_DbNewWideIntObj(wideValue, "unknown", 0); } @@ -2776,18 +2922,18 @@ #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_NewWideIntObj( - register Tcl_WideInt wideValue) + Tcl_WideInt wideValue) /* Wide integer used to initialize the new * object. */ { - register Tcl_Obj *objPtr; + Tcl_Obj *objPtr; TclNewObj(objPtr); - TclSetIntObj(objPtr, wideValue); + Tcl_SetWideIntObj(objPtr, wideValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ /* @@ -2824,30 +2970,30 @@ #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewWideIntObj( - register Tcl_WideInt wideValue, + 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. */ { - register Tcl_Obj *objPtr; + Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); - TclSetIntObj(objPtr, wideValue); + Tcl_SetWideIntObj(objPtr, wideValue); return objPtr; } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_DbNewWideIntObj( - register Tcl_WideInt wideValue, + Tcl_WideInt wideValue, /* Long 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 @@ -2875,20 +3021,32 @@ *---------------------------------------------------------------------- */ void Tcl_SetWideIntObj( - register Tcl_Obj *objPtr, /* Object w. internal rep to init. */ - register Tcl_WideInt wideValue) + 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"); } - TclSetIntObj(objPtr, wideValue); + if ((wideValue >= (Tcl_WideInt) LONG_MIN) + && (wideValue <= (Tcl_WideInt) LONG_MAX)) { + TclSetLongObj(objPtr, (long) wideValue); + } else { +#ifndef TCL_WIDE_INT_IS_LONG + TclSetWideIntObj(objPtr, wideValue); +#else + mp_int big; + + TclBNInitBignumFromWideInt(&big, wideValue); + Tcl_SetBignumObj(objPtr, &big); +#endif + } } /* *---------------------------------------------------------------------- * @@ -2911,19 +3069,25 @@ */ int Tcl_GetWideIntFromObj( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr, /* Object from which to get a wide int. */ - register Tcl_WideInt *wideIntPtr) + Tcl_Obj *objPtr, /* Object from which to get a wide int. */ + Tcl_WideInt *wideIntPtr) /* Place to store resulting long. */ { do { - if (objPtr->typePtr == &tclIntType) { +#ifndef TCL_WIDE_INT_IS_LONG + if (objPtr->typePtr == &tclWideIntType) { *wideIntPtr = objPtr->internalRep.wideValue; return TCL_OK; } +#endif + if (objPtr->typePtr == &tclIntType) { + *wideIntPtr = (Tcl_WideInt) objPtr->internalRep.longValue; + return TCL_OK; + } if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected integer but got \"%s\"", TclGetString(objPtr))); @@ -2936,30 +3100,29 @@ * Must check for those bignum values that can fit in a * Tcl_WideInt, even when auto-narrowing is enabled. */ mp_int big; - Tcl_WideUInt value = 0; - unsigned long numBytes = sizeof(Tcl_WideInt); - Tcl_WideInt scratch; - unsigned char *bytes = (unsigned char *) &scratch; - - TclUnpackBignum(objPtr, big); - if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) { - while (numBytes-- > 0) { - value = (value << CHAR_BIT) | *bytes++; - } - if (big.sign) { - if (value <= 1 + ~(Tcl_WideUInt)WIDE_MIN) { + + UNPACK_BIGNUM(objPtr, big); + if ((size_t) big.used <= (CHAR_BIT * sizeof(Tcl_WideInt) + + MP_DIGIT_BIT - 1) / MP_DIGIT_BIT) { + Tcl_WideUInt value = 0; + size_t numBytes; + Tcl_WideInt scratch; + unsigned char *bytes = (unsigned char *) &scratch; + + if (mp_to_ubin(&big, bytes, sizeof(Tcl_WideInt), &numBytes) == MP_OKAY) { + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } + if (big.sign) { *wideIntPtr = - (Tcl_WideInt) value; - return TCL_OK; + } else { + *wideIntPtr = (Tcl_WideInt) value; } - } else { - if (value <= (Tcl_WideUInt)WIDE_MAX) { - *wideIntPtr = (Tcl_WideInt) value; - return TCL_OK; - } + return TCL_OK; } } if (interp != NULL) { const char *s = "integer value too large to represent"; Tcl_Obj *msg = Tcl_NewStringObj(s, -1); @@ -2971,74 +3134,37 @@ } } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } +#ifndef TCL_WIDE_INT_IS_LONG /* *---------------------------------------------------------------------- * - * TclGetWideBitsFromObj -- + * SetWideIntFromAny -- * - * Attempt to return a wide integer from the Tcl object "objPtr". If the - * object is not already a int, double or bignum, an attempt will be made - * to convert it to one of these. Out-of-range values don't result in an - * error, but only the least significant 64 bits will be returned. + * Attempts to force the internal representation for a Tcl object to + * tclWideIntType, specifically. * * Results: - * The return value is a standard Tcl object result. If an error occurs + * The return value is a standard object Tcl result. If an error occurs * during conversion, an error message is left in the interpreter's * result unless "interp" is NULL. * - * Side effects: - * If the object is not already an int, double or bignum object, the - * conversion will free any old internal representation. - * *---------------------------------------------------------------------- */ -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. */ -{ - do { - if (objPtr->typePtr == &tclIntType) { - *wideIntPtr = objPtr->internalRep.wideValue; - return TCL_OK; - } - if (objPtr->typePtr == &tclDoubleType) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "expected integer but got \"%s\"", - TclGetString(objPtr))); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL); - } - return TCL_ERROR; - } - if (objPtr->typePtr == &tclBignumType) { - mp_int big; - - Tcl_WideUInt value = 0, scratch; - unsigned long numBytes = sizeof(Tcl_WideInt); - unsigned char *bytes = (unsigned char *) &scratch; - - Tcl_GetBignumFromObj(NULL, objPtr, &big); - mp_mod_2d(&big, (int) (CHAR_BIT * sizeof(Tcl_WideInt)), &big); - mp_to_unsigned_bin_n(&big, bytes, &numBytes); - while (numBytes-- > 0) { - value = (value << CHAR_BIT) | *bytes++; - } - *wideIntPtr = !big.sign ? (Tcl_WideInt)value : -(Tcl_WideInt)value; - mp_clear(&big); - return TCL_OK; - } - } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, - TCL_PARSE_INTEGER_ONLY)==TCL_OK); - return TCL_ERROR; -} +static int +SetWideIntFromAny( + Tcl_Interp *interp, /* Tcl interpreter */ + Tcl_Obj *objPtr) /* Pointer to the object to convert */ +{ + Tcl_WideInt w; + return Tcl_GetWideIntFromObj(interp, objPtr, &w); +} +#endif /* !TCL_WIDE_INT_IS_LONG */ /* *---------------------------------------------------------------------- * * FreeBignum -- @@ -3055,14 +3181,14 @@ FreeBignum( Tcl_Obj *objPtr) { mp_int toFree; /* Bignum to free */ - TclUnpackBignum(objPtr, toFree); + UNPACK_BIGNUM(objPtr, toFree); mp_clear(&toFree); if (PTR2INT(objPtr->internalRep.twoPtrValue.ptr2) < 0) { - Tcl_Free(objPtr->internalRep.twoPtrValue.ptr1); + ckfree(objPtr->internalRep.twoPtrValue.ptr1); } objPtr->typePtr = NULL; } /* @@ -3088,11 +3214,11 @@ { mp_int bignumVal; mp_int bignumCopy; copyPtr->typePtr = &tclBignumType; - TclUnpackBignum(srcPtr, bignumVal); + UNPACK_BIGNUM(srcPtr, bignumVal); if (mp_init_copy(&bignumCopy, &bignumVal) != MP_OKAY) { Tcl_Panic("initialization failure in DupBignum"); } PACK_BIGNUM(bignumCopy, copyPtr); } @@ -3121,14 +3247,16 @@ UpdateStringOfBignum( Tcl_Obj *objPtr) { mp_int bignumVal; int size; + int status; char *stringVal; - TclUnpackBignum(objPtr, bignumVal); - if (MP_OKAY != mp_radix_size(&bignumVal, 10, &size)) { + UNPACK_BIGNUM(objPtr, bignumVal); + status = mp_radix_size(&bignumVal, 10, &size); + if (status != MP_OKAY) { Tcl_Panic("radix size failure in UpdateStringOfBignum"); } if (size < 2) { /* * mp_radix_size() returns < 2 when more than INT_MAX bytes would be @@ -3139,18 +3267,17 @@ * in a packed bignum, this branch will never be taken. */ Tcl_Panic("UpdateStringOfBignum: string length limit exceeded"); } - - stringVal = Tcl_InitStringRep(objPtr, NULL, size - 1); - - TclOOM(stringVal, size); - if (MP_OKAY != mp_toradix_n(&bignumVal, stringVal, 10, size)) { + stringVal = (char *)ckalloc(size); + status = mp_to_radix(&bignumVal, stringVal, size, NULL, 10); + if (status != MP_OKAY) { Tcl_Panic("conversion failure in UpdateStringOfBignum"); } - (void) Tcl_InitStringRep(objPtr, NULL, size - 1); + objPtr->bytes = stringVal; + objPtr->length = size - 1; /* size includes a trailing NUL byte. */ } /* *---------------------------------------------------------------------- * @@ -3262,34 +3389,41 @@ do { if (objPtr->typePtr == &tclBignumType) { if (copy || Tcl_IsShared(objPtr)) { mp_int temp; - TclUnpackBignum(objPtr, temp); - mp_init_copy(bignumValue, &temp); + UNPACK_BIGNUM(objPtr, temp); + if (mp_init_copy(bignumValue, &temp) != MP_OKAY) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "insufficient memory to unpack bignum", -1)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return TCL_ERROR; + } } else { - TclUnpackBignum(objPtr, *bignumValue); - /* Optimized TclFreeIntRep */ + UNPACK_BIGNUM(objPtr, *bignumValue); objPtr->internalRep.twoPtrValue.ptr1 = NULL; objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = NULL; - /* - * TODO: If objPtr has a string rep, this leaves - * it undisturbed. Not clear that's proper. Pure - * bignum values are converted to empty string. - */ if (objPtr->bytes == NULL) { - TclInitStringRep(objPtr, NULL, 0); + TclInitStringRep(objPtr, tclEmptyStringRep, 0); } } return TCL_OK; } if (objPtr->typePtr == &tclIntType) { - TclInitBignumFromWideInt(bignumValue, + TclBNInitBignumFromLong(bignumValue, objPtr->internalRep.longValue); + return TCL_OK; + } +#ifndef TCL_WIDE_INT_IS_LONG + if (objPtr->typePtr == &tclWideIntType) { + TclBNInitBignumFromWideInt(bignumValue, objPtr->internalRep.wideValue); return TCL_OK; } +#endif if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected integer but got \"%s\"", TclGetString(objPtr))); @@ -3391,35 +3525,65 @@ void Tcl_SetBignumObj( Tcl_Obj *objPtr, /* Object to set */ mp_int *bignumValue) /* Value to store */ { - Tcl_WideUInt value = 0; - unsigned long numBytes = sizeof(Tcl_WideUInt); - Tcl_WideUInt scratch; - unsigned char *bytes = (unsigned char *) &scratch; - if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetBignumObj"); } - if (mp_to_unsigned_bin_n(bignumValue, bytes, &numBytes) != MP_OKAY) { - goto tooLargeForWide; - } - while (numBytes-- > 0) { - value = (value << CHAR_BIT) | *bytes++; - } - if (value > ((Tcl_WideUInt)WIDE_MAX + bignumValue->sign)) { - goto tooLargeForWide; - } - if (bignumValue->sign) { - TclSetIntObj(objPtr, -(Tcl_WideInt)value); - } else { - TclSetIntObj(objPtr, (Tcl_WideInt)value); - } - mp_clear(bignumValue); - return; + if ((size_t) bignumValue->used + <= (CHAR_BIT * sizeof(long) + MP_DIGIT_BIT - 1) / MP_DIGIT_BIT) { + unsigned long value = 0; + size_t numBytes; + long scratch; + unsigned char *bytes = (unsigned char *) &scratch; + + if (mp_to_ubin(bignumValue, bytes, sizeof(long), &numBytes) != MP_OKAY) { + goto tooLargeForLong; + } + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } + if (value > (((~(unsigned long)0) >> 1) + bignumValue->sign)) { + goto tooLargeForLong; + } + if (bignumValue->sign) { + TclSetLongObj(objPtr, -(long)value); + } else { + TclSetLongObj(objPtr, (long)value); + } + mp_clear(bignumValue); + return; + } + tooLargeForLong: +#ifndef TCL_WIDE_INT_IS_LONG + if ((size_t) bignumValue->used + <= (CHAR_BIT * sizeof(Tcl_WideInt) + MP_DIGIT_BIT - 1) / MP_DIGIT_BIT) { + Tcl_WideUInt value = 0; + size_t numBytes; + Tcl_WideInt scratch; + unsigned char *bytes = (unsigned char *)&scratch; + + if (mp_to_ubin(bignumValue, bytes, sizeof(Tcl_WideInt), &numBytes) != MP_OKAY) { + goto tooLargeForWide; + } + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } + if (value > (((~(Tcl_WideUInt)0) >> 1) + bignumValue->sign)) { + goto tooLargeForWide; + } + if (bignumValue->sign) { + TclSetWideIntObj(objPtr, -(Tcl_WideInt)value); + } else { + TclSetWideIntObj(objPtr, (Tcl_WideInt)value); + } + mp_clear(bignumValue); + return; + } tooLargeForWide: +#endif TclInvalidateStringRep(objPtr); TclFreeIntRep(objPtr); TclSetBignumIntRep(objPtr, bignumValue); } @@ -3497,92 +3661,35 @@ } *clientDataPtr = &objPtr->internalRep.doubleValue; return TCL_OK; } if (objPtr->typePtr == &tclIntType) { - *typePtr = TCL_NUMBER_INT; + *typePtr = TCL_NUMBER_LONG; + *clientDataPtr = &objPtr->internalRep.longValue; + return TCL_OK; + } +#ifndef TCL_WIDE_INT_IS_LONG + if (objPtr->typePtr == &tclWideIntType) { + *typePtr = TCL_NUMBER_WIDE; *clientDataPtr = &objPtr->internalRep.wideValue; return TCL_OK; } +#endif if (objPtr->typePtr == &tclBignumType) { static Tcl_ThreadDataKey bignumKey; - mp_int *bigPtr = Tcl_GetThreadData(&bignumKey, sizeof(mp_int)); + mp_int *bigPtr = Tcl_GetThreadData(&bignumKey, + (int) sizeof(mp_int)); - TclUnpackBignum(objPtr, *bigPtr); + UNPACK_BIGNUM(objPtr, *bigPtr); *typePtr = TCL_NUMBER_BIG; *clientDataPtr = bigPtr; return TCL_OK; } } while (TCL_OK == TclParseNumber(interp, objPtr, "number", NULL, -1, NULL, 0)); return TCL_ERROR; } - -/* - *---------------------------------------------------------------------- - * - * Tcl_IncrRefCount -- - * - * Increments the reference count of the object. - * - * Results: - * None. - * - *---------------------------------------------------------------------- - */ - -#undef Tcl_IncrRefCount -void -Tcl_IncrRefCount( - Tcl_Obj *objPtr) /* The object we are registering a reference to. */ -{ - ++(objPtr)->refCount; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_DecrRefCount -- - * - * Decrements the reference count of the object. - * - * Results: - * None. - * - *---------------------------------------------------------------------- - */ - -#undef Tcl_DecrRefCount -void -Tcl_DecrRefCount( - Tcl_Obj *objPtr) /* The object we are releasing a reference to. */ -{ - if (objPtr->refCount-- <= 1) { - TclFreeObj(objPtr); - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_IsShared -- - * - * Tests if the object has a ref count greater than one. - * - * Results: - * Boolean value that is the result of the test. - * - *---------------------------------------------------------------------- - */ - -#undef Tcl_IsShared -int -Tcl_IsShared( - Tcl_Obj *objPtr) /* The object to test for being shared. */ -{ - return ((objPtr)->refCount + 1 > 2); -} /* *---------------------------------------------------------------------- * * Tcl_DbIncrRefCount -- @@ -3603,11 +3710,11 @@ *---------------------------------------------------------------------- */ void Tcl_DbIncrRefCount( - register 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. */ @@ -3617,11 +3724,11 @@ fprintf(stderr, "file = %s, line = %d\n", file, line); fflush(stderr); Tcl_Panic("incrementing refCount of previously disposed object"); } -#if TCL_THREADS +# ifdef TCL_THREADS /* * Check to make sure that the Tcl_Obj was allocated by the current * thread. Don't do this check when shutting down since thread local * storage can be finalized before the last Tcl_Obj is freed. */ @@ -3666,11 +3773,11 @@ *---------------------------------------------------------------------- */ void Tcl_DbDecrRefCount( - register 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. */ @@ -3680,11 +3787,11 @@ fprintf(stderr, "file = %s, line = %d\n", file, line); fflush(stderr); Tcl_Panic("decrementing refCount of previously disposed object"); } -#if TCL_THREADS +# ifdef TCL_THREADS /* * Check to make sure that the Tcl_Obj was allocated by the current * thread. Don't do this check when shutting down since thread local * storage can be finalized before the last Tcl_Obj is freed. */ @@ -3732,11 +3839,11 @@ *---------------------------------------------------------------------- */ int Tcl_DbIsShared( - register Tcl_Obj *objPtr, /* The object to test for being shared. */ + Tcl_Obj *objPtr, /* The object to test for being shared. */ 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. */ { @@ -3745,11 +3852,11 @@ fprintf(stderr, "file = %s, line = %d\n", file, line); fflush(stderr); Tcl_Panic("checking whether previously disposed object is shared"); } -#if TCL_THREADS +# ifdef TCL_THREADS /* * Check to make sure that the Tcl_Obj was allocated by the current * thread. Don't do this check when shutting down since thread local * storage can be finalized before the last Tcl_Obj is freed. */ @@ -3804,11 +3911,11 @@ *---------------------------------------------------------------------- */ void Tcl_InitObjHashTable( - register Tcl_HashTable *tablePtr) + Tcl_HashTable *tablePtr) /* Pointer to table record, which is supplied * by the caller. */ { Tcl_InitCustomHashTable(tablePtr, TCL_CUSTOM_PTR_KEYS, &tclObjHashKeyType); @@ -3834,11 +3941,11 @@ AllocObjEntry( Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key to store in the hash table entry. */ { Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr; - Tcl_HashEntry *hPtr = Tcl_Alloc(sizeof(Tcl_HashEntry)); + Tcl_HashEntry *hPtr = (Tcl_HashEntry *)ckalloc(sizeof(Tcl_HashEntry)); hPtr->key.objPtr = objPtr; Tcl_IncrRefCount(objPtr); hPtr->clientData = NULL; @@ -3865,14 +3972,14 @@ int TclCompareObjKeys( void *keyPtr, /* New key to compare. */ Tcl_HashEntry *hPtr) /* Existing key to compare. */ { - Tcl_Obj *objPtr1 = (Tcl_Obj *) keyPtr; + Tcl_Obj *objPtr1 = keyPtr; Tcl_Obj *objPtr2 = (Tcl_Obj *) hPtr->key.oneWordValue; - register const char *p1, *p2; - register size_t l1, l2; + const char *p1, *p2; + size_t l1, l2; /* * If the object pointers are the same then they match. * OPT: this comparison was moved to the caller @@ -3928,11 +4035,11 @@ Tcl_HashEntry *hPtr) /* Hash entry to free. */ { Tcl_Obj *objPtr = (Tcl_Obj *) hPtr->key.oneWordValue; Tcl_DecrRefCount(objPtr); - Tcl_Free(hPtr); + ckfree(hPtr); } /* *---------------------------------------------------------------------- * @@ -3949,19 +4056,19 @@ * None. * *---------------------------------------------------------------------- */ -TCL_HASH_TYPE +unsigned int TclHashObjKey( Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key from which to compute hash value. */ { - Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr; - const char *string = TclGetString(objPtr); - size_t length = objPtr->length; - TCL_HASH_TYPE result = 0; + Tcl_Obj *objPtr = keyPtr; + int length; + const char *string = TclGetStringFromObj(objPtr, &length); + unsigned int result = 0; /* * I tried a zillion different hash functions and asked many other people * for advice. Many people had their own favorite functions, all * different, but no-one had much idea why they were good ones. I chose @@ -3993,11 +4100,11 @@ * See also HashString in tclLiteral.c. * * See [tcl-Feature Request #2958832] */ - if (length) { + if (length > 0) { result = UCHAR(*string); while (--length) { result += (result << 3) + UCHAR(*++string); } } @@ -4025,17 +4132,17 @@ Tcl_Command Tcl_GetCommandFromObj( Tcl_Interp *interp, /* The interpreter in which to resolve the * command and to report errors. */ - register Tcl_Obj *objPtr) /* The object containing the command's name. + Tcl_Obj *objPtr) /* The object containing the command's name. * If the name starts with "::", will be * looked up in global namespace. Else, looked * up first in the current namespace, then in * global namespace. */ { - register ResolvedCmdName *resPtr; + ResolvedCmdName *resPtr; /* * Get the internal representation, converting to a command type if * needed. The internal representation is a ResolvedCmdName that points to * the actual command. @@ -4053,17 +4160,18 @@ * If any check fails, then force another conversion to the command type, * to discard the old rep and create a new one. */ resPtr = objPtr->internalRep.twoPtrValue.ptr1; - if (objPtr->typePtr == &tclCmdNameType) { - register Command *cmdPtr = resPtr->cmdPtr; + if ((objPtr->typePtr == &tclCmdNameType) && (resPtr != NULL)) { + Command *cmdPtr = resPtr->cmdPtr; if ((cmdPtr->cmdEpoch == resPtr->cmdEpoch) + && !(cmdPtr->flags & CMD_IS_DELETED) && (interp == cmdPtr->nsPtr->interp) && !(cmdPtr->nsPtr->flags & NS_DYING)) { - register Namespace *refNsPtr = (Namespace *) + Namespace *refNsPtr = (Namespace *) TclGetCurrentNamespace(interp); if ((resPtr->refNsPtr == NULL) || ((refNsPtr == resPtr->refNsPtr) && (resPtr->refNsId == refNsPtr->nsId) @@ -4076,11 +4184,11 @@ /* * OK, must create a new internal representation (or fail) as any cache we * had is invalid one way or another. */ - /* See [07d13d99b0a9] why we cannot call SetCmdNameFromAny() directly here. */ + /* See [] why we cannot call SetCmdNameFromAny() directly here. */ if (tclCmdNameType.setFromAnyProc(interp, objPtr) != TCL_OK) { return NULL; } resPtr = objPtr->internalRep.twoPtrValue.ptr1; return (Tcl_Command) (resPtr ? resPtr->cmdPtr : NULL); @@ -4104,82 +4212,61 @@ * TclNRExecuteByteCode has a chance to recognize that it was deleted. * *---------------------------------------------------------------------- */ -static void -SetCmdNameObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr, - Command *cmdPtr, - ResolvedCmdName *resPtr) -{ - Interp *iPtr = (Interp *) interp; - ResolvedCmdName *fillPtr; - const char *name = TclGetString(objPtr); - - if (resPtr) { - fillPtr = resPtr; - } else { - fillPtr = Tcl_Alloc(sizeof(ResolvedCmdName)); - fillPtr->refCount = 1; - } - - fillPtr->cmdPtr = cmdPtr; - cmdPtr->refCount++; - fillPtr->cmdEpoch = cmdPtr->cmdEpoch; - - /* NOTE: relying on NULL termination here. */ - if ((name[0] == ':') && (name[1] == ':')) { - /* - * Fully qualified names always resolve to same thing. No need - * to record resolution context information. - */ - - fillPtr->refNsPtr = NULL; - fillPtr->refNsId = 0; /* Will not be read */ - fillPtr->refNsCmdEpoch = 0; /* Will not be read */ - } else { - /* - * Record current state of current namespace as the resolution - * context of this command name lookup. - */ - Namespace *currNsPtr = iPtr->varFramePtr->nsPtr; - - fillPtr->refNsPtr = currNsPtr; - fillPtr->refNsId = currNsPtr->nsId; - fillPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; - } - - if (resPtr == NULL) { - TclFreeIntRep(objPtr); - - objPtr->internalRep.twoPtrValue.ptr1 = fillPtr; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - objPtr->typePtr = &tclCmdNameType; - } -} - void TclSetCmdNameObj( Tcl_Interp *interp, /* Points to interpreter containing command * that should be cached in objPtr. */ - register Tcl_Obj *objPtr, /* Points to Tcl object to be changed to a + Tcl_Obj *objPtr, /* Points to Tcl object to be changed to a * CmdName object. */ Command *cmdPtr) /* Points to Command structure that the * CmdName object should refer to. */ { - register ResolvedCmdName *resPtr; + Interp *iPtr = (Interp *) interp; + ResolvedCmdName *resPtr; + Namespace *currNsPtr; + const char *name; if (objPtr->typePtr == &tclCmdNameType) { resPtr = objPtr->internalRep.twoPtrValue.ptr1; if (resPtr != NULL && resPtr->cmdPtr == cmdPtr) { return; } } - SetCmdNameObj(interp, objPtr, cmdPtr, NULL); + cmdPtr->refCount++; + resPtr = (ResolvedCmdName *)ckalloc(sizeof(ResolvedCmdName)); + resPtr->cmdPtr = cmdPtr; + resPtr->cmdEpoch = cmdPtr->cmdEpoch; + resPtr->refCount = 1; + + name = TclGetString(objPtr); + if ((*name++ == ':') && (*name == ':')) { + /* + * The name is fully qualified: set the referring namespace to + * NULL. + */ + + resPtr->refNsPtr = NULL; + } else { + /* + * Get the current namespace. + */ + + currNsPtr = iPtr->varFramePtr->nsPtr; + + resPtr->refNsPtr = currNsPtr; + resPtr->refNsId = currNsPtr->nsId; + resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; + } + + TclFreeIntRep(objPtr); + objPtr->internalRep.twoPtrValue.ptr1 = resPtr; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; + objPtr->typePtr = &tclCmdNameType; } /* *---------------------------------------------------------------------- * @@ -4201,32 +4288,34 @@ *---------------------------------------------------------------------- */ static void FreeCmdNameInternalRep( - register Tcl_Obj *objPtr) /* CmdName object with internal + Tcl_Obj *objPtr) /* CmdName object with internal * representation to free. */ { - register ResolvedCmdName *resPtr = objPtr->internalRep.twoPtrValue.ptr1; + ResolvedCmdName *resPtr = objPtr->internalRep.twoPtrValue.ptr1; + if (resPtr != NULL) { /* * Decrement the reference count of the ResolvedCmdName structure. If * there are no more uses, free the ResolvedCmdName structure. */ - if (resPtr->refCount-- <= 1) { + if (resPtr->refCount-- == 1) { /* * Now free the cached command, unless it is still in its hash * table or if there are other references to it from other cmdName * objects. */ Command *cmdPtr = resPtr->cmdPtr; TclCleanupCommandMacro(cmdPtr); - Tcl_Free(resPtr); + ckfree(resPtr); } + } objPtr->typePtr = NULL; } /* *---------------------------------------------------------------------- @@ -4249,17 +4338,19 @@ */ static void DupCmdNameInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ - register Tcl_Obj *copyPtr) /* Object with internal rep to set. */ + Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - register ResolvedCmdName *resPtr = srcPtr->internalRep.twoPtrValue.ptr1; + ResolvedCmdName *resPtr = srcPtr->internalRep.twoPtrValue.ptr1; copyPtr->internalRep.twoPtrValue.ptr1 = resPtr; copyPtr->internalRep.twoPtrValue.ptr2 = NULL; + if (resPtr != NULL) { resPtr->refCount++; + } copyPtr->typePtr = &tclCmdNameType; } /* *---------------------------------------------------------------------- @@ -4283,15 +4374,17 @@ */ static int SetCmdNameFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr) /* The object to convert. */ + Tcl_Obj *objPtr) /* The object to convert. */ { + Interp *iPtr = (Interp *) interp; const char *name; - register Command *cmdPtr; - register ResolvedCmdName *resPtr; + Command *cmdPtr; + Namespace *currNsPtr; + ResolvedCmdName *resPtr; if (interp == NULL) { return TCL_ERROR; } @@ -4306,35 +4399,63 @@ name = TclGetString(objPtr); cmdPtr = (Command *) Tcl_FindCommand(interp, name, /*ns*/ NULL, /*flags*/ 0); /* - * Stop shimmering and caching nothing when we found nothing. Just - * report the failure to find the command as an error. - */ - - if (cmdPtr == NULL) { - return TCL_ERROR; - } - - resPtr = objPtr->internalRep.twoPtrValue.ptr1; - if ((objPtr->typePtr == &tclCmdNameType) && (resPtr->refCount == 1)) { - /* - * Re-use existing ResolvedCmdName struct when possible. - * Cleanup the old fields that need it. - */ - - Command *oldCmdPtr = resPtr->cmdPtr; - - if (oldCmdPtr->refCount-- <= 1) { - TclCleanupCommandMacro(oldCmdPtr); - } - } else { - resPtr = NULL; - } - - SetCmdNameObj(interp, objPtr, cmdPtr, resPtr); + * Free the old internalRep before setting the new one. Do this after + * getting the string rep to allow the conversion code (in particular, + * Tcl_GetStringFromObj) to use that old internalRep. + */ + + if (cmdPtr) { + cmdPtr->refCount++; + resPtr = objPtr->internalRep.twoPtrValue.ptr1; + if ((objPtr->typePtr == &tclCmdNameType) + && resPtr && (resPtr->refCount == 1)) { + /* + * Reuse the old ResolvedCmdName struct instead of freeing it + */ + + Command *oldCmdPtr = resPtr->cmdPtr; + + if (--oldCmdPtr->refCount == 0) { + TclCleanupCommandMacro(oldCmdPtr); + } + } else { + TclFreeIntRep(objPtr); + resPtr = (ResolvedCmdName *)ckalloc(sizeof(ResolvedCmdName)); + resPtr->refCount = 1; + objPtr->internalRep.twoPtrValue.ptr1 = resPtr; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; + objPtr->typePtr = &tclCmdNameType; + } + resPtr->cmdPtr = cmdPtr; + resPtr->cmdEpoch = cmdPtr->cmdEpoch; + if ((*name++ == ':') && (*name == ':')) { + /* + * The name is fully qualified: set the referring namespace to + * NULL. + */ + + resPtr->refNsPtr = NULL; + } else { + /* + * Get the current namespace. + */ + + currNsPtr = iPtr->varFramePtr->nsPtr; + + resPtr->refNsPtr = currNsPtr; + resPtr->refNsId = currNsPtr->nsId; + resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; + } + } else { + TclFreeIntRep(objPtr); + objPtr->internalRep.twoPtrValue.ptr1 = NULL; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; + objPtr->typePtr = &tclCmdNameType; + } return TCL_OK; } /* *---------------------------------------------------------------------- @@ -4357,10 +4478,11 @@ ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { + char ptrBuffer[2*TCL_INTEGER_SPACE+6]; Tcl_Obj *descObj; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "value"); return TCL_ERROR; @@ -4370,24 +4492,40 @@ * Value is a bignum with a refcount of 14, object pointer at 0x12345678, * internal representation 0x45671234:0x98765432, string representation * "1872361827361287" */ - descObj = Tcl_ObjPrintf("value is a %s with a refcount of %" TCL_Z_MODIFIER "u," - " object pointer at %p", - objv[1]->typePtr ? objv[1]->typePtr->name : "pure string", - objv[1]->refCount, objv[1]); - - if (objv[1]->typePtr) { - if (objv[1]->typePtr == &tclDoubleType) { - Tcl_AppendPrintfToObj(descObj, ", internal representation %g", - objv[1]->internalRep.doubleValue); - } else { - Tcl_AppendPrintfToObj(descObj, ", internal representation %p:%p", - (void *) objv[1]->internalRep.twoPtrValue.ptr1, - (void *) objv[1]->internalRep.twoPtrValue.ptr2); - } + sprintf(ptrBuffer, "%p", (void *) objv[1]); + descObj = Tcl_ObjPrintf("value is a %s with a refcount of %d," + " object pointer at %s", + objv[1]->typePtr ? objv[1]->typePtr->name : "pure string", + objv[1]->refCount, ptrBuffer); + + /* + * This is a workaround to silence reports from `make valgrind` + * on 64-bit systems. The problem is that the test suite + * includes calling the [represenation] command on values of + * &tclDoubleType. When these values are created, the "doubleValue" + * is set, but when the "twoPtrValue" is examined, its "ptr2" + * field has never been initialized. Since [representation] + * presents the value of the ptr2 value in its output, valgrind + * alerts about the read of uninitialized memory. + * + * The general problem with [representation], that it can read + * and report uninitialized fields, is still present. This is + * just the minimal workaround to silence one particular test. + */ + + if ((sizeof(void *) > 4) && objv[1]->typePtr == &tclDoubleType) { + objv[1]->internalRep.twoPtrValue.ptr2 = NULL; + } + if (objv[1]->typePtr) { + sprintf(ptrBuffer, "%p:%p", + (void *) objv[1]->internalRep.twoPtrValue.ptr1, + (void *) objv[1]->internalRep.twoPtrValue.ptr2); + Tcl_AppendPrintfToObj(descObj, ", internal representation %s", + ptrBuffer); } if (objv[1]->bytes) { Tcl_AppendToObj(descObj, ", string representation \"", -1); Tcl_AppendLimitedToObj(descObj, objv[1]->bytes, objv[1]->length, Index: generic/tclOptimize.c ================================================================== --- generic/tclOptimize.c +++ generic/tclOptimize.c @@ -32,11 +32,11 @@ #define IsTargetAddress(tablePtr, address) \ (Tcl_FindHashEntry((tablePtr), (void *) (address)) != NULL) #define AddrLength(address) \ (tclInstructionTable[*(unsigned char *)(address)].numBytes) #define InstLength(instruction) \ - (tclInstructionTable[(unsigned char)(instruction)].numBytes) + (tclInstructionTable[UCHAR(instruction)].numBytes) /* * ---------------------------------------------------------------------- * * LocateTargetAddresses -- @@ -229,13 +229,13 @@ blank = size + InstLength(nextInst); } else if (nextInst == INST_STR_CONCAT1 && TclGetUInt1AtPtr(currentInstPtr + size + 1) == 2) { Tcl_Obj *litPtr = TclFetchLiteral(envPtr, TclGetUInt1AtPtr(currentInstPtr + 1)); - size_t numBytes; + int numBytes; - (void) TclGetStringFromObj(litPtr, &numBytes); + (void) Tcl_GetStringFromObj(litPtr, &numBytes); if (numBytes == 0) { blank = size + InstLength(nextInst); } } break; @@ -244,13 +244,13 @@ blank = size + 1; } else if (nextInst == INST_STR_CONCAT1 && TclGetUInt1AtPtr(currentInstPtr + size + 1) == 2) { Tcl_Obj *litPtr = TclFetchLiteral(envPtr, TclGetUInt4AtPtr(currentInstPtr + 1)); - size_t numBytes; + int numBytes; - (void) TclGetStringFromObj(litPtr, &numBytes); + (void) Tcl_GetStringFromObj(litPtr, &numBytes); if (numBytes == 0) { blank = size + InstLength(nextInst); } } break; @@ -285,10 +285,12 @@ case INST_INCR_SCALAR1: case INST_INCR_ARRAY1: case INST_INCR_ARRAY_STK: case INST_INCR_SCALAR_STK: case INST_INCR_STK: + case INST_LOR: + case INST_LAND: case INST_EQ: case INST_NEQ: case INST_LT: case INST_LE: case INST_GT: Index: generic/tclPanic.c ================================================================== --- generic/tclPanic.c +++ generic/tclPanic.c @@ -13,19 +13,23 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #if defined(_WIN32) || defined(__CYGWIN__) - MODULE_SCOPE void tclWinDebugPanic(const char *format, ...); + MODULE_SCOPE TCL_NORETURN void tclWinDebugPanic(const char *format, ...); #endif /* * The panicProc variable contains a pointer to an application specific panic * procedure. */ +#if defined(__CYGWIN__) +static TCL_NORETURN Tcl_PanicProc *panicProc = tclWinDebugPanic; +#else static TCL_NORETURN1 Tcl_PanicProc *panicProc = NULL; +#endif /* *---------------------------------------------------------------------- * * Tcl_SetPanicProc -- @@ -43,12 +47,84 @@ void Tcl_SetPanicProc( TCL_NORETURN1 Tcl_PanicProc *proc) { +#if defined(_WIN32) + /* tclWinDebugPanic only installs if there is no panicProc yet. */ + if ((proc != tclWinDebugPanic) || (panicProc == NULL)) +#elif defined(__CYGWIN__) + if (proc == NULL) + panicProc = tclWinDebugPanic; + else +#endif panicProc = proc; - TclInitSubsystems(); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PanicVA -- + * + * Print an error message and kill the process. + * + * Results: + * None. + * + * Side effects: + * The process dies, entering the debugger if possible. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_PanicVA( + const char *format, /* Format string, suitable for passing to + * fprintf. */ + va_list argList) /* Variable argument list. */ +{ + char *arg1, *arg2, *arg3; /* Additional arguments (variable in number) + * to pass to fprintf. */ + char *arg4, *arg5, *arg6, *arg7, *arg8; + + arg1 = va_arg(argList, char *); + arg2 = va_arg(argList, char *); + arg3 = va_arg(argList, char *); + arg4 = va_arg(argList, char *); + arg5 = va_arg(argList, char *); + arg6 = va_arg(argList, char *); + arg7 = va_arg(argList, char *); + arg8 = va_arg(argList, char *); + + if (panicProc != NULL) { + panicProc(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); +#ifdef _WIN32 + } else if (IsDebuggerPresent()) { + tclWinDebugPanic(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); +#endif + } else { + fprintf(stderr, format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, + arg8); + fprintf(stderr, "\n"); + fflush(stderr); +#if defined(_WIN32) || defined(__CYGWIN__) +# if defined(__GNUC__) + __builtin_trap(); +# elif defined(_WIN64) + __debugbreak(); +# elif defined(_MSC_VER) && defined (_M_IX86) + _asm {int 3} +# else + DebugBreak(); +# endif +#endif +#if defined(_WIN32) + ExitProcess(1); +#else + abort(); +#endif + } } /* *---------------------------------------------------------------------- * @@ -63,11 +139,12 @@ * The process dies, entering the debugger if possible. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ +/* ARGSUSED */ + /* * The following comment is here so that Coverity's static analizer knows that * a Tcl_Panic() call can never return and avoids lots of false positives. */ @@ -76,56 +153,18 @@ Tcl_Panic( const char *format, ...) { va_list argList; - char *arg1, *arg2, *arg3; /* Additional arguments (variable in number) - * to pass to fprintf. */ - char *arg4, *arg5, *arg6, *arg7, *arg8; - va_start(argList, format); - arg1 = va_arg(argList, char *); - arg2 = va_arg(argList, char *); - arg3 = va_arg(argList, char *); - arg4 = va_arg(argList, char *); - arg5 = va_arg(argList, char *); - arg6 = va_arg(argList, char *); - arg7 = va_arg(argList, char *); - arg8 = va_arg(argList, char *); + Tcl_PanicVA(format, argList); va_end (argList); - - if (panicProc != NULL) { - panicProc(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); - } else { -#if defined(_WIN32) || defined(__CYGWIN__) - tclWinDebugPanic(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); -#else - fprintf(stderr, format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, - arg8); - fprintf(stderr, "\n"); - fflush(stderr); -#endif -# if defined(__GNUC__) - __builtin_trap(); -# elif defined(_WIN64) - __debugbreak(); -# elif defined(_MSC_VER) && defined (_M_IX86) - _asm {int 3} -# elif defined(_WIN32) - DebugBreak(); -# endif -#if defined(_WIN32) - ExitProcess(1); -#else - abort(); -#endif - } } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: generic/tclParse.c ================================================================== --- generic/tclParse.c +++ generic/tclParse.c @@ -17,11 +17,16 @@ #include "tclParse.h" #include /* * The following table provides parsing information about each possible 8-bit - * character. The table is designed to be referenced with unsigned characters. + * character. The table is designed to be referenced with either signed or + * unsigned characters, so it has 384 entries. The first 128 entries + * correspond to negative character values, the next 256 correspond to + * positive character values. The last 128 entries are identical to the first + * 128. The table is always indexed with a 128-byte offset (the 128th entry + * corresponds to a character value of 0). * * The macro CHAR_TYPE is used to index into the table and return information * about its character argument. The following return values are defined. * * TYPE_NORMAL - All characters that don't have special significance to @@ -37,10 +42,46 @@ * TYPE_CLOSE_BRACK - Character is a right square bracket. * TYPE_BRACE - Character is a curly brace (either left or right). */ const char tclCharTypeTable[] = { + /* + * Negative character values, from -128 to -1: + */ + + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, /* * Positive character values, from 0-127: */ @@ -117,19 +158,19 @@ /* * Prototypes for local functions defined in this file: */ -static inline int CommandComplete(const char *script, size_t numBytes); -static size_t ParseComment(const char *src, size_t numBytes, +static inline int CommandComplete(const char *script, int numBytes); +static int ParseComment(const char *src, int numBytes, Tcl_Parse *parsePtr); -static int ParseTokens(const char *src, size_t numBytes, int mask, +static int ParseTokens(const char *src, int numBytes, int mask, int flags, Tcl_Parse *parsePtr); -static size_t ParseWhiteSpace(const char *src, size_t numBytes, +static int ParseWhiteSpace(const char *src, int numBytes, int *incompletePtr, char *typePtr); -static size_t ParseAllWhiteSpace(const char *src, size_t numBytes, - int *incompletePtr); +static int ParseHex(const char *src, int numBytes, + int *resultPtr); /* *---------------------------------------------------------------------- * * TclParseInit -- @@ -147,11 +188,11 @@ void TclParseInit( Tcl_Interp *interp, /* Interpreter to use for error reporting */ const char *start, /* Start of string to be parsed. */ - size_t numBytes, /* Total number of bytes in string. If -1, + int numBytes, /* Total number of bytes in string. If < 0, * the script consists of all bytes up to the * first null character. */ Tcl_Parse *parsePtr) /* Points to struct to initialize */ { parsePtr->numWords = 0; @@ -193,44 +234,44 @@ Tcl_ParseCommand( Tcl_Interp *interp, /* Interpreter to use for error reporting; if * NULL, then no error message is provided. */ const char *start, /* First character of string containing one or * more Tcl commands. */ - size_t numBytes, /* Total number of bytes in string. If -1, + register int numBytes, /* Total number of bytes in string. If < 0, * the script consists of all bytes up to the * 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) + register 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 + register const char *src; /* Points to current character in the * command. */ char type; /* Result returned by CHAR_TYPE(*src). */ Tcl_Token *tokenPtr; /* Pointer to token being filled in. */ int wordIndex; /* Index of word token for current word. */ int terminators; /* CHAR_TYPE bits that indicate the end of a * command. */ const char *termPtr; /* Set by Tcl_ParseBraces/QuotedString to * point to char after terminating one. */ - size_t scanned; + int scanned; + if (numBytes < 0 && start) { + numBytes = strlen(start); + } + TclParseInit(interp, start, numBytes, parsePtr); if ((start == NULL) && (numBytes != 0)) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "can't parse a NULL pointer", -1)); } return TCL_ERROR; } - if (numBytes == TCL_AUTO_LENGTH) { - numBytes = strlen(start); - } - TclParseInit(interp, start, numBytes, parsePtr); parsePtr->commentStart = NULL; parsePtr->commentSize = 0; parsePtr->commandStart = NULL; parsePtr->commandSize = 0; if (nested != 0) { @@ -257,56 +298,39 @@ * The following loop parses the words of the command, one word in each * iteration through the loop. */ parsePtr->commandStart = src; - type = CHAR_TYPE(*src); - scanned = 1; /* Can't have missing whitepsace before first word. */ while (1) { int expandWord = 0; - /* Are we at command termination? */ - - if ((numBytes == 0) || (type & terminators) != 0) { - parsePtr->term = src; - parsePtr->commandSize = src + (numBytes != 0) - - parsePtr->commandStart; - return TCL_OK; - } - - /* Are we missing white space after previous word? */ - - if (scanned == 0) { - if (src[-1] == '"') { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "extra characters after close-quote", -1)); - } - parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA; - } else { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "extra characters after close-brace", -1)); - } - parsePtr->errorType = TCL_PARSE_BRACE_EXTRA; - } - parsePtr->term = src; - error: - Tcl_FreeParse(parsePtr); - parsePtr->commandSize = parsePtr->end - parsePtr->commandStart; - return TCL_ERROR; - } - /* * Create the token for the word. */ TclGrowParseTokenArray(parsePtr, 1); wordIndex = parsePtr->numTokens; tokenPtr = &parsePtr->tokenPtr[wordIndex]; tokenPtr->type = TCL_TOKEN_WORD; + /* + * Skip white space before the word. Also skip a backslash-newline + * sequence: it should be treated just like white space. + */ + + scanned = ParseWhiteSpace(src,numBytes, &parsePtr->incomplete, &type); + src += scanned; + numBytes -= scanned; + if (numBytes == 0) { + parsePtr->term = src; + break; + } + if ((type & terminators) != 0) { + parsePtr->term = src; + src++; + break; + } tokenPtr->start = src; parsePtr->numTokens++; parsePtr->numWords++; /* @@ -342,11 +366,11 @@ expPtr = &parsePtr->tokenPtr[expIdx]; if ((0 == expandWord) /* Haven't seen prefix already */ && (1 == parsePtr->numTokens - expIdx) /* Only one token */ - && (((1 == expPtr->size) + && (((1 == (size_t) expPtr->size) /* Same length as prefix */ && (expPtr->start[0] == '*'))) /* Is the prefix */ && (numBytes > 0) && (0 == ParseWhiteSpace(termPtr, numBytes, &parsePtr->incomplete, &type)) @@ -377,12 +401,11 @@ tokenPtr = &parsePtr->tokenPtr[wordIndex]; tokenPtr->size = src - tokenPtr->start; tokenPtr->numComponents = parsePtr->numTokens - (wordIndex + 1); if (expandWord) { - size_t i; - int isLiteral = 1; + int i, isLiteral = 1; /* * When a command includes a word that is an expanded literal; for * example, {*}{1 2 3}, the parser performs that expansion * immediately, generating several TCL_TOKEN_SIMPLE_WORDs instead @@ -424,11 +447,11 @@ * Step through the literal string, parsing and counting list * elements. */ while (nextElem < listEnd) { - size_t size; + int size; code = TclFindElement(NULL, nextElem, listEnd - nextElem, &elemStart, &nextElem, &size, &literal); if ((code != TCL_OK) || !literal) { break; @@ -523,16 +546,56 @@ } else if ((tokenPtr->numComponents == 1) && (tokenPtr[1].type == TCL_TOKEN_TEXT)) { tokenPtr->type = TCL_TOKEN_SIMPLE_WORD; } - /* Parse the whitespace between words. */ + /* + * Do two additional checks: (a) make sure we're really at the end of + * a word (there might have been garbage left after a quoted or braced + * word), and (b) check for the end of the command. + */ scanned = ParseWhiteSpace(src,numBytes, &parsePtr->incomplete, &type); - src += scanned; - numBytes -= scanned; + if (scanned) { + src += scanned; + numBytes -= scanned; + continue; + } + + if (numBytes == 0) { + parsePtr->term = src; + break; + } + if ((type & terminators) != 0) { + parsePtr->term = src; + src++; + break; + } + if (src[-1] == '"') { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "extra characters after close-quote", -1)); + } + parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA; + } else { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "extra characters after close-brace", -1)); + } + parsePtr->errorType = TCL_PARSE_BRACE_EXTRA; + } + parsePtr->term = src; + goto error; } + + parsePtr->commandSize = src - parsePtr->commandStart; + return TCL_OK; + + error: + Tcl_FreeParse(parsePtr); + parsePtr->commandSize = parsePtr->end - parsePtr->commandStart; + return TCL_ERROR; } /* *---------------------------------------------------------------------- * @@ -616,14 +679,14 @@ * None. * *---------------------------------------------------------------------- */ -static size_t +static int ParseWhiteSpace( const char *src, /* First character to parse. */ - size_t numBytes, /* Max number of bytes to scan. */ + register int numBytes, /* Max number of bytes to scan. */ int *incompletePtr, /* Set this boolean memory to true if parsing * indicates an incomplete command. */ char *typePtr) /* Points to location to store character type * of character that ends run of whitespace */ { @@ -670,41 +733,32 @@ * Returns the number of bytes recognized as white space. * *---------------------------------------------------------------------- */ -static size_t -ParseAllWhiteSpace( +int +TclParseAllWhiteSpace( const char *src, /* First character to parse. */ - size_t numBytes, /* Max number of byes to scan */ - int *incompletePtr) /* Set true if parse is incomplete. */ + int numBytes) /* Max number of byes to scan */ { + int dummy; char type; const char *p = src; do { - size_t scanned = ParseWhiteSpace(p, numBytes, incompletePtr, &type); + int scanned = ParseWhiteSpace(p, numBytes, &dummy, &type); p += scanned; numBytes -= scanned; } while (numBytes && (*p == '\n') && (p++, --numBytes)); return (p-src); } - -size_t -TclParseAllWhiteSpace( - const char *src, /* First character to parse. */ - size_t numBytes) /* Max number of byes to scan */ -{ - int dummy; - return ParseAllWhiteSpace(src, numBytes, &dummy); -} /* *---------------------------------------------------------------------- * - * TclParseHex -- + * ParseHex -- * * Scans a hexadecimal number as a Tcl_UniChar value (e.g., for parsing * \x and \u escape sequences). At most numBytes bytes are scanned. * * Results: @@ -720,24 +774,24 @@ * *---------------------------------------------------------------------- */ int -TclParseHex( +ParseHex( const char *src, /* First character to parse. */ - size_t numBytes, /* Max number of byes to scan */ - int *resultPtr) /* Points to storage provided by caller where + int numBytes, /* Max number of byes to scan */ + int *resultPtr) /* Points to storage provided by caller where * the character resulting from the * conversion is to be written. */ { int result = 0; register const char *p = src; while (numBytes--) { unsigned char digit = UCHAR(*p); - if (!isxdigit(digit) || (result > 0x10fff)) { + if (!isxdigit(digit) || (result > 0x10FFF)) { break; } p++; result <<= 4; @@ -778,23 +832,22 @@ int TclParseBackslash( const char *src, /* Points to the backslash character of a a * backslash sequence. */ - size_t numBytes, /* Max number of bytes to scan. */ - size_t *readPtr, /* NULL, or points to storage where the number + int numBytes, /* Max number of bytes to scan. */ + int *readPtr, /* NULL, or points to storage where the number * of bytes scanned should be written. */ char *dst) /* NULL, or points to buffer where the UTF-8 * encoding of the backslash sequence is to be * written. At most TCL_UTF_MAX bytes will be * written there. */ { register const char *p = src+1; - Tcl_UniChar unichar = 0; int result; - size_t count; - char buf[4] = ""; + int count; + char buf[TCL_UTF_MAX] = ""; if (numBytes == 0) { if (readPtr != NULL) { *readPtr = 0; } @@ -816,11 +869,11 @@ } count = 2; switch (*p) { /* - * Note: in the conversions below, use absolute values (e.g., 0xa) + * Note: in the conversions below, use absolute values (e.g., 0xA) * rather than symbolic values (e.g. \n) that get converted by the * compiler. It's possible that compilers on some platforms will do * the symbolic conversions differently, which could result in * non-portable Tcl scripts. */ @@ -830,26 +883,26 @@ break; case 'b': result = 0x8; break; case 'f': - result = 0xc; + result = 0xC; break; case 'n': - result = 0xa; + result = 0xA; break; case 'r': - result = 0xd; + result = 0xD; break; case 't': result = 0x9; break; case 'v': - result = 0xb; + result = 0xB; break; case 'x': - count += TclParseHex(p+1, (numBytes > 3) ? 2 : numBytes-2, &result); + count += ParseHex(p+1, (numBytes > 3) ? 2 : numBytes-2, &result); if (count == 2) { /* * No hexdigits -> This is just "x". */ @@ -856,29 +909,46 @@ result = 'x'; } else { /* * Keep only the last byte (2 hex digits). */ - result = (unsigned char) result; + result = UCHAR(result); } break; case 'u': - count += TclParseHex(p+1, (numBytes > 5) ? 4 : numBytes-2, &result); + count += ParseHex(p+1, (numBytes > 5) ? 4 : numBytes-2, &result); if (count == 2) { /* * No hexdigits -> This is just "u". */ result = 'u'; +#if TCL_UTF_MAX > 3 + } else if (((result & 0xFC00) == 0xD800) && (count == 6) + && (p[5] == '\\') && (p[6] == 'u') && (numBytes >= 10)) { + /* If high surrogate is immediately followed by a low surrogate + * escape, combine them into one character. */ + int low; + int count2 = ParseHex(p+7, 4, &low); + if ((count2 == 4) && ((low & 0xFC00) == 0xDC00)) { + result = ((result & 0x3FF)<<10 | (low & 0x3FF)) + 0x10000; + count += count2 + 2; + } +#endif } break; case 'U': - count += TclParseHex(p+1, (numBytes > 9) ? 8 : numBytes-2, &result); + count += ParseHex(p+1, (numBytes > 9) ? 8 : numBytes-2, &result); if (count == 2) { /* * No hexdigits -> This is just "U". */ result = 'U'; +#if TCL_UTF_MAX > 3 + } else if ((result & ~0x7FF) == 0xD800) { + /* Upper or lower surrogate, not allowed in this syntax. */ + result = 0xFFFD; +#endif } break; case '\n': count--; do { @@ -920,33 +990,32 @@ * front of a multi-byte utf-8 character. While this means nothing * special, we shouldn't break up a correct utf-8 character. [Bug * #217987] test subst-3.2 */ - if (Tcl_UtfCharComplete(p, numBytes - 1)) { - count = TclUtfToUniChar(p, &unichar) + 1; /* +1 for '\' */ + if (TclUCS4Complete(p, numBytes - 1)) { + count = TclUtfToUCS4(p, &result) + 1; /* +1 for '\' */ } else { - char utfBytes[TCL_UTF_MAX]; + char utfBytes[8]; memcpy(utfBytes, p, numBytes - 1); utfBytes[numBytes - 1] = '\0'; - count = TclUtfToUniChar(utfBytes, &unichar) + 1; + count = TclUtfToUCS4(utfBytes, &result) + 1; } - result = unichar; break; } done: if (readPtr != NULL) { *readPtr = count; } - count = Tcl_UniCharToUtf(result, dst); - if ((result >= 0xD800) && (count < 3)) { - /* Special case for handling high surrogates. */ - count += Tcl_UniCharToUtf(-1, dst + count); +#if TCL_UTF_MAX < 4 + if (result > 0xFFFF) { + result = 0xFFFD; } - return count; +#endif + return TclUCS4ToUtf(result, dst); } /* *---------------------------------------------------------------------- * @@ -963,55 +1032,67 @@ * None. * *---------------------------------------------------------------------- */ -static size_t +static int ParseComment( const char *src, /* First character to parse. */ - size_t numBytes, /* Max number of bytes to scan. */ + register int numBytes, /* Max number of bytes to scan. */ Tcl_Parse *parsePtr) /* Information about parse in progress. * Updated if parsing indicates an incomplete * command. */ { register const char *p = src; - int incomplete = parsePtr->incomplete; while (numBytes) { - size_t scanned = ParseAllWhiteSpace(p, numBytes, &incomplete); - p += scanned; - numBytes -= scanned; + char type; + int scanned; + + do { + scanned = ParseWhiteSpace(p, numBytes, + &parsePtr->incomplete, &type); + p += scanned; + numBytes -= scanned; + } while (numBytes && (*p == '\n') && (p++,numBytes--)); if ((numBytes == 0) || (*p != '#')) { break; } if (parsePtr->commentStart == NULL) { parsePtr->commentStart = p; } - p++; - numBytes--; - while (numBytes) { - if (*p == '\n') { - p++; - numBytes--; - break; - } - if (*p == '\\') { - p++; - numBytes--; - if (numBytes == 0) { - break; - } - } - incomplete = (*p == '\n'); - p++; - numBytes--; - } - parsePtr->commentSize = p - parsePtr->commentStart; - } - parsePtr->incomplete = incomplete; + while (numBytes) { + if (*p == '\\') { + scanned = ParseWhiteSpace(p, numBytes, &parsePtr->incomplete, + &type); + if (scanned) { + p += scanned; + numBytes -= scanned; + } else { + /* + * General backslash substitution in comments isn't part + * of the formal spec, but test parse-15.47 and history + * indicate that it has been the de facto rule. Don't + * change it now. + */ + + TclParseBackslash(p, numBytes, &scanned, NULL); + p += scanned; + numBytes -= scanned; + } + } else { + p++; + numBytes--; + if (p[-1] == '\n') { + break; + } + } + } + parsePtr->commentSize = p - parsePtr->commentStart; + } return (p - src); } /* *---------------------------------------------------------------------- @@ -1039,11 +1120,11 @@ */ static int ParseTokens( register const char *src, /* First character to parse. */ - size_t numBytes, /* Max number of bytes to scan. */ + register int numBytes, /* Max number of bytes to scan. */ int mask, /* Specifies when to stop parsing. The parse * stops at the first unquoted character whose * CHAR_TYPE contains any of the bits in * mask. */ int flags, /* OR-ed bits indicating what substitutions to @@ -1279,11 +1360,11 @@ Tcl_FreeParse( Tcl_Parse *parsePtr) /* Structure that was filled in by a previous * call to Tcl_ParseCommand. */ { if (parsePtr->tokenPtr != parsePtr->staticTokens) { - Tcl_Free(parsePtr->tokenPtr); + ckfree(parsePtr->tokenPtr); parsePtr->tokenPtr = parsePtr->staticTokens; } } /* @@ -1317,11 +1398,11 @@ Tcl_ParseVarName( Tcl_Interp *interp, /* Interpreter to use for error reporting; if * NULL, then no error message is provided. */ const char *start, /* Start of variable substitution string. * First character must be "$". */ - size_t numBytes, /* Total number of bytes in string. If -1, + register int numBytes, /* Total number of bytes in string. If < 0, * the string consists of all bytes up to the * first null character. */ Tcl_Parse *parsePtr, /* Structure to fill in with information about * the variable name. */ int append) /* Non-zero means append tokens to existing @@ -1332,19 +1413,18 @@ Tcl_Token *tokenPtr; register const char *src; int varIndex; unsigned array; - if ((numBytes == 0) || (start == NULL)) { - return TCL_ERROR; - } - if (numBytes == TCL_AUTO_LENGTH) { + if (numBytes < 0 && start) { numBytes = strlen(start); } - if (!append) { TclParseInit(interp, start, numBytes, parsePtr); + } + if ((numBytes == 0) || (start == NULL)) { + return TCL_ERROR; } /* * Generate one token for the variable, an additional token for the name, * plus any number of additional tokens for the index, if there is one. @@ -1595,11 +1675,11 @@ Tcl_ParseBraces( Tcl_Interp *interp, /* Interpreter to use for error reporting; if * NULL, then no error message is provided. */ const char *start, /* Start of string enclosed in braces. The * first character must be {'. */ - size_t numBytes, /* Total number of bytes in string. If -1, + register int numBytes, /* Total number of bytes in string. If < 0, * the string consists of all bytes up to the * first null character. */ register Tcl_Parse *parsePtr, /* Structure to fill in with information about * the string. */ @@ -1612,22 +1692,20 @@ * the terminating '}' if the parse was * successful. */ { Tcl_Token *tokenPtr; register const char *src; - int startIndex, level; - size_t length; + int startIndex, level, length; - if ((numBytes == 0) || (start == NULL)) { - return TCL_ERROR; - } - if (numBytes == TCL_AUTO_LENGTH) { + if (numBytes < 0 && start) { numBytes = strlen(start); } - if (!append) { TclParseInit(interp, start, numBytes, parsePtr); + } + if ((numBytes == 0) || (start == NULL)) { + return TCL_ERROR; } src = start; startIndex = parsePtr->numTokens; @@ -1749,11 +1827,11 @@ break; case '\n': openBrace = 0; break; case '#' : - if (openBrace && TclIsSpaceProc(src[-1])) { + if (openBrace && TclIsSpaceProcM(src[-1])) { Tcl_AppendToObj(Tcl_GetObjResult(parsePtr->interp), ": possible unbalanced brace in comment", -1); goto error; } break; @@ -1798,11 +1876,11 @@ Tcl_ParseQuotedString( Tcl_Interp *interp, /* Interpreter to use for error reporting; if * NULL, then no error message is provided. */ const char *start, /* Start of the quoted string. The first * character must be '"'. */ - size_t numBytes, /* Total number of bytes in string. If -1, + register int numBytes, /* Total number of bytes in string. If < 0, * the string consists of all bytes up to the * first null character. */ register Tcl_Parse *parsePtr, /* Structure to fill in with information about * the string. */ @@ -1813,19 +1891,18 @@ const char **termPtr) /* If non-NULL, points to word in which to * store a pointer to the character just after * the quoted string's terminating close-quote * if the parse succeeds. */ { - if ((numBytes == 0) || (start == NULL)) { - return TCL_ERROR; - } - if (numBytes == TCL_AUTO_LENGTH) { + if (numBytes < 0 && start) { numBytes = strlen(start); } - if (!append) { TclParseInit(interp, start, numBytes, parsePtr); + } + if ((numBytes == 0) || (start == NULL)) { + return TCL_ERROR; } if (TCL_OK != ParseTokens(start+1, numBytes-1, TYPE_QUOTE, TCL_SUBST_ALL, parsePtr)) { goto error; @@ -1880,16 +1957,16 @@ void TclSubstParse( Tcl_Interp *interp, const char *bytes, - size_t numBytes, + int numBytes, int flags, Tcl_Parse *parsePtr, Tcl_InterpState *statePtr) { - size_t length = numBytes; + int length = numBytes; const char *p = bytes; TclParseInit(interp, p, length, parsePtr); /* @@ -2093,11 +2170,11 @@ * commands. The 'outerScript' refers to the * most-outer script containing the embedded * command, which is refered to by 'script'. * The 'clNextOuter' refers to the current * entry in the table of continuation lines in - * this "master script", and the character + * this "main script", and the character * offsets are relative to the 'outerScript' * as well. * * If outerScript == script, then this call is * for words in the outer-most script or @@ -2142,20 +2219,20 @@ } } if (isLiteral) { maxNumCL = NUM_STATIC_POS; - clPosition = Tcl_Alloc(maxNumCL * sizeof(int)); + clPosition = ckalloc(maxNumCL * sizeof(int)); } adjust = 0; result = NULL; for (; count>0 && code==TCL_OK ; count--, tokenPtr++) { Tcl_Obj *appendObj = NULL; const char *append = NULL; int appendByteLength = 0; - char utfCharBytes[4] = ""; + char utfCharBytes[TCL_UTF_MAX] = ""; switch (tokenPtr->type) { case TCL_TOKEN_TEXT: append = tokenPtr->start; appendByteLength = tokenPtr->size; @@ -2182,21 +2259,21 @@ */ if ((appendByteLength == 1) && (utfCharBytes[0] == ' ') && (tokenPtr->start[1] == '\n')) { if (isLiteral) { - size_t clPos; + int clPos; if (result == 0) { clPos = 0; } else { - (void)TclGetStringFromObj(result, &clPos); + Tcl_GetStringFromObj(result, &clPos); } if (numCL >= maxNumCL) { maxNumCL *= 2; - clPosition = Tcl_Realloc(clPosition, + clPosition = ckrealloc(clPosition, maxNumCL * sizeof(int)); } clPosition[numCL] = clPos; numCL++; } @@ -2350,11 +2427,11 @@ * Release the temp table we used to collect the locations of * continuation lines, if any. */ if (maxNumCL) { - Tcl_Free(clPosition); + ckfree(clPosition); } } else { Tcl_ResetResult(interp); } } @@ -2388,11 +2465,11 @@ */ static inline int CommandComplete( const char *script, /* Script to check. */ - size_t numBytes) /* Number of bytes in script. */ + int numBytes) /* Number of bytes in script. */ { Tcl_Parse parse; const char *p, *end; int result; @@ -2462,12 +2539,12 @@ int TclObjCommandComplete( Tcl_Obj *objPtr) /* Points to object holding script to * check. */ { - size_t length; - const char *script = TclGetStringFromObj(objPtr, &length); + int length; + const char *script = Tcl_GetStringFromObj(objPtr, &length); return CommandComplete(script, length); } /* Index: generic/tclParse.h ================================================================== --- generic/tclParse.h +++ generic/tclParse.h @@ -10,8 +10,8 @@ #define TYPE_QUOTE 0x8 #define TYPE_CLOSE_PAREN 0x10 #define TYPE_CLOSE_BRACK 0x20 #define TYPE_BRACE 0x40 -#define CHAR_TYPE(c) tclCharTypeTable[(unsigned char)(c)] +#define CHAR_TYPE(c) (tclCharTypeTable+128)[(unsigned char)(c)] MODULE_SCOPE const char tclCharTypeTable[]; Index: generic/tclPathObj.c ================================================================== --- generic/tclPathObj.c +++ generic/tclPathObj.c @@ -23,11 +23,11 @@ static void DupFsPathInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static void FreeFsPathInternalRep(Tcl_Obj *pathPtr); static void UpdateStringOfFsPath(Tcl_Obj *pathPtr); static int SetFsPathFromAny(Tcl_Interp *interp, Tcl_Obj *pathPtr); -static size_t FindSplitPos(const char *path, int separator); +static int FindSplitPos(const char *path, int separator); static int IsSeparatorOrNull(int ch); static Tcl_Obj * GetExtension(Tcl_Obj *pathPtr); static int MakePathFromNormalized(Tcl_Interp *interp, Tcl_Obj *pathPtr); @@ -34,11 +34,11 @@ /* * Define the 'path' object type, which Tcl uses to represent file paths * internally. */ -static const Tcl_ObjType fsPathType = { +static const Tcl_ObjType tclFsPathType = { "path", /* name */ FreeFsPathInternalRep, /* freeIntRepProc */ DupFsPathInternalRep, /* dupIntRepProc */ UpdateStringOfFsPath, /* updateStringProc */ SetFsPathFromAny /* setFromAnyProc */ @@ -48,43 +48,52 @@ * struct FsPath -- * * Internal representation of a Tcl_Obj of "path" type. This can be used to * represent relative or absolute paths, and has certain optimisations when * used to represent paths which are already normalized and absolute. + * + * Note that both 'translatedPathPtr' and 'normPathPtr' can be a circular + * reference to the container Tcl_Obj of this FsPath. * * There are two cases, with the first being the most common: * * (i) flags == 0, => Ordinary path. * - * translatedPathPtr contains the translated path. If it is NULL then the path - * is pure normalized. cwdPtr is null for an absolute path, and non-null for a - * relative path (unless the cwd has never been set, in which case the cwdPtr - * may also be null for a relative path). + * translatedPathPtr contains the translated path (which may be a circular + * reference to the object itself). If it is NULL then the path is pure + * normalized (and the normPathPtr will be a circular reference). cwdPtr is + * null for an absolute path, and non-null for a relative path (unless the cwd + * has never been set, in which case the cwdPtr may also be null for a + * relative path). * * (ii) flags != 0, => Special path, see TclNewFSPathObj * * Now, this is a path like 'file join $dir $tail' where, cwdPtr is the $dir * and normPathPtr is the $tail. * */ -typedef struct { +typedef struct FsPath { Tcl_Obj *translatedPathPtr; /* Name without any ~user sequences. If this * is NULL, then this is a pure normalized, * absolute path object, in which the parent * Tcl_Obj's string rep is already both * translated and normalized. */ Tcl_Obj *normPathPtr; /* Normalized absolute path, without ., .. or - * ~user sequences. */ + * ~user sequences. If the Tcl_Obj containing + * this FsPath is already normalized, this may + * be a circular reference back to the + * container. If that is NOT the case, we have + * a refCount on the object. */ Tcl_Obj *cwdPtr; /* If null, path is absolute, else this points * to the cwd object used for this path. We * have a refCount on the object. */ int flags; /* Flags to describe interpretation - see * below. */ ClientData nativePathPtr; /* Native representation of this path, which * is filesystem dependent. */ - size_t filesystemEpoch; /* Used to ensure the path representation was + int filesystemEpoch; /* Used to ensure the path representation was * generated during the correct filesystem * epoch. The epoch changes when * filesystem-mounts are changed. */ const Tcl_Filesystem *fsPtr;/* The Tcl_Filesystem that claims this path */ } FsPath; @@ -99,18 +108,13 @@ /* * Define some macros to give us convenient access to path-object specific * fields. */ -#define PATHOBJ(pathPtr) ((FsPath *) (TclFetchIntRep((pathPtr), &fsPathType)->twoPtrValue.ptr1)) +#define PATHOBJ(pathPtr) ((FsPath *) (pathPtr)->internalRep.twoPtrValue.ptr1) #define SETPATHOBJ(pathPtr,fsPathPtr) \ - do { \ - Tcl_ObjIntRep ir; \ - ir.twoPtrValue.ptr1 = (void *) (fsPathPtr); \ - ir.twoPtrValue.ptr2 = NULL; \ - Tcl_StoreIntRep((pathPtr), &fsPathType, &ir); \ - } while (0) + ((pathPtr)->internalRep.twoPtrValue.ptr1 = (void *) (fsPathPtr)) #define PATHFLAGS(pathPtr) (PATHOBJ(pathPtr)->flags) /* *--------------------------------------------------------------------------- * @@ -219,18 +223,18 @@ again: if (IsSeparatorOrNull(dirSep[2])) { /* * Need to skip '.' in the path. */ - size_t curLen; + int curLen; if (retVal == NULL) { const char *path = TclGetString(pathPtr); retVal = Tcl_NewStringObj(path, dirSep - path); Tcl_IncrRefCount(retVal); } - (void)TclGetStringFromObj(retVal, &curLen); + Tcl_GetStringFromObj(retVal, &curLen); if (curLen == 0) { Tcl_AppendToObj(retVal, dirSep, 1); } dirSep += 2; oldDirSep = dirSep; @@ -239,11 +243,11 @@ } continue; } if (dirSep[2] == '.' && IsSeparatorOrNull(dirSep[3])) { Tcl_Obj *linkObj; - size_t curLen; + int curLen; char *linkStr; /* * Have '..' so need to skip previous directory. */ @@ -252,11 +256,11 @@ const char *path = TclGetString(pathPtr); retVal = Tcl_NewStringObj(path, dirSep - path); Tcl_IncrRefCount(retVal); } - (void)TclGetStringFromObj(retVal, &curLen); + Tcl_GetStringFromObj(retVal, &curLen); if (curLen == 0) { Tcl_AppendToObj(retVal, dirSep, 1); } if (!first || (tclPlatform == TCL_PLATFORM_UNIX)) { linkObj = Tcl_FSLink(retVal, NULL, 0); @@ -283,13 +287,13 @@ * to retVal's directory. This means concatenating * the link onto the directory of the path so far. */ const char *path = - TclGetStringFromObj(retVal, &curLen); + Tcl_GetStringFromObj(retVal, &curLen); - while (curLen-- > 0) { + while (--curLen >= 0) { if (IsSeparatorOrNull(path[curLen])) { break; } } @@ -298,11 +302,11 @@ */ Tcl_SetObjLength(retVal, curLen+1); Tcl_AppendObjToObj(retVal, linkObj); TclDecrRefCount(linkObj); - linkStr = TclGetStringFromObj(retVal, &curLen); + linkStr = Tcl_GetStringFromObj(retVal, &curLen); } else { /* * Absolute link. */ @@ -311,36 +315,36 @@ retVal = Tcl_DuplicateObj(linkObj); TclDecrRefCount(linkObj); } else { retVal = linkObj; } - linkStr = TclGetStringFromObj(retVal, &curLen); + linkStr = Tcl_GetStringFromObj(retVal, &curLen); /* * Convert to forward-slashes on windows. */ if (tclPlatform == TCL_PLATFORM_WINDOWS) { - size_t i; + int i; for (i = 0; i < curLen; i++) { if (linkStr[i] == '\\') { linkStr[i] = '/'; } } } } } else { - linkStr = TclGetStringFromObj(retVal, &curLen); + linkStr = Tcl_GetStringFromObj(retVal, &curLen); } /* * Either way, we now remove the last path element (but * not the first character of the path). */ - while (curLen-- > 0) { + while (--curLen >= 0) { if (IsSeparatorOrNull(linkStr[curLen])) { if (curLen) { Tcl_SetObjLength(retVal, curLen); } else { Tcl_SetObjLength(retVal, 1); @@ -398,12 +402,12 @@ /* * Ensure a windows drive like C:/ has a trailing separator. */ if (tclPlatform == TCL_PLATFORM_WINDOWS) { - size_t len; - const char *path = TclGetStringFromObj(retVal, &len); + int len; + const char *path = Tcl_GetStringFromObj(retVal, &len); if (len == 2 && path[0] != 0 && path[1] == ':') { if (Tcl_IsShared(retVal)) { TclDecrRefCount(retVal); retVal = Tcl_DuplicateObj(retVal); @@ -558,11 +562,11 @@ TclPathPart( Tcl_Interp *interp, /* Used for error reporting */ Tcl_Obj *pathPtr, /* Path to take dirname of */ Tcl_PathPart portion) /* Requested portion of name */ { - if (TclHasIntRep(pathPtr, &fsPathType)) { + if (pathPtr->typePtr == &tclFsPathType) { FsPath *fsPathPtr = PATHOBJ(pathPtr); if (PATHFLAGS(pathPtr) != 0) { switch (portion) { case TCL_PATH_DIRNAME: { @@ -572,12 +576,13 @@ * part with the dirname of the joined-on bit. We could handle * that special case here, but we don't, and instead just use * the standardPath code. */ - size_t numBytes; - const char *rest = TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes); + int numBytes; + const char *rest = + Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &numBytes); if (strchr(rest, '/') != NULL) { goto standardPath; } /* @@ -609,12 +614,13 @@ * it. If so, the 'tail' would be only the part following the * last delimiter. We could handle that special case here, but * we don't, and instead just use the standardPath code. */ - size_t numBytes; - const char *rest = TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes); + int numBytes; + const char *rest = + Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &numBytes); if (strchr(rest, '/') != NULL) { goto standardPath; } /* @@ -637,13 +643,13 @@ } case TCL_PATH_EXTENSION: return GetExtension(fsPathPtr->normPathPtr); case TCL_PATH_ROOT: { const char *fileName, *extension; - size_t length; + int length; - fileName = TclGetStringFromObj(fsPathPtr->normPathPtr, + fileName = Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &length); extension = TclGetExtension(fileName); if (extension == NULL) { /* * There is no extension so the root is the same as the @@ -660,11 +666,11 @@ * the tail. */ Tcl_Obj *resultPtr = TclNewFSPathObj(fsPathPtr->cwdPtr, fileName, - length - strlen(extension)); + (int)(length - strlen(extension))); Tcl_IncrRefCount(resultPtr); return resultPtr; } } @@ -688,21 +694,21 @@ standardPath: resultPtr = NULL; if (portion == TCL_PATH_EXTENSION) { return GetExtension(pathPtr); } else if (portion == TCL_PATH_ROOT) { - size_t length; + int length; const char *fileName, *extension; - fileName = TclGetStringFromObj(pathPtr, &length); + fileName = Tcl_GetStringFromObj(pathPtr, &length); extension = TclGetExtension(fileName); if (extension == NULL) { Tcl_IncrRefCount(pathPtr); return pathPtr; } else { Tcl_Obj *root = Tcl_NewStringObj(fileName, - length - strlen(extension)); + (int) (length - strlen(extension))); Tcl_IncrRefCount(root); return root; } } @@ -856,11 +862,10 @@ assert ( elements > 0 ); if (elements == 2) { Tcl_Obj *elt = objv[0]; - Tcl_ObjIntRep *eltIr = TclFetchIntRep(elt, &fsPathType); /* * This is a special case where we can be much more efficient, where * we are joining a single relative path onto an object that is * already of path type. The 'TclNewFSPathObj' call below creates an @@ -870,11 +875,11 @@ * * Bugfix [a47641a0]. TclNewFSPathObj requires first argument * to be an absolute path. Added a check for that elt is absolute. */ - if ((eltIr) + if ((elt->typePtr == &tclFsPathType) && !((elt->bytes != NULL) && (elt->bytes[0] == '\0')) && TclGetPathType(elt, NULL, NULL, NULL) == TCL_PATH_ABSOLUTE) { Tcl_Obj *tailObj = objv[1]; Tcl_PathType type; @@ -881,13 +886,13 @@ /* if forceRelative - second path is relative */ type = forceRelative ? TCL_PATH_RELATIVE : TclGetPathType(tailObj, NULL, NULL, NULL); if (type == TCL_PATH_RELATIVE) { const char *str; - size_t len; + int len; - str = TclGetStringFromObj(tailObj, &len); + str = Tcl_GetStringFromObj(tailObj, &len); if (len == 0) { /* * This happens if we try to handle the root volume '/'. * There's no need to return a special path object, when * the base itself is just fine! @@ -912,11 +917,11 @@ * all backslashes to forward slashes, so the base part * cannot have backslashes either. */ if ((tclPlatform != TCL_PLATFORM_WINDOWS) - || (strchr(TclGetString(elt), '\\') == NULL)) { + || (strchr(Tcl_GetString(elt), '\\') == NULL)) { if (PATHFLAGS(elt)) { return TclNewFSPathObj(elt, str, len); } if (TCL_PATH_ABSOLUTE != Tcl_FSGetPathType(elt)) { @@ -948,18 +953,17 @@ } assert ( res == NULL ); for (i = 0; i < elements; i++) { - int driveNameLength; - size_t strEltLen, length; + int driveNameLength, strEltLen, length; Tcl_PathType type; char *strElt, *ptr; Tcl_Obj *driveName = NULL; Tcl_Obj *elt = objv[i]; - strElt = TclGetStringFromObj(elt, &strEltLen); + strElt = Tcl_GetStringFromObj(elt, &strEltLen); driveNameLength = 0; /* if forceRelative - all paths excepting first one are relative */ type = (forceRelative && (i > 0)) ? TCL_PATH_RELATIVE : TclGetPathType(elt, &fsPtr, &driveNameLength, &driveName); if (type != TCL_PATH_RELATIVE) { @@ -1051,12 +1055,14 @@ */ noQuickReturn: if (res == NULL) { res = Tcl_NewObj(); + ptr = Tcl_GetStringFromObj(res, &length); + } else { + ptr = Tcl_GetStringFromObj(res, &length); } - ptr = TclGetStringFromObj(res, &length); /* * Strip off any './' before a tilde, unless this is the beginning of * the path. */ @@ -1085,11 +1091,11 @@ if (fsPtr->filesystemSeparatorProc != NULL) { Tcl_Obj *sep = fsPtr->filesystemSeparatorProc(res); if (sep != NULL) { separator = TclGetString(sep)[0]; - TclDecrRefCount(sep); + Tcl_DecrRefCount(sep); } /* Safety check in case the VFS driver caused sharing */ if (Tcl_IsShared(res)) { TclDecrRefCount(res); res = Tcl_DuplicateObj(res); @@ -1097,13 +1103,13 @@ } } if (length > 0 && ptr[length -1] != '/') { Tcl_AppendToObj(res, &separator, 1); - (void)TclGetStringFromObj(res, &length); + Tcl_GetStringFromObj(res, &length); } - Tcl_SetObjLength(res, length + strlen(strElt)); + Tcl_SetObjLength(res, length + (int) strlen(strElt)); ptr = TclGetString(res) + length; for (; *strElt != '\0'; strElt++) { if (*strElt == separator) { while (strElt[1] == separator) { @@ -1163,20 +1169,43 @@ * object is already of FsPath type, and is a relative path, we do have to * worry about the cwd. If the cwd has changed, we must recompute the * path. */ - if (TclHasIntRep(pathPtr, &fsPathType)) { + if (pathPtr->typePtr == &tclFsPathType) { if (TclFSEpochOk(PATHOBJ(pathPtr)->filesystemEpoch)) { return TCL_OK; } - TclGetString(pathPtr); - Tcl_StoreIntRep(pathPtr, &fsPathType, NULL); + if (pathPtr->bytes == NULL) { + UpdateStringOfFsPath(pathPtr); + } + FreeFsPathInternalRep(pathPtr); } return SetFsPathFromAny(interp, pathPtr); + + /* + * We used to have more complex code here: + * + * FsPath *fsPathPtr = PATHOBJ(pathPtr); + * if (fsPathPtr->cwdPtr == NULL || PATHFLAGS(pathPtr) != 0) { + * return TCL_OK; + * } else { + * if (TclFSCwdPointerEquals(&fsPathPtr->cwdPtr)) { + * return TCL_OK; + * } else { + * if (pathPtr->bytes == NULL) { + * UpdateStringOfFsPath(pathPtr); + * } + * FreeFsPathInternalRep(pathPtr); + * return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType); + * } + * } + * + * But we no longer believe this is necessary. + */ } /* * Helper function for normalization. */ @@ -1201,11 +1230,11 @@ * Helper function for SetFsPathFromAny. Returns position of first directory * delimiter in the path. If no separator is found, then returns the position * of the end of the string. */ -static size_t +static int FindSplitPos( const char *path, int separator) { int count = 0; @@ -1255,11 +1284,11 @@ Tcl_Obj * TclNewFSPathObj( Tcl_Obj *dirPtr, const char *addStrRep, - size_t len) + int len) { FsPath *fsPathPtr; Tcl_Obj *pathPtr; const char *p; int state = 0, count = 0; @@ -1287,11 +1316,11 @@ Tcl_DecrRefCount(tail); return pathPtr; } pathPtr = Tcl_NewObj(); - fsPathPtr = Tcl_Alloc(sizeof(FsPath)); + fsPathPtr = ckalloc(sizeof(FsPath)); /* * Set up the path. */ @@ -1304,24 +1333,26 @@ fsPathPtr->fsPtr = NULL; fsPathPtr->filesystemEpoch = 0; SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = TCLPATH_APPENDED; - TclInvalidateStringRep(pathPtr); + pathPtr->typePtr = &tclFsPathType; + pathPtr->bytes = NULL; + pathPtr->length = 0; /* * Look for path components made up of only "." * This is overly conservative analysis to keep simple. It may mark some * things as needing more aggressive normalization that don't actually * need it. No harm done. */ - for (p = addStrRep; len+1 > 1; p++, len--) { + for (p = addStrRep; len > 0; p++, len--) { switch (state) { case 0: /* So far only "." since last dirsep or start */ switch (*p) { case '.': - count = 1; + count++; break; case '/': case '\\': case ':': if (count) { @@ -1354,24 +1385,24 @@ static Tcl_Obj * AppendPath( Tcl_Obj *head, Tcl_Obj *tail) { + int numBytes; const char *bytes; Tcl_Obj *copy = Tcl_DuplicateObj(head); - size_t length; /* * This is likely buggy when dealing with virtual filesystem drivers * that use some character other than "/" as a path separator. I know * of no evidence that such a foolish thing exists. This solution was * chosen so that "JoinPath" operations that pass through either path * intrep produce the same results; that is, bugward compatibility. If * we need to fix that bug here, it needs fixing in TclJoinPath() too. */ - bytes = TclGetStringFromObj(tail, &length); - if (length == 0) { + bytes = Tcl_GetStringFromObj(tail, &numBytes); + if (numBytes == 0) { Tcl_AppendToObj(copy, "/", 1); } else { TclpNativeJoinPath(copy, bytes); } return copy; @@ -1403,15 +1434,14 @@ TclFSMakePathRelative( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *pathPtr, /* The path we have. */ Tcl_Obj *cwdPtr) /* Make it relative to this. */ { - size_t cwdLen, len; + int cwdLen, len; const char *tempStr; - Tcl_ObjIntRep *irPtr = TclFetchIntRep(pathPtr, &fsPathType); - if (irPtr) { + if (pathPtr->typePtr == &tclFsPathType) { FsPath *fsPathPtr = PATHOBJ(pathPtr); if (PATHFLAGS(pathPtr) != 0 && fsPathPtr->cwdPtr == cwdPtr) { return fsPathPtr->normPathPtr; } @@ -1426,11 +1456,11 @@ * * Note that if we get this wrong, we will strip off either too much or * too little below, leading to wrong answers returned by glob. */ - tempStr = TclGetStringFromObj(cwdPtr, &cwdLen); + tempStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen); /* * Should we perhaps use 'Tcl_FSPathSeparator'? But then what about the * Windows special case? Perhaps we should just check if cwd is a root * volume. @@ -1446,11 +1476,11 @@ if (tempStr[cwdLen-1] != '/' && tempStr[cwdLen-1] != '\\') { cwdLen++; } break; } - tempStr = TclGetStringFromObj(pathPtr, &len); + tempStr = Tcl_GetStringFromObj(pathPtr, &len); return Tcl_NewStringObj(tempStr + cwdLen, len - cwdLen); } /* @@ -1475,31 +1505,56 @@ Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *pathPtr) /* The object to convert. */ { FsPath *fsPathPtr; - if (TclHasIntRep(pathPtr, &fsPathType)) { + if (pathPtr->typePtr == &tclFsPathType) { return TCL_OK; } - fsPathPtr = Tcl_Alloc(sizeof(FsPath)); + /* + * Free old representation + */ + + if (pathPtr->typePtr != NULL) { + if (pathPtr->bytes == NULL) { + if (pathPtr->typePtr->updateStringProc == NULL) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can't find object string representation", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "WTF", + NULL); + } + return TCL_ERROR; + } + pathPtr->typePtr->updateStringProc(pathPtr); + } + TclFreeIntRep(pathPtr); + } + + fsPathPtr = ckalloc(sizeof(FsPath)); /* * It's a pure normalized absolute path. */ fsPathPtr->translatedPathPtr = NULL; - Tcl_IncrRefCount(fsPathPtr->normPathPtr = Tcl_DuplicateObj(pathPtr)); + /* + * Circular reference by design. + */ + + fsPathPtr->normPathPtr = pathPtr; fsPathPtr->cwdPtr = NULL; fsPathPtr->nativePathPtr = NULL; fsPathPtr->fsPtr = NULL; /* Remember the epoch under which we decided pathPtr was normalized */ fsPathPtr->filesystemEpoch = TclFSEpoch(); SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = 0; + pathPtr->typePtr = &tclFsPathType; return TCL_OK; } /* @@ -1514,11 +1569,11 @@ * efficient way of creating the appropriate path object type. * * Any memory which is allocated for 'clientData' should be retained * until clientData is passed to the filesystem's freeInternalRepProc * when it can be freed. The built in platform-specific filesystems use - * 'Tcl_Alloc' to allocate clientData, and Tcl_Free to free it. + * 'ckalloc' to allocate clientData, and ckfree to free it. * * Results: * NULL or a valid path object pointer, with refCount zero. * * Side effects: @@ -1546,23 +1601,37 @@ /* * Free old representation; shouldn't normally be any, but best to be * safe. */ - Tcl_StoreIntRep(pathPtr, &fsPathType, NULL); - fsPathPtr = Tcl_Alloc(sizeof(FsPath)); + if (pathPtr->typePtr != NULL) { + if (pathPtr->bytes == NULL) { + if (pathPtr->typePtr->updateStringProc == NULL) { + return NULL; + } + pathPtr->typePtr->updateStringProc(pathPtr); + } + TclFreeIntRep(pathPtr); + } + + fsPathPtr = ckalloc(sizeof(FsPath)); fsPathPtr->translatedPathPtr = NULL; - Tcl_IncrRefCount(fsPathPtr->normPathPtr = Tcl_DuplicateObj(pathPtr)); + /* + * Circular reference, by design. + */ + + fsPathPtr->normPathPtr = pathPtr; fsPathPtr->cwdPtr = NULL; fsPathPtr->nativePathPtr = clientData; fsPathPtr->fsPtr = fromFilesystem; fsPathPtr->filesystemEpoch = TclFSEpoch(); SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = 0; + pathPtr->typePtr = &tclFsPathType; return pathPtr; } /* @@ -1605,26 +1674,24 @@ * translated result we need, and can store it for future use. */ Tcl_Obj *translatedCwdPtr = Tcl_FSGetTranslatedPath(interp, srcFsPathPtr->cwdPtr); - Tcl_ObjIntRep *translatedCwdIrPtr; - if (translatedCwdPtr == NULL) { return NULL; } retObj = Tcl_FSJoinToPath(translatedCwdPtr, 1, &srcFsPathPtr->normPathPtr); - Tcl_IncrRefCount(srcFsPathPtr->translatedPathPtr = retObj); - translatedCwdIrPtr = TclFetchIntRep(translatedCwdPtr, &fsPathType); - if (translatedCwdIrPtr) { + srcFsPathPtr->translatedPathPtr = retObj; + if (translatedCwdPtr->typePtr == &tclFsPathType) { srcFsPathPtr->filesystemEpoch = PATHOBJ(translatedCwdPtr)->filesystemEpoch; } else { srcFsPathPtr->filesystemEpoch = 0; } + Tcl_IncrRefCount(retObj); Tcl_DecrRefCount(translatedCwdPtr); } else { /* * It is a pure absolute, normalized path object. This is * something like being a 'pure list'. The object's string, @@ -1672,13 +1739,13 @@ Tcl_Obj *pathPtr) { Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr); if (transPtr != NULL) { - size_t len; - const char *orig = TclGetStringFromObj(transPtr, &len); - char *result = Tcl_Alloc(len+1); + int len; + const char *orig = Tcl_GetStringFromObj(transPtr, &len); + char *result = ckalloc(len+1); memcpy(result, orig, len+1); TclDecrRefCount(transPtr); return result; } @@ -1722,22 +1789,23 @@ * This is a special path object which is the result of something like * 'file join' */ Tcl_Obj *dir, *copy; - size_t tailLen, cwdLen; - int pathType; + int tailLen, cwdLen, pathType; pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr); dir = Tcl_FSGetNormalizedPath(interp, fsPathPtr->cwdPtr); if (dir == NULL) { return NULL; } /* TODO: Figure out why this is needed. */ - TclGetString(pathPtr); + if (pathPtr->bytes == NULL) { + UpdateStringOfFsPath(pathPtr); + } - (void)TclGetStringFromObj(fsPathPtr->normPathPtr, &tailLen); + Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &tailLen); if (tailLen) { copy = AppendPath(dir, fsPathPtr->normPathPtr); } else { copy = Tcl_DuplicateObj(dir); } @@ -1746,11 +1814,11 @@ /* * We now own a reference on both 'dir' and 'copy' */ - (void) TclGetStringFromObj(dir, &cwdLen); + (void) Tcl_GetStringFromObj(dir, &cwdLen); /* Normalize the combined string. */ if (PATHFLAGS(pathPtr) & TCLPATH_NEEDNORM) { /* @@ -1783,11 +1851,11 @@ if (pathType == TCL_PATH_RELATIVE) { Tcl_Obj *origDir = fsPathPtr->cwdPtr; /* * NOTE: here we are (dangerously?) assuming that origDir points - * to a Tcl_Obj with Tcl_ObjType == &fsPathType. The + * to a Tcl_Obj with Tcl_ObjType == &tclFsPathType. The * pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr); * above that set the pathType value should have established that, * but it's far less clear on what basis we know there's been no * shimmering since then. */ @@ -1801,11 +1869,10 @@ fsPathPtr->normPathPtr = copy; /* * That's our reference to copy used. */ - copy = NULL; TclDecrRefCount(dir); TclDecrRefCount(origDir); } else { TclDecrRefCount(fsPathPtr->cwdPtr); @@ -1814,11 +1881,11 @@ fsPathPtr->normPathPtr = copy; /* * That's our reference to copy used. */ - copy = NULL; + TclDecrRefCount(dir); } PATHFLAGS(pathPtr) = 0; } @@ -1826,24 +1893,26 @@ * Ensure cwd hasn't changed. */ if (fsPathPtr->cwdPtr != NULL) { if (!TclFSCwdPointerEquals(&fsPathPtr->cwdPtr)) { - TclGetString(pathPtr); - Tcl_StoreIntRep(pathPtr, &fsPathType, NULL); + if (pathPtr->bytes == NULL) { + UpdateStringOfFsPath(pathPtr); + } + FreeFsPathInternalRep(pathPtr); if (SetFsPathFromAny(interp, pathPtr) != TCL_OK) { return NULL; } fsPathPtr = PATHOBJ(pathPtr); } else if (fsPathPtr->normPathPtr == NULL) { - size_t cwdLen; + int cwdLen; Tcl_Obj *copy; copy = AppendPath(fsPathPtr->cwdPtr, pathPtr); - (void) TclGetStringFromObj(fsPathPtr->cwdPtr, &cwdLen); - cwdLen += (TclGetString(copy)[cwdLen] == '/'); + (void) Tcl_GetStringFromObj(fsPathPtr->cwdPtr, &cwdLen); + cwdLen += (Tcl_GetString(copy)[cwdLen] == '/'); /* * Normalize the combined string, but only starting after the end * of the previously normalized 'dir'. This should be much faster! */ @@ -1853,10 +1922,11 @@ Tcl_IncrRefCount(fsPathPtr->normPathPtr); } } if (fsPathPtr->normPathPtr == NULL) { Tcl_Obj *useThisCwd = NULL; + int pureNormalized = 1; /* * Since normPathPtr is NULL, but this is a valid path object, we know * that the translatedPathPtr cannot be NULL. */ @@ -1902,10 +1972,11 @@ if (useThisCwd == NULL) { return NULL; } + pureNormalized = 0; Tcl_DecrRefCount(absolutePath); absolutePath = Tcl_FSJoinToPath(useThisCwd, 1, &absolutePath); Tcl_IncrRefCount(absolutePath); /* @@ -1921,24 +1992,48 @@ absolutePath = TclWinVolumeRelativeNormalize(interp, path, &useThisCwd); if (absolutePath == NULL) { return NULL; } + pureNormalized = 0; #endif /* _WIN32 */ } } /* * Already has refCount incremented. */ - if (fsPathPtr->normPathPtr) { - Tcl_DecrRefCount(fsPathPtr->normPathPtr); - } fsPathPtr->normPathPtr = TclFSNormalizeAbsolutePath(interp, absolutePath); + /* + * Check if path is pure normalized (this can only be the case if it + * is an absolute path). + */ + + if (pureNormalized) { + int normPathLen, pathLen; + const char *normPath; + + path = TclGetStringFromObj(pathPtr, &pathLen); + normPath = TclGetStringFromObj(fsPathPtr->normPathPtr, &normPathLen); + if ((pathLen == normPathLen) && !memcmp(path, normPath, pathLen)) { + /* + * The path was already normalized. Get rid of the duplicate. + */ + + TclDecrRefCount(fsPathPtr->normPathPtr); + + /* + * We do *not* increment the refCount for this circular + * reference. + */ + + fsPathPtr->normPathPtr = pathPtr; + } + } if (useThisCwd != NULL) { /* * We just need to free an object we allocated above for relative * paths (this was returned by Tcl_FSJoinToPath above), and then * of course store the cwd. @@ -2051,10 +2146,11 @@ } nativePathPtr = proc(pathPtr); srcFsPathPtr = PATHOBJ(pathPtr); srcFsPathPtr->nativePathPtr = nativePathPtr; + srcFsPathPtr->filesystemEpoch = TclFSEpoch(); } return srcFsPathPtr->nativePathPtr; } @@ -2081,11 +2177,11 @@ Tcl_Obj *pathPtr, const Tcl_Filesystem **fsPtrPtr) { FsPath *srcFsPathPtr; - if (!TclHasIntRep(pathPtr, &fsPathType)) { + if (pathPtr->typePtr != &tclFsPathType) { return TCL_OK; } srcFsPathPtr = PATHOBJ(pathPtr); @@ -2097,12 +2193,14 @@ if (!TclFSEpochOk(srcFsPathPtr->filesystemEpoch)) { /* * We have to discard the stale representation and recalculate it. */ - TclGetString(pathPtr); - Tcl_StoreIntRep(pathPtr, &fsPathType, NULL); + if (pathPtr->bytes == NULL) { + UpdateStringOfFsPath(pathPtr); + } + FreeFsPathInternalRep(pathPtr); if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) { return TCL_ERROR; } srcFsPathPtr = PATHOBJ(pathPtr); } @@ -2143,11 +2241,11 @@ /* * Make sure pathPtr is of the correct type. */ - if (!TclHasIntRep(pathPtr, &fsPathType)) { + if (pathPtr->typePtr != &tclFsPathType) { if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) { return; } } @@ -2178,12 +2276,11 @@ Tcl_FSEqualPaths( Tcl_Obj *firstPtr, Tcl_Obj *secondPtr) { const char *firstStr, *secondStr; - size_t firstLen, secondLen; - int tempErrno; + int firstLen, secondLen, tempErrno; if (firstPtr == secondPtr) { return 1; } @@ -2238,16 +2335,16 @@ static int SetFsPathFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *pathPtr) /* The object to convert. */ { - size_t len; + int len; FsPath *fsPathPtr; Tcl_Obj *transPtr; char *name; - if (TclHasIntRep(pathPtr, &fsPathType)) { + if (pathPtr->typePtr == &tclFsPathType) { return TCL_OK; } /* * First step is to translate the filename. This is similar to @@ -2261,19 +2358,19 @@ * However, the split/join routines are quite complex, and one has to make * sure not to break anything on Unix or Win (fCmd.test, fileName.test and * cmdAH.test exercise most of the code). */ - name = TclGetStringFromObj(pathPtr, &len); + name = Tcl_GetStringFromObj(pathPtr, &len); /* * Handle tilde substitutions, if needed. */ if (len && name[0] == '~') { Tcl_DString temp; - size_t split; + int split; char separator = '/'; /* * We have multiple cases '~/foo/bar...', '~user/foo/bar...', etc. * split becomes value 1 for '~/...' as well as for '~'. @@ -2357,12 +2454,11 @@ * Skip '~'. It's replaced by its expansion. */ objc--; objv++; while (objc--) { - TclpNativeJoinPath(transPtr, TclGetString(*objv)); - objv++; + TclpNativeJoinPath(transPtr, Tcl_GetString(*objv++)); } TclDecrRefCount(parts); } else { Tcl_Obj *pair[2]; @@ -2384,27 +2480,33 @@ /* * Now we have a translated filename in 'transPtr'. This will have forward * slashes on Windows, and will not contain any ~user sequences. */ - fsPathPtr = Tcl_Alloc(sizeof(FsPath)); + fsPathPtr = ckalloc(sizeof(FsPath)); - if (transPtr == pathPtr) { - transPtr = Tcl_DuplicateObj(pathPtr); - fsPathPtr->filesystemEpoch = 0; + fsPathPtr->translatedPathPtr = transPtr; + if (transPtr != pathPtr) { + Tcl_IncrRefCount(fsPathPtr->translatedPathPtr); + /* Redo translation when $env(HOME) changes */ + fsPathPtr->filesystemEpoch = TclFSEpoch(); } else { - fsPathPtr->filesystemEpoch = TclFSEpoch(); + fsPathPtr->filesystemEpoch = 0; } - Tcl_IncrRefCount(transPtr); - fsPathPtr->translatedPathPtr = transPtr; fsPathPtr->normPathPtr = NULL; fsPathPtr->cwdPtr = NULL; fsPathPtr->nativePathPtr = NULL; fsPathPtr->fsPtr = NULL; + /* + * Free old representation before installing our new one. + */ + + TclFreeIntRep(pathPtr); SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = 0; + pathPtr->typePtr = &tclFsPathType; return TCL_OK; } static void FreeFsPathInternalRep( @@ -2423,11 +2525,10 @@ } fsPathPtr->normPathPtr = NULL; } if (fsPathPtr->cwdPtr != NULL) { TclDecrRefCount(fsPathPtr->cwdPtr); - fsPathPtr->cwdPtr = NULL; } if (fsPathPtr->nativePathPtr != NULL && fsPathPtr->fsPtr != NULL) { Tcl_FSFreeInternalRepProc *freeProc = fsPathPtr->fsPtr->freeInternalRepProc; @@ -2435,31 +2536,42 @@ freeProc(fsPathPtr->nativePathPtr); fsPathPtr->nativePathPtr = NULL; } } - Tcl_Free(fsPathPtr); + ckfree(fsPathPtr); + pathPtr->typePtr = NULL; } static void DupFsPathInternalRep( Tcl_Obj *srcPtr, /* Path obj with internal rep to copy. */ Tcl_Obj *copyPtr) /* Path obj with internal rep to set. */ { FsPath *srcFsPathPtr = PATHOBJ(srcPtr); - FsPath *copyFsPathPtr = Tcl_Alloc(sizeof(FsPath)); + FsPath *copyFsPathPtr = ckalloc(sizeof(FsPath)); SETPATHOBJ(copyPtr, copyFsPathPtr); - copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr; - if (copyFsPathPtr->translatedPathPtr != NULL) { - Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr); + if (srcFsPathPtr->translatedPathPtr == srcPtr) { + /* Cycle in src -> make cycle in copy. */ + copyFsPathPtr->translatedPathPtr = copyPtr; + } else { + copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr; + if (copyFsPathPtr->translatedPathPtr != NULL) { + Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr); + } } - copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr; - if (copyFsPathPtr->normPathPtr != NULL) { - Tcl_IncrRefCount(copyFsPathPtr->normPathPtr); + if (srcFsPathPtr->normPathPtr == srcPtr) { + /* Cycle in src -> make cycle in copy. */ + copyFsPathPtr->normPathPtr = copyPtr; + } else { + copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr; + if (copyFsPathPtr->normPathPtr != NULL) { + Tcl_IncrRefCount(copyFsPathPtr->normPathPtr); + } } copyFsPathPtr->cwdPtr = srcFsPathPtr->cwdPtr; if (copyFsPathPtr->cwdPtr != NULL) { Tcl_IncrRefCount(copyFsPathPtr->cwdPtr); @@ -2481,10 +2593,12 @@ } else { copyFsPathPtr->nativePathPtr = NULL; } copyFsPathPtr->fsPtr = srcFsPathPtr->fsPtr; copyFsPathPtr->filesystemEpoch = srcFsPathPtr->filesystemEpoch; + + copyPtr->typePtr = &tclFsPathType; } /* *--------------------------------------------------------------------------- * @@ -2501,30 +2615,26 @@ *--------------------------------------------------------------------------- */ static void UpdateStringOfFsPath( - register Tcl_Obj *pathPtr) /* path obj with string rep to update. */ + Tcl_Obj *pathPtr) /* path obj with string rep to update. */ { FsPath *fsPathPtr = PATHOBJ(pathPtr); - size_t cwdLen; + int cwdLen; Tcl_Obj *copy; if (PATHFLAGS(pathPtr) == 0 || fsPathPtr->cwdPtr == NULL) { Tcl_Panic("Called UpdateStringOfFsPath with invalid object"); } copy = AppendPath(fsPathPtr->cwdPtr, fsPathPtr->normPathPtr); - if (Tcl_IsShared(copy)) { - copy = Tcl_DuplicateObj(copy); - } - Tcl_IncrRefCount(copy); - /* Steal copy's string rep */ - pathPtr->bytes = TclGetStringFromObj(copy, &cwdLen); + pathPtr->bytes = Tcl_GetStringFromObj(copy, &cwdLen); pathPtr->length = cwdLen; - TclInitStringRep(copy, NULL, 0); + copy->bytes = tclEmptyStringRep; + copy->length = 0; TclDecrRefCount(copy); } /* *--------------------------------------------------------------------------- @@ -2557,11 +2667,11 @@ * path (i.e. the user should be able to do 'file exists ""' without * throwing an error), but equally the path doesn't exist. Those are the * semantics of Tcl (at present anyway), so we have to abide by them here. */ - if (TclHasIntRep(pathPtr, &fsPathType)) { + if (pathPtr->typePtr == &tclFsPathType) { if (pathPtr->bytes != NULL && pathPtr->bytes[0] == '\0') { /* * We reject the empty path "". */ @@ -2572,17 +2682,17 @@ * Otherwise there is no way this path can be empty. */ } else { /* * It is somewhat unusual to reach this code path without the object - * being of fsPathType. However, we do our best to deal with the + * being of tclFsPathType. However, we do our best to deal with the * situation. */ - size_t len; + int len; - (void) TclGetStringFromObj(pathPtr, &len); + (void) Tcl_GetStringFromObj(pathPtr, &len); if (len == 0) { /* * We reject the empty path "". */ Index: generic/tclPipe.c ================================================================== --- generic/tclPipe.c +++ generic/tclPipe.c @@ -58,11 +58,11 @@ *---------------------------------------------------------------------- */ static TclFile FileForRedirect( - Tcl_Interp *interp, /* Interpreter to use for error reporting. */ + Tcl_Interp *interp, /* Intepreter to use for error reporting. */ const char *spec, /* Points to character just after redirection * character. */ int atOK, /* Non-zero means that '@' notation can be * used to specify a channel, zero means that * it isn't. */ @@ -186,11 +186,11 @@ register Detached *detPtr; int i; Tcl_MutexLock(&pipeMutex); for (i = 0; i < numPids; i++) { - detPtr = Tcl_Alloc(sizeof(Detached)); + detPtr = ckalloc(sizeof(Detached)); detPtr->pid = pidPtr[i]; detPtr->nextPtr = detList; detList = detPtr; } Tcl_MutexUnlock(&pipeMutex); @@ -219,17 +219,17 @@ void Tcl_ReapDetachedProcs(void) { register Detached *detPtr; Detached *nextPtr, *prevPtr; - int status, code; + int status; + Tcl_Pid pid; Tcl_MutexLock(&pipeMutex); for (detPtr = detList, prevPtr = NULL; detPtr != NULL; ) { - status = TclProcessWait(detPtr->pid, WNOHANG, &code, NULL, NULL); - if (status == TCL_PROCESS_UNCHANGED || (status == TCL_PROCESS_ERROR - && code != ECHILD)) { + pid = Tcl_WaitPid(detPtr->pid, &status, WNOHANG); + if ((pid == 0) || ((pid == (Tcl_Pid) -1) && (errno != ECHILD))) { prevPtr = detPtr; detPtr = detPtr->nextPtr; continue; } nextPtr = detPtr->nextPtr; @@ -236,11 +236,11 @@ if (prevPtr == NULL) { detList = detPtr->nextPtr; } else { prevPtr->nextPtr = detPtr->nextPtr; } - Tcl_Free(detPtr); + ckfree(detPtr); detPtr = nextPtr; } Tcl_MutexUnlock(&pipeMutex); } @@ -275,25 +275,42 @@ * from pipeline. NULL means there isn't any * stderr output. */ { int result = TCL_OK; int i, abnormalExit, anyErrorInfo; - TclProcessWaitStatus waitStatus; - int code; - Tcl_Obj *msg, *error; + Tcl_Pid pid; + int waitStatus; + const char *msg; + unsigned long resolvedPid; abnormalExit = 0; for (i = 0; i < numPids; i++) { - waitStatus = TclProcessWait(pidPtr[i], 0, &code, &msg, &error); - if (waitStatus == TCL_PROCESS_ERROR) { + /* + * We need to get the resolved pid before we wait on it as the windows + * implementation of Tcl_WaitPid deletes the information such that any + * following calls to TclpGetPid fail. + */ + + resolvedPid = TclpGetPid(pidPtr[i]); + pid = Tcl_WaitPid(pidPtr[i], &waitStatus, 0); + if (pid == (Tcl_Pid) -1) { result = TCL_ERROR; if (interp != NULL) { - Tcl_SetObjErrorCode(interp, error); - Tcl_SetObjResult(interp, msg); + msg = Tcl_PosixError(interp); + if (errno == ECHILD) { + /* + * This changeup in message suggested by Mark Diekhans to + * remind people that ECHILD errors can occur on some + * systems if SIGCHLD isn't in its default state. + */ + + msg = + "child process lost (is SIGCHLD ignored or trapped?)"; + } + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error waiting for process to exit: %s", msg)); } - Tcl_DecrRefCount(error); - Tcl_DecrRefCount(msg); continue; } /* * Create error messages for unusual process exits. An extra newline @@ -300,23 +317,43 @@ * gets appended to each error message, but it gets removed below (in * the same fashion that an extra newline in the command's output is * removed). */ - if (waitStatus != TCL_PROCESS_EXITED || code != 0) { + if (!WIFEXITED(waitStatus) || (WEXITSTATUS(waitStatus) != 0)) { + char msg1[TCL_INTEGER_SPACE], msg2[TCL_INTEGER_SPACE]; + result = TCL_ERROR; - if (waitStatus == TCL_PROCESS_EXITED) { + sprintf(msg1, "%lu", resolvedPid); + if (WIFEXITED(waitStatus)) { if (interp != NULL) { - Tcl_SetObjErrorCode(interp, error); + sprintf(msg2, "%u", WEXITSTATUS(waitStatus)); + Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2, NULL); } abnormalExit = 1; } else if (interp != NULL) { - Tcl_SetObjErrorCode(interp, error); - Tcl_SetObjResult(interp, msg); + const char *p; + + if (WIFSIGNALED(waitStatus)) { + p = Tcl_SignalMsg(WTERMSIG(waitStatus)); + Tcl_SetErrorCode(interp, "CHILDKILLED", msg1, + Tcl_SignalId(WTERMSIG(waitStatus)), p, NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "child killed: %s\n", p)); + } else if (WIFSTOPPED(waitStatus)) { + p = Tcl_SignalMsg(WSTOPSIG(waitStatus)); + Tcl_SetErrorCode(interp, "CHILDSUSP", msg1, + Tcl_SignalId(WSTOPSIG(waitStatus)), p, NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "child suspended: %s\n", p)); + } else { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "child wait status didn't make sense\n", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", + "ODDWAITRESULT", msg1, NULL); + } } - Tcl_DecrRefCount(error); - Tcl_DecrRefCount(msg); } } /* * Read the standard error file. If there's anything there, then return an @@ -331,14 +368,14 @@ if (interp != NULL) { int count; Tcl_Obj *objPtr; - Tcl_Seek(errorChan, 0, SEEK_SET); + Tcl_Seek(errorChan, (Tcl_WideInt)0, SEEK_SET); objPtr = Tcl_NewObj(); count = Tcl_ReadChars(errorChan, objPtr, -1, 0); - if (count == -1) { + if (count < 0) { result = TCL_ERROR; Tcl_DecrRefCount(objPtr); Tcl_ResetResult(interp); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "error reading stderr output file: %s", @@ -411,11 +448,11 @@ * redirection in the command). The file id * with which to write to this pipe is stored * at *inPipePtr. NULL means command specified * its own input source. */ TclFile *outPipePtr, /* If non-NULL, output to the pipeline goes to - * a pipe, unless overriden by redirection in + * a pipe, unless overridden by redirection in * the command. The file id with which to read * frome this pipe is stored at *outPipePtr. * NULL means command specified its own output * sink. */ TclFile *errFilePtr) /* If non-NULL, all stderr output from the @@ -822,11 +859,11 @@ * Scan through the argc array, creating a process for each group of * arguments between the "|" characters. */ Tcl_ReapDetachedProcs(); - pidPtr = Tcl_Alloc(cmdCount * sizeof(Tcl_Pid)); + pidPtr = ckalloc(cmdCount * sizeof(Tcl_Pid)); curInFile = inputFile; for (i = 0; i < argc; i = lastArg + 1) { int result, joinThisError; @@ -897,11 +934,10 @@ } Tcl_DStringFree(&execBuffer); pidPtr[numPids] = pid; numPids++; - TclProcessCreated(pid); /* * Close off our copies of file descriptors that were set up for this * child, then set up the input for the next child. */ @@ -976,11 +1012,11 @@ for (i = 0; i < numPids; i++) { if (pidPtr[i] != (Tcl_Pid) -1) { Tcl_DetachPids(1, &pidPtr[i]); } } - Tcl_Free(pidPtr); + ckfree(pidPtr); } numPids = -1; goto cleanup; } @@ -1080,11 +1116,11 @@ return channel; error: if (numPids > 0) { Tcl_DetachPids(numPids, pidPtr); - Tcl_Free(pidPtr); + ckfree(pidPtr); } if (inPipe != NULL) { TclpCloseFile(inPipe); } if (outPipe != NULL) { Index: generic/tclPkg.c ================================================================== --- generic/tclPkg.c +++ generic/tclPkg.c @@ -15,14 +15,10 @@ * package requirements. */ #include "tclInt.h" -MODULE_SCOPE char *tclEmptyStringRep; - -char *tclEmptyStringRep = &tclEmptyString; - /* * Each invocation of the "package ifneeded" command creates a structure of * the following type, which is used to load the package into the interpreter * if it is requested with a "package require" command. */ @@ -30,44 +26,30 @@ typedef struct PkgAvail { char *version; /* Version string; malloc'ed. */ char *script; /* Script to invoke to provide this version of * the package. Malloc'ed and protected by * Tcl_Preserve and Tcl_Release. */ - char *pkgIndex; /* Full file name of pkgIndex file */ struct PkgAvail *nextPtr; /* Next in list of available versions of the * same package. */ } PkgAvail; -typedef struct PkgName { - struct PkgName *nextPtr; /* Next in list of package names being - * initialized. */ - char name[1]; -} PkgName; - -typedef struct PkgFiles { - PkgName *names; /* Package names being initialized. Must be - * first field. */ - Tcl_HashTable table; /* Table which contains files for each - * package. */ -} PkgFiles; - /* * For each package that is known in any way to an interpreter, there is one * record of the following type. These records are stored in the * "packageTable" hash table in the interpreter, keyed by package name such as * "Tk" (no version number). */ -typedef struct { +typedef struct Package { Tcl_Obj *version; PkgAvail *availPtr; /* First in list of all available versions of * this package. */ const void *clientData; /* Client data. */ } Package; typedef struct Require { - void *clientDataPtr; + void * clientDataPtr; const char *name; Package *pkgPtr; char *versionToProvide; } Require; @@ -109,14 +91,14 @@ /* * Helper macros. */ #define DupBlock(v,s,len) \ - ((v) = Tcl_Alloc(len), memcpy((v),(s),(len))) + ((v) = ckalloc(len), memcpy((v),(s),(len))) #define DupString(v,s) \ do { \ - size_t local__len = strlen(s) + 1; \ + unsigned local__len = (unsigned) (strlen(s) + 1); \ DupBlock((v),(s),local__len); \ } while (0) /* *---------------------------------------------------------------------- @@ -173,17 +155,17 @@ if (CheckVersionAndConvert(interp, Tcl_GetString(pkgPtr->version), &pvi, NULL) != TCL_OK) { return TCL_ERROR; } else if (CheckVersionAndConvert(interp, version, &vi, NULL) != TCL_OK) { - Tcl_Free(pvi); + ckfree(pvi); return TCL_ERROR; } res = CompareVersions(pvi, vi, NULL); - Tcl_Free(pvi); - Tcl_Free(vi); + ckfree(pvi); + ckfree(vi); if (res == 0) { if (clientData != NULL) { pkgPtr->clientData = clientData; } @@ -221,82 +203,10 @@ * invoked to provide the package. * *---------------------------------------------------------------------- */ -static void -PkgFilesCleanupProc( - ClientData clientData, - Tcl_Interp *interp) -{ - PkgFiles *pkgFiles = (PkgFiles *) clientData; - Tcl_HashSearch search; - Tcl_HashEntry *entry; - - while (pkgFiles->names) { - PkgName *name = pkgFiles->names; - - pkgFiles->names = name->nextPtr; - Tcl_Free(name); - } - entry = Tcl_FirstHashEntry(&pkgFiles->table, &search); - while (entry) { - Tcl_Obj *obj = (Tcl_Obj *)Tcl_GetHashValue(entry); - - Tcl_DecrRefCount(obj); - entry = Tcl_NextHashEntry(&search); - } - Tcl_DeleteHashTable(&pkgFiles->table); - Tcl_Free(pkgFiles); - return; -} - -void * -TclInitPkgFiles( - Tcl_Interp *interp) -{ - /* - * If assocdata "tclPkgFiles" doesn't exist yet, create it. - */ - - PkgFiles *pkgFiles = Tcl_GetAssocData(interp, "tclPkgFiles", NULL); - - if (!pkgFiles) { - pkgFiles = Tcl_Alloc(sizeof(PkgFiles)); - pkgFiles->names = NULL; - Tcl_InitHashTable(&pkgFiles->table, TCL_STRING_KEYS); - Tcl_SetAssocData(interp, "tclPkgFiles", PkgFilesCleanupProc, pkgFiles); - } - return pkgFiles; -} - -void -TclPkgFileSeen( - Tcl_Interp *interp, - const char *fileName) -{ - PkgFiles *pkgFiles = (PkgFiles *) - Tcl_GetAssocData(interp, "tclPkgFiles", NULL); - - if (pkgFiles && pkgFiles->names) { - const char *name = pkgFiles->names->name; - Tcl_HashTable *table = &pkgFiles->table; - int new; - Tcl_HashEntry *entry = Tcl_CreateHashEntry(table, name, &new); - Tcl_Obj *list; - - if (new) { - list = Tcl_NewObj(); - Tcl_SetHashValue(entry, list); - Tcl_IncrRefCount(list); - } else { - list = Tcl_GetHashValue(entry); - } - Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj(fileName, -1)); - } -} - #undef Tcl_PkgRequire const char * Tcl_PkgRequire( Tcl_Interp *interp, /* Interpreter in which package is now * available. */ @@ -362,16 +272,16 @@ * trouble. We would like to catch that error and report a useful * message back to the user. That's what we're doing. * * Second, how does this work? If we reach this point, then the global * variable tclEmptyStringRep has the value NULL. Compare that with - * the definition of tclEmptyStringRep near the top of this file. It - * clearly should not have the value NULL; it should point to the char - * tclEmptyString. If we see it having the value NULL, then somehow we - * are seeing a Tcl library that isn't completely initialized, and - * that's an indicator for the error condition described above. - * (Further explanation is welcome.) + * the definition of tclEmptyStringRep near the top of the file + * generic/tclObj.c. It clearly should not have the value NULL; it + * should point to the char tclEmptyString. If we see it having the + * value NULL, then somehow we are seeing a Tcl library that isn't + * completely initialized, and that's an indicator for the error + * condition described above. (Further explanation is welcome.) * * Third, so what do we do about it? This situation indicates the * package we just loaded wasn't properly compiled to be stub-enabled, * yet it thinks it is stub-enabled (it called Tcl_InitStubs()). We * want to report that the package just loaded is broken, so we want @@ -379,15 +289,22 @@ * to indicate failure to Tcl_InitStubs() so that it will also fail. * (Further explanation why we don't want to Tcl_Panic() is welcome. * After all, two Tcl libraries can't be a good thing!) * * Trouble is that's going to be tricky. We're now using a Tcl library - * that's not fully initialized. Functions in it may not work - * reliably, so be very careful about adding any other calls here - * without checking how they behave when initialization is incomplete. + * that's not fully initialized. In particular, it doesn't have a + * proper value for tclEmptyStringRep. The Tcl_Obj system heavily + * depends on the value of tclEmptyStringRep and all of Tcl depends + * (increasingly) on the Tcl_Obj system, we need to correct that flaw + * before making the calls to set the interpreter result to the error + * message. That's the only flaw corrected; other problems with + * initialization of the Tcl library are not remedied, so be very + * careful about adding any other calls here without checking how they + * behave when initialization is incomplete. */ + tclEmptyStringRep = &tclEmptyString; Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Cannot load package \"%s\" in standalone executable:" " This package is not compiled with stub support", name)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNSTUBBED", NULL); return NULL; @@ -431,133 +348,93 @@ Tcl_Obj *const reqv[], /* 0 means to use the latest version * available. */ void *clientDataPtr) { RequireProcArgs args; - args.name = name; args.clientDataPtr = clientDataPtr; - return Tcl_NRCallObjProc(interp, - TclNRPkgRequireProc, (void *) &args, reqc, reqv); + return Tcl_NRCallObjProc(interp, TclNRPkgRequireProc, (void *)&args, reqc, reqv); } static int TclNRPkgRequireProc( ClientData clientData, Tcl_Interp *interp, int reqc, - Tcl_Obj *const reqv[]) -{ + Tcl_Obj *const reqv[]) { RequireProcArgs *args = clientData; - - Tcl_NRAddCallback(interp, - PkgRequireCore, (void *) args->name, INT2PTR(reqc), (void *) reqv, - args->clientDataPtr); + Tcl_NRAddCallback(interp, PkgRequireCore, (void *)args->name, INT2PTR(reqc), (void *)reqv, args->clientDataPtr); return TCL_OK; } static int -PkgRequireCore( - ClientData data[], - Tcl_Interp *interp, - int result) +PkgRequireCore(ClientData data[], Tcl_Interp *interp, int result) { const char *name = data[0]; int reqc = PTR2INT(data[1]); Tcl_Obj *const *reqv = data[2]; int code = CheckAllRequirements(interp, reqc, reqv); Require *reqPtr; - if (code != TCL_OK) { return code; } - reqPtr = Tcl_Alloc(sizeof(Require)); + reqPtr = ckalloc(sizeof(Require)); Tcl_NRAddCallback(interp, PkgRequireCoreCleanup, reqPtr, NULL, NULL, NULL); reqPtr->clientDataPtr = data[3]; reqPtr->name = name; reqPtr->pkgPtr = FindPackage(interp, name); if (reqPtr->pkgPtr->version == NULL) { - Tcl_NRAddCallback(interp, - SelectPackage, reqPtr, INT2PTR(reqc), (void *) reqv, - PkgRequireCoreStep1); + Tcl_NRAddCallback(interp, SelectPackage, reqPtr, INT2PTR(reqc), (void *)reqv, PkgRequireCoreStep1); } else { - Tcl_NRAddCallback(interp, - PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *) reqv,NULL); + Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); } return TCL_OK; } static int -PkgRequireCoreStep1( - ClientData data[], - Tcl_Interp *interp, - int result) -{ +PkgRequireCoreStep1(ClientData data[], Tcl_Interp *interp, int result) { Tcl_DString command; char *script; Require *reqPtr = data[0]; int reqc = PTR2INT(data[1]); Tcl_Obj **const reqv = data[2]; const char *name = reqPtr->name /* Name of desired package. */; - - /* - * If we've got the package in the DB already, go on to actually loading - * it. - */ - - if (reqPtr->pkgPtr->version != NULL) { - Tcl_NRAddCallback(interp, - PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); - return TCL_OK; - } - - /* - * The package is not in the database. If there is a "package unknown" - * command, invoke it. - */ - - script = ((Interp *) interp)->packageUnknown; - if (script == NULL) { - /* - * No package unknown script. Move on to finalizing. - */ - - Tcl_NRAddCallback(interp, - PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); - return TCL_OK; - } - - /* - * Invoke the "package unknown" script synchronously. - */ - - Tcl_DStringInit(&command); - Tcl_DStringAppend(&command, script, -1); - Tcl_DStringAppendElement(&command, name); - AddRequirementsToDString(&command, reqc, reqv); - - Tcl_NRAddCallback(interp, - PkgRequireCoreStep2, reqPtr, INT2PTR(reqc), (void *) reqv, NULL); - Tcl_NREvalObj(interp, - Tcl_NewStringObj(Tcl_DStringValue(&command), - Tcl_DStringLength(&command)), - TCL_EVAL_GLOBAL); - Tcl_DStringFree(&command); + if (reqPtr->pkgPtr->version == NULL) { + /* + * The package is not in the database. If there is a "package unknown" + * command, invoke it. + */ + + script = ((Interp *) interp)->packageUnknown; + if (script == NULL) { + Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + } else { + Tcl_DStringInit(&command); + Tcl_DStringAppend(&command, script, -1); + Tcl_DStringAppendElement(&command, name); + AddRequirementsToDString(&command, reqc, reqv); + + Tcl_NRAddCallback(interp, PkgRequireCoreStep2, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + Tcl_NREvalObj(interp, + Tcl_NewStringObj(Tcl_DStringValue(&command), Tcl_DStringLength(&command)), + TCL_EVAL_GLOBAL + ); + Tcl_DStringFree(&command); + } + return TCL_OK; + } else { + Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + } return TCL_OK; } static int -PkgRequireCoreStep2( - ClientData data[], - Tcl_Interp *interp, - int result) -{ +PkgRequireCoreStep2(ClientData data[], Tcl_Interp *interp, int result) { Require *reqPtr = data[0]; int reqc = PTR2INT(data[1]); Tcl_Obj **const reqv = data[2]; - const char *name = reqPtr->name; /* Name of desired package. */ - + const char *name = reqPtr->name /* Name of desired package. */; if ((result != TCL_OK) && (result != TCL_ERROR)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad return code: %d", result)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); result = TCL_ERROR; @@ -566,35 +443,24 @@ Tcl_AddErrorInfo(interp, "\n (\"package unknown\" script)"); return result; } Tcl_ResetResult(interp); - - /* - * pkgPtr may now be invalid, so refresh it. - */ - + /* pkgPtr may now be invalid, so refresh it. */ reqPtr->pkgPtr = FindPackage(interp, name); - Tcl_NRAddCallback(interp, - SelectPackage, reqPtr, INT2PTR(reqc), (void *) reqv, - PkgRequireCoreFinal); + Tcl_NRAddCallback(interp, SelectPackage, reqPtr, INT2PTR(reqc), (void *)reqv, PkgRequireCoreFinal); return TCL_OK; } static int -PkgRequireCoreFinal( - ClientData data[], - Tcl_Interp *interp, - int result) -{ +PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result) { Require *reqPtr = data[0]; int reqc = PTR2INT(data[1]), satisfies; Tcl_Obj **const reqv = data[2]; char *pkgVersionI; void *clientDataPtr = reqPtr->clientDataPtr; - const char *name = reqPtr->name; /* Name of desired package. */ - + const char *name = reqPtr->name /* Name of desired package. */; if (reqPtr->pkgPtr->version == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't find package %s", name)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL); AddRequirementsToResult(interp, reqc, reqv); @@ -608,11 +474,11 @@ if (reqc != 0) { CheckVersionAndConvert(interp, Tcl_GetString(reqPtr->pkgPtr->version), &pkgVersionI, NULL); satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv); - Tcl_Free(pkgVersionI); + ckfree(pkgVersionI); if (!satisfies) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "version conflict for package \"%s\": have %s, need", name, Tcl_GetString(reqPtr->pkgPtr->version))); @@ -631,25 +497,18 @@ Tcl_SetObjResult(interp, reqPtr->pkgPtr->version); return TCL_OK; } static int -PkgRequireCoreCleanup( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - Tcl_Free(data[0]); +PkgRequireCoreCleanup(ClientData data[], Tcl_Interp *interp, int result) { + ckfree(data[0]); return result; } + static int -SelectPackage( - ClientData data[], - Tcl_Interp *interp, - int result) -{ +SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { PkgAvail *availPtr, *bestPtr, *bestStablePtr; char *availVersion, *bestVersion, *bestStableVersion; /* Internal rep. of versions */ int availStable, satisfies; Require *reqPtr = data[0]; @@ -673,14 +532,14 @@ Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL); return TCL_ERROR; } /* - * The package isn't yet present. Search the list of available versions - * and invoke the script for the best available version. We are actually - * locating the best, and the best stable version. One of them is then - * chosen based on the selection mode. + * The package isn't yet present. Search the list of available + * versions and invoke the script for the best available version. We + * are actually locating the best, and the best stable version. One of + * them is then chosen based on the selection mode. */ bestPtr = NULL; bestStablePtr = NULL; bestVersion = NULL; @@ -689,27 +548,23 @@ for (availPtr = pkgPtr->availPtr; availPtr != NULL; availPtr = availPtr->nextPtr) { if (CheckVersionAndConvert(interp, availPtr->version, &availVersion, &availStable) != TCL_OK) { /* - * The provided version number has invalid syntax. This should not - * happen. This should have been caught by the 'package ifneeded' - * registering the package. + * The provided version number has invalid syntax. This + * should not happen. This should have been caught by the + * 'package ifneeded' registering the package. */ continue; } - /* - * Check satisfaction of requirements before considering the current - * version further. - */ - + /* Check satisfaction of requirements before considering the current version further. */ if (reqc > 0) { satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv); if (!satisfies) { - Tcl_Free(availVersion); + ckfree(availVersion); availVersion = NULL; continue; } } @@ -723,27 +578,24 @@ if (res > 0) { /* * The version of the package sought is better than the * currently selected version. */ - - Tcl_Free(bestVersion); + ckfree(bestVersion); bestVersion = NULL; goto newbest; } } else { newbest: - /* - * We have found a version which is better than our max. - */ + /* We have found a version which is better than our max. */ bestPtr = availPtr; CheckVersionAndConvert(interp, bestPtr->version, &bestVersion, NULL); } if (!availStable) { - Tcl_Free(availVersion); + ckfree(availVersion); availVersion = NULL; continue; } if (bestStablePtr != NULL) { @@ -753,121 +605,82 @@ * Note: Used internal reps in the comparison! */ if (res > 0) { /* - * This stable version of the package sought is better than - * the currently selected stable version. + * This stable version of the package sought is better + * than the currently selected stable version. */ - - Tcl_Free(bestStableVersion); + ckfree(bestStableVersion); bestStableVersion = NULL; goto newstable; } } else { newstable: - /* - * We have found a stable version which is better than our max - * stable. - */ - + /* We have found a stable version which is better than our max stable. */ bestStablePtr = availPtr; - CheckVersionAndConvert(interp, bestStablePtr->version, - &bestStableVersion, NULL); + CheckVersionAndConvert(interp, bestStablePtr->version, &bestStableVersion, NULL); } - Tcl_Free(availVersion); + ckfree(availVersion); availVersion = NULL; } /* end for */ /* * Clean up memorized internal reps, if any. */ if (bestVersion != NULL) { - Tcl_Free(bestVersion); + ckfree(bestVersion); bestVersion = NULL; } if (bestStableVersion != NULL) { - Tcl_Free(bestStableVersion); + ckfree(bestStableVersion); bestStableVersion = NULL; } /* - * Now choose a version among the two best. For 'latest' we simply take - * (actually keep) the best. For 'stable' we take the best stable, if - * there is any, or the best if there is nothing stable. + * Now choose a version among the two best. For 'latest' we simply + * take (actually keep) the best. For 'stable' we take the best + * stable, if there is any, or the best if there is nothing stable. */ if ((iPtr->packagePrefer == PKG_PREFER_STABLE) && (bestStablePtr != NULL)) { bestPtr = bestStablePtr; } if (bestPtr == NULL) { - Tcl_NRAddCallback(interp, - data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + Tcl_NRAddCallback(interp, data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL); } else { /* * We found an ifneeded script for the package. Be careful while * executing it: this could cause reentrancy, so (a) protect the - * script itself from deletion and (b) don't assume that bestPtr will - * still exist when the script completes. + * script itself from deletion and (b) don't assume that bestPtr + * will still exist when the script completes. */ char *versionToProvide = bestPtr->version; - PkgFiles *pkgFiles; - PkgName *pkgName; + pkgPtr->clientData = versionToProvide; Tcl_Preserve(versionToProvide); - pkgPtr->clientData = versionToProvide; - - pkgFiles = TclInitPkgFiles(interp); - - /* - * Push "ifneeded" package name in "tclPkgFiles" assocdata. - */ - - pkgName = Tcl_Alloc(sizeof(PkgName) + strlen(name)); - pkgName->nextPtr = pkgFiles->names; - strcpy(pkgName->name, name); - pkgFiles->names = pkgName; - if (bestPtr->pkgIndex) { - TclPkgFileSeen(interp, bestPtr->pkgIndex); - } reqPtr->versionToProvide = versionToProvide; - Tcl_NRAddCallback(interp, - SelectPackageFinal, reqPtr, INT2PTR(reqc), (void *)reqv, - data[3]); - Tcl_NREvalObj(interp, Tcl_NewStringObj(bestPtr->script, -1), - TCL_EVAL_GLOBAL); + Tcl_NRAddCallback(interp, SelectPackageFinal, reqPtr, INT2PTR(reqc), (void *)reqv, data[3]); + Tcl_NREvalObj(interp, Tcl_NewStringObj(bestPtr->script, -1), TCL_EVAL_GLOBAL); } return TCL_OK; } static int -SelectPackageFinal( - ClientData data[], - Tcl_Interp *interp, - int result) -{ +SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) { Require *reqPtr = data[0]; int reqc = PTR2INT(data[1]); Tcl_Obj **const reqv = data[2]; const char *name = reqPtr->name; char *versionToProvide = reqPtr->versionToProvide; - /* - * Pop the "ifneeded" package name from "tclPkgFiles" assocdata - */ - - PkgFiles *pkgFiles = Tcl_GetAssocData(interp, "tclPkgFiles", NULL); - PkgName *pkgName = pkgFiles->names; - pkgFiles->names = pkgName->nextPtr; - Tcl_Free(pkgName); - reqPtr->pkgPtr = FindPackage(interp, name); if (result == TCL_OK) { Tcl_ResetResult(interp); if (reqPtr->pkgPtr->version == NULL) { result = TCL_ERROR; @@ -883,17 +696,17 @@ if (TCL_OK != CheckVersionAndConvert(interp, Tcl_GetString(reqPtr->pkgPtr->version), &pvi, NULL)) { result = TCL_ERROR; } else if (CheckVersionAndConvert(interp, versionToProvide, &vi, NULL) != TCL_OK) { - Tcl_Free(pvi); + ckfree(pvi); result = TCL_ERROR; } else { int res = CompareVersions(pvi, vi, NULL); - Tcl_Free(pvi); - Tcl_Free(vi); + ckfree(pvi); + ckfree(vi); if (res != 0) { result = TCL_ERROR; Tcl_SetObjResult(interp, Tcl_ObjPrintf( "attempt to provide package %s %s failed:" " package %s %s provided instead", @@ -903,12 +716,13 @@ "WRONGPROVIDE", NULL); } } } } else if (result != TCL_ERROR) { - Tcl_Obj *codePtr = Tcl_NewIntObj(result); + Tcl_Obj *codePtr; + TclNewIntObj(codePtr, result); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "attempt to provide package %s %s failed:" " bad return code: %s", name, versionToProvide, TclGetString(codePtr))); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); @@ -923,17 +737,18 @@ } Tcl_Release(versionToProvide); if (result != TCL_OK) { /* - * Take a non-TCL_OK code from the script as an indication the package - * wasn't loaded properly, so the package system should not remember - * an improper load. + * Take a non-TCL_OK code from the script as an indication the + * package wasn't loaded properly, so the package system + * should not remember an improper load. * - * This is consistent with our returning NULL. If we're not willing to - * tell our caller we got a particular version, we shouldn't store - * that version for telling future callers either. + * This is consistent with our returning NULL. If we're not + * willing to tell our caller we got a particular version, we + * shouldn't store that version for telling future callers + * either. */ if (reqPtr->pkgPtr->version != NULL) { Tcl_DecrRefCount(reqPtr->pkgPtr->version); reqPtr->pkgPtr->version = NULL; @@ -940,12 +755,11 @@ } reqPtr->pkgPtr->clientData = NULL; return result; } - Tcl_NRAddCallback(interp, - data[3], reqPtr, INT2PTR(reqc), (void *) reqv, NULL); + Tcl_NRAddCallback(interp, data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -1067,18 +881,18 @@ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { static const char *const pkgOptions[] = { - "files", "forget", "ifneeded", "names", "prefer", - "present", "provide", "require", "unknown", "vcompare", - "versions", "vsatisfies", NULL + "forget", "ifneeded", "names", "prefer", "present", + "provide", "require", "unknown", "vcompare", "versions", + "vsatisfies", NULL }; enum pkgOptions { - PKG_FILES, PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PREFER, - PKG_PRESENT, PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE, - PKG_VERSIONS, PKG_VSATISFIES + PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PREFER, PKG_PRESENT, + PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE, PKG_VERSIONS, + PKG_VSATISFIES }; Interp *iPtr = (Interp *) interp; int optionIndex, exact, i, newobjc, satisfies; PkgAvail *availPtr, *prevPtr; Package *pkgPtr; @@ -1098,44 +912,15 @@ if (Tcl_GetIndexFromObj(interp, objv[1], pkgOptions, "option", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } switch ((enum pkgOptions) 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); - if (pkgFiles) { - Tcl_HashEntry *entry = Tcl_FindHashEntry(&pkgFiles->table, - TclGetString(objv[2])); - - if (entry) { - Tcl_SetObjResult(interp, (Tcl_Obj *)Tcl_GetHashValue(entry)); - } - } - 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]); - if (pkgFiles) { - hPtr = Tcl_FindHashEntry(&pkgFiles->table, keyString); - if (hPtr) { - Tcl_Obj *obj = Tcl_GetHashValue(hPtr); - Tcl_DeleteHashEntry(hPtr); - Tcl_DecrRefCount(obj); - } - } - hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString); if (hPtr == NULL) { continue; } pkgPtr = Tcl_GetHashValue(hPtr); @@ -1146,23 +931,18 @@ while (pkgPtr->availPtr != NULL) { availPtr = pkgPtr->availPtr; pkgPtr->availPtr = availPtr->nextPtr; Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC); Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); - if (availPtr->pkgIndex) { - Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC); - availPtr->pkgIndex = NULL; - } - Tcl_Free(availPtr); + ckfree(availPtr); } - Tcl_Free(pkgPtr); + ckfree(pkgPtr); } break; } case PKG_IFNEEDED: { - size_t length; - int res; + int length, res; char *argv3i, *avi; if ((objc != 4) && (objc != 5)) { Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?"); return TCL_ERROR; @@ -1173,69 +953,60 @@ } argv2 = TclGetString(objv[2]); if (objc == 4) { hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); if (hPtr == NULL) { - Tcl_Free(argv3i); + ckfree(argv3i); return TCL_OK; } pkgPtr = Tcl_GetHashValue(hPtr); } else { pkgPtr = FindPackage(interp, argv2); } - argv3 = TclGetStringFromObj(objv[3], &length); + argv3 = Tcl_GetStringFromObj(objv[3], &length); for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL; prevPtr = availPtr, availPtr = availPtr->nextPtr) { if (CheckVersionAndConvert(interp, availPtr->version, &avi, NULL) != TCL_OK) { - Tcl_Free(argv3i); + ckfree(argv3i); return TCL_ERROR; } res = CompareVersions(avi, argv3i, NULL); - Tcl_Free(avi); + ckfree(avi); - if (res == 0) { + if (res == 0){ if (objc == 4) { - Tcl_Free(argv3i); + ckfree(argv3i); Tcl_SetObjResult(interp, Tcl_NewStringObj(availPtr->script, -1)); return TCL_OK; } Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); - if (availPtr->pkgIndex) { - Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC); - availPtr->pkgIndex = NULL; - } break; } } - Tcl_Free(argv3i); + ckfree(argv3i); if (objc == 4) { return TCL_OK; } if (availPtr == NULL) { - availPtr = Tcl_Alloc(sizeof(PkgAvail)); - availPtr->pkgIndex = NULL; - DupBlock(availPtr->version, argv3, length + 1); + availPtr = ckalloc(sizeof(PkgAvail)); + DupBlock(availPtr->version, argv3, (unsigned) length + 1); if (prevPtr == NULL) { availPtr->nextPtr = pkgPtr->availPtr; pkgPtr->availPtr = availPtr; } else { availPtr->nextPtr = prevPtr->nextPtr; prevPtr->nextPtr = availPtr; } } - if (iPtr->scriptFile) { - argv4 = TclGetStringFromObj(iPtr->scriptFile, &length); - DupBlock(availPtr->pkgIndex, argv4, length + 1); - } - argv4 = TclGetStringFromObj(objv[4], &length); - DupBlock(availPtr->script, argv4, length + 1); + argv4 = Tcl_GetStringFromObj(objv[4], &length); + DupBlock(availPtr->script, argv4, (unsigned) length + 1); break; } case PKG_NAMES: if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); @@ -1361,61 +1132,55 @@ objvListPtr = Tcl_NewListObj(0, NULL); Tcl_IncrRefCount(objvListPtr); Tcl_ListObjAppendElement(interp, objvListPtr, ov); Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); - Tcl_NRAddCallback(interp, - TclNRPackageObjCmdCleanup, objv[3], objvListPtr, NULL,NULL); - Tcl_NRAddCallback(interp, - PkgRequireCore, (void *) argv3, INT2PTR(newobjc), - newObjvPtr, NULL); + Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[3], objvListPtr, NULL, NULL); + Tcl_NRAddCallback(interp, PkgRequireCore, (void *)argv3, INT2PTR(newobjc), newObjvPtr, NULL); return TCL_OK; } else { - int i, newobjc = objc-3; Tcl_Obj *const *newobjv = objv + 3; + newobjc = objc - 3; - if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) { + if (CheckAllRequirements(interp, objc - 3, objv + 3) != TCL_OK) { return TCL_ERROR; } objvListPtr = Tcl_NewListObj(0, NULL); Tcl_IncrRefCount(objvListPtr); Tcl_IncrRefCount(objv[2]); for (i = 0; i < newobjc; i++) { + /* * Tcl_Obj structures may have come from another interpreter, * so duplicate them. */ - Tcl_ListObjAppendElement(interp, objvListPtr, - Tcl_DuplicateObj(newobjv[i])); + Tcl_ListObjAppendElement(interp, objvListPtr, Tcl_DuplicateObj(newobjv[i])); } Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); - Tcl_NRAddCallback(interp, - TclNRPackageObjCmdCleanup, objv[2], objvListPtr, NULL,NULL); - Tcl_NRAddCallback(interp, - PkgRequireCore, (void *) argv2, INT2PTR(newobjc), - newObjvPtr, NULL); + Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[2], objvListPtr, NULL, NULL); + Tcl_NRAddCallback(interp, PkgRequireCore, (void *)argv2, INT2PTR(newobjc), newObjvPtr, NULL); return TCL_OK; } break; case PKG_UNKNOWN: { - size_t length; + int length; 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); + ckfree(iPtr->packageUnknown); } - argv2 = TclGetStringFromObj(objv[2], &length); + argv2 = Tcl_GetStringFromObj(objv[2], &length); if (argv2[0] == 0) { iPtr->packageUnknown = NULL; } else { - DupBlock(iPtr->packageUnknown, argv2, length+1); + DupBlock(iPtr->packageUnknown, argv2, (unsigned) length+1); } } else { Tcl_WrongNumArgs(interp, 2, objv, "?command?"); return TCL_ERROR; } @@ -1466,11 +1231,11 @@ argv3 = TclGetString(objv[3]); argv2 = TclGetString(objv[2]); if (CheckVersionAndConvert(interp, argv2, &iva, NULL) != TCL_OK || CheckVersionAndConvert(interp, argv3, &ivb, NULL) != TCL_OK) { if (iva != NULL) { - Tcl_Free(iva); + ckfree(iva); } /* * ivb cannot be set in this branch. */ @@ -1482,12 +1247,12 @@ * Comparison is done on the internal representation. */ Tcl_SetObjResult(interp, Tcl_NewIntObj(CompareVersions(iva, ivb, NULL))); - Tcl_Free(iva); - Tcl_Free(ivb); + ckfree(iva); + ckfree(ivb); break; case PKG_VERSIONS: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "package"); return TCL_ERROR; @@ -1517,16 +1282,16 @@ argv2 = TclGetString(objv[2]); if (CheckVersionAndConvert(interp, argv2, &argv2i, NULL) != TCL_OK) { return TCL_ERROR; } else if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) { - Tcl_Free(argv2i); + ckfree(argv2i); return TCL_ERROR; } satisfies = SomeRequirementSatisfied(argv2i, objc-3, objv+3); - Tcl_Free(argv2i); + ckfree(argv2i); Tcl_SetObjResult(interp, Tcl_NewBooleanObj(satisfies)); break; } default: @@ -1534,17 +1299,13 @@ } return TCL_OK; } static int -TclNRPackageObjCmdCleanup( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - TclDecrRefCount((Tcl_Obj *) data[0]); - TclDecrRefCount((Tcl_Obj *) data[1]); +TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int result) { + TclDecrRefCount((Tcl_Obj *)data[0]); + TclDecrRefCount((Tcl_Obj *)data[1]); return result; } /* *---------------------------------------------------------------------- @@ -1574,11 +1335,11 @@ int isNew; Package *pkgPtr; hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &isNew); if (isNew) { - pkgPtr = Tcl_Alloc(sizeof(Package)); + pkgPtr = ckalloc(sizeof(Package)); pkgPtr->version = NULL; pkgPtr->availPtr = NULL; pkgPtr->clientData = NULL; Tcl_SetHashValue(hPtr, pkgPtr); } else { @@ -1604,11 +1365,11 @@ *---------------------------------------------------------------------- */ void TclFreePackageInfo( - Interp *iPtr) /* Interpreter that is being deleted. */ + Interp *iPtr) /* Interpereter that is being deleted. */ { Package *pkgPtr; Tcl_HashSearch search; Tcl_HashEntry *hPtr; PkgAvail *availPtr; @@ -1622,21 +1383,17 @@ while (pkgPtr->availPtr != NULL) { availPtr = pkgPtr->availPtr; pkgPtr->availPtr = availPtr->nextPtr; Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC); Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); - if (availPtr->pkgIndex) { - Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC); - availPtr->pkgIndex = NULL; - } - Tcl_Free(availPtr); + ckfree(availPtr); } - Tcl_Free(pkgPtr); + ckfree(pkgPtr); } Tcl_DeleteHashTable(&iPtr->packageTable); if (iPtr->packageUnknown != NULL) { - Tcl_Free(iPtr->packageUnknown); + ckfree(iPtr->packageUnknown); } } /* *---------------------------------------------------------------------- @@ -1672,11 +1429,11 @@ int hasunstable = 0; /* * 4* assuming that each char is a separator (a,b become ' -x '). * 4+ to have spce for an additional -2 at the end */ - char *ibuf = Tcl_Alloc(4 + 4*strlen(string)); + char *ibuf = ckalloc(4 + 4*strlen(string)); char *ip = ibuf; /* * Basic rules * (1) First character has to be a digit. @@ -1740,20 +1497,20 @@ if (prevChar!='.' && prevChar!='a' && prevChar!='b') { *ip = '\0'; if (internal != NULL) { *internal = ibuf; } else { - Tcl_Free(ibuf); + ckfree(ibuf); } if (stable != NULL) { *stable = !hasunstable; } return TCL_OK; } error: - Tcl_Free(ibuf); + ckfree(ibuf); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected version number but got \"%s\"", string)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSION", NULL); return TCL_ERROR; } @@ -2023,11 +1780,11 @@ /* * Exactly one dash is present. Copy the string, split at the location of * dash and check that both parts are versions. Note that the max part can * be empty. Also note that the string allocated with strdup() must be - * freed with free() and not Tcl_Free(). + * freed with free() and not ckfree(). */ DupString(buf, string); dash = buf + (dash - string); *dash = '\0'; /* buf now <=> min part */ @@ -2034,15 +1791,15 @@ dash++; /* dash now <=> max part */ if ((CheckVersionAndConvert(interp, buf, NULL, NULL) != TCL_OK) || ((*dash != '\0') && (CheckVersionAndConvert(interp, dash, NULL, NULL) != TCL_OK))) { - Tcl_Free(buf); + ckfree(buf); return TCL_ERROR; } - Tcl_Free(buf); + ckfree(buf); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -2067,15 +1824,14 @@ * version. */ Tcl_Obj *const reqv[]) /* 0 means to use the latest version * available. */ { Tcl_Obj *result = Tcl_GetObjResult(interp); - int i; - size_t length; + int i, length; for (i = 0; i < reqc; i++) { - const char *v = TclGetStringFromObj(reqv[i], &length); + const char *v = Tcl_GetStringFromObj(reqv[i], &length); if ((length & 0x1) && (v[length/2] == '-') && (strncmp(v, v+((length+1)/2), length/2) == 0)) { Tcl_AppendPrintfToObj(result, " exactly %s", v+((length+1)/2)); } else { @@ -2204,11 +1960,11 @@ CheckVersionAndConvert(NULL, req, &reqi, NULL); strcat(reqi, " -2"); res = CompareVersions(havei, reqi, &thisIsMajor); satisfied = (res == 0) || ((res == 1) && !thisIsMajor); - Tcl_Free(reqi); + ckfree(reqi); return satisfied; } /* * Exactly one dash is present (Assumption of valid syntax). Copy the req, @@ -2228,12 +1984,12 @@ */ CheckVersionAndConvert(NULL, buf, &min, NULL); strcat(min, " -2"); satisfied = (CompareVersions(havei, min, NULL) >= 0); - Tcl_Free(min); - Tcl_Free(buf); + ckfree(min); + ckfree(buf); return satisfied; } /* * We have both min and max, and generate their internal reps. When @@ -2251,13 +2007,13 @@ strcat(max, " -2"); satisfied = ((CompareVersions(min, havei, NULL) <= 0) && (CompareVersions(havei, max, NULL) < 0)); } - Tcl_Free(min); - Tcl_Free(max); - Tcl_Free(buf); + ckfree(min); + ckfree(max); + ckfree(buf); return satisfied; } /* *---------------------------------------------------------------------- @@ -2282,27 +2038,27 @@ Tcl_PkgInitStubsCheck( Tcl_Interp *interp, const char * version, int exact) { - const char *actualVersion = Tcl_PkgPresentEx(interp, "Tcl", version, 0, NULL); + const char *actualVersion = Tcl_PkgPresent(interp, "Tcl", version, 0); - if ((exact&1) && actualVersion) { + if (exact && actualVersion) { const char *p = version; int count = 0; while (*p) { count += !isdigit(UCHAR(*p++)); } if (count == 1) { if (0 != strncmp(version, actualVersion, strlen(version))) { /* Construct error message */ - Tcl_PkgPresentEx(interp, "Tcl", version, 1, NULL); + Tcl_PkgPresent(interp, "Tcl", version, 1); return NULL; } } else { - return Tcl_PkgPresentEx(interp, "Tcl", version, 1, NULL); + return Tcl_PkgPresent(interp, "Tcl", version, 1); } } return actualVersion; } /* Index: generic/tclPkgConfig.c ================================================================== --- generic/tclPkgConfig.c +++ generic/tclPkgConfig.c @@ -33,16 +33,24 @@ * configuration values. */ #include "tclInt.h" +#ifndef TCL_CFGVAL_ENCODING +# ifdef _WIN32 +# define TCL_CFGVAL_ENCODING "cp1252" +# else +# define TCL_CFGVAL_ENCODING "iso8859-1" +# endif +#endif + /* * Use C preprocessor statements to define the various values for the embedded * configuration information. */ -#if TCL_THREADS +#ifdef TCL_THREADS # define CFG_THREADED "1" #else # define CFG_THREADED "0" #endif @@ -103,12 +111,10 @@ {"libdir,runtime", CFG_RUNTIME_LIBDIR}, {"bindir,runtime", CFG_RUNTIME_BINDIR}, {"scriptdir,runtime", CFG_RUNTIME_SCRDIR}, {"includedir,runtime", CFG_RUNTIME_INCDIR}, {"docdir,runtime", CFG_RUNTIME_DOCDIR}, - {"dllfile,runtime", CFG_RUNTIME_DLLFILE}, - {"zipfile,runtime", CFG_RUNTIME_ZIPFILE}, /* Installation paths to various stuff */ {"libdir,install", CFG_INSTALL_LIBDIR}, {"bindir,install", CFG_INSTALL_BINDIR}, Index: generic/tclPlatDecls.h ================================================================== --- generic/tclPlatDecls.h +++ generic/tclPlatDecls.h @@ -50,40 +50,40 @@ * Exported function declarations: */ #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ /* 0 */ -EXTERN TCHAR * Tcl_WinUtfToTChar(const char *str, size_t len, +EXTERN TCHAR * Tcl_WinUtfToTChar(const char *str, int len, Tcl_DString *dsPtr); /* 1 */ -EXTERN char * Tcl_WinTCharToUtf(const TCHAR *str, size_t len, +EXTERN char * Tcl_WinTCharToUtf(const TCHAR *str, int len, Tcl_DString *dsPtr); #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ /* 0 */ EXTERN int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp, const char *bundleName, int hasResourceFile, - size_t maxPathLen, char *libraryPath); + int maxPathLen, char *libraryPath); /* 1 */ EXTERN int Tcl_MacOSXOpenVersionedBundleResources( Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, - int hasResourceFile, size_t maxPathLen, + int hasResourceFile, int maxPathLen, char *libraryPath); #endif /* MACOSX */ typedef struct TclPlatStubs { int magic; void *hooks; #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ - TCHAR * (*tcl_WinUtfToTChar) (const char *str, size_t len, Tcl_DString *dsPtr); /* 0 */ - char * (*tcl_WinTCharToUtf) (const TCHAR *str, size_t len, Tcl_DString *dsPtr); /* 1 */ + TCHAR * (*tcl_WinUtfToTChar) (const char *str, int len, Tcl_DString *dsPtr); /* 0 */ + char * (*tcl_WinTCharToUtf) (const TCHAR *str, int len, Tcl_DString *dsPtr); /* 1 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ - int (*tcl_MacOSXOpenBundleResources) (Tcl_Interp *interp, const char *bundleName, int hasResourceFile, size_t maxPathLen, char *libraryPath); /* 0 */ - int (*tcl_MacOSXOpenVersionedBundleResources) (Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, size_t maxPathLen, char *libraryPath); /* 1 */ + int (*tcl_MacOSXOpenBundleResources) (Tcl_Interp *interp, const char *bundleName, int hasResourceFile, int maxPathLen, char *libraryPath); /* 0 */ + int (*tcl_MacOSXOpenVersionedBundleResources) (Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, int maxPathLen, char *libraryPath); /* 1 */ #endif /* MACOSX */ } TclPlatStubs; extern const TclPlatStubs *tclPlatStubsPtr; @@ -111,12 +111,17 @@ #endif /* MACOSX */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ + +#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 #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT #endif /* _TCLPLATDECLS */ Index: generic/tclPort.h ================================================================== --- generic/tclPort.h +++ generic/tclPort.h @@ -21,10 +21,25 @@ # include "tclWinPort.h" #else # include "tclUnixPort.h" #endif #include "tcl.h" + +#if !defined(LLONG_MIN) +# ifdef TCL_WIDE_INT_IS_LONG +# define LLONG_MIN LONG_MIN +# else +# ifdef LLONG_BIT +# define LLONG_MIN ((Tcl_WideInt)(Tcl_LongAsWide(1)<<(LLONG_BIT-1))) +# else +/* Assume we're on a system with a 64-bit 'long long' type */ +# define LLONG_MIN ((Tcl_WideInt)(Tcl_LongAsWide(1)<<63)) +# endif +# endif +/* Assume that if LLONG_MIN is undefined, then so is LLONG_MAX */ +# define LLONG_MAX (~LLONG_MIN) +#endif #define UWIDE_MAX ((Tcl_WideUInt)-1) #define WIDE_MAX ((Tcl_WideInt)(UWIDE_MAX >> 1)) #define WIDE_MIN ((Tcl_WideInt)((Tcl_WideUInt)WIDE_MAX+1)) Index: generic/tclPreserve.c ================================================================== --- generic/tclPreserve.c +++ generic/tclPreserve.c @@ -20,11 +20,11 @@ * number of calls in effect. */ typedef struct { ClientData clientData; /* Address of preserved block. */ - size_t refCount; /* Number of Tcl_Preserve calls in effect for + int refCount; /* Number of Tcl_Preserve calls in effect for * block. */ int mustFree; /* Non-zero means Tcl_EventuallyFree was * called while a Tcl_Preserve call was in * effect, so the structure must be freed when * refCount becomes zero. */ @@ -35,13 +35,13 @@ * Global data structures used to hold the list of preserved data references. * These variables are protected by "preserveMutex". */ static Reference *refArray = NULL; /* First in array of references. */ -static size_t spaceAvl = 0; /* Total number of structures available at +static int spaceAvl = 0; /* Total number of structures available at * *firstRefPtr. */ -static size_t inUse = 0; /* Count of structures currently in use in +static int inUse = 0; /* Count of structures currently in use in * refArray. */ TCL_DECLARE_MUTEX(preserveMutex)/* To protect the above statics */ #define INITIAL_SIZE 2 /* Initial number of reference slots to make */ @@ -51,21 +51,21 @@ * avoid the more time-expensive algorithm of Tcl_Preserve(). This mechanism * is mainly used when we have lots of references to a few big, expensive * objects that we don't want to live any longer than necessary. */ -typedef struct { +typedef struct HandleStruct { void *ptr; /* Pointer to the memory block being tracked. * This field will become NULL when the memory * block is deleted. This field must be the * first in the structure. */ #ifdef TCL_MEM_DEBUG void *ptr2; /* Backup copy of the above pointer used to * ensure that the contents of the handle are * not changed by anyone else. */ #endif - size_t refCount; /* Number of TclHandlePreserve() calls in + int refCount; /* Number of TclHandlePreserve() calls in * effect on this handle. */ } HandleStruct; /* *---------------------------------------------------------------------- @@ -87,11 +87,11 @@ void TclFinalizePreserve(void) { Tcl_MutexLock(&preserveMutex); if (spaceAvl != 0) { - Tcl_Free(refArray); + ckfree(refArray); refArray = NULL; inUse = 0; spaceAvl = 0; } Tcl_MutexUnlock(&preserveMutex); @@ -119,11 +119,11 @@ void Tcl_Preserve( ClientData clientData) /* Pointer to malloc'ed block of memory. */ { Reference *refPtr; - size_t i; + int i; /* * See if there is already a reference for this pointer. If so, just * increment its reference count. */ @@ -142,11 +142,11 @@ * if it is full. */ if (inUse == spaceAvl) { spaceAvl = spaceAvl ? 2*spaceAvl : INITIAL_SIZE; - refArray = Tcl_Realloc(refArray, spaceAvl * sizeof(Reference)); + refArray = ckrealloc(refArray, spaceAvl * sizeof(Reference)); } /* * Make a new entry for the new reference. */ @@ -153,11 +153,11 @@ refPtr = &refArray[inUse]; refPtr->clientData = clientData; refPtr->refCount = 1; refPtr->mustFree = 0; - refPtr->freeProc = 0; + refPtr->freeProc = TCL_STATIC; inUse += 1; Tcl_MutexUnlock(&preserveMutex); } /* @@ -182,11 +182,11 @@ void Tcl_Release( ClientData clientData) /* Pointer to malloc'ed block of memory. */ { Reference *refPtr; - size_t i; + int i; Tcl_MutexLock(&preserveMutex); for (i=0, refPtr=refArray ; iclientData != clientData) { continue; } - if (refPtr->refCount-- > 1) { + if (--refPtr->refCount != 0) { Tcl_MutexUnlock(&preserveMutex); return; } /* @@ -222,11 +222,11 @@ */ Tcl_MutexUnlock(&preserveMutex); if (mustFree) { if (freeProc == TCL_DYNAMIC) { - Tcl_Free(clientData); + ckfree(clientData); } else { freeProc(clientData); } } return; @@ -262,11 +262,11 @@ Tcl_EventuallyFree( ClientData clientData, /* Pointer to malloc'ed block of memory. */ Tcl_FreeProc *freeProc) /* Function to actually do free. */ { Reference *refPtr; - size_t i; + int i; /* * See if there is a reference for this pointer. If so, set its "mustFree" * flag (the flag had better not be set already!). */ @@ -289,11 +289,11 @@ /* * No reference for this block. Free it now. */ if (freeProc == TCL_DYNAMIC) { - Tcl_Free(clientData); + ckfree(clientData); } else { freeProc(clientData); } } @@ -325,11 +325,11 @@ TclHandleCreate( void *ptr) /* Pointer to an arbitrary block of memory to * be tracked for deletion. Must not be * NULL. */ { - HandleStruct *handlePtr = Tcl_Alloc(sizeof(HandleStruct)); + HandleStruct *handlePtr = ckalloc(sizeof(HandleStruct)); handlePtr->ptr = ptr; #ifdef TCL_MEM_DEBUG handlePtr->ptr2 = ptr; #endif @@ -375,11 +375,11 @@ handlePtr, handlePtr->ptr2, handlePtr->ptr); } #endif handlePtr->ptr = NULL; if (handlePtr->refCount == 0) { - Tcl_Free(handlePtr); + ckfree(handlePtr); } } /* *--------------------------------------------------------------------------- @@ -457,12 +457,12 @@ if ((handlePtr->ptr != NULL) && (handlePtr->ptr != handlePtr->ptr2)) { Tcl_Panic("someone has changed the block referenced by the handle %p\nfrom %p to %p", handlePtr, handlePtr->ptr2, handlePtr->ptr); } #endif - if ((handlePtr->refCount-- <= 1) && (handlePtr->ptr == NULL)) { - Tcl_Free(handlePtr); + if ((--handlePtr->refCount == 0) && (handlePtr->ptr == NULL)) { + ckfree(handlePtr); } } /* * Local Variables: Index: generic/tclProc.c ================================================================== --- generic/tclProc.c +++ generic/tclProc.c @@ -13,11 +13,10 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclCompile.h" -#include /* * Variables that are part of the [apply] command implementation and which * have to be passed to the other side of the NRE call. */ @@ -66,26 +65,10 @@ * instead. */ NULL /* SetFromAny function; Tcl_ConvertToType * should panic instead. */ }; -#define ProcSetIntRep(objPtr, procPtr) \ - do { \ - Tcl_ObjIntRep ir; \ - (procPtr)->refCount++; \ - ir.twoPtrValue.ptr1 = (procPtr); \ - ir.twoPtrValue.ptr2 = NULL; \ - Tcl_StoreIntRep((objPtr), &tclProcBodyType, &ir); \ - } while (0) - -#define ProcGetIntRep(objPtr, procPtr) \ - do { \ - const Tcl_ObjIntRep *irPtr; \ - irPtr = TclFetchIntRep((objPtr), &tclProcBodyType); \ - (procPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ - } while (0) - /* * The [upvar]/[uplevel] level reference type. Uses the longValue field * to remember the integer value of a parsed # format. * * Uses the default behaviour throughout, and never disposes of the string @@ -104,35 +87,17 @@ * Internally, ptr1 is a pointer to a Proc instance that is not bound to a * command name, and ptr2 is a pointer to the namespace that the Proc instance * will execute within. IF YOU CHANGE THIS, CHECK IN tclDisassemble.c TOO. */ -static const Tcl_ObjType lambdaType = { +const Tcl_ObjType tclLambdaType = { "lambdaExpr", /* name */ FreeLambdaInternalRep, /* freeIntRepProc */ DupLambdaInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ SetLambdaFromAny /* setFromAnyProc */ }; - -#define LambdaSetIntRep(objPtr, procPtr, nsObjPtr) \ - do { \ - Tcl_ObjIntRep ir; \ - ir.twoPtrValue.ptr1 = (procPtr); \ - ir.twoPtrValue.ptr2 = (nsObjPtr); \ - Tcl_IncrRefCount((nsObjPtr)); \ - Tcl_StoreIntRep((objPtr), &lambdaType, &ir); \ - } while (0) - -#define LambdaGetIntRep(objPtr, procPtr, nsObjPtr) \ - do { \ - const Tcl_ObjIntRep *irPtr; \ - irPtr = TclFetchIntRep((objPtr), &lambdaType); \ - (procPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ - (nsObjPtr) = irPtr ? irPtr->twoPtrValue.ptr2 : NULL; \ - } while (0) - /* *---------------------------------------------------------------------- * * Tcl_ProcObjCmd -- @@ -155,11 +120,11 @@ ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - register Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *) interp; Proc *procPtr; const char *procName; const char *simpleName, *procArgs, *procBody; Namespace *nsPtr, *altNsPtr, *cxtNsPtr; Tcl_Command cmd; @@ -230,13 +195,14 @@ * processing. Find a way to factor the common elements into a single * function. */ if (iPtr->cmdFramePtr) { - CmdFrame *contextPtr = TclStackAlloc(interp, sizeof(CmdFrame)); + CmdFrame *contextPtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame)); *contextPtr = *iPtr->cmdFramePtr; + if (contextPtr->type == TCL_LOCATION_BC) { /* * Retrieve source information from the bytecode, if possible. If * the information is retrieved successfully, context.type will be * TCL_LOCATION_SOURCE and the reference held by @@ -261,15 +227,15 @@ if (contextPtr->line && (contextPtr->nline >= 4) && (contextPtr->line[3] >= 0)) { int isNew; Tcl_HashEntry *hePtr; - CmdFrame *cfPtr = Tcl_Alloc(sizeof(CmdFrame)); + CmdFrame *cfPtr = (CmdFrame *)ckalloc(sizeof(CmdFrame)); cfPtr->level = -1; cfPtr->type = contextPtr->type; - cfPtr->line = Tcl_Alloc(sizeof(int)); + cfPtr->line = (int *)ckalloc(sizeof(int)); cfPtr->line[0] = contextPtr->line[3]; cfPtr->nline = 1; cfPtr->framePtr = NULL; cfPtr->nextPtr = NULL; @@ -278,11 +244,11 @@ cfPtr->cmd = NULL; cfPtr->len = 0; hePtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr, - procPtr, &isNew); + (char *)procPtr, &isNew); if (!isNew) { /* * Get the old command frame and release it. See also * TclProcCleanupProc in this file. Currently it seems as * if only the procbodytest::proc command of the testsuite @@ -293,13 +259,13 @@ if (cfOldPtr->type == TCL_LOCATION_SOURCE) { Tcl_DecrRefCount(cfOldPtr->data.eval.path); cfOldPtr->data.eval.path = NULL; } - Tcl_Free(cfOldPtr->line); + ckfree(cfOldPtr->line); cfOldPtr->line = NULL; - Tcl_Free(cfOldPtr); + ckfree(cfOldPtr); } Tcl_SetHashValue(hePtr, cfPtr); } /* @@ -338,11 +304,11 @@ while (*procArgs == ' ') { procArgs++; } if ((procArgs[0] == 'a') && (strncmp(procArgs, "args", 4) == 0)) { - size_t numBytes; + int numBytes; procArgs +=4; while (*procArgs != '\0') { if (*procArgs != ' ') { goto done; @@ -352,11 +318,11 @@ /* * The argument list is just "args"; check the body */ - procBody = TclGetStringFromObj(objv[3], &numBytes); + procBody = Tcl_GetStringFromObj(objv[3], &numBytes); if (TclParseAllWhiteSpace(procBody, numBytes) < numBytes) { goto done; } /* @@ -403,18 +369,17 @@ Tcl_Obj *bodyPtr, /* Command body. */ Proc **procPtrPtr) /* Returns: pointer to proc data. */ { Interp *iPtr = (Interp *) interp; - register Proc *procPtr = NULL; + Proc *procPtr; int i, result, numArgs; - register CompiledLocal *localPtr = NULL; + CompiledLocal *localPtr = NULL; Tcl_Obj **argArray; int precompiled = 0; - ProcGetIntRep(bodyPtr, procPtr); - if (procPtr != NULL) { + if (bodyPtr->typePtr == &tclProcBodyType) { /* * Because the body is a TclProProcBody, the actual body is already * compiled, and it is not shared with anyone else, so it's OK not to * unshare it (as a matter of fact, it is bad to unshare it, because * there may be no source code). @@ -423,10 +388,11 @@ * rather, we use what is in the body object. We increment the ref * count of the Proc struct since the command (soon to be created) * will be holding a reference to it. */ + procPtr = bodyPtr->internalRep.twoPtrValue.ptr1; procPtr->iPtr = iPtr; procPtr->refCount++; precompiled = 1; } else { /* @@ -444,11 +410,11 @@ * not want any bytecode internal representation. */ if (Tcl_IsShared(bodyPtr)) { const char *bytes; - size_t length; + int length; Tcl_Obj *sharedBodyPtr = bodyPtr; bytes = TclGetStringFromObj(bodyPtr, &length); bodyPtr = Tcl_NewStringObj(bytes, length); @@ -467,11 +433,11 @@ * will be a reference to it in the Proc structure. */ Tcl_IncrRefCount(bodyPtr); - procPtr = Tcl_Alloc(sizeof(Proc)); + procPtr = (Proc *)ckalloc(sizeof(Proc)); procPtr->iPtr = iPtr; procPtr->refCount = 1; procPtr->bodyPtr = bodyPtr; procPtr->numArgs = 0; /* Actual argument count is set below. */ procPtr->numCompiledLocals = 0; @@ -484,11 +450,11 @@ * argument specifier. If the body is precompiled, processing is limited * to checking that the parsed argument is consistent with the one stored * in the Proc. */ - result = Tcl_ListObjGetElements(interp , argsPtr ,&numArgs ,&argArray); + result = Tcl_ListObjGetElements(interp, argsPtr, &numArgs, &argArray); if (result != TCL_OK) { goto procError; } if (precompiled) { @@ -506,13 +472,12 @@ procPtr->numArgs = numArgs; procPtr->numCompiledLocals = numArgs; } for (i = 0; i < numArgs; i++) { - const char *argname, *argnamei, *argnamelast; - int fieldCount; - size_t nameLength; + const char *argname, *p, *last; + int fieldCount, nameLength; Tcl_Obj **fieldValues; /* * Now divide the specifier up into name and default. */ @@ -538,39 +503,37 @@ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } - argname = TclGetStringFromObj(fieldValues[0], &nameLength); - /* * Check that the formal parameter name is a scalar. */ - argnamei = argname; - argnamelast = Tcl_UtfPrev(argname + nameLength, argname); - while (argnamei < argnamelast) { - if (*argnamei == '(') { - if (*argnamelast == ')') { /* We have an array element. */ + p = argname = Tcl_GetStringFromObj(fieldValues[0], &nameLength); + last = argname + nameLength; + while (p < last) { + if (*p == '(') { + if (last[-1] == ')') { /* We have an array element. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "formal parameter \"%s\" is an array element", - TclGetString(fieldValues[0]))); + Tcl_GetString(fieldValues[0]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } - } else if (*argnamei == ':' && *(argnamei+1) == ':') { + } else if (p[0] == ':' && p[1] == ':') { Tcl_Obj *errorObj = Tcl_NewStringObj( "formal parameter \"", -1); Tcl_AppendObjToObj(errorObj, fieldValues[0]); Tcl_AppendToObj(errorObj, "\" is not a simple name", -1); Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } - argnamei = Tcl_UtfNext(argnamei); + p++; } if (precompiled) { /* * Compare the parsed argument with the stored one. Note that the @@ -600,13 +563,15 @@ /* * Compare the default value if any. */ if (localPtr->defValuePtr != NULL) { - size_t tmpLength, valueLength; - const char *tmpPtr = TclGetStringFromObj(localPtr->defValuePtr, &tmpLength); - const char *value = TclGetStringFromObj(fieldValues[1], &valueLength); + int tmpLength, valueLength; + const char *tmpPtr = TclGetStringFromObj(localPtr->defValuePtr, + &tmpLength); + const char *value = TclGetStringFromObj(fieldValues[1], + &valueLength); if ((valueLength != tmpLength) || memcmp(value, tmpPtr, tmpLength) != 0 ) { Tcl_Obj *errorObj = Tcl_ObjPrintf( @@ -632,11 +597,12 @@ /* * Allocate an entry in the runtime procedure frame's array of * local variables for the argument. */ - localPtr = Tcl_Alloc(offsetof(CompiledLocal, name) + fieldValues[0]->length +1); + localPtr = (CompiledLocal *)ckalloc( + TclOffset(CompiledLocal, name) + fieldValues[0]->length + 1); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } else { procPtr->lastLocalPtr->nextPtr = localPtr; procPtr->lastLocalPtr = localPtr; @@ -677,13 +643,13 @@ if (localPtr->defValuePtr != NULL) { Tcl_DecrRefCount(localPtr->defValuePtr); } - Tcl_Free(localPtr); + ckfree(localPtr); } - Tcl_Free(procPtr); + ckfree(procPtr); } return TCL_ERROR; } /* @@ -716,19 +682,60 @@ Tcl_Interp *interp, /* Interpreter in which to find frame. */ const char *name, /* String describing frame. */ CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if * global frame indicated). */ { - int result; - Tcl_Obj obj; - - obj.bytes = (char *) name; - obj.length = strlen(name); - obj.typePtr = NULL; - result = TclObjGetFrame(interp, &obj, framePtrPtr); - TclFreeIntRep(&obj); - return result; + Interp *iPtr = (Interp *) interp; + int curLevel, level, result; + CallFrame *framePtr; + + /* + * Parse string to figure out which level number to go to. + */ + + result = 1; + curLevel = iPtr->varFramePtr->level; + if (*name== '#') { + if (Tcl_GetInt(NULL, name+1, &level) != TCL_OK || level < 0) { + goto levelError; + } + } else if (isdigit(UCHAR(*name))) { /* INTL: digit */ + if (Tcl_GetInt(NULL, name, &level) != TCL_OK) { + goto levelError; + } + level = curLevel - level; + } else { + /* + * (historical, TODO) If name does not contain a level (#0 or 1), + * TclGetFrame and Tcl_UpVar2 uses current level - 1 + */ + level = curLevel - 1; + result = 0; + name = "1"; /* be more consistent with TclObjGetFrame (error at top - 1) */ + } + + /* + * Figure out which frame to use, and return it to the caller. + */ + + for (framePtr = iPtr->varFramePtr; framePtr != NULL; + framePtr = framePtr->callerVarPtr) { + if (framePtr->level == level) { + break; + } + } + if (framePtr == NULL) { + goto levelError; + } + + *framePtrPtr = framePtr; + return result; + + levelError: + Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL); + return -1; } /* *---------------------------------------------------------------------- * @@ -759,15 +766,13 @@ Tcl_Interp *interp, /* Interpreter in which to find frame. */ Tcl_Obj *objPtr, /* Object describing frame. */ CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if * global frame indicated). */ { - register Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *) interp; int curLevel, level, result; - const Tcl_ObjIntRep *irPtr; const char *name = NULL; - Tcl_WideInt w; /* * Parse object to figure out which level number to go to. */ @@ -779,38 +784,29 @@ * a generation of a stringrep. */ if (objPtr == NULL) { /* Do nothing */ - } else if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &level)) { - Tcl_GetWideIntFromObj(NULL, objPtr, &w); - if (w < 0 || w > INT_MAX || curLevel > w + INT_MAX) { - result = -1; - } else { - level = curLevel - level; - result = 1; - } - } else if ((irPtr = TclFetchIntRep(objPtr, &levelReferenceType))) { - level = irPtr->wideValue; + } else if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &level) + && (level >= 0)) { + level = curLevel - level; + result = 1; + } else if (objPtr->typePtr == &levelReferenceType) { + level = (int) objPtr->internalRep.longValue; result = 1; } else { name = TclGetString(objPtr); if (name[0] == '#') { - if (TCL_OK == Tcl_GetInt(NULL, name+1, &level)) { - if (level < 0 || (level > 0 && name[1] == '-')) { - result = -1; - } else { - Tcl_ObjIntRep ir; - - ir.wideValue = level; - Tcl_StoreIntRep(objPtr, &levelReferenceType, &ir); - result = 1; - } + if (TCL_OK == Tcl_GetInt(NULL, name+1, &level) && level >= 0) { + TclFreeIntRep(objPtr); + objPtr->typePtr = &levelReferenceType; + objPtr->internalRep.longValue = level; + result = 1; } else { result = -1; } - } else if (TclGetWideBitsFromObj(interp, objPtr, &w) == TCL_OK) { + } else if (isdigit(UCHAR(name[0]))) { /* INTL: digit */ /* * If this were an integer, we'd have succeeded already. * Docs say we have to treat this as a 'bad level' error. */ result = -1; @@ -817,10 +813,11 @@ } } if (result == 0) { level = curLevel - 1; + name = "1"; } if (result != -1) { if (level >= 0) { CallFrame *framePtr; for (framePtr = iPtr->varFramePtr; framePtr != NULL; @@ -829,15 +826,15 @@ *framePtrPtr = framePtr; return result; } } } + if (name == NULL) { + name = TclGetString(objPtr); + } } - if (name == NULL) { - name = TclGetString(objPtr); - } Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", name, NULL); return -1; } @@ -896,21 +893,40 @@ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - register Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *) interp; CmdFrame *invoker = NULL; int word = 0; int result; CallFrame *savedVarFramePtr, *framePtr; Tcl_Obj *objPtr; if (objc < 2) { + /* to do + * simplify things by interpreting the argument as a command when there + * is only one argument. This requires a TIP since currently a single + * argument is interpreted as a level indicator if possible. + */ uplevelSyntax: Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?"); return TCL_ERROR; + } else if (!TclHasStringRep(objv[1]) && objc == 2) { + int status ,llength; + status = Tcl_ListObjLength(interp, objv[1], &llength); + if (status == TCL_OK && llength > 1) { + /* the first argument can't interpreted as a level. Avoid + * generating a string representation of the script. */ + result = TclGetFrame(interp, "1", &framePtr); + if (result == -1) { + return TCL_ERROR; + } + objc -= 1; + objv += 1; + goto havelevel; + } } /* * Find the level to use for executing the command. */ @@ -922,10 +938,12 @@ objc -= result + 1; if (objc == 0) { goto uplevelSyntax; } objv += result + 1; + + havelevel: /* * Modify the interpreter state to execute in the given frame. */ @@ -1036,32 +1054,36 @@ ProcWrongNumArgs( Tcl_Interp *interp, int skip) { CallFrame *framePtr = ((Interp *)interp)->varFramePtr; - register Proc *procPtr = framePtr->procPtr; + Proc *procPtr = framePtr->procPtr; int localCt = procPtr->numCompiledLocals, numArgs, i; Tcl_Obj **desiredObjs; const char *final = NULL; /* * Build up desired argument list for Tcl_WrongNumArgs */ numArgs = framePtr->procPtr->numArgs; - desiredObjs = TclStackAlloc(interp, + desiredObjs = (Tcl_Obj **)TclStackAlloc(interp, (int) sizeof(Tcl_Obj *) * (numArgs+1)); if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) { desiredObjs[0] = Tcl_NewStringObj("lambdaExpr", -1); } else { +#ifdef AVOID_HACKS_FOR_ITCL desiredObjs[0] = framePtr->objv[skip-1]; +#else + desiredObjs[0] = Tcl_NewListObj(1, framePtr->objv + skip - 1); +#endif /* AVOID_HACKS_FOR_ITCL */ } Tcl_IncrRefCount(desiredObjs[0]); if (localCt > 0) { - register Var *defPtr = (Var *) (&framePtr->localCachePtr->varName0 + localCt); + Var *defPtr = (Var *)(&framePtr->localCachePtr->varName0 + localCt); for (i=1 ; i<=numArgs ; i++, defPtr++) { Tcl_Obj *argObj; Tcl_Obj *namePtr = localName(framePtr, i-1); @@ -1120,14 +1142,14 @@ Var *varPtr = framePtr->compiledLocals; Tcl_Obj *bodyPtr; ByteCode *codePtr; bodyPtr = framePtr->procPtr->bodyPtr; - ByteCodeGetIntRep(bodyPtr, &tclByteCodeType, codePtr); - if (codePtr == NULL) { + if (bodyPtr->typePtr != &tclByteCodeType) { Tcl_Panic("body object for proc attached to frame is not a byte code type"); } + codePtr = bodyPtr->internalRep.twoPtrValue.ptr1; if (framePtr->numCompiledLocals) { if (!codePtr->localCachePtr) { InitLocalCache(framePtr->procPtr) ; } @@ -1192,11 +1214,11 @@ for (; localPtr != NULL; localPtr = localPtr->nextPtr) { if (localPtr->resolveInfo) { if (localPtr->resolveInfo->deleteProc) { localPtr->resolveInfo->deleteProc(localPtr->resolveInfo); } else { - Tcl_Free(localPtr->resolveInfo); + ckfree(localPtr->resolveInfo); } localPtr->resolveInfo = NULL; } localPtr->flags &= ~VAR_RESOLVED; @@ -1248,11 +1270,11 @@ * should be used. */ resVarInfo = localPtr->resolveInfo; if (resVarInfo && resVarInfo->fetchProc) { - register Var *resolvedVarPtr = (Var *) + Var *resolvedVarPtr = (Var *) resVarInfo->fetchProc(interp, resVarInfo); if (resolvedVarPtr) { if (TclIsVarInHash(resolvedVarPtr)) { VarHashRefCount(resolvedVarPtr)++; @@ -1271,45 +1293,43 @@ { int i; Tcl_Obj **namePtrPtr = &localCachePtr->varName0; for (i = 0; i < localCachePtr->numVars; i++, namePtrPtr++) { - register Tcl_Obj *objPtr = *namePtrPtr; + Tcl_Obj *objPtr = *namePtrPtr; if (objPtr) { /* TclReleaseLiteral calls Tcl_DecrRefCount for us */ TclReleaseLiteral(interp, objPtr); } } - Tcl_Free(localCachePtr); + ckfree(localCachePtr); } static void InitLocalCache( Proc *procPtr) { Interp *iPtr = procPtr->iPtr; - ByteCode *codePtr; + ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; int localCt = procPtr->numCompiledLocals; int numArgs = procPtr->numArgs, i = 0; Tcl_Obj **namePtr; Var *varPtr; LocalCache *localCachePtr; CompiledLocal *localPtr; int new; - ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); - /* * Cache the names and initial values of local variables; store the * cache in both the framePtr for this execution and in the codePtr * for future calls. */ - localCachePtr = Tcl_Alloc(sizeof(LocalCache) - + (localCt - 1) * sizeof(Tcl_Obj *) + localCachePtr = (LocalCache *)ckalloc(TclOffset(LocalCache, varName0) + + localCt * sizeof(Tcl_Obj *) + numArgs * sizeof(Var)); namePtr = &localCachePtr->varName0; varPtr = (Var *) (namePtr + localCt); localPtr = procPtr->firstLocalPtr; @@ -1316,11 +1336,11 @@ while (localPtr) { if (TclIsVarTemporary(localPtr)) { *namePtr = NULL; } else { *namePtr = TclCreateLiteral(iPtr, localPtr->name, - localPtr->nameLength, /* hash */ -1, + localPtr->nameLength, /* hash */ (unsigned int) -1, &new, /* nsPtr */ NULL, 0, NULL); Tcl_IncrRefCount(*namePtr); } if (i < numArgs) { @@ -1357,25 +1377,23 @@ *---------------------------------------------------------------------- */ static int InitArgsAndLocals( - register Tcl_Interp *interp,/* Interpreter in which procedure was + Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ Tcl_Obj *procNameObj, /* Procedure name for error reporting. */ int skip) /* Number of initial arguments to be skipped, * i.e., words in the "command name". */ { CallFrame *framePtr = ((Interp *)interp)->varFramePtr; - register Proc *procPtr = framePtr->procPtr; - ByteCode *codePtr; - register Var *varPtr, *defPtr; + Proc *procPtr = framePtr->procPtr; + ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; + Var *varPtr, *defPtr; int localCt = procPtr->numCompiledLocals, numArgs, argCt, i, imax; Tcl_Obj *const *argObjs; - ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); - /* * Make sure that the local cache of variable names and initial values has * been initialised properly . */ @@ -1394,11 +1412,11 @@ * Create the "compiledLocals" array. Make sure it is large enough to hold * all the procedure's compiled local variables, including its formal * parameters. */ - varPtr = TclStackAlloc(interp, (int)(localCt * sizeof(Var))); + varPtr = TclStackAlloc(interp, localCt * sizeof(Var)); framePtr->compiledLocals = varPtr; framePtr->numCompiledLocals = localCt; /* * Match and assign the call's actual parameters to the procedure's formal @@ -1524,11 +1542,11 @@ int TclPushProcCallFrame( ClientData clientData, /* Record describing procedure to be * interpreted. */ - register Tcl_Interp *interp,/* Interpreter in which procedure was + Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ int objc, /* Count of number of arguments to this * procedure. */ Tcl_Obj *const objv[], /* Argument value objects. */ int isLambda) /* 1 if this is a call by ApplyObjCmd: it @@ -1546,12 +1564,11 @@ * slots for the procedure's non-argument local variables. Note that * compiling the body might increase procPtr->numCompiledLocals if new * local variables are found while compiling. */ - ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); - if (codePtr != NULL) { + if (procPtr->bodyPtr->typePtr == &tclByteCodeType) { Interp *iPtr = (Interp *) interp; /* * When we've got bytecode, this is the check for validity. That is, * the bytecode must be for the right interpreter (no cross-leaks!), @@ -1559,10 +1576,11 @@ * is up-to-date), the namespace must match (so variable handling * is right) and the resolverEpoch must match (so that new shadowed * commands and/or resolver changes are considered). */ + codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != nsPtr) || (codePtr->nsEpoch != nsPtr->resolverEpoch)) { goto doCompilation; @@ -1616,11 +1634,11 @@ int TclObjInterpProc( ClientData clientData, /* Record describing procedure to be * interpreted. */ - register Tcl_Interp *interp,/* Interpreter in which procedure was + Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ int objc, /* Count of number of arguments to this * procedure. */ Tcl_Obj *const objv[]) /* Argument value objects. */ { @@ -1633,11 +1651,11 @@ int TclNRInterpProc( ClientData clientData, /* Record describing procedure to be * interpreted. */ - register Tcl_Interp *interp,/* Interpreter in which procedure was + Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ int objc, /* Count of number of arguments to this * procedure. */ Tcl_Obj *const objv[]) /* Argument value objects. */ { @@ -1668,20 +1686,20 @@ *---------------------------------------------------------------------- */ int TclNRInterpProcCore( - register Tcl_Interp *interp,/* Interpreter in which procedure was + Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ Tcl_Obj *procNameObj, /* Procedure name for error reporting. */ int skip, /* Number of initial arguments to be skipped, * i.e., words in the "command name". */ ProcErrorProc *errorProc) /* How to convert results from the script into * results of the overall procedure. */ { Interp *iPtr = (Interp *) interp; - register Proc *procPtr = iPtr->varFramePtr->procPtr; + Proc *procPtr = iPtr->varFramePtr->procPtr; int result; CallFrame *freePtr; ByteCode *codePtr; result = InitArgsAndLocals(interp, procNameObj, skip); @@ -1694,12 +1712,12 @@ return TCL_ERROR; } #if defined(TCL_COMPILE_DEBUG) if (tclTraceExec >= 1) { - register CallFrame *framePtr = iPtr->varFramePtr; - register int i; + CallFrame *framePtr = iPtr->varFramePtr; + int i; if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) { fprintf(stdout, "Calling lambda "); } else { fprintf(stdout, "Calling proc "); @@ -1756,11 +1774,11 @@ /* * Invoke the commands in the procedure's body. */ procPtr->refCount++; - ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); + codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; TclNRAddCallback(interp, InterpProcNR2, procNameObj, errorProc, NULL, NULL); return TclNRExecuteByteCode(interp, codePtr); } @@ -1841,13 +1859,11 @@ "invoked \"%s\" outside of a loop", ((result == TCL_BREAK) ? "break" : "continue"))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", NULL); result = TCL_ERROR; - /* - * Fall through to the TCL_ERROR handling code. - */ + /* FALLTHRU */ 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 @@ -1890,13 +1906,11 @@ const char *description, /* string describing this body of code. */ const char *procName) /* Name of this procedure. */ { Interp *iPtr = (Interp *) interp; Tcl_CallFrame *framePtr; - ByteCode *codePtr; - - ByteCodeGetIntRep(bodyPtr, &tclByteCodeType, codePtr); + ByteCode *codePtr = bodyPtr->internalRep.twoPtrValue.ptr1; /* * If necessary, compile the procedure's body. The compiler will allocate * frame slots for the procedure's non-argument local variables. If the * ByteCode already exists, make sure it hasn't been invalidated by @@ -1908,11 +1922,11 @@ * * Precompiled procedure bodies, however, are immutable and therefore they * are not recompiled, even if things have changed. */ - if (codePtr != NULL) { + if (bodyPtr->typePtr == &tclByteCodeType) { if (((Interp *) *codePtr->interpHandle == iPtr) && (codePtr->compileEpoch == iPtr->compileEpoch) && (codePtr->nsPtr == nsPtr) && (codePtr->nsEpoch == nsPtr->resolverEpoch)) { return TCL_OK; @@ -1927,16 +1941,15 @@ return TCL_ERROR; } codePtr->compileEpoch = iPtr->compileEpoch; codePtr->nsPtr = nsPtr; } else { - Tcl_StoreIntRep(bodyPtr, &tclByteCodeType, NULL); - codePtr = NULL; + TclFreeIntRep(bodyPtr); } } - if (codePtr == NULL) { + if (bodyPtr->typePtr != &tclByteCodeType) { Tcl_HashEntry *hePtr; #ifdef TCL_COMPILE_DEBUG if (tclTraceCompile >= 1) { /* @@ -1989,14 +2002,14 @@ clPtr = clPtr->nextPtr; if (toFree->resolveInfo) { if (toFree->resolveInfo->deleteProc) { toFree->resolveInfo->deleteProc(toFree->resolveInfo); } else { - Tcl_Free(toFree->resolveInfo); + ckfree(toFree->resolveInfo); } } - Tcl_Free(toFree); + ckfree(toFree); } procPtr->numCompiledLocals = procPtr->numArgs; } (void) TclPushStackFrame(interp, &framePtr, (Tcl_Namespace *) nsPtr, @@ -2053,18 +2066,17 @@ Tcl_Interp *interp, /* The interpreter in which the procedure was * called. */ Tcl_Obj *procNameObj) /* Name of the procedure. Used for error * messages and trace information. */ { - unsigned int overflow, limit = 60; - size_t nameLen; - const char *procName = TclGetStringFromObj(procNameObj, &nameLen); + int overflow, limit = 60, nameLen; + const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen); overflow = (nameLen > limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (procedure \"%.*s%s\" line %d)", - (int)(overflow ? limit :nameLen), procName, + (overflow ? limit : nameLen), procName, (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } /* *---------------------------------------------------------------------- @@ -2114,13 +2126,13 @@ *---------------------------------------------------------------------- */ void TclProcCleanupProc( - register Proc *procPtr) /* Procedure to be deleted. */ + Proc *procPtr) /* Procedure to be deleted. */ { - register CompiledLocal *localPtr; + CompiledLocal *localPtr; Tcl_Obj *bodyPtr = procPtr->bodyPtr; Tcl_Obj *defPtr; Tcl_ResolvedVarInfo *resVarInfo; Tcl_HashEntry *hePtr = NULL; CmdFrame *cfPtr = NULL; @@ -2135,22 +2147,22 @@ resVarInfo = localPtr->resolveInfo; if (resVarInfo) { if (resVarInfo->deleteProc) { resVarInfo->deleteProc(resVarInfo); } else { - Tcl_Free(resVarInfo); + ckfree(resVarInfo); } } if (localPtr->defValuePtr != NULL) { defPtr = localPtr->defValuePtr; Tcl_DecrRefCount(defPtr); } - Tcl_Free(localPtr); + ckfree(localPtr); localPtr = nextPtr; } - Tcl_Free(procPtr); + ckfree(procPtr); /* * TIP #280: Release the location data associated with this Proc * structure, if any. The interpreter may not exist (For example for * procbody structures created by tbcload. @@ -2163,20 +2175,20 @@ hePtr = Tcl_FindHashEntry(iPtr->linePBodyPtr, (char *) procPtr); if (!hePtr) { return; } - cfPtr = Tcl_GetHashValue(hePtr); + cfPtr = (CmdFrame *) Tcl_GetHashValue(hePtr); if (cfPtr) { if (cfPtr->type == TCL_LOCATION_SOURCE) { Tcl_DecrRefCount(cfPtr->data.eval.path); cfPtr->data.eval.path = NULL; } - Tcl_Free(cfPtr->line); + ckfree(cfPtr->line); cfPtr->line = NULL; - Tcl_Free(cfPtr); + ckfree(cfPtr); } Tcl_DeleteHashEntry(hePtr); } /* @@ -2282,11 +2294,14 @@ return NULL; } TclNewObj(objPtr); if (objPtr) { - ProcSetIntRep(objPtr, procPtr); + objPtr->typePtr = &tclProcBodyType; + objPtr->internalRep.twoPtrValue.ptr1 = procPtr; + + procPtr->refCount++; } return objPtr; } @@ -2310,14 +2325,15 @@ static void ProcBodyDup( Tcl_Obj *srcPtr, /* Object to copy. */ Tcl_Obj *dupPtr) /* Target object for the duplication. */ { - Proc *procPtr; - ProcGetIntRep(srcPtr, procPtr); + Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1; - ProcSetIntRep(dupPtr, procPtr); + dupPtr->typePtr = &tclProcBodyType; + dupPtr->internalRep.twoPtrValue.ptr1 = procPtr; + procPtr->refCount++; } /* *---------------------------------------------------------------------- * @@ -2339,13 +2355,11 @@ static void ProcBodyFree( Tcl_Obj *objPtr) /* The object to clean up. */ { - Proc *procPtr; - - ProcGetIntRep(objPtr, procPtr); + Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1; if (procPtr->refCount-- <= 1) { TclProcCleanupProc(procPtr); } } @@ -2365,44 +2379,42 @@ */ static void DupLambdaInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ - register Tcl_Obj *copyPtr) /* Object with internal rep to set. */ + Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - Proc *procPtr; - Tcl_Obj *nsObjPtr; + Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1; + Tcl_Obj *nsObjPtr = srcPtr->internalRep.twoPtrValue.ptr2; - LambdaGetIntRep(srcPtr, procPtr, nsObjPtr); - assert(procPtr != NULL); + copyPtr->internalRep.twoPtrValue.ptr1 = procPtr; + copyPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr; procPtr->refCount++; - - LambdaSetIntRep(copyPtr, procPtr, nsObjPtr); + Tcl_IncrRefCount(nsObjPtr); + copyPtr->typePtr = &tclLambdaType; } static void FreeLambdaInternalRep( - register Tcl_Obj *objPtr) /* CmdName object with internal representation + Tcl_Obj *objPtr) /* CmdName object with internal representation * to free. */ { - Proc *procPtr; - Tcl_Obj *nsObjPtr; + Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1; + Tcl_Obj *nsObjPtr = objPtr->internalRep.twoPtrValue.ptr2; - LambdaGetIntRep(objPtr, procPtr, nsObjPtr); - assert(procPtr != NULL); - - if (procPtr->refCount-- <= 1) { + if (procPtr->refCount-- == 1) { TclProcCleanupProc(procPtr); } TclDecrRefCount(nsObjPtr); + objPtr->typePtr = NULL; } static int SetLambdaFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr) /* The object to convert. */ + Tcl_Obj *objPtr) /* The object to convert. */ { Interp *iPtr = (Interp *) interp; const char *name; Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv; int isNew, objc, result; @@ -2413,18 +2425,18 @@ return TCL_ERROR; } /* * Convert objPtr to list type first; if it cannot be converted, or if its - * length is not 2, then it cannot be converted to lambdaType. + * length is not 2, then it cannot be converted to tclLambdaType. */ result = TclListObjGetElements(NULL, objPtr, &objc, &objv); if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't interpret \"%s\" as a lambda expression", - TclGetString(objPtr))); + Tcl_GetString(objPtr))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", NULL); return TCL_ERROR; } argsPtr = objv[0]; @@ -2506,16 +2518,16 @@ /* * Move from approximation (line of list cmd word) to actual * location (line of 2nd list element). */ - cfPtr = Tcl_Alloc(sizeof(CmdFrame)); + cfPtr = (CmdFrame *)ckalloc(sizeof(CmdFrame)); TclListLines(objPtr, contextPtr->line[1], 2, buf, NULL); cfPtr->level = -1; cfPtr->type = contextPtr->type; - cfPtr->line = Tcl_Alloc(sizeof(int)); + cfPtr->line = (int *)ckalloc(sizeof(int)); cfPtr->line[0] = buf[1]; cfPtr->nline = 1; cfPtr->framePtr = NULL; cfPtr->nextPtr = NULL; @@ -2554,45 +2566,24 @@ } else { nsObjPtr = objv[2]; } } + Tcl_IncrRefCount(nsObjPtr); + /* * Free the list internalrep of objPtr - this will free argsPtr, but * bodyPtr retains a reference from the Proc structure. Then finish the - * conversion to lambdaType. + * conversion to tclLambdaType. */ - LambdaSetIntRep(objPtr, procPtr, nsObjPtr); - return TCL_OK; -} - -Proc * -TclGetLambdaFromObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr, - Tcl_Obj **nsObjPtrPtr) -{ - Proc *procPtr; - Tcl_Obj *nsObjPtr; - - LambdaGetIntRep(objPtr, procPtr, nsObjPtr); - - if (procPtr == NULL) { - if (SetLambdaFromAny(interp, objPtr) != TCL_OK) { - return NULL; - } - LambdaGetIntRep(objPtr, procPtr, nsObjPtr); - } - - assert(procPtr != NULL); - if (procPtr->iPtr != (Interp *)interp) { - return NULL; - } - - *nsObjPtrPtr = nsObjPtr; - return procPtr; + TclFreeIntRep(objPtr); + + objPtr->internalRep.twoPtrValue.ptr1 = procPtr; + objPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr; + objPtr->typePtr = &tclLambdaType; + return TCL_OK; } /* *---------------------------------------------------------------------- * @@ -2625,10 +2616,11 @@ ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + Interp *iPtr = (Interp *) interp; Proc *procPtr = NULL; Tcl_Obj *lambdaPtr, *nsObjPtr; int result; Tcl_Namespace *nsPtr; ApplyExtraData *extraPtr; @@ -2642,21 +2634,52 @@ * Set lambdaPtr, convert it to tclLambdaType in the current interp if * necessary. */ lambdaPtr = objv[1]; - procPtr = TclGetLambdaFromObj(interp, lambdaPtr, &nsObjPtr); + if (lambdaPtr->typePtr == &tclLambdaType) { + procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1; + } + +#define JOE_EXTENSION 0 +/* + * Note: this code is NOT FUNCTIONAL due to the NR implementation; DO NOT + * ENABLE! Leaving here as reminder to (a) TIP the suggestion, and (b) adapt + * the code. (MS) + */ + +#if JOE_EXTENSION + else { + /* + * Joe English's suggestion to allow cmdNames to function as lambdas. + */ + + Tcl_Obj *elemPtr; + int numElem; + + if ((lambdaPtr->typePtr == &tclCmdNameType) || + (TclListObjGetElements(interp, lambdaPtr, &numElem, + &elemPtr) == TCL_OK && numElem == 1)) { + return Tcl_EvalObjv(interp, objc-1, objv+1, 0); + } + } +#endif - if (procPtr == NULL) { - return TCL_ERROR; + if ((procPtr == NULL) || (procPtr->iPtr != iPtr)) { + result = SetLambdaFromAny(interp, lambdaPtr); + if (result != TCL_OK) { + return result; + } + procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1; } /* - * Push a call frame for the lambda namespace. - * Note that TclObjInterpProc() will pop it. + * Find the namespace where this lambda should run, and push a call frame + * for that namespace. Note that TclObjInterpProc() will pop it. */ + nsObjPtr = lambdaPtr->internalRep.twoPtrValue.ptr2; result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); if (result != TCL_OK) { return TCL_ERROR; } @@ -2724,18 +2747,17 @@ Tcl_Interp *interp, /* The interpreter in which the procedure was * called. */ Tcl_Obj *procNameObj) /* Name of the procedure. Used for error * messages and trace information. */ { - unsigned int overflow, limit = 60; - size_t nameLen; - const char *procName = TclGetStringFromObj(procNameObj, &nameLen); + int overflow, limit = 60, nameLen; + const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen); overflow = (nameLen > limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (lambda term \"%.*s%s\" line %d)", - (int)(overflow ? limit : nameLen), procName, + (overflow ? limit : nameLen), procName, (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } /* *---------------------------------------------------------------------- DELETED generic/tclProcess.c Index: generic/tclProcess.c ================================================================== --- generic/tclProcess.c +++ /dev/null @@ -1,957 +0,0 @@ -/* - * tclProcess.c -- - * - * This file implements the "tcl::process" ensemble for subprocess - * management as defined by TIP #462. - * - * Copyright (c) 2017 Frederic Bonnet. - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#include "tclInt.h" - -/* - * Autopurge flag. Process-global because of the way Tcl manages child - * processes (see tclPipe.c). - */ - -static int autopurge = 1; /* Autopurge flag. */ - -/* - * Hash tables that keeps track of all child process statuses. Keys are the - * child process ids and resolved pids, values are (ProcessInfo *). - */ - -typedef struct ProcessInfo { - Tcl_Pid pid; /* Process id. */ - int resolvedPid; /* Resolved process id. */ - int purge; /* Purge eventualy. */ - TclProcessWaitStatus status;/* Process status. */ - int code; /* Error code, exit status or signal - number. */ - Tcl_Obj *msg; /* Error message. */ - Tcl_Obj *error; /* Error code. */ -} ProcessInfo; -static Tcl_HashTable infoTablePerPid; -static Tcl_HashTable infoTablePerResolvedPid; -static int infoTablesInitialized = 0; /* 0 means not yet initialized. */ -TCL_DECLARE_MUTEX(infoTablesMutex) - - /* - * Prototypes for functions defined later in this file: - */ - -static void InitProcessInfo(ProcessInfo *info, Tcl_Pid pid, - int resolvedPid); -static void FreeProcessInfo(ProcessInfo *info); -static int RefreshProcessInfo(ProcessInfo *info, int options); -static TclProcessWaitStatus WaitProcessStatus(Tcl_Pid pid, size_t resolvedPid, - int options, int *codePtr, Tcl_Obj **msgPtr, - Tcl_Obj **errorObjPtr); -static Tcl_Obj * BuildProcessStatusObj(ProcessInfo *info); -static int ProcessListObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int ProcessStatusObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int ProcessPurgeObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int ProcessAutopurgeObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); - -/* - *---------------------------------------------------------------------- - * - * InitProcessInfo -- - * - * Initializes the ProcessInfo structure. - * - * Results: - * None. - * - * Side effects: - * Memory written. - * - *---------------------------------------------------------------------- - */ - -void -InitProcessInfo( - ProcessInfo *info, /* Structure to initialize. */ - Tcl_Pid pid, /* Process id. */ - int resolvedPid) /* Resolved process id. */ -{ - info->pid = pid; - info->resolvedPid = resolvedPid; - info->purge = 0; - info->status = TCL_PROCESS_UNCHANGED; - info->code = 0; - info->msg = NULL; - info->error = NULL; -} - -/* - *---------------------------------------------------------------------- - * - * FreeProcessInfo -- - * - * Free the ProcessInfo structure. - * - * Results: - * None. - * - * Side effects: - * Memory deallocated, Tcl_Obj refcount decreased. - * - *---------------------------------------------------------------------- - */ - -void -FreeProcessInfo( - ProcessInfo *info) /* Structure to free. */ -{ - /* - * Free stored Tcl_Objs. - */ - - if (info->msg) { - Tcl_DecrRefCount(info->msg); - } - if (info->error) { - Tcl_DecrRefCount(info->error); - } - - /* - * Free allocated structure. - */ - - Tcl_Free(info); -} - -/* - *---------------------------------------------------------------------- - * - * RefreshProcessInfo -- - * - * Refresh process info. - * - * Results: - * Nonzero if state changed, else zero. - * - * Side effects: - * May call WaitProcessStatus, which can block if WNOHANG option is set. - * - *---------------------------------------------------------------------- - */ - -int -RefreshProcessInfo( - ProcessInfo *info, /* Structure to refresh. */ - int options /* Options passed to WaitProcessStatus. */ -) -{ - if (info->status == TCL_PROCESS_UNCHANGED) { - /* - * Refresh & store status. - */ - - info->status = WaitProcessStatus(info->pid, info->resolvedPid, - options, &info->code, &info->msg, &info->error); - if (info->msg) Tcl_IncrRefCount(info->msg); - if (info->error) Tcl_IncrRefCount(info->error); - return (info->status != TCL_PROCESS_UNCHANGED); - } else { - /* - * No change. - */ - - return 0; - } -} - -/* - *---------------------------------------------------------------------- - * - * WaitProcessStatus -- - * - * Wait for process status to change. - * - * Results: - * TclProcessWaitStatus enum value. - * - * Side effects: - * May call WaitProcessStatus, which can block if WNOHANG option is set. - * - *---------------------------------------------------------------------- - */ - -TclProcessWaitStatus -WaitProcessStatus( - Tcl_Pid pid, /* Process id. */ - size_t resolvedPid, /* Resolved process id. */ - int options, /* Options passed to Tcl_WaitPid. */ - int *codePtr, /* If non-NULL, will receive either: - * - 0 for normal exit. - * - errno in case of error. - * - non-zero exit code for abormal exit. - * - signal number if killed or suspended. - * - Tcl_WaitPid status in all other cases. - */ - Tcl_Obj **msgObjPtr, /* If non-NULL, will receive error message. */ - Tcl_Obj **errorObjPtr) /* If non-NULL, will receive error code. */ -{ - int waitStatus; - Tcl_Obj *errorStrings[5]; - const char *msg; - - pid = Tcl_WaitPid(pid, &waitStatus, options); - if (pid == 0) { - /* - * No change. - */ - - return TCL_PROCESS_UNCHANGED; - } - - /* - * Get process status. - */ - - if (pid == (Tcl_Pid) -1) { - /* - * POSIX errName msg - */ - - msg = Tcl_ErrnoMsg(errno); - if (errno == ECHILD) { - /* - * This changeup in message suggested by Mark Diekhans to - * remind people that ECHILD errors can occur on some - * systems if SIGCHLD isn't in its default state. - */ - - msg = "child process lost (is SIGCHLD ignored or trapped?)"; - } - if (codePtr) *codePtr = errno; - if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf( - "error waiting for process to exit: %s", msg); - if (errorObjPtr) { - errorStrings[0] = Tcl_NewStringObj("POSIX", -1); - errorStrings[1] = Tcl_NewStringObj(Tcl_ErrnoId(), -1); - errorStrings[2] = Tcl_NewStringObj(msg, -1); - *errorObjPtr = Tcl_NewListObj(3, errorStrings); - } - return TCL_PROCESS_ERROR; - } else if (WIFEXITED(waitStatus)) { - if (codePtr) *codePtr = WEXITSTATUS(waitStatus); - if (!WEXITSTATUS(waitStatus)) { - /* - * Normal exit. - */ - - if (msgObjPtr) *msgObjPtr = NULL; - if (errorObjPtr) *errorObjPtr = NULL; - } else { - /* - * CHILDSTATUS pid code - * - * Child exited with a non-zero exit status. - */ - - if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj( - "child process exited abnormally", -1); - if (errorObjPtr) { - errorStrings[0] = Tcl_NewStringObj("CHILDSTATUS", -1); - errorStrings[1] = Tcl_NewIntObj(resolvedPid); - errorStrings[2] = Tcl_NewIntObj(WEXITSTATUS(waitStatus)); - *errorObjPtr = Tcl_NewListObj(3, errorStrings); - } - } - return TCL_PROCESS_EXITED; - } else if (WIFSIGNALED(waitStatus)) { - /* - * CHILDKILLED pid sigName msg - * - * Child killed because of a signal. - */ - - msg = Tcl_SignalMsg(WTERMSIG(waitStatus)); - if (codePtr) *codePtr = WTERMSIG(waitStatus); - if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf( - "child killed: %s", msg); - if (errorObjPtr) { - errorStrings[0] = Tcl_NewStringObj("CHILDKILLED", -1); - errorStrings[1] = Tcl_NewIntObj(resolvedPid); - errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WTERMSIG(waitStatus)), -1); - errorStrings[3] = Tcl_NewStringObj(msg, -1); - *errorObjPtr = Tcl_NewListObj(4, errorStrings); - } - return TCL_PROCESS_SIGNALED; - } else if (WIFSTOPPED(waitStatus)) { - /* - * CHILDSUSP pid sigName msg - * - * Child suspended because of a signal. - */ - - msg = Tcl_SignalMsg(WSTOPSIG(waitStatus)); - if (codePtr) *codePtr = WSTOPSIG(waitStatus); - if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf( - "child suspended: %s", msg); - if (errorObjPtr) { - errorStrings[0] = Tcl_NewStringObj("CHILDSUSP", -1); - errorStrings[1] = Tcl_NewIntObj(resolvedPid); - errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WSTOPSIG(waitStatus)), -1); - errorStrings[3] = Tcl_NewStringObj(msg, -1); - *errorObjPtr = Tcl_NewListObj(4, errorStrings); - } - return TCL_PROCESS_STOPPED; - } else { - /* - * TCL OPERATION EXEC ODDWAITRESULT - * - * Child wait status didn't make sense. - */ - - if (codePtr) *codePtr = waitStatus; - if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj( - "child wait status didn't make sense\n", -1); - if (errorObjPtr) { - errorStrings[0] = Tcl_NewStringObj("TCL", -1); - errorStrings[1] = Tcl_NewStringObj("OPERATION", -1); - errorStrings[2] = Tcl_NewStringObj("EXEC", -1); - errorStrings[3] = Tcl_NewStringObj("ODDWAITRESULT", -1); - errorStrings[4] = Tcl_NewIntObj(resolvedPid); - *errorObjPtr = Tcl_NewListObj(5, errorStrings); - } - return TCL_PROCESS_UNKNOWN_STATUS; - } -} - - -/* - *---------------------------------------------------------------------- - * - * BuildProcessStatusObj -- - * - * Build a list object with process status. The first element is always - * a standard Tcl return value, which can be either TCL_OK or TCL_ERROR. - * In the latter case, the second element is the error message and the - * third element is a Tcl error code (see tclvars). - * - * Results: - * A list object. - * - * Side effects: - * Tcl_Objs are created. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -BuildProcessStatusObj( - ProcessInfo *info) -{ - Tcl_Obj *resultObjs[3]; - - if (info->status == TCL_PROCESS_UNCHANGED) { - /* - * Process still running, return empty obj. - */ - - return Tcl_NewObj(); - } - if (info->status == TCL_PROCESS_EXITED && info->code == 0) { - /* - * Normal exit, return TCL_OK. - */ - - return Tcl_NewIntObj(TCL_OK); - } - - /* - * Abnormal exit, return {TCL_ERROR msg error} - */ - - resultObjs[0] = Tcl_NewIntObj(TCL_ERROR); - resultObjs[1] = info->msg; - resultObjs[2] = info->error; - return Tcl_NewListObj(3, resultObjs); -} - -/*---------------------------------------------------------------------- - * - * ProcessListObjCmd -- - * - * This function implements the 'tcl::process list' Tcl command. - * Refer to the user documentation for details on what it does. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * Access to the internal structures is protected by infoTablesMutex. - * - *---------------------------------------------------------------------- - */ - -static int -ProcessListObjCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Obj *list; - Tcl_HashEntry *entry; - Tcl_HashSearch search; - ProcessInfo *info; - - if (objc != 1) { - Tcl_WrongNumArgs(interp, 1, objv, NULL); - return TCL_ERROR; - } - - /* - * Return the list of all chid process ids. - */ - - list = Tcl_NewListObj(0, NULL); - Tcl_MutexLock(&infoTablesMutex); - for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); - entry != NULL; entry = Tcl_NextHashEntry(&search)) { - info = (ProcessInfo *) Tcl_GetHashValue(entry); - Tcl_ListObjAppendElement(interp, list, - Tcl_NewIntObj(info->resolvedPid)); - } - Tcl_MutexUnlock(&infoTablesMutex); - Tcl_SetObjResult(interp, list); - return TCL_OK; -} - -/*---------------------------------------------------------------------- - * - * ProcessStatusObjCmd -- - * - * This function implements the 'tcl::process status' Tcl command. - * Refer to the user documentation for details on what it does. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * Access to the internal structures is protected by infoTablesMutex. - * Calls RefreshProcessInfo, which can block if -wait switch is given. - * - *---------------------------------------------------------------------- - */ - -static int -ProcessStatusObjCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Obj *dict; - int index, options = WNOHANG; - Tcl_HashEntry *entry; - Tcl_HashSearch search; - ProcessInfo *info; - int numPids; - Tcl_Obj **pidObjs; - int result; - int i; - int pid; - Tcl_Obj *const *savedobjv = objv; - static const char *const switches[] = { - "-wait", "--", NULL - }; - enum switches { - STATUS_WAIT, STATUS_LAST - }; - - while (objc > 1) { - if (TclGetString(objv[1])[0] != '-') { - break; - } - if (Tcl_GetIndexFromObj(interp, objv[1], switches, "switches", 0, - &index) != TCL_OK) { - return TCL_ERROR; - } - ++objv; --objc; - if (STATUS_WAIT == (enum switches) index) { - options = 0; - } else { - break; - } - } - - if (objc != 1 && objc != 2) { - Tcl_WrongNumArgs(interp, 1, savedobjv, "?switches? ?pids?"); - return TCL_ERROR; - } - - if (objc == 1) { - /* - * Return a dict with all child process statuses. - */ - - dict = Tcl_NewDictObj(); - Tcl_MutexLock(&infoTablesMutex); - for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); - entry != NULL; entry = Tcl_NextHashEntry(&search)) { - info = (ProcessInfo *) Tcl_GetHashValue(entry); - RefreshProcessInfo(info, options); - - if (info->purge && autopurge) { - /* - * Purge entry. - */ - - Tcl_DeleteHashEntry(entry); - entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); - Tcl_DeleteHashEntry(entry); - FreeProcessInfo(info); - } else { - /* - * Add to result. - */ - - Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), - BuildProcessStatusObj(info)); - } - } - Tcl_MutexUnlock(&infoTablesMutex); - } else { - /* - * Only return statuses of provided processes. - */ - - result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs); - if (result != TCL_OK) { - return result; - } - dict = Tcl_NewDictObj(); - Tcl_MutexLock(&infoTablesMutex); - for (i = 0; i < numPids; i++) { - result = Tcl_GetIntFromObj(interp, pidObjs[i], &pid); - if (result != TCL_OK) { - Tcl_MutexUnlock(&infoTablesMutex); - Tcl_DecrRefCount(dict); - return result; - } - - entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid)); - if (!entry) { - /* - * Skip unknown process. - */ - - continue; - } - - info = (ProcessInfo *) Tcl_GetHashValue(entry); - RefreshProcessInfo(info, options); - - if (info->purge && autopurge) { - /* - * Purge entry. - */ - - Tcl_DeleteHashEntry(entry); - entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); - Tcl_DeleteHashEntry(entry); - FreeProcessInfo(info); - } else { - /* - * Add to result. - */ - - Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), - BuildProcessStatusObj(info)); - } - } - Tcl_MutexUnlock(&infoTablesMutex); - } - Tcl_SetObjResult(interp, dict); - return TCL_OK; -} - -/*---------------------------------------------------------------------- - * - * ProcessPurgeObjCmd -- - * - * This function implements the 'tcl::process purge' Tcl command. - * Refer to the user documentation for details on what it does. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * Frees all ProcessInfo structures with their purge flag set. - * - *---------------------------------------------------------------------- - */ - -static int -ProcessPurgeObjCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_HashEntry *entry; - Tcl_HashSearch search; - ProcessInfo *info; - int numPids; - Tcl_Obj **pidObjs; - int result; - int i; - int pid; - - if (objc != 1 && objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "?pids?"); - return TCL_ERROR; - } - - /* - * First reap detached procs so that their purge flag is up-to-date. - */ - - Tcl_ReapDetachedProcs(); - - if (objc == 1) { - /* - * Purge all terminated processes. - */ - - Tcl_MutexLock(&infoTablesMutex); - for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); - entry != NULL; entry = Tcl_NextHashEntry(&search)) { - info = (ProcessInfo *) Tcl_GetHashValue(entry); - if (info->purge) { - Tcl_DeleteHashEntry(entry); - entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); - Tcl_DeleteHashEntry(entry); - FreeProcessInfo(info); - } - } - Tcl_MutexUnlock(&infoTablesMutex); - } else { - /* - * Purge only provided processes. - */ - - result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs); - if (result != TCL_OK) { - return result; - } - Tcl_MutexLock(&infoTablesMutex); - for (i = 0; i < numPids; i++) { - result = Tcl_GetIntFromObj(interp, pidObjs[i], &pid); - if (result != TCL_OK) { - Tcl_MutexUnlock(&infoTablesMutex); - return result; - } - - entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid)); - if (!entry) { - /* - * Skip unknown process. - */ - - continue; - } - - info = (ProcessInfo *) Tcl_GetHashValue(entry); - if (info->purge) { - Tcl_DeleteHashEntry(entry); - entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); - Tcl_DeleteHashEntry(entry); - FreeProcessInfo(info); - } - } - Tcl_MutexUnlock(&infoTablesMutex); - } - - return TCL_OK; -} - -/*---------------------------------------------------------------------- - * - * ProcessAutopurgeObjCmd -- - * - * This function implements the 'tcl::process autopurge' Tcl command. - * Refer to the user documentation for details on what it does. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * Alters detached process handling by Tcl_ReapDetachedProcs(). - * - *---------------------------------------------------------------------- - */ - -static int -ProcessAutopurgeObjCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - if (objc != 1 && objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "?flag?"); - return TCL_ERROR; - } - - if (objc == 2) { - /* - * Set given value. - */ - - int flag; - int result = Tcl_GetBooleanFromObj(interp, objv[1], &flag); - if (result != TCL_OK) { - return result; - } - - autopurge = !!flag; - } - - /* - * Return current value. - */ - - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(autopurge)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclInitProcessCmd -- - * - * This procedure creates the "tcl::process" Tcl command. See the user - * documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -Tcl_Command -TclInitProcessCmd( - Tcl_Interp *interp) /* Current interpreter. */ -{ - static const EnsembleImplMap processImplMap[] = { - {"list", ProcessListObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1}, - {"status", ProcessStatusObjCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1}, - {"purge", ProcessPurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, - {"autopurge", ProcessAutopurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, - {NULL, NULL, NULL, NULL, NULL, 0} - }; - Tcl_Command processCmd; - - if (infoTablesInitialized == 0) { - Tcl_MutexLock(&infoTablesMutex); - if (infoTablesInitialized == 0) { - Tcl_InitHashTable(&infoTablePerPid, TCL_ONE_WORD_KEYS); - Tcl_InitHashTable(&infoTablePerResolvedPid, TCL_ONE_WORD_KEYS); - infoTablesInitialized = 1; - } - Tcl_MutexUnlock(&infoTablesMutex); - } - - processCmd = TclMakeEnsemble(interp, "::tcl::process", processImplMap); - Tcl_Export(interp, Tcl_FindNamespace(interp, "::tcl", NULL, 0), - "process", 0); - return processCmd; -} - -/* - *---------------------------------------------------------------------- - * - * TclProcessCreated -- - * - * Called when a child process has been created by Tcl. - * - * Results: - * None. - * - * Side effects: - * Internal structures are updated with a new ProcessInfo. - * - *---------------------------------------------------------------------- - */ - -void -TclProcessCreated( - Tcl_Pid pid) /* Process id. */ -{ - size_t resolvedPid; - Tcl_HashEntry *entry, *entry2; - int isNew; - ProcessInfo *info; - - /* - * Get resolved pid first. - */ - - resolvedPid = TclpGetPid(pid); - - Tcl_MutexLock(&infoTablesMutex); - - /* - * Create entry in pid table. - */ - - entry = Tcl_CreateHashEntry(&infoTablePerPid, pid, &isNew); - if (!isNew) { - /* - * Pid was reused, free old info and reuse structure. - */ - - info = (ProcessInfo *) Tcl_GetHashValue(entry); - entry2 = Tcl_FindHashEntry(&infoTablePerResolvedPid, - INT2PTR(resolvedPid)); - if (entry2) Tcl_DeleteHashEntry(entry2); - FreeProcessInfo(info); - } - - /* - * Allocate and initialize info structure. - */ - - info = (ProcessInfo *) Tcl_Alloc(sizeof(ProcessInfo)); - InitProcessInfo(info, pid, resolvedPid); - - /* - * Add entry to tables. - */ - - Tcl_SetHashValue(entry, info); - entry = Tcl_CreateHashEntry(&infoTablePerResolvedPid, INT2PTR(resolvedPid), - &isNew); - Tcl_SetHashValue(entry, info); - - Tcl_MutexUnlock(&infoTablesMutex); -} - -/* - *---------------------------------------------------------------------- - * - * TclProcessWait -- - * - * Wait for process status to change. - * - * Results: - * TclProcessWaitStatus enum value. - * - * Side effects: - * Completed process info structures are purged immediately (autopurge on) - * or eventually (autopurge off). - * - *---------------------------------------------------------------------- - */ - -TclProcessWaitStatus -TclProcessWait( - Tcl_Pid pid, /* Process id. */ - int options, /* Options passed to WaitProcessStatus. */ - int *codePtr, /* If non-NULL, will receive either: - * - 0 for normal exit. - * - errno in case of error. - * - non-zero exit code for abormal exit. - * - signal number if killed or suspended. - * - Tcl_WaitPid status in all other cases. - */ - Tcl_Obj **msgObjPtr, /* If non-NULL, will receive error message. */ - Tcl_Obj **errorObjPtr) /* If non-NULL, will receive error code. */ -{ - Tcl_HashEntry *entry; - ProcessInfo *info; - TclProcessWaitStatus result; - - /* - * First search for pid in table. - */ - - Tcl_MutexLock(&infoTablesMutex); - entry = Tcl_FindHashEntry(&infoTablePerPid, pid); - if (!entry) { - /* - * Unknown process, just call WaitProcessStatus and return. - */ - - result = WaitProcessStatus(pid, TclpGetPid(pid), options, codePtr, - msgObjPtr, errorObjPtr); - if (msgObjPtr && *msgObjPtr) Tcl_IncrRefCount(*msgObjPtr); - if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr); - Tcl_MutexUnlock(&infoTablesMutex); - return result; - } - - info = (ProcessInfo *) Tcl_GetHashValue(entry); - if (info->purge) { - /* - * Process has completed but TclProcessWait has already been called, - * so report no change. - */ - Tcl_MutexUnlock(&infoTablesMutex); - - return TCL_PROCESS_UNCHANGED; - } - - RefreshProcessInfo(info, options); - if (info->status == TCL_PROCESS_UNCHANGED) { - /* - * No change, stop there. - */ - Tcl_MutexUnlock(&infoTablesMutex); - - return TCL_PROCESS_UNCHANGED; - } - - /* - * Set return values. - */ - - result = info->status; - if (codePtr) *codePtr = info->code; - if (msgObjPtr) *msgObjPtr = info->msg; - if (errorObjPtr) *errorObjPtr = info->error; - if (msgObjPtr && *msgObjPtr) Tcl_IncrRefCount(*msgObjPtr); - if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr); - - if (autopurge) { - /* - * Purge now. - */ - - Tcl_DeleteHashEntry(entry); - entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, - INT2PTR(info->resolvedPid)); - Tcl_DeleteHashEntry(entry); - FreeProcessInfo(info); - } else { - /* - * Eventually purge. Subsequent calls will return - * TCL_PROCESS_UNCHANGED. - */ - - info->purge = 1; - } - Tcl_MutexUnlock(&infoTablesMutex); - return result; -} Index: generic/tclRegexp.c ================================================================== --- generic/tclRegexp.c +++ generic/tclRegexp.c @@ -11,11 +11,10 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclRegexp.h" -#include /* *---------------------------------------------------------------------- * The routines in this file use Henry Spencer's regular expression package * contained in the following additional source files: @@ -68,11 +67,11 @@ typedef struct { int initialized; /* Set to 1 when the module is initialized. */ char *patterns[NUM_REGEXPS];/* Strings corresponding to compiled regular * expression patterns. NULL means that this * slot isn't used. Malloc-ed. */ - size_t patLengths[NUM_REGEXPS];/* Number of non-null characters in + int patLengths[NUM_REGEXPS];/* Number of non-null characters in * corresponding entry in patterns. -1 means * entry isn't used. */ struct TclRegexp *regexps[NUM_REGEXPS]; /* Compiled forms of above strings. Also * malloc-ed, or NULL if not in use yet. */ @@ -83,19 +82,19 @@ /* * Declarations for functions used only in this file. */ static TclRegexp * CompileRegexp(Tcl_Interp *interp, const char *pattern, - size_t length, int flags); + int length, int flags); static void DupRegexpInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static void FinalizeRegexp(ClientData clientData); static void FreeRegexp(TclRegexp *regexpPtr); static void FreeRegexpInternalRep(Tcl_Obj *objPtr); static int RegExpExecUniChar(Tcl_Interp *interp, Tcl_RegExp re, - const Tcl_UniChar *uniString, size_t numChars, - size_t nmatches, int flags); + const Tcl_UniChar *uniString, int numChars, + int nmatches, int flags); static int SetRegexpFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); /* * The regular expression Tcl object type. This serves as a cache of the * compiled form of the regular expression. @@ -106,27 +105,10 @@ FreeRegexpInternalRep, /* freeIntRepProc */ DupRegexpInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ SetRegexpFromAny /* setFromAnyProc */ }; - -#define RegexpSetIntRep(objPtr, rePtr) \ - do { \ - Tcl_ObjIntRep ir; \ - (rePtr)->refCount++; \ - ir.twoPtrValue.ptr1 = (rePtr); \ - ir.twoPtrValue.ptr2 = NULL; \ - Tcl_StoreIntRep((objPtr), &tclRegexpType, &ir); \ - } while (0) - -#define RegexpGetIntRep(objPtr, rePtr) \ - do { \ - const Tcl_ObjIntRep *irPtr; \ - irPtr = TclFetchIntRep((objPtr), &tclRegexpType); \ - (rePtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ - } while (0) - /* *---------------------------------------------------------------------- * * Tcl_RegExpCompile -- @@ -188,12 +170,11 @@ const char *text, /* Text against which to match re. */ const char *start) /* If text is part of a larger string, this * identifies beginning of larger string, so * that "^" won't match. */ { - int flags, result; - size_t numChars; + int flags, result, numChars; TclRegexp *regexp = (TclRegexp *) re; Tcl_DString ds; const Tcl_UniChar *ustr; /* @@ -249,11 +230,11 @@ void Tcl_RegExpRange( Tcl_RegExp re, /* Compiled regular expression that has been * passed to Tcl_RegExpExec. */ - size_t index, /* 0 means give the range of the entire match, + int index, /* 0 means give the range of the entire match, * > 0 means give the range of a matching * subrange. */ const char **startPtr, /* Store address of first character in * (sub-)range here. */ const char **endPtr) /* Store address of character just after last @@ -260,13 +241,13 @@ * in (sub-)range here. */ { TclRegexp *regexpPtr = (TclRegexp *) re; const char *string; - if (index > regexpPtr->re.re_nsub) { + if ((size_t) index > regexpPtr->re.re_nsub) { *startPtr = *endPtr = NULL; - } else if (regexpPtr->matches[index].rm_so == TCL_INDEX_NONE) { + } else if (regexpPtr->matches[index].rm_so == -1) { *startPtr = *endPtr = NULL; } else { if (regexpPtr->objPtr) { string = TclGetString(regexpPtr->objPtr); } else { @@ -301,25 +282,27 @@ RegExpExecUniChar( Tcl_Interp *interp, /* Interpreter to use for error reporting. */ Tcl_RegExp re, /* Compiled regular expression; returned by a * previous call to Tcl_GetRegExpFromObj */ const Tcl_UniChar *wString, /* String against which to match re. */ - size_t numChars, /* Length of Tcl_UniChar string. */ - size_t nm, /* How many subexpression matches (counting + int numChars, /* Length of Tcl_UniChar string (must be + * >=0). */ + int nmatches, /* How many subexpression matches (counting * the whole match as subexpression 0) are of * interest. -1 means "don't know". */ int flags) /* Regular expression flags. */ { int status; TclRegexp *regexpPtr = (TclRegexp *) re; size_t last = regexpPtr->re.re_nsub + 1; + size_t nm = last; - if (nm >= last) { - nm = last; + if (nmatches >= 0 && (size_t) nmatches < nm) { + nm = (size_t) nmatches; } - status = TclReExec(®expPtr->re, wString, numChars, + status = TclReExec(®expPtr->re, wString, (size_t) numChars, ®expPtr->details, nm, regexpPtr->matches, flags); /* * Check for errors. */ @@ -359,27 +342,27 @@ void TclRegExpRangeUniChar( Tcl_RegExp re, /* Compiled regular expression that has been * passed to Tcl_RegExpExec. */ - size_t index, /* 0 means give the range of the entire match, + int index, /* 0 means give the range of the entire match, * > 0 means give the range of a matching - * subrange, TCL_INDEX_NONE means the range of the + * subrange, -1 means the range of the * rm_extend field. */ - size_t *startPtr, /* Store address of first character in + int *startPtr, /* Store address of first character in * (sub-)range here. */ - size_t *endPtr) /* Store address of character just after last + int *endPtr) /* Store address of character just after last * in (sub-)range here. */ { TclRegexp *regexpPtr = (TclRegexp *) re; - if ((regexpPtr->flags®_EXPECT) && (index == TCL_INDEX_NONE)) { + if ((regexpPtr->flags®_EXPECT) && (index == -1)) { *startPtr = regexpPtr->details.rm_extend.rm_so; *endPtr = regexpPtr->details.rm_extend.rm_eo; - } else if (index + 1 > regexpPtr->re.re_nsub + 1) { - *startPtr = TCL_INDEX_NONE; - *endPtr = TCL_INDEX_NONE; + } else if ((size_t) index > regexpPtr->re.re_nsub) { + *startPtr = -1; + *endPtr = -1; } else { *startPtr = regexpPtr->matches[index].rm_so; *endPtr = regexpPtr->matches[index].rm_eo; } } @@ -439,20 +422,20 @@ Tcl_Interp *interp, /* Interpreter to use for error reporting. */ Tcl_RegExp re, /* Compiled regular expression; must have been * returned by previous call to * Tcl_GetRegExpFromObj. */ Tcl_Obj *textObj, /* Text against which to match re. */ - size_t offset, /* Character index that marks where matching + int offset, /* Character index that marks where matching * should begin. */ - size_t nmatches, /* How many subexpression matches (counting + int nmatches, /* How many subexpression matches (counting * the whole match as subexpression 0) are of * interest. -1 means all of them. */ int flags) /* Regular expression execution flags. */ { TclRegexp *regexpPtr = (TclRegexp *) re; Tcl_UniChar *udata; - size_t length; + int length; int reflags = regexpPtr->flags; #define TCL_REG_GLOBOK_FLAGS \ (TCL_REG_ADVANCED | TCL_REG_NOSUB | TCL_REG_NOCASE) /* @@ -479,11 +462,11 @@ */ regexpPtr->string = NULL; regexpPtr->objPtr = textObj; - udata = TclGetUnicodeFromObj(textObj, &length); + udata = Tcl_GetUnicodeFromObj(textObj, &length); if (offset > length) { offset = length; } udata += offset; @@ -591,25 +574,44 @@ * expression pattern. Internal rep will be * changed to compiled form of this regular * expression. */ int flags) /* Regular expression compilation flags. */ { - size_t length; + int length; TclRegexp *regexpPtr; const char *pattern; - RegexpGetIntRep(objPtr, regexpPtr); + /* + * This is OK because we only actually interpret this value properly as a + * TclRegexp* when the type is tclRegexpType. + */ + + regexpPtr = objPtr->internalRep.twoPtrValue.ptr1; - if ((regexpPtr == NULL) || (regexpPtr->flags != flags)) { + if ((objPtr->typePtr != &tclRegexpType) || (regexpPtr->flags != flags)) { pattern = TclGetStringFromObj(objPtr, &length); regexpPtr = CompileRegexp(interp, pattern, length, flags); if (regexpPtr == NULL) { return NULL; } - RegexpSetIntRep(objPtr, regexpPtr); + /* + * Add a reference to the regexp so it will persist even if it is + * pushed out of the current thread's regexp cache. This reference + * will be removed when the object's internal rep is freed. + */ + + regexpPtr->refCount++; + + /* + * Free the old representation and set our type. + */ + + TclFreeIntRep(objPtr); + objPtr->internalRep.twoPtrValue.ptr1 = regexpPtr; + objPtr->typePtr = &tclRegexpType; } return (Tcl_RegExp) regexpPtr; } /* @@ -675,11 +677,11 @@ * well and Tcl has other limits that constrain things as well... */ resultObj = Tcl_NewObj(); Tcl_ListObjAppendElement(NULL, resultObj, - TclNewWideIntObjFromSize(regexpPtr->re.re_nsub)); + Tcl_NewIntObj((int) regexpPtr->re.re_nsub)); /* * Now append a list of all the bit-flags set for the RE. */ @@ -722,16 +724,16 @@ char cbuf[TCL_INTEGER_SPACE]; size_t n; const char *p; Tcl_ResetResult(interp); - n = TclReError(status, NULL, buf, sizeof(buf)); + n = TclReError(status, buf, sizeof(buf)); p = (n > sizeof(buf)) ? "..." : ""; Tcl_SetObjResult(interp, Tcl_ObjPrintf("%s%s%s", msg, buf, p)); sprintf(cbuf, "%d", status); - (void) TclReError(REG_ITOA, NULL, cbuf, sizeof(cbuf)); + (void) TclReError(REG_ITOA, cbuf, sizeof(cbuf)); Tcl_SetErrorCode(interp, "REGEXP", cbuf, buf, NULL); } /* *---------------------------------------------------------------------- @@ -752,23 +754,20 @@ static void FreeRegexpInternalRep( Tcl_Obj *objPtr) /* Regexp object with internal rep to free. */ { - TclRegexp *regexpRepPtr; - - RegexpGetIntRep(objPtr, regexpRepPtr); - - assert(regexpRepPtr != NULL); + TclRegexp *regexpRepPtr = objPtr->internalRep.twoPtrValue.ptr1; /* * If this is the last reference to the regexp, free it. */ if (regexpRepPtr->refCount-- <= 1) { FreeRegexp(regexpRepPtr); } + objPtr->typePtr = NULL; } /* *---------------------------------------------------------------------- * @@ -789,17 +788,15 @@ static void DupRegexpInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - TclRegexp *regexpPtr; + TclRegexp *regexpPtr = srcPtr->internalRep.twoPtrValue.ptr1; - RegexpGetIntRep(srcPtr, regexpPtr); - - assert(regexpPtr != NULL); - - RegexpSetIntRep(copyPtr, regexpPtr); + regexpPtr->refCount++; + copyPtr->internalRep.twoPtrValue.ptr1 = srcPtr->internalRep.twoPtrValue.ptr1; + copyPtr->typePtr = &tclRegexpType; } /* *---------------------------------------------------------------------- * @@ -855,11 +852,11 @@ static TclRegexp * CompileRegexp( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ const char *string, /* The regexp to compile (UTF-8). */ - size_t length, /* The length of the string in bytes. */ + int length, /* The length of the string in bytes. */ int flags) /* Compilation flags. */ { TclRegexp *regexpPtr; const Tcl_UniChar *uniString; int numChars, status, i, exact; @@ -913,11 +910,11 @@ /* * This is a new expression, so compile it and add it to the cache. */ - regexpPtr = Tcl_Alloc(sizeof(TclRegexp)); + regexpPtr = (TclRegexp*)ckalloc(sizeof(TclRegexp)); regexpPtr->objPtr = NULL; regexpPtr->string = NULL; regexpPtr->details.rm_extend.rm_so = -1; regexpPtr->details.rm_extend.rm_eo = -1; @@ -940,11 +937,11 @@ if (status != REG_OKAY) { /* * Clean up and report errors in the interpreter, if possible. */ - Tcl_Free(regexpPtr); + ckfree(regexpPtr); if (interp) { TclRegError(interp, "couldn't compile regular expression pattern: ", status); } return NULL; @@ -968,11 +965,11 @@ * Allocate enough space for all of the subexpressions, plus one extra for * the entire pattern. */ regexpPtr->matches = - Tcl_Alloc(sizeof(regmatch_t) * (regexpPtr->re.re_nsub + 1)); + (regmatch_t*)ckalloc(sizeof(regmatch_t) * (regexpPtr->re.re_nsub + 1)); /* * Initialize the refcount to one initially, since it is in the cache. */ @@ -987,18 +984,18 @@ TclRegexp *oldRegexpPtr = tsdPtr->regexps[NUM_REGEXPS-1]; if (oldRegexpPtr->refCount-- <= 1) { FreeRegexp(oldRegexpPtr); } - Tcl_Free(tsdPtr->patterns[NUM_REGEXPS-1]); + ckfree(tsdPtr->patterns[NUM_REGEXPS-1]); } for (i = NUM_REGEXPS - 2; i >= 0; i--) { tsdPtr->patterns[i+1] = tsdPtr->patterns[i]; tsdPtr->patLengths[i+1] = tsdPtr->patLengths[i]; tsdPtr->regexps[i+1] = tsdPtr->regexps[i]; } - tsdPtr->patterns[0] = Tcl_Alloc(length + 1); + tsdPtr->patterns[0] = (char *)ckalloc(length + 1); memcpy(tsdPtr->patterns[0], string, length + 1); tsdPtr->patLengths[0] = length; tsdPtr->regexps[0] = regexpPtr; return regexpPtr; @@ -1027,13 +1024,13 @@ TclReFree(®expPtr->re); if (regexpPtr->globObjPtr) { TclDecrRefCount(regexpPtr->globObjPtr); } if (regexpPtr->matches) { - Tcl_Free(regexpPtr->matches); + ckfree(regexpPtr->matches); } - Tcl_Free(regexpPtr); + ckfree(regexpPtr); } /* *---------------------------------------------------------------------- * @@ -1061,11 +1058,11 @@ for (i = 0; (i < NUM_REGEXPS) && (tsdPtr->patterns[i] != NULL); i++) { regexpPtr = tsdPtr->regexps[i]; if (regexpPtr->refCount-- <= 1) { FreeRegexp(regexpPtr); } - Tcl_Free(tsdPtr->patterns[i]); + ckfree(tsdPtr->patterns[i]); tsdPtr->patterns[i] = NULL; } /* * We may find ourselves reinitialized if another finalization routine Index: generic/tclRegexp.h ================================================================== --- generic/tclRegexp.h +++ generic/tclRegexp.h @@ -35,11 +35,11 @@ * representation of the last string matched * with this regexp to indicate the location * of subexpressions. */ rm_detail_t details; /* Detailed information on match (currently * used only for REG_EXPECT). */ - size_t refCount; /* Count of number of references to this + int refCount; /* Count of number of references to this * compiled regexp. */ } TclRegexp; #endif /* _TCLREGEXP */ Index: generic/tclResolve.c ================================================================== --- generic/tclResolve.c +++ generic/tclResolve.c @@ -99,13 +99,13 @@ /* * Otherwise, this is a new scheme. Add it to the FRONT of the linked * list, so that it overrides existing schemes. */ - resPtr = Tcl_Alloc(sizeof(ResolverScheme)); + resPtr = ckalloc(sizeof(ResolverScheme)); len = strlen(name) + 1; - resPtr->name = Tcl_Alloc(len); + resPtr->name = ckalloc(len); memcpy(resPtr->name, name, len); resPtr->cmdResProc = cmdProc; resPtr->varResProc = varProc; resPtr->compiledVarResProc = compiledVarProc; resPtr->nextPtr = iPtr->resolverPtr; @@ -223,12 +223,12 @@ if (resPtr->cmdResProc) { BumpCmdRefEpochs(iPtr->globalNsPtr); } *prevPtrPtr = resPtr->nextPtr; - Tcl_Free(resPtr->name); - Tcl_Free(resPtr); + ckfree(resPtr->name); + ckfree(resPtr); return 1; } return 0; } Index: generic/tclResult.c ================================================================== --- generic/tclResult.c +++ generic/tclResult.c @@ -25,18 +25,19 @@ */ static Tcl_Obj ** GetKeys(void); static void ReleaseKeys(ClientData clientData); static void ResetObjResult(Interp *iPtr); +static void SetupAppendBuffer(Interp *iPtr, int newSpace); /* * This structure is used to take a snapshot of the interpreter state in * Tcl_SaveInterpState. You can snapshot the state, execute a command, and * then back up to the result or the error that was previously in progress. */ -typedef struct { +typedef struct InterpState { int status; /* return code status */ int flags; /* Each remaining field saves the */ int returnLevel; /* corresponding field of the Interp */ int returnCode; /* struct. These fields taken together are */ Tcl_Obj *errorInfo; /* the "state" of the interp. */ @@ -72,11 +73,11 @@ Tcl_SaveInterpState( Tcl_Interp *interp, /* Interpreter's state to be saved */ int status) /* status code for current operation */ { Interp *iPtr = (Interp *) interp; - InterpState *statePtr = Tcl_Alloc(sizeof(InterpState)); + InterpState *statePtr = ckalloc(sizeof(InterpState)); statePtr->status = status; statePtr->flags = iPtr->flags & ERR_ALREADY_LOGGED; statePtr->returnLevel = iPtr->returnLevel; statePtr->returnCode = iPtr->returnCode; @@ -202,11 +203,300 @@ } if (statePtr->errorStack) { Tcl_DecrRefCount(statePtr->errorStack); } Tcl_DecrRefCount(statePtr->objResult); - Tcl_Free(statePtr); + ckfree(statePtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SaveResult -- + * + * Takes a snapshot of the current result state of the interpreter. The + * snapshot can be restored at any point by Tcl_RestoreResult. Note that + * this routine does not preserve the errorCode, errorInfo, or flags + * fields so it should not be used if an error is in progress. + * + * Once a snapshot is saved, it must be restored by calling + * Tcl_RestoreResult, or discarded by calling Tcl_DiscardResult. + * + * Results: + * None. + * + * Side effects: + * Resets the interpreter result. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_SaveResult +void +Tcl_SaveResult( + Tcl_Interp *interp, /* Interpreter to save. */ + Tcl_SavedResult *statePtr) /* Pointer to state structure. */ +{ + Interp *iPtr = (Interp *) interp; + + /* + * Move the result object into the save state. Note that we don't need to + * change its refcount because we're moving it, not adding a new + * reference. Put an empty object into the interpreter. + */ + + statePtr->objResultPtr = iPtr->objResultPtr; + iPtr->objResultPtr = Tcl_NewObj(); + Tcl_IncrRefCount(iPtr->objResultPtr); + + /* + * Save the string result. + */ + + statePtr->freeProc = iPtr->freeProc; + if (iPtr->result == iPtr->resultSpace) { + /* + * Copy the static string data out of the interp buffer. + */ + + statePtr->result = statePtr->resultSpace; + strcpy(statePtr->result, iPtr->result); + statePtr->appendResult = NULL; + } else if (iPtr->result == iPtr->appendResult) { + /* + * Move the append buffer out of the interp. + */ + + statePtr->appendResult = iPtr->appendResult; + statePtr->appendAvl = iPtr->appendAvl; + statePtr->appendUsed = iPtr->appendUsed; + statePtr->result = statePtr->appendResult; + iPtr->appendResult = NULL; + iPtr->appendAvl = 0; + iPtr->appendUsed = 0; + } else { + /* + * Move the dynamic or static string out of the interpreter. + */ + + statePtr->result = iPtr->result; + statePtr->appendResult = NULL; + } + + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = 0; + iPtr->freeProc = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RestoreResult -- + * + * Restores the state of the interpreter to a snapshot taken by + * Tcl_SaveResult. After this call, the token for the interpreter state + * is no longer valid. + * + * Results: + * None. + * + * Side effects: + * Restores the interpreter result. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_RestoreResult +void +Tcl_RestoreResult( + Tcl_Interp *interp, /* Interpreter being restored. */ + Tcl_SavedResult *statePtr) /* State returned by Tcl_SaveResult. */ +{ + Interp *iPtr = (Interp *) interp; + + Tcl_ResetResult(interp); + + /* + * Restore the string result. + */ + + iPtr->freeProc = statePtr->freeProc; + if (statePtr->result == statePtr->resultSpace) { + /* + * Copy the static string data into the interp buffer. + */ + + iPtr->result = iPtr->resultSpace; + strcpy(iPtr->result, statePtr->result); + } else if (statePtr->result == statePtr->appendResult) { + /* + * Move the append buffer back into the interp. + */ + + if (iPtr->appendResult != NULL) { + ckfree(iPtr->appendResult); + } + + iPtr->appendResult = statePtr->appendResult; + iPtr->appendAvl = statePtr->appendAvl; + iPtr->appendUsed = statePtr->appendUsed; + iPtr->result = iPtr->appendResult; + } else { + /* + * Move the dynamic or static string back into the interpreter. + */ + + iPtr->result = statePtr->result; + } + + /* + * Restore the object result. + */ + + Tcl_DecrRefCount(iPtr->objResultPtr); + iPtr->objResultPtr = statePtr->objResultPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DiscardResult -- + * + * Frees the memory associated with an interpreter snapshot taken by + * Tcl_SaveResult. If the snapshot is not restored, this function must be + * called to discard it, or the memory will be lost. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_DiscardResult +void +Tcl_DiscardResult( + Tcl_SavedResult *statePtr) /* State returned by Tcl_SaveResult. */ +{ + TclDecrRefCount(statePtr->objResultPtr); + + if (statePtr->result == statePtr->appendResult) { + ckfree(statePtr->appendResult); + } else if (statePtr->freeProc == TCL_DYNAMIC) { + ckfree(statePtr->result); + } else if (statePtr->freeProc) { + statePtr->freeProc(statePtr->result); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetResult -- + * + * Arrange for "result" to be the Tcl return value. + * + * Results: + * None. + * + * Side effects: + * interp->result is left pointing either to "result" or to a copy of it. + * Also, the object result is reset. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetResult( + Tcl_Interp *interp, /* Interpreter with which to associate the + * return value. */ + char *result, /* Value to be returned. If NULL, the result + * is set to an empty string. */ + Tcl_FreeProc *freeProc) /* Gives information about the string: + * TCL_STATIC, TCL_VOLATILE, or the address of + * a Tcl_FreeProc such as free. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_FreeProc *oldFreeProc = iPtr->freeProc; + char *oldResult = iPtr->result; + + if (result == NULL) { + iPtr->resultSpace[0] = 0; + iPtr->result = iPtr->resultSpace; + iPtr->freeProc = 0; + } else if (freeProc == TCL_VOLATILE) { + int length = strlen(result); + + if (length > TCL_RESULT_SIZE) { + iPtr->result = ckalloc(length + 1); + iPtr->freeProc = TCL_DYNAMIC; + } else { + iPtr->result = iPtr->resultSpace; + iPtr->freeProc = 0; + } + memcpy(iPtr->result, result, length+1); + } else { + iPtr->result = (char *) result; + iPtr->freeProc = freeProc; + } + + /* + * If the old result was dynamically-allocated, free it up. Do it here, + * rather than at the beginning, in case the new result value was part of + * the old result value. + */ + + if (oldFreeProc != 0) { + if (oldFreeProc == TCL_DYNAMIC) { + ckfree(oldResult); + } else { + oldFreeProc(oldResult); + } + } + + /* + * Reset the object result since we just set the string result. + */ + + ResetObjResult(iPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetStringResult -- + * + * Returns an interpreter's result value as a string. + * + * Results: + * The interpreter's result as a string. + * + * Side effects: + * If the string result is empty, the object result is moved to the + * string result, then the object result is reset. + * + *---------------------------------------------------------------------- + */ + +const char * +Tcl_GetStringResult( + Tcl_Interp *interp)/* Interpreter whose result to return. */ +{ + /* + * If the string result is empty, move the object result to the string + * result, then reset the object result. + */ + + Interp *iPtr = (Interp *) interp; + + if (*(iPtr->result) == 0) { + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), + TCL_VOLATILE); + } + return iPtr->result; } /* *---------------------------------------------------------------------- * @@ -228,15 +518,15 @@ void Tcl_SetObjResult( Tcl_Interp *interp, /* Interpreter with which to associate the * return object value. */ - register Tcl_Obj *objPtr) /* Tcl object to be returned. If NULL, the obj + Tcl_Obj *objPtr) /* Tcl object to be returned. If NULL, the obj * result is made an empty string object. */ { - register Interp *iPtr = (Interp *) interp; - register Tcl_Obj *oldObjResult = iPtr->objResultPtr; + Interp *iPtr = (Interp *) interp; + Tcl_Obj *oldObjResult = iPtr->objResultPtr; iPtr->objResultPtr = objPtr; Tcl_IncrRefCount(objPtr); /* since interp result is a reference */ /* @@ -243,10 +533,25 @@ * We wait until the end to release the old object result, in case we are * setting the result to itself. */ TclDecrRefCount(oldObjResult); + + /* + * Reset the string result since we just set the result object. + */ + + if (iPtr->freeProc != NULL) { + if (iPtr->freeProc == TCL_DYNAMIC) { + ckfree(iPtr->result); + } else { + iPtr->freeProc(iPtr->result); + } + iPtr->freeProc = 0; + } + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = 0; } /* *---------------------------------------------------------------------- * @@ -270,14 +575,91 @@ Tcl_Obj * Tcl_GetObjResult( Tcl_Interp *interp) /* Interpreter whose result to return. */ { - register Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *) interp; + Tcl_Obj *objResultPtr; + int length; + /* + * If the string result is non-empty, move the string result to the object + * result, then reset the string result. + */ + + if (iPtr->result[0] != 0) { + ResetObjResult(iPtr); + + objResultPtr = iPtr->objResultPtr; + length = strlen(iPtr->result); + TclInitStringRep(objResultPtr, iPtr->result, length); + + if (iPtr->freeProc != NULL) { + if (iPtr->freeProc == TCL_DYNAMIC) { + ckfree(iPtr->result); + } else { + iPtr->freeProc(iPtr->result); + } + iPtr->freeProc = 0; + } + iPtr->result = iPtr->resultSpace; + iPtr->result[0] = 0; + } return iPtr->objResultPtr; } + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppendResultVA -- + * + * Append a variable number of strings onto the interpreter's result. + * + * Results: + * None. + * + * Side effects: + * The result of the interpreter given by the first argument is extended + * by the strings in the va_list (up to a terminating NULL argument). + * + * If the string result is non-empty, the object result forced to be a + * duplicate of it first. There will be a string result afterwards. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AppendResultVA( + Tcl_Interp *interp, /* Interpreter with which to associate the + * return value. */ + va_list argList) /* Variable argument list. */ +{ + Tcl_Obj *objPtr = Tcl_GetObjResult(interp); + + if (Tcl_IsShared(objPtr)) { + objPtr = Tcl_DuplicateObj(objPtr); + } + Tcl_AppendStringsToObjVA(objPtr, argList); + Tcl_SetObjResult(interp, objPtr); + + /* + * Strictly we should call Tcl_GetStringResult(interp) here to make sure + * that interp->result is correct according to the old contract, but that + * makes the performance of much code (e.g. in Tk) absolutely awful. So we + * leave it out; code that really wants interp->result can just insert the + * calls to Tcl_GetStringResult() itself. [Patch 1041072 discussion] + */ + +#ifdef USE_INTERP_RESULT + /* + * Ensure that the interp->result is legal so old Tcl 7.* code still + * works. There's still embarrasingly much of it about... + */ + + (void) Tcl_GetStringResult(interp); +#endif /* USE_INTERP_RESULT */ +} /* *---------------------------------------------------------------------- * * Tcl_AppendResult -- @@ -301,27 +683,13 @@ void Tcl_AppendResult( Tcl_Interp *interp, ...) { va_list argList; - Tcl_Obj *objPtr; va_start(argList, interp); - objPtr = Tcl_GetObjResult(interp); - - if (Tcl_IsShared(objPtr)) { - objPtr = Tcl_DuplicateObj(objPtr); - } - while (1) { - const char *bytes = va_arg(argList, char *); - - if (bytes == NULL) { - break; - } - Tcl_AppendToObj(objPtr, bytes, -1); - } - Tcl_SetObjResult(interp, objPtr); + Tcl_AppendResultVA(interp, argList); va_end(argList); } /* *---------------------------------------------------------------------- @@ -352,52 +720,180 @@ * extended. */ const char *element) /* String to convert to list element and add * to result. */ { Interp *iPtr = (Interp *) interp; - Tcl_Obj *elementPtr = Tcl_NewStringObj(element, -1); - Tcl_Obj *listPtr = Tcl_NewListObj(1, &elementPtr); - const char *bytes; - size_t length; - - if (Tcl_IsShared(iPtr->objResultPtr)) { - Tcl_SetObjResult(interp, Tcl_DuplicateObj(iPtr->objResultPtr)); - } - bytes = TclGetStringFromObj(iPtr->objResultPtr, &length); - if (TclNeedSpace(bytes, bytes + length)) { - Tcl_AppendToObj(iPtr->objResultPtr, " ", 1); - } - Tcl_AppendObjToObj(iPtr->objResultPtr, listPtr); - Tcl_DecrRefCount(listPtr); + char *dst; + int size; + int flags; + int quoteHash = 1; + + /* + * If the string result is empty, move the object result to the string + * result, then reset the object result. + */ + + (void) Tcl_GetStringResult(interp); + + /* + * See how much space is needed, and grow the append buffer if needed to + * accommodate the list element. + */ + + size = Tcl_ScanElement(element, &flags) + 1; + if ((iPtr->result != iPtr->appendResult) + || (iPtr->appendResult[iPtr->appendUsed] != 0) + || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) { + SetupAppendBuffer(iPtr, size+iPtr->appendUsed); + } + + /* + * Convert the string into a list element and copy it to the buffer that's + * forming, with a space separator if needed. + */ + + dst = iPtr->appendResult + iPtr->appendUsed; + if (TclNeedSpace(iPtr->appendResult, dst)) { + iPtr->appendUsed++; + *dst = ' '; + dst++; + + /* + * If we need a space to separate this element from preceding stuff, + * then this element will not lead a list, and need not have it's + * leading '#' quoted. + */ + quoteHash = 0; + } else { + while ((--dst >= iPtr->appendResult) && TclIsSpaceProcM(*dst)) { + } + quoteHash = !TclNeedSpace(iPtr->appendResult, dst+1); + } + dst = iPtr->appendResult + iPtr->appendUsed; + if (!quoteHash) { + flags |= TCL_DONT_QUOTE_HASH; + } + + iPtr->appendUsed += Tcl_ConvertElement(element, dst, flags); +} + +/* + *---------------------------------------------------------------------- + * + * SetupAppendBuffer -- + * + * This function makes sure that there is an append buffer properly + * initialized, if necessary, from the interpreter's result, and that it + * has at least enough room to accommodate newSpace new bytes of + * information. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +SetupAppendBuffer( + Interp *iPtr, /* Interpreter whose result is being set up. */ + int newSpace) /* Make sure that at least this many bytes of + * new information may be added. */ +{ + int totalSpace; + + /* + * Make the append buffer larger, if that's necessary, then copy the + * result into the append buffer and make the append buffer the official + * Tcl result. + */ + + if (iPtr->result != iPtr->appendResult) { + /* + * If an oversized buffer was used recently, then free it up so we go + * back to a smaller buffer. This avoids tying up memory forever after + * a large operation. + */ + + if (iPtr->appendAvl > 500) { + ckfree(iPtr->appendResult); + iPtr->appendResult = NULL; + iPtr->appendAvl = 0; + } + iPtr->appendUsed = strlen(iPtr->result); + } else if (iPtr->result[iPtr->appendUsed] != 0) { + /* + * Most likely someone has modified a result created by + * Tcl_AppendResult et al. so that it has a different size. Just + * recompute the size. + */ + + iPtr->appendUsed = strlen(iPtr->result); + } + + totalSpace = newSpace + iPtr->appendUsed; + if (totalSpace >= iPtr->appendAvl) { + char *new; + + if (totalSpace < 100) { + totalSpace = 200; + } else { + totalSpace *= 2; + } + new = ckalloc(totalSpace); + strcpy(new, iPtr->result); + if (iPtr->appendResult != NULL) { + ckfree(iPtr->appendResult); + } + iPtr->appendResult = new; + iPtr->appendAvl = totalSpace; + } else if (iPtr->result != iPtr->appendResult) { + strcpy(iPtr->appendResult, iPtr->result); + } + + Tcl_FreeResult((Tcl_Interp *) iPtr); + iPtr->result = iPtr->appendResult; } /* *---------------------------------------------------------------------- * * Tcl_FreeResult -- * * This function frees up the memory associated with an interpreter's - * result, resetting the interpreter's result object. Tcl_FreeResult is - * most commonly used when a function is about to replace one result - * value with another. + * string result. It also resets the interpreter's result object. + * Tcl_FreeResult is most commonly used when a function is about to + * replace one result value with another. * * Results: * None. * * Side effects: - * Frees the memory associated with interp's result but does not change - * any part of the error dictionary (i.e., the errorinfo and errorcode - * remain the same). + * Frees the memory associated with interp's string result and sets + * interp->freeProc to zero, but does not change interp->result or clear + * error state. Resets interp's result object to an unshared empty + * object. * *---------------------------------------------------------------------- */ void Tcl_FreeResult( - register Tcl_Interp *interp)/* Interpreter for which to free result. */ + Tcl_Interp *interp)/* Interpreter for which to free result. */ { - register Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *) interp; + + if (iPtr->freeProc != NULL) { + if (iPtr->freeProc == TCL_DYNAMIC) { + ckfree(iPtr->result); + } else { + iPtr->freeProc(iPtr->result); + } + iPtr->freeProc = 0; + } ResetObjResult(iPtr); } /* @@ -419,15 +915,25 @@ *---------------------------------------------------------------------- */ void Tcl_ResetResult( - register Tcl_Interp *interp)/* Interpreter for which to clear result. */ + Tcl_Interp *interp)/* Interpreter for which to clear result. */ { - register Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *) interp; ResetObjResult(iPtr); + if (iPtr->freeProc != NULL) { + if (iPtr->freeProc == TCL_DYNAMIC) { + ckfree(iPtr->result); + } else { + iPtr->freeProc(iPtr->result); + } + iPtr->freeProc = 0; + } + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = 0; if (iPtr->errorCode) { /* Legacy support */ if (iPtr->flags & ERR_LEGACY_COPY) { Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL, iPtr->errorCode, TCL_GLOBAL_ONLY); @@ -472,31 +978,73 @@ *---------------------------------------------------------------------- */ static void ResetObjResult( - register Interp *iPtr) /* Points to the interpreter whose result + Interp *iPtr) /* Points to the interpreter whose result * object should be reset. */ { - register Tcl_Obj *objResultPtr = iPtr->objResultPtr; + Tcl_Obj *objResultPtr = iPtr->objResultPtr; if (Tcl_IsShared(objResultPtr)) { TclDecrRefCount(objResultPtr); TclNewObj(objResultPtr); Tcl_IncrRefCount(objResultPtr); iPtr->objResultPtr = objResultPtr; } else { - if (objResultPtr->bytes != &tclEmptyString) { + if (objResultPtr->bytes != tclEmptyStringRep) { if (objResultPtr->bytes) { - Tcl_Free(objResultPtr->bytes); + ckfree(objResultPtr->bytes); } - objResultPtr->bytes = &tclEmptyString; + objResultPtr->bytes = tclEmptyStringRep; objResultPtr->length = 0; } TclFreeIntRep(objResultPtr); } } + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetErrorCodeVA -- + * + * This function is called to record machine-readable information about + * an error that is about to be returned. + * + * Results: + * None. + * + * Side effects: + * The errorCode field of the interp is modified to hold all of the + * arguments to this function, in a list form with each argument becoming + * one element of the list. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetErrorCodeVA( + Tcl_Interp *interp, /* Interpreter in which to set errorCode */ + va_list argList) /* Variable argument list. */ +{ + Tcl_Obj *errorObj = Tcl_NewObj(); + + /* + * Scan through the arguments one at a time, appending them to the + * errorCode field as list elements. + */ + + while (1) { + char *elem = va_arg(argList, char *); + + if (elem == NULL) { + break; + } + Tcl_ListObjAppendElement(NULL, errorObj, Tcl_NewStringObj(elem, -1)); + } + Tcl_SetObjErrorCode(interp, errorObj); +} /* *---------------------------------------------------------------------- * * Tcl_SetErrorCode -- @@ -518,34 +1066,18 @@ void Tcl_SetErrorCode( Tcl_Interp *interp, ...) { va_list argList; - Tcl_Obj *errorObj; /* * Scan through the arguments one at a time, appending them to the * errorCode field as list elements. */ va_start(argList, interp); - errorObj = Tcl_NewObj(); - - /* - * Scan through the arguments one at a time, appending them to the - * errorCode field as list elements. - */ - - while (1) { - char *elem = va_arg(argList, char *); - - if (elem == NULL) { - break; - } - Tcl_ListObjAppendElement(NULL, errorObj, Tcl_NewStringObj(elem, -1)); - } - Tcl_SetObjErrorCode(interp, errorObj); + Tcl_SetErrorCodeVA(interp, argList); va_end(argList); } /* *---------------------------------------------------------------------- @@ -587,10 +1119,11 @@ * Returns the line number associated with the current error. * *---------------------------------------------------------------------- */ +#undef Tcl_GetErrorLine int Tcl_GetErrorLine( Tcl_Interp *interp) { return ((Interp *) interp)->errorLine; @@ -604,10 +1137,11 @@ * Sets the line number associated with the current error. * *---------------------------------------------------------------------- */ +#undef Tcl_SetErrorLine void Tcl_SetErrorLine( Tcl_Interp *interp, int value) { @@ -749,14 +1283,14 @@ iPtr->errorInfo = NULL; } Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO], &valuePtr); if (valuePtr != NULL) { - size_t length; + int infoLen; - (void) TclGetStringFromObj(valuePtr, &length); - if (length) { + (void) TclGetStringFromObj(valuePtr, &infoLen); + if (infoLen) { iPtr->errorInfo = valuePtr; Tcl_IncrRefCount(iPtr->errorInfo); iPtr->flags |= ERR_ALREADY_LOGGED; } } @@ -855,15 +1389,17 @@ Tcl_Obj *valuePtr; Tcl_Obj *returnOpts = Tcl_NewObj(); Tcl_Obj **keys = GetKeys(); for (; objc > 1; objv += 2, objc -= 2) { - const char *opt = TclGetString(objv[0]); - const char *compare = TclGetString(keys[KEY_OPTIONS]); + int optLen; + const char *opt = TclGetStringFromObj(objv[0], &optLen); + int compareLen; + const char *compare = + TclGetStringFromObj(keys[KEY_OPTIONS], &compareLen); - if ((objv[0]->length == keys[KEY_OPTIONS]->length) - && (memcmp(opt, compare, objv[0]->length) == 0)) { + if ((optLen == compareLen) && (memcmp(opt, compare, optLen) == 0)) { Tcl_DictSearch search; int done = 0; Tcl_Obj *keyPtr; Tcl_Obj *dict = objv[1]; @@ -1153,43 +1689,37 @@ /* *------------------------------------------------------------------------- * * Tcl_TransferResult -- * - * Copy the result (and error information) from one interp to another. + * Transfer the result (and error information) from one interp to another. * Used when one interp has caused another interp to evaluate a script * and then wants to transfer the results back to itself. * - * This routine copies the string reps of the result and error - * information. It does not simply increment the refcounts of the result - * and error information objects themselves. It is not legal to exchange - * objects between interps, because an object may be kept alive by one - * interp, but have an internal rep that is only valid while some other - * interp is alive. - * * Results: - * The target interp's result is set to a copy of the source interp's - * result. The source's errorInfo field may be transferred to the - * target's errorInfo field, and the source's errorCode field may be - * transferred to the target's errorCode field. + * The result of targetInterp is set to the result read from sourceInterp. + * The return options dictionary of sourceInterp is transferred to + * targetInterp as appropriate for the return code value code. * * Side effects: * None. * *------------------------------------------------------------------------- */ void Tcl_TransferResult( - Tcl_Interp *sourceInterp, /* Interp whose result and error information + Tcl_Interp *sourceInterp, /* Interp whose result and return options * should be moved to the target interp. * After moving result, this interp's result * is reset. */ - int result, /* TCL_OK if just the result should be copied, - * TCL_ERROR if both the result and error - * information should be copied. */ - Tcl_Interp *targetInterp) /* Interp where result and error information + int code, /* The return code value active in + * sourceInterp. Controls how the return options + * dictionary is retrieved from sourceInterp, + * same as in Tcl_GetReturnOptions, to then be + * transferred to targetInterp. */ + Tcl_Interp *targetInterp) /* Interp where result and return options * should be stored. If source and target are * the same, nothing is done. */ { Interp *tiPtr = (Interp *) targetInterp; Interp *siPtr = (Interp *) sourceInterp; @@ -1196,11 +1726,11 @@ if (sourceInterp == targetInterp) { return; } - if (result == TCL_OK && siPtr->returnOpts == NULL) { + if (code == TCL_OK && siPtr->returnOpts == NULL) { /* * Special optimization for the common case of normal command return * code and no explicit return options. */ @@ -1208,11 +1738,11 @@ Tcl_DecrRefCount(tiPtr->returnOpts); tiPtr->returnOpts = NULL; } } else { Tcl_SetReturnOptions(targetInterp, - Tcl_GetReturnOptions(sourceInterp, result)); + Tcl_GetReturnOptions(sourceInterp, code)); tiPtr->flags &= ~(ERR_ALREADY_LOGGED); } Tcl_SetObjResult(targetInterp, Tcl_GetObjResult(sourceInterp)); Tcl_ResetResult(sourceInterp); } Index: generic/tclScan.c ================================================================== --- generic/tclScan.c +++ generic/tclScan.c @@ -8,11 +8,10 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" -#include "tommath.h" /* * Flag values used by Tcl_ScanObjCmd. */ @@ -27,11 +26,11 @@ /* * The following structure contains the information associated with a * character set. */ -typedef struct { +typedef struct CharSet { int exclude; /* 1 if this is an exclusion set. */ int nchars; Tcl_UniChar *chars; int nranges; struct Range { @@ -100,13 +99,13 @@ nranges++; } end += TclUtfToUniChar(end, &ch); } - cset->chars = Tcl_Alloc(sizeof(Tcl_UniChar) * (end - format - 1)); + cset->chars = ckalloc(sizeof(Tcl_UniChar) * (end - format - 1)); if (nranges > 0) { - cset->ranges = Tcl_Alloc(sizeof(struct Range) * nranges); + cset->ranges = ckalloc(sizeof(struct Range) * nranges); } else { cset->ranges = NULL; } /* @@ -222,13 +221,13 @@ static void ReleaseCharSet( CharSet *cset) { - Tcl_Free(cset->chars); + ckfree(cset->chars); if (cset->ranges) { - Tcl_Free(cset->ranges); + ckfree(cset->ranges); } } /* *---------------------------------------------------------------------- @@ -259,11 +258,11 @@ int gotXpg, gotSequential, value, i, flags; char *end; Tcl_UniChar ch = 0; int objIndex, xpgSize, nspace = numVars; int *nassign = TclStackAlloc(interp, nspace * sizeof(int)); - char buf[TCL_UTF_MAX + 1] = ""; + char buf[TCL_UTF_MAX+1] = ""; Tcl_Obj *errorMsg; /* Place to build an error messages. Note that * these are messy operations because we do * not want to use the formatting engine; * we're inside there! */ @@ -361,12 +360,14 @@ flags |= SCAN_BIG; format += 1; format += TclUtfToUniChar(format, &ch); break; } + /* FALLTHRU */ case 'L': flags |= SCAN_LONGER; + /* FALLTHRU */ case 'h': format += TclUtfToUniChar(format, &ch); } if (!(flags & SCAN_SUPPRESS) && numVars && (objIndex >= numVars)) { @@ -384,13 +385,11 @@ "field width may not be specified in %c conversion", -1)); Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADWIDTH", NULL); goto error; } - /* - * Fall through! - */ + /* FALLTHRU */ case 'n': case 's': if (flags & (SCAN_LONGER|SCAN_BIG)) { invalidFieldSize: buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; @@ -414,11 +413,18 @@ case 'i': case 'o': case 'x': case 'X': case 'b': + break; case 'u': + if (flags & SCAN_BIG) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unsigned bignum scans are invalid", -1)); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADUNSIGNED",NULL); + goto error; + } break; /* * Bracket terms need special checking */ case '[': @@ -577,21 +583,18 @@ int width, underflow = 0; Tcl_WideInt wideValue; Tcl_UniChar ch = 0, sch = 0; Tcl_Obj **objs = NULL, *objPtr = NULL; int flags; - char buf[513]; /* Temporary buffer to hold scanned number - * strings before they are passed to - * strtoul. */ if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "string format ?varName ...?"); return TCL_ERROR; } - format = TclGetString(objv[2]); + format = Tcl_GetString(objv[2]); numVars = objc-3; /* * Check for errors in the format string. */ @@ -603,17 +606,17 @@ /* * Allocate space for the result objects. */ if (totalVars > 0) { - objs = Tcl_Alloc(sizeof(Tcl_Obj *) * totalVars); + objs = ckalloc(sizeof(Tcl_Obj *) * totalVars); for (i = 0; i < totalVars; i++) { objs[i] = NULL; } } - string = TclGetString(objv[1]); + string = Tcl_GetString(objv[1]); baseString = string; /* * Iterate over the format string filling in the result objects until we * reach the end of input, the end of the format string, or there is a @@ -701,15 +704,14 @@ flags |= SCAN_BIG; format += 1; format += TclUtfToUniChar(format, &ch); break; } + /* FALLTHRU */ case 'L': flags |= SCAN_LONGER; - /* - * Fall through so we skip to the next character. - */ + /* FALLTHRU */ case 'h': format += TclUtfToUniChar(format, &ch); } /* @@ -717,11 +719,11 @@ */ switch (ch) { case 'n': if (!(flags & SCAN_SUPPRESS)) { - objPtr = Tcl_NewWideIntObj(string - baseString); + TclNewIntObj(objPtr, string - baseString); Tcl_IncrRefCount(objPtr); CLANG_ASSERT(objs); objs[objIndex++] = objPtr; } nconversions++; @@ -877,21 +879,14 @@ case 'c': /* * Scan a single Unicode character. */ - offset = TclUtfToUniChar(string, &sch); - i = (int)sch; -#if TCL_UTF_MAX <= 4 - if ((sch >= 0xD800) && (offset < 3)) { - offset += TclUtfToUniChar(string+offset, &sch); - i = (((i<<10) & 0x0FFC00) + 0x10000) + (sch & 0x3FF); - } -#endif + offset = TclUtfToUCS4(string, &i); string += offset; if (!(flags & SCAN_SUPPRESS)) { - objPtr = Tcl_NewWideIntObj(i); + TclNewIntObj(objPtr, i); Tcl_IncrRefCount(objPtr); CLANG_ASSERT(objs); objs[objIndex++] = objPtr; } break; @@ -898,11 +893,11 @@ case 'i': /* * Scan an unsigned or signed integer. */ - objPtr = Tcl_NewWideIntObj(0); + objPtr = Tcl_NewLongObj(0); Tcl_IncrRefCount(objPtr); if (width == 0) { width = ~0; } if (TCL_OK != TclParseNumber(NULL, objPtr, NULL, string, width, @@ -924,58 +919,40 @@ Tcl_DecrRefCount(objPtr); break; } if (flags & SCAN_LONGER) { if (Tcl_GetWideIntFromObj(NULL, objPtr, &wideValue) != TCL_OK) { - wideValue = WIDE_MAX; + wideValue = ~(Tcl_WideUInt)0 >> 1; /* WIDE_MAX */ if (TclGetString(objPtr)[0] == '-') { - wideValue = WIDE_MIN; + wideValue++; /* WIDE_MAX + 1 = WIDE_MIN */ } } if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) { - sprintf(buf, "%" TCL_LL_MODIFIER "u", wideValue); - Tcl_SetStringObj(objPtr, buf, -1); - } else { - TclSetIntObj(objPtr, wideValue); - } - } else if (flags & SCAN_BIG) { - if (flags & SCAN_UNSIGNED) { - mp_int big; - int code = Tcl_GetBignumFromObj(interp, objPtr, &big); - - if (code == TCL_OK) { - if (big.sign != MP_ZPOS) { - code = TCL_ERROR; - } - mp_clear(&big); - } - - if (code == TCL_ERROR) { - if (objs != NULL) { - Tcl_Free(objs); - } - Tcl_DecrRefCount(objPtr); - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "unsigned bignum scans are invalid", -1)); - Tcl_SetErrorCode(interp, "TCL", "FORMAT", - "BADUNSIGNED",NULL); - return TCL_ERROR; - } - } - } else { + mp_int big; + TclBNInitBignumFromWideUInt(&big, (Tcl_WideUInt)wideValue); + Tcl_SetBignumObj(objPtr, &big); + } else { + Tcl_SetWideIntObj(objPtr, wideValue); + } + } else if (!(flags & SCAN_BIG)) { if (TclGetLongFromObj(NULL, objPtr, &value) != TCL_OK) { if (TclGetString(objPtr)[0] == '-') { value = LONG_MIN; } else { value = LONG_MAX; } } if ((flags & SCAN_UNSIGNED) && (value < 0)) { - sprintf(buf, "%lu", value); /* INTL: ISO digit */ - Tcl_SetStringObj(objPtr, buf, -1); +#ifdef TCL_WIDE_INT_IS_LONG + mp_int big; + TclBNInitBignumFromWideUInt(&big, (unsigned long)value); + Tcl_SetBignumObj(objPtr, &big); +#else + Tcl_SetWideIntObj(objPtr, (unsigned long)value); +#endif } else { - TclSetIntObj(objPtr, value); + Tcl_SetLongObj(objPtr, value); } } objs[objIndex++] = objPtr; break; @@ -1007,14 +984,12 @@ string = end; } else { double dvalue; if (Tcl_GetDoubleFromObj(NULL, objPtr, &dvalue) != TCL_OK) { #ifdef ACCEPT_NAN - const Tcl_ObjIntRep *irPtr - = TclFetchIntRep(objPtr, &tclDoubleType); - if (irPtr) { - dvalue = irPtr->doubleValue; + if (objPtr->typePtr == &tclDoubleType) { + dvalue = objPtr->internalRep.doubleValue; } else #endif { Tcl_DecrRefCount(objPtr); goto done; @@ -1058,11 +1033,11 @@ } else { /* * Here no vars were specified, we want a list returned (inline scan) */ - objPtr = Tcl_NewObj(); + TclNewObj(objPtr); for (i = 0; i < totalVars; i++) { if (objs[i] != NULL) { Tcl_ListObjAppendElement(NULL, objPtr, objs[i]); Tcl_DecrRefCount(objs[i]); } else { @@ -1074,25 +1049,25 @@ Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewObj()); } } } if (objs != NULL) { - Tcl_Free(objs); + ckfree(objs); } if (code == TCL_OK) { if (underflow && (nconversions == 0)) { if (numVars) { - objPtr = Tcl_NewWideIntObj(-1); + TclNewIntObj(objPtr, -1); } else { if (objPtr) { Tcl_SetListObj(objPtr, 0, NULL); } else { - objPtr = Tcl_NewObj(); + TclNewObj(objPtr); } } } else if (numVars) { - objPtr = Tcl_NewWideIntObj(result); + TclNewIntObj(objPtr, result); } Tcl_SetObjResult(interp, objPtr); } return code; } Index: generic/tclStrToD.c ================================================================== --- generic/tclStrToD.c +++ generic/tclStrToD.c @@ -13,12 +13,24 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tommath.h" +#include #include +#ifdef _WIN32 +#define copysign _copysign +#endif + +/* + * Define KILL_OCTAL to suppress interpretation of numbers with leading zero + * as octal. (Ceterum censeo: numeros octonarios delendos esse.) + */ + +#undef KILL_OCTAL + /* * This code supports (at least hypothetically), IBM, Cray, VAX and IEEE-754 * floating point; of these, only IEEE-754 can represent NaN. IEEE-754 can be * uniquely determined by radix and by the widths of significand and exponent. */ @@ -43,11 +55,11 @@ #if defined(__GNUC__) typedef unsigned int fpu_control_t __attribute__ ((__mode__ (__HI__))); #define _FPU_GETCW(cw) __asm__ __volatile__ ("fnstcw %0" : "=m" (*&cw)) #define _FPU_SETCW(cw) __asm__ __volatile__ ("fldcw %0" : : "m" (*&cw)) -# define FPU_IEEE_ROUNDING 0x027f +# define FPU_IEEE_ROUNDING 0x027F # define ADJUST_FPU_CONTROL_WORD #define TCL_IEEE_DOUBLE_ROUNDING \ fpu_control_t roundTo53Bits = FPU_IEEE_ROUNDING; \ fpu_control_t oldRoundingMode; \ _FPU_GETCW(oldRoundingMode); \ @@ -92,14 +104,14 @@ * HP's PA_RISC architecture uses 7ff4000000000000 to represent a quiet NaN. * Everyone else uses 7ff8000000000000. (Why, HP, why?) */ #ifdef __hppa -# define NAN_START 0x7ff4 +# define NAN_START 0x7FF4 # define NAN_MASK (((Tcl_WideUInt) 1) << 50) #else -# define NAN_START 0x7ff8 +# define NAN_START 0x7FF8 # define NAN_MASK (((Tcl_WideUInt) 1) << 51) #endif /* * Constants used by this file (most of which are only ever calculated at @@ -117,37 +129,37 @@ */ #define SIGN_BIT 0x80000000 /* Mask for the sign bit in the first word of * a double. */ -#define EXP_MASK 0x7ff00000 +#define EXP_MASK 0x7FF00000 /* Mask for the exponent field in the first * word of a double. */ #define EXP_SHIFT 20 /* Shift count to make the exponent an * integer. */ #define HIDDEN_BIT (((Tcl_WideUInt) 0x00100000) << 32) /* Hidden 1 bit for the significand. */ -#define HI_ORDER_SIG_MASK 0x000fffff +#define HI_ORDER_SIG_MASK 0x000FFFFF /* Mask for the high-order part of the * significand in the first word of a * double. */ #define SIG_MASK (((Tcl_WideUInt) HI_ORDER_SIG_MASK << 32) \ - | 0xffffffff) + | 0xFFFFFFFF) /* Mask for the 52-bit significand. */ #define FP_PRECISION 53 /* Number of bits of significand plus the * hidden bit. */ -#define EXPONENT_BIAS 0x3ff /* Bias of the exponent 0. */ +#define EXPONENT_BIAS 0x3FF /* Bias of the exponent 0. */ /* * Derived quantities. */ #define TEN_PMAX 22 /* floor(FP_PRECISION*log(2)/log(5)) */ #define QUICK_MAX 14 /* floor((FP_PRECISION-1)*log(2)/log(10))-1 */ #define BLETCH 0x10 /* Highest power of two that is greater than * DBL_MAX_10_EXP, divided by 16. */ -#define DIGIT_GROUP 8 /* floor(DIGIT_BIT*log(2)/log(10)) */ +#define DIGIT_GROUP 8 /* floor(MP_DIGIT_BIT*log(2)/log(10)) */ /* * Union used to dismantle floating point numbers. */ @@ -287,14 +299,14 @@ */ static int AccumulateDecimalDigit(unsigned, int, Tcl_WideUInt *, mp_int *, int); static double MakeHighPrecisionDouble(int signum, - mp_int *significand, int nSigDigs, int exponent); + mp_int *significand, int nSigDigs, long exponent); static double MakeLowPrecisionDouble(int signum, Tcl_WideUInt significand, int nSigDigs, - int exponent); + long exponent); #ifdef IEEE_FLOATING_POINT static double MakeNaN(int signum, Tcl_WideUInt tag); #endif static double RefineApproximation(double approx, mp_int *exactSignificand, int exponent); @@ -318,40 +330,40 @@ static char * StrictQuickFormat(double, int, int, double, char *, int *); static char * QuickConversion(double, int, int, int, int, int, int, int *, char **); static void CastOutPowersOf2(int *, int *, int *); -static char * ShorteningInt64Conversion(Double *, Tcl_WideUInt, +static char * ShorteningInt64Conversion(Double *, int, Tcl_WideUInt, int, int, int, int, int, int, int, int, int, int, int, int *, char **); -static char * StrictInt64Conversion(Double *, Tcl_WideUInt, +static char * StrictInt64Conversion(Double *, int, Tcl_WideUInt, int, int, int, int, int, int, int, int, int *, char **); static int ShouldBankerRoundUpPowD(mp_int *, int, int); static int ShouldBankerRoundUpToNextPowD(mp_int *, mp_int *, - int, int, mp_int *); + int, int, int, mp_int *); static char * ShorteningBignumConversionPowD(Double *dPtr, - Tcl_WideUInt bw, int b2, int b5, + int convType, Tcl_WideUInt bw, int b2, int b5, int m2plus, int m2minus, int m5, int sd, int k, int len, int ilim, int ilim1, int *decpt, char **endPtr); -static char * StrictBignumConversionPowD(Double *dPtr, +static char * StrictBignumConversionPowD(Double *dPtr, int convType, Tcl_WideUInt bw, int b2, int b5, int sd, int k, int len, int ilim, int ilim1, int *decpt, char **endPtr); static int ShouldBankerRoundUp(mp_int *, mp_int *, int); static int ShouldBankerRoundUpToNext(mp_int *, mp_int *, - mp_int *, int); -static char * ShorteningBignumConversion(Double *dPtr, + mp_int *, int, int, mp_int *); +static char * ShorteningBignumConversion(Double *dPtr, int convType, Tcl_WideUInt bw, int b2, int m2plus, int m2minus, int s2, int s5, int k, int len, int ilim, int ilim1, int *decpt, char **endPtr); -static char * StrictBignumConversion(Double *dPtr, +static char * StrictBignumConversion(Double *dPtr, int convType, Tcl_WideUInt bw, int b2, int s2, int s5, int k, int len, int ilim, int ilim1, int *decpt, char **endPtr); static double BignumToBiasedFrExp(const mp_int *big, int *machexp); @@ -472,20 +484,20 @@ const char *expected, /* Description of the type of number the * caller expects to be able to parse * ("integer", "boolean value", etc.). */ const char *bytes, /* Pointer to the start of the string to * scan. */ - size_t numBytes, /* Maximum number of bytes to scan, see + int numBytes, /* Maximum number of bytes to scan, see * above. */ const char **endPtrPtr, /* Place to store pointer to the character * that terminated the scan. */ int flags) /* Flags governing the parse. */ { enum State { INITIAL, SIGNUM, ZERO, ZERO_X, - ZERO_O, ZERO_B, ZERO_D, BINARY, - HEXADECIMAL, OCTAL, DECIMAL, + ZERO_O, ZERO_B, BINARY, + HEXADECIMAL, OCTAL, BAD_OCTAL, DECIMAL, LEADING_RADIX_POINT, FRACTION, EXPONENT_START, EXPONENT_SIGNUM, EXPONENT, sI, sIN, sINF, sINFI, sINFIN, sINFINI, sINFINIT, sINFINITY #ifdef IEEE_FLOATING_POINT , sN, sNA, sNAN, sNANPAREN, sNANHEX, sNANFINISH @@ -526,34 +538,21 @@ * point. */ int status = TCL_OK; /* Status to return to caller. */ char d = 0; /* Last hexadecimal digit scanned; initialized * to avoid a compiler warning. */ int shift = 0; /* Amount to shift when accumulating binary */ + int explicitOctal = 0; -#define ALL_BITS ((Tcl_WideUInt)-1) +#define ALL_BITS (~(Tcl_WideUInt)0) #define MOST_BITS (ALL_BITS >> 1) /* * Initialize bytes to start of the object's string rep if the caller * didn't pass anything else. */ if (bytes == NULL) { - if (interp == NULL && endPtrPtr == NULL) { - if (TclHasIntRep(objPtr, &tclDictType)) { - /* A dict can never be a (single) number */ - return TCL_ERROR; - } - if (TclHasIntRep(objPtr, &tclListType)) { - int length; - /* A list can only be a (single) number if its length == 1 */ - TclListObjLength(NULL, objPtr, &length); - if (length != 1) { - return TCL_ERROR; - } - } - } bytes = TclGetString(objPtr); } p = bytes; len = numBytes; @@ -567,11 +566,11 @@ /* * Initial state. Acceptable characters are +, -, digits, period, * I, N, and whitespace. */ - if (TclIsSpaceProc(c)) { + if (TclIsSpaceProcM(c)) { if (flags & TCL_PARSE_NO_WHITESPACE) { goto endgame; } break; } else if (c == '+') { @@ -657,18 +656,18 @@ } if (flags & TCL_PARSE_BINARY_ONLY) { goto zerob; } if (c == 'o' || c == 'O') { + explicitOctal = 1; state = ZERO_O; break; } - if (c == 'd' || c == 'D') { - state = ZERO_D; - break; - } +#ifdef KILL_OCTAL goto decimal; +#endif + /* FALLTHROUGH */ case OCTAL: /* * Scanned an optional + or -, followed by a string of octal * digits. Acceptable inputs are more digits, period, or E. If 8 @@ -702,13 +701,13 @@ if ((octalSignificandWide != 0) && (((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt)) || (octalSignificandWide > - ((Tcl_WideUInt)-1 >> shift)))) { + (~(Tcl_WideUInt)0 >> shift)))) { octalSignificandOverflow = 1; - TclInitBignumFromWideUInt(&octalSignificandBig, + TclBNInitBignumFromWideUInt(&octalSignificandBig, octalSignificandWide); } } if (!octalSignificandOverflow) { octalSignificandWide = @@ -727,10 +726,62 @@ } numTrailZeros = 0; state = OCTAL; break; } + /* FALLTHROUGH */ + + case BAD_OCTAL: + if (explicitOctal) { + /* + * No forgiveness for bad digits in explicitly octal numbers. + */ + + goto endgame; + } + if (flags & TCL_PARSE_INTEGER_ONLY) { + /* + * No seeking floating point when parsing only integer. + */ + + goto endgame; + } +#ifndef KILL_OCTAL + + /* + * Scanned a number with a leading zero that contains an 8, 9, + * radix point or E. This is an invalid octal number, but might + * still be floating point. + */ + + if (c == '0') { + numTrailZeros++; + state = BAD_OCTAL; + break; + } else if (isdigit(UCHAR(c))) { + if (objPtr != NULL) { + significandOverflow = AccumulateDecimalDigit( + (unsigned)(c-'0'), numTrailZeros, + &significandWide, &significandBig, + significandOverflow); + } + if (numSigDigs != 0) { + numSigDigs += (numTrailZeros + 1); + } else { + numSigDigs = 1; + } + numTrailZeros = 0; + state = BAD_OCTAL; + break; + } else if (c == '.') { + state = FRACTION; + break; + } else if (c == 'E' || c == 'e') { + state = EXPONENT_START; + break; + } +#endif goto endgame; /* * Scanned 0x. If state is HEXADECIMAL, scanned at least one * character following the 0x. The only acceptable inputs are @@ -767,13 +818,13 @@ * large shifts first. */ if (significandWide != 0 && ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || - significandWide > ((Tcl_WideUInt)-1 >> shift))) { + significandWide > (~(Tcl_WideUInt)0 >> shift))) { significandOverflow = 1; - TclInitBignumFromWideUInt(&significandBig, + TclBNInitBignumFromWideUInt(&significandBig, significandWide); } } if (!significandOverflow) { significandWide = (significandWide << shift) + d; @@ -788,10 +839,11 @@ case BINARY: acceptState = state; acceptPoint = p; acceptLen = len; + /* FALLTHRU */ case ZERO_B: zerob: if (c == '0') { numTrailZeros++; state = BINARY; @@ -808,13 +860,13 @@ * large shifts first. */ if (significandWide != 0 && ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || - significandWide > ((Tcl_WideUInt)-1 >> shift))) { + significandWide > (~(Tcl_WideUInt)0 >> shift))) { significandOverflow = 1; - TclInitBignumFromWideUInt(&significandBig, + TclBNInitBignumFromWideUInt(&significandBig, significandWide); } } if (!significandOverflow) { significandWide = (significandWide << shift) + 1; @@ -825,27 +877,19 @@ } numTrailZeros = 0; state = BINARY; break; - case ZERO_D: - if (c == '0') { - numTrailZeros++; - } else if ( ! isdigit(UCHAR(c))) { - goto endgame; - } - state = DECIMAL; - flags |= TCL_PARSE_INTEGER_ONLY; - /* FALLTHROUGH */ - case DECIMAL: /* * Scanned an optional + or - followed by a string of decimal * digits. */ +#ifdef KILL_OCTAL decimal: +#endif acceptState = state; acceptPoint = p; acceptLen = len; if (c == '0') { numTrailZeros++; @@ -1049,11 +1093,11 @@ state = sNANFINISH; break; } /* FALLTHROUGH */ case sNANPAREN: - if (TclIsSpaceProc(c)) { + if (TclIsSpaceProcM(c)) { break; } if (numSigDigs < 13) { if (c >= '0' && c <= '9') { d = c - '0'; @@ -1103,17 +1147,17 @@ if (!(flags & TCL_PARSE_NO_WHITESPACE)) { /* * Accept trailing whitespace. */ - while (len != 0 && TclIsSpaceProc(*p)) { + while (len != 0 && TclIsSpaceProcM(*p)) { 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; } @@ -1125,14 +1169,14 @@ if (status == TCL_OK && objPtr != NULL) { TclFreeIntRep(objPtr); switch (acceptState) { case SIGNUM: + case BAD_OCTAL: case ZERO_X: case ZERO_O: case ZERO_B: - case ZERO_D: case LEADING_RADIX_POINT: case EXPONENT_START: case EXPONENT_SIGNUM: case sI: case sIN: @@ -1152,11 +1196,11 @@ shift = numTrailZeros; if (!significandOverflow && significandWide != 0 && ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || significandWide > (MOST_BITS + signum) >> shift)) { significandOverflow = 1; - TclInitBignumFromWideUInt(&significandBig, significandWide); + TclBNInitBignumFromWideUInt(&significandBig, significandWide); } if (shift) { if (!significandOverflow) { significandWide <<= shift; } else { @@ -1173,11 +1217,11 @@ shift = 4 * numTrailZeros; if (!significandOverflow && significandWide !=0 && ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || significandWide > (MOST_BITS + signum) >> shift)) { significandOverflow = 1; - TclInitBignumFromWideUInt(&significandBig, significandWide); + TclBNInitBignumFromWideUInt(&significandBig, significandWide); } if (shift) { if (!significandOverflow) { significandWide <<= shift; } else { @@ -1194,11 +1238,11 @@ shift = 3 * numTrailZeros; if (!octalSignificandOverflow && octalSignificandWide != 0 && ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || octalSignificandWide > (MOST_BITS + signum) >> shift)) { octalSignificandOverflow = 1; - TclInitBignumFromWideUInt(&octalSignificandBig, + TclBNInitBignumFromWideUInt(&octalSignificandBig, octalSignificandWide); } if (shift) { if (!octalSignificandOverflow) { octalSignificandWide <<= shift; @@ -1206,61 +1250,89 @@ mp_mul_2d(&octalSignificandBig, shift, &octalSignificandBig); } } if (!octalSignificandOverflow) { - if (octalSignificandWide > (MOST_BITS + signum)) { - TclInitBignumFromWideUInt(&octalSignificandBig, + if (octalSignificandWide > + (Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) { +#ifndef TCL_WIDE_INT_IS_LONG + if (octalSignificandWide <= (MOST_BITS + signum)) { + objPtr->typePtr = &tclWideIntType; + if (signum) { + objPtr->internalRep.wideValue = + - (Tcl_WideInt) octalSignificandWide; + } else { + objPtr->internalRep.wideValue = + (Tcl_WideInt) octalSignificandWide; + } + break; + } +#endif + TclBNInitBignumFromWideUInt(&octalSignificandBig, octalSignificandWide); octalSignificandOverflow = 1; } else { objPtr->typePtr = &tclIntType; if (signum) { - objPtr->internalRep.wideValue = - - (Tcl_WideInt) octalSignificandWide; + objPtr->internalRep.longValue = + - (long) octalSignificandWide; } else { - objPtr->internalRep.wideValue = - (Tcl_WideInt) octalSignificandWide; + objPtr->internalRep.longValue = + (long) octalSignificandWide; } } } if (octalSignificandOverflow) { if (signum) { - mp_neg(&octalSignificandBig, &octalSignificandBig); + (void)mp_neg(&octalSignificandBig, &octalSignificandBig); } TclSetBignumIntRep(objPtr, &octalSignificandBig); } break; case ZERO: case DECIMAL: significandOverflow = AccumulateDecimalDigit(0, numTrailZeros-1, &significandWide, &significandBig, significandOverflow); - if (!significandOverflow && (significandWide > MOST_BITS+signum)){ + if (!significandOverflow && (significandWide > MOST_BITS+signum)) { significandOverflow = 1; - TclInitBignumFromWideUInt(&significandBig, significandWide); + TclBNInitBignumFromWideUInt(&significandBig, significandWide); } returnInteger: if (!significandOverflow) { - if (significandWide > MOST_BITS+signum) { - TclInitBignumFromWideUInt(&significandBig, + if (significandWide > + (Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) { +#ifndef TCL_WIDE_INT_IS_LONG + if (significandWide <= MOST_BITS+signum) { + objPtr->typePtr = &tclWideIntType; + if (signum) { + objPtr->internalRep.wideValue = + - (Tcl_WideInt) significandWide; + } else { + objPtr->internalRep.wideValue = + (Tcl_WideInt) significandWide; + } + break; + } +#endif + TclBNInitBignumFromWideUInt(&significandBig, significandWide); significandOverflow = 1; } else { objPtr->typePtr = &tclIntType; if (signum) { - objPtr->internalRep.wideValue = - - (Tcl_WideInt) significandWide; + objPtr->internalRep.longValue = + - (long) significandWide; } else { - objPtr->internalRep.wideValue = - (Tcl_WideInt) significandWide; + objPtr->internalRep.longValue = + (long) significandWide; } } } if (significandOverflow) { if (signum) { - mp_neg(&significandBig, &significandBig); + (void)mp_neg(&significandBig, &significandBig); } TclSetBignumIntRep(objPtr, &significandBig); } break; @@ -1275,20 +1347,49 @@ * k = numTrailZeros+exponent-numDigitsAfterDp. */ objPtr->typePtr = &tclDoubleType; if (exponentSignum) { + /* + * At this point exponent>=0, so the following calculation + * cannot underflow. + */ exponent = -exponent; } + + /* + * Adjust the exponent for the number of trailing zeros that + * have not been accumulated, and the number of digits after + * the decimal point. Pin any overflow to LONG_MAX/LONG_MIN + * respectively. + */ + + if (exponent >= 0) { + if (exponent - numDigitsAfterDp > LONG_MAX - numTrailZeros) { + exponent = LONG_MAX; + } else { + exponent = exponent - numDigitsAfterDp + numTrailZeros; + } + } else { + if (exponent + numTrailZeros < LONG_MIN + numDigitsAfterDp) { + exponent = LONG_MIN; + } else { + exponent = exponent + numTrailZeros - numDigitsAfterDp; + } + } + + /* + * The desired number is now significandWide * 10**exponent + * or significandBig * 10**exponent, depending on whether + * the significand has overflowed a wide int. + */ if (!significandOverflow) { objPtr->internalRep.doubleValue = MakeLowPrecisionDouble( - signum, significandWide, numSigDigs, - numTrailZeros + exponent - numDigitsAfterDp); + signum, significandWide, numSigDigs, exponent); } else { objPtr->internalRep.doubleValue = MakeHighPrecisionDouble( - signum, &significandBig, numSigDigs, - numTrailZeros + exponent - numDigitsAfterDp); + signum, &significandBig, numSigDigs, exponent); } break; case sINF: case sINFINITY: @@ -1301,11 +1402,11 @@ break; #ifdef IEEE_FLOATING_POINT case sNAN: case sNANFINISH: - objPtr->internalRep.doubleValue = MakeNaN(signum,significandWide); + objPtr->internalRep.doubleValue = MakeNaN(signum, significandWide); objPtr->typePtr = &tclDoubleType; break; #endif case INITIAL: /* This case only to silence compiler warning. */ @@ -1322,10 +1423,13 @@ Tcl_Obj *msg = Tcl_ObjPrintf("expected %s but got \"", expected); Tcl_AppendLimitedToObj(msg, bytes, numBytes, 50, ""); Tcl_AppendToObj(msg, "\"", -1); + if (state == BAD_OCTAL) { + Tcl_AppendToObj(msg, " (looks like invalid octal number)", -1); + } Tcl_SetObjResult(interp, msg); Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL); } } @@ -1386,17 +1490,17 @@ */ *wideRepPtr = digit; return 0; } else if (numZeros >= maxpow10_wide - || w > ((Tcl_WideUInt)-1-digit)/pow10_wide[numZeros+1]) { + || w > ((~(Tcl_WideUInt)0)-digit)/pow10_wide[numZeros+1]) { /* * Wide multiplication will overflow. Expand the number to a * bignum and fall through into the bignum case. */ - TclInitBignumFromWideUInt(bignumRepPtr, w); + TclBNInitBignumFromWideUInt(bignumRepPtr, w); } else { /* * Wide multiplication. */ @@ -1420,13 +1524,13 @@ } else { /* * More than single digit multiplication. Multiply by the appropriate * small powers of 5, and then shift. Large strings of zeroes are * eaten 256 at a time; this is less efficient than it could be, but - * seems implausible. We presume that DIGIT_BIT is at least 27. The + * seems implausible. We presume that MP_DIGIT_BIT is at least 27. The * first multiplication, by up to 10**7, is done with a one-DIGIT - * multiply (this presumes that DIGIT_BIT >= 24). + * multiply (this presumes that MP_DIGIT_BIT >= 24). */ n = numZeros + 1; mp_mul_d(bignumRepPtr, (mp_digit) pow10_wide[n&0x7], bignumRepPtr); for (i=3; i<=7; ++i) { @@ -1465,13 +1569,13 @@ */ static double MakeLowPrecisionDouble( int signum, /* 1 if the number is negative, 0 otherwise */ - Tcl_WideUInt significand, /* Significand of the number. */ - int numSigDigs, /* Number of digits in the significand. */ - int exponent) /* Power of ten. */ + Tcl_WideUInt significand, /* Significand of the number */ + int numSigDigs, /* Number of digits in the significand */ + long exponent) /* Power of ten */ { double retval; /* Value of the number. */ mp_int significandBig; /* Significand expressed as a bignum. */ /* @@ -1486,10 +1590,13 @@ /* * Test for the easy cases. */ + if (significand == 0) { + return copysign(0.0, -signum); + } if (numSigDigs <= QUICK_MAX) { if (exponent >= 0) { if (exponent <= mmaxpow) { /* * The significand is an exact integer, and so is @@ -1535,11 +1642,11 @@ /* * All the easy cases have failed. Promote ths significand to bignum and * call MakeHighPrecisionDouble to do it the hard way. */ - TclInitBignumFromWideUInt(&significandBig, significand); + TclBNInitBignumFromWideUInt(&significandBig, significand); retval = MakeHighPrecisionDouble(0, &significandBig, numSigDigs, exponent); mp_clear(&significandBig); /* @@ -1578,14 +1685,14 @@ *---------------------------------------------------------------------- */ static double MakeHighPrecisionDouble( - int signum, /* 1=negative, 0=nonnegative. */ - mp_int *significand, /* Exact significand of the number. */ - int numSigDigs, /* Number of significant digits. */ - int exponent) /* Power of 10 by which to multiply. */ + int signum, /* 1=negative, 0=nonnegative */ + mp_int *significand, /* Exact significand of the number */ + int numSigDigs, /* Number of significant digits */ + long exponent) /* Power of 10 by which to multiply */ { double retval; int machexp; /* Machine exponent of a power of 10. */ /* @@ -1597,19 +1704,22 @@ */ TCL_IEEE_DOUBLE_ROUNDING; /* - * Quick checks for over/underflow. + * Quick checks for zero, and over/underflow. Be careful to avoid + * integer overflow when calculating with 'exponent'. */ - if (numSigDigs+exponent-1 > maxDigits) { + if (mp_iszero(significand)) { + return copysign(0.0, -signum); + } + if (exponent >= 0 && exponent-1 > maxDigits-numSigDigs) { retval = HUGE_VAL; goto returnValue; - } - if (numSigDigs+exponent-1 < minDigits) { - retval = 0; + } else if (exponent < 0 && numSigDigs+exponent < minDigits+1) { + retval = 0.0; goto returnValue; } /* * Develop a first approximation to the significand. It is tempting simply @@ -1740,10 +1850,13 @@ * correction term. */ int roundToEven = 0; /* Flag == TRUE if we need to invoke * "round to even" functionality */ double rteSignificand; /* Significand of the round-to-even result */ int rteExponent; /* Exponent of the round-to-even result */ + int shift; /* Shift count for converting numerator + * and denominator of corrector to floating + * point */ Tcl_WideInt rteSigWide; /* Wide integer version of the significand * for testing evenness */ int i; /* @@ -1752,17 +1865,26 @@ */ if (approxResult == HUGE_VAL) { return approxResult; } - - /* - * Find a common denominator for the decimal and binary fractions. The - * common denominator will be 2**M2 + 5**M5. - */ - significand = frexp(approxResult, &binExponent); + + /* + * We are trying to compute a corrector term that, when added to the + * approximate result, will yield close to the exact result. + * The exact result is exactSignificand * 10**exponent. + * The approximate result is significand * 2**binExponent + * If exponent<0, we need to multiply the exact value by 10**-exponent + * to make it an integer, plus another factor of 2 to decide on rounding. + * Similarly if binExponent 0) { + mp_div_2d(&twoMv, shift, &twoMv, NULL); + mp_div_2d(&twoMd, shift, &twoMd, NULL); + } /* * Convert the numerator and denominator of the corrector term accurately * to floating point numbers. */ @@ -1954,20 +2099,20 @@ Tcl_WideUInt *wPtr) /* INOUT: Number to shift. */ { int rv = 0; Tcl_WideUInt w = *wPtr; - if (!(w & (Tcl_WideUInt) 0xffffffff)) { + if (!(w & (Tcl_WideUInt) 0xFFFFFFFF)) { w >>= 32; rv += 32; } - if (!(w & (Tcl_WideUInt) 0xffff)) { + if (!(w & (Tcl_WideUInt) 0xFFFF)) { w >>= 16; rv += 16; } - if (!(w & (Tcl_WideUInt) 0xff)) { + if (!(w & (Tcl_WideUInt) 0xFF)) { w >>= 8; rv += 8; } - if (!(w & (Tcl_WideUInt) 0xf)) { + if (!(w & (Tcl_WideUInt) 0xF)) { w >>= 4; rv += 4; } if (!(w & 0x3)) { w >>= 2; rv += 2; } @@ -1997,25 +2142,25 @@ Tcl_WideUInt w) /* Number to interrogate. */ { int rv; unsigned long wi; - if (w & ((Tcl_WideUInt) 0xffffffff << 32)) { + if (w & ((Tcl_WideUInt) 0xFFFFFFFF << 32)) { wi = (unsigned long) (w >> 32); rv = 32; } else { wi = (unsigned long) w; rv = 0; } - if (wi & 0xffff0000) { + if (wi & 0xFFFF0000) { wi >>= 16; rv += 16; } - if (wi & 0xff00) { + if (wi & 0xFF00) { wi >>= 8; rv += 8; } - if (wi & 0xf0) { + if (wi & 0xF0) { wi >>= 4; rv += 4; } - if (wi & 0xc) { + if (wi & 0xC) { wi >>= 2; rv += 2; } if (wi & 0x2) { wi >>= 1; ++rv; } @@ -2108,11 +2253,11 @@ * * Bailout for formatting infinities and Not-A-Number. * * Results: * Returns one of the strings 'Infinity' and 'NaN'. The string returned - * must be freed by the caller using 'Tcl_Free'. + * must be freed by the caller using 'ckfree'. * * Side effects: * Stores 9999 in *decpt, and sets '*endPtr' to designate the terminating * NUL byte of the string if 'endPtr' is not NULL. * @@ -2127,17 +2272,17 @@ { char *retval; *decpt = 9999; if (!(d->w.word1) && !(d->w.word0 & HI_ORDER_SIG_MASK)) { - retval = Tcl_Alloc(9); + retval = ckalloc(9); strcpy(retval, "Infinity"); if (endPtr) { *endPtr = retval + 8; } } else { - retval = Tcl_Alloc(4); + retval = ckalloc(4); strcpy(retval, "NaN"); if (endPtr) { *endPtr = retval + 3; } } @@ -2164,11 +2309,11 @@ static inline char * FormatZero( int *decpt, /* Location of the decimal point. */ char **endPtr) /* Pointer to the end of the formatted data */ { - char *retval = Tcl_Alloc(2); + char *retval = ckalloc(2); strcpy(retval, "0"); if (endPtr) { *endPtr = retval+1; } @@ -2345,22 +2490,29 @@ *---------------------------------------------------------------------- */ static inline void SetPrecisionLimits( - int flags, /* Type of conversion: TCL_DD_SHORTEST, - * TCL_DD_E_FMT, TCL_DD_F_FMT. */ + int convType, /* Type of conversion: TCL_DD_SHORTEST, + * TCL_DD_STEELE0, TCL_DD_E_FMT, + * TCL_DD_F_FMT. */ int k, /* Floor(log10(number to convert)) */ int *ndigitsPtr, /* IN/OUT: Number of digits requested (will be * adjusted if needed). */ int *iPtr, /* OUT: Maximum number of digits to return. */ int *iLimPtr, /* OUT: Number of digits of significance if * the bignum method is used.*/ int *iLim1Ptr) /* OUT: Number of digits of significance if * the quick method is used. */ { - switch (flags & TCL_DD_CONVERSION_TYPE_MASK) { + switch (convType) { + case TCL_DD_SHORTEST0: + case TCL_DD_STEELE0: + *iLimPtr = *iLim1Ptr = -1; + *iPtr = 18; + *ndigitsPtr = 0; + break; case TCL_DD_E_FORMAT: if (*ndigitsPtr <= 0) { *ndigitsPtr = 1; } *iLimPtr = *iLim1Ptr = *iPtr = *ndigitsPtr; @@ -2372,14 +2524,14 @@ if (*iPtr <= 0) { *iPtr = 1; } break; default: - *iLimPtr = *iLim1Ptr = -1; - *iPtr = 18; - *ndigitsPtr = 0; - break; + *iPtr = -1; + *iLimPtr = -1; + *iLim1Ptr = -1; + Tcl_Panic("impossible conversion type in TclDoubleDigits"); } } /* *---------------------------------------------------------------------- @@ -2449,11 +2601,11 @@ if (k > 0) { /* * The number must be reduced to bring it into range. */ - ds = tens[k & 0xf]; + ds = tens[k & 0xF]; j = k >> 4; if (j & BLETCH) { j &= (BLETCH-1); d /= bigtens[N_BIGTENS - 1]; ieps++; @@ -2470,11 +2622,11 @@ } else if ((j1 = -k) != 0) { /* * The number must be increased to bring it into range. */ - d *= tens[j1 & 0xf]; + d *= tens[j1 & 0xF]; i = 0; for (j = j1>>4; j; j>>=1) { if (j & 1) { ieps++; d *= bigtens[i]; @@ -2710,11 +2862,11 @@ /* * Handle the peculiar case where the result has no significant digits. */ - retval = Tcl_Alloc(len + 1); + retval = ckalloc(len + 1); if (ilim == 0) { d -= 5.; if (d > eps.d) { *retval = '1'; *decpt = k; @@ -2721,11 +2873,11 @@ return retval; } else if (d < -eps.d) { *decpt = k; return retval; } else { - Tcl_Free(retval); + ckfree(retval); return NULL; } } /* @@ -2736,11 +2888,11 @@ end = ShorteningQuickFormat(d, k, ilim, eps.d, retval, decpt); } else { end = StrictQuickFormat(d, k, ilim, eps.d, retval, decpt); } if (end == NULL) { - Tcl_Free(retval); + ckfree(retval); return NULL; } *end = '\0'; if (endPtr != NULL) { *endPtr = end; @@ -2805,10 +2957,12 @@ */ static inline char * ShorteningInt64Conversion( Double *dPtr, /* Original number to convert. */ + int convType, /* Type of conversion (shortest, Steele, + * E format, F format). */ Tcl_WideUInt bw, /* Integer significand. */ int b2, int b5, /* Scale factor for the significand in the * numerator. */ int m2plus, int m2minus, int m5, /* Scale factors for 1/2 ulp in the numerator @@ -2821,11 +2975,11 @@ int ilim1, /* Number of digits to convert if b < s */ int *decpt, /* OUTPUT: Position of the decimal point. */ char **endPtr) /* OUTPUT: Position of the terminal '\0' at * the end of the returned string. */ { - char *retval = Tcl_Alloc(len + 1); + char *retval = ckalloc(len + 1); /* Output buffer. */ Tcl_WideUInt b = (bw * wuipow5[b5]) << b2; /* Numerator of the fraction being * converted. */ Tcl_WideUInt S = wuipow5[s5] << s2; @@ -2871,11 +3025,11 @@ * Does the current digit put us on the low side of the exact value * but within within roundoff of being exact? */ if (b < mplus || (b == mplus - && (dPtr->w.word1 & 1) == 0)) { + && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) { /* * Make sure we shouldn't be rounding *up* instead, in case the * next number above is closer. */ @@ -2900,11 +3054,11 @@ * Does one plus the current digit put us within roundoff of the * number? */ if (b > S - mminus || (b == S - mminus - && (dPtr->w.word1 & 1) == 0)) { + && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) { if (digit == 9) { *s++ = '9'; s = BumpUp(s, retval, &k); break; } @@ -2972,10 +3126,12 @@ */ static inline char * StrictInt64Conversion( Double *dPtr, /* Original number to convert. */ + int convType, /* Type of conversion (shortest, Steele, + * E format, F format). */ Tcl_WideUInt bw, /* Integer significand. */ int b2, int b5, /* Scale factor for the significand in the * numerator. */ int s2, int s5, /* Scale factors for the denominator. */ int k, /* Number of output digits before the decimal @@ -2985,11 +3141,11 @@ int ilim1, /* Number of digits to convert if b < s */ int *decpt, /* OUTPUT: Position of the decimal point. */ char **endPtr) /* OUTPUT: Position of the terminal '\0' at * the end of the returned string. */ { - char *retval = Tcl_Alloc(len + 1); + char *retval = ckalloc(len + 1); /* Output buffer. */ Tcl_WideUInt b = (bw * wuipow5[b5]) << b2; /* Numerator of the fraction being * converted. */ Tcl_WideUInt S = wuipow5[s5] << s2; @@ -3064,11 +3220,11 @@ * * ShouldBankerRoundUpPowD -- * * Test whether bankers' rounding should round a digit up. Assumption is * made that the denominator of the fraction being tested is a power of - * 2**DIGIT_BIT. + * 2**MP_DIGIT_BIT. * * Results: * Returns 1 iff the fraction is more than 1/2, or if the fraction is * exactly 1/2 and the digit is odd. * @@ -3076,11 +3232,11 @@ */ static inline int ShouldBankerRoundUpPowD( mp_int *b, /* Numerator of the fraction. */ - int sd, /* Denominator is 2**(sd*DIGIT_BIT). */ + int sd, /* Denominator is 2**(sd*MP_DIGIT_BIT). */ int isodd) /* 1 if the digit is odd, 0 if even. */ { int i; static const mp_digit topbit = ((mp_digit)1) << (MP_DIGIT_BIT - 1); @@ -3115,20 +3271,23 @@ static inline int ShouldBankerRoundUpToNextPowD( mp_int *b, /* Numerator of the fraction. */ mp_int *m, /* Numerator of the rounding tolerance. */ - int sd, /* Common denominator is 2**(sd*DIGIT_BIT). */ + int sd, /* Common denominator is 2**(sd*MP_DIGIT_BIT). */ + int convType, /* Conversion type: STEELE defeats + * round-to-even (not sure why one wants to do + * this; I copied it from Gay). FIXME */ int isodd, /* 1 if the integer significand is odd. */ mp_int *temp) /* Work area for the calculation. */ { int i; /* * Compare B and S-m - which is the same as comparing B+m and S - which we * do by computing b+m and doing a bitwhack compare against - * 2**(DIGIT_BIT*sd) + * 2**(MP_DIGIT_BIT*sd) */ mp_add(b, m, temp); if (temp->used <= sd) { /* Too few digits to be > s */ return 0; @@ -3140,10 +3299,14 @@ for (i = sd-1; i >= 0; --i) { /* Check for ==s */ if (temp->dp[i] != 0) { /* > s */ return 1; } + } + if (convType == TCL_DD_STEELE0) { + /* Biased rounding. */ + return 0; } return isodd; } /* @@ -3152,11 +3315,11 @@ * ShorteningBignumConversionPowD -- * * Converts a double-precision number to the shortest string of digits * that reconverts exactly to the given number, or to 'ilim' digits if * that will yield a shorter result. The denominator in David Gay's - * conversion algorithm is known to be a power of 2**DIGIT_BIT, and hence + * conversion algorithm is known to be a power of 2**MP_DIGIT_BIT, and hence * the division in the main loop may be replaced by a digit shift and * mask. * * Results: * Returns the string of significant decimal digits, in newly allocated @@ -3170,10 +3333,12 @@ */ static inline char * ShorteningBignumConversionPowD( Double *dPtr, /* Original number to convert. */ + int convType, /* Type of conversion (shortest, Steele, + * E format, F format). */ Tcl_WideUInt bw, /* Integer significand. */ int b2, int b5, /* Scale factor for the significand in the * numerator. */ int m2plus, int m2minus, int m5, /* Scale factors for 1/2 ulp in the numerator @@ -3186,11 +3351,11 @@ int ilim1, /* Number of digits to convert if b < s */ int *decpt, /* OUTPUT: Position of the decimal point. */ char **endPtr) /* OUTPUT: Position of the terminal '\0' at * the end of the returned string. */ { - char *retval = Tcl_Alloc(len + 1); + char *retval = ckalloc(len + 1); /* Output buffer. */ mp_int b; /* Numerator of the fraction being * converted. */ mp_int mplus, mminus; /* Bounds for roundoff. */ mp_digit digit; /* Current output digit. */ @@ -3202,11 +3367,11 @@ /* * b = bw * 2**b2 * 5**b5 * mminus = 5**m5 */ - TclInitBignumFromWideUInt(&b, bw); + TclBNInitBignumFromWideUInt(&b, bw); mp_init_set(&mminus, 1); MulPow5(&b, b5, &b); mp_mul_2d(&b, b2, &b); /* @@ -3232,11 +3397,11 @@ mp_mul_2d(&mplus, m2plus-m2minus, &mplus); } mp_init(&temp); /* - * Loop through the digits. Do division and mod by s == 2**(sd*DIGIT_BIT) + * Loop through the digits. Do division and mod by s == 2**(sd*MP_DIGIT_BIT) * by mp_digit extraction. */ i = 0; for (;;) { @@ -3255,11 +3420,11 @@ * but within within roundoff of being exact? */ r1 = mp_cmp_mag(&b, (m2plus > m2minus)? &mplus : &mminus); if (r1 == MP_LT || (r1 == MP_EQ - && (dPtr->w.word1 & 1) == 0)) { + && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) { /* * Make sure we shouldn't be rounding *up* instead, in case the * next number above is closer. */ @@ -3283,11 +3448,11 @@ /* * Does one plus the current digit put us within roundoff of the * number? */ - if (ShouldBankerRoundUpToNextPowD(&b, &mminus, sd, + if (ShouldBankerRoundUpToNextPowD(&b, &mminus, sd, convType, dPtr->w.word1 & 1, &temp)) { if (digit == 9) { *s++ = '9'; s = BumpUp(s, retval, &k); break; @@ -3344,11 +3509,11 @@ * StrictBignumConversionPowD -- * * Converts a double-precision number to a fixed-lengt string of 'ilim' * digits (or 'ilim1' if log10(d) has been overestimated). The * denominator in David Gay's conversion algorithm is known to be a power - * of 2**DIGIT_BIT, and hence the division in the main loop may be + * of 2**MP_DIGIT_BIT, and hence the division in the main loop may be * replaced by a digit shift and mask. * * Results: * Returns the string of significant decimal digits, in newly allocated * memory. @@ -3361,10 +3526,12 @@ */ static inline char * StrictBignumConversionPowD( Double *dPtr, /* Original number to convert. */ + int convType, /* Type of conversion (shortest, Steele, + * E format, F format). */ Tcl_WideUInt bw, /* Integer significand. */ int b2, int b5, /* Scale factor for the significand in the * numerator. */ int sd, /* Scale factor for the denominator. */ int k, /* Number of output digits before the decimal @@ -3374,23 +3541,24 @@ int ilim1, /* Number of digits to convert if b < s */ int *decpt, /* OUTPUT: Position of the decimal point. */ char **endPtr) /* OUTPUT: Position of the terminal '\0' at * the end of the returned string. */ { - char *retval = Tcl_Alloc(len + 1); + char *retval = ckalloc(len + 1); /* Output buffer. */ mp_int b; /* Numerator of the fraction being * converted. */ mp_digit digit; /* Current output digit. */ char *s = retval; /* Cursor in the output buffer. */ int i; /* Index in the output buffer. */ + mp_int temp; /* * b = bw * 2**b2 * 5**b5 */ - TclInitBignumFromWideUInt(&b, bw); + TclBNInitBignumFromWideUInt(&b, bw); MulPow5(&b, b5, &b); mp_mul_2d(&b, b2, &b); /* * Adjust if the logarithm was guessed wrong. @@ -3399,13 +3567,14 @@ if (b.used <= sd) { mp_mul_d(&b, 10, &b); ilim = ilim1; --k; } + mp_init(&temp); /* - * Loop through the digits. Do division and mod by s == 2**(sd*DIGIT_BIT) + * Loop through the digits. Do division and mod by s == 2**(sd*MP_DIGIT_BIT) * by mp_digit extraction. */ i = 1; for (;;) { @@ -3447,11 +3616,11 @@ /* * Endgame - store the location of the decimal point and the end of the * string. */ - mp_clear(&b); + mp_clear_multi(&b, &temp, NULL); *s = '\0'; *decpt = k; if (endPtr) { *endPtr = s; } @@ -3511,28 +3680,33 @@ ShouldBankerRoundUpToNext( mp_int *b, /* Remainder from the division that produced * the last digit. */ mp_int *m, /* Numerator of the rounding tolerance. */ mp_int *S, /* Denominator. */ - int isodd) /* 1 if the integer significand is odd. */ + int convType, /* Conversion type: STEELE0 defeats + * round-to-even. (Not sure why one would want + * this; I coped it from Gay). FIXME */ + int isodd, /* 1 if the integer significand is odd. */ + mp_int *temp) /* Work area needed for the calculation. */ { int r; - mp_int temp; /* * Compare b and S-m: this is the same as comparing B+m and S. */ - mp_init(&temp); - mp_add(b, m, &temp); - r = mp_cmp_mag(&temp, S); - mp_clear(&temp); + mp_add(b, m, temp); + r = mp_cmp_mag(temp, S); switch(r) { case MP_LT: return 0; case MP_EQ: - return isodd; + if (convType == TCL_DD_STEELE0) { + return 0; + } else { + return isodd; + } case MP_GT: return 1; } Tcl_Panic("in ShouldBankerRoundUpToNext, trichotomy fails!"); return 0; @@ -3557,10 +3731,11 @@ */ static inline char * ShorteningBignumConversion( Double *dPtr, /* Original number being converted. */ + int convType, /* Conversion type. */ Tcl_WideUInt bw, /* Integer significand and exponent. */ int b2, /* Scale factor for the significand. */ int m2plus, int m2minus, /* Scale factors for 1/2 ulp in numerator. */ int s2, int s5, /* Scale factors for denominator. */ int k, /* Guessed position of the decimal point. */ @@ -3568,29 +3743,30 @@ int ilim, /* Number of digits to convert if b >= s */ int ilim1, /* Number of digits to convert if b < s */ int *decpt, /* OUTPUT: Position of the decimal point. */ char **endPtr) /* OUTPUT: Pointer to the end of the number */ { - char *retval = Tcl_Alloc(len+1); + char *retval = ckalloc(len+1); /* Buffer of digits to return. */ char *s = retval; /* Cursor in the return value. */ mp_int b; /* Numerator of the result. */ mp_int mminus; /* 1/2 ulp below the result. */ mp_int mplus; /* 1/2 ulp above the result. */ mp_int S; /* Denominator of the result. */ mp_int dig; /* Current digit of the result. */ int digit; /* Current digit of the result. */ + mp_int temp; /* Work area. */ int minit = 1; /* Fudge factor for when we misguess k. */ int i; int r1; /* * b = bw * 2**b2 * 5**b5 * S = 2**s2 * 5*s5 */ - TclInitBignumFromWideUInt(&b, bw); + TclBNInitBignumFromWideUInt(&b, bw); mp_mul_2d(&b, b2, &b); mp_init_set(&S, 1); MulPow5(&S, s5, &S); mp_mul_2d(&S, s2, &S); /* @@ -3612,10 +3788,11 @@ mp_mul_2d(&mminus, m2minus, &mminus); if (m2plus > m2minus) { mp_init_copy(&mplus, &mminus); mp_mul_2d(&mplus, m2plus-m2minus, &mplus); } + mp_init(&temp); /* * Loop through the digits. */ @@ -3632,11 +3809,12 @@ * Does the current digit leave us with a remainder small enough to * round to it? */ r1 = mp_cmp_mag(&b, (m2plus > m2minus)? &mplus : &mminus); - if (r1 == MP_LT || (r1 == MP_EQ && (dPtr->w.word1 & 1) == 0)) { + if (r1 == MP_LT || (r1 == MP_EQ + && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) { mp_mul_2d(&b, 1, &b); if (ShouldBankerRoundUp(&b, &S, digit&1)) { ++digit; if (digit == 10) { *s++ = '9'; @@ -3651,12 +3829,12 @@ /* * Does the current digit leave us with a remainder large enough to * commit to rounding up to the next higher digit? */ - if (ShouldBankerRoundUpToNext(&b, &mminus, &S, - dPtr->w.word1 & 1)) { + if (ShouldBankerRoundUpToNext(&b, &mminus, &S, convType, + dPtr->w.word1 & 1, &temp)) { ++digit; if (digit == 10) { *s++ = '9'; s = BumpUp(s, retval, &k); break; @@ -3739,11 +3917,11 @@ */ if (m2plus > m2minus) { mp_clear(&mplus); } - mp_clear_multi(&b, &mminus, &dig, &S, NULL); + mp_clear_multi(&b, &mminus, &temp, &dig, &S, NULL); *s = '\0'; *decpt = k; if (endPtr) { *endPtr = s; } @@ -3769,10 +3947,11 @@ */ static inline char * StrictBignumConversion( Double *dPtr, /* Original number being converted. */ + int convType, /* Conversion type. */ Tcl_WideUInt bw, /* Integer significand and exponent. */ int b2, /* Scale factor for the significand. */ int s2, int s5, /* Scale factors for denominator. */ int k, /* Guessed position of the decimal point. */ int len, /* Size of the digit buffer to allocate. */ @@ -3779,27 +3958,28 @@ int ilim, /* Number of digits to convert if b >= s */ int ilim1, /* Number of digits to convert if b < s */ int *decpt, /* OUTPUT: Position of the decimal point. */ char **endPtr) /* OUTPUT: Pointer to the end of the number */ { - char *retval = Tcl_Alloc(len+1); + char *retval = ckalloc(len+1); /* Buffer of digits to return. */ char *s = retval; /* Cursor in the return value. */ mp_int b; /* Numerator of the result. */ mp_int S; /* Denominator of the result. */ mp_int dig; /* Current digit of the result. */ int digit; /* Current digit of the result. */ + mp_int temp; /* Work area. */ int g; /* Size of the current digit ground. */ int i, j; /* * b = bw * 2**b2 * 5**b5 * S = 2**s2 * 5*s5 */ - mp_init_multi(&dig, NULL); - TclInitBignumFromWideUInt(&b, bw); + mp_init_multi(&temp, &dig, NULL); + TclBNInitBignumFromWideUInt(&b, bw); mp_mul_2d(&b, b2, &b); mp_init_set(&S, 1); MulPow5(&S, s5, &S); mp_mul_2d(&S, s2, &S); /* @@ -3901,11 +4081,11 @@ /* * Endgame - store the location of the decimal point and the end of the * string. */ - mp_clear_multi(&b, &S, &dig, NULL); + mp_clear_multi(&b, &S, &temp, &dig, NULL); *s = '\0'; *decpt = k; if (endPtr) { *endPtr = s; } @@ -3931,18 +4111,28 @@ * sign (or no sign) should appear. * * This function is a service routine that produces the string of digits for * floating-point-to-decimal conversion. It can do a number of things * according to the 'flags' argument. Valid values for 'flags' include: - * TCL_DD_SHORTEST - This is the default for floating point conversion. - * It constructs the shortest string of + * TCL_DD_SHORTEST - This is the default for floating point conversion if + * ::tcl_precision is 0. It constructs the shortest string of * digits that will reconvert to the given number when scanned. * For floating point numbers that are exactly between two * decimal numbers, it resolves using the 'round to even' rule. * With this value, the 'ndigits' parameter is ignored. + * TCL_DD_STEELE - This value is not recommended and may be removed in + * the future. It follows the conversion algorithm outlined in + * "How to Print Floating-Point Numbers Accurately" by Guy + * L. Steele, Jr. and Jon L. White [Proc. ACM SIGPLAN '90, + * pp. 112-126]. This rule has the effect of rendering 1e23 as + * 9.9999999999999999e22 - which is a 'better' approximation in + * the sense that it will reconvert correctly even if a + * subsequent input conversion is 'round up' or 'round down' + * rather than 'round to nearest', but is surprising otherwise. * TCL_DD_E_FORMAT - This value is used to prepare numbers for %e format - * conversion. It constructs a string of at most 'ndigits' digits, + * conversion (or for default floating->string if tcl_precision + * is not 0). It constructs a string of at most 'ndigits' digits, * choosing the one that is closest to the given number (and * resolving ties with 'round to even'). It is allowed to return * fewer than 'ndigits' if the number converts exactly; if the * TCL_DD_E_FORMAT|TCL_DD_SHORTEN_FLAG is supplied instead, it * also returns fewer digits if the shorter string will still @@ -3986,10 +4176,14 @@ int *sign, /* OUTPUT: 1 if the result is negative. */ char **endPtr) /* OUTPUT: If not NULL, receives a pointer to * one character beyond the end of the * returned string. */ { + int convType = (flags & TCL_DD_CONVERSION_TYPE_MASK); + /* Type of conversion being performed: + * TCL_DD_SHORTEST0, TCL_DD_STEELE0, + * TCL_DD_E_FORMAT, or TCL_DD_F_FORMAT. */ Double d; /* Union for deconstructing doubles. */ Tcl_WideUInt bw; /* Integer significand. */ int be; /* Power of 2 by which b must be multiplied */ int bbits; /* Number of bits needed to represent b. */ int denorm; /* Flag == 1 iff the input number was @@ -4053,22 +4247,22 @@ /* * Correct an incorrect caller-supplied 'ndigits'. Also determine: * i = The maximum number of decimal digits that will be returned in the * formatted string. This is k + 1 + ndigits for F format, 18 for - * shortest, and ndigits for E format. + * shortest and Steele, and ndigits for E format. * ilim = The number of significant digits to convert if k has been - * guessed correctly. This is -1 for shortest (which + * guessed correctly. This is -1 for shortest and Steele (which * stop when all significance has been lost), 'ndigits' for E * format, and 'k + 1 + ndigits' for F format. * ilim1 = The minimum number of significant digits to convert if k has - * been guessed 1 too high. This, too, is -1 for shortest, - * and 'ndigits' for E format, but it's 'ndigits-1' for F + * been guessed 1 too high. This, too, is -1 for shortest and + * Steele, and 'ndigits' for E format, but it's 'ndigits-1' for F * format. */ - SetPrecisionLimits(flags, k, &ndigits, &i, &ilim, &ilim1); + SetPrecisionLimits(convType, k, &ndigits, &i, &ilim, &ilim1); /* * Try to do low-precision conversion in floating point rather than * resorting to expensive multiprecision arithmetic. */ @@ -4137,16 +4331,16 @@ * 64-bit arithmetic with no need for expensive multiprecision * operations. (This will be true for all numbers in the range * [1.0e-3 .. 1.0e+24]). */ - return ShorteningInt64Conversion(&d, bw, b2, b5, m2plus, + return ShorteningInt64Conversion(&d, convType, bw, b2, b5, m2plus, m2minus, m5, s2, s5, k, len, ilim, ilim1, decpt, endPtr); } else if (s5 == 0) { /* * The denominator is a power of 2, so we can replace division by - * digit shifts. First we round up s2 to a multiple of DIGIT_BIT, + * digit shifts. First we round up s2 to a multiple of MP_DIGIT_BIT, * and adjust m2 and b2 accordingly. Then we launch into a version * of the comparison that's specialized for the 'power of mp_digit * in the denominator' case. */ @@ -4156,20 +4350,20 @@ b2 += delta; m2plus += delta; m2minus += delta; s2 += delta; } - return ShorteningBignumConversionPowD(&d, bw, b2, b5, + return ShorteningBignumConversionPowD(&d, convType, bw, b2, b5, m2plus, m2minus, m5, s2/MP_DIGIT_BIT, k, len, ilim, ilim1, decpt, endPtr); } else { /* * Alas, there's no helpful special case; use full-up bignum * arithmetic for the conversion. */ - return ShorteningBignumConversion(&d, bw, b2, m2plus, + return ShorteningBignumConversion(&d, convType, bw, b2, m2plus, m2minus, s2, s5, k, len, ilim, ilim1, decpt, endPtr); } } else { /* * Non-shortening conversion. @@ -4193,16 +4387,16 @@ * then all our intermediate calculations can be done using exact * 64-bit arithmetic with no need for expensive multiprecision * operations. */ - return StrictInt64Conversion(&d, bw, b2, b5, s2, s5, k, + return StrictInt64Conversion(&d, convType, bw, b2, b5, s2, s5, k, len, ilim, ilim1, decpt, endPtr); } else if (s5 == 0) { /* * The denominator is a power of 2, so we can replace division by - * digit shifts. First we round up s2 to a multiple of DIGIT_BIT, + * digit shifts. First we round up s2 to a multiple of MP_DIGIT_BIT, * and adjust m2 and b2 accordingly. Then we launch into a version * of the comparison that's specialized for the 'power of mp_digit * in the denominator' case. */ @@ -4210,21 +4404,21 @@ int delta = MP_DIGIT_BIT - (s2 % MP_DIGIT_BIT); b2 += delta; s2 += delta; } - return StrictBignumConversionPowD(&d, bw, b2, b5, + return StrictBignumConversionPowD(&d, convType, bw, b2, b5, s2/MP_DIGIT_BIT, k, len, ilim, ilim1, decpt, endPtr); } else { /* * There are no helpful special cases, but at least we know in * advance how many digits we will convert. We can run the * conversion in steps of DIGIT_GROUP digits, so as to have many * fewer mp_int divisions. */ - return StrictBignumConversion(&d, bw, b2, s2, s5, k, + return StrictBignumConversion(&d, convType, bw, b2, s2, s5, k, len, ilim, ilim1, decpt, endPtr); } } } @@ -4272,11 +4466,12 @@ * Initialize table of powers of 10 expressed as wide integers. */ maxpow10_wide = (int) floor(sizeof(Tcl_WideUInt) * CHAR_BIT * log(2.) / log(10.)); - pow10_wide = Tcl_Alloc((maxpow10_wide + 1) * sizeof(Tcl_WideUInt)); + pow10_wide = (Tcl_WideUInt *) + ckalloc((maxpow10_wide + 1) * sizeof(Tcl_WideUInt)); u = 1; for (i = 0; i < maxpow10_wide; ++i) { pow10_wide[i] = u; u *= 10; } @@ -4348,13 +4543,13 @@ */ #ifdef IEEE_FLOATING_POINT bitwhack.dv = 1.000000238418579; /* 3ff0 0000 4000 0000 */ - if ((bitwhack.iv >> 32) == 0x3ff00000) { + if ((bitwhack.iv >> 32) == 0x3FF00000) { n770_fp = 0; - } else if ((bitwhack.iv & 0xffffffff) == 0x3ff00000) { + } else if ((bitwhack.iv & 0xFFFFFFFF) == 0x3FF00000) { n770_fp = 1; } else { Tcl_Panic("unknown floating point word order on this machine"); } #endif @@ -4379,11 +4574,11 @@ void TclFinalizeDoubleConversion(void) { int i; - Tcl_Free(pow10_wide); + ckfree(pow10_wide); for (i=0; i<9; ++i) { mp_clear(pow5 + i); } for (i=0; i < 5; ++i) { mp_clear(pow5_13 + i); @@ -4429,19 +4624,19 @@ Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); } return TCL_ERROR; } - fract = frexp(d, &expt); + fract = frexp(d,&expt); if (expt <= 0) { mp_init(b); mp_zero(b); } else { Tcl_WideInt w = (Tcl_WideInt) ldexp(fract, mantBits); int shift = expt - mantBits; - TclInitBignumFromWideInt(b, w); + TclBNInitBignumFromWideInt(b, w); if (shift < 0) { mp_div_2d(b, -shift, b, NULL); } else if (shift > 0) { mp_mul_2d(b, shift, b); } @@ -4479,14 +4674,14 @@ */ bits = mp_count_bits(a); if (bits > DBL_MAX_EXP*log2FLT_RADIX) { errno = ERANGE; - if (a->sign == MP_ZPOS) { - return HUGE_VAL; - } else { + if (mp_isneg(a)) { return -HUGE_VAL; + } else { + return HUGE_VAL; } } shift = mantBits - bits; /* @@ -4512,27 +4707,27 @@ * Round to even */ mp_div_2d(a, -shift, &b, NULL); if (mp_isodd(&b)) { - if (b.sign == MP_ZPOS) { - mp_add_d(&b, 1, &b); + if (mp_isneg(&b)) { + mp_sub_d(&b, 1, &b); } else { - mp_sub_d(&b, 1, &b); + mp_add_d(&b, 1, &b); } } } else { /* * Ordinary rounding */ mp_div_2d(a, -1-shift, &b, NULL); - if (b.sign == MP_ZPOS) { - mp_add_d(&b, 1, &b); + if (mp_isneg(&b)) { + mp_sub_d(&b, 1, &b); } else { - mp_sub_d(&b, 1, &b); + mp_add_d(&b, 1, &b); } mp_div_2d(&b, 1, &b, NULL); } } @@ -4554,14 +4749,14 @@ /* * Return the result with the appropriate sign. */ - if (a->sign == MP_ZPOS) { - return r; + if (mp_isneg(a)) { + return -r; } else { - return -r; + return r; } } /* *---------------------------------------------------------------------- @@ -4583,11 +4778,11 @@ { double r = 0.0; mp_int b; mp_init(&b); - if (a->sign != MP_ZPOS) { + if (mp_cmp_d(a, 0) == MP_LT) { mp_neg(a, &b); r = -TclFloor(&b); } else { int bits = mp_count_bits(a); @@ -4600,11 +4795,11 @@ mp_mul_2d(a, shift, &b); } else if (shift < 0) { mp_int d; mp_init(&d); mp_div_2d(a, -shift, &b, &d); - exact = d.used == 0; + exact = mp_iszero(&d); mp_clear(&d); } else { mp_copy(a, &b); } if (!exact) { @@ -4640,11 +4835,11 @@ { double r = 0.0; mp_int b; mp_init(&b); - if (a->sign != MP_ZPOS) { + if (mp_cmp_d(a, 0) == MP_LT) { mp_neg(a, &b); r = -TclCeil(&b); } else { int bits = mp_count_bits(a); @@ -4730,11 +4925,11 @@ /* * Return the result with the appropriate sign. */ *machexp = bits - mantBits + 2; - return ((a->sign == MP_ZPOS) ? r : -r); + return (mp_isneg(a) ? -r : r); } /* *---------------------------------------------------------------------- * @@ -4769,11 +4964,11 @@ if (exponent > 0) { /* * Multiply by 10**exponent. */ - retval = frexp(retval * pow10vals[exponent & 0xf], &j); + retval = frexp(retval * pow10vals[exponent&0xF], &j); expt += j; for (i=4; i<9; ++i) { if (exponent & (1<> 32) & 0xffffffff) | (w << 32)); + return (((w >> 32) & 0xFFFFFFFF) | (w << 32)); } #endif /* *---------------------------------------------------------------------- Index: generic/tclStringObj.c ================================================================== --- generic/tclStringObj.c +++ generic/tclStringObj.c @@ -36,40 +36,48 @@ #include "tclInt.h" #include "tommath.h" #include "tclStringRep.h" -#include "assert.h" +/* + * Set COMPAT to 1 to restore the shimmering patterns to those of Tcl 8.5. + * This is an escape hatch in case the changes have some unexpected unwelcome + * impact on performance. If things go well, this mechanism can go away when + * post-8.6 development begins. + */ + +#define COMPAT 0 + /* * Prototypes for functions defined later in this file: */ static void AppendPrintfToObjVA(Tcl_Obj *objPtr, const char *format, va_list argList); static void AppendUnicodeToUnicodeRep(Tcl_Obj *objPtr, - const Tcl_UniChar *unicode, size_t appendNumChars); + const Tcl_UniChar *unicode, int appendNumChars); static void AppendUnicodeToUtfRep(Tcl_Obj *objPtr, - const Tcl_UniChar *unicode, size_t numChars); + const Tcl_UniChar *unicode, int numChars); static void AppendUtfToUnicodeRep(Tcl_Obj *objPtr, - const char *bytes, size_t numBytes); + const char *bytes, int numBytes); static void AppendUtfToUtfRep(Tcl_Obj *objPtr, - const char *bytes, size_t numBytes); + const char *bytes, int numBytes); static void DupStringInternalRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); -static size_t ExtendStringRepWithUnicode(Tcl_Obj *objPtr, - const Tcl_UniChar *unicode, size_t numChars); +static int ExtendStringRepWithUnicode(Tcl_Obj *objPtr, + const Tcl_UniChar *unicode, int numChars); static void ExtendUnicodeRepWithString(Tcl_Obj *objPtr, - const char *bytes, size_t numBytes, - size_t numAppendChars); + const char *bytes, int numBytes, + int numAppendChars); static void FillUnicodeRep(Tcl_Obj *objPtr); static void FreeStringInternalRep(Tcl_Obj *objPtr); -static void GrowStringBuffer(Tcl_Obj *objPtr, size_t needed, int flag); -static void GrowUnicodeBuffer(Tcl_Obj *objPtr, size_t needed); +static void GrowStringBuffer(Tcl_Obj *objPtr, int needed, int flag); +static void GrowUnicodeBuffer(Tcl_Obj *objPtr, int needed); static int SetStringFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void SetUnicodeObj(Tcl_Obj *objPtr, - const Tcl_UniChar *unicode, size_t numChars); -static size_t UnicodeLength(const Tcl_UniChar *unicode); + const Tcl_UniChar *unicode, int numChars); +static int UnicodeLength(const Tcl_UniChar *unicode); static void UpdateStringOfString(Tcl_Obj *objPtr); /* * The structure below defines the string Tcl object type by means of * functions that can be invoked by generic object code. @@ -121,11 +129,11 @@ #endif static void GrowStringBuffer( Tcl_Obj *objPtr, - size_t needed, + int needed, int flag) { /* * Pre-conditions: * objPtr->typePtr == &tclStringType @@ -133,75 +141,82 @@ * flag || objPtr->bytes != NULL */ String *stringPtr = GET_STRING(objPtr); char *ptr = NULL; - size_t attempt; + int attempt; - if (objPtr->bytes == &tclEmptyString) { + if (objPtr->bytes == tclEmptyStringRep) { objPtr->bytes = NULL; } if (flag == 0 || stringPtr->allocated > 0) { - attempt = 2 * needed; - ptr = Tcl_AttemptRealloc(objPtr->bytes, attempt + 1); + if (needed <= INT_MAX / 2) { + attempt = 2 * needed; + ptr = (char *)attemptckrealloc(objPtr->bytes, attempt + 1); + } if (ptr == NULL) { /* * Take care computing the amount of modest growth to avoid * overflow into invalid argument values for attempt. */ - size_t limit = INT_MAX - needed; - size_t extra = needed - objPtr->length + TCL_MIN_GROWTH; - size_t growth = (extra > limit) ? limit : extra; + unsigned int limit = INT_MAX - needed; + unsigned int extra = needed - objPtr->length + TCL_MIN_GROWTH; + int growth = (int) ((extra > limit) ? limit : extra); attempt = needed + growth; - ptr = Tcl_AttemptRealloc(objPtr->bytes, attempt + 1); + ptr = (char *)attemptckrealloc(objPtr->bytes, attempt + 1); } } if (ptr == NULL) { /* * First allocation - just big enough; or last chance fallback. */ attempt = needed; - ptr = Tcl_Realloc(objPtr->bytes, attempt + 1); + ptr = (char *)ckrealloc(objPtr->bytes, attempt + 1); } objPtr->bytes = ptr; stringPtr->allocated = attempt; } static void GrowUnicodeBuffer( Tcl_Obj *objPtr, - size_t needed) + int needed) { /* * Pre-conditions: * objPtr->typePtr == &tclStringType * needed > stringPtr->maxChars + * needed < STRING_MAXCHARS */ String *ptr = NULL, *stringPtr = GET_STRING(objPtr); - size_t attempt; + int attempt; if (stringPtr->maxChars > 0) { /* * Subsequent appends - apply the growth algorithm. */ - attempt = 2 * needed; - ptr = stringAttemptRealloc(stringPtr, attempt); + if (needed <= STRING_MAXCHARS / 2) { + attempt = 2 * needed; + ptr = stringAttemptRealloc(stringPtr, attempt); + } if (ptr == NULL) { /* * Take care computing the amount of modest growth to avoid * overflow into invalid argument values for attempt. */ - size_t extra = needed - stringPtr->numChars + unsigned int limit = STRING_MAXCHARS - needed; + unsigned int extra = needed - stringPtr->numChars + TCL_MIN_UNICHAR_GROWTH; + int growth = (int) ((extra > limit) ? limit : extra); - attempt = needed + extra; + attempt = needed + growth; ptr = stringAttemptRealloc(stringPtr, attempt); } } if (ptr == NULL) { /* @@ -245,11 +260,11 @@ #undef Tcl_NewStringObj Tcl_Obj * Tcl_NewStringObj( const char *bytes, /* Points to the first of the length bytes * used to initialize the new object. */ - size_t length) /* The number of bytes to copy from "bytes" + int length) /* The number of bytes to copy from "bytes" * when initializing the new object. If * negative, use bytes up to the first NUL * byte. */ { return Tcl_DbNewStringObj(bytes, length, "unknown", 0); @@ -257,17 +272,18 @@ #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_NewStringObj( const char *bytes, /* Points to the first of the length bytes * used to initialize the new object. */ - size_t length) /* The number of bytes to copy from "bytes" - * when initializing the new object. If -1, - * use bytes up to the first NUL byte. */ + int length) /* The number of bytes to copy from "bytes" + * when initializing the new object. If + * negative, use bytes up to the first NUL + * byte. */ { Tcl_Obj *objPtr; - if (length == TCL_AUTO_LENGTH) { + if (length < 0) { length = (bytes? strlen(bytes) : 0); } TclNewStringObj(objPtr, bytes, length); return objPtr; } @@ -305,21 +321,22 @@ #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewStringObj( const char *bytes, /* Points to the first of the length bytes * used to initialize the new object. */ - size_t length, /* The number of bytes to copy from "bytes" - * when initializing the new object. If -1, - * use bytes up to the first NUL byte. */ + int length, /* The number of bytes to copy from "bytes" + * when initializing the new object. If + * negative, use bytes up to the first NUL + * byte. */ 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. */ { Tcl_Obj *objPtr; - if (length == TCL_AUTO_LENGTH) { + if (length < 0) { length = (bytes? strlen(bytes) : 0); } TclDbNewObj(objPtr, file, line); TclInitStringRep(objPtr, bytes, length); return objPtr; @@ -327,13 +344,14 @@ #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_DbNewStringObj( const char *bytes, /* Points to the first of the length bytes * used to initialize the new object. */ - size_t length, /* The number of bytes to copy from "bytes" - * when initializing the new object. If -1, - * use bytes up to the first NUL byte. */ + int length, /* The number of bytes to copy from "bytes" + * when initializing the new object. If + * negative, use bytes up to the first NUL + * byte. */ 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. */ { @@ -362,11 +380,11 @@ Tcl_Obj * Tcl_NewUnicodeObj( const Tcl_UniChar *unicode, /* The unicode string used to initialize the * new object. */ - size_t numChars) /* Number of characters in the unicode + int numChars) /* Number of characters in the unicode * string. */ { Tcl_Obj *objPtr; TclNewObj(objPtr); @@ -389,17 +407,17 @@ * rep. * *---------------------------------------------------------------------- */ -size_t +int Tcl_GetCharLength( Tcl_Obj *objPtr) /* The String object to get the num chars * of. */ { String *stringPtr; - size_t numChars = 0; + int numChars; /* * Quick, no-shimmer return for short string reps. */ @@ -410,20 +428,21 @@ /* * Optimize the case where we're really dealing with a bytearray object; * we don't need to convert to a string to perform the get-length operation. * - * Starting in Tcl 8.7, we check for a "pure" bytearray, because the - * machinery behind that test is using a proper bytearray ObjType. We - * could also compute length of an improper bytearray without shimmering - * but there's no value in that. We *want* to shimmer an improper bytearray - * because improper bytearrays have worthless internal reps. + * NOTE that we do not need the bytearray to be "pure". A ByteArray value + * with a string rep cannot be trusted to represent the same value as the + * string rep, but it *can* be trusted to have the same character length + * as the string rep, which is all this routine cares about. */ - if (TclIsPureByteArray(objPtr)) { - (void) TclGetByteArrayFromObj(objPtr, &numChars); - return numChars; + if (objPtr->typePtr == &tclByteArrayType) { + int length; + + (void) Tcl_GetByteArrayFromObj(objPtr, &length); + return length; } /* * OK, need to work with the object as a string. */ @@ -434,13 +453,25 @@ /* * If numChars is unknown, compute it. */ - if (numChars == TCL_AUTO_LENGTH) { + if (numChars == -1) { TclNumUtfChars(numChars, objPtr->bytes, objPtr->length); stringPtr->numChars = numChars; + +#if COMPAT + if (numChars < objPtr->length) { + /* + * Since we've just computed the number of chars, and not all UTF + * chars are 1-byte long, go ahead and populate the unicode + * string. + */ + + FillUnicodeRep(objPtr); + } +#endif } return numChars; } /* @@ -458,20 +489,20 @@ * None. * *---------------------------------------------------------------------- */ int -TclCheckEmptyString( +TclCheckEmptyString ( Tcl_Obj *objPtr) { int length = -1; - if (objPtr->bytes == &tclEmptyString) { + if (objPtr->bytes == tclEmptyStringRep) { return TCL_EMPTYSTRING_YES; } - if (TclListObjIsCanonical(objPtr)) { + if (TclIsPureList(objPtr)) { Tcl_ListObjLength(NULL, objPtr, &length); return length == 0; } if (TclIsPureDict(objPtr)) { @@ -486,15 +517,14 @@ } /* *---------------------------------------------------------------------- * - * Tcl_GetUniChar -- + * Tcl_GetUniChar/TclGetUCS4 -- * * Get the index'th Unicode character from the String object. If index - * is out of range or it references a low surrogate preceded by a high - * surrogate, the result = -1; + * is out of range, the result = 0xFFFD (Tcl_GetUniChar) resp. -1 (TclGetUCS4) * * Results: * Returns the index'th Unicode character in the Object. * * Side effects: @@ -501,32 +531,91 @@ * Fills unichar with the index'th Unicode character. * *---------------------------------------------------------------------- */ -int +Tcl_UniChar Tcl_GetUniChar( Tcl_Obj *objPtr, /* The object to get the Unicode charater * from. */ - size_t index) /* Get the index'th Unicode character. */ + int index) /* Get the index'th Unicode character. */ +{ + String *stringPtr; + int length; + + if (index < 0) { + return 0xFFFD; + } + + /* + * Optimize the case where we're really dealing with a bytearray object + * we don't need to convert to a string to perform the indexing operation. + */ + + if (TclIsPureByteArray(objPtr)) { + unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length); + if (index >= length) { + return 0xFFFD; + } + + return (Tcl_UniChar) bytes[index]; + } + + /* + * OK, need to work with the object as a string. + */ + + SetStringFromAny(NULL, objPtr); + stringPtr = GET_STRING(objPtr); + + if (stringPtr->hasUnicode == 0) { + /* + * If numChars is unknown, compute it. + */ + + if (stringPtr->numChars == -1) { + TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length); + } + if (stringPtr->numChars == objPtr->length) { + return (Tcl_UniChar) objPtr->bytes[index]; + } + FillUnicodeRep(objPtr); + stringPtr = GET_STRING(objPtr); + } + + if (index >= stringPtr->numChars) { + return 0xFFFD; + } + return stringPtr->unicode[index]; +} + +#if TCL_UTF_MAX == 4 +int +TclGetUCS4( + Tcl_Obj *objPtr, /* The object to get the Unicode charater + * from. */ + int index) /* Get the index'th Unicode character. */ { String *stringPtr; - int ch; + int ch, length; + + if (index < 0) { + return -1; + } /* * Optimize the case where we're really dealing with a bytearray object * we don't need to convert to a string to perform the indexing operation. */ if (TclIsPureByteArray(objPtr)) { - size_t length = 0; - unsigned char *bytes = TclGetByteArrayFromObj(objPtr, &length); + unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length); if (index >= length) { return -1; } - return bytes[index]; + return (int) bytes[index]; } /* * OK, need to work with the object as a string. */ @@ -537,11 +626,11 @@ if (stringPtr->hasUnicode == 0) { /* * If numChars is unknown, compute it. */ - if (stringPtr->numChars == TCL_AUTO_LENGTH) { + if (stringPtr->numChars == -1) { TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length); } if (stringPtr->numChars == objPtr->length) { return (Tcl_UniChar) objPtr->bytes[index]; } @@ -569,10 +658,38 @@ } } #endif return ch; } +#endif + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetUnicode -- + * + * Get the Unicode form of the String object. If the object is not + * already a String object, it will be converted to one. If the String + * object does not have a Unicode rep, then one is created from the UTF + * string format. + * + * Results: + * Returns a pointer to the object's internal Unicode string. + * + * Side effects: + * Converts the object to have the String internal rep. + * + *---------------------------------------------------------------------- + */ + +Tcl_UniChar * +Tcl_GetUnicode( + Tcl_Obj *objPtr) /* The object to find the unicode string + * for. */ +{ + return Tcl_GetUnicodeFromObj(objPtr, NULL); +} /* *---------------------------------------------------------------------- * * Tcl_GetUnicodeFromObj -- @@ -635,31 +752,28 @@ */ Tcl_Obj * Tcl_GetRange( Tcl_Obj *objPtr, /* The Tcl object to find the range of. */ - size_t first, /* First index of the range. */ - size_t last) /* Last index of the range. */ + int first, /* First index of the range. */ + int last) /* Last index of the range. */ { Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */ String *stringPtr; - size_t length = 0; + int length; - if (first == TCL_INDEX_NONE) { - first = TCL_INDEX_START; - } - if (last + 2 <= first + 1) { - return Tcl_NewObj(); + if (first < 0) { + first = 0; } /* * Optimize the case where we're really dealing with a bytearray object * we don't need to convert to a string to perform the substring operation. */ if (TclIsPureByteArray(objPtr)) { - unsigned char *bytes = TclGetByteArrayFromObj(objPtr, &length); + unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length); if (last >= length) { last = length - 1; } if (last < first) { @@ -678,11 +792,11 @@ if (stringPtr->hasUnicode == 0) { /* * If numChars is unknown, compute it. */ - if (stringPtr->numChars == TCL_AUTO_LENGTH) { + if (stringPtr->numChars == -1) { TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length); } if (stringPtr->numChars == objPtr->length) { if (last >= stringPtr->numChars) { last = stringPtr->numChars - 1; @@ -708,19 +822,19 @@ last = stringPtr->numChars; } if (last < first) { return Tcl_NewObj(); } -#if TCL_UTF_MAX <= 4 +#if TCL_UTF_MAX == 4 /* See: bug [11ae2be95dac9417] */ - if ((first + 1 > 1) && ((stringPtr->unicode[first] & 0xFC00) == 0xDC00) - && ((stringPtr->unicode[first-1] & 0xFC00) == 0xD800)) { + if ((first > 0) && ((stringPtr->unicode[first] & 0xFC00) == 0xDC00) + && ((stringPtr->unicode[first-1] & 0xFC00) == 0xD800)) { ++first; } - if ((last + 2 < stringPtr->numChars + 1) - && ((stringPtr->unicode[last+1] & 0xFC00) == 0xDC00) - && ((stringPtr->unicode[last] & 0xFC00) == 0xD800)) { + if ((last + 1 < stringPtr->numChars) + && ((stringPtr->unicode[last+1] & 0xFC00) == 0xDC00) + && ((stringPtr->unicode[last] & 0xFC00) == 0xD800)) { ++last; } #endif return Tcl_NewUnicodeObj(stringPtr->unicode + first, last - first + 1); } @@ -749,12 +863,12 @@ void Tcl_SetStringObj( Tcl_Obj *objPtr, /* Object whose internal rep to init. */ const char *bytes, /* Points to the first of the length bytes * used to initialize the object. */ - size_t length) /* The number of bytes to copy from "bytes" - * when initializing the object. If -1, + int length) /* The number of bytes to copy from "bytes" + * when initializing the object. If negative, * use bytes up to the first NUL byte.*/ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetStringObj"); } @@ -769,11 +883,11 @@ * Free any old string rep, then set the string rep to a copy of the * length bytes starting at "bytes". */ TclInvalidateStringRep(objPtr); - if (length == TCL_AUTO_LENGTH) { + if (length < 0) { length = (bytes? strlen(bytes) : 0); } TclInitStringRep(objPtr, bytes, length); } @@ -802,16 +916,25 @@ void Tcl_SetObjLength( Tcl_Obj *objPtr, /* Pointer to object. This object must not * currently be shared. */ - size_t length) /* Number of bytes desired for string + int length) /* Number of bytes desired for string * representation of object, not including * terminating null byte. */ { String *stringPtr; + if (length < 0) { + /* + * Setting to a negative length is nonsense. This is probably the + * result of overflowing the signed integer range. + */ + + Tcl_Panic("Tcl_SetObjLength: negative length requested: " + "%d (integer overflow?)", length); + } if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetObjLength"); } if (objPtr->bytes && objPtr->length == length) { @@ -827,14 +950,14 @@ */ if (length > stringPtr->allocated) { /* * Need to enlarge the buffer. */ - if (objPtr->bytes == &tclEmptyString) { - objPtr->bytes = Tcl_Alloc(length + 1); + if (objPtr->bytes == tclEmptyStringRep) { + objPtr->bytes = (char *)ckalloc(length + 1); } else { - objPtr->bytes = Tcl_Realloc(objPtr->bytes, length + 1); + objPtr->bytes = (char *)ckrealloc(objPtr->bytes, length + 1); } stringPtr->allocated = length; } objPtr->length = length; @@ -842,13 +965,18 @@ /* * Invalidate the unicode data. */ - stringPtr->numChars = TCL_AUTO_LENGTH; + stringPtr->numChars = -1; stringPtr->hasUnicode = 0; } else { + /* + * Changing length of pure unicode string. + */ + + stringCheckLimits(length); if (length > stringPtr->maxChars) { stringPtr = stringRealloc(stringPtr, length); SET_STRING(objPtr, stringPtr); stringPtr->maxChars = length; } @@ -893,16 +1021,24 @@ int Tcl_AttemptSetObjLength( Tcl_Obj *objPtr, /* Pointer to object. This object must not * currently be shared. */ - size_t length) /* Number of bytes desired for string + int length) /* Number of bytes desired for string * representation of object, not including * terminating null byte. */ { String *stringPtr; + if (length < 0) { + /* + * Setting to a negative length is nonsense. This is probably the + * result of overflowing the signed integer range. + */ + + return 0; + } if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_AttemptSetObjLength"); } if (objPtr->bytes && objPtr->length == length) { return 1; @@ -920,14 +1056,14 @@ * Need to enlarge the buffer. */ char *newBytes; - if (objPtr->bytes == &tclEmptyString) { - newBytes = Tcl_AttemptAlloc(length + 1); + if (objPtr->bytes == tclEmptyStringRep) { + newBytes = (char *)attemptckalloc(length + 1); } else { - newBytes = Tcl_AttemptRealloc(objPtr->bytes, length + 1); + newBytes = (char *)attemptckrealloc(objPtr->bytes, length + 1); } if (newBytes == NULL) { return 0; } objPtr->bytes = newBytes; @@ -939,17 +1075,20 @@ /* * Invalidate the unicode data. */ - stringPtr->numChars = TCL_AUTO_LENGTH; + stringPtr->numChars = -1; stringPtr->hasUnicode = 0; } else { /* * Changing length of pure unicode string. */ + if (length > STRING_MAXCHARS) { + return 0; + } if (length > stringPtr->maxChars) { stringPtr = stringAttemptRealloc(stringPtr, length); if (stringPtr == NULL) { return 0; } @@ -992,52 +1131,54 @@ void Tcl_SetUnicodeObj( Tcl_Obj *objPtr, /* The object to set the string of. */ const Tcl_UniChar *unicode, /* The unicode string used to initialize the * object. */ - size_t numChars) /* Number of characters in the unicode + int numChars) /* Number of characters in the unicode * string. */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetUnicodeObj"); } TclFreeIntRep(objPtr); SetUnicodeObj(objPtr, unicode, numChars); } -static size_t +static int UnicodeLength( const Tcl_UniChar *unicode) { - size_t numChars = 0; + int numChars = 0; if (unicode) { - while ((numChars != TCL_AUTO_LENGTH) && (unicode[numChars] != 0)) { + while (numChars >= 0 && unicode[numChars] != 0) { numChars++; } } + stringCheckLimits(numChars); return numChars; } static void SetUnicodeObj( Tcl_Obj *objPtr, /* The object to set the string of. */ const Tcl_UniChar *unicode, /* The unicode string used to initialize the * object. */ - size_t numChars) /* Number of characters in the unicode + int numChars) /* Number of characters in the unicode * string. */ { String *stringPtr; - if (numChars == TCL_AUTO_LENGTH) { + if (numChars < 0) { numChars = UnicodeLength(unicode); } /* * Allocate enough space for the String structure + Unicode string. */ + stringCheckLimits(numChars); stringPtr = stringAlloc(numChars); SET_STRING(objPtr, stringPtr); objPtr->typePtr = &tclStringType; stringPtr->maxChars = numChars; @@ -1071,53 +1212,61 @@ void Tcl_AppendLimitedToObj( Tcl_Obj *objPtr, /* Points to the object to append to. */ const char *bytes, /* Points to the bytes to append to the * object. */ - size_t length, /* The number of bytes available to be - * appended from "bytes". If -1, then - * all bytes up to a NUL byte are available. */ - size_t limit, /* The maximum number of bytes to append to + int length, /* The number of bytes available to be + * appended from "bytes". If < 0, then all + * bytes up to a NUL byte are available. */ + int limit, /* The maximum number of bytes to append to * the object. */ const char *ellipsis) /* Ellipsis marker string, appended to the * object to indicate not all available bytes * at "bytes" were appended. */ { String *stringPtr; - size_t toCopy = 0; + int toCopy = 0; + int eLen = 0; - if (Tcl_IsShared(objPtr)) { - Tcl_Panic("%s called with shared object", "Tcl_AppendLimitedToObj"); - } - - if (length == TCL_AUTO_LENGTH) { + if (length < 0) { length = (bytes ? strlen(bytes) : 0); } if (length == 0) { return; + } + if (limit <= 0) { + return; } if (length <= limit) { toCopy = length; } else { if (ellipsis == NULL) { ellipsis = "..."; } - toCopy = (bytes == NULL) ? limit - : (size_t)(Tcl_UtfPrev(bytes+limit+1-strlen(ellipsis), bytes) - bytes); + eLen = strlen(ellipsis); + while (eLen > limit) { + eLen = TclUtfPrev(ellipsis+eLen, ellipsis) - ellipsis; + } + + toCopy = TclUtfPrev(bytes+limit+1-eLen, bytes) - bytes; } /* * If objPtr has a valid Unicode rep, then append the Unicode conversion * of "bytes" to the objPtr's Unicode rep, otherwise append "bytes" to * objPtr's string rep. */ + + if (Tcl_IsShared(objPtr)) { + Tcl_Panic("%s called with shared object", "Tcl_AppendLimitedToObj"); + } SetStringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); - if (stringPtr->hasUnicode && (stringPtr->numChars+1) > 1) { + if (stringPtr->hasUnicode && stringPtr->numChars > 0) { AppendUtfToUnicodeRep(objPtr, bytes, toCopy); } else { AppendUtfToUtfRep(objPtr, bytes, toCopy); } @@ -1124,14 +1273,14 @@ if (length <= limit) { return; } stringPtr = GET_STRING(objPtr); - if (stringPtr->hasUnicode && (stringPtr->numChars+1) > 1) { - AppendUtfToUnicodeRep(objPtr, ellipsis, strlen(ellipsis)); + if (stringPtr->hasUnicode && stringPtr->numChars > 0) { + AppendUtfToUnicodeRep(objPtr, ellipsis, eLen); } else { - AppendUtfToUtfRep(objPtr, ellipsis, strlen(ellipsis)); + AppendUtfToUtfRep(objPtr, ellipsis, eLen); } } /* *---------------------------------------------------------------------- @@ -1153,15 +1302,15 @@ void Tcl_AppendToObj( Tcl_Obj *objPtr, /* Points to the object to append to. */ const char *bytes, /* Points to the bytes to append to the * object. */ - size_t length) /* The number of bytes to append from "bytes". - * If -1, then append all bytes up to NUL + int length) /* The number of bytes to append from "bytes". + * If < 0, then append all bytes up to NUL * byte. */ { - Tcl_AppendLimitedToObj(objPtr, bytes, length, TCL_AUTO_LENGTH, NULL); + Tcl_AppendLimitedToObj(objPtr, bytes, length, INT_MAX, NULL); } /* *---------------------------------------------------------------------- * @@ -1182,11 +1331,11 @@ void Tcl_AppendUnicodeToObj( Tcl_Obj *objPtr, /* Points to the object to append to. */ const Tcl_UniChar *unicode, /* The unicode string to append to the * object. */ - size_t length) /* Number of chars in "unicode". */ + int length) /* Number of chars in "unicode". */ { String *stringPtr; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_AppendUnicodeToObj"); @@ -1203,11 +1352,15 @@ * If objPtr has a valid Unicode rep, then append the "unicode" to the * objPtr's Unicode rep, otherwise the UTF conversion of "unicode" to * objPtr's string rep. */ - if (stringPtr->hasUnicode) { + if (stringPtr->hasUnicode +#if COMPAT + && stringPtr->numChars > 0 +#endif + ) { AppendUnicodeToUnicodeRep(objPtr, unicode, length); } else { AppendUnicodeToUtfRep(objPtr, unicode, length); } } @@ -1236,36 +1389,35 @@ Tcl_AppendObjToObj( Tcl_Obj *objPtr, /* Points to the object to append to. */ Tcl_Obj *appendObjPtr) /* Object to append. */ { String *stringPtr; - size_t length = 0, numChars; - size_t appendNumChars = TCL_AUTO_LENGTH; + int length, numChars, appendNumChars = -1; const char *bytes; /* * Special case: second object is standard-empty is fast case. We know * that appending nothing to anything leaves that starting anything... */ - if (appendObjPtr->bytes == &tclEmptyString) { + if (appendObjPtr->bytes == tclEmptyStringRep) { return; } /* * Handle append of one bytearray object to another as a special case. - * Note that we only do this when the objects are pure so that the - * bytearray faithfully represent the true value; Otherwise appending the - * byte arrays together could lose information; + * Note that we only do this when the objects don't have string reps; if + * it did, then appending the byte arrays together could well lose + * information; this is a special-case optimization only. */ - if ((TclIsPureByteArray(objPtr) || objPtr->bytes == &tclEmptyString) + if ((TclIsPureByteArray(objPtr) || objPtr->bytes == tclEmptyStringRep) && TclIsPureByteArray(appendObjPtr)) { /* * You might expect the code here to be * - * bytes = TclGetByteArrayFromObj(appendObjPtr, &length); + * bytes = Tcl_GetByteArrayFromObj(appendObjPtr, &length); * TclAppendBytesToByteArray(objPtr, bytes, length); * * and essentially all of the time that would be fine. However, it * would run into trouble in the case where objPtr and appendObjPtr * point to the same thing. That may never be a good idea. It seems to @@ -1277,14 +1429,14 @@ * cases. * * First, get the lengths. */ - size_t lengthSrc = 0; + int lengthSrc; - (void) TclGetByteArrayFromObj(objPtr, &length); - (void) TclGetByteArrayFromObj(appendObjPtr, &lengthSrc); + (void) Tcl_GetByteArrayFromObj(objPtr, &length); + (void) Tcl_GetByteArrayFromObj(appendObjPtr, &lengthSrc); /* * Grow buffer enough for the append. */ @@ -1316,18 +1468,22 @@ /* * If objPtr has a valid Unicode rep, then get a Unicode string from * appendObjPtr and append it. */ - if (stringPtr->hasUnicode) { + if (stringPtr->hasUnicode +#if COMPAT + && stringPtr->numChars > 0 +#endif + ) { /* * If appendObjPtr is not of the "String" type, don't convert it. */ - if (TclHasIntRep(appendObjPtr, &tclStringType)) { + if (appendObjPtr->typePtr == &tclStringType) { Tcl_UniChar *unicode = - TclGetUnicodeFromObj(appendObjPtr, &numChars); + Tcl_GetUnicodeFromObj(appendObjPtr, &numChars); AppendUnicodeToUnicodeRep(objPtr, unicode, numChars); } else { bytes = TclGetStringFromObj(appendObjPtr, &length); AppendUtfToUnicodeRep(objPtr, bytes, length); @@ -1342,19 +1498,23 @@ */ bytes = TclGetStringFromObj(appendObjPtr, &length); numChars = stringPtr->numChars; - if ((numChars != TCL_AUTO_LENGTH) && TclHasIntRep(appendObjPtr, &tclStringType)) { + if ((numChars >= 0) && (appendObjPtr->typePtr == &tclStringType)) { String *appendStringPtr = GET_STRING(appendObjPtr); appendNumChars = appendStringPtr->numChars; } AppendUtfToUtfRep(objPtr, bytes, length); - if ((numChars != TCL_AUTO_LENGTH) && (appendNumChars != TCL_AUTO_LENGTH)) { + if (numChars >= 0 && appendNumChars >= 0 +#if COMPAT + && appendNumChars == length +#endif + ) { stringPtr->numChars = numChars + appendNumChars; } } /* @@ -1376,16 +1536,16 @@ static void AppendUnicodeToUnicodeRep( Tcl_Obj *objPtr, /* Points to the object to append to. */ const Tcl_UniChar *unicode, /* String to append. */ - size_t appendNumChars) /* Number of chars of "unicode" to append. */ + int appendNumChars) /* Number of chars of "unicode" to append. */ { String *stringPtr; - size_t numChars; + int numChars; - if (appendNumChars == TCL_AUTO_LENGTH) { + if (appendNumChars < 0) { appendNumChars = UnicodeLength(unicode); } if (appendNumChars == 0) { return; } @@ -1400,34 +1560,35 @@ * "TCL STRING GROWTH ALGORITHM" comment at the top of this file for an * explanation of this growth algorithm. */ numChars = stringPtr->numChars + appendNumChars; + stringCheckLimits(numChars); if (numChars > stringPtr->maxChars) { - size_t index = TCL_INDEX_NONE; + int offset = -1; /* * Protect against case where unicode points into the existing * stringPtr->unicode array. Force it to follow any relocations due to * the reallocs below. */ if (unicode && unicode >= stringPtr->unicode && unicode <= stringPtr->unicode + stringPtr->maxChars) { - index = unicode - stringPtr->unicode; + offset = unicode - stringPtr->unicode; } GrowUnicodeBuffer(objPtr, numChars); stringPtr = GET_STRING(objPtr); /* * Relocate unicode if needed; see above. */ - if (index != TCL_INDEX_NONE) { - unicode = stringPtr->unicode + index; + if (offset >= 0) { + unicode = stringPtr->unicode + offset; } } /* * Copy the new string onto the end of the old string, then add the @@ -1464,19 +1625,27 @@ static void AppendUnicodeToUtfRep( Tcl_Obj *objPtr, /* Points to the object to append to. */ const Tcl_UniChar *unicode, /* String to convert to UTF. */ - size_t numChars) /* Number of chars of "unicode" to convert. */ + int numChars) /* Number of chars of "unicode" to convert. */ { String *stringPtr = GET_STRING(objPtr); numChars = ExtendStringRepWithUnicode(objPtr, unicode, numChars); - if (stringPtr->numChars != TCL_AUTO_LENGTH) { + if (stringPtr->numChars != -1) { stringPtr->numChars += numChars; } + +#if COMPAT + /* + * Invalidate the unicode rep. + */ + + stringPtr->hasUnicode = 0; +#endif } /* *---------------------------------------------------------------------- * @@ -1497,11 +1666,11 @@ static void AppendUtfToUnicodeRep( Tcl_Obj *objPtr, /* Points to the object to append to. */ const char *bytes, /* String to convert to Unicode. */ - size_t numBytes) /* Number of bytes of "bytes" to convert. */ + int numBytes) /* Number of bytes of "bytes" to convert. */ { String *stringPtr; if (numBytes == 0) { return; @@ -1533,14 +1702,14 @@ static void AppendUtfToUtfRep( Tcl_Obj *objPtr, /* Points to the object to append to. */ const char *bytes, /* String to append. */ - size_t numBytes) /* Number of bytes of "bytes" to append. */ + int numBytes) /* Number of bytes of "bytes" to append. */ { String *stringPtr; - size_t newLength, oldLength; + int newLength, oldLength; if (numBytes == 0) { return; } @@ -1552,14 +1721,17 @@ if (objPtr->bytes == NULL) { objPtr->length = 0; } oldLength = objPtr->length; newLength = numBytes + oldLength; + if (newLength < 0) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } stringPtr = GET_STRING(objPtr); if (newLength > stringPtr->allocated) { - size_t offset = TCL_AUTO_LENGTH; + int offset = -1; /* * Protect against case where unicode points into the existing * stringPtr->unicode array. Force it to follow any relocations due to * the reallocs below. @@ -1579,28 +1751,65 @@ /* * Relocate bytes if needed; see above. */ - if (offset != TCL_AUTO_LENGTH) { + if (offset >= 0) { bytes = objPtr->bytes + offset; } } /* * Invalidate the unicode data. */ - stringPtr->numChars = TCL_AUTO_LENGTH; + stringPtr->numChars = -1; stringPtr->hasUnicode = 0; if (bytes) { memmove(objPtr->bytes + oldLength, bytes, numBytes); } objPtr->bytes[newLength] = 0; objPtr->length = newLength; } + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppendStringsToObjVA -- + * + * This function appends one or more null-terminated strings to an + * object. + * + * Results: + * None. + * + * Side effects: + * The contents of all the string arguments are appended to the string + * representation of objPtr. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AppendStringsToObjVA( + Tcl_Obj *objPtr, /* Points to the object to append to. */ + va_list argList) /* Variable argument list. */ +{ + if (Tcl_IsShared(objPtr)) { + Tcl_Panic("%s called with shared object", "Tcl_AppendStringsToObj"); + } + + while (1) { + const char *bytes = va_arg(argList, char *); + + if (bytes == NULL) { + break; + } + Tcl_AppendToObj(objPtr, bytes, -1); + } +} /* *---------------------------------------------------------------------- * * Tcl_AppendStringsToObj -- @@ -1624,22 +1833,11 @@ ...) { va_list argList; va_start(argList, objPtr); - if (Tcl_IsShared(objPtr)) { - Tcl_Panic("%s called with shared object", "Tcl_AppendStringsToObj"); - } - - while (1) { - const char *bytes = va_arg(argList, char *); - - if (bytes == NULL) { - break; - } - Tcl_AppendToObj(objPtr, bytes, -1); - } + Tcl_AppendStringsToObjVA(objPtr, argList); va_end(argList); } /* *---------------------------------------------------------------------- @@ -1668,12 +1866,12 @@ const char *format, int objc, Tcl_Obj *const objv[]) { const char *span = format, *msg, *errCode; - int objIndex = 0, gotXpg = 0, gotSequential = 0; - size_t originalLength, limit, numBytes = 0; + int numBytes = 0, objIndex = 0, gotXpg = 0, gotSequential = 0; + int originalLength, limit; Tcl_UniChar ch = 0; static const char *mixedXPG = "cannot mix \"%\" and \"%n$\" conversion specifiers"; static const char *const badIndex[2] = { "not enough arguments for all format specifiers", @@ -1682,12 +1880,12 @@ static const char *overflow = "max size for a Tcl value exceeded"; if (Tcl_IsShared(appendObj)) { Tcl_Panic("%s called with shared object", "Tcl_AppendFormatToObj"); } - (void)TclGetStringFromObj(appendObj, &originalLength); - limit = (size_t)INT_MAX - originalLength; + TclGetStringFromObj(appendObj, &originalLength); + limit = INT_MAX - originalLength; /* * Format string is NUL-terminated. */ @@ -1696,12 +1894,11 @@ int gotMinus = 0, gotHash = 0, gotZero = 0, gotSpace = 0, gotPlus = 0; int width, gotPrecision, precision, sawFlag, useShort = 0, useBig = 0; #ifndef TCL_WIDE_INT_IS_LONG int useWide = 0; #endif - int newXpg, numChars, allocSegment = 0, segmentLimit; - size_t segmentNumBytes; + int newXpg, numChars, allocSegment = 0, segmentLimit, segmentNumBytes; Tcl_Obj *segment; int step = TclUtfToUniChar(format, &ch); format += step; if (ch != '%') { @@ -1829,11 +2026,11 @@ } objIndex++; format += step; step = TclUtfToUniChar(format, &ch); } - if (width > (int) limit) { + if (width > limit) { msg = overflow; errCode = "OVERFLOW"; goto errorMsg; } @@ -1892,29 +2089,10 @@ #ifndef TCL_WIDE_INT_IS_LONG } else { useWide = 1; #endif } - } else if (ch == 'I') { - if ((format[1] == '6') && (format[2] == '4')) { - format += (step + 2); - step = TclUtfToUniChar(format, &ch); -#ifndef TCL_WIDE_INT_IS_LONG - useWide = 1; -#endif - } else if ((format[1] == '3') && (format[2] == '2')) { - format += (step + 2); - step = TclUtfToUniChar(format, &ch); - } else { - format += step; - step = TclUtfToUniChar(format, &ch); - } - } else if ((ch == 't') || (ch == 'z') || (ch == 'q') || (ch == 'j') - || (ch == 'L')) { - format += step; - step = TclUtfToUniChar(format, &ch); - useBig = 1; } format += step; span = format; @@ -1949,24 +2127,31 @@ if (TclGetIntFromObj(interp, segment, &code) != TCL_OK) { goto error; } length = Tcl_UniCharToUtf(code, buf); +#if TCL_UTF_MAX > 3 if ((code >= 0xD800) && (length < 3)) { /* Special case for handling high surrogates. */ length += Tcl_UniCharToUtf(-1, buf + length); } +#endif segment = Tcl_NewStringObj(buf, length); Tcl_IncrRefCount(segment); allocSegment = 1; break; } case 'u': + if (useBig) { + msg = "unsigned bignum format is invalid"; + errCode = "BADUNSIGNED"; + goto errorMsg; + } + /* FALLTHRU */ case 'd': case 'o': - case 'p': case 'x': case 'X': case 'b': { short s = 0; /* Silence compiler warning; only defined and * used when useShort is true. */ @@ -1973,65 +2158,60 @@ long l; Tcl_WideInt w; mp_int big; int toAppend, isNegative = 0; -#ifndef TCL_WIDE_INT_IS_LONG - if (ch == 'p') { - useWide = 1; - } -#endif if (useBig) { - int cmpResult; if (Tcl_GetBignumFromObj(interp, segment, &big) != TCL_OK) { goto error; } - cmpResult = mp_cmp_d(&big, 0); - isNegative = (cmpResult == MP_LT); - if (cmpResult == MP_EQ) gotHash = 0; - if (ch == 'u') { - if (isNegative) { - mp_clear(&big); - msg = "unsigned bignum format is invalid"; - errCode = "BADUNSIGNED"; - goto errorMsg; - } else { - ch = 'd'; - } - } + isNegative = (mp_cmp_d(&big, 0) == MP_LT); #ifndef TCL_WIDE_INT_IS_LONG } else if (useWide) { - if (TclGetWideBitsFromObj(interp, segment, &w) != TCL_OK) { - goto error; + if (Tcl_GetWideIntFromObj(NULL, segment, &w) != TCL_OK) { + Tcl_Obj *objPtr; + + if (Tcl_GetBignumFromObj(interp,segment,&big) != TCL_OK) { + goto error; + } + mp_mod_2d(&big, CHAR_BIT*sizeof(Tcl_WideInt), &big); + objPtr = Tcl_NewBignumObj(&big); + Tcl_IncrRefCount(objPtr); + Tcl_GetWideIntFromObj(NULL, objPtr, &w); + Tcl_DecrRefCount(objPtr); } isNegative = (w < (Tcl_WideInt) 0); - if (w == (Tcl_WideInt) 0) gotHash = 0; #endif } else if (TclGetLongFromObj(NULL, segment, &l) != TCL_OK) { - if (TclGetWideBitsFromObj(interp, segment, &w) != TCL_OK) { - goto error; + if (Tcl_GetWideIntFromObj(NULL, segment, &w) != TCL_OK) { + Tcl_Obj *objPtr; + + if (Tcl_GetBignumFromObj(interp,segment,&big) != TCL_OK) { + goto error; + } + mp_mod_2d(&big, CHAR_BIT * sizeof(long), &big); + objPtr = Tcl_NewBignumObj(&big); + Tcl_IncrRefCount(objPtr); + TclGetLongFromObj(NULL, objPtr, &l); + Tcl_DecrRefCount(objPtr); } else { - l = (long) w; + l = Tcl_WideAsLong(w); } if (useShort) { s = (short) l; isNegative = (s < (short) 0); - if (s == (short) 0) gotHash = 0; } else { isNegative = (l < (long) 0); - if (l == (long) 0) gotHash = 0; } } else if (useShort) { s = (short) l; isNegative = (s < (short) 0); - if (s == (short) 0) gotHash = 0; } else { isNegative = (l < (long) 0); - if (l == (long) 0) gotHash = 0; } - segment = Tcl_NewObj(); + TclNewObj(segment); allocSegment = 1; segmentLimit = INT_MAX; Tcl_IncrRefCount(segment); if ((isNegative || gotPlus || gotSpace) && (useBig || ch=='d')) { @@ -2038,19 +2218,22 @@ Tcl_AppendToObj(segment, (isNegative ? "-" : gotPlus ? "+" : " "), 1); segmentLimit -= 1; } - if (gotHash || (ch == 'p')) { + if (gotHash) { switch (ch) { case 'o': - Tcl_AppendToObj(segment, "0o", 2); + Tcl_AppendToObj(segment, "0", 1); + segmentLimit -= 1; + precision--; + break; + case 'X': + Tcl_AppendToObj(segment, "0X", 2); segmentLimit -= 2; break; - case 'p': case 'x': - case 'X': Tcl_AppendToObj(segment, "0x", 2); segmentLimit -= 2; break; case 'b': Tcl_AppendToObj(segment, "0b", 2); @@ -2059,24 +2242,24 @@ } } switch (ch) { case 'd': { - size_t length; + int length; Tcl_Obj *pure; const char *bytes; if (useShort) { - pure = Tcl_NewWideIntObj(s); + TclNewIntObj(pure, (int) s); #ifndef TCL_WIDE_INT_IS_LONG } else if (useWide) { pure = Tcl_NewWideIntObj(w); #endif } else if (useBig) { pure = Tcl_NewBignumObj(&big); } else { - pure = Tcl_NewWideIntObj(l); + pure = Tcl_NewLongObj(l); } Tcl_IncrRefCount(pure); bytes = TclGetStringFromObj(pure, &length); /* @@ -2094,25 +2277,25 @@ * entirely of one-byte encoded characters, so "length" is the * number of chars. */ if (gotPrecision) { - if (length < (size_t)precision) { + if (length < precision) { segmentLimit -= precision - length; } - while (length < (size_t)precision) { + while (length < precision) { Tcl_AppendToObj(segment, "0", 1); length++; } gotZero = 0; } if (gotZero) { length += Tcl_GetCharLength(segment); - if (length < (size_t)width) { + if (length < width) { segmentLimit -= width - length; } - while (length < (size_t)width) { + while (length < width) { Tcl_AppendToObj(segment, "0", 1); length++; } } if (toAppend > segmentLimit) { @@ -2125,18 +2308,16 @@ break; } case 'u': case 'o': - case 'p': case 'x': case 'X': case 'b': { - Tcl_WideUInt bits = 0; - Tcl_WideInt numDigits = 0; - int numBits = 4, base = 16, index = 0, shift = 0; - size_t length; + Tcl_WideUInt bits = (Tcl_WideUInt) 0; + Tcl_WideInt numDigits = (Tcl_WideInt) 0; + int length, numBits = 4, base = 16, index = 0, shift = 0; Tcl_Obj *pure; char *bytes; if (ch == 'u') { base = 10; @@ -2192,17 +2373,17 @@ /* * Need to be sure zero becomes "0", not "". */ - if (numDigits == 0) { + if ((numDigits == 0) && !((ch == 'o') && gotHash)) { numDigits = 1; } - pure = Tcl_NewObj(); - Tcl_SetObjLength(pure, numDigits); + TclNewObj(pure); + Tcl_SetObjLength(pure, (int) numDigits); bytes = TclGetString(pure); - toAppend = length = numDigits; + toAppend = length = (int) numDigits; while (numDigits--) { int digitOffset; if (useBig && big.used) { if (index < big.used && (size_t) shift < @@ -2210,11 +2391,11 @@ bits |= ((Tcl_WideUInt) big.dp[index++]) << shift; shift += MP_DIGIT_BIT; } shift -= numBits; } - digitOffset = bits % base; + digitOffset = (int) (bits % base); if (digitOffset > 9) { if (ch == 'X') { bytes[numDigits] = 'A' + digitOffset - 10; } else { bytes[numDigits] = 'a' + digitOffset - 10; @@ -2226,25 +2407,25 @@ } if (useBig) { mp_clear(&big); } if (gotPrecision) { - if (length < (size_t)precision) { + if (length < precision) { segmentLimit -= precision - length; } - while (length < (size_t)precision) { + while (length < precision) { Tcl_AppendToObj(segment, "0", 1); length++; } gotZero = 0; } if (gotZero) { length += Tcl_GetCharLength(segment); - if (length < (size_t)width) { + if (length < width) { segmentLimit -= width - length; } - while (length < (size_t)width) { + while (length < width) { Tcl_AppendToObj(segment, "0", 1); length++; } } if (toAppend > segmentLimit) { @@ -2259,12 +2440,10 @@ } break; } - case 'a': - case 'A': case 'e': case 'E': case 'f': case 'g': case 'G': { @@ -2316,11 +2495,11 @@ */ *p++ = (char) ch; *p = '\0'; - segment = Tcl_NewObj(); + TclNewObj(segment); allocSegment = 1; if (!Tcl_AttemptSetObjLength(segment, length)) { msg = overflow; errCode = "OVERFLOW"; goto errorMsg; @@ -2329,16 +2508,10 @@ if (!Tcl_AttemptSetObjLength(segment, sprintf(bytes, spec, d))) { msg = overflow; errCode = "OVERFLOW"; goto errorMsg; } - if (ch == 'A') { - char *p = TclGetString(segment) + 1; - *p = 'x'; - p = strchr(p, 'P'); - if (p) *p = 'p'; - } break; } default: if (interp != NULL) { Tcl_SetObjResult(interp, @@ -2359,11 +2532,11 @@ Tcl_AppendToObj(appendObj, (gotZero ? "0" : " "), 1); numChars++; } } - (void)TclGetStringFromObj(segment, &segmentNumBytes); + TclGetStringFromObj(segment, &segmentNumBytes); if (segmentNumBytes > limit) { if (allocSegment) { Tcl_DecrRefCount(segment); } msg = overflow; @@ -2430,12 +2603,13 @@ const char *format, int objc, Tcl_Obj *const objv[]) { int result; - Tcl_Obj *objPtr = Tcl_NewObj(); + Tcl_Obj *objPtr; + TclNewObj(objPtr); result = Tcl_AppendFormatToObj(interp, objPtr, format, objc, objv); if (result != TCL_OK) { Tcl_DecrRefCount(objPtr); return NULL; } @@ -2459,13 +2633,14 @@ Tcl_Obj *objPtr, const char *format, va_list argList) { int code, objc; - Tcl_Obj **objv, *list = Tcl_NewObj(); + Tcl_Obj **objv, *list; const char *p; + TclNewObj(list); p = format; Tcl_IncrRefCount(list); while (*p != '\0') { int size = 0, seekingConversion = 1, gotPrecision = 0; int lastNum = -1; @@ -2501,12 +2676,12 @@ * Within that buffer, we trim both ends if needed so that we * copy only whole characters, and avoid copying any partial * multi-byte characters. */ - q = Tcl_UtfPrev(end, bytes); - if (!Tcl_UtfCharComplete(q, (end - q))) { + q = TclUtfPrev(end, bytes); + if (!Tcl_UtfCharComplete(q, (int)(end - q))) { end = q; } q = bytes + TCL_UTF_MAX; while ((bytes < end) && (bytes < q) @@ -2513,109 +2688,68 @@ && ((*bytes & 0xC0) == 0x80)) { bytes++; } Tcl_ListObjAppendElement(NULL, list, - Tcl_NewStringObj(bytes , (end - bytes))); + Tcl_NewStringObj(bytes , (int)(end - bytes))); break; } case 'c': case 'i': case 'u': case 'd': case 'o': - case 'p': case 'x': case 'X': seekingConversion = 0; switch (size) { case -1: case 0: - Tcl_ListObjAppendElement(NULL, list, Tcl_NewWideIntObj( - va_arg(argList, int))); + Tcl_ListObjAppendElement(NULL, list, Tcl_NewLongObj( + (long) va_arg(argList, int))); break; case 1: - Tcl_ListObjAppendElement(NULL, list, Tcl_NewWideIntObj( + Tcl_ListObjAppendElement(NULL, list, Tcl_NewLongObj( va_arg(argList, long))); break; - case 2: - Tcl_ListObjAppendElement(NULL, list, Tcl_NewWideIntObj( - va_arg(argList, Tcl_WideInt))); - break; - case 3: - Tcl_ListObjAppendElement(NULL, list, Tcl_NewBignumObj( - va_arg(argList, mp_int *))); - break; } break; - case 'a': - case 'A': case 'e': case 'E': case 'f': case 'g': case 'G': - if (size > 0) { Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj( - (double)va_arg(argList, long double))); - } else { - Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj( - va_arg(argList, double))); - } + va_arg(argList, double))); seekingConversion = 0; break; case '*': - lastNum = va_arg(argList, int); - Tcl_ListObjAppendElement(NULL, list, Tcl_NewWideIntObj(lastNum)); + lastNum = (int) va_arg(argList, int); + Tcl_ListObjAppendElement(NULL, list, Tcl_NewIntObj(lastNum)); p++; break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': { char *end; - lastNum = strtoul(p, &end, 10); + lastNum = (int) strtoul(p, &end, 10); p = end; break; } case '.': gotPrecision = 1; p++; break; + /* TODO: support for wide (and bignum?) arguments */ case 'l': - ++size; - p++; - break; - case 't': - case 'z': - if (sizeof(size_t) == sizeof(Tcl_WideInt)) { - size = 2; - } - p++; - break; - case 'j': - case 'q': - size = 2; - p++; - break; - case 'I': - if (p[1]=='6' && p[2]=='4') { - p += 2; - size = 2; - } else if (p[1]=='3' && p[2]=='2') { - p += 2; - } else if (sizeof(size_t) == sizeof(Tcl_WideInt)) { - size = 2; - } - p++; - break; - case 'L': - size = 3; + size = 1; p++; break; case 'h': size = -1; + /* FALLTHRU */ default: p++; } } while (seekingConversion); } @@ -2622,11 +2756,11 @@ TclListObjGetElements(NULL, list, &objc, &objv); code = Tcl_AppendFormatToObj(NULL, objPtr, format, objc, objv); if (code != TCL_OK) { Tcl_AppendPrintfToObj(objPtr, "Unable to format \"%s\" with supplied arguments: %s", - format, TclGetString(list)); + format, Tcl_GetString(list)); } Tcl_DecrRefCount(list); } /* @@ -2674,12 +2808,13 @@ Tcl_ObjPrintf( const char *format, ...) { va_list argList; - Tcl_Obj *objPtr = Tcl_NewObj(); + Tcl_Obj *objPtr; + TclNewObj(objPtr); va_start(argList, format); AppendPrintfToObjVA(objPtr, format, argList); va_end(argList); return objPtr; } @@ -2702,924 +2837,33 @@ */ char * TclGetStringStorage( Tcl_Obj *objPtr, - size_t *sizePtr) + unsigned int *sizePtr) { String *stringPtr; - if (!TclHasIntRep(objPtr, &tclStringType) || objPtr->bytes == NULL) { - return TclGetStringFromObj(objPtr, sizePtr); + if (objPtr->typePtr != &tclStringType || objPtr->bytes == NULL) { + return TclGetStringFromObj(objPtr, (int *)sizePtr); } stringPtr = GET_STRING(objPtr); *sizePtr = stringPtr->allocated; return objPtr->bytes; } - -/* - *--------------------------------------------------------------------------- - * - * TclStringRepeat -- - * - * Performs the [string repeat] function. - * - * Results: - * A (Tcl_Obj *) pointing to the result value, or NULL in case of an - * error. - * - * Side effects: - * On error, when interp is not NULL, error information is left in it. - * - *--------------------------------------------------------------------------- - */ - -Tcl_Obj * -TclStringRepeat( - Tcl_Interp *interp, - Tcl_Obj *objPtr, - size_t count, - int flags) -{ - Tcl_Obj *objResultPtr; - int inPlace = flags & TCL_STRING_IN_PLACE; - size_t length = 0, unichar = 0, done = 1; - int binary = TclIsPureByteArray(objPtr); - - /* assert (count >= 2) */ - - /* - * Analyze to determine what representation result should be. - * GOALS: Avoid shimmering & string rep generation. - * Produce pure bytearray when possible. - * Error on overflow. - */ - - if (!binary) { - if (TclHasIntRep(objPtr, &tclStringType)) { - String *stringPtr = GET_STRING(objPtr); - if (stringPtr->hasUnicode) { - unichar = 1; - } - } - } - - if (binary) { - /* Result will be pure byte array. Pre-size it */ - (void)TclGetByteArrayFromObj(objPtr, &length); - } else if (unichar) { - /* Result will be pure Tcl_UniChar array. Pre-size it. */ - (void)TclGetUnicodeFromObj(objPtr, &length); - } else { - /* Result will be concat of string reps. Pre-size it. */ - (void)TclGetStringFromObj(objPtr, &length); - } - - if (length == 0) { - /* Any repeats of empty is empty. */ - return objPtr; - } - - if (count > INT_MAX/length) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "max size for a Tcl value (%d bytes) exceeded", INT_MAX)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - } - return NULL; - } - - if (binary) { - /* Efficiently produce a pure byte array result */ - objResultPtr = (!inPlace || Tcl_IsShared(objPtr)) ? - Tcl_DuplicateObj(objPtr) : objPtr; - - Tcl_SetByteArrayLength(objResultPtr, count*length); /* PANIC? */ - Tcl_SetByteArrayLength(objResultPtr, length); - while (count - done > done) { - Tcl_AppendObjToObj(objResultPtr, objResultPtr); - done *= 2; - } - TclAppendBytesToByteArray(objResultPtr, - Tcl_GetByteArrayFromObj(objResultPtr, NULL), - (count - done) * length); - } else if (unichar) { - /* - * Efficiently produce a pure Tcl_UniChar array result. - */ - - if (!inPlace || Tcl_IsShared(objPtr)) { - objResultPtr = Tcl_NewUnicodeObj(Tcl_GetUnicode(objPtr), length); - } else { - TclInvalidateStringRep(objPtr); - objResultPtr = objPtr; - } - - if (0 == Tcl_AttemptSetObjLength(objResultPtr, count*length)) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "string size overflow: unable to alloc %" - TCL_Z_MODIFIER "u bytes", - STRING_SIZE(count*length))); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - } - return NULL; - } - Tcl_SetObjLength(objResultPtr, length); - while (count - done > done) { - Tcl_AppendObjToObj(objResultPtr, objResultPtr); - done *= 2; - } - Tcl_AppendUnicodeToObj(objResultPtr, Tcl_GetUnicode(objResultPtr), - (count - done) * length); - } else { - /* - * Efficiently concatenate string reps. - */ - - if (!inPlace || Tcl_IsShared(objPtr)) { - objResultPtr = Tcl_NewStringObj(TclGetString(objPtr), length); - } else { - TclFreeIntRep(objPtr); - objResultPtr = objPtr; - } - if (0 == Tcl_AttemptSetObjLength(objResultPtr, count*length)) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "string size overflow: unable to alloc %" TCL_Z_MODIFIER "u bytes", - count*length)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - } - return NULL; - } - Tcl_SetObjLength(objResultPtr, length); - while (count - done > done) { - Tcl_AppendObjToObj(objResultPtr, objResultPtr); - done *= 2; - } - Tcl_AppendToObj(objResultPtr, TclGetString(objResultPtr), - (count - done) * length); - } - return objResultPtr; -} - -/* - *--------------------------------------------------------------------------- - * - * TclStringCat -- - * - * Performs the [string cat] function. - * - * Results: - * A (Tcl_Obj *) pointing to the result value, or NULL in case of an - * error. - * - * Side effects: - * On error, when interp is not NULL, error information is left in it. - * - *--------------------------------------------------------------------------- - */ - -Tcl_Obj * -TclStringCat( - Tcl_Interp *interp, - int objc, - Tcl_Obj * const objv[], - int flags) -{ - Tcl_Obj *objResultPtr, * const *ov; - int oc, binary = 1; - size_t length = 0; - int allowUniChar = 1, requestUniChar = 0; - int first = objc - 1; /* Index of first value possibly not empty */ - int last = 0; /* Index of last value possibly not empty */ - int inPlace = flags & TCL_STRING_IN_PLACE; - - /* assert ( objc >= 0 ) */ - - if (objc <= 1) { - /* Only one or no objects; return first or empty */ - return objc ? objv[0] : Tcl_NewObj(); - } - - /* assert ( objc >= 2 ) */ - - /* - * Analyze to determine what representation result should be. - * GOALS: Avoid shimmering & string rep generation. - * Produce pure bytearray when possible. - * Error on overflow. - */ - - ov = objv, oc = objc; - do { - Tcl_Obj *objPtr = *ov++; - - if (TclIsPureByteArray(objPtr)) { - allowUniChar = 0; - } else if (objPtr->bytes) { - /* Value has a string rep. */ - if (objPtr->length) { - /* - * Non-empty string rep. Not a pure bytearray, so we won't - * create a pure bytearray. - */ - - binary = 0; - if ((objPtr->typePtr) && (objPtr->typePtr != &tclStringType)) { - /* Prevent shimmer of non-string types. */ - allowUniChar = 0; - } - } - } else { - /* assert (objPtr->typePtr != NULL) -- stork! */ - binary = 0; - if (TclHasIntRep(objPtr, &tclStringType)) { - /* Have a pure Unicode value; ask to preserve it */ - requestUniChar = 1; - } else { - /* Have another type; prevent shimmer */ - allowUniChar = 0; - } - } - } while (--oc && (binary || allowUniChar)); - - if (binary) { - /* - * Result will be pure byte array. Pre-size it - */ - - size_t numBytes = 0; - ov = objv; - oc = objc; - do { - Tcl_Obj *objPtr = *ov++; - - /* - * Every argument is either a bytearray with a ("pure") - * value we know we can safely use, or it is an empty string. - * We don't need to count bytes for the empty strings. - */ - - if (TclIsPureByteArray(objPtr)) { - (void)TclGetByteArrayFromObj(objPtr, &numBytes); /* PANIC? */ - - if (numBytes) { - last = objc - oc; - if (length == 0) { - first = last; - } - length += numBytes; - } - } - } while (--oc); - } else if (allowUniChar && requestUniChar) { - /* - * Result will be pure Tcl_UniChar array. Pre-size it. - */ - - ov = objv; - oc = objc; - do { - Tcl_Obj *objPtr = *ov++; - - if ((objPtr->bytes == NULL) || (objPtr->length)) { - size_t numChars; - - (void)TclGetUnicodeFromObj(objPtr, &numChars); /* PANIC? */ - if (numChars) { - last = objc - oc; - if (length == 0) { - first = last; - } - length += numChars; - } - } - } while (--oc); - } else { - /* Result will be concat of string reps. Pre-size it. */ - ov = objv; oc = objc; - do { - Tcl_Obj *pendingPtr = NULL; - - /* - * Loop until a possibly non-empty value is reached. - * Keep string rep generation pending when possible. - */ - - do { - /* assert ( pendingPtr == NULL ) */ - /* assert ( length == 0 ) */ - - Tcl_Obj *objPtr = *ov++; - - if (objPtr->bytes == NULL) { - /* No string rep; Take the chance we can avoid making it */ - pendingPtr = objPtr; - } else { - (void)TclGetStringFromObj(objPtr, &length); /* PANIC? */ - } - } while (--oc && (length == 0) && (pendingPtr == NULL)); - - /* - * Either we found a possibly non-empty value, and we remember - * this index as the first and last such value so far seen, - * or (oc == 0) and all values are known empty, - * so first = last = objc - 1 signals the right quick return. - */ - - first = last = objc - oc - 1; - - if (oc && (length == 0)) { - size_t numBytes; - - /* assert ( pendingPtr != NULL ) */ - - /* - * There's a pending value followed by more values. Loop over - * remaining values generating strings until a non-empty value - * is found, or the pending value gets its string generated. - */ - - do { - Tcl_Obj *objPtr = *ov++; - (void)TclGetStringFromObj(objPtr, &numBytes); /* PANIC? */ - } while (--oc && numBytes == 0 && pendingPtr->bytes == NULL); - - if (numBytes) { - last = objc -oc -1; - } - if (oc || numBytes) { - (void)TclGetStringFromObj(pendingPtr, &length); - } - if (length == 0) { - if (numBytes) { - first = last; - } - } else if (numBytes + length > (size_t)INT_MAX) { - goto overflow; - } - length += numBytes; - } - } while (oc && (length == 0)); - - while (oc) { - size_t numBytes; - Tcl_Obj *objPtr = *ov++; - - /* assert ( length > 0 && pendingPtr == NULL ) */ - - TclGetString(objPtr); /* PANIC? */ - numBytes = objPtr->length; - if (numBytes) { - last = objc - oc; - if (numBytes + length > (size_t)INT_MAX) { - goto overflow; - } - length += numBytes; - } - --oc; - } - } - - if (last <= first /*|| length == 0 */) { - /* 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); - - if (binary) { - /* Efficiently produce a pure byte array result */ - unsigned char *dst; - - /* - * Broken interface! Byte array value routines offer no way to handle - * failure to allocate enough space. Following stanza may panic. - */ - - if (inPlace && !Tcl_IsShared(*objv)) { - size_t start = 0; - - objResultPtr = *objv++; objc--; - (void)TclGetByteArrayFromObj(objResultPtr, &start); - dst = Tcl_SetByteArrayLength(objResultPtr, length) + start; - } else { - objResultPtr = Tcl_NewByteArrayObj(NULL, length); - dst = Tcl_SetByteArrayLength(objResultPtr, length); - } - while (objc--) { - Tcl_Obj *objPtr = *objv++; - - /* - * Every argument is either a bytearray with a ("pure") - * value we know we can safely use, or it is an empty string. - * We don't need to copy bytes from the empty strings. - */ - - if (TclIsPureByteArray(objPtr)) { - size_t more = 0; - unsigned char *src = TclGetByteArrayFromObj(objPtr, &more); - memcpy(dst, src, more); - dst += more; - } - } - } else if (allowUniChar && requestUniChar) { - /* Efficiently produce a pure Tcl_UniChar array result */ - Tcl_UniChar *dst; - - if (inPlace && !Tcl_IsShared(*objv)) { - size_t start; - - objResultPtr = *objv++; objc--; - - /* Ugly interface! Force resize of the unicode array. */ - (void)TclGetUnicodeFromObj(objResultPtr, &start); - Tcl_InvalidateStringRep(objResultPtr); - if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "concatenation failed: unable to alloc %" - TCL_Z_MODIFIER "u bytes", - STRING_SIZE(length))); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - } - return NULL; - } - dst = Tcl_GetUnicode(objResultPtr) + start; - } else { - Tcl_UniChar ch = 0; - - /* Ugly interface! No scheme to init array size. */ - objResultPtr = Tcl_NewUnicodeObj(&ch, 0); /* PANIC? */ - if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { - Tcl_DecrRefCount(objResultPtr); - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "concatenation failed: unable to alloc %" - TCL_Z_MODIFIER "u bytes", - STRING_SIZE(length))); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - } - return NULL; - } - dst = Tcl_GetUnicode(objResultPtr); - } - while (objc--) { - Tcl_Obj *objPtr = *objv++; - - if ((objPtr->bytes == NULL) || (objPtr->length)) { - size_t more; - Tcl_UniChar *src = TclGetUnicodeFromObj(objPtr, &more); - memcpy(dst, src, more * sizeof(Tcl_UniChar)); - dst += more; - } - } - } else { - /* Efficiently concatenate string reps */ - char *dst; - - if (inPlace && !Tcl_IsShared(*objv)) { - size_t start; - - objResultPtr = *objv++; objc--; - - (void)TclGetStringFromObj(objResultPtr, &start); - if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "concatenation failed: unable to alloc %" TCL_Z_MODIFIER "u bytes", - length)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - } - return NULL; - } - dst = TclGetString(objResultPtr) + start; - - /* assert ( length > start ) */ - TclFreeIntRep(objResultPtr); - } else { - objResultPtr = Tcl_NewObj(); /* PANIC? */ - if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { - Tcl_DecrRefCount(objResultPtr); - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "concatenation failed: unable to alloc %" TCL_Z_MODIFIER "u bytes", - length)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - } - return NULL; - } - dst = TclGetString(objResultPtr); - } - while (objc--) { - Tcl_Obj *objPtr = *objv++; - - if ((objPtr->bytes == NULL) || (objPtr->length)) { - size_t more; - char *src = TclGetStringFromObj(objPtr, &more); - - memcpy(dst, src, more); - dst += more; - } - } - /* Must NUL-terminate! */ - *dst = '\0'; - } - return objResultPtr; - - overflow: - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "max size for a Tcl value (%d bytes) exceeded", INT_MAX)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - } - return NULL; -} - -/* - *--------------------------------------------------------------------------- - * - * TclStringCmp -- - * Compare two Tcl_Obj values as strings. - * - * Results: - * Like memcmp, return -1, 0, or 1. - * - * Side effects: - * String representations may be generated. Internal representation may - * be changed. - * - *--------------------------------------------------------------------------- - */ - -int -TclStringCmp( - Tcl_Obj *value1Ptr, - Tcl_Obj *value2Ptr, - int checkEq, /* comparison is only for equality */ - int nocase, /* comparison is not case sensitive */ - size_t reqlength) /* requested length */ -{ - char *s1, *s2; - int empty, match; - size_t length, s1len = 0, s2len = 0; - memCmpFn_t memCmpFn; - - if ((reqlength == 0) || (value1Ptr == value2Ptr)) { - /* - * Always match at 0 chars of if it is the same obj. - */ - match = 0; - } else { - if (!nocase && TclIsPureByteArray(value1Ptr) - && TclIsPureByteArray(value2Ptr)) { - /* - * Use binary versions of comparisons since that won't cause undue - * type conversions and it is much faster. Only do this if we're - * case-sensitive (which is all that really makes sense with byte - * arrays anyway, and we have no memcasecmp() for some reason... :^) - */ - - s1 = (char *) TclGetByteArrayFromObj(value1Ptr, &s1len); - s2 = (char *) TclGetByteArrayFromObj(value2Ptr, &s2len); - memCmpFn = memcmp; - } else if (TclHasIntRep(value1Ptr, &tclStringType) - && TclHasIntRep(value2Ptr, &tclStringType)) { - /* - * Do a unicode-specific comparison if both of the args are of - * String type. If the char length == byte length, we can do a - * memcmp. In benchmark testing this proved the most efficient - * check between the unicode and string comparison operations. - */ - - if (nocase) { - s1 = (char *) TclGetUnicodeFromObj(value1Ptr, &s1len); - s2 = (char *) TclGetUnicodeFromObj(value2Ptr, &s2len); - memCmpFn = (memCmpFn_t)Tcl_UniCharNcasecmp; - } else { - s1len = Tcl_GetCharLength(value1Ptr); - s2len = Tcl_GetCharLength(value2Ptr); - if ((s1len == value1Ptr->length) - && (value1Ptr->bytes != NULL) - && (s2len == value2Ptr->length) - && (value2Ptr->bytes != NULL)) { - s1 = value1Ptr->bytes; - s2 = value2Ptr->bytes; - memCmpFn = memcmp; - } else { - s1 = (char *) Tcl_GetUnicode(value1Ptr); - s2 = (char *) Tcl_GetUnicode(value2Ptr); - if ( -#ifdef WORDS_BIGENDIAN - 1 -#else - checkEq -#endif - ) { - memCmpFn = memcmp; - s1len *= sizeof(Tcl_UniChar); - s2len *= sizeof(Tcl_UniChar); - } else { - memCmpFn = (memCmpFn_t) Tcl_UniCharNcmp; - } - } - } - } else { - empty = TclCheckEmptyString(value1Ptr); - if (empty > 0) { - switch (TclCheckEmptyString(value2Ptr)) { - case -1: - s1 = 0; - s1len = 0; - s2 = TclGetStringFromObj(value2Ptr, &s2len); - break; - case 0: - match = -1; - goto matchdone; - case 1: - default: /* avoid warn: `s2` may be used uninitialized */ - match = 0; - goto matchdone; - } - } else if (TclCheckEmptyString(value2Ptr) > 0) { - switch (empty) { - case -1: - s2 = 0; - s2len = 0; - s1 = TclGetStringFromObj(value1Ptr, &s1len); - break; - case 0: - match = 1; - goto matchdone; - case 1: - default: /* avoid warn: `s1` may be used uninitialized */ - match = 0; - goto matchdone; - } - } else { - s1 = TclGetStringFromObj(value1Ptr, &s1len); - s2 = TclGetStringFromObj(value2Ptr, &s2len); - } - if (!nocase && checkEq) { - /* - * When we have equal-length we can check only for - * (in)equality. We can use memcmp in all (n)eq cases because - * we don't need to worry about lexical LE/BE variance. - */ - - memCmpFn = memcmp; - } else { - /* - * As a catch-all we will work with UTF-8. We cannot use - * memcmp() as that is unsafe with any string containing NUL - * (\xC0\x80 in Tcl's utf rep). We can use the more efficient - * TclpUtfNcmp2 if we are case-sensitive and no specific - * length was requested. - */ - - if ((reqlength == TCL_AUTO_LENGTH) && !nocase) { - memCmpFn = (memCmpFn_t) TclpUtfNcmp2; - } else { - s1len = Tcl_NumUtfChars(s1, s1len); - s2len = Tcl_NumUtfChars(s2, s2len); - memCmpFn = (memCmpFn_t) - (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp); - } - } - } - - length = (s1len < s2len) ? s1len : s2len; - if (reqlength == TCL_AUTO_LENGTH) { - /* - * The requested length is negative, so we ignore it by setting it - * to length + 1 so we correct the match var. - */ - - reqlength = length + 1; - } else if (reqlength > 0 && reqlength < length) { - length = reqlength; - } - - if (checkEq && (s1len != s2len)) { - match = 1; /* This will be reversed below. */ - } else { - /* - * The comparison function should compare up to the minimum byte - * length only. - */ - - match = memCmpFn(s1, s2, length); - } - if ((match == 0) && (reqlength > length)) { - match = s1len - s2len; - } - match = (match > 0) ? 1 : (match < 0) ? -1 : 0; - } - matchdone: - return match; -} - -/* - *--------------------------------------------------------------------------- - * - * TclStringFirst -- - * - * Implements the [string first] operation. - * - * Results: - * If needle is found as a substring of haystack, the index of the - * first instance of such a find is returned. If needle is not present - * as a substring of haystack, TCL_IO_FAILURE is returned. - * - * Side effects: - * needle and haystack may have their Tcl_ObjType changed. - * - *--------------------------------------------------------------------------- - */ - -size_t -TclStringFirst( - Tcl_Obj *needle, - Tcl_Obj *haystack, - size_t start) -{ - size_t lh = 0, ln = Tcl_GetCharLength(needle); - - if (start == TCL_AUTO_LENGTH) { - start = 0; - } - if (ln == 0) { - /* We don't find empty substrings. Bizarre! - * Whenever this routine is turned into a proper substring - * finder, change to `return start` after limits imposed. */ - return TCL_IO_FAILURE; - } - - if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) { - unsigned char *end, *try, *bh; - unsigned char *bn = TclGetByteArrayFromObj(needle, &ln); - - /* Find bytes in bytes */ - bh = TclGetByteArrayFromObj(haystack, &lh); - if ((lh < ln) || (start > lh - ln)) { - /* Don't start the loop if there cannot be a valid answer */ - return TCL_IO_FAILURE; - } - end = bh + lh; - - try = bh + start; - while (try + ln <= end) { - /* - * Look for the leading byte of the needle in the haystack - * starting at try and stopping when there's not enough room - * for the needle left. - */ - try = memchr(try, bn[0], (end + 1 - ln) - try); - if (try == NULL) { - /* Leading byte not found -> needle cannot be found. */ - return TCL_IO_FAILURE; - } - /* Leading byte found, check rest of needle. */ - if (0 == memcmp(try+1, bn+1, ln-1)) { - /* Checks! Return the successful index. */ - return (try - bh); - } - /* Rest of needle match failed; Iterate to continue search. */ - try++; - } - return TCL_IO_FAILURE; - } - - /* - * TODO: It might be nice to support some cases where it is not - * necessary to shimmer to &tclStringType to compute the result, - * and instead operate just on the objPtr->bytes values directly. - * However, we also do not want the answer to change based on the - * code pathway, or if it does we want that to be for some values - * we explicitly decline to support. Getting there will involve - * locking down in practice more firmly just what encodings produce - * what supported results for the objPtr->bytes values. For now, - * do only the well-defined Tcl_UniChar array search. - */ - - { - Tcl_UniChar *try, *end, *uh; - Tcl_UniChar *un = TclGetUnicodeFromObj(needle, &ln); - - uh = TclGetUnicodeFromObj(haystack, &lh); - if ((lh < ln) || (start > lh - ln)) { - /* Don't start the loop if there cannot be a valid answer */ - return TCL_IO_FAILURE; - } - end = uh + lh; - - for (try = uh + start; try + ln <= end; try++) { - if ((*try == *un) && (0 == - memcmp(try + 1, un + 1, (ln-1) * sizeof(Tcl_UniChar)))) { - return (try - uh); - } - } - return TCL_IO_FAILURE; - } -} - -/* - *--------------------------------------------------------------------------- - * - * TclStringLast -- - * - * Implements the [string last] operation. - * - * Results: - * If needle is found as a substring of haystack, the index of the - * last instance of such a find is returned. If needle is not present - * as a substring of haystack, TCL_IO_FAILURE is returned. - * - * Side effects: - * needle and haystack may have their Tcl_ObjType changed. - * - *--------------------------------------------------------------------------- - */ - -size_t -TclStringLast( - Tcl_Obj *needle, - Tcl_Obj *haystack, - size_t last) -{ - size_t lh = 0, ln = Tcl_GetCharLength(needle); - - if (ln == 0) { - /* - * We don't find empty substrings. Bizarre! - * - * TODO: When we one day make this a true substring - * finder, change this to "return last", after limitation. - */ - return TCL_IO_FAILURE; - } - - if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) { - unsigned char *try, *bh = TclGetByteArrayFromObj(haystack, &lh); - unsigned char *bn = TclGetByteArrayFromObj(needle, &ln); - - if (last + 1 >= lh + 1) { - last = lh - 1; - } - if (last + 1 < ln) { - /* Don't start the loop if there cannot be a valid answer */ - return TCL_IO_FAILURE; - } - try = bh + last + 1 - ln; - - while (try >= bh) { - if ((*try == bn[0]) - && (0 == memcmp(try+1, bn+1, ln-1))) { - return (try - bh); - } - try--; - } - return TCL_IO_FAILURE; - } - - { - Tcl_UniChar *try, *uh = TclGetUnicodeFromObj(haystack, &lh); - Tcl_UniChar *un = TclGetUnicodeFromObj(needle, &ln); - - if (last + 1 >= lh + 1) { - last = lh - 1; - } - if (last + 1 < ln) { - /* Don't start the loop if there cannot be a valid answer */ - return TCL_IO_FAILURE; - } - try = uh + last + 1 - ln; - while (try >= uh) { - if ((*try == un[0]) - && (0 == memcmp(try+1, un+1, (ln-1)*sizeof(Tcl_UniChar)))) { - return (try - uh); - } - try--; - } - return TCL_IO_FAILURE; - } -} - /* *--------------------------------------------------------------------------- * * TclStringReverse -- * * Implements the [string reverse] operation. * * Results: - * A Tcl value which is the [string reverse] of the argument supplied. - * When sharing rules permit and the caller requests, the returned value - * might be the argument with modifications done in place. + * An unshared Tcl value which is the [string reverse] of the argument + * supplied. When sharing rules permit, the returned value might be the + * argument with modifications done in place. * * Side effects: * May allocate a new Tcl_Obj. * *--------------------------------------------------------------------------- @@ -3627,11 +2871,11 @@ static void ReverseBytes( unsigned char *to, /* Copy bytes into here... */ unsigned char *from, /* ...from here... */ - size_t count) /* Until this many are copied, */ + int count) /* Until this many are copied, */ /* reversing as you go. */ { unsigned char *src = from + count; if (to == from) { @@ -3649,22 +2893,20 @@ } } Tcl_Obj * TclStringReverse( - Tcl_Obj *objPtr, - int flags) + Tcl_Obj *objPtr) { String *stringPtr; Tcl_UniChar ch = 0; - int inPlace = flags & TCL_STRING_IN_PLACE; if (TclIsPureByteArray(objPtr)) { - size_t numBytes = 0; - unsigned char *from = TclGetByteArrayFromObj(objPtr, &numBytes); + int numBytes; + unsigned char *from = Tcl_GetByteArrayFromObj(objPtr, &numBytes); - if (!inPlace || Tcl_IsShared(objPtr)) { + if (Tcl_IsShared(objPtr)) { objPtr = Tcl_NewByteArrayObj(NULL, numBytes); } ReverseBytes(Tcl_GetByteArrayFromObj(objPtr, NULL), from, numBytes); return objPtr; } @@ -3674,11 +2916,11 @@ if (stringPtr->hasUnicode) { Tcl_UniChar *from = Tcl_GetUnicode(objPtr); Tcl_UniChar *src = from + stringPtr->numChars; - if (!inPlace || Tcl_IsShared(objPtr)) { + if (Tcl_IsShared(objPtr)) { Tcl_UniChar *to; /* * Create a non-empty, pure unicode value, so we can coax * Tcl_SetObjLength into growing the unicode rep buffer. @@ -3702,41 +2944,41 @@ } } } if (objPtr->bytes) { - size_t numChars = stringPtr->numChars; - size_t numBytes = objPtr->length; + int numChars = stringPtr->numChars; + int numBytes = objPtr->length; char *to, *from = objPtr->bytes; - if (!inPlace || Tcl_IsShared(objPtr)) { - objPtr = Tcl_NewObj(); + if (Tcl_IsShared(objPtr)) { + TclNewObj(objPtr); Tcl_SetObjLength(objPtr, numBytes); } to = objPtr->bytes; - if ((numChars == TCL_AUTO_LENGTH) || (numChars < numBytes)) { + if (numChars < numBytes) { /* * Either numChars == -1 and we don't know how many chars are * represented by objPtr->bytes and we need Pass 1 just in case, * or numChars >= 0 and we know we have fewer chars than bytes, so * we know there's a multibyte character needing Pass 1. * * Pass 1. Reverse the bytes of each multi-byte character. */ - size_t charCount = 0; - size_t bytesLeft = numBytes; + int charCount = 0; + int bytesLeft = numBytes; while (bytesLeft) { /* * NOTE: We know that the from buffer is NUL-terminated. It's * part of the contract for objPtr->bytes values. Thus, we can * skip calling Tcl_UtfCharComplete() here. */ - size_t bytesInChar = TclUtfToUniChar(from, &ch); + int bytesInChar = TclUtfToUniChar(from, &ch); ReverseBytes((unsigned char *)to, (unsigned char *)from, bytesInChar); to += bytesInChar; from += bytesInChar; @@ -3751,151 +2993,10 @@ ReverseBytes((unsigned char *)to, (unsigned char *)from, numBytes); } return objPtr; } - -/* - *--------------------------------------------------------------------------- - * - * TclStringReplace -- - * - * Implements the inner engine of the [string replace] and - * [string insert] commands. - * - * The result is a concatenation of a prefix from objPtr, characters - * 0 through first-1, the insertPtr string value, and a suffix from - * objPtr, characters from first + count to the end. The effect is as if - * the inner substring of characters first through first+count-1 are - * removed and replaced with insertPtr. If insertPtr is NULL, it is - * treated as an empty string. When passed the flag TCL_STRING_IN_PLACE, - * this routine will try to do the work within objPtr, so long as no - * sharing forbids it. Without that request, or as needed, a new Tcl - * value will be allocated to be the result. - * - * Results: - * A Tcl value that is the result of the substring replacement. May - * return NULL in case of an error. When NULL is returned and interp is - * non-NULL, error information is left in interp - * - *--------------------------------------------------------------------------- - */ - -Tcl_Obj * -TclStringReplace( - Tcl_Interp *interp, /* For error reporting, may be NULL */ - Tcl_Obj *objPtr, /* String to act upon */ - size_t first, /* First index to replace */ - size_t count, /* How many chars to replace */ - Tcl_Obj *insertPtr, /* Replacement string, may be NULL */ - int flags) /* TCL_STRING_IN_PLACE => attempt in-place */ -{ - int inPlace = flags & TCL_STRING_IN_PLACE; - Tcl_Obj *result; - - /* Replace nothing with nothing */ - if ((insertPtr == NULL) && (count == 0)) { - if (inPlace) { - return objPtr; - } else { - return Tcl_DuplicateObj(objPtr); - } - } - - /* - * The caller very likely had to call Tcl_GetCharLength() or similar - * to be able to process index values. This means it is likely that - * objPtr is either a proper "bytearray" or a "string" or else it has - * a known and short string rep. - */ - - if (TclIsPureByteArray(objPtr)) { - size_t numBytes = 0; - unsigned char *bytes = TclGetByteArrayFromObj(objPtr, &numBytes); - - if (insertPtr == NULL) { - /* Replace something with nothing. */ - - assert ( first <= numBytes ) ; - assert ( count <= numBytes ) ; - assert ( first + count <= numBytes ) ; - - result = Tcl_NewByteArrayObj(NULL, numBytes - count);/* PANIC? */ - TclAppendBytesToByteArray(result, bytes, first); - TclAppendBytesToByteArray(result, bytes + first + count, - numBytes - count - first); - return result; - } - - /* Replace everything */ - if ((first == 0) && (count == numBytes)) { - return insertPtr; - } - - if (TclIsPureByteArray(insertPtr)) { - size_t newBytes = 0; - unsigned char *iBytes - = TclGetByteArrayFromObj(insertPtr, &newBytes); - - if (count == newBytes && inPlace && !Tcl_IsShared(objPtr)) { - /* - * Removal count and replacement count are equal. - * Other conditions permit. Do in-place splice. - */ - - memcpy(bytes + first, iBytes, count); - Tcl_InvalidateStringRep(objPtr); - return objPtr; - } - - if ((size_t)newBytes > INT_MAX - (numBytes - count)) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "max size for a Tcl value (%d bytes) exceeded", - INT_MAX)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - } - return NULL; - } - result = Tcl_NewByteArrayObj(NULL, numBytes - count + newBytes); - /* PANIC? */ - Tcl_SetByteArrayLength(result, 0); - TclAppendBytesToByteArray(result, bytes, first); - TclAppendBytesToByteArray(result, iBytes, newBytes); - TclAppendBytesToByteArray(result, bytes + first + count, - numBytes - count - first); - return result; - } - - /* Flow through to try other approaches below */ - } - - /* - * TODO: Figure out how not to generate a Tcl_UniChar array rep - * when it can be determined objPtr->bytes points to a string of - * all single-byte characters so we can index it directly. - */ - - /* The traditional implementation... */ - { - size_t numChars; - Tcl_UniChar *ustring = TclGetUnicodeFromObj(objPtr, &numChars); - - /* TODO: Is there an in-place option worth pursuing here? */ - - result = Tcl_NewUnicodeObj(ustring, first); - if (insertPtr) { - Tcl_AppendObjToObj(result, insertPtr); - } - if (first + count < (size_t)numChars) { - Tcl_AppendUnicodeToObj(result, ustring + first + count, - numChars - first - count); - } - - return result; - } -} /* *--------------------------------------------------------------------------- * * FillUnicodeRep -- @@ -3925,24 +3026,25 @@ static void ExtendUnicodeRepWithString( Tcl_Obj *objPtr, const char *bytes, - size_t numBytes, - size_t numAppendChars) + int numBytes, + int numAppendChars) { String *stringPtr = GET_STRING(objPtr); - size_t needed, numOrigChars = 0; + int needed, numOrigChars = 0; Tcl_UniChar *dst, unichar = 0; if (stringPtr->hasUnicode) { numOrigChars = stringPtr->numChars; } - if (numAppendChars == TCL_AUTO_LENGTH) { + if (numAppendChars == -1) { TclNumUtfChars(numAppendChars, bytes, numBytes); } needed = numOrigChars + numAppendChars; + stringCheckLimits(needed); if (needed > stringPtr->maxChars) { GrowUnicodeBuffer(objPtr, needed); stringPtr = GET_STRING(objPtr); } @@ -3986,11 +3088,12 @@ * currently have an internal rep.*/ { String *srcStringPtr = GET_STRING(srcPtr); String *copyStringPtr = NULL; - if (srcStringPtr->numChars == TCL_AUTO_LENGTH) { +#if COMPAT==0 + if (srcStringPtr->numChars == -1) { /* * The String struct in the source value holds zero useful data. Don't * bother copying it. Don't even bother allocating space in which to * copy it. Just let the copy be untyped. */ @@ -4028,10 +3131,45 @@ * code, so it doesn't contain any extra bytes that might exist in the * source object. */ copyStringPtr->allocated = copyPtr->bytes ? copyPtr->length : 0; +#else /* COMPAT!=0 */ + /* + * If the src obj is a string of 1-byte Utf chars, then copy the string + * rep of the source object and create an "empty" Unicode internal rep for + * the new object. Otherwise, copy Unicode internal rep, and invalidate + * the string rep of the new object. + */ + + if (srcStringPtr->hasUnicode && srcStringPtr->numChars > 0) { + /* + * Copy the full allocation for the Unicode buffer. + */ + + copyStringPtr = stringAlloc(srcStringPtr->maxChars); + copyStringPtr->maxChars = srcStringPtr->maxChars; + memcpy(copyStringPtr->unicode, srcStringPtr->unicode, + srcStringPtr->numChars * sizeof(Tcl_UniChar)); + copyStringPtr->unicode[srcStringPtr->numChars] = 0; + copyStringPtr->allocated = 0; + } else { + copyStringPtr = stringAlloc(0); + copyStringPtr->unicode[0] = 0; + copyStringPtr->maxChars = 0; + + /* + * Tricky point: the string value was copied by generic object + * management code, so it doesn't contain any extra bytes that might + * exist in the source object. + */ + + copyStringPtr->allocated = copyPtr->length; + } + copyStringPtr->numChars = srcStringPtr->numChars; + copyStringPtr->hasUnicode = srcStringPtr->hasUnicode; +#endif /* COMPAT==0 */ SET_STRING(copyPtr, copyStringPtr); copyPtr->typePtr = &tclStringType; } @@ -4055,11 +3193,11 @@ static int SetStringFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr) /* The object to convert. */ { - if (!TclHasIntRep(objPtr, &tclStringType)) { + if (objPtr->typePtr != &tclStringType) { String *stringPtr = stringAlloc(0); /* * Convert whatever we have into an untyped value. Just A String. */ @@ -4115,32 +3253,32 @@ */ stringPtr->allocated = 0; if (stringPtr->numChars == 0) { - TclInitStringRep(objPtr, NULL, 0); + TclInitStringRep(objPtr, tclEmptyStringRep, 0); } else { (void) ExtendStringRepWithUnicode(objPtr, stringPtr->unicode, stringPtr->numChars); } } -static size_t +static int ExtendStringRepWithUnicode( Tcl_Obj *objPtr, const Tcl_UniChar *unicode, - size_t numChars) + int numChars) { /* * Pre-condition: this is the "string" Tcl_ObjType. */ - size_t i, origLength, size = 0; - char *dst; + int i, origLength, size = 0; + char *dst, buf[4] = ""; String *stringPtr = GET_STRING(objPtr); - if (numChars == TCL_AUTO_LENGTH) { + if (numChars < 0) { numChars = UnicodeLength(unicode); } if (numChars == 0) { return 0; @@ -4158,12 +3296,15 @@ if (numChars <= (INT_MAX - size)/TCL_UTF_MAX && stringPtr->allocated >= size + numChars * TCL_UTF_MAX) { goto copyBytes; } - for (i = 0; i < numChars; i++) { - size += TclUtfCount(unicode[i]); + for (i = 0; i < numChars && size >= 0; i++) { + size += Tcl_UniCharToUtf((int) unicode[i], buf); + } + if (size < 0) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } /* * Grow space if needed. */ @@ -4201,11 +3342,11 @@ static void FreeStringInternalRep( Tcl_Obj *objPtr) /* Object with internal rep to free. */ { - Tcl_Free(GET_STRING(objPtr)); + ckfree(GET_STRING(objPtr)); objPtr->typePtr = NULL; } /* * Local Variables: Index: generic/tclStringRep.h ================================================================== --- generic/tclStringRep.h +++ generic/tclStringRep.h @@ -29,14 +29,10 @@ * Copyright (c) 1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ - -#ifndef _TCLSTRINGREP -#define _TCLSTRINGREP - /* * The following structure is the internal rep for a String object. It keeps * track of how much memory has been used and how much has been allocated for * the Unicode and UTF string to enable growing and shrinking of the UTF and @@ -48,47 +44,54 @@ * restricted to the Basic Multilingual Plane (i.e. U+00000 to U+0FFFF). This * can be officially modified by altering the definition of Tcl_UniChar in * tcl.h, but do not do that unless you are sure what you're doing! */ -typedef struct { - size_t numChars; /* The number of chars in the string. -1 means - * this value has not been calculated. Any other +typedef struct String { + int numChars; /* The number of chars in the string. -1 means + * this value has not been calculated. >= 0 * means that there is a valid Unicode rep, or * that the number of UTF bytes == the number * of chars. */ - size_t allocated; /* The amount of space actually allocated for + int allocated; /* The amount of space actually allocated for * the UTF string (minus 1 byte for the * termination char). */ - size_t maxChars; /* Max number of chars that can fit in the + int maxChars; /* Max number of chars that can fit in the * space allocated for the unicode array. */ int hasUnicode; /* Boolean determining whether the string has * a Unicode representation. */ - Tcl_UniChar unicode[1]; /* The array of Unicode chars. The actual size + Tcl_UniChar unicode[TCLFLEXARRAY]; /* The array of Unicode chars. The actual size * of this field depends on the 'maxChars' * field above. */ } String; +#define STRING_MAXCHARS \ + (int)(((size_t)UINT_MAX - 1 - TclOffset(String, unicode))/sizeof(Tcl_UniChar)) #define STRING_SIZE(numChars) \ - (sizeof(String) + ((numChars) * sizeof(Tcl_UniChar))) + (TclOffset(String, unicode) + ((numChars + 1) * sizeof(Tcl_UniChar))) +#define stringCheckLimits(numChars) \ + do { \ + if ((numChars) < 0 || (numChars) > STRING_MAXCHARS) { \ + Tcl_Panic("max length for a Tcl unicode value (%d chars) exceeded", \ + STRING_MAXCHARS); \ + } \ + } while (0) #define stringAttemptAlloc(numChars) \ - (String *) Tcl_AttemptAlloc(STRING_SIZE(numChars)) + (String *) attemptckalloc((unsigned) STRING_SIZE(numChars)) #define stringAlloc(numChars) \ - (String *) Tcl_Alloc(STRING_SIZE(numChars)) + (String *) ckalloc((unsigned) STRING_SIZE(numChars)) #define stringRealloc(ptr, numChars) \ - (String *) Tcl_Realloc((ptr), STRING_SIZE(numChars)) + (String *) ckrealloc((ptr), (unsigned) STRING_SIZE(numChars)) #define stringAttemptRealloc(ptr, numChars) \ - (String *) Tcl_AttemptRealloc((ptr), STRING_SIZE(numChars)) + (String *) attemptckrealloc((ptr), (unsigned) STRING_SIZE(numChars)) #define GET_STRING(objPtr) \ ((String *) (objPtr)->internalRep.twoPtrValue.ptr1) #define SET_STRING(objPtr, stringPtr) \ - ((objPtr)->internalRep.twoPtrValue.ptr2 = NULL), \ ((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (stringPtr)) -#endif /* _TCLSTRINGREP */ /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: generic/tclStringTrim.h ================================================================== --- generic/tclStringTrim.h +++ generic/tclStringTrim.h @@ -26,10 +26,12 @@ MODULE_SCOPE const char tclDefaultTrimSet[]; /* * The whitespace trimming set used when [concat]enating. This is a subset of * the above, and deliberately so. + * + * TODO: Find a reasonable way to guarantee in sync with TclIsSpaceProc() */ #define CONCAT_TRIM_SET " \f\v\r\t\n" #endif /* TCL_STRING_TRIM_H */ Index: generic/tclStubInit.c ================================================================== --- generic/tclStubInit.c +++ generic/tclStubInit.c @@ -8,11 +8,11 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" -#include "tommath.h" +#include "tommath_private.h" #ifdef __CYGWIN__ # include #endif @@ -27,63 +27,179 @@ */ #undef Tcl_Alloc #undef Tcl_Free #undef Tcl_Realloc +#undef Tcl_NewBooleanObj #undef Tcl_NewByteArrayObj #undef Tcl_NewDoubleObj +#undef Tcl_NewIntObj #undef Tcl_NewListObj #undef Tcl_NewLongObj -#undef Tcl_DbNewLongObj #undef Tcl_NewObj #undef Tcl_NewStringObj -#undef Tcl_GetUnicode #undef Tcl_DumpActiveMemory #undef Tcl_ValidateAllMemory -#undef Tcl_SetExitProc -#undef Tcl_SetPanicProc +#undef Tcl_FindHashEntry +#undef Tcl_CreateHashEntry +#undef Tcl_Panic +#undef Tcl_FindExecutable #undef TclpGetPid -#undef TclStaticPackage -#undef Tcl_BackgroundError +#undef TclSockMinimumBuffers +#define TclBackgroundException Tcl_BackgroundException +#undef Tcl_SetIntObj +#undef TclpInetNtoa +#undef TclWinGetServByName +#undef TclWinGetSockOpt +#undef TclWinSetSockOpt +#undef TclBN_mp_tc_and +#undef TclBN_mp_tc_or +#undef TclBN_mp_tc_xor +#define TclBN_mp_tc_and TclBN_mp_and +#define TclBN_mp_tc_or TclBN_mp_or +#define TclBN_mp_tc_xor TclBN_mp_xor #define TclStaticPackage Tcl_StaticPackage - -#ifdef TCL_MEM_DEBUG -# define Tcl_Alloc TclpAlloc -# define Tcl_Free TclpFree -# define Tcl_Realloc TclpRealloc -# undef Tcl_AttemptAlloc -# define Tcl_AttemptAlloc TclpAlloc -# undef Tcl_AttemptRealloc -# define Tcl_AttemptRealloc TclpRealloc +#define TclUnusedStubEntry NULL + +/* See bug 510001: TclSockMinimumBuffers needs plat imp */ +#ifdef _WIN64 +# define TclSockMinimumBuffersOld 0 +#else +#define TclSockMinimumBuffersOld sockMinimumBuffersOld +static int TclSockMinimumBuffersOld(int sock, int size) +{ + return TclSockMinimumBuffers(INT2PTR(sock), size); +} +#endif + +MP_SET_UNSIGNED(mp_set_ull, Tcl_WideUInt) +MP_GET_MAG(mp_get_mag_ull, Tcl_WideUInt) +MP_SET_SIGNED(mp_set_ll, mp_set_ull, Tcl_WideInt, Tcl_WideUInt) + + +mp_err TclBN_mp_set_int(mp_int *a, unsigned long i) +{ + mp_set_ull(a, i); + return MP_OKAY; +} + +mp_err TclBN_mp_init_set_int(mp_int *a, unsigned long i) +{ + mp_err result = mp_init(a); + if (result == MP_OKAY) { + mp_set_ull(a, i); + } + return result; +} + +int TclBN_mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast) +{ + return mp_expt_u32(a, b, c); +} + +#define TclBN_mp_div_ld TclBNMpDivLd +static mp_err TclBN_mp_div_ld(const mp_int *a, Tcl_WideUInt b, mp_int *c, Tcl_WideUInt *d) { + mp_err result; + mp_digit d2; + + if ((b | (mp_digit)-1) != (mp_digit)-1) { + return MP_VAL; + } + result = mp_div_d(a, b, c, (d ? &d2 : NULL)); + if (d) { + *d = d2; + } + return result; +} + +#define TclSetStartupScriptPath setStartupScriptPath +static void TclSetStartupScriptPath(Tcl_Obj *path) +{ + Tcl_SetStartupScript(path, NULL); +} +#define TclGetStartupScriptPath getStartupScriptPath +static Tcl_Obj *TclGetStartupScriptPath(void) +{ + return Tcl_GetStartupScript(NULL); +} +#define TclSetStartupScriptFileName setStartupScriptFileName +static void TclSetStartupScriptFileName( + const char *fileName) +{ + Tcl_SetStartupScript(Tcl_NewStringObj(fileName,-1), NULL); +} +#define TclGetStartupScriptFileName getStartupScriptFileName +static const char *TclGetStartupScriptFileName(void) +{ + Tcl_Obj *path = Tcl_GetStartupScript(NULL); + if (path == NULL) { + return NULL; + } + return Tcl_GetString(path); +} + +#if defined(_WIN32) || defined(__CYGWIN__) +#undef TclWinNToHS +#define TclWinNToHS winNToHS +static unsigned short TclWinNToHS(unsigned short ns) { + return ntohs(ns); +} +#endif + +#define TclpCreateTempFile_ TclpCreateTempFile +#define TclUnixWaitForFile_ TclUnixWaitForFile +#ifndef MAC_OSX_TCL /* On UNIX, fill with other stub entries */ +#define TclMacOSXGetFileAttribute (int (*)(Tcl_Interp *, int, Tcl_Obj *, Tcl_Obj **))(void *)TclpCreateProcess +#define TclMacOSXSetFileAttribute (int (*)(Tcl_Interp *, int, Tcl_Obj *, Tcl_Obj *))(void *)isatty +#define TclMacOSXCopyFileAttributes (int (*)(const char *, const char *, const Tcl_StatBuf *))(void *)TclUnixCopyFile +#define TclMacOSXMatchType (int (*)(Tcl_Interp *, const char *, const char *, Tcl_StatBuf *, Tcl_GlobTypeData *))(void *)TclpMakeFile +#define TclMacOSXNotifierAddRunLoopMode (void (*)(const void *))(void *)TclpOpenFile #endif #ifdef _WIN32 # define TclUnixWaitForFile 0 # define TclUnixCopyFile 0 # define TclUnixOpenTemporaryFile 0 +# define TclpReaddir 0 # define TclpIsAtty 0 #elif defined(__CYGWIN__) -# define TclpIsAtty TclPlatIsAtty -static void -doNothing(void) -{ - /* dummy implementation, no need to do anything */ -} -# define TclWinAddProcess (void (*) (void *, size_t)) doNothing +# define TclpIsAtty isatty +# define TclWinSetInterfaces (void (*) (int))(void *)doNothing +# define TclWinAddProcess (void (*) (void *, unsigned int))(void *)doNothing # define TclWinFlushDirtyChannels doNothing +# define TclWinResetInterfaces doNothing + +#define TclWinGetPlatformId winGetPlatformId +static int +TclWinGetPlatformId() +{ + /* Don't bother to determine the real platform on cygwin, + * because VER_PLATFORM_WIN32_NT is the only supported platform */ + return 2; /* VER_PLATFORM_WIN32_NT */; +} + +#define TclWinSetSockOpt winSetSockOpt +static int +TclWinSetSockOpt(SOCKET s, int level, int optname, + const char *optval, int optlen) +{ + return setsockopt((int) s, level, optname, optval, optlen); +} + +#define TclWinGetSockOpt winGetSockOpt static int -TclpIsAtty(int fd) -{ - return isatty(fd); -} - -void *TclWinGetTclInstance() -{ - void *hInstance = NULL; - GetModuleHandleExW(GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS, - (const char *)&TclpIsAtty, &hInstance); - return hInstance; +TclWinGetSockOpt(SOCKET s, int level, int optname, + char *optval, int *optlen) +{ + return getsockopt((int) s, level, optname, optval, optlen); +} + +#define TclWinGetServByName winGetServByName +static struct servent * +TclWinGetServByName(const char *name, const char *proto) +{ + return getservbyname(name, proto); } #define TclWinNoBackslash winNoBackslash static char * TclWinNoBackslash(char *path) @@ -96,58 +212,186 @@ } } return path; } -size_t +void *TclWinGetTclInstance() +{ + void *hInstance = NULL; + GetModuleHandleExW(GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS, + (const char *)&TclWinNoBackslash, &hInstance); + return hInstance; +} + +int TclpGetPid(Tcl_Pid pid) { - return (size_t) pid; + return (int) (size_t) pid; +} + +static void +doNothing(void) +{ + /* dummy implementation, no need to do anything */ } char * Tcl_WinUtfToTChar( const char *string, - size_t len, + int len, Tcl_DString *dsPtr) { +#if TCL_UTF_MAX > 4 + Tcl_UniChar ch = 0; + wchar_t *w, *wString; + const char *p, *end; + int oldLength; +#endif + Tcl_DStringInit(dsPtr); if (!string) { return NULL; } - return (char *)TclUtfToWCharDString(string, len, dsPtr); +#if TCL_UTF_MAX > 4 + + if (len < 0) { + len = strlen(string); + } + + /* + * Unicode string length in Tcl_UniChars will be <= UTF-8 string length in + * bytes. + */ + + oldLength = Tcl_DStringLength(dsPtr); + + Tcl_DStringSetLength(dsPtr, + oldLength + (int) ((len + 1) * sizeof(wchar_t))); + wString = (wchar_t *) (Tcl_DStringValue(dsPtr) + oldLength); + + w = wString; + p = string; + end = string + len - 4; + while (p < end) { + p += TclUtfToUniChar(p, &ch); + if (ch > 0xFFFF) { + *w++ = (wchar_t) (0xD800 + ((ch -= 0x10000) >> 10)); + *w++ = (wchar_t) (0xDC00 | (ch & 0x3FF)); + } else { + *w++ = ch; + } + } + end += 4; + while (p < end) { + if (Tcl_UtfCharComplete(p, end-p)) { + p += TclUtfToUniChar(p, &ch); + } else { + ch = UCHAR(*p++); + } + if (ch > 0xFFFF) { + *w++ = (wchar_t) (0xD800 + ((ch -= 0x10000) >> 10)); + *w++ = (wchar_t) (0xDC00 | (ch & 0x3FF)); + } else { + *w++ = ch; + } + } + *w = '\0'; + Tcl_DStringSetLength(dsPtr, + oldLength + ((char *) w - (char *) wString)); + + return (char *)wString; +#else + return (char *)Tcl_UtfToUniCharDString(string, len, dsPtr); +#endif } char * Tcl_WinTCharToUtf( const char *string, - size_t len, + int len, Tcl_DString *dsPtr) { +#if TCL_UTF_MAX > 4 + const wchar_t *w, *wEnd; + char *p, *result; + int oldLength, blen = 1; +#endif + Tcl_DStringInit(dsPtr); if (!string) { return NULL; } - if (len == TCL_AUTO_LENGTH) { + if (len < 0) { len = wcslen((wchar_t *)string); } else { len /= 2; } - return TclWCharToUtfDString((const WCHAR *)string, len, dsPtr); +#if TCL_UTF_MAX > 4 + oldLength = Tcl_DStringLength(dsPtr); + Tcl_DStringSetLength(dsPtr, oldLength + (len + 1) * 4); + result = Tcl_DStringValue(dsPtr) + oldLength; + + p = result; + wEnd = (wchar_t *)string + len; + for (w = (wchar_t *)string; w < wEnd; ) { + if (!blen && ((*w & 0xFC00) != 0xDC00)) { + /* Special case for handling high surrogates. */ + p += Tcl_UniCharToUtf(-1, p); + } + blen = Tcl_UniCharToUtf(*w, p); + p += blen; + if ((*w >= 0xD800) && (blen < 3)) { + /* Indication that high surrogate is handled */ + blen = 0; + } + w++; + } + if (!blen) { + /* Special case for handling high surrogates. */ + p += Tcl_UniCharToUtf(-1, p); + } + Tcl_DStringSetLength(dsPtr, oldLength + (p - result)); + + return result; +#else + return Tcl_UniCharToUtfDString((Tcl_UniChar *)string, len, dsPtr); +#endif } #if 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. Tcl 9 must find a better solution, but that cannot be done * without introducing a binary incompatibility. */ +#define Tcl_DbNewLongObj ((Tcl_Obj*(*)(long,const char*,int))(void *)dbNewLongObj) +static Tcl_Obj *dbNewLongObj( + int intValue, + const char *file, + int line +) { +#ifdef TCL_MEM_DEBUG + register Tcl_Obj *objPtr; + + TclDbNewObj(objPtr, file, line); + objPtr->bytes = NULL; + + objPtr->internalRep.longValue = (long) intValue; + objPtr->typePtr = &tclIntType; + return objPtr; +#else + return Tcl_NewIntObj(intValue); +#endif +} +#define Tcl_GetLongFromObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))(void *)Tcl_GetIntFromObj +#define Tcl_NewLongObj (Tcl_Obj*(*)(long))(void *)Tcl_NewIntObj +#define Tcl_SetLongObj (void(*)(Tcl_Obj*,long))(void *)Tcl_SetIntObj static int exprInt(Tcl_Interp *interp, const char *expr, int *ptr){ long longValue; int result = Tcl_ExprLong(interp, expr, &longValue); if (result == TCL_OK) { - if ((longValue >= (long)(INT_MIN)) + if ((longValue >= -(long)(UINT_MAX)) && (longValue <= (long)(UINT_MAX))) { *ptr = (int)longValue; } else { Tcl_SetObjResult(interp, Tcl_NewStringObj( "integer value too large to represent as non-long integer", -1)); @@ -159,11 +403,11 @@ #define Tcl_ExprLong (int(*)(Tcl_Interp*,const char*,long*))exprInt static int exprIntObj(Tcl_Interp *interp, Tcl_Obj*expr, int *ptr){ long longValue; int result = Tcl_ExprLongObj(interp, expr, &longValue); if (result == TCL_OK) { - if ((longValue >= (long)(INT_MIN)) + if ((longValue >= -(long)(UINT_MAX)) && (longValue <= (long)(UINT_MAX))) { *ptr = (int)longValue; } else { Tcl_SetObjResult(interp, Tcl_NewStringObj( "integer value too large to represent as non-long integer", -1)); @@ -171,13 +415,67 @@ } } return result; } #define Tcl_ExprLongObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))exprIntObj -#endif /* TCL_WIDE_INT_IS_LONG */ +static int uniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned int n){ + return Tcl_UniCharNcmp(ucs, uct, (unsigned long)n); +} +#define Tcl_UniCharNcmp (int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long))(void *)uniCharNcmp +static int utfNcmp(const char *s1, const char *s2, unsigned int n){ + return Tcl_UtfNcmp(s1, s2, (unsigned long)n); +} +#define Tcl_UtfNcmp (int(*)(const char*,const char*,unsigned long))(void *)utfNcmp +static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){ + return Tcl_UtfNcasecmp(s1, s2, (unsigned long)n); +} +#define Tcl_UtfNcasecmp (int(*)(const char*,const char*,unsigned long))(void *)utfNcasecmp +static int uniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned int n){ + return Tcl_UniCharNcasecmp(ucs, uct, (unsigned long)n); +} +#define Tcl_UniCharNcasecmp (int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long))(void *)uniCharNcasecmp +static int formatInt(char *buffer, int n){ + return TclFormatInt(buffer, (long)n); +} +#define TclFormatInt (int(*)(char *, long))(void *)formatInt + +#endif + +#else /* UNIX and MAC */ +# define TclpLocaltime_unix TclpLocaltime +# define TclpGmtime_unix TclpGmtime +#endif + +mp_err mp_to_unsigned_bin(const mp_int *a, unsigned char *b) +{ + return mp_to_ubin(a, b, INT_MAX, NULL); +} + +mp_err mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen) +{ + size_t n = mp_ubin_size(a); + if (*outlen < (unsigned long)n) { + return MP_VAL; + } + *outlen = (unsigned long)n; + return mp_to_ubin(a, b, n, NULL); +} + +mp_err mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen) +{ + if (maxlen < 0) { + return MP_VAL; + } + return mp_to_radix(a, str, maxlen, NULL, radix); +} -#endif /* __CYGWIN__ */ +void bn_reverse(unsigned char *s, int len) +{ + if (len > 0) { + s_mp_reverse(s, (size_t)len); + } +} /* * WARNING: The contents of this file is automatically generated by the * tools/genStubs.tcl script. Any modifications to the function declarations * below should be made in the generic/tcl.decls script. @@ -184,19 +482,10 @@ */ MODULE_SCOPE const TclStubs tclStubs; MODULE_SCOPE const TclTomMathStubs tclTomMathStubs; -#ifdef __GNUC__ -/* - * The rest of this file shouldn't warn about deprecated functions; they're - * there because we intend them to be so and know that this file is OK to - * touch those fields. - */ -#pragma GCC diagnostic ignored "-Wdeprecated-declarations" -#endif - /* !BEGIN!: Do not edit below this line. */ static const TclIntStubs tclIntStubs = { TCL_STUB_MAGIC, 0, @@ -206,11 +495,11 @@ TclAllocateFreeObjects, /* 3 */ 0, /* 4 */ TclCleanupChildren, /* 5 */ TclCleanupCommand, /* 6 */ TclCopyAndCollapse, /* 7 */ - 0, /* 8 */ + TclCopyChannelOld, /* 8 */ TclCreatePipeline, /* 9 */ TclCreateProc, /* 10 */ TclDeleteCompiledLocalVars, /* 11 */ TclDeleteVars, /* 12 */ 0, /* 13 */ @@ -232,11 +521,11 @@ 0, /* 29 */ 0, /* 30 */ TclGetExtension, /* 31 */ TclGetFrame, /* 32 */ 0, /* 33 */ - 0, /* 34 */ + TclGetIntForIndex, /* 34 */ 0, /* 35 */ 0, /* 36 */ TclGetLoadedPackages, /* 37 */ TclGetNamespaceForQualName, /* 38 */ TclGetObjInterpProc, /* 39 */ @@ -275,11 +564,11 @@ 0, /* 72 */ 0, /* 73 */ TclpFree, /* 74 */ TclpGetClicks, /* 75 */ TclpGetSeconds, /* 76 */ - 0, /* 77 */ + TclpGetTime, /* 77 */ 0, /* 78 */ 0, /* 79 */ 0, /* 80 */ TclpRealloc, /* 81 */ 0, /* 82 */ @@ -286,11 +575,11 @@ 0, /* 83 */ 0, /* 84 */ 0, /* 85 */ 0, /* 86 */ 0, /* 87 */ - 0, /* 88 */ + TclPrecTraceProc, /* 88 */ TclPreventAliasLoop, /* 89 */ 0, /* 90 */ TclProcCleanupProc, /* 91 */ TclProcCompileProc, /* 92 */ TclProcDeleteProc, /* 93 */ @@ -302,40 +591,40 @@ 0, /* 99 */ 0, /* 100 */ TclSetPreInitScript, /* 101 */ TclSetupEnv, /* 102 */ TclSockGetPort, /* 103 */ - 0, /* 104 */ + TclSockMinimumBuffersOld, /* 104 */ 0, /* 105 */ 0, /* 106 */ 0, /* 107 */ TclTeardownNamespace, /* 108 */ TclUpdateReturnInfo, /* 109 */ TclSockMinimumBuffers, /* 110 */ Tcl_AddInterpResolvers, /* 111 */ - 0, /* 112 */ - 0, /* 113 */ - 0, /* 114 */ - 0, /* 115 */ - 0, /* 116 */ - 0, /* 117 */ + Tcl_AppendExportList, /* 112 */ + Tcl_CreateNamespace, /* 113 */ + Tcl_DeleteNamespace, /* 114 */ + Tcl_Export, /* 115 */ + Tcl_FindCommand, /* 116 */ + Tcl_FindNamespace, /* 117 */ Tcl_GetInterpResolvers, /* 118 */ Tcl_GetNamespaceResolvers, /* 119 */ Tcl_FindNamespaceVar, /* 120 */ - 0, /* 121 */ - 0, /* 122 */ - 0, /* 123 */ - 0, /* 124 */ - 0, /* 125 */ + Tcl_ForgetImport, /* 121 */ + Tcl_GetCommandFromObj, /* 122 */ + Tcl_GetCommandFullName, /* 123 */ + Tcl_GetCurrentNamespace, /* 124 */ + Tcl_GetGlobalNamespace, /* 125 */ Tcl_GetVariableFullName, /* 126 */ - 0, /* 127 */ + Tcl_Import, /* 127 */ Tcl_PopCallFrame, /* 128 */ Tcl_PushCallFrame, /* 129 */ Tcl_RemoveInterpResolvers, /* 130 */ Tcl_SetNamespaceResolvers, /* 131 */ TclpHasSockets, /* 132 */ - 0, /* 133 */ + TclpGetDate, /* 133 */ 0, /* 134 */ 0, /* 135 */ 0, /* 136 */ 0, /* 137 */ TclGetEnv, /* 138 */ @@ -356,36 +645,36 @@ TclGetLibraryPath, /* 153 */ 0, /* 154 */ 0, /* 155 */ TclRegError, /* 156 */ TclVarTraceExists, /* 157 */ - 0, /* 158 */ - 0, /* 159 */ + TclSetStartupScriptFileName, /* 158 */ + TclGetStartupScriptFileName, /* 159 */ 0, /* 160 */ TclChannelTransform, /* 161 */ TclChannelEventScriptInvoker, /* 162 */ TclGetInstructionTable, /* 163 */ TclExpandCodeArray, /* 164 */ TclpSetInitialEncodings, /* 165 */ TclListObjSetElement, /* 166 */ - 0, /* 167 */ - 0, /* 168 */ + TclSetStartupScriptPath, /* 167 */ + TclGetStartupScriptPath, /* 168 */ TclpUtfNcmp2, /* 169 */ TclCheckInterpTraces, /* 170 */ TclCheckExecutionTraces, /* 171 */ TclInThreadExit, /* 172 */ TclUniCharMatch, /* 173 */ 0, /* 174 */ TclCallVarTraces, /* 175 */ TclCleanupVar, /* 176 */ TclVarErrMsg, /* 177 */ - 0, /* 178 */ - 0, /* 179 */ + Tcl_SetStartupScript, /* 178 */ + Tcl_GetStartupScript, /* 179 */ 0, /* 180 */ 0, /* 181 */ - 0, /* 182 */ - 0, /* 183 */ + TclpLocaltime, /* 182 */ + TclpGmtime, /* 183 */ 0, /* 184 */ 0, /* 185 */ 0, /* 186 */ 0, /* 187 */ 0, /* 188 */ @@ -434,11 +723,11 @@ TclGetNamespaceFromObj, /* 231 */ TclEvalObjEx, /* 232 */ TclGetSrcInfoForPc, /* 233 */ TclVarHashCreateVar, /* 234 */ TclInitVarHashTable, /* 235 */ - 0, /* 236 */ + TclBackgroundException, /* 236 */ TclResetCancellation, /* 237 */ TclNRInterpProc, /* 238 */ TclNRInterpProcCore, /* 239 */ TclNRRunCallbacks, /* 240 */ TclNREvalObjEx, /* 241 */ @@ -456,11 +745,13 @@ TclPtrSetVar, /* 253 */ TclPtrIncrObjVar, /* 254 */ TclPtrObjMakeUpvar, /* 255 */ TclPtrUnsetVar, /* 256 */ TclStaticPackage, /* 257 */ - TclpCreateTemporaryDirectory, /* 258 */ + 0, /* 258 */ + 0, /* 259 */ + TclUnusedStubEntry, /* 260 */ }; static const TclIntPlatStubs tclIntPlatStubs = { TCL_STUB_MAGIC, 0, @@ -468,28 +759,28 @@ TclGetAndDetachPids, /* 0 */ TclpCloseFile, /* 1 */ TclpCreateCommandChannel, /* 2 */ TclpCreatePipe, /* 3 */ TclpCreateProcess, /* 4 */ - 0, /* 5 */ + TclUnixWaitForFile_, /* 5 */ TclpMakeFile, /* 6 */ TclpOpenFile, /* 7 */ TclUnixWaitForFile, /* 8 */ TclpCreateTempFile, /* 9 */ - 0, /* 10 */ - 0, /* 11 */ - 0, /* 12 */ - 0, /* 13 */ + TclpReaddir, /* 10 */ + TclpLocaltime_unix, /* 11 */ + TclpGmtime_unix, /* 12 */ + TclpInetNtoa, /* 13 */ TclUnixCopyFile, /* 14 */ - 0, /* 15 */ - 0, /* 16 */ - 0, /* 17 */ - 0, /* 18 */ - 0, /* 19 */ + TclMacOSXGetFileAttribute, /* 15 */ + TclMacOSXSetFileAttribute, /* 16 */ + TclMacOSXCopyFileAttributes, /* 17 */ + TclMacOSXMatchType, /* 18 */ + TclMacOSXNotifierAddRunLoopMode, /* 19 */ 0, /* 20 */ 0, /* 21 */ - 0, /* 22 */ + TclpCreateTempFile_, /* 22 */ 0, /* 23 */ 0, /* 24 */ 0, /* 25 */ 0, /* 26 */ 0, /* 27 */ @@ -497,20 +788,20 @@ TclWinCPUID, /* 29 */ TclUnixOpenTemporaryFile, /* 30 */ #endif /* UNIX */ #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ TclWinConvertError, /* 0 */ - 0, /* 1 */ - 0, /* 2 */ - 0, /* 3 */ + TclWinConvertWSAError, /* 1 */ + TclWinGetServByName, /* 2 */ + TclWinGetSockOpt, /* 3 */ TclWinGetTclInstance, /* 4 */ TclUnixWaitForFile, /* 5 */ - 0, /* 6 */ - 0, /* 7 */ + TclWinNToHS, /* 6 */ + TclWinSetSockOpt, /* 7 */ TclpGetPid, /* 8 */ - 0, /* 9 */ - 0, /* 10 */ + TclWinGetPlatformId, /* 9 */ + TclpReaddir, /* 10 */ TclGetAndDetachPids, /* 11 */ TclpCloseFile, /* 12 */ TclpCreateCommandChannel, /* 13 */ TclpCreatePipe, /* 14 */ TclpCreateProcess, /* 15 */ @@ -517,45 +808,45 @@ TclpIsAtty, /* 16 */ TclUnixCopyFile, /* 17 */ TclpMakeFile, /* 18 */ TclpOpenFile, /* 19 */ TclWinAddProcess, /* 20 */ - 0, /* 21 */ + TclpInetNtoa, /* 21 */ TclpCreateTempFile, /* 22 */ 0, /* 23 */ TclWinNoBackslash, /* 24 */ 0, /* 25 */ - 0, /* 26 */ + TclWinSetInterfaces, /* 26 */ TclWinFlushDirtyChannels, /* 27 */ - 0, /* 28 */ + TclWinResetInterfaces, /* 28 */ TclWinCPUID, /* 29 */ TclUnixOpenTemporaryFile, /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ TclGetAndDetachPids, /* 0 */ TclpCloseFile, /* 1 */ TclpCreateCommandChannel, /* 2 */ TclpCreatePipe, /* 3 */ TclpCreateProcess, /* 4 */ - 0, /* 5 */ + TclUnixWaitForFile_, /* 5 */ TclpMakeFile, /* 6 */ TclpOpenFile, /* 7 */ TclUnixWaitForFile, /* 8 */ TclpCreateTempFile, /* 9 */ - 0, /* 10 */ - 0, /* 11 */ - 0, /* 12 */ - 0, /* 13 */ + TclpReaddir, /* 10 */ + TclpLocaltime_unix, /* 11 */ + TclpGmtime_unix, /* 12 */ + TclpInetNtoa, /* 13 */ TclUnixCopyFile, /* 14 */ TclMacOSXGetFileAttribute, /* 15 */ TclMacOSXSetFileAttribute, /* 16 */ TclMacOSXCopyFileAttributes, /* 17 */ TclMacOSXMatchType, /* 18 */ TclMacOSXNotifierAddRunLoopMode, /* 19 */ 0, /* 20 */ 0, /* 21 */ - 0, /* 22 */ + TclpCreateTempFile_, /* 22 */ 0, /* 23 */ 0, /* 24 */ 0, /* 25 */ 0, /* 26 */ 0, /* 27 */ @@ -629,38 +920,41 @@ TclBN_mp_to_unsigned_bin_n, /* 45 */ TclBN_mp_toradix_n, /* 46 */ TclBN_mp_unsigned_bin_size, /* 47 */ TclBN_mp_xor, /* 48 */ TclBN_mp_zero, /* 49 */ - 0, /* 50 */ - 0, /* 51 */ - 0, /* 52 */ - 0, /* 53 */ - 0, /* 54 */ - 0, /* 55 */ - 0, /* 56 */ - 0, /* 57 */ - 0, /* 58 */ - 0, /* 59 */ - 0, /* 60 */ + TclBN_reverse, /* 50 */ + TclBN_fast_s_mp_mul_digs, /* 51 */ + TclBN_fast_s_mp_sqr, /* 52 */ + TclBN_mp_karatsuba_mul, /* 53 */ + TclBN_mp_karatsuba_sqr, /* 54 */ + TclBN_mp_toom_mul, /* 55 */ + TclBN_mp_toom_sqr, /* 56 */ + TclBN_s_mp_add, /* 57 */ + TclBN_s_mp_mul_digs, /* 58 */ + TclBN_s_mp_sqr, /* 59 */ + TclBN_s_mp_sub, /* 60 */ TclBN_mp_init_set_int, /* 61 */ TclBN_mp_set_int, /* 62 */ TclBN_mp_cnt_lsb, /* 63 */ - 0, /* 64 */ - 0, /* 65 */ - 0, /* 66 */ + TclBNInitBignumFromLong, /* 64 */ + TclBNInitBignumFromWideInt, /* 65 */ + TclBNInitBignumFromWideUInt, /* 66 */ TclBN_mp_expt_d_ex, /* 67 */ - TclBN_mp_set_long_long, /* 68 */ - TclBN_mp_get_long_long, /* 69 */ - TclBN_mp_set_long, /* 70 */ - TclBN_mp_get_long, /* 71 */ - TclBN_mp_get_int, /* 72 */ - 0, /* 73 */ - 0, /* 74 */ - 0, /* 75 */ + TclBN_mp_set_ull, /* 68 */ + TclBN_mp_get_mag_ull, /* 69 */ + TclBN_mp_set_ll, /* 70 */ + 0, /* 71 */ + 0, /* 72 */ + TclBN_mp_tc_and, /* 73 */ + TclBN_mp_tc_or, /* 74 */ + TclBN_mp_tc_xor, /* 75 */ TclBN_mp_signed_rsh, /* 76 */ - TclBN_mp_get_bit, /* 77 */ + 0, /* 77 */ + TclBN_mp_to_ubin, /* 78 */ + TclBN_mp_div_ld, /* 79 */ + TclBN_mp_to_radix, /* 80 */ }; static const TclStubHooks tclStubHooks = { &tclPlatStubs, &tclIntStubs, @@ -706,25 +1000,25 @@ Tcl_ConcatObj, /* 17 */ Tcl_ConvertToType, /* 18 */ Tcl_DbDecrRefCount, /* 19 */ Tcl_DbIncrRefCount, /* 20 */ Tcl_DbIsShared, /* 21 */ - 0, /* 22 */ + Tcl_DbNewBooleanObj, /* 22 */ Tcl_DbNewByteArrayObj, /* 23 */ Tcl_DbNewDoubleObj, /* 24 */ Tcl_DbNewListObj, /* 25 */ - 0, /* 26 */ + Tcl_DbNewLongObj, /* 26 */ Tcl_DbNewObj, /* 27 */ Tcl_DbNewStringObj, /* 28 */ Tcl_DuplicateObj, /* 29 */ - 0, /* 30 */ + TclFreeObj, /* 30 */ Tcl_GetBoolean, /* 31 */ Tcl_GetBooleanFromObj, /* 32 */ Tcl_GetByteArrayFromObj, /* 33 */ Tcl_GetDouble, /* 34 */ Tcl_GetDoubleFromObj, /* 35 */ - 0, /* 36 */ + Tcl_GetIndexFromObj, /* 36 */ Tcl_GetInt, /* 37 */ Tcl_GetIntFromObj, /* 38 */ Tcl_GetLongFromObj, /* 39 */ Tcl_GetObjType, /* 40 */ Tcl_GetStringFromObj, /* 41 */ @@ -733,39 +1027,39 @@ Tcl_ListObjAppendElement, /* 44 */ Tcl_ListObjGetElements, /* 45 */ Tcl_ListObjIndex, /* 46 */ Tcl_ListObjLength, /* 47 */ Tcl_ListObjReplace, /* 48 */ - 0, /* 49 */ + Tcl_NewBooleanObj, /* 49 */ Tcl_NewByteArrayObj, /* 50 */ Tcl_NewDoubleObj, /* 51 */ - 0, /* 52 */ + Tcl_NewIntObj, /* 52 */ Tcl_NewListObj, /* 53 */ - 0, /* 54 */ + Tcl_NewLongObj, /* 54 */ Tcl_NewObj, /* 55 */ Tcl_NewStringObj, /* 56 */ - 0, /* 57 */ + Tcl_SetBooleanObj, /* 57 */ Tcl_SetByteArrayLength, /* 58 */ Tcl_SetByteArrayObj, /* 59 */ Tcl_SetDoubleObj, /* 60 */ - 0, /* 61 */ + Tcl_SetIntObj, /* 61 */ Tcl_SetListObj, /* 62 */ - 0, /* 63 */ + Tcl_SetLongObj, /* 63 */ Tcl_SetObjLength, /* 64 */ Tcl_SetStringObj, /* 65 */ - 0, /* 66 */ - 0, /* 67 */ + Tcl_AddErrorInfo, /* 66 */ + Tcl_AddObjErrorInfo, /* 67 */ Tcl_AllowExceptions, /* 68 */ Tcl_AppendElement, /* 69 */ Tcl_AppendResult, /* 70 */ Tcl_AsyncCreate, /* 71 */ Tcl_AsyncDelete, /* 72 */ Tcl_AsyncInvoke, /* 73 */ Tcl_AsyncMark, /* 74 */ Tcl_AsyncReady, /* 75 */ - 0, /* 76 */ - 0, /* 77 */ + Tcl_BackgroundError, /* 76 */ + Tcl_Backslash, /* 77 */ Tcl_BadChannelOption, /* 78 */ Tcl_CallWhenDeleted, /* 79 */ Tcl_CancelIdleCall, /* 80 */ Tcl_Close, /* 81 */ Tcl_CommandComplete, /* 82 */ @@ -779,11 +1073,11 @@ Tcl_CreateCloseHandler, /* 90 */ Tcl_CreateCommand, /* 91 */ Tcl_CreateEventSource, /* 92 */ Tcl_CreateExitHandler, /* 93 */ Tcl_CreateInterp, /* 94 */ - 0, /* 95 */ + Tcl_CreateMathFunc, /* 95 */ Tcl_CreateObjCommand, /* 96 */ Tcl_CreateSlave, /* 97 */ Tcl_CreateTimerHandler, /* 98 */ Tcl_CreateTrace, /* 99 */ Tcl_DeleteAssocData, /* 100 */ @@ -813,13 +1107,13 @@ Tcl_DStringSetLength, /* 124 */ Tcl_DStringStartSublist, /* 125 */ Tcl_Eof, /* 126 */ Tcl_ErrnoId, /* 127 */ Tcl_ErrnoMsg, /* 128 */ - 0, /* 129 */ + Tcl_Eval, /* 129 */ Tcl_EvalFile, /* 130 */ - 0, /* 131 */ + Tcl_EvalObj, /* 131 */ Tcl_EventuallyFree, /* 132 */ Tcl_Exit, /* 133 */ Tcl_ExposeCommand, /* 134 */ Tcl_ExprBoolean, /* 135 */ Tcl_ExprBooleanObj, /* 136 */ @@ -828,11 +1122,11 @@ Tcl_ExprLong, /* 139 */ Tcl_ExprLongObj, /* 140 */ Tcl_ExprObj, /* 141 */ Tcl_ExprString, /* 142 */ Tcl_Finalize, /* 143 */ - 0, /* 144 */ + Tcl_FindExecutable, /* 144 */ Tcl_FirstHashEntry, /* 145 */ Tcl_Flush, /* 146 */ Tcl_FreeResult, /* 147 */ Tcl_GetAlias, /* 148 */ Tcl_GetAliasObj, /* 149 */ @@ -866,15 +1160,15 @@ Tcl_Gets, /* 169 */ Tcl_GetsObj, /* 170 */ Tcl_GetServiceMode, /* 171 */ Tcl_GetSlave, /* 172 */ Tcl_GetStdChannel, /* 173 */ - 0, /* 174 */ - 0, /* 175 */ + Tcl_GetStringResult, /* 174 */ + Tcl_GetVar, /* 175 */ Tcl_GetVar2, /* 176 */ - 0, /* 177 */ - 0, /* 178 */ + Tcl_GlobalEval, /* 177 */ + Tcl_GlobalEvalObj, /* 178 */ Tcl_HideCommand, /* 179 */ Tcl_Init, /* 180 */ Tcl_InitHashTable, /* 181 */ Tcl_InputBlocked, /* 182 */ Tcl_InputBuffered, /* 183 */ @@ -912,69 +1206,69 @@ Tcl_RegExpRange, /* 215 */ Tcl_Release, /* 216 */ Tcl_ResetResult, /* 217 */ Tcl_ScanElement, /* 218 */ Tcl_ScanCountedElement, /* 219 */ - 0, /* 220 */ + Tcl_SeekOld, /* 220 */ Tcl_ServiceAll, /* 221 */ Tcl_ServiceEvent, /* 222 */ Tcl_SetAssocData, /* 223 */ Tcl_SetChannelBufferSize, /* 224 */ Tcl_SetChannelOption, /* 225 */ Tcl_SetCommandInfo, /* 226 */ Tcl_SetErrno, /* 227 */ Tcl_SetErrorCode, /* 228 */ Tcl_SetMaxBlockTime, /* 229 */ - 0, /* 230 */ + Tcl_SetPanicProc, /* 230 */ Tcl_SetRecursionLimit, /* 231 */ - 0, /* 232 */ + Tcl_SetResult, /* 232 */ Tcl_SetServiceMode, /* 233 */ Tcl_SetObjErrorCode, /* 234 */ Tcl_SetObjResult, /* 235 */ Tcl_SetStdChannel, /* 236 */ - 0, /* 237 */ + Tcl_SetVar, /* 237 */ Tcl_SetVar2, /* 238 */ Tcl_SignalId, /* 239 */ Tcl_SignalMsg, /* 240 */ Tcl_SourceRCFile, /* 241 */ Tcl_SplitList, /* 242 */ Tcl_SplitPath, /* 243 */ - 0, /* 244 */ - 0, /* 245 */ - 0, /* 246 */ - 0, /* 247 */ + Tcl_StaticPackage, /* 244 */ + Tcl_StringMatch, /* 245 */ + Tcl_TellOld, /* 246 */ + Tcl_TraceVar, /* 247 */ Tcl_TraceVar2, /* 248 */ Tcl_TranslateFileName, /* 249 */ Tcl_Ungets, /* 250 */ Tcl_UnlinkVar, /* 251 */ Tcl_UnregisterChannel, /* 252 */ - 0, /* 253 */ + Tcl_UnsetVar, /* 253 */ Tcl_UnsetVar2, /* 254 */ - 0, /* 255 */ + Tcl_UntraceVar, /* 255 */ Tcl_UntraceVar2, /* 256 */ Tcl_UpdateLinkedVar, /* 257 */ - 0, /* 258 */ + Tcl_UpVar, /* 258 */ Tcl_UpVar2, /* 259 */ Tcl_VarEval, /* 260 */ - 0, /* 261 */ + Tcl_VarTraceInfo, /* 261 */ Tcl_VarTraceInfo2, /* 262 */ Tcl_Write, /* 263 */ Tcl_WrongNumArgs, /* 264 */ Tcl_DumpActiveMemory, /* 265 */ Tcl_ValidateAllMemory, /* 266 */ - 0, /* 267 */ - 0, /* 268 */ + Tcl_AppendResultVA, /* 267 */ + Tcl_AppendStringsToObjVA, /* 268 */ Tcl_HashStats, /* 269 */ Tcl_ParseVar, /* 270 */ - 0, /* 271 */ + Tcl_PkgPresent, /* 271 */ Tcl_PkgPresentEx, /* 272 */ - 0, /* 273 */ - 0, /* 274 */ - 0, /* 275 */ - 0, /* 276 */ + Tcl_PkgProvide, /* 273 */ + Tcl_PkgRequire, /* 274 */ + Tcl_SetErrorCodeVA, /* 275 */ + Tcl_VarEvalVA, /* 276 */ Tcl_WaitPid, /* 277 */ - 0, /* 278 */ + Tcl_PanicVA, /* 278 */ Tcl_GetVersion, /* 279 */ Tcl_InitMemory, /* 280 */ Tcl_StackChannel, /* 281 */ Tcl_UnstackChannel, /* 282 */ Tcl_GetStackedChannel, /* 283 */ @@ -982,11 +1276,11 @@ 0, /* 285 */ Tcl_AppendObjToObj, /* 286 */ Tcl_CreateEncoding, /* 287 */ Tcl_CreateThreadExitHandler, /* 288 */ Tcl_DeleteThreadExitHandler, /* 289 */ - 0, /* 290 */ + Tcl_DiscardResult, /* 290 */ Tcl_EvalEx, /* 291 */ Tcl_EvalObjv, /* 292 */ Tcl_EvalObjEx, /* 293 */ Tcl_ExitThread, /* 294 */ Tcl_ExternalToUtf, /* 295 */ @@ -1006,12 +1300,12 @@ Tcl_MutexUnlock, /* 309 */ Tcl_ConditionNotify, /* 310 */ Tcl_ConditionWait, /* 311 */ Tcl_NumUtfChars, /* 312 */ Tcl_ReadChars, /* 313 */ - 0, /* 314 */ - 0, /* 315 */ + Tcl_RestoreResult, /* 314 */ + Tcl_SaveResult, /* 315 */ Tcl_SetSystemEncoding, /* 316 */ Tcl_SetVar2Ex, /* 317 */ Tcl_ThreadAlert, /* 318 */ Tcl_ThreadQueueEvent, /* 319 */ Tcl_UniCharAtIndex, /* 320 */ @@ -1033,12 +1327,12 @@ Tcl_UtfToUniChar, /* 336 */ Tcl_UtfToUpper, /* 337 */ Tcl_WriteChars, /* 338 */ Tcl_WriteObj, /* 339 */ Tcl_GetString, /* 340 */ - 0, /* 341 */ - 0, /* 342 */ + Tcl_GetDefaultEncodingDir, /* 341 */ + Tcl_SetDefaultEncodingDir, /* 342 */ Tcl_AlertNotifier, /* 343 */ Tcl_ServiceModeHook, /* 344 */ Tcl_UniCharIsAlnum, /* 345 */ Tcl_UniCharIsAlpha, /* 346 */ Tcl_UniCharIsDigit, /* 347 */ @@ -1049,11 +1343,11 @@ Tcl_UniCharLen, /* 352 */ Tcl_UniCharNcmp, /* 353 */ Tcl_UniCharToUtfDString, /* 354 */ Tcl_UtfToUniCharDString, /* 355 */ Tcl_GetRegExpFromObj, /* 356 */ - 0, /* 357 */ + Tcl_EvalTokens, /* 357 */ Tcl_FreeParse, /* 358 */ Tcl_LogCommandInfo, /* 359 */ Tcl_ParseBraces, /* 360 */ Tcl_ParseCommand, /* 361 */ Tcl_ParseExpr, /* 362 */ @@ -1074,11 +1368,11 @@ Tcl_RegExpGetInfo, /* 377 */ Tcl_NewUnicodeObj, /* 378 */ Tcl_SetUnicodeObj, /* 379 */ Tcl_GetCharLength, /* 380 */ Tcl_GetUniChar, /* 381 */ - 0, /* 382 */ + Tcl_GetUnicode, /* 382 */ Tcl_GetRange, /* 383 */ Tcl_AppendUnicodeToObj, /* 384 */ Tcl_RegExpMatchObj, /* 385 */ Tcl_SetNotifier, /* 386 */ Tcl_GetAllocMutex, /* 387 */ @@ -1113,12 +1407,12 @@ Tcl_SpliceChannel, /* 416 */ Tcl_ClearChannelHandlers, /* 417 */ Tcl_IsChannelExisting, /* 418 */ Tcl_UniCharNcasecmp, /* 419 */ Tcl_UniCharCaseMatch, /* 420 */ - 0, /* 421 */ - 0, /* 422 */ + Tcl_FindHashEntry, /* 421 */ + Tcl_CreateHashEntry, /* 422 */ Tcl_InitCustomHashTable, /* 423 */ Tcl_InitObjHashTable, /* 424 */ Tcl_CommandTraceInfo, /* 425 */ Tcl_TraceCommand, /* 426 */ Tcl_UntraceCommand, /* 427 */ @@ -1127,12 +1421,12 @@ Tcl_AttemptRealloc, /* 430 */ Tcl_AttemptDbCkrealloc, /* 431 */ Tcl_AttemptSetObjLength, /* 432 */ Tcl_GetChannelThread, /* 433 */ Tcl_GetUnicodeFromObj, /* 434 */ - 0, /* 435 */ - 0, /* 436 */ + Tcl_GetMathFuncInfo, /* 435 */ + Tcl_ListMathFuncs, /* 436 */ Tcl_SubstObj, /* 437 */ Tcl_DetachChannel, /* 438 */ Tcl_IsStandardChannel, /* 439 */ Tcl_FSCopyFile, /* 440 */ Tcl_FSCopyDirectory, /* 441 */ @@ -1211,11 +1505,11 @@ Tcl_FindNamespace, /* 514 */ Tcl_FindCommand, /* 515 */ Tcl_GetCommandFromObj, /* 516 */ Tcl_GetCommandFullName, /* 517 */ Tcl_FSEvalFileEx, /* 518 */ - 0, /* 519 */ + Tcl_SetExitProc, /* 519 */ Tcl_LimitAddHandler, /* 520 */ Tcl_LimitRemoveHandler, /* 521 */ Tcl_LimitReady, /* 522 */ Tcl_LimitCheck, /* 523 */ Tcl_LimitExceeded, /* 524 */ @@ -1323,23 +1617,27 @@ Tcl_NRSubstObj, /* 626 */ Tcl_LoadFile, /* 627 */ Tcl_FindSymbol, /* 628 */ Tcl_FSUnloadFile, /* 629 */ Tcl_ZlibStreamSetCompressionDictionary, /* 630 */ - Tcl_OpenTcpServerEx, /* 631 */ - TclZipfs_Mount, /* 632 */ - TclZipfs_Unmount, /* 633 */ - TclZipfs_TclLibrary, /* 634 */ - TclZipfs_MountBuffer, /* 635 */ - Tcl_FreeIntRep, /* 636 */ - Tcl_InitStringRep, /* 637 */ - Tcl_FetchIntRep, /* 638 */ - Tcl_StoreIntRep, /* 639 */ - Tcl_HasStringRep, /* 640 */ - Tcl_IncrRefCount, /* 641 */ - Tcl_DecrRefCount, /* 642 */ - Tcl_IsShared, /* 643 */ - Tcl_LinkArray, /* 644 */ - Tcl_GetIntForIndex, /* 645 */ + 0, /* 631 */ + 0, /* 632 */ + 0, /* 633 */ + 0, /* 634 */ + 0, /* 635 */ + 0, /* 636 */ + 0, /* 637 */ + 0, /* 638 */ + 0, /* 639 */ + 0, /* 640 */ + 0, /* 641 */ + 0, /* 642 */ + 0, /* 643 */ + 0, /* 644 */ + 0, /* 645 */ + 0, /* 646 */ + 0, /* 647 */ + 0, /* 648 */ + TclUnusedStubEntry, /* 649 */ }; /* !END!: Do not edit above this line. */ Index: generic/tclStubLib.c ================================================================== --- generic/tclStubLib.c +++ generic/tclStubLib.c @@ -22,14 +22,17 @@ const TclPlatStubs *tclPlatStubsPtr = NULL; const TclIntStubs *tclIntStubsPtr = NULL; const TclIntPlatStubs *tclIntPlatStubsPtr = NULL; /* - * Use our own ISDIGIT to avoid linking to libc on windows + * Use our own isDigit to avoid linking to libc on windows */ -#define ISDIGIT(c) (((unsigned)((c)-'0')) <= 9) +static int isDigit(const int c) +{ + return (c >= '0' && c <= '9'); +} /* *---------------------------------------------------------------------- * * Tcl_InitStubs -- @@ -49,12 +52,11 @@ #undef Tcl_InitStubs MODULE_SCOPE const char * Tcl_InitStubs( Tcl_Interp *interp, const char *version, - int exact, - int magic) + int exact) { Interp *iPtr = (Interp *) interp; const char *actualVersion = NULL; ClientData pkgData = NULL; const TclStubs *stubsPtr = iPtr->stubTable; @@ -63,35 +65,35 @@ * We can't optimize this check by caching tclStubsPtr because that * prevents apps from being able to load/unload Tcl dynamically multiple * times. [Bug 615304] */ - if (!stubsPtr || (stubsPtr->magic != (((exact&0xff00) >= 0x900) ? magic : TCL_STUB_MAGIC))) { - iPtr->legacyResult = "interpreter uses an incompatible stubs mechanism"; - iPtr->legacyFreeProc = 0; /* TCL_STATIC */ + if (!stubsPtr || (stubsPtr->magic != TCL_STUB_MAGIC)) { + iPtr->result = (char *)"interpreter uses an incompatible stubs mechanism"; + iPtr->freeProc = TCL_STATIC; return NULL; } actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 0, &pkgData); if (actualVersion == NULL) { return NULL; } - if (exact&1) { + if (exact) { const char *p = version; int count = 0; while (*p) { - count += !ISDIGIT(*p++); + count += !isDigit(*p++); } if (count == 1) { const char *q = actualVersion; p = version; while (*p && (*p == *q)) { p++; q++; } - if (*p || ISDIGIT(*q)) { + if (*p || isDigit(*q)) { /* Construct error message */ stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL); return NULL; } } else { @@ -99,20 +101,16 @@ if (actualVersion == NULL) { return NULL; } } } - if (((exact&0xff00) < 0x900)) { - /* We are running Tcl 8.x */ - stubsPtr = (TclStubs *)pkgData; - } - tclStubsPtr = stubsPtr; - - if (stubsPtr->hooks) { - tclPlatStubsPtr = stubsPtr->hooks->tclPlatStubs; - tclIntStubsPtr = stubsPtr->hooks->tclIntStubs; - tclIntPlatStubsPtr = stubsPtr->hooks->tclIntPlatStubs; + tclStubsPtr = (TclStubs *)pkgData; + + if (tclStubsPtr->hooks) { + tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs; + tclIntStubsPtr = tclStubsPtr->hooks->tclIntStubs; + tclIntPlatStubsPtr = tclStubsPtr->hooks->tclIntPlatStubs; } else { tclPlatStubsPtr = NULL; tclIntStubsPtr = NULL; tclIntPlatStubsPtr = NULL; } Index: generic/tclTest.c ================================================================== --- generic/tclTest.c +++ generic/tclTest.c @@ -40,21 +40,28 @@ /* * Declare external functions used in Windows tests. */ -DLLEXPORT int Tcltest_Init(Tcl_Interp *interp); -DLLEXPORT int Tcltest_SafeInit(Tcl_Interp *interp); +/* + * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the + * Tcltest_Init declaration is in the source file itself, which is only + * accessed when we are building a library. + */ + +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLEXPORT +EXTERN int Tcltest_Init(Tcl_Interp *interp); +EXTERN int Tcltest_SafeInit(Tcl_Interp *interp); /* * Dynamic string shared by TestdcallCmd and DelCallbackProc; used to collect * the results of the various deletion callbacks. */ static Tcl_DString delString; static Tcl_Interp *delInterp; -static const Tcl_ObjType *properByteArrayType; /* * One of the following structures exists for each asynchronous handler * created by the "testasync" command". */ @@ -66,22 +73,10 @@ * invoked. */ struct TestAsyncHandler *nextPtr; /* Next is list of handlers. */ } TestAsyncHandler; -/* - * Start of the socket driver state structure to acces field testFlags - */ - -typedef struct TcpState TcpState; - -struct TcpState { - Tcl_Channel channel; /* Channel associated with this socket. */ - int testFlags; /* bit field for tests. Is set by testsocket - * test procedure */ -}; - TCL_DECLARE_MUTEX(asyncTestMutex) static TestAsyncHandler *firstHandler = NULL; /* @@ -158,237 +153,136 @@ /* * Forward declarations for procedures defined later in this file: */ -static int AsyncHandlerProc(void *clientData, - Tcl_Interp *interp, int code); -#if TCL_THREADS -static Tcl_ThreadCreateType AsyncThreadProc(void *); -#endif -static void CleanupTestSetassocdataTests( - void *clientData, Tcl_Interp *interp); -static void CmdDelProc1(void *clientData); -static void CmdDelProc2(void *clientData); -static int CmdProc1(void *clientData, - Tcl_Interp *interp, int argc, const char **argv); -static int CmdProc2(void *clientData, - Tcl_Interp *interp, int argc, const char **argv); -static void CmdTraceDeleteProc( - void *clientData, Tcl_Interp *interp, - int level, char *command, Tcl_CmdProc *cmdProc, - void *cmdClientData, int argc, - const char *argv[]); -static void CmdTraceProc(void *clientData, - Tcl_Interp *interp, int level, char *command, - Tcl_CmdProc *cmdProc, void *cmdClientData, - int argc, const char *argv[]); -static int CreatedCommandProc( - void *clientData, Tcl_Interp *interp, - int argc, const char **argv); -static int CreatedCommandProc2( - void *clientData, Tcl_Interp *interp, - int argc, const char **argv); -static void DelCallbackProc(void *clientData, - Tcl_Interp *interp); -static int DelCmdProc(void *clientData, - Tcl_Interp *interp, int argc, const char **argv); -static void DelDeleteProc(void *clientData); -static void EncodingFreeProc(void *clientData); -static int EncodingToUtfProc(void *clientData, - const char *src, int srcLen, int flags, - Tcl_EncodingState *statePtr, char *dst, - int dstLen, int *srcReadPtr, int *dstWrotePtr, - int *dstCharsPtr); -static int EncodingFromUtfProc(void *clientData, - const char *src, int srcLen, int flags, - Tcl_EncodingState *statePtr, char *dst, - int dstLen, int *srcReadPtr, int *dstWrotePtr, - int *dstCharsPtr); -static void ExitProcEven(void *clientData); -static void ExitProcOdd(void *clientData); -static int GetTimesObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static void MainLoop(void); -static int NoopCmd(void *clientData, - Tcl_Interp *interp, int argc, const char **argv); -static int NoopObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int ObjTraceProc(void *clientData, - Tcl_Interp *interp, int level, const char *command, - Tcl_Command commandToken, int objc, - Tcl_Obj *const objv[]); -static void ObjTraceDeleteProc(void *clientData); -static void PrintParse(Tcl_Interp *interp, Tcl_Parse *parsePtr); -static void SpecialFree(void *blockPtr); -static int StaticInitProc(Tcl_Interp *interp); -static int TestasyncCmd(void *dummy, - Tcl_Interp *interp, int argc, const char **argv); -static int TestbytestringObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int TestpurebytesobjObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int TeststringbytesObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int TestcmdinfoCmd(void *dummy, - Tcl_Interp *interp, int argc, const char **argv); -static int TestcmdtokenCmd(void *dummy, - Tcl_Interp *interp, int argc, const char **argv); -static int TestcmdtraceCmd(void *dummy, - Tcl_Interp *interp, int argc, const char **argv); -static int TestconcatobjCmd(void *dummy, - Tcl_Interp *interp, int argc, const char **argv); -static int TestcreatecommandCmd(void *dummy, - Tcl_Interp *interp, int argc, const char **argv); -static int TestdcallCmd(void *dummy, - Tcl_Interp *interp, int argc, const char **argv); -static int TestdelCmd(void *dummy, - Tcl_Interp *interp, int argc, const char **argv); -static int TestdelassocdataCmd(void *dummy, - Tcl_Interp *interp, int argc, const char **argv); -static int TestdoubledigitsObjCmd(void *dummy, - Tcl_Interp* interp, int objc, - Tcl_Obj* const objv[]); -static int TestdstringCmd(void *dummy, - Tcl_Interp *interp, int argc, const char **argv); -static int TestencodingObjCmd(void *dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int TestevalexObjCmd(void *dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int TestevalobjvObjCmd(void *dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int TesteventObjCmd(void *unused, - Tcl_Interp *interp, int argc, - Tcl_Obj *const objv[]); -static int TesteventProc(Tcl_Event *event, int flags); -static int TesteventDeleteProc(Tcl_Event *event, - void *clientData); -static int TestexithandlerCmd(void *dummy, - Tcl_Interp *interp, int argc, const char **argv); -static int TestexprlongCmd(void *dummy, - Tcl_Interp *interp, int argc, const char **argv); -static int TestexprlongobjCmd(void *dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int TestexprdoubleCmd(void *dummy, - Tcl_Interp *interp, int argc, const char **argv); -static int TestexprdoubleobjCmd(void *dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int TestexprparserObjCmd(void *dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int TestexprstringCmd(void *dummy, - Tcl_Interp *interp, int argc, const char **argv); -static int TestfileCmd(void *dummy, - Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestfilelinkCmd(void *dummy, - Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestfeventCmd(void *dummy, - Tcl_Interp *interp, int argc, const char **argv); -static int TestgetassocdataCmd(void *dummy, - Tcl_Interp *interp, int argc, const char **argv); -static int TestgetintCmd(void *dummy, - Tcl_Interp *interp, int argc, const char **argv); -static int TestlongsizeCmd(void *dummy, - Tcl_Interp *interp, int argc, const char **argv); -static int TestgetplatformCmd(void *dummy, - Tcl_Interp *interp, int argc, const char **argv); -static int TestgetvarfullnameCmd( - void *dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int TestinterpdeleteCmd(void *dummy, - Tcl_Interp *interp, int argc, const char **argv); -static int TestlinkCmd(void *dummy, - Tcl_Interp *interp, int argc, const char **argv); -static int TestlinkarrayCmd(void *dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const *objv); -static int TestlocaleCmd(void *dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int TestmainthreadCmd(void *dummy, - Tcl_Interp *interp, int argc, const char **argv); -static int TestsetmainloopCmd(void *dummy, - Tcl_Interp *interp, int argc, const char **argv); -static int TestexitmainloopCmd(void *dummy, - Tcl_Interp *interp, int argc, const char **argv); -static int TestpanicCmd(void *dummy, - Tcl_Interp *interp, int argc, const char **argv); -static int TestparseargsCmd(void *dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int TestparserObjCmd(void *dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int TestparsevarObjCmd(void *dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int TestparsevarnameObjCmd(void *dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int TestpreferstableObjCmd(void *dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int TestprintObjCmd(void *dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int TestregexpObjCmd(void *dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int TestreturnObjCmd(void *dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static void TestregexpXflags(const char *string, - size_t length, int *cflagsPtr, int *eflagsPtr); -static int TestsaveresultCmd(void *dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static void TestsaveresultFree(void *blockPtr); -static int TestsetassocdataCmd(void *dummy, - Tcl_Interp *interp, int argc, const char **argv); -static int TestsetCmd(void *dummy, - Tcl_Interp *interp, int argc, const char **argv); -static int Testset2Cmd(void *dummy, - Tcl_Interp *interp, int argc, const char **argv); -static int TestseterrorcodeCmd(void *dummy, - Tcl_Interp *interp, int argc, const char **argv); -static int TestsetobjerrorcodeCmd( - void *dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int TestsetplatformCmd(void *dummy, - Tcl_Interp *interp, int argc, const char **argv); -static int TeststaticpkgCmd(void *dummy, - Tcl_Interp *interp, int argc, const char **argv); -static int TesttranslatefilenameCmd(void *dummy, - Tcl_Interp *interp, int argc, const char **argv); -static int TestupvarCmd(void *dummy, - Tcl_Interp *interp, int argc, const char **argv); -static int TestWrongNumArgsObjCmd( - void *clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int TestGetIndexFromObjStructObjCmd( - void *clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int TestChannelCmd(void *clientData, - Tcl_Interp *interp, int argc, const char **argv); -static int TestChannelEventCmd(void *clientData, - Tcl_Interp *interp, int argc, const char **argv); -static int TestSocketCmd(void *clientData, - Tcl_Interp *interp, int argc, const char **argv); -static int TestFilesystemObjCmd(void *dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int TestSimpleFilesystemObjCmd( - void *dummy, Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +static int AsyncHandlerProc(ClientData clientData, + Tcl_Interp *interp, int code); +#ifdef TCL_THREADS +static Tcl_ThreadCreateType AsyncThreadProc(ClientData); +#endif +static void CleanupTestSetassocdataTests( + ClientData clientData, Tcl_Interp *interp); +static void CmdDelProc1(ClientData clientData); +static void CmdDelProc2(ClientData clientData); +static Tcl_CmdProc CmdProc1; +static Tcl_CmdProc CmdProc2; +static void CmdTraceDeleteProc( + ClientData clientData, Tcl_Interp *interp, + int level, char *command, Tcl_CmdProc *cmdProc, + ClientData cmdClientData, int argc, + const char *argv[]); +static void CmdTraceProc(ClientData clientData, + Tcl_Interp *interp, int level, char *command, + Tcl_CmdProc *cmdProc, ClientData cmdClientData, + int argc, const char *argv[]); +static Tcl_CmdProc CreatedCommandProc; +static Tcl_CmdProc CreatedCommandProc2; +static void DelCallbackProc(ClientData clientData, + Tcl_Interp *interp); +static Tcl_CmdProc DelCmdProc; +static void DelDeleteProc(ClientData clientData); +static void EncodingFreeProc(ClientData clientData); +static int EncodingToUtfProc(ClientData clientData, + const char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, + int dstLen, int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr); +static int EncodingFromUtfProc(ClientData clientData, + const char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, + int dstLen, int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr); +static void ExitProcEven(ClientData clientData); +static void ExitProcOdd(ClientData clientData); +static Tcl_ObjCmdProc GetTimesObjCmd; +static void MainLoop(void); +static Tcl_CmdProc NoopCmd; +static Tcl_ObjCmdProc NoopObjCmd; +static int ObjTraceProc(ClientData clientData, + Tcl_Interp *interp, int level, const char *command, + Tcl_Command commandToken, int objc, + Tcl_Obj *const objv[]); +static void ObjTraceDeleteProc(ClientData clientData); +static void PrintParse(Tcl_Interp *interp, Tcl_Parse *parsePtr); +static void SpecialFree(char *blockPtr); +static int StaticInitProc(Tcl_Interp *interp); +static Tcl_CmdProc TestasyncCmd; +static Tcl_ObjCmdProc TestbumpinterpepochObjCmd; +static Tcl_ObjCmdProc TestsetbytearraylengthObjCmd; +static Tcl_ObjCmdProc TestpurebytesobjObjCmd; +static Tcl_ObjCmdProc TestbytestringObjCmd; +static Tcl_ObjCmdProc TeststringbytesObjCmd; +static Tcl_CmdProc TestcmdinfoCmd; +static Tcl_CmdProc TestcmdtokenCmd; +static Tcl_CmdProc TestcmdtraceCmd; +static Tcl_CmdProc TestconcatobjCmd; +static Tcl_CmdProc TestcreatecommandCmd; +static Tcl_CmdProc TestdcallCmd; +static Tcl_CmdProc TestdelCmd; +static Tcl_CmdProc TestdelassocdataCmd; +static Tcl_ObjCmdProc TestdoubledigitsObjCmd; +static Tcl_CmdProc TestdstringCmd; +static Tcl_ObjCmdProc TestencodingObjCmd; +static Tcl_ObjCmdProc TestevalexObjCmd; +static Tcl_ObjCmdProc TestevalobjvObjCmd; +static Tcl_ObjCmdProc TesteventObjCmd; +static int TesteventProc(Tcl_Event *event, int flags); +static int TesteventDeleteProc(Tcl_Event *event, + ClientData clientData); +static Tcl_CmdProc TestexithandlerCmd; +static Tcl_CmdProc TestexprlongCmd; +static Tcl_ObjCmdProc TestexprlongobjCmd; +static Tcl_CmdProc TestexprdoubleCmd; +static Tcl_ObjCmdProc TestexprdoubleobjCmd; +static Tcl_ObjCmdProc TestexprparserObjCmd; +static Tcl_CmdProc TestexprstringCmd; +static Tcl_ObjCmdProc TestfileCmd; +static Tcl_ObjCmdProc TestfilelinkCmd; +static Tcl_CmdProc TestfeventCmd; +static Tcl_CmdProc TestgetassocdataCmd; +static Tcl_CmdProc TestgetintCmd; +static Tcl_CmdProc TestgetplatformCmd; +static Tcl_ObjCmdProc TestgetvarfullnameCmd; +static Tcl_CmdProc TestinterpdeleteCmd; +static Tcl_CmdProc TestlinkCmd; +static Tcl_ObjCmdProc TestlocaleCmd; +static int TestMathFunc(ClientData clientData, + Tcl_Interp *interp, Tcl_Value *args, + Tcl_Value *resultPtr); +static int TestMathFunc2(ClientData clientData, + Tcl_Interp *interp, Tcl_Value *args, + Tcl_Value *resultPtr); +static Tcl_CmdProc TestmainthreadCmd; +static Tcl_CmdProc TestsetmainloopCmd; +static Tcl_CmdProc TestexitmainloopCmd; +static Tcl_CmdProc TestpanicCmd; +static Tcl_ObjCmdProc TestparseargsCmd; +static Tcl_ObjCmdProc TestparserObjCmd; +static Tcl_ObjCmdProc TestparsevarObjCmd; +static Tcl_ObjCmdProc TestparsevarnameObjCmd; +static Tcl_ObjCmdProc TestregexpObjCmd; +static Tcl_ObjCmdProc TestreturnObjCmd; +static void TestregexpXflags(const char *string, + int length, int *cflagsPtr, int *eflagsPtr); +static Tcl_ObjCmdProc TestsaveresultCmd; +static void TestsaveresultFree(char *blockPtr); +static Tcl_CmdProc TestsetassocdataCmd; +static Tcl_CmdProc TestsetCmd; +static Tcl_CmdProc Testset2Cmd; +static Tcl_CmdProc TestseterrorcodeCmd; +static Tcl_ObjCmdProc TestsetobjerrorcodeCmd; +static Tcl_CmdProc TestsetplatformCmd; +static Tcl_CmdProc TeststaticpkgCmd; +static Tcl_CmdProc TesttranslatefilenameCmd; +static Tcl_CmdProc TestupvarCmd; +static Tcl_ObjCmdProc TestWrongNumArgsObjCmd; +static Tcl_ObjCmdProc TestGetIndexFromObjStructObjCmd; +static Tcl_CmdProc TestChannelCmd; +static Tcl_CmdProc TestChannelEventCmd; +static Tcl_ObjCmdProc TestFilesystemObjCmd; +static Tcl_ObjCmdProc TestSimpleFilesystemObjCmd; static void TestReport(const char *cmd, Tcl_Obj *arg1, Tcl_Obj *arg2); static Tcl_Obj * TestReportGetNativePath(Tcl_Obj *pathPtr); static Tcl_FSStatProc TestReportStat; static Tcl_FSAccessProc TestReportAccess; @@ -411,45 +305,31 @@ static Tcl_FSUtimeProc TestReportUtime; static Tcl_FSNormalizePathProc TestReportNormalizePath; static Tcl_FSPathInFilesystemProc TestReportInFilesystem; static Tcl_FSFreeInternalRepProc TestReportFreeInternalRep; static Tcl_FSDupInternalRepProc TestReportDupInternalRep; - +static Tcl_CmdProc TestServiceModeCmd; static Tcl_FSStatProc SimpleStat; static Tcl_FSAccessProc SimpleAccess; static Tcl_FSOpenFileChannelProc SimpleOpenFileChannel; static Tcl_FSListVolumesProc SimpleListVolumes; static Tcl_FSPathInFilesystemProc SimplePathInFilesystem; static Tcl_Obj * SimpleRedirect(Tcl_Obj *pathPtr); static Tcl_FSMatchInDirectoryProc SimpleMatchInDirectory; -static int TestNumUtfCharsCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int TestFindFirstCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int TestFindLastCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int TestHashSystemHashCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +static Tcl_ObjCmdProc TestUtfNextCmd; +static Tcl_ObjCmdProc TestUtfPrevCmd; +static Tcl_ObjCmdProc TestNumUtfCharsCmd; +static Tcl_ObjCmdProc TestFindFirstCmd; +static Tcl_ObjCmdProc TestFindLastCmd; +static Tcl_ObjCmdProc TestHashSystemHashCmd; static Tcl_NRPostProc NREUnwind_callback; -static int TestNREUnwind(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int TestNRELevels(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int TestInterpResolverCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +static Tcl_ObjCmdProc TestNREUnwind; +static Tcl_ObjCmdProc TestNRELevels; +static Tcl_ObjCmdProc TestInterpResolverCmd; #if defined(HAVE_CPUID) || defined(_WIN32) -static int TestcpuidCmd(void *dummy, - Tcl_Interp* interp, int objc, - Tcl_Obj *const objv[]); +static Tcl_ObjCmdProc TestcpuidCmd; #endif static const Tcl_Filesystem testReportingFilesystem = { "reporting", sizeof(Tcl_Filesystem), @@ -553,45 +433,43 @@ int Tcltest_Init( Tcl_Interp *interp) /* Interpreter for application. */ { + Tcl_ValueType t3ArgTypes[2]; + Tcl_Obj **objv, *objPtr; int objc, index; static const char *const specialOptions[] = { "-appinitprocerror", "-appinitprocdeleteinterp", "-appinitprocclosestderr", "-appinitprocsetrcfile", NULL }; - if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { + if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { return TCL_ERROR; } - if (Tcl_TomMath_InitStubs(interp, "8.5-") == NULL) { + if (Tcl_TomMath_InitStubs(interp, "8.5") == NULL) { return TCL_ERROR; } if (Tcl_OOInitStubs(interp) == NULL) { return TCL_ERROR; } /* TIP #268: Full patchlevel instead of just major.minor */ - if (Tcl_PkgProvideEx(interp, "Tcltest", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) { + if (Tcl_PkgProvide(interp, "Tcltest", TCL_PATCH_LEVEL) == TCL_ERROR) { return TCL_ERROR; } - objPtr = Tcl_NewStringObj("abc", 3); - (void)Tcl_GetByteArrayFromObj(objPtr, &index); - properByteArrayType = objPtr->typePtr; - Tcl_DecrRefCount(objPtr); - /* * Create additional commands and math functions for testing Tcl. */ Tcl_CreateObjCommand(interp, "gettimes", GetTimesObjCmd, NULL, NULL); Tcl_CreateCommand(interp, "noop", NoopCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testpurebytesobj", TestpurebytesobjObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testsetbytearraylength", TestsetbytearraylengthObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "teststringbytes", TeststringbytesObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd, @@ -599,10 +477,12 @@ Tcl_CreateObjCommand(interp, "testsimplefilesystem", TestSimpleFilesystemObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testgetindexfromobjstruct", TestGetIndexFromObjStructObjCmd, NULL, NULL); Tcl_CreateCommand(interp, "testasync", TestasyncCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testbumpinterpepoch", + TestbumpinterpepochObjCmd, NULL, NULL); Tcl_CreateCommand(interp, "testchannel", TestChannelCmd, NULL, NULL); Tcl_CreateCommand(interp, "testchannelevent", TestChannelEventCmd, NULL, NULL); Tcl_CreateCommand(interp, "testcmdtoken", TestcmdtokenCmd, NULL, @@ -656,20 +536,17 @@ TestHashSystemHashCmd, NULL, NULL); Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd, NULL, NULL); Tcl_CreateCommand(interp, "testgetint", TestgetintCmd, NULL, NULL); - Tcl_CreateCommand(interp, "testlongsize", TestlongsizeCmd, - NULL, NULL); Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testgetvarfullname", TestgetvarfullnameCmd, NULL, NULL); Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd, NULL, NULL); Tcl_CreateCommand(interp, "testlink", TestlinkCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testlinkarray", TestlinkarrayCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL, NULL); Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testparseargs", TestparseargsCmd,NULL,NULL); Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd, @@ -676,47 +553,49 @@ NULL, NULL); Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testparsevarname", TestparsevarnameObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testpreferstable", TestpreferstableObjCmd, - NULL, NULL); - Tcl_CreateObjCommand(interp, "testprint", TestprintObjCmd, - NULL, NULL); Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd, + NULL, NULL); + Tcl_CreateCommand(interp, "testservicemode", TestServiceModeCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd, NULL, NULL); Tcl_CreateCommand(interp, "testseterr", TestsetCmd, - INT2PTR(TCL_LEAVE_ERR_MSG), NULL); + (ClientData) TCL_LEAVE_ERR_MSG, NULL); Tcl_CreateCommand(interp, "testset2", Testset2Cmd, - INT2PTR(TCL_LEAVE_ERR_MSG), NULL); + (ClientData) TCL_LEAVE_ERR_MSG, NULL); Tcl_CreateCommand(interp, "testseterrorcode", TestseterrorcodeCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testsetobjerrorcode", TestsetobjerrorcodeCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testutfnext", + TestUtfNextCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testutfprev", + TestUtfPrevCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testnumutfchars", TestNumUtfCharsCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testfindfirst", TestFindFirstCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testfindlast", TestFindLastCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd, NULL, NULL); - Tcl_CreateCommand(interp, "testsocket", TestSocketCmd, - NULL, NULL); Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd, NULL, NULL); Tcl_CreateCommand(interp, "testtranslatefilename", TesttranslatefilenameCmd, NULL, NULL); Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, NULL, NULL); + Tcl_CreateMathFunc(interp, "T1", 0, NULL, TestMathFunc, (ClientData) 123); + Tcl_CreateMathFunc(interp, "T2", 0, NULL, TestMathFunc, (ClientData) 345); Tcl_CreateCommand(interp, "testmainthread", TestmainthreadCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetmainloop", TestsetmainloopCmd, NULL, NULL); Tcl_CreateCommand(interp, "testexitmainloop", TestexitmainloopCmd, @@ -723,10 +602,15 @@ NULL, NULL); #if defined(HAVE_CPUID) || defined(_WIN32) Tcl_CreateObjCommand(interp, "testcpuid", TestcpuidCmd, NULL, NULL); #endif + t3ArgTypes[0] = TCL_EITHER; + t3ArgTypes[1] = TCL_EITHER; + Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2, + NULL); + Tcl_CreateObjCommand(interp, "testnreunwind", TestNREUnwind, NULL, NULL); Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels, NULL, NULL); Tcl_CreateObjCommand(interp, "testinterpresolver", TestInterpResolverCmd, @@ -736,11 +620,11 @@ return TCL_ERROR; } if (Procbodytest_Init(interp) != TCL_OK) { return TCL_ERROR; } -#if TCL_THREADS +#ifdef TCL_THREADS if (TclThread_Init(interp) != TCL_OK) { return TCL_ERROR; } #endif @@ -805,11 +689,11 @@ int Tcltest_SafeInit( Tcl_Interp *interp) /* Interpreter for application. */ { - if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { + if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { return TCL_ERROR; } return Procbodytest_SafeInit(interp); } @@ -828,21 +712,21 @@ * Creates, deletes, and invokes handlers. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int TestasyncCmd( - void *dummy, /* Not used. */ + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { TestAsyncHandler *asyncPtr, *prevPtr; int id, code; static int nextId = 1; + (void)dummy; if (argc < 2) { wrongNumArgs: Tcl_AppendResult(interp, "wrong # args", NULL); return TCL_ERROR; @@ -849,12 +733,12 @@ } if (strcmp(argv[1], "create") == 0) { if (argc != 3) { goto wrongNumArgs; } - asyncPtr = Tcl_Alloc(sizeof(TestAsyncHandler)); - asyncPtr->command = Tcl_Alloc(strlen(argv[2]) + 1); + asyncPtr = (TestAsyncHandler *)ckalloc(sizeof(TestAsyncHandler)); + asyncPtr->command = (char *)ckalloc(strlen(argv[2]) + 1); strcpy(asyncPtr->command, argv[2]); Tcl_MutexLock(&asyncTestMutex); asyncPtr->id = nextId; nextId++; asyncPtr->handler = Tcl_AsyncCreate(AsyncHandlerProc, @@ -868,12 +752,12 @@ Tcl_MutexLock(&asyncTestMutex); while (firstHandler != NULL) { asyncPtr = firstHandler; firstHandler = asyncPtr->nextPtr; Tcl_AsyncDelete(asyncPtr->handler); - Tcl_Free(asyncPtr->command); - Tcl_Free(asyncPtr); + ckfree(asyncPtr->command); + ckfree(asyncPtr); } Tcl_MutexUnlock(&asyncTestMutex); return TCL_OK; } if (argc != 3) { @@ -892,12 +776,12 @@ firstHandler = asyncPtr->nextPtr; } else { prevPtr->nextPtr = asyncPtr->nextPtr; } Tcl_AsyncDelete(asyncPtr->handler); - Tcl_Free(asyncPtr->command); - Tcl_Free(asyncPtr); + ckfree(asyncPtr->command); + ckfree(asyncPtr); break; } Tcl_MutexUnlock(&asyncTestMutex); } else if (strcmp(argv[1], "mark") == 0) { if (argc != 5) { @@ -916,11 +800,11 @@ } } Tcl_SetObjResult(interp, Tcl_NewStringObj(argv[3], -1)); Tcl_MutexUnlock(&asyncTestMutex); return code; -#if TCL_THREADS +#ifdef TCL_THREADS } else if (strcmp(argv[1], "marklater") == 0) { if (argc != 3) { goto wrongNumArgs; } if (Tcl_GetInt(interp, argv[2], &id) != TCL_OK) { @@ -956,20 +840,19 @@ return TCL_OK; } static int AsyncHandlerProc( - void *clientData, /* If of TestAsyncHandler structure. + ClientData clientData, /* If of TestAsyncHandler structure. * in global list. */ Tcl_Interp *interp, /* Interpreter in which command was * executed, or NULL. */ int code) /* Current return code from command. */ { TestAsyncHandler *asyncPtr; int id = PTR2INT(clientData); - const char *listArgv[4]; - char *cmd; + const char *listArgv[4], *cmd; char string[TCL_INTEGER_SPACE]; Tcl_MutexLock(&asyncTestMutex); for (asyncPtr = firstHandler; asyncPtr != NULL; asyncPtr = asyncPtr->nextPtr) { @@ -984,11 +867,11 @@ return TCL_OK; } TclFormatInt(string, code); listArgv[0] = asyncPtr->command; - listArgv[1] = Tcl_GetStringResult(interp); + listArgv[1] = Tcl_GetString(Tcl_GetObjResult(interp)); listArgv[2] = string; listArgv[3] = NULL; cmd = Tcl_Merge(3, listArgv); if (interp != NULL) { code = Tcl_EvalEx(interp, cmd, -1, 0); @@ -996,11 +879,11 @@ /* * this should not happen, but by definition of how async handlers are * invoked, it's possible. Better error checking is needed here. */ } - Tcl_Free(cmd); + ckfree(cmd); return code; } /* *---------------------------------------------------------------------- @@ -1016,14 +899,14 @@ * Invokes Tcl_AsyncMark on the handler * *---------------------------------------------------------------------- */ -#if TCL_THREADS +#ifdef TCL_THREADS static Tcl_ThreadCreateType AsyncThreadProc( - void *clientData) /* Parameter is the id of a + ClientData clientData) /* Parameter is the id of a * TestAsyncHandler, defined above. */ { TestAsyncHandler *asyncPtr; int id = PTR2INT(clientData); @@ -1039,10 +922,27 @@ Tcl_MutexUnlock(&asyncTestMutex); Tcl_ExitThread(TCL_OK); TCL_THREAD_CREATE_RETURN; } #endif + +static int +TestbumpinterpepochObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Interp *iPtr = (Interp *)interp; + + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, ""); + return TCL_ERROR; + } + iPtr->compileEpoch++; + return TCL_OK; +} /* *---------------------------------------------------------------------- * * TestcmdinfoCmd -- @@ -1058,27 +958,27 @@ * Creates and deletes various commands and modifies their data. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int TestcmdinfoCmd( - void *dummy, /* Not used. */ + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { Tcl_CmdInfo info; + (void)dummy; if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " option cmdName\"", NULL); return TCL_ERROR; } if (strcmp(argv[1], "create") == 0) { - Tcl_CreateCommand(interp, argv[2], CmdProc1, (void *) "original", + Tcl_CreateCommand(interp, argv[2], CmdProc1, (ClientData) "original", CmdDelProc1); } else if (strcmp(argv[1], "delete") == 0) { Tcl_DStringInit(&delString); Tcl_DeleteCommand(interp, argv[2]); Tcl_DStringResult(interp, &delString); @@ -1111,15 +1011,15 @@ } else { Tcl_AppendResult(interp, " stringProc", NULL); } } else if (strcmp(argv[1], "modify") == 0) { info.proc = CmdProc2; - info.clientData = (void *) "new_command_data"; + info.clientData = (ClientData) "new_command_data"; info.objProc = NULL; info.objClientData = NULL; info.deleteProc = CmdDelProc2; - info.deleteData = (void *) "new_delete_data"; + info.deleteData = (ClientData) "new_delete_data"; if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) { Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); } else { Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); } @@ -1129,26 +1029,24 @@ return TCL_ERROR; } return TCL_OK; } - /*ARGSUSED*/ static int CmdProc1( - void *clientData, /* String to return. */ + ClientData clientData, /* String to return. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { Tcl_AppendResult(interp, "CmdProc1 ", (char *) clientData, NULL); return TCL_OK; } - /*ARGSUSED*/ static int CmdProc2( - void *clientData, /* String to return. */ + ClientData clientData, /* String to return. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { Tcl_AppendResult(interp, "CmdProc2 ", (char *) clientData, NULL); @@ -1155,20 +1053,20 @@ return TCL_OK; } static void CmdDelProc1( - void *clientData) /* String to save. */ + ClientData 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. */ + ClientData clientData) /* String to save. */ { Tcl_DStringInit(&delString); Tcl_DStringAppend(&delString, "CmdDelProc2 ", -1); Tcl_DStringAppend(&delString, (char *) clientData, -1); } @@ -1188,14 +1086,13 @@ * Creates and deletes various commands and modifies their data. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int TestcmdtokenCmd( - void *dummy, /* Not used. */ + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { Tcl_Command token; @@ -1207,13 +1104,13 @@ " option arg\"", NULL); return TCL_ERROR; } if (strcmp(argv[1], "create") == 0) { token = Tcl_CreateCommand(interp, argv[2], CmdProc1, - (void *) "original", NULL); + (ClientData) "original", NULL); sprintf(buf, "%p", (void *)token); - Tcl_AppendResult(interp, buf, NULL); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } else if (strcmp(argv[1], "name") == 0) { Tcl_Obj *objPtr; if (sscanf(argv[2], "%p", &l) != 1) { Tcl_AppendResult(interp, "bad command token \"", argv[2], @@ -1252,14 +1149,13 @@ * a procedure by the command trace. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int TestcmdtraceCmd( - void *dummy, /* Not used. */ + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { Tcl_DString buffer; @@ -1311,15 +1207,15 @@ static int deleteCalled; deleteCalled = 0; cmdTrace = Tcl_CreateObjTrace(interp, 50000, TCL_ALLOW_INLINE_COMPILATION, ObjTraceProc, - &deleteCalled, ObjTraceDeleteProc); - result = Tcl_EvalEx(interp, argv[2], -1, 0); + (ClientData) &deleteCalled, ObjTraceDeleteProc); + result = Tcl_Eval(interp, argv[2]); Tcl_DeleteTrace(interp, cmdTrace); if (!deleteCalled) { - Tcl_AppendResult(interp, "Delete wasn't called", NULL); + Tcl_SetResult(interp, "Delete wasn't called", TCL_STATIC); return TCL_ERROR; } else { return result; } } else if (strcmp(argv[1], "doubletest") == 0) { @@ -1326,11 +1222,11 @@ Tcl_Trace t1, t2; Tcl_DStringInit(&buffer); t1 = Tcl_CreateTrace(interp, 1, CmdTraceProc, &buffer); t2 = Tcl_CreateTrace(interp, 50000, CmdTraceProc, &buffer); - result = Tcl_EvalEx(interp, argv[2], -1, 0); + result = Tcl_Eval(interp, argv[2]); if (result == TCL_OK) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL); } Tcl_DeleteTrace(interp, t2); @@ -1344,19 +1240,19 @@ return TCL_OK; } static void CmdTraceProc( - void *clientData, /* Pointer to buffer in which the + ClientData clientData, /* Pointer to buffer in which the * command and arguments are appended. * Accumulates test result. */ Tcl_Interp *interp, /* Current interpreter. */ int level, /* Current trace level. */ char *command, /* The command being traced (after * substitutions). */ Tcl_CmdProc *cmdProc, /* Points to command's command procedure. */ - void *cmdClientData, /* Client data associated with command + ClientData cmdClientData, /* Client data associated with command * procedure. */ int argc, /* Number of arguments. */ const char *argv[]) /* Argument strings. */ { Tcl_DString *bufPtr = (Tcl_DString *) clientData; @@ -1371,17 +1267,17 @@ Tcl_DStringEndSublist(bufPtr); } static void CmdTraceDeleteProc( - void *clientData, /* Unused. */ + ClientData clientData, /* Unused. */ Tcl_Interp *interp, /* Current interpreter. */ int level, /* Current trace level. */ char *command, /* The command being traced (after * substitutions). */ Tcl_CmdProc *cmdProc, /* Points to command's command procedure. */ - void *cmdClientData, /* Client data associated with command + ClientData cmdClientData, /* Client data associated with command * procedure. */ int argc, /* Number of arguments. */ const char *argv[]) /* Argument strings. */ { /* @@ -1393,11 +1289,11 @@ Tcl_DeleteTrace(interp, cmdTrace); } static int ObjTraceProc( - void *clientData, /* unused */ + ClientData clientData, /* unused */ Tcl_Interp *interp, /* Tcl interpreter */ int level, /* Execution level */ const char *command, /* Command being executed */ Tcl_Command token, /* Command information */ int objc, /* Parameter count */ @@ -1421,11 +1317,11 @@ } } static void ObjTraceDeleteProc( - void *clientData) + ClientData clientData) { int *intPtr = (int *) clientData; *intPtr = 1; /* Record that the trace was deleted */ } @@ -1450,11 +1346,11 @@ *---------------------------------------------------------------------- */ static int TestcreatecommandCmd( - void *dummy, /* Not used. */ + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { if (argc != 2) { @@ -1480,11 +1376,11 @@ return TCL_OK; } static int CreatedCommandProc( - void *clientData, /* String to return. */ + ClientData clientData, /* String to return. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { Tcl_CmdInfo info; @@ -1502,11 +1398,11 @@ return TCL_OK; } static int CreatedCommandProc2( - void *clientData, /* String to return. */ + ClientData clientData, /* String to return. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { Tcl_CmdInfo info; @@ -1538,14 +1434,13 @@ * Creates and deletes interpreters. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int TestdcallCmd( - void *dummy, /* Not used. */ + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { int i, id; @@ -1556,14 +1451,14 @@ if (Tcl_GetInt(interp, argv[i], &id) != TCL_OK) { return TCL_ERROR; } if (id < 0) { Tcl_DontCallWhenDeleted(delInterp, DelCallbackProc, - INT2PTR(-id)); + (ClientData) INT2PTR(-id)); } else { Tcl_CallWhenDeleted(delInterp, DelCallbackProc, - INT2PTR(id)); + (ClientData) INT2PTR(id)); } } Tcl_DeleteInterp(delInterp); Tcl_DStringResult(interp, &delString); return TCL_OK; @@ -1573,11 +1468,11 @@ * The deletion callback used by TestdcallCmd: */ static void DelCallbackProc( - void *clientData, /* Numerical value to append to delString. */ + ClientData clientData, /* Numerical value to append to delString. */ Tcl_Interp *interp) /* Interpreter being deleted. */ { int id = PTR2INT(clientData); char buffer[TCL_INTEGER_SPACE]; @@ -1603,66 +1498,65 @@ * Creates a command. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int TestdelCmd( - void *dummy, /* Not used. */ + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { DelCmd *dPtr; - Tcl_Interp *slave; + Tcl_Interp *child; if (argc != 4) { - Tcl_AppendResult(interp, "wrong # args", NULL); + Tcl_SetResult(interp, "wrong # args", TCL_STATIC); return TCL_ERROR; } - slave = Tcl_GetSlave(interp, argv[1]); - if (slave == NULL) { + child = Tcl_GetChild(interp, argv[1]); + if (child == NULL) { return TCL_ERROR; } - dPtr = Tcl_Alloc(sizeof(DelCmd)); + dPtr = (DelCmd *)ckalloc(sizeof(DelCmd)); dPtr->interp = interp; - dPtr->deleteCmd = Tcl_Alloc(strlen(argv[3]) + 1); + dPtr->deleteCmd = (char *)ckalloc(strlen(argv[3]) + 1); strcpy(dPtr->deleteCmd, argv[3]); - Tcl_CreateCommand(slave, argv[2], DelCmdProc, dPtr, + Tcl_CreateCommand(child, argv[2], DelCmdProc, (ClientData) dPtr, DelDeleteProc); return TCL_OK; } static int DelCmdProc( - void *clientData, /* String result to return. */ + ClientData clientData, /* String result to return. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { DelCmd *dPtr = (DelCmd *) clientData; Tcl_AppendResult(interp, dPtr->deleteCmd, NULL); - Tcl_Free(dPtr->deleteCmd); - Tcl_Free(dPtr); + ckfree(dPtr->deleteCmd); + ckfree(dPtr); return TCL_OK; } static void DelDeleteProc( - void *clientData) /* String command to evaluate. */ + ClientData clientData) /* String command to evaluate. */ { - DelCmd *dPtr = clientData; + DelCmd *dPtr = (DelCmd *)clientData; - Tcl_EvalEx(dPtr->interp, dPtr->deleteCmd, -1, 0); + Tcl_Eval(dPtr->interp, dPtr->deleteCmd); Tcl_ResetResult(dPtr->interp); - Tcl_Free(dPtr->deleteCmd); - Tcl_Free(dPtr); + ckfree(dPtr->deleteCmd); + ckfree(dPtr); } /* *---------------------------------------------------------------------- * @@ -1681,11 +1575,11 @@ *---------------------------------------------------------------------- */ static int TestdelassocdataCmd( - void *clientData, /* Not used. */ + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { if (argc != 2) { @@ -1710,18 +1604,18 @@ * testdoubledigits fpval ndigits type ?shorten" * * Parameters: * fpval - Floating-point value to format. * ndigits - Digit count to request from Tcl_DoubleDigits - * type - One of 'shortest', 'e', 'f' + * type - One of 'shortest', 'Steele', 'e', 'f' * shorten - Indicates that the 'shorten' flag should be passed in. * *----------------------------------------------------------------------------- */ static int -TestdoubledigitsObjCmd(void *unused, +TestdoubledigitsObjCmd(ClientData unused, /* NULL */ Tcl_Interp* interp, /* Tcl interpreter */ int objc, /* Parameter count */ @@ -1728,16 +1622,18 @@ Tcl_Obj* const objv[]) /* Parameter vector */ { static const char* options[] = { "shortest", + "Steele", "e", "f", NULL }; static const int types[] = { TCL_DD_SHORTEST, + TCL_DD_STEELE, TCL_DD_E_FORMAT, TCL_DD_F_FORMAT }; const Tcl_ObjType* doubleType; @@ -1757,12 +1653,12 @@ return TCL_ERROR; } status = Tcl_GetDoubleFromObj(interp, objv[1], &d); if (status != TCL_OK) { doubleType = Tcl_GetObjType("double"); - if (Tcl_FetchIntRep(objv[1], doubleType) - && TclIsNaN(objv[1]->internalRep.doubleValue)) { + if (objv[1]->typePtr == doubleType + || TclIsNaN(objv[1]->internalRep.doubleValue)) { status = TCL_OK; memcpy(&d, &(objv[1]->internalRep.doubleValue), sizeof(double)); } } if (status != TCL_OK @@ -1780,11 +1676,11 @@ } type |= TCL_DD_SHORTEN_FLAG; } str = TclDoubleDigits(d, ndigits, type, &decpt, &signum, &endPtr); strObj = Tcl_NewStringObj(str, endPtr-str); - Tcl_Free(str); + ckfree(str); retval = Tcl_NewListObj(1, &strObj); Tcl_ListObjAppendElement(NULL, retval, Tcl_NewIntObj(decpt)); strObj = Tcl_NewStringObj(signum ? "-" : "+", 1); Tcl_ListObjAppendElement(NULL, retval, strObj); Tcl_SetObjResult(interp, retval); @@ -1806,23 +1702,22 @@ * Creates, deletes, and invokes handlers. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int TestdstringCmd( - void *dummy, /* Not used. */ + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { int count; if (argc < 2) { wrongNumArgs: - Tcl_AppendResult(interp, "wrong # args", NULL); + Tcl_SetResult(interp, "wrong # args", TCL_STATIC); return TCL_ERROR; } if (strcmp(argv[1], "append") == 0) { if (argc != 4) { goto wrongNumArgs; @@ -1854,19 +1749,19 @@ } else if (strcmp(argv[1], "gresult") == 0) { if (argc != 3) { goto wrongNumArgs; } if (strcmp(argv[2], "staticsmall") == 0) { - Tcl_AppendResult(interp, "short", NULL); + Tcl_SetResult(interp, "short", TCL_STATIC); } else if (strcmp(argv[2], "staticlarge") == 0) { - Tcl_AppendResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", NULL); + Tcl_SetResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", TCL_STATIC); } else if (strcmp(argv[2], "free") == 0) { - char *s = Tcl_Alloc(100); + char *s = ckalloc(100); strcpy(s, "This is a malloc-ed string"); Tcl_SetResult(interp, s, TCL_DYNAMIC); } else if (strcmp(argv[2], "special") == 0) { - char *s = (char*)Tcl_Alloc(100) + 16; + char *s = (char*)ckalloc(100) + 16; strcpy(s, "This is a specially-allocated string"); Tcl_SetResult(interp, s, SpecialFree); } else { Tcl_AppendResult(interp, "bad gresult option \"", argv[2], "\": must be staticsmall, staticlarge, free, or special", @@ -1911,13 +1806,13 @@ * The procedure below is used as a special freeProc to test how well * Tcl_DStringGetResult handles freeProc's other than free. */ static void SpecialFree(blockPtr) - void *blockPtr; /* Block to free. */ + char *blockPtr; /* Block to free. */ { - Tcl_Free(((char *)blockPtr) - 16); + ckfree(blockPtr - 16); } /* *---------------------------------------------------------------------- * @@ -1933,14 +1828,13 @@ * Load encodings. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int TestencodingObjCmd( - void *dummy, /* Not used. */ + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Encoding encoding; @@ -1964,51 +1858,48 @@ Tcl_EncodingType type; if (objc != 5) { return TCL_ERROR; } - encodingPtr = Tcl_Alloc(sizeof(TclEncoding)); + encodingPtr = (TclEncoding *)ckalloc(sizeof(TclEncoding)); encodingPtr->interp = interp; string = Tcl_GetStringFromObj(objv[3], &length); - encodingPtr->toUtfCmd = Tcl_Alloc(length + 1); + encodingPtr->toUtfCmd = (char *)ckalloc(length + 1); memcpy(encodingPtr->toUtfCmd, string, length + 1); string = Tcl_GetStringFromObj(objv[4], &length); - encodingPtr->fromUtfCmd = Tcl_Alloc(length + 1); + encodingPtr->fromUtfCmd = (char *)ckalloc(length + 1); memcpy(encodingPtr->fromUtfCmd, string, length + 1); string = Tcl_GetStringFromObj(objv[2], &length); type.encodingName = string; type.toUtfProc = EncodingToUtfProc; type.fromUtfProc = EncodingFromUtfProc; type.freeProc = EncodingFreeProc; - type.clientData = encodingPtr; + type.clientData = (ClientData) encodingPtr; type.nullSize = 1; Tcl_CreateEncoding(&type); break; } case ENC_DELETE: if (objc != 3) { return TCL_ERROR; } - if (TCL_OK != Tcl_GetEncodingFromObj(interp, objv[2], &encoding)) { - return TCL_ERROR; - } - Tcl_FreeEncoding(encoding); /* Free returned reference */ - Tcl_FreeEncoding(encoding); /* Free to match CREATE */ - TclFreeIntRep(objv[2]); /* Free the cached ref */ + encoding = Tcl_GetEncoding(NULL, Tcl_GetString(objv[2])); + Tcl_FreeEncoding(encoding); + Tcl_FreeEncoding(encoding); break; } return TCL_OK; } static int EncodingToUtfProc( - void *clientData, /* TclEncoding structure. */ + ClientData clientData, /* TclEncoding structure. */ const char *src, /* Source string in specified encoding. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ Tcl_EncodingState *statePtr,/* Current state. */ char *dst, /* Output buffer. */ @@ -2019,11 +1910,11 @@ { int len; TclEncoding *encodingPtr; encodingPtr = (TclEncoding *) clientData; - Tcl_EvalEx(encodingPtr->interp, encodingPtr->toUtfCmd, -1, TCL_EVAL_GLOBAL); + Tcl_EvalEx(encodingPtr->interp,encodingPtr->toUtfCmd,-1,TCL_EVAL_GLOBAL); len = strlen(Tcl_GetStringResult(encodingPtr->interp)); if (len > dstLen) { len = dstLen; } @@ -2036,11 +1927,11 @@ return TCL_OK; } static int EncodingFromUtfProc( - void *clientData, /* TclEncoding structure. */ + ClientData clientData, /* TclEncoding structure. */ const char *src, /* Source string in specified encoding. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ Tcl_EncodingState *statePtr,/* Current state. */ char *dst, /* Output buffer. */ @@ -2051,11 +1942,11 @@ { int len; TclEncoding *encodingPtr; encodingPtr = (TclEncoding *) clientData; - Tcl_EvalEx(encodingPtr->interp, encodingPtr->fromUtfCmd, -1, TCL_EVAL_GLOBAL); + Tcl_EvalEx(encodingPtr->interp, encodingPtr->fromUtfCmd,-1,TCL_EVAL_GLOBAL); len = strlen(Tcl_GetStringResult(encodingPtr->interp)); if (len > dstLen) { len = dstLen; } @@ -2068,17 +1959,17 @@ return TCL_OK; } static void EncodingFreeProc( - void *clientData) /* ClientData associated with type. */ + ClientData clientData) /* ClientData associated with type. */ { - TclEncoding *encodingPtr = clientData; + TclEncoding *encodingPtr = (TclEncoding *)clientData; - Tcl_Free(encodingPtr->toUtfCmd); - Tcl_Free(encodingPtr->fromUtfCmd); - Tcl_Free(encodingPtr); + ckfree(encodingPtr->toUtfCmd); + ckfree(encodingPtr->fromUtfCmd); + ckfree(encodingPtr); } /* *---------------------------------------------------------------------- * @@ -2096,11 +1987,11 @@ *---------------------------------------------------------------------- */ static int TestevalexObjCmd( - void *dummy, /* Not used. */ + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int length, flags; @@ -2141,11 +2032,11 @@ *---------------------------------------------------------------------- */ static int TestevalobjvObjCmd( - void *dummy, /* Not used. */ + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int evalGlobal; @@ -2190,11 +2081,11 @@ *---------------------------------------------------------------------- */ static int TesteventObjCmd( - void *unused, /* Not used */ + ClientData unused, /* Not used */ Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj *const objv[]) /* Parameter vector */ { static const char *const subcommands[] = { /* Possible subcommands */ @@ -2229,11 +2120,11 @@ } if (Tcl_GetIndexFromObj(interp, objv[3], positions, "position specifier", TCL_EXACT, &posIndex) != TCL_OK) { return TCL_ERROR; } - ev = Tcl_Alloc(sizeof(TestEvent)); + ev = (TestEvent *)ckalloc(sizeof(TestEvent)); ev->header.proc = TesteventProc; ev->header.nextPtr = NULL; ev->interp = interp; ev->command = objv[4]; Tcl_IncrRefCount(ev->command); @@ -2287,18 +2178,18 @@ int retval; if (result != TCL_OK) { Tcl_AddErrorInfo(interp, " (command bound to \"testevent\" callback)"); - Tcl_BackgroundException(interp, TCL_ERROR); + Tcl_BackgroundError(interp); return 1; /* Avoid looping on errors */ } if (Tcl_GetBooleanFromObj(interp, Tcl_GetObjResult(interp), &retval) != TCL_OK) { Tcl_AddErrorInfo(interp, " (return value from \"testevent\" callback)"); - Tcl_BackgroundException(interp, TCL_ERROR); + Tcl_BackgroundError(interp); return 1; } if (retval) { Tcl_DecrRefCount(ev->tag); Tcl_DecrRefCount(ev->command); @@ -2326,11 +2217,11 @@ */ static int TesteventDeleteProc( Tcl_Event *event, /* Event to examine */ - void *clientData) /* Tcl_Obj containing the name of the event(s) + ClientData 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 */ @@ -2369,11 +2260,11 @@ *---------------------------------------------------------------------- */ static int TestexithandlerCmd( - void *clientData, /* Not used. */ + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { int value; @@ -2386,14 +2277,14 @@ if (Tcl_GetInt(interp, argv[2], &value) != TCL_OK) { return TCL_ERROR; } if (strcmp(argv[1], "create") == 0) { Tcl_CreateExitHandler((value & 1) ? ExitProcOdd : ExitProcEven, - INT2PTR(value)); + (ClientData) INT2PTR(value)); } else if (strcmp(argv[1], "delete") == 0) { Tcl_DeleteExitHandler((value & 1) ? ExitProcOdd : ExitProcEven, - INT2PTR(value)); + (ClientData) INT2PTR(value)); } else { Tcl_AppendResult(interp, "bad option \"", argv[1], "\": must be create or delete", NULL); return TCL_ERROR; } @@ -2400,32 +2291,32 @@ return TCL_OK; } static void ExitProcOdd( - void *clientData) /* Integer value to print. */ + ClientData clientData) /* Integer value to print. */ { char buf[16 + TCL_INTEGER_SPACE]; - size_t len; + int len; - sprintf(buf, "odd %" TCL_Z_MODIFIER "d\n", (size_t)PTR2INT(clientData)); + sprintf(buf, "odd %d\n", (int)PTR2INT(clientData)); len = strlen(buf); - if (len != (size_t) write(1, buf, len)) { + if (len != (int) write(1, buf, len)) { Tcl_Panic("ExitProcOdd: unable to write to stdout"); } } static void ExitProcEven( - void *clientData) /* Integer value to print. */ + ClientData clientData) /* Integer value to print. */ { char buf[16 + TCL_INTEGER_SPACE]; - size_t len; + int len; - sprintf(buf, "even %" TCL_Z_MODIFIER "d\n", (size_t)PTR2INT(clientData)); + sprintf(buf, "even %d\n", (int)PTR2INT(clientData)); len = strlen(buf); - if (len != (size_t) write(1, buf, len)) { + if (len != (int) write(1, buf, len)) { Tcl_Panic("ExitProcEven: unable to write to stdout"); } } /* @@ -2445,11 +2336,11 @@ *---------------------------------------------------------------------- */ static int TestexprlongCmd( - void *clientData, /* Not used. */ + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { long exprResult; @@ -2459,11 +2350,11 @@ if (argc != 2) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], " expression\"", NULL); return TCL_ERROR; } - Tcl_AppendResult(interp, "This is a result", NULL); + Tcl_SetResult(interp, "This is a result", TCL_STATIC); result = Tcl_ExprLong(interp, argv[1], &exprResult); if (result != TCL_OK) { return result; } sprintf(buf, ": %ld", exprResult); @@ -2488,11 +2379,11 @@ *---------------------------------------------------------------------- */ static int TestexprlongobjCmd( - void *clientData, /* Not used. */ + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Argument objects. */ { long exprResult; @@ -2501,11 +2392,11 @@ if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "expression"); return TCL_ERROR; } - Tcl_AppendResult(interp, "This is a result", NULL); + Tcl_SetResult(interp, "This is a result", TCL_STATIC); result = Tcl_ExprLongObj(interp, objv[1], &exprResult); if (result != TCL_OK) { return result; } sprintf(buf, ": %ld", exprResult); @@ -2530,11 +2421,11 @@ *---------------------------------------------------------------------- */ static int TestexprdoubleCmd( - void *clientData, /* Not used. */ + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { double exprResult; @@ -2544,11 +2435,11 @@ if (argc != 2) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], " expression\"", NULL); return TCL_ERROR; } - Tcl_AppendResult(interp, "This is a result", NULL); + Tcl_SetResult(interp, "This is a result", TCL_STATIC); result = Tcl_ExprDouble(interp, argv[1], &exprResult); if (result != TCL_OK) { return result; } strcpy(buf, ": "); @@ -2574,11 +2465,11 @@ *---------------------------------------------------------------------- */ static int TestexprdoubleobjCmd( - void *clientData, /* Not used. */ + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Argument objects. */ { double exprResult; @@ -2587,11 +2478,11 @@ if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "expression"); return TCL_ERROR; } - Tcl_AppendResult(interp, "This is a result", NULL); + Tcl_SetResult(interp, "This is a result", TCL_STATIC); result = Tcl_ExprDoubleObj(interp, objv[1], &exprResult); if (result != TCL_OK) { return result; } strcpy(buf, ": "); @@ -2616,11 +2507,11 @@ *---------------------------------------------------------------------- */ static int TestexprstringCmd( - void *clientData, /* Not used. */ + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { if (argc != 2) { @@ -2648,11 +2539,11 @@ *---------------------------------------------------------------------- */ static int TestfilelinkCmd( - void *clientData, /* Not used. */ + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { Tcl_Obj *contents; @@ -2715,11 +2606,11 @@ *---------------------------------------------------------------------- */ static int TestgetassocdataCmd( - void *clientData, /* Not used. */ + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { char *res; @@ -2753,11 +2644,11 @@ *---------------------------------------------------------------------- */ static int TestgetplatformCmd( - void *clientData, /* Not used. */ + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { static const char *const platformStrings[] = { "unix", "mac", "windows" }; @@ -2791,30 +2682,29 @@ * Deletes one or more interpreters. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int TestinterpdeleteCmd( - void *dummy, /* Not used. */ + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { - Tcl_Interp *slaveToDelete; + Tcl_Interp *childToDelete; if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " path\"", NULL); return TCL_ERROR; } - slaveToDelete = Tcl_GetSlave(interp, argv[1]); - if (slaveToDelete == NULL) { + childToDelete = Tcl_GetChild(interp, argv[1]); + if (childToDelete == NULL) { return TCL_ERROR; } - Tcl_DeleteInterp(slaveToDelete); + Tcl_DeleteInterp(childToDelete); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -2832,32 +2722,31 @@ * values of the linked variables. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int TestlinkCmd( - void *dummy, /* Not used. */ + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { static int intVar = 43; static int boolVar = 4; static double realVar = 1.23; - static Tcl_WideInt wideVar = 79; + static Tcl_WideInt wideVar = Tcl_LongAsWide(79); static char *stringVar = NULL; static char charVar = '@'; static unsigned char ucharVar = 130; static short shortVar = 3000; static unsigned short ushortVar = 60000; - static unsigned int uintVar = 0xbeeffeed; + static unsigned int uintVar = 0xBEEFFEED; static long longVar = 123456789L; static unsigned long ulongVar = 3456789012UL; static float floatVar = 4.5; - static Tcl_WideUInt uwideVar = 123; + static Tcl_WideUInt uwideVar = (Tcl_WideUInt) Tcl_LongAsWide(123); static int created = 0; char buffer[2*TCL_DOUBLE_SPACE]; int writable, flag; Tcl_Obj *tmp; @@ -3043,14 +2932,14 @@ Tcl_AppendElement(interp, buffer); TclFormatInt(buffer, (int) ushortVar); Tcl_AppendElement(interp, buffer); TclFormatInt(buffer, (int) uintVar); Tcl_AppendElement(interp, buffer); - tmp = Tcl_NewWideIntObj(longVar); + tmp = Tcl_NewLongObj(longVar); Tcl_AppendElement(interp, Tcl_GetString(tmp)); Tcl_DecrRefCount(tmp); - tmp = Tcl_NewWideIntObj((long)ulongVar); + tmp = Tcl_NewLongObj((long)ulongVar); Tcl_AppendElement(interp, Tcl_GetString(tmp)); Tcl_DecrRefCount(tmp); Tcl_PrintDouble(NULL, (double)floatVar, buffer); Tcl_AppendElement(interp, buffer); tmp = Tcl_NewWideIntObj((Tcl_WideInt)uwideVar); @@ -3082,16 +2971,16 @@ return TCL_ERROR; } } if (argv[5][0] != 0) { if (stringVar != NULL) { - Tcl_Free(stringVar); + ckfree(stringVar); } if (strcmp(argv[5], "-") == 0) { stringVar = NULL; } else { - stringVar = Tcl_Alloc(strlen(argv[5]) + 1); + stringVar = (char *)ckalloc(strlen(argv[5]) + 1); strcpy(stringVar, argv[5]); } } if (argv[6][0] != 0) { tmp = Tcl_NewStringObj(argv[6], -1); @@ -3189,16 +3078,16 @@ } Tcl_UpdateLinkedVar(interp, "bool"); } if (argv[5][0] != 0) { if (stringVar != NULL) { - Tcl_Free(stringVar); + ckfree(stringVar); } if (strcmp(argv[5], "-") == 0) { stringVar = NULL; } else { - stringVar = Tcl_Alloc(strlen(argv[5]) + 1); + stringVar = (char *)ckalloc(strlen(argv[5]) + 1); strcpy(stringVar, argv[5]); } Tcl_UpdateLinkedVar(interp, "string"); } if (argv[6][0] != 0) { @@ -3287,128 +3176,10 @@ } /* *---------------------------------------------------------------------- * - * TestlinkarrayCmd -- - * - * This function is invoked to process the "testlinkarray" Tcl command. - * It is used to test the 'Tcl_LinkArray' function. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Creates, deletes, and invokes variable links. - * - *---------------------------------------------------------------------- - */ - -static int -TestlinkarrayCmd( - ClientData dummy, /* Not used. */ - 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 LinkOption { LINK_UPDATE, LINK_REMOVE, LINK_CREATE }; - static const char *LinkType[] = { - "char", "uchar", "short", "ushort", "int", "uint", "long", "ulong", - "wide", "uwide", "float", "double", "string", "char*", "binary", NULL - }; - /* all values after TCL_LINK_CHARS_ARRAY are used as arrays (see below) */ - static int LinkTypes[] = { - TCL_LINK_CHAR, TCL_LINK_UCHAR, - TCL_LINK_SHORT, TCL_LINK_USHORT, TCL_LINK_INT, TCL_LINK_UINT, - TCL_LINK_LONG, TCL_LINK_ULONG, TCL_LINK_WIDE_INT, TCL_LINK_WIDE_UINT, - TCL_LINK_FLOAT, TCL_LINK_DOUBLE, TCL_LINK_STRING, TCL_LINK_CHARS, - TCL_LINK_BINARY - }; - int optionIndex, typeIndex, readonly, i, size, length; - char *name, *arg; - Tcl_WideInt addr; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option args"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[1], LinkOption, "option", 0, - &optionIndex) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum LinkOption) optionIndex) { - case LINK_UPDATE: - for (i=2; itype = TCL_INT; + resultPtr->intValue = PTR2INT(clientData); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestMathFunc2 -- + * + * This is a user-defined math procedure to test out math procedures + * that do have arguments, in this case 2. + * + * Results: + * A normal Tcl completion code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestMathFunc2( + ClientData clientData, /* Integer value to return. */ + Tcl_Interp *interp, /* Used to report errors. */ + Tcl_Value *args, /* Points to an array of two Tcl_Value structs + * for the two arguments. */ + Tcl_Value *resultPtr) /* Where to store the result. */ +{ + int result = TCL_OK; + + /* + * Return the maximum of the two arguments with the correct type. + */ + + if (args[0].type == TCL_INT) { + int i0 = args[0].intValue; + + if (args[1].type == TCL_INT) { + int i1 = args[1].intValue; + + resultPtr->type = TCL_INT; + resultPtr->intValue = ((i0 > i1)? i0 : i1); + } else if (args[1].type == TCL_DOUBLE) { + double d0 = i0; + double d1 = args[1].doubleValue; + + resultPtr->type = TCL_DOUBLE; + resultPtr->doubleValue = ((d0 > d1)? d0 : d1); + } else if (args[1].type == TCL_WIDE_INT) { + Tcl_WideInt w0 = Tcl_LongAsWide(i0); + Tcl_WideInt w1 = args[1].wideValue; + + resultPtr->type = TCL_WIDE_INT; + resultPtr->wideValue = ((w0 > w1)? w0 : w1); + } else { + Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC); + result = TCL_ERROR; + } + } else if (args[0].type == TCL_DOUBLE) { + double d0 = args[0].doubleValue; + + if (args[1].type == TCL_INT) { + double d1 = args[1].intValue; + + resultPtr->type = TCL_DOUBLE; + resultPtr->doubleValue = ((d0 > d1)? d0 : d1); + } else if (args[1].type == TCL_DOUBLE) { + double d1 = args[1].doubleValue; + + resultPtr->type = TCL_DOUBLE; + resultPtr->doubleValue = ((d0 > d1)? d0 : d1); + } else if (args[1].type == TCL_WIDE_INT) { + double d1 = Tcl_WideAsDouble(args[1].wideValue); + + resultPtr->type = TCL_DOUBLE; + resultPtr->doubleValue = ((d0 > d1)? d0 : d1); + } else { + Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC); + result = TCL_ERROR; + } + } else if (args[0].type == TCL_WIDE_INT) { + Tcl_WideInt w0 = args[0].wideValue; + + if (args[1].type == TCL_INT) { + Tcl_WideInt w1 = Tcl_LongAsWide(args[1].intValue); + + resultPtr->type = TCL_WIDE_INT; + resultPtr->wideValue = ((w0 > w1)? w0 : w1); + } else if (args[1].type == TCL_DOUBLE) { + double d0 = Tcl_WideAsDouble(w0); + double d1 = args[1].doubleValue; + + resultPtr->type = TCL_DOUBLE; + resultPtr->doubleValue = ((d0 > d1)? d0 : d1); + } else if (args[1].type == TCL_WIDE_INT) { + Tcl_WideInt w1 = args[1].wideValue; + + resultPtr->type = TCL_WIDE_INT; + resultPtr->wideValue = ((w0 > w1)? w0 : w1); + } else { + Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC); + result = TCL_ERROR; + } + } else { + Tcl_SetResult(interp, "T3: wrong type for arg 1", TCL_STATIC); + result = TCL_ERROR; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * * CleanupTestSetassocdataTests -- * * This function is called when an interpreter is deleted to clean * up any data left over from running the testsetassocdata command. * @@ -3480,17 +3387,16 @@ * Side effects: * Releases storage. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ static void CleanupTestSetassocdataTests( - void *clientData, /* Data to be released. */ + ClientData clientData, /* Data to be released. */ Tcl_Interp *interp) /* Interpreter being deleted. */ { - Tcl_Free(clientData); + ckfree(clientData); } /* *---------------------------------------------------------------------- * @@ -3508,11 +3414,11 @@ *---------------------------------------------------------------------- */ static int TestparserObjCmd( - void *clientData, /* Not used. */ + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { const char *script; @@ -3564,11 +3470,11 @@ *---------------------------------------------------------------------- */ static int TestexprparserObjCmd( - void *clientData, /* Not used. */ + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { const char *script; @@ -3711,11 +3617,11 @@ *---------------------------------------------------------------------- */ static int TestparsevarObjCmd( - void *clientData, /* Not used. */ + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { const char *value, *name, *termPtr; @@ -3752,11 +3658,11 @@ *---------------------------------------------------------------------- */ static int TestparsevarnameObjCmd( - void *clientData, /* Not used. */ + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { const char *script; @@ -3798,79 +3704,10 @@ } /* *---------------------------------------------------------------------- * - * TestpreferstableObjCmd -- - * - * This procedure implements the "testpreferstable" command. It is - * used for being able to test the "package" command even when the - * environment variable TCL_PKG_PREFER_LATEST is set in your environment. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestpreferstableObjCmd( - void *clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* The argument objects. */ -{ - Interp *iPtr = (Interp *) interp; - iPtr->packagePrefer = PKG_PREFER_STABLE; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TestprintObjCmd -- - * - * This procedure implements the "testprint" command. It is - * used for being able to test the Tcl_ObjPrintf() function. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestprintObjCmd( - void *clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* The argument objects. */ -{ - Tcl_WideInt argv1 = 0; - size_t argv2; - - if (objc < 2 || objc > 3) { - Tcl_WrongNumArgs(interp, 1, objv, "format wideint"); - } - - if (objc > 1) { - Tcl_GetWideIntFromObj(interp, objv[2], &argv1); - } - argv2 = (size_t)argv1; - Tcl_SetObjResult(interp, Tcl_ObjPrintf(Tcl_GetString(objv[1]), argv1, argv2, argv2)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * * TestregexpObjCmd -- * * This procedure implements the "testregexp" command. It is used to give * a direct interface for regexp flags. It's identical to * Tcl_RegexpObjCmd except for the -xflags option, and the consequences @@ -3883,20 +3720,18 @@ * See the user documentation. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int TestregexpObjCmd( - void *dummy, /* Not used. */ + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int i, indices, stringLength, match, about; - size_t ii; + int i, ii, indices, stringLength, match, about; int hasxflags, cflags, eflags; Tcl_RegExp regExpr; const char *string; Tcl_Obj *objPtr; Tcl_RegExpInfo info; @@ -4005,17 +3840,17 @@ Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); if (objc > 2 && (cflags®_EXPECT) && indices) { const char *varName; const char *value; - size_t start, end; + int start, end; char resinfo[TCL_INTEGER_SPACE * 2]; varName = Tcl_GetString(objv[2]); TclRegExpRangeUniChar(regExpr, -1, &start, &end); - sprintf(resinfo, "%" TCL_LL_MODIFIER "d %" TCL_LL_MODIFIER "d", TclWideIntFromSize(start), TclWideIntFromSize(end-1)); - value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0); + sprintf(resinfo, "%d %d", start, end-1); + value = Tcl_SetVar(interp, varName, resinfo, 0); if (value == NULL) { Tcl_AppendResult(interp, "couldn't set variable \"", varName, "\"", NULL); return TCL_ERROR; } @@ -4024,12 +3859,12 @@ const char *value; char resinfo[TCL_INTEGER_SPACE * 2]; Tcl_RegExpGetInfo(regExpr, &info); varName = Tcl_GetString(objv[2]); - sprintf(resinfo, "%" TCL_LL_MODIFIER "d", TclWideIntFromSize(info.extendStart)); - value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0); + sprintf(resinfo, "%ld", info.extendStart); + value = Tcl_SetVar(interp, varName, resinfo, 0); if (value == NULL) { Tcl_AppendResult(interp, "couldn't set variable \"", varName, "\"", NULL); return TCL_ERROR; } @@ -4045,23 +3880,23 @@ objc -= 2; objv += 2; Tcl_RegExpGetInfo(regExpr, &info); for (i = 0; i < objc; i++) { - size_t start, end; + int start, end; Tcl_Obj *newPtr, *varPtr, *valuePtr; varPtr = objv[i]; - ii = ((cflags®_EXPECT) && i == objc-1) ? TCL_INDEX_NONE : (size_t)i; + ii = ((cflags®_EXPECT) && i == objc-1) ? -1 : i; if (indices) { Tcl_Obj *objs[2]; - if (ii == TCL_INDEX_NONE) { + if (ii == -1) { TclRegExpRangeUniChar(regExpr, ii, &start, &end); } else if (ii > info.nsubs) { - start = TCL_INDEX_NONE; - end = TCL_INDEX_NONE; + start = -1; + end = -1; } else { start = info.matches[ii].start; end = info.matches[ii].end; } @@ -4068,20 +3903,20 @@ /* * Adjust index so it refers to the last character in the match * instead of the first character after the match. */ - if (end != TCL_INDEX_NONE) { + if (end >= 0) { end--; } - objs[0] = TclNewWideIntObjFromSize(start); - objs[1] = TclNewWideIntObjFromSize(end); + objs[0] = Tcl_NewLongObj(start); + objs[1] = Tcl_NewLongObj(end); newPtr = Tcl_NewListObj(2, objs); } else { - if (ii == TCL_INDEX_NONE) { + if (ii == -1) { TclRegExpRangeUniChar(regExpr, ii, &start, &end); newPtr = Tcl_GetRange(objPtr, start, end); } else if (ii > info.nsubs) { newPtr = Tcl_NewObj(); } else { @@ -4121,16 +3956,15 @@ */ static void TestregexpXflags( const char *string, /* The string of flags. */ - size_t length, /* The length of the string in bytes. */ + int length, /* The length of the string in bytes. */ int *cflagsPtr, /* compile flags word */ int *eflagsPtr) /* exec flags word */ { - size_t i; - int cflags, eflags; + int i, cflags, eflags; cflags = *cflagsPtr; eflags = *eflagsPtr; for (i = 0; i < length; i++) { switch (string[i]) { @@ -4209,14 +4043,13 @@ * See the user documentation. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int TestreturnObjCmd( - void *dummy, /* Not used. */ + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { return TCL_RETURN; @@ -4240,11 +4073,11 @@ *---------------------------------------------------------------------- */ static int TestsetassocdataCmd( - void *clientData, /* Not used. */ + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { char *buf, *oldData; @@ -4254,24 +4087,25 @@ Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], " data_key data_item\"", NULL); return TCL_ERROR; } - buf = Tcl_Alloc(strlen(argv[2]) + 1); + buf = ckalloc(strlen(argv[2]) + 1); strcpy(buf, argv[2]); /* * If we previously associated a malloced value with the variable, * free it before associating a new value. */ oldData = (char *) Tcl_GetAssocData(interp, argv[1], &procPtr); if ((oldData != NULL) && (procPtr == CleanupTestSetassocdataTests)) { - Tcl_Free(oldData); + ckfree(oldData); } - Tcl_SetAssocData(interp, argv[1], CleanupTestSetassocdataTests, buf); + Tcl_SetAssocData(interp, argv[1], CleanupTestSetassocdataTests, + (ClientData) buf); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -4291,11 +4125,11 @@ *---------------------------------------------------------------------- */ static int TestsetplatformCmd( - void *clientData, /* Not used. */ + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { size_t length; @@ -4340,11 +4174,11 @@ *---------------------------------------------------------------------- */ static int TeststaticpkgCmd( - void *dummy, /* Not used. */ + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { int safe, loaded; @@ -4358,21 +4192,21 @@ return TCL_ERROR; } if (Tcl_GetInt(interp, argv[3], &loaded) != TCL_OK) { return TCL_ERROR; } - Tcl_StaticPackage((loaded) ? interp : NULL, argv[1], + tclStubsPtr->tcl_StaticPackage((loaded) ? interp : NULL, argv[1], StaticInitProc, (safe) ? StaticInitProc : NULL); return TCL_OK; } static int StaticInitProc( Tcl_Interp *interp) /* Interpreter in which package is supposedly * being loaded. */ { - Tcl_SetVar2(interp, "x", NULL, "loaded", TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "x", "loaded", TCL_GLOBAL_ONLY); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -4391,11 +4225,11 @@ *---------------------------------------------------------------------- */ static int TesttranslatefilenameCmd( - void *dummy, /* Not used. */ + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { Tcl_DString buffer; @@ -4430,14 +4264,13 @@ * Creates or modifies an "upvar" reference. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int TestupvarCmd( - void *dummy, /* Not used. */ + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { int flags = 0; @@ -4452,11 +4285,11 @@ if (strcmp(argv[4], "global") == 0) { flags = TCL_GLOBAL_ONLY; } else if (strcmp(argv[4], "namespace") == 0) { flags = TCL_NAMESPACE_ONLY; } - return Tcl_UpVar2(interp, argv[1], argv[2], NULL, argv[3], flags); + return Tcl_UpVar(interp, argv[1], argv[2], argv[3], flags); } else { if (strcmp(argv[5], "global") == 0) { flags = TCL_GLOBAL_ONLY; } else if (strcmp(argv[5], "namespace") == 0) { flags = TCL_NAMESPACE_ONLY; @@ -4483,20 +4316,19 @@ * None. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int TestseterrorcodeCmd( - void *dummy, /* Not used. */ + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { if (argc > 6) { - Tcl_AppendResult(interp, "too many args", NULL); + Tcl_SetResult(interp, "too many args", TCL_STATIC); return TCL_ERROR; } switch (argc) { case 1: Tcl_SetErrorCode(interp, "NONE", NULL); @@ -4536,14 +4368,13 @@ * None. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int TestsetobjerrorcodeCmd( - void *dummy, /* Not used. */ + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { Tcl_SetObjErrorCode(interp, Tcl_ConcatObj(objc - 1, objv + 1)); @@ -4565,14 +4396,13 @@ * Creates and deletes interpreters. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int TestfeventCmd( - void *clientData, /* Not used. */ + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { static Tcl_Interp *interp2 = NULL; @@ -4640,11 +4470,11 @@ *---------------------------------------------------------------------- */ static int TestpanicCmd( - void *dummy, /* Not used. */ + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { char *argString; @@ -4654,18 +4484,18 @@ * Append all of the arguments together separated by spaces */ argString = Tcl_Merge(argc-1, argv+1); Tcl_Panic("%s", argString); - Tcl_Free(argString); + ckfree(argString); return TCL_OK; } static int TestfileCmd( - void *dummy, /* Not used. */ + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ Tcl_Obj *const argv[]) /* The argument objects. */ { int force, i, j, result; @@ -4743,11 +4573,11 @@ *---------------------------------------------------------------------- */ static int TestgetvarfullnameCmd( - void *dummy, /* Not used. */ + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { const char *name, *arg; @@ -4817,50 +4647,52 @@ *---------------------------------------------------------------------- */ static int GetTimesObjCmd( - void *unused, /* Unused. */ + ClientData unused, /* Unused. */ Tcl_Interp *interp, /* The current interpreter. */ - int notused1, /* Number of arguments. */ - Tcl_Obj *const notused2[]) /* The argument objects. */ + int objc, /* Number of arguments. (not used)*/ + Tcl_Obj *const dummy[]) /* The argument objects (not used). */ { Interp *iPtr = (Interp *) interp; int i, n; double timePer; Tcl_Time start, stop; Tcl_Obj *objPtr, **objv; const char *s; char newString[TCL_INTEGER_SPACE]; + (void)objc; + (void)dummy; /* alloc & free 100000 times */ fprintf(stderr, "alloc & free 100000 6 word items\n"); Tcl_GetTime(&start); for (i = 0; i < 100000; i++) { - objPtr = Tcl_Alloc(sizeof(Tcl_Obj)); - Tcl_Free(objPtr); + objPtr = (Tcl_Obj *)ckalloc(sizeof(Tcl_Obj)); + ckfree(objPtr); } Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); fprintf(stderr, " %.3f usec per alloc+free\n", timePer/100000); /* alloc 5000 times */ fprintf(stderr, "alloc 5000 6 word items\n"); - objv = Tcl_Alloc(5000 * sizeof(Tcl_Obj *)); + objv = (Tcl_Obj **) ckalloc(5000 * sizeof(Tcl_Obj *)); Tcl_GetTime(&start); for (i = 0; i < 5000; i++) { - objv[i] = Tcl_Alloc(sizeof(Tcl_Obj)); + objv[i] = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj)); } Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); fprintf(stderr, " %.3f usec per alloc\n", timePer/5000); /* free 5000 times */ fprintf(stderr, "free 5000 6 word items\n"); Tcl_GetTime(&start); for (i = 0; i < 5000; i++) { - Tcl_Free(objv[i]); + ckfree(objv[i]); } Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); fprintf(stderr, " %.3f usec per free\n", timePer/5000); @@ -4882,11 +4714,11 @@ Tcl_DecrRefCount(objPtr); } Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); fprintf(stderr, " %.3f usec per Tcl_DecrRefCount\n", timePer/5000); - Tcl_Free(objv); + ckfree(objv); /* TclGetString 100000 times */ fprintf(stderr, "TclGetStringFromObj of \"12345\" 100000 times\n"); objPtr = Tcl_NewStringObj("12345", -1); Tcl_GetTime(&start); @@ -4946,14 +4778,14 @@ timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); fprintf(stderr, " %.3f usec per hashtable lookup of \"gettimes\"\n", timePer/100000); /* Tcl_SetVar 100000 times */ - fprintf(stderr, "Tcl_SetVar2 of \"12345\" 100000 times\n"); + fprintf(stderr, "Tcl_SetVar of \"12345\" 100000 times\n"); Tcl_GetTime(&start); for (i = 0; i < 100000; i++) { - s = Tcl_SetVar2(interp, "a", NULL, "12345", TCL_LEAVE_ERR_MSG); + s = Tcl_SetVar(interp, "a", "12345", TCL_LEAVE_ERR_MSG); if (s == NULL) { return TCL_ERROR; } } Tcl_GetTime(&stop); @@ -4963,11 +4795,11 @@ /* Tcl_GetVar 100000 times */ fprintf(stderr, "Tcl_GetVar of a==\"12345\" 100000 times\n"); Tcl_GetTime(&start); for (i = 0; i < 100000; i++) { - s = Tcl_GetVar2(interp, "a", NULL, TCL_LEAVE_ERR_MSG); + s = Tcl_GetVar(interp, "a", TCL_LEAVE_ERR_MSG); if (s == NULL) { return TCL_ERROR; } } Tcl_GetTime(&stop); @@ -4996,11 +4828,11 @@ *---------------------------------------------------------------------- */ static int NoopCmd( - void *unused, /* Unused. */ + ClientData unused, /* Unused. */ Tcl_Interp *interp, /* The current interpreter. */ int argc, /* The number of arguments. */ const char **argv) /* The argument strings. */ { return TCL_OK; @@ -5023,11 +4855,11 @@ *---------------------------------------------------------------------- */ static int NoopObjCmd( - void *unused, /* Not used. */ + ClientData unused, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { return TCL_OK; @@ -5048,17 +4880,18 @@ *---------------------------------------------------------------------- */ static int TeststringbytesObjCmd( - void *unused, /* Not used. */ + ClientData dummy, Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { int n; const unsigned char *p; + (void)dummy; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "value"); return TCL_ERROR; } @@ -5088,16 +4921,17 @@ *---------------------------------------------------------------------- */ static int TestpurebytesobjObjCmd( - ClientData unused, /* Not used. */ + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { Tcl_Obj *objPtr; + (void)dummy; if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "?string?"); return TCL_ERROR; } @@ -5108,17 +4942,62 @@ */ memset(&objPtr->internalRep, 0, sizeof(objPtr->internalRep)); if (objc == 2) { const char *s = Tcl_GetString(objv[1]); objPtr->length = objv[1]->length; - objPtr->bytes = Tcl_Alloc(objPtr->length + 1); + objPtr->bytes = (char *)ckalloc(objPtr->length + 1); memcpy(objPtr->bytes, s, objPtr->length); objPtr->bytes[objPtr->length] = 0; } Tcl_SetObjResult(interp, objPtr); return TCL_OK; } + +/* + *---------------------------------------------------------------------- + * + * TestsetbytearraylengthObjCmd -- + * + * Testing command 'testsetbytearraylength` used to test the public + * interface routine Tcl_SetByteArrayLength(). + * + * Results: + * Returns the TCL_OK result code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestsetbytearraylengthObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ +{ + int n; + Tcl_Obj *obj = NULL; + (void)dummy; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "value length"); + return TCL_ERROR; + } + if (TCL_OK != Tcl_GetIntFromObj(interp, objv[2], &n)) { + return TCL_ERROR; + } + if (Tcl_IsShared(objv[1])) { + obj = Tcl_DuplicateObj(objv[1]); + } else { + obj = objv[1]; + } + Tcl_SetByteArrayLength(obj, n); + Tcl_SetObjResult(interp, obj); + return TCL_OK; +} /* *---------------------------------------------------------------------- * * TestbytestringObjCmd -- @@ -5135,27 +5014,25 @@ *---------------------------------------------------------------------- */ static int TestbytestringObjCmd( - void *unused, /* Not used. */ + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { int n = 0; const char *p; + (void)dummy; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "bytearray"); return TCL_ERROR; } + p = (const char *)Tcl_GetByteArrayFromObj(objv[1], &n); - if ((p == NULL) || !Tcl_FetchIntRep(objv[1], properByteArrayType)) { - Tcl_AppendResult(interp, "testbytestring expects bytes", NULL); - return TCL_ERROR; - } Tcl_SetObjResult(interp, Tcl_NewStringObj(p, n)); return TCL_OK; } /* @@ -5173,31 +5050,30 @@ * Variables may be set. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int TestsetCmd( - void *data, /* Additional flags for Get/SetVar2. */ - register Tcl_Interp *interp,/* Current interpreter. */ + ClientData data, /* Additional flags for Get/SetVar2. */ + Tcl_Interp *interp,/* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { int flags = PTR2INT(data); const char *value; if (argc == 2) { - Tcl_AppendResult(interp, "before get", NULL); + Tcl_SetResult(interp, "before get", TCL_STATIC); value = Tcl_GetVar2(interp, argv[1], NULL, flags); if (value == NULL) { return TCL_ERROR; } Tcl_AppendElement(interp, value); return TCL_OK; } else if (argc == 3) { - Tcl_AppendResult(interp, "before set", NULL); + Tcl_SetResult(interp, "before set", TCL_STATIC); value = Tcl_SetVar2(interp, argv[1], NULL, argv[2], flags); if (value == NULL) { return TCL_ERROR; } Tcl_AppendElement(interp, value); @@ -5208,28 +5084,28 @@ return TCL_ERROR; } } static int Testset2Cmd( - void *data, /* Additional flags for Get/SetVar2. */ - register Tcl_Interp *interp,/* Current interpreter. */ + ClientData data, /* Additional flags for Get/SetVar2. */ + Tcl_Interp *interp,/* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { int flags = PTR2INT(data); const char *value; if (argc == 3) { - Tcl_AppendResult(interp, "before get", NULL); + Tcl_SetResult(interp, "before get", TCL_STATIC); value = Tcl_GetVar2(interp, argv[1], argv[2], flags); if (value == NULL) { return TCL_ERROR; } Tcl_AppendElement(interp, value); return TCL_OK; } else if (argc == 4) { - Tcl_AppendResult(interp, "before set", NULL); + Tcl_SetResult(interp, "before set", TCL_STATIC); value = Tcl_SetVar2(interp, argv[1], argv[2], argv[3], flags); if (value == NULL) { return TCL_ERROR; } Tcl_AppendElement(interp, value); @@ -5256,18 +5132,18 @@ * None. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int TestsaveresultCmd( - void *dummy, /* Not used. */ - register Tcl_Interp *interp,/* Current interpreter. */ + ClientData dummy, /* Not used. */ + Tcl_Interp *interp,/* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { + Interp* iPtr = (Interp*) interp; int discard, result, index; Tcl_SavedResult state; Tcl_Obj *objPtr; static const char *const optionStrings[] = { "append", "dynamic", "free", "object", "small", NULL @@ -5290,21 +5166,20 @@ } if (Tcl_GetBooleanFromObj(interp, objv[3], &discard) != TCL_OK) { return TCL_ERROR; } - freeCount = 0; objPtr = NULL; /* Lint. */ switch ((enum options) index) { case RESULT_SMALL: - Tcl_AppendResult(interp, "small result", NULL); + Tcl_SetResult(interp, "small result", TCL_VOLATILE); break; case RESULT_APPEND: Tcl_AppendResult(interp, "append result", NULL); break; case RESULT_FREE: { - char *buf = Tcl_Alloc(200); + char *buf = ckalloc(200); strcpy(buf, "free result"); Tcl_SetResult(interp, buf, TCL_DYNAMIC); break; } @@ -5315,16 +5190,17 @@ objPtr = Tcl_NewStringObj("object result", -1); Tcl_SetObjResult(interp, objPtr); break; } + freeCount = 0; Tcl_SaveResult(interp, &state); if (((enum options) index) == RESULT_OBJECT) { result = Tcl_EvalObjEx(interp, objv[2], 0); } else { - result = Tcl_EvalEx(interp, Tcl_GetString(objv[2]), -1, 0); + result = Tcl_Eval(interp, Tcl_GetString(objv[2])); } if (discard) { Tcl_DiscardResult(&state); } else { @@ -5331,13 +5207,18 @@ Tcl_RestoreResult(interp, &state); result = TCL_OK; } switch ((enum options) index) { - case RESULT_DYNAMIC: - Tcl_AppendElement(interp, freeCount ? "freed" : "leak"); + case RESULT_DYNAMIC: { + int present = iPtr->freeProc == TestsaveresultFree; + int called = freeCount; + + Tcl_AppendElement(interp, called ? "called" : "notCalled"); + Tcl_AppendElement(interp, present ? "present" : "missing"); break; + } case RESULT_OBJECT: Tcl_AppendElement(interp, Tcl_GetObjResult(interp) == objPtr ? "same" : "different"); break; default: @@ -5362,11 +5243,11 @@ *---------------------------------------------------------------------- */ static void TestsaveresultFree( - void *blockPtr) + char *blockPtr) { freeCount++; } /* @@ -5386,22 +5267,22 @@ *---------------------------------------------------------------------- */ static int TestmainthreadCmd( - void *dummy, /* Not used. */ - register Tcl_Interp *interp,/* Current interpreter. */ + ClientData dummy, /* Not used. */ + Tcl_Interp *interp,/* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { if (argc == 1) { Tcl_Obj *idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t)Tcl_GetCurrentThread()); Tcl_SetObjResult(interp, idObj); return TCL_OK; } else { - Tcl_AppendResult(interp, "wrong # args", NULL); + Tcl_SetResult(interp, "wrong # args", TCL_STATIC); return TCL_ERROR; } } /* @@ -5447,12 +5328,12 @@ *---------------------------------------------------------------------- */ static int TestsetmainloopCmd( - void *dummy, /* Not used. */ - register Tcl_Interp *interp,/* Current interpreter. */ + ClientData dummy, /* Not used. */ + Tcl_Interp *interp,/* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { exitMainLoop = 0; Tcl_SetMainLoop(MainLoop); @@ -5476,12 +5357,12 @@ *---------------------------------------------------------------------- */ static int TestexitmainloopCmd( - void *dummy, /* Not used. */ - register Tcl_Interp *interp,/* Current interpreter. */ + ClientData dummy, /* Not used. */ + Tcl_Interp *interp,/* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { exitMainLoop = 1; return TCL_OK; @@ -5502,14 +5383,13 @@ * None. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int TestChannelCmd( - void *clientData, /* Not used. */ + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Interpreter for result. */ int argc, /* Count of additional args. */ const char **argv) /* Additional arg strings. */ { const char *cmdName; /* Sub command. */ @@ -5549,11 +5429,11 @@ if (strcmp(argv[2], Tcl_GetChannelName(curPtr->chan)) == 0) { *nextPtrPtr = curPtr->nextPtr; curPtr->nextPtr = NULL; chan = curPtr->chan; - Tcl_Free(curPtr); + ckfree(curPtr); break; } } } else { chan = Tcl_GetChannel(interp, argv[2], &mode); @@ -5564,11 +5444,10 @@ chanPtr = (Channel *) chan; statePtr = chanPtr->state; chanPtr = statePtr->topChanPtr; chan = (Tcl_Channel) chanPtr; } else { - /* lint */ statePtr = NULL; chan = NULL; } if ((cmdName[0] == 's') && (strncmp(cmdName, "setchannelerror", len) == 0)) { @@ -5619,11 +5498,11 @@ Tcl_CutChannel(chan); /* Remember the channel in the pool of detached channels */ - det = Tcl_Alloc(sizeof(TestChannel)); + det = (TestChannel *)ckalloc(sizeof(TestChannel)); det->chan = chan; det->nextPtr = firstDetached; firstDetached = det; return TCL_OK; @@ -5811,11 +5690,11 @@ return TCL_OK; } for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { - Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr)); + Tcl_AppendElement(interp, (char *)Tcl_GetHashKey(hTblPtr, hPtr)); } return TCL_OK; } if ((cmdName[0] == 'o') && @@ -5852,11 +5731,11 @@ hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { chanPtr = (Channel *) Tcl_GetHashValue(hPtr); statePtr = chanPtr->state; if (statePtr->flags & TCL_READABLE) { - Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr)); + Tcl_AppendElement(interp, (char *)Tcl_GetHashKey(hTblPtr, hPtr)); } } return TCL_OK; } @@ -5909,11 +5788,11 @@ for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { chanPtr = (Channel *) Tcl_GetHashValue(hPtr); statePtr = chanPtr->state; if (statePtr->flags & TCL_WRITABLE) { - Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr)); + Tcl_AppendElement(interp, (char *)Tcl_GetHashKey(hTblPtr, hPtr)); } } return TCL_OK; } @@ -5971,14 +5850,13 @@ * Creates, deletes and returns channel event handlers. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int TestChannelEventCmd( - void *dummy, /* Not used. */ + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { Tcl_Obj *resultListPtr; @@ -6017,11 +5895,12 @@ Tcl_AppendResult(interp, "bad event name \"", argv[3], "\": must be readable, writable, or none", NULL); return TCL_ERROR; } - esPtr = Tcl_Alloc(sizeof(EventScriptRecord)); + esPtr = (EventScriptRecord *) ckalloc((unsigned) + sizeof(EventScriptRecord)); esPtr->nextPtr = statePtr->scriptRecordPtr; statePtr->scriptRecordPtr = esPtr; esPtr->chanPtr = chanPtr; esPtr->interp = interp; @@ -6028,11 +5907,11 @@ esPtr->mask = mask; esPtr->scriptPtr = Tcl_NewStringObj(argv[4], -1); Tcl_IncrRefCount(esPtr->scriptPtr); Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask, - TclChannelEventScriptInvoker, esPtr); + TclChannelEventScriptInvoker, (ClientData) esPtr); return TCL_OK; } if ((cmd[0] == 'd') && (strncmp(cmd, "delete", len) == 0)) { @@ -6072,13 +5951,13 @@ Tcl_Panic("TestChannelEventCmd: damaged event script list"); } prevEsPtr->nextPtr = esPtr->nextPtr; } Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, - TclChannelEventScriptInvoker, esPtr); + TclChannelEventScriptInvoker, (ClientData) esPtr); Tcl_DecrRefCount(esPtr->scriptPtr); - Tcl_Free(esPtr); + ckfree(esPtr); return TCL_OK; } if ((cmd[0] == 'l') && (strncmp(cmd, "list", len) == 0)) { @@ -6113,13 +5992,13 @@ for (esPtr = statePtr->scriptRecordPtr; esPtr != NULL; esPtr = nextEsPtr) { nextEsPtr = esPtr->nextPtr; Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, - TclChannelEventScriptInvoker, esPtr); + TclChannelEventScriptInvoker, (ClientData) esPtr); Tcl_DecrRefCount(esPtr->scriptPtr); - Tcl_Free(esPtr); + ckfree(esPtr); } statePtr->scriptRecordPtr = NULL; return TCL_OK; } @@ -6159,11 +6038,11 @@ "\": must be readable, writable, or none", NULL); return TCL_ERROR; } esPtr->mask = mask; Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask, - TclChannelEventScriptInvoker, esPtr); + TclChannelEventScriptInvoker, (ClientData) esPtr); return TCL_OK; } Tcl_AppendResult(interp, "bad command ", cmd, ", must be one of " "add, delete, list, set, or removeall", NULL); return TCL_ERROR; @@ -6170,76 +6049,55 @@ } /* *---------------------------------------------------------------------- * - * TestSocketCmd -- + * TestServiceModeCmd -- * - * Implements the Tcl "testsocket" debugging command and its - * subcommands. This is part of the testing environment. + * This procedure implements the "testservicemode" command which gets or + * sets the current Tcl ServiceMode. There are several tests which open + * a file and assign various handlers to it. For these tests to be + * deterministic it is important that file events not be processed until + * all of the handlers are in place. * * Results: * A standard Tcl result. * * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -TestSocketCmd( - void *clientData, /* Not used. */ - Tcl_Interp *interp, /* Interpreter for result. */ - int argc, /* Count of additional args. */ - const char **argv) /* Additional arg strings. */ -{ - const char *cmdName; /* Sub command. */ - size_t len; /* Length of subcommand string. */ - - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " subcommand ?additional args..?\"", NULL); - return TCL_ERROR; - } - cmdName = argv[1]; - len = strlen(cmdName); - - if ((cmdName[0] == 't') && (strncmp(cmdName, "testflags", len) == 0)) { - Tcl_Channel hChannel; - int modePtr; - TcpState *statePtr; - /* Set test value in the socket driver - */ - /* Check for argument "channel name" - */ - if (argc < 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " testflags channel flags\"", NULL); - return TCL_ERROR; - } - hChannel = Tcl_GetChannel(interp, argv[2], &modePtr); - if ( NULL == hChannel ) { - Tcl_AppendResult(interp, "unknown channel:", argv[2], NULL); - return TCL_ERROR; - } - statePtr = (TcpState *)Tcl_GetChannelInstanceData(hChannel); - if ( NULL == statePtr) { - Tcl_AppendResult(interp, "No channel instance data:", argv[2], - NULL); - return TCL_ERROR; - } - statePtr->testFlags = atoi(argv[3]); - return TCL_OK; - } - - Tcl_AppendResult(interp, "bad option \"", cmdName, "\": should be " - "testflags", NULL); - return TCL_ERROR; -} - + * May change the ServiceMode setting. + * + *---------------------------------------------------------------------- + */ + +static int +TestServiceModeCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ +{ + int newmode, oldmode; + if (argc > 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?newmode?\"", NULL); + return TCL_ERROR; + } + oldmode = (Tcl_GetServiceMode() != TCL_SERVICE_NONE); + if (argc == 2) { + if (Tcl_GetInt(interp, argv[1], &newmode) == TCL_ERROR) { + return TCL_ERROR; + } + if (newmode == 0) { + Tcl_SetServiceMode(TCL_SERVICE_NONE); + } else { + Tcl_SetServiceMode(TCL_SERVICE_ALL); + } + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(oldmode)); + return TCL_OK; +} + /* *---------------------------------------------------------------------- * * TestWrongNumArgsObjCmd -- * @@ -6254,11 +6112,11 @@ *---------------------------------------------------------------------- */ static int TestWrongNumArgsObjCmd( - void *dummy, /* Not used. */ + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int i, length; @@ -6267,11 +6125,11 @@ if (objc < 3) { /* * Don't use Tcl_WrongNumArgs here, as that is the function * we want to test! */ - Tcl_AppendResult(interp, "insufficient arguments", NULL); + Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC); return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, objv[1], &i) != TCL_OK) { return TCL_ERROR; @@ -6284,11 +6142,11 @@ if (i > objc - 3) { /* * Asked for more arguments than were given. */ - Tcl_AppendResult(interp, "insufficient arguments", NULL); + Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC); return TCL_ERROR; } Tcl_WrongNumArgs(interp, i, &(objv[3]), msg); return TCL_OK; @@ -6310,11 +6168,11 @@ *---------------------------------------------------------------------- */ static int TestGetIndexFromObjStructObjCmd( - void *dummy, /* Not used. */ + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *const ary[] = { @@ -6364,11 +6222,11 @@ *---------------------------------------------------------------------- */ static int TestFilesystemObjCmd( - void *dummy, + ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { int res, boolVal; @@ -6380,11 +6238,11 @@ } if (Tcl_GetBooleanFromObj(interp, objv[1], &boolVal) != TCL_OK) { return TCL_ERROR; } if (boolVal) { - res = Tcl_FSRegister(interp, &testReportingFilesystem); + res = Tcl_FSRegister((ClientData)interp, &testReportingFilesystem); msg = (res == TCL_OK) ? "registered" : "failed"; } else { res = Tcl_FSUnregister(&testReportingFilesystem); msg = (res == TCL_OK) ? "unregistered" : "failed"; } @@ -6393,11 +6251,11 @@ } static int TestReportInFilesystem( Tcl_Obj *pathPtr, - void **clientDataPtr) + ClientData *clientDataPtr) { static Tcl_Obj *lastPathPtr = NULL; Tcl_Obj *newPathPtr; if (pathPtr == lastPathPtr) { @@ -6415,11 +6273,11 @@ Tcl_DecrRefCount(newPathPtr); lastPathPtr = NULL; return -1; } lastPathPtr = NULL; - *clientDataPtr = newPathPtr; + *clientDataPtr = (ClientData) newPathPtr; return TCL_OK; } /* * Simple helper function to extract the native vfs representation of a path @@ -6433,11 +6291,11 @@ return (Tcl_Obj*) Tcl_FSGetInternalRep(pathPtr, &testReportingFilesystem); } static void TestReportFreeInternalRep( - void *clientData) + ClientData clientData) { Tcl_Obj *nativeRep = (Tcl_Obj *) clientData; if (nativeRep != NULL) { /* Free the path */ @@ -6445,11 +6303,11 @@ } } static ClientData TestReportDupInternalRep( - void *clientData) + ClientData clientData) { Tcl_Obj *original = (Tcl_Obj *) clientData; Tcl_IncrRefCount(original); return clientData; @@ -6464,15 +6322,10 @@ Tcl_Interp *interp = (Tcl_Interp *) Tcl_FSData(&testReportingFilesystem); if (interp == NULL) { /* This is bad, but not much we can do about it */ } else { - /* - * No idea why I decided to program this up using the old string-based - * API, but there you go. We should convert it to objects. - */ - Tcl_Obj *savedResult; Tcl_DString ds; Tcl_DStringInit(&ds); Tcl_DStringAppend(&ds, "lappend filesystemReport ", -1); @@ -6486,11 +6339,11 @@ } Tcl_DStringEndSublist(&ds); savedResult = Tcl_GetObjResult(interp); Tcl_IncrRefCount(savedResult); Tcl_SetObjResult(interp, Tcl_NewObj()); - Tcl_EvalEx(interp, Tcl_DStringValue(&ds), -1, 0); + Tcl_Eval(interp, Tcl_DStringValue(&ds)); Tcl_DStringFree(&ds); Tcl_ResetResult(interp); Tcl_SetObjResult(interp, savedResult); Tcl_DecrRefCount(savedResult); } @@ -6711,11 +6564,11 @@ } static int SimplePathInFilesystem( Tcl_Obj *pathPtr, - void **clientDataPtr) + ClientData *clientDataPtr) { const char *str = Tcl_GetString(pathPtr); if (strncmp(str, "simplefs:/", 10)) { return -1; @@ -6740,11 +6593,11 @@ * important features. */ static int TestSimpleFilesystemObjCmd( - void *dummy, + ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { int res, boolVal; @@ -6756,11 +6609,11 @@ } if (Tcl_GetBooleanFromObj(interp, objv[1], &boolVal) != TCL_OK) { return TCL_ERROR; } if (boolVal) { - res = Tcl_FSRegister(interp, &simpleFilesystem); + res = Tcl_FSRegister((ClientData)interp, &simpleFilesystem); msg = (res == TCL_OK) ? "registered" : "failed"; } else { res = Tcl_FSUnregister(&simpleFilesystem); msg = (res == TCL_OK) ? "unregistered" : "failed"; } @@ -6893,29 +6746,164 @@ retVal = Tcl_NewStringObj("simplefs:/", -1); Tcl_IncrRefCount(retVal); return retVal; } + +/* + * Used to check operations of Tcl_UtfNext. + * + * Usage: testutfnext $bytes $offset + */ + +static int +TestUtfNextCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + int numBytes; /* Number of bytes supplied in the test string */ + int offset; /* Number of bytes we are permitted to read */ + char *bytes; + const char *result, *first; + char buffer[32]; + static const char tobetested[] = "A\xA0\xC0\xC1\xC2\xD0\xE0\xE8\xF2\xF7\xF8\xFE\xFF"; + const char *p = tobetested; + (void)dummy; + + if (objc < 2 || objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "string ?numBytes?"); + return TCL_ERROR; + } + + bytes = Tcl_GetStringFromObj(objv[1], &numBytes); + + offset = numBytes +TCL_UTF_MAX -1; /* If no constraint is given, allow + * the terminating NUL to limit + * operations. */ + + if (objc == 3) { + if (TCL_OK != TclGetIntForIndex(interp, objv[2], numBytes, &offset)) { + return TCL_ERROR; + } + if (offset < 0) { + offset = 0; + } + if (offset > numBytes +TCL_UTF_MAX -1) { + offset = numBytes +TCL_UTF_MAX -1; + } + } + + if (numBytes > (int)sizeof(buffer) - 3) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"testutfnext\" can only handle %d bytes", + (int)sizeof(buffer) - 4)); + return TCL_ERROR; + } + + memcpy(buffer + 1, bytes, numBytes); + buffer[0] = buffer[numBytes + 1] = buffer[numBytes + 2] = buffer[numBytes + 3] = '\xA0'; + + if (!Tcl_UtfCharComplete(buffer + 1, offset)) { + /* Cannot scan a complete sequence from the data */ + + Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); + return TCL_OK; + } + + first = result = Tcl_UtfNext(buffer + 1); + while ((buffer[0] = *p++) != '\0') { + /* Run Tcl_UtfNext with many more possible bytes at src[-1], all should give the same result */ + result = Tcl_UtfNext(buffer + 1); + if (first != result) { + Tcl_AppendResult(interp, "Tcl_UtfNext is not supposed to read src[-1]", NULL); + return TCL_ERROR; + } + } + p = tobetested; + while ((buffer[numBytes + 1] = *p++) != '\0') { + /* Run Tcl_UtfNext with many more possible bytes at src[end], all should give the same result */ + result = Tcl_UtfNext(buffer + 1); + if (first != result) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "Tcl_UtfNext is not supposed to read src[end]\n" + "Different result when src[end] is %#x", UCHAR(p[-1]))); + return TCL_ERROR; + } + } + + Tcl_SetObjResult(interp, Tcl_NewIntObj(first - buffer - 1)); + + return TCL_OK; +} +/* + * Used to check operations of Tcl_UtfPrev. + * + * Usage: testutfprev $bytes $offset + */ + +static int +TestUtfPrevCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + int numBytes, offset; + char *bytes; + const char *result; + + if (objc < 2 || objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "bytes ?offset?"); + return TCL_ERROR; + } + + bytes = Tcl_GetStringFromObj(objv[1], &numBytes); + + if (objc == 3) { + if (TCL_OK != TclGetIntForIndex(interp, objv[2], numBytes, &offset)) { + return TCL_ERROR; + } + if (offset < 0) { + offset = 0; + } + if (offset > numBytes) { + offset = numBytes; + } + } else { + offset = numBytes; + } + result = TclUtfPrev(bytes + offset, bytes); + Tcl_SetObjResult(interp, Tcl_NewIntObj(result - bytes)); + return TCL_OK; +} /* * Used to check correct string-length determining in Tcl_NumUtfChars */ static int TestNumUtfCharsCmd( - void *clientData, + ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { if (objc > 1) { - int len = -1; + int numBytes, len, limit = -1; + const char *bytes = Tcl_GetStringFromObj(objv[1], &numBytes); if (objc > 2) { - (void) Tcl_GetIntFromObj(interp, objv[2], &len); + if (TclGetIntForIndex(interp, objv[2], numBytes, &limit) != TCL_OK) { + return TCL_ERROR; + } + if (limit > numBytes + 1) { + limit = numBytes + 1; + } } - len = Tcl_NumUtfChars(Tcl_GetString(objv[1]), len); + len = Tcl_NumUtfChars(bytes, limit); Tcl_SetObjResult(interp, Tcl_NewIntObj(len)); } return TCL_OK; } @@ -6923,11 +6911,11 @@ * Used to check correct operation of Tcl_UtfFindFirst */ static int TestFindFirstCmd( - void *clientData, + ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { if (objc > 1) { @@ -6945,11 +6933,11 @@ * Used to check correct operation of Tcl_UtfFindLast */ static int TestFindLastCmd( - void *clientData, + ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { if (objc > 1) { @@ -6987,34 +6975,34 @@ *---------------------------------------------------------------------- */ static int TestcpuidCmd( - void *dummy, + ClientData dummy, Tcl_Interp* interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj *const * objv) /* Parameter vector */ { int status, index, i; - int regs[4]; + unsigned int regs[4]; Tcl_Obj *regsObjs[4]; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "eax"); return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, objv[1], &index) != TCL_OK) { return TCL_ERROR; } - status = TclWinCPUID(index, regs); + status = TclWinCPUID((unsigned) index, regs); if (status != TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewStringObj("operation not available", -1)); return status; } for (i=0 ; i<4 ; ++i) { - regsObjs[i] = Tcl_NewIntObj(regs[i]); + regsObjs[i] = Tcl_NewIntObj((int) regs[i]); } Tcl_SetObjResult(interp, Tcl_NewListObj(4, regsObjs)); return TCL_OK; } #endif @@ -7023,11 +7011,11 @@ * Used to do basic checks of the TCL_HASH_KEY_SYSTEM_HASH flag */ static int TestHashSystemHashCmd( - void *clientData, + ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { static const Tcl_HashKeyType hkType = { @@ -7035,10 +7023,11 @@ NULL, NULL, NULL, NULL }; Tcl_HashTable hash; Tcl_HashEntry *hPtr; int i, isNew, limit = 100; + (void)dummy; if (objc>1 && Tcl_GetIntFromObj(interp, objv[1], &limit)!=TCL_OK) { return TCL_ERROR; } @@ -7059,11 +7048,11 @@ return TCL_ERROR; } Tcl_SetHashValue(hPtr, INT2PTR(i+42)); } - if (hash.numEntries != (size_t)limit) { + if (hash.numEntries != limit) { Tcl_AppendResult(interp, "unexpected maximal size", NULL); Tcl_DeleteHashTable(&hash); return TCL_ERROR; } @@ -7099,17 +7088,19 @@ * Used for testing Tcl_GetInt which is no longer used directly by the * core very much. */ static int TestgetintCmd( - void *dummy, + ClientData dummy, Tcl_Interp *interp, int argc, const char **argv) { + (void)dummy; + if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args", NULL); + Tcl_SetResult(interp, "wrong # args", TCL_STATIC); return TCL_ERROR; } else { int val, i, total=0; for (i=1 ; iexecEnvPtr->callbackPtr; + (void)dummy; + (void)objc; + (void)objv; if (refDepth == NULL) { refDepth = &depth; } @@ -7242,11 +7223,11 @@ *---------------------------------------------------------------------- */ static int TestconcatobjCmd( - void *dummy, /* Not used. */ + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { Tcl_Obj *list1Ptr, *list2Ptr, *emptyPtr, *concatPtr, *tmpPtr; @@ -7263,15 +7244,21 @@ emptyPtr = Tcl_NewObj(); list1Ptr = Tcl_NewStringObj("foo bar sum", -1); Tcl_ListObjLength(NULL, list1Ptr, &len); - Tcl_InvalidateStringRep(list1Ptr); + if (list1Ptr->bytes != NULL) { + ckfree(list1Ptr->bytes); + list1Ptr->bytes = NULL; + } list2Ptr = Tcl_NewStringObj("eeny meeny", -1); Tcl_ListObjLength(NULL, list2Ptr, &len); - Tcl_InvalidateStringRep(list2Ptr); + if (list2Ptr->bytes != NULL) { + ckfree(list2Ptr->bytes); + list2Ptr->bytes = NULL; + } /* * Verify that concat'ing a list obj with one or more empty strings does * return a fresh Tcl_Obj (see also [Bug 2055782]). */ @@ -7411,12 +7398,10 @@ result = TCL_ERROR; Tcl_AppendResult(interp, "\n\t* (e) concatObj does not have refCount 0", NULL); } if (concatPtr == tmpPtr) { - int len; - result = TCL_ERROR; Tcl_AppendResult(interp, "\n\t* (e) concatObj is not a new obj ", NULL); (void) Tcl_ListObjLength(NULL, concatPtr, &len); @@ -7443,12 +7428,10 @@ result = TCL_ERROR; Tcl_AppendResult(interp, "\n\t* (f) concatObj does not have refCount 0", NULL); } if (concatPtr == tmpPtr) { - int len; - result = TCL_ERROR; Tcl_AppendResult(interp, "\n\t* (f) concatObj is not a new obj ", NULL); (void) Tcl_ListObjLength(NULL, concatPtr, &len); @@ -7476,12 +7459,10 @@ result = TCL_ERROR; Tcl_AppendResult(interp, "\n\t* (g) concatObj does not have refCount 0", NULL); } if (concatPtr == tmpPtr) { - int len; - result = TCL_ERROR; Tcl_AppendResult(interp, "\n\t* (g) concatObj is not a new obj ", NULL); (void) Tcl_ListObjLength(NULL, concatPtr, &len); @@ -7539,11 +7520,11 @@ *---------------------------------------------------------------------- */ static int TestparseargsCmd( - void *dummy, /* Not used. */ + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Arguments. */ { static int foo = 0; @@ -7560,11 +7541,11 @@ } result[0] = Tcl_NewIntObj(foo); result[1] = Tcl_NewIntObj(count); result[2] = Tcl_NewListObj(count, remObjv); Tcl_SetObjResult(interp, Tcl_NewListObj(3, result)); - Tcl_Free(remObjv); + ckfree(remObjv); return TCL_OK; } /** * Test harness for command and variable resolvers. @@ -7572,20 +7553,21 @@ static int InterpCmdResolver( Tcl_Interp *interp, const char *name, - Tcl_Namespace *context, + Tcl_Namespace *dummy, int flags, Tcl_Command *rPtr) { Interp *iPtr = (Interp *) interp; CallFrame *varFramePtr = iPtr->varFramePtr; Proc *procPtr = (varFramePtr->isProcCallFrame & FRAME_IS_PROC) ? varFramePtr->procPtr : NULL; Namespace *callerNsPtr = varFramePtr->nsPtr; Tcl_Command resolvedCmdPtr = NULL; + (void)dummy; /* * Just do something special on a cmd literal "z" in two cases: * A) when the caller is a proc "x", and the proc is either in "::" or in "::ns2". * B) the caller's namespace is "ctx1" or "ctx2" @@ -7641,11 +7623,11 @@ * context. The resolved procs are taken from the the global * namespace (for simplicity). */ CallFrame *parentFramePtr = varFramePtr->callerPtr; - const char *context = parentFramePtr != NULL ? parentFramePtr->nsPtr->name : "(NULL)"; + char *context = parentFramePtr != NULL ? parentFramePtr->nsPtr->name : "(NULL)"; if (strcmp(context, "ctx1") == 0 && (name[0] == 'z') && (name[1] == '\0')) { resolvedCmdPtr = Tcl_FindCommand(interp, "y", NULL, TCL_GLOBAL_ONLY); /* fprintf(stderr, "... y ==> %p\n", resolvedCmdPtr);*/ @@ -7687,11 +7669,11 @@ static inline void HashVarFree( Tcl_Var var) { if (VarHashRefCount(var) < 2) { - Tcl_Free(var); + ckfree(var); } else { VarHashRefCount(var)--; } } @@ -7703,15 +7685,15 @@ Tcl_DecrRefCount(resVarInfo->nameObj); if (resVarInfo->var) { HashVarFree(resVarInfo->var); } - Tcl_Free(vInfoPtr); + ckfree(vInfoPtr); } #define TclVarHashGetValue(hPtr) \ - ((Var *) ((char *)hPtr - offsetof(VarInHash, entry))) + ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry))) static Tcl_Var MyCompiledVarFetch( Tcl_Interp *interp, Tcl_ResolvedVarInfo *vinfoPtr) @@ -7746,11 +7728,11 @@ var = NULL; } resVarInfo->var = var; /* - * Increment the reference counter to avoid Tcl_Free() of the variable in + * Increment the reference counter to avoid ckfree() of the variable in * Tcl's FreeVarEntry(); for cleanup, we provide our own HashVarFree(); */ VarHashRefCount(var)++; return var; @@ -7763,11 +7745,11 @@ int length, Tcl_Namespace *context, Tcl_ResolvedVarInfo **rPtr) { if (*name == 'T') { - MyResolvedVarInfo *resVarInfo = Tcl_Alloc(sizeof(MyResolvedVarInfo)); + MyResolvedVarInfo *resVarInfo = ckalloc(sizeof(MyResolvedVarInfo)); resVarInfo->vInfo.fetchProc = MyCompiledVarFetch; resVarInfo->vInfo.deleteProc = MyCompiledVarFree; resVarInfo->var = NULL; resVarInfo->nameObj = Tcl_NewStringObj(name, -1); @@ -7778,11 +7760,11 @@ return TCL_CONTINUE; } static int TestInterpResolverCmd( - void *clientData, + ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { static const char *const table[] = { @@ -7794,11 +7776,11 @@ if ((objc < 2) || (objc > 3)) { Tcl_WrongNumArgs(interp, 1, objv, "up|down ?interp?"); return TCL_ERROR; } if (objc == 3) { - interp = Tcl_GetSlave(interp, Tcl_GetString(objv[2])); + interp = Tcl_GetChild(interp, Tcl_GetString(objv[2])); if (interp == NULL) { Tcl_AppendResult(interp, "provided interpreter not found", NULL); return TCL_ERROR; } } Index: generic/tclTestObj.c ================================================================== --- generic/tclTestObj.c +++ generic/tclTestObj.c @@ -51,17 +51,17 @@ #define VARPTR_KEY "TCLOBJTEST_VARPTR" #define NUMBER_OF_OBJECT_VARS 20 static void VarPtrDeleteProc(ClientData clientData, Tcl_Interp *interp) { - register int i; + int i; Tcl_Obj **varPtr = (Tcl_Obj **) clientData; for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) { if (varPtr[i]) Tcl_DecrRefCount(varPtr[i]); } Tcl_DeleteAssocData(interp, VARPTR_KEY); - Tcl_Free(varPtr); + ckfree(varPtr); } static Tcl_Obj **GetVarPtr(Tcl_Interp *interp) { Tcl_InterpDeleteProc *proc; @@ -89,19 +89,19 @@ int TclObjTest_Init( Tcl_Interp *interp) { - register int i; + int i; /* * An array of Tcl_Obj pointers used in the commands that operate on or get * the values of Tcl object-valued variables. varPtr[i] is the i-th variable's * Tcl_Obj *. */ Tcl_Obj **varPtr; - varPtr = (Tcl_Obj **) Tcl_Alloc(NUMBER_OF_OBJECT_VARS *sizeof(varPtr[0])); + varPtr = (Tcl_Obj **) ckalloc(NUMBER_OF_OBJECT_VARS *sizeof(varPtr[0])); if (!varPtr) { return TCL_ERROR; } Tcl_SetAssocData(interp, VARPTR_KEY, VarPtrDeleteProc, varPtr); for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) { @@ -129,11 +129,11 @@ /* *---------------------------------------------------------------------- * * TestbignumobjCmd -- * - * This function implmenets the "testbignumobj" command. It is used + * This function implements the "testbignumobj" command. It is used * to exercise the bignum Tcl object type implementation. * * Results: * Returns a standard Tcl object result. * @@ -158,11 +158,11 @@ BIGNUM_SET, BIGNUM_GET, BIGNUM_MULT10, BIGNUM_DIV10, BIGNUM_ISEVEN, BIGNUM_RADIXSIZE }; int index, varIndex; const char *string; - mp_int bignumValue, newValue; + mp_int bignumValue; Tcl_Obj **varPtr; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); return TCL_ERROR; @@ -231,23 +231,20 @@ } if (Tcl_GetBignumFromObj(interp, varPtr[varIndex], &bignumValue) != TCL_OK) { return TCL_ERROR; } - if (mp_init(&newValue) != MP_OKAY - || (mp_mul_d(&bignumValue, 10, &newValue) != MP_OKAY)) { + if (mp_mul_d(&bignumValue, 10, &bignumValue) != MP_OKAY) { mp_clear(&bignumValue); - mp_clear(&newValue); Tcl_SetObjResult(interp, Tcl_NewStringObj("error in mp_mul_d", -1)); return TCL_ERROR; } - mp_clear(&bignumValue); if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetBignumObj(varPtr[varIndex], &newValue); + Tcl_SetBignumObj(varPtr[varIndex], &bignumValue); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewBignumObj(&newValue)); + SetVarToObj(varPtr, varIndex, Tcl_NewBignumObj(&bignumValue)); } break; case BIGNUM_DIV10: if (objc != 3) { @@ -259,23 +256,20 @@ } if (Tcl_GetBignumFromObj(interp, varPtr[varIndex], &bignumValue) != TCL_OK) { return TCL_ERROR; } - if (mp_init(&newValue) != MP_OKAY - || (mp_div_d(&bignumValue, 10, &newValue, NULL) != MP_OKAY)) { + if (mp_div_d(&bignumValue, 10, &bignumValue, NULL) != MP_OKAY) { mp_clear(&bignumValue); - mp_clear(&newValue); Tcl_SetObjResult(interp, Tcl_NewStringObj("error in mp_div_d", -1)); return TCL_ERROR; } - mp_clear(&bignumValue); if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetBignumObj(varPtr[varIndex], &newValue); + Tcl_SetBignumObj(varPtr[varIndex], &bignumValue); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewBignumObj(&newValue)); + SetVarToObj(varPtr, varIndex, Tcl_NewBignumObj(&bignumValue)); } break; case BIGNUM_ISEVEN: if (objc != 3) { @@ -286,15 +280,21 @@ return TCL_ERROR; } if (Tcl_GetBignumFromObj(interp, varPtr[varIndex], &bignumValue) != TCL_OK) { return TCL_ERROR; + } + if (mp_mod_2d(&bignumValue, 1, &bignumValue) != MP_OKAY) { + mp_clear(&bignumValue); + Tcl_SetObjResult(interp, + Tcl_NewStringObj("error in mp_mod_2d", -1)); + return TCL_ERROR; } if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetIntObj(varPtr[varIndex], !mp_isodd(&bignumValue)); + Tcl_SetIntObj(varPtr[varIndex], mp_iszero(&bignumValue)); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(!mp_isodd(&bignumValue))); + SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(mp_iszero(&bignumValue))); } mp_clear(&bignumValue); break; case BIGNUM_RADIXSIZE: @@ -383,13 +383,13 @@ * we must create a new object to modify/set and decrement the old * formerly-shared object's ref count. This is "copy on write". */ if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetWideIntObj(varPtr[varIndex], boolValue != 0); + Tcl_SetBooleanObj(varPtr[varIndex], boolValue); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(boolValue != 0)); + SetVarToObj(varPtr, varIndex, Tcl_NewBooleanObj(boolValue)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "get") == 0) { if (objc != 3) { goto wrongNumArgs; @@ -408,13 +408,13 @@ if (Tcl_GetBooleanFromObj(interp, varPtr[varIndex], &boolValue) != TCL_OK) { return TCL_ERROR; } if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetWideIntObj(varPtr[varIndex], boolValue == 0); + Tcl_SetBooleanObj(varPtr[varIndex], !boolValue); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(boolValue == 0)); + SetVarToObj(varPtr, varIndex, Tcl_NewBooleanObj(!boolValue)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad option \"", Tcl_GetString(objv[1]), @@ -574,12 +574,12 @@ /* * Keep this structure declaration in sync with tclIndexObj.c */ struct IndexRep { void *tablePtr; /* Pointer to the table of strings. */ - size_t offset; /* Offset between table entries. */ - size_t index; /* Selected index into table. */ + int offset; /* Offset between table entries. */ + int index; /* Selected index into table. */ }; struct IndexRep *indexRep; if ((objc == 3) && (strcmp(Tcl_GetString(objv[1]), "check") == 0)) { @@ -614,20 +614,34 @@ } if (Tcl_GetBooleanFromObj(interp, objv[2], &allowAbbrev) != TCL_OK) { return TCL_ERROR; } - argv = Tcl_Alloc((objc-3) * sizeof(char *)); + argv = ckalloc((objc-3) * sizeof(char *)); for (i = 4; i < objc; i++) { argv[i-4] = Tcl_GetString(objv[i]); } argv[objc-4] = NULL; + + /* + * Tcl_GetIndexFromObj assumes that the table is statically-allocated so + * that its address is different for each index object. If we accidently + * allocate a table at the same address as that cached in the index + * object, clear out the object's cached state. + */ + + if (objv[3]->typePtr != NULL + && !strcmp("index", objv[3]->typePtr->name)) { + indexRep = objv[3]->internalRep.twoPtrValue.ptr1; + if (indexRep->tablePtr == (void *) argv) { + TclFreeIntRep(objv[3]); + } + } result = Tcl_GetIndexFromObj((setError? interp : NULL), objv[3], - argv, "token", INDEX_TEMP_TABLE|(allowAbbrev? 0 : TCL_EXACT), - &index); - Tcl_Free((void *)argv); + argv, "token", (allowAbbrev? 0 : TCL_EXACT), &index); + ckfree(argv); if (result == TCL_OK) { Tcl_SetIntObj(Tcl_GetObjResult(interp), index); } return result; } @@ -656,11 +670,11 @@ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int intValue, varIndex, i; - Tcl_WideInt wideValue; + long longValue; const char *index, *subCmd, *string; Tcl_Obj **varPtr; if (objc < 3) { wrongNumArgs: @@ -711,47 +725,47 @@ if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { Tcl_SetIntObj(varPtr[varIndex], intValue); } else { SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue)); } - } else if (strcmp(subCmd, "setint") == 0) { + } else if (strcmp(subCmd, "setlong") == 0) { if (objc != 4) { goto wrongNumArgs; } string = Tcl_GetString(objv[3]); if (Tcl_GetInt(interp, string, &i) != TCL_OK) { return TCL_ERROR; } intValue = i; if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetWideIntObj(varPtr[varIndex], intValue); + Tcl_SetLongObj(varPtr[varIndex], intValue); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(intValue)); + SetVarToObj(varPtr, varIndex, Tcl_NewLongObj(intValue)); } Tcl_SetObjResult(interp, varPtr[varIndex]); - } else if (strcmp(subCmd, "setmax") == 0) { - Tcl_WideInt maxWide = WIDE_MAX; + } else if (strcmp(subCmd, "setmaxlong") == 0) { + long maxLong = LONG_MAX; if (objc != 3) { goto wrongNumArgs; } if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetWideIntObj(varPtr[varIndex], maxWide); + Tcl_SetLongObj(varPtr[varIndex], maxLong); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(maxWide)); + SetVarToObj(varPtr, varIndex, Tcl_NewLongObj(maxLong)); } - } else if (strcmp(subCmd, "ismax") == 0) { + } else if (strcmp(subCmd, "ismaxlong") == 0) { if (objc != 3) { goto wrongNumArgs; } if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } - if (Tcl_GetWideIntFromObj(interp, varPtr[varIndex], &wideValue) != TCL_OK) { + if (Tcl_GetLongFromObj(interp, varPtr[varIndex], &longValue) != TCL_OK) { return TCL_ERROR; } Tcl_AppendToObj(Tcl_GetObjResult(interp), - ((wideValue == WIDE_MAX)? "1" : "0"), -1); + ((longValue == LONG_MAX)? "1" : "0"), -1); } else if (strcmp(subCmd, "get") == 0) { if (objc != 3) { goto wrongNumArgs; } if (CheckIfVarUnset(interp, varPtr,varIndex)) { @@ -780,13 +794,13 @@ } #if (INT_MAX == LONG_MAX) /* int is same size as long int */ Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1); #else if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetWideIntObj(varPtr[varIndex], LONG_MAX); + Tcl_SetLongObj(varPtr[varIndex], LONG_MAX); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(LONG_MAX)); + SetVarToObj(varPtr, varIndex, Tcl_NewLongObj(LONG_MAX)); } if (Tcl_GetIntFromObj(interp, varPtr[varIndex], &i) != TCL_OK) { Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1); return TCL_OK; @@ -1086,13 +1100,10 @@ } if (objv[2]->typePtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1)); } else { typeName = objv[2]->typePtr->name; -#ifndef TCL_WIDE_INT_IS_LONG - if (!strcmp(typeName, "wideInt")) typeName = "int"; -#endif Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1)); } } else if (strcmp(subCmd, "refcount") == 0) { if (objc != 3) { goto wrongNumArgs; @@ -1102,11 +1113,11 @@ return TCL_ERROR; } if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(varPtr[varIndex]->refCount)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(varPtr[varIndex]->refCount)); } else if (strcmp(subCmd, "type") == 0) { if (objc != 3) { goto wrongNumArgs; } index = Tcl_GetString(objv[2]); @@ -1116,15 +1127,10 @@ if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } if (varPtr[varIndex]->typePtr == NULL) { /* a string! */ Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", -1); -#ifndef TCL_WIDE_INT_IS_LONG - } else if (!strcmp(varPtr[varIndex]->typePtr->name, "wideInt")) { - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "int", -1); -#endif } else { Tcl_AppendToObj(Tcl_GetObjResult(interp), varPtr[varIndex]->typePtr->name, -1); } } else if (strcmp(subCmd, "types") == 0) { @@ -1271,12 +1277,12 @@ break; case 4: /* length */ if (objc != 3) { goto wrongNumArgs; } - Tcl_SetWideIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL) - ? (Tcl_WideInt)varPtr[varIndex]->length : (Tcl_WideInt)-1); + Tcl_SetIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL) + ? varPtr[varIndex]->length : -1); break; case 5: /* length2 */ if (objc != 3) { goto wrongNumArgs; } @@ -1346,11 +1352,11 @@ break; case 10: /* getunicode */ if (objc != 3) { goto wrongNumArgs; } - Tcl_GetUnicode(varPtr[varIndex]); + Tcl_GetUnicodeFromObj(varPtr[varIndex], NULL); break; case 11: /* appendself */ if (objc != 4) { goto wrongNumArgs; } Index: generic/tclTestProcBodyObj.c ================================================================== --- generic/tclTestProcBodyObj.c +++ generic/tclTestProcBodyObj.c @@ -33,11 +33,11 @@ /* * this struct describes an entry in the table of command names and command * procs */ -typedef struct { +typedef struct CmdTable { const char *cmdName; /* command name */ Tcl_ObjCmdProc *proc; /* command proc */ int exportIt; /* if 1, export the command */ } CmdTable; @@ -188,11 +188,11 @@ if (RegisterCommand(interp, packageName, cmdTablePtr) != TCL_OK) { return TCL_ERROR; } } - return Tcl_PkgProvideEx(interp, packageName, packageVersion, NULL); + return Tcl_PkgProvide(interp, packageName, packageVersion); } /* *---------------------------------------------------------------------- * @@ -337,12 +337,12 @@ if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, ""); return TCL_ERROR; } - version = Tcl_PkgPresentEx(interp, packageName, packageVersion, 1, NULL); - Tcl_SetObjResult(interp, Tcl_NewWideIntObj( + version = Tcl_PkgPresent(interp, packageName, packageVersion, 1); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj( strcmp(version, packageVersion) == 0)); return TCL_OK; } /* Index: generic/tclThread.c ================================================================== --- generic/tclThread.c +++ generic/tclThread.c @@ -38,10 +38,25 @@ static void ForgetSyncObject(void *objPtr, SyncObjRecord *recPtr); static void RememberSyncObject(void *objPtr, SyncObjRecord *recPtr); +/* + * Several functions are #defined to nothing in tcl.h if TCL_THREADS is not + * specified. Here we undo that so the functions are defined in the stubs + * table. + */ + +#ifndef TCL_THREADS +#undef Tcl_MutexLock +#undef Tcl_MutexUnlock +#undef Tcl_MutexFinalize +#undef Tcl_ConditionNotify +#undef Tcl_ConditionWait +#undef Tcl_ConditionFinalize +#endif + /* *---------------------------------------------------------------------- * * Tcl_GetThreadData -- * @@ -59,28 +74,28 @@ */ void * Tcl_GetThreadData( Tcl_ThreadDataKey *keyPtr, /* Identifier for the data chunk */ - size_t size) /* Size of storage block */ + int size) /* Size of storage block */ { void *result; -#if TCL_THREADS +#ifdef TCL_THREADS /* * Initialize the key for this thread. */ result = TclThreadStorageKeyGet(keyPtr); if (result == NULL) { - result = Tcl_Alloc(size); + result = ckalloc(size); memset(result, 0, size); TclThreadStorageKeySet(keyPtr, result); } #else /* TCL_THREADS */ if (*keyPtr == NULL) { - result = Tcl_Alloc(size); + result = ckalloc(size); memset(result, 0, size); *keyPtr = result; RememberSyncObject(keyPtr, &keyRecord); } else { result = *keyPtr; @@ -109,11 +124,11 @@ void * TclThreadDataKeyGet( Tcl_ThreadDataKey *keyPtr) /* Identifier for the data chunk. */ { -#if TCL_THREADS +#ifdef TCL_THREADS return TclThreadStorageKeyGet(keyPtr); #else /* TCL_THREADS */ return *keyPtr; #endif /* TCL_THREADS */ } @@ -124,11 +139,11 @@ * RememberSyncObject * * Keep a list of (mutexes/condition variable/data key) used during * finalization. * - * Assume master lock is held. + * Assume global lock is held. * * Results: * None. * * Side effects: @@ -162,18 +177,18 @@ * pointers to the new list. */ if (recPtr->num >= recPtr->max) { recPtr->max += 8; - newList = Tcl_Alloc(recPtr->max * sizeof(void *)); + newList = ckalloc(recPtr->max * sizeof(void *)); for (i=0,j=0 ; inum ; i++) { if (recPtr->list[i] != NULL) { newList[j++] = recPtr->list[i]; } } if (recPtr->list != NULL) { - Tcl_Free(recPtr->list); + ckfree(recPtr->list); } recPtr->list = newList; recPtr->num = j; } @@ -185,11 +200,11 @@ *---------------------------------------------------------------------- * * ForgetSyncObject * * Remove a single object from the list. - * Assume master lock is held. + * Assume global lock is held. * * Results: * None. * * Side effects: @@ -217,11 +232,11 @@ *---------------------------------------------------------------------- * * TclRememberMutex * * Keep a list of mutexes used during finalization. - * Assume master lock is held. + * Assume global lock is held. * * Results: * None. * * Side effects: @@ -252,30 +267,29 @@ * Remove the mutex from the list. * *---------------------------------------------------------------------- */ -#undef Tcl_MutexFinalize void Tcl_MutexFinalize( Tcl_Mutex *mutexPtr) { -#if TCL_THREADS +#ifdef TCL_THREADS TclpFinalizeMutex(mutexPtr); #endif - TclpMasterLock(); + TclpGlobalLock(); ForgetSyncObject(mutexPtr, &mutexRecord); - TclpMasterUnlock(); + TclpGlobalUnlock(); } /* *---------------------------------------------------------------------- * * TclRememberCondition * * Keep a list of condition variables used during finalization. - * Assume master lock is held. + * Assume global lock is held. * * Results: * None. * * Side effects: @@ -306,21 +320,20 @@ * Remove the condition variable from the list. * *---------------------------------------------------------------------- */ -#undef Tcl_ConditionFinalize void Tcl_ConditionFinalize( Tcl_Condition *condPtr) { -#if TCL_THREADS +#ifdef TCL_THREADS TclpFinalizeCondition(condPtr); #endif - TclpMasterLock(); + TclpGlobalLock(); ForgetSyncObject(condPtr, &condRecord); - TclpMasterUnlock(); + TclpGlobalUnlock(); } /* *---------------------------------------------------------------------- * @@ -341,11 +354,11 @@ void TclFinalizeThreadData(int quick) { TclFinalizeThreadDataThread(); -#if TCL_THREADS && defined(USE_THREAD_ALLOC) +#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) if (!quick) { /* * Quick exit principle makes it useless to terminate allocators */ TclFinalizeThreadAllocThread(); @@ -374,15 +387,15 @@ TclFinalizeSynchronization(void) { int i; void *blockPtr; Tcl_ThreadDataKey *keyPtr; -#if TCL_THREADS +#ifdef TCL_THREADS Tcl_Mutex *mutexPtr; Tcl_Condition *condPtr; - TclpMasterLock(); + TclpGlobalLock(); #endif /* * If we're running unthreaded, the TSD blocks are simply stored inside * their thread data keys. Free them here. @@ -390,21 +403,21 @@ if (keyRecord.list != NULL) { for (i=0 ; i= sizeof(size_t)) { + /* An unsigned int overflow can also be a size_t overflow */ + const size_t zero = 0; + const size_t max = ~zero; + + if (((size_t) reqSize) > max - sizeof(Block) - RCHECK) { + /* Requested allocation exceeds memory */ + return NULL; + } + } +#endif GETCACHE(cachePtr); /* * Increment the requested size to include room for the Block structure. @@ -322,11 +344,11 @@ #if RCHECK size++; #endif if (size > MAXALLOC) { bucket = NBUCKETS; - blockPtr = TclpSysAlloc(size); + blockPtr = TclpSysAlloc(size, 0); if (blockPtr != NULL) { cachePtr->totalAssigned += reqSize; } } else { bucket = 0; @@ -363,11 +385,11 @@ *---------------------------------------------------------------------- */ void TclpFree( - void *ptr) + char *ptr) { Cache *cachePtr; Block *blockPtr; int bucket; @@ -420,14 +442,14 @@ * Previous memory, if any, may be freed. * *---------------------------------------------------------------------- */ -void * +char * TclpRealloc( - void *ptr, - size_t reqSize) + char *ptr, + unsigned int reqSize) { Cache *cachePtr; Block *blockPtr; void *newPtr; size_t size, min; @@ -434,10 +456,23 @@ int bucket; if (ptr == NULL) { return TclpAlloc(reqSize); } + +#ifndef __LP64__ + if (sizeof(int) >= sizeof(size_t)) { + /* An unsigned int overflow can also be a size_t overflow */ + const size_t zero = 0; + const size_t max = ~zero; + + if (((size_t) reqSize) > max - sizeof(Block) - RCHECK) { + /* Requested allocation exceeds memory */ + return NULL; + } + } +#endif GETCACHE(cachePtr); /* * If the block is not a system block and fits in place, simply return the @@ -535,11 +570,11 @@ Tcl_MutexUnlock(objLockPtr); if (cachePtr->numObjects == 0) { Tcl_Obj *newObjsPtr; cachePtr->numObjects = numMove = NOBJALLOC; - newObjsPtr = TclpSysAlloc(sizeof(Tcl_Obj) * numMove); + newObjsPtr = TclpSysAlloc(sizeof(Tcl_Obj) * numMove, 0); if (newObjsPtr == NULL) { Tcl_Panic("alloc: could not allocate %d new objects", numMove); } cachePtr->lastPtr = newObjsPtr + numMove - 1; objPtr = cachePtr->firstObjPtr; /* NULL */ @@ -643,12 +678,12 @@ } else { sprintf(buf, "thread%p", cachePtr->owner); Tcl_DStringAppendElement(dsPtr, buf); } for (n = 0; n < NBUCKETS; ++n) { - sprintf(buf, "%" TCL_Z_MODIFIER "u %" TCL_Z_MODIFIER "u %" TCL_Z_MODIFIER "u %" TCL_Z_MODIFIER "u %" TCL_Z_MODIFIER "u %" TCL_Z_MODIFIER "u %" TCL_Z_MODIFIER "u", - bucketInfo[n].blockSize, + sprintf(buf, "%lu %ld %ld %ld %ld %ld %ld", + (unsigned long) bucketInfo[n].blockSize, cachePtr->buckets[n].numFree, cachePtr->buckets[n].numRemoves, cachePtr->buckets[n].numInserts, cachePtr->buckets[n].totalAssigned, cachePtr->buckets[n].numLocks, @@ -933,11 +968,11 @@ GetBlocks( Cache *cachePtr, int bucket) { register Block *blockPtr; - register size_t n; + register int n; /* * First, atttempt to move blocks from the shared cache. Note the * potentially dirty read of numFree before acquiring the lock which is a * slight performance enhancement. The value is verified after the lock is @@ -988,11 +1023,11 @@ */ blockPtr = NULL; n = NBUCKETS; size = 0; /* lint */ - while (--n > (size_t)bucket) { + while (--n > bucket) { if (cachePtr->buckets[n].numFree > 0) { size = bucketInfo[n].blockSize; blockPtr = cachePtr->buckets[n].firstPtr; cachePtr->buckets[n].firstPtr = blockPtr->nextBlock; cachePtr->buckets[n].numFree--; @@ -1004,11 +1039,11 @@ * Otherwise, allocate a big new block directly. */ if (blockPtr == NULL) { size = MAXALLOC; - blockPtr = TclpSysAlloc(size); + blockPtr = TclpSysAlloc(size, 0); if (blockPtr == NULL) { return 0; } } @@ -1027,44 +1062,10 @@ cachePtr->buckets[bucket].lastPtr = blockPtr; blockPtr->nextBlock = NULL; } return 1; } - -/* - *---------------------------------------------------------------------- - * - * TclInitThreadAlloc -- - * - * Initializes the allocator cache-maintenance structures. - * It is done early and protected during the TclInitSubsystems(). - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -TclInitThreadAlloc(void) -{ - unsigned int i; - - listLockPtr = TclpNewAllocMutex(); - objLockPtr = TclpNewAllocMutex(); - for (i = 0; i < NBUCKETS; ++i) { - bucketInfo[i].blockSize = MINALLOC << i; - bucketInfo[i].maxBlocks = ((size_t)1) << (NBUCKETS - 1 - i); - bucketInfo[i].numMove = i < NBUCKETS - 1 ? - 1 << (NBUCKETS - 2 - i) : 1; - bucketInfo[i].lockPtr = TclpNewAllocMutex(); - } - TclpInitAllocCache(); -} /* *---------------------------------------------------------------------- * * TclFinalizeThreadAlloc -- Index: generic/tclThreadJoin.c ================================================================== --- generic/tclThreadJoin.c +++ generic/tclThreadJoin.c @@ -199,11 +199,11 @@ *result = threadPtr->result; Tcl_ConditionFinalize(&threadPtr->cond); Tcl_MutexFinalize(&threadPtr->threadMutex); - Tcl_Free(threadPtr); + ckfree(threadPtr); return TCL_OK; } /* @@ -228,11 +228,11 @@ TclRememberJoinableThread( Tcl_ThreadId id) /* The thread to remember as joinable */ { JoinableThread *threadPtr; - threadPtr = Tcl_Alloc(sizeof(JoinableThread)); + threadPtr = ckalloc(sizeof(JoinableThread)); threadPtr->id = id; threadPtr->done = 0; threadPtr->waitedUpon = 0; threadPtr->threadMutex = (Tcl_Mutex) NULL; threadPtr->cond = (Tcl_Condition) NULL; Index: generic/tclThreadStorage.c ================================================================== --- generic/tclThreadStorage.c +++ generic/tclThreadStorage.c @@ -11,11 +11,11 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" -#if TCL_THREADS +#ifdef TCL_THREADS #include /* * IMPLEMENTATION NOTES: * @@ -25,25 +25,25 @@ * slot, because there is a hard limit on the number of TSD slots. Valid key * offsets are greater than 0; 0 is for the initialized Tcl_ThreadDataKey. */ /* - * The master collection of information about TSDs. This is shared across the + * The global collection of information about TSDs. This is shared across the * whole process, and includes the mutex used to protect it. */ -static struct TSDMaster { +static struct { void *key; /* Key into the system TSD structure. The * collection of Tcl TSD values for a * particular thread will hang off the * back-end of this. */ sig_atomic_t counter; /* The number of different Tcl TSDs used * across *all* threads. This is a strictly * increasing value. */ Tcl_Mutex mutex; /* Protection for the rest of this structure, * which holds per-process data. */ -} tsdMaster = { NULL, 0, NULL }; +} tsdGlobal = { NULL, 0, NULL }; /* * The type of the data held per thread in a system TSD. */ @@ -55,11 +55,11 @@ /* * The actual type of Tcl_ThreadDataKey. */ -typedef union TSDUnion { +typedef union { volatile sig_atomic_t offset; /* The type is really an offset into the * thread-local table of TSDs, which is this * field. */ void *ptr; /* For alignment purposes only. Not actually @@ -83,18 +83,18 @@ TSDTableCreate(void) { TSDTable *tsdTablePtr; sig_atomic_t i; - tsdTablePtr = TclpSysAlloc(sizeof(TSDTable)); + tsdTablePtr = TclpSysAlloc(sizeof(TSDTable), 0); if (tsdTablePtr == NULL) { Tcl_Panic("unable to allocate TSDTable"); } tsdTablePtr->allocated = 8; tsdTablePtr->tablePtr = - TclpSysAlloc(sizeof(void *) * tsdTablePtr->allocated); + TclpSysAlloc(sizeof(void *) * tsdTablePtr->allocated, 0); if (tsdTablePtr->tablePtr == NULL) { Tcl_Panic("unable to allocate TSDTable"); } for (i = 0; i < tsdTablePtr->allocated; ++i) { @@ -115,11 +115,11 @@ /* * These values were allocated in Tcl_GetThreadData in tclThread.c * and must now be deallocated or they will leak. */ - Tcl_Free(tsdTablePtr->tablePtr[i]); + ckfree(tsdTablePtr->tablePtr[i]); } } TclpSysFree(tsdTablePtr->tablePtr); TclpSysFree(tsdTablePtr); @@ -187,11 +187,11 @@ void * TclThreadStorageKeyGet( Tcl_ThreadDataKey *dataKeyPtr) { - TSDTable *tsdTablePtr = TclpThreadGetMasterTSD(tsdMaster.key); + TSDTable *tsdTablePtr = TclpThreadGetGlobalTSD(tsdGlobal.key); ClientData resultPtr = NULL; TSDUnion *keyPtr = (TSDUnion *) dataKeyPtr; sig_atomic_t offset = keyPtr->offset; if ((tsdTablePtr != NULL) && (offset > 0) @@ -221,16 +221,16 @@ void TclThreadStorageKeySet( Tcl_ThreadDataKey *dataKeyPtr, void *value) { - TSDTable *tsdTablePtr = TclpThreadGetMasterTSD(tsdMaster.key); + TSDTable *tsdTablePtr = TclpThreadGetGlobalTSD(tsdGlobal.key); TSDUnion *keyPtr = (TSDUnion *) dataKeyPtr; if (tsdTablePtr == NULL) { tsdTablePtr = TSDTableCreate(); - TclpThreadSetMasterTSD(tsdMaster.key, tsdTablePtr); + TclpThreadSetGlobalTSD(tsdGlobal.key, tsdTablePtr); } /* * Get the lock while we check if this TSD is new or not. Note that this * is the only place where Tcl_ThreadDataKey values are set. We use a @@ -238,19 +238,19 @@ * since it is on quite a few critical paths and will only get set once in * each location. */ if (keyPtr->offset == 0) { - Tcl_MutexLock(&tsdMaster.mutex); + Tcl_MutexLock(&tsdGlobal.mutex); if (keyPtr->offset == 0) { /* * The Tcl_ThreadDataKey hasn't been used yet. Make a new one. */ - keyPtr->offset = ++tsdMaster.counter; + keyPtr->offset = ++tsdGlobal.counter; } - Tcl_MutexUnlock(&tsdMaster.mutex); + Tcl_MutexUnlock(&tsdGlobal.mutex); } /* * Check if this is the first time this Tcl_ThreadDataKey has been used * with the current thread. Note that we don't need to hold a lock when @@ -286,15 +286,15 @@ */ void TclFinalizeThreadDataThread(void) { - TSDTable *tsdTablePtr = TclpThreadGetMasterTSD(tsdMaster.key); + TSDTable *tsdTablePtr = TclpThreadGetGlobalTSD(tsdGlobal.key); if (tsdTablePtr != NULL) { TSDTableDelete(tsdTablePtr); - TclpThreadSetMasterTSD(tsdMaster.key, NULL); + TclpThreadSetGlobalTSD(tsdGlobal.key, NULL); } } /* *---------------------------------------------------------------------- @@ -314,11 +314,11 @@ */ void TclInitThreadStorage(void) { - tsdMaster.key = TclpThreadCreateKey(); + tsdGlobal.key = TclpThreadCreateKey(); } /* *---------------------------------------------------------------------- * @@ -337,12 +337,12 @@ */ void TclFinalizeThreadStorage(void) { - TclpThreadDeleteKey(tsdMaster.key); - tsdMaster.key = NULL; + TclpThreadDeleteKey(tsdGlobal.key); + tsdGlobal.key = NULL; } #else /* !TCL_THREADS */ /* * Stub functions for non-threaded builds Index: generic/tclThreadTest.c ================================================================== --- generic/tclThreadTest.c +++ generic/tclThreadTest.c @@ -16,11 +16,11 @@ #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif #include "tclInt.h" -#if TCL_THREADS +#ifdef TCL_THREADS /* * Each thread has an single instance of the following structure. There is one * instance of this structure per thread even if that thread contains multiple * interpreters. The interpreter identified by this structure is the main * interpreter for the thread. @@ -430,14 +430,14 @@ return TCL_ERROR; } Tcl_MutexLock(&threadMutex); errorThreadId = Tcl_GetCurrentThread(); if (errorProcString) { - Tcl_Free(errorProcString); + ckfree(errorProcString); } proc = Tcl_GetString(objv[2]); - errorProcString = Tcl_Alloc(strlen(proc) + 1); + errorProcString = ckalloc(strlen(proc) + 1); strcpy(errorProcString, proc); Tcl_MutexUnlock(&threadMutex); return TCL_OK; } case THREAD_WAIT: @@ -506,11 +506,11 @@ ctrl.flags = 0; joinable = joinable ? TCL_THREAD_JOINABLE : TCL_THREAD_NOFLAGS; Tcl_MutexLock(&threadMutex); - if (Tcl_CreateThread(&id, NewTestThread, &ctrl, + if (Tcl_CreateThread(&id, NewTestThread, (ClientData) &ctrl, TCL_THREAD_STACK_DEFAULT, joinable) != TCL_OK) { Tcl_MutexUnlock(&threadMutex); Tcl_AppendResult(interp, "can't create a new thread", NULL); return TCL_ERROR; } @@ -593,11 +593,11 @@ /* * We need to keep a pointer to the alloc'ed mem of the script we are * eval'ing, for the case that we exit during evaluation */ - threadEvalScript = Tcl_Alloc(strlen(ctrlPtr->script) + 1); + threadEvalScript = ckalloc(strlen(ctrlPtr->script) + 1); strcpy(threadEvalScript, ctrlPtr->script); Tcl_CreateThreadExitHandler(ThreadExitProc, threadEvalScript); /* @@ -652,13 +652,13 @@ Tcl_Channel errChannel; const char *errorInfo, *argv[3]; char *script; char buf[TCL_DOUBLE_SPACE+1]; - sprintf(buf, "%p", Tcl_GetCurrentThread()); + sprintf(buf, "%" TCL_LL_MODIFIER "d", (Tcl_WideInt)(size_t)Tcl_GetCurrentThread()); - errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY); + errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); if (errorProcString == NULL) { errChannel = Tcl_GetStdChannel(TCL_STDERR); Tcl_WriteChars(errChannel, "Error from thread ", -1); Tcl_WriteChars(errChannel, buf, -1); Tcl_WriteChars(errChannel, "\n", 1); @@ -668,11 +668,11 @@ argv[0] = errorProcString; argv[1] = buf; argv[2] = errorInfo; script = Tcl_Merge(3, argv); ThreadSend(interp, errorThreadId, script, 0); - Tcl_Free(script); + ckfree(script); } } /* @@ -838,17 +838,17 @@ /* * Create the event for its event queue. */ - threadEventPtr = Tcl_Alloc(sizeof(ThreadEvent)); - threadEventPtr->script = Tcl_Alloc(strlen(script) + 1); + threadEventPtr = ckalloc(sizeof(ThreadEvent)); + threadEventPtr->script = ckalloc(strlen(script) + 1); strcpy(threadEventPtr->script, script); if (!wait) { resultPtr = threadEventPtr->resultPtr = NULL; } else { - resultPtr = Tcl_Alloc(sizeof(ThreadEventResult)); + resultPtr = ckalloc(sizeof(ThreadEventResult)); threadEventPtr->resultPtr = resultPtr; /* * Initialize the result fields. */ @@ -916,23 +916,23 @@ Tcl_MutexUnlock(&threadMutex); if (resultPtr->code != TCL_OK) { if (resultPtr->errorCode) { Tcl_SetErrorCode(interp, resultPtr->errorCode, NULL); - Tcl_Free(resultPtr->errorCode); + ckfree(resultPtr->errorCode); } if (resultPtr->errorInfo) { Tcl_AddErrorInfo(interp, resultPtr->errorInfo); - Tcl_Free(resultPtr->errorInfo); + ckfree(resultPtr->errorInfo); } } Tcl_AppendResult(interp, resultPtr->result, NULL); Tcl_ConditionFinalize(&resultPtr->done); code = resultPtr->code; - Tcl_Free(resultPtr->result); - Tcl_Free(resultPtr); + ckfree(resultPtr->result); + ckfree(resultPtr); return code; } /* @@ -1029,29 +1029,29 @@ Tcl_ResetResult(interp); Tcl_CreateThreadExitHandler(ThreadFreeProc, threadEventPtr->script); code = Tcl_EvalEx(interp, threadEventPtr->script,-1,TCL_EVAL_GLOBAL); Tcl_DeleteThreadExitHandler(ThreadFreeProc, threadEventPtr->script); if (code != TCL_OK) { - errorCode = Tcl_GetVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY); - errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY); + errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY); + errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); } else { errorCode = errorInfo = NULL; } result = Tcl_GetStringResult(interp); } - Tcl_Free(threadEventPtr->script); + ckfree(threadEventPtr->script); if (resultPtr) { Tcl_MutexLock(&threadMutex); resultPtr->code = code; - resultPtr->result = Tcl_Alloc(strlen(result) + 1); + resultPtr->result = ckalloc(strlen(result) + 1); strcpy(resultPtr->result, result); if (errorCode != NULL) { - resultPtr->errorCode = Tcl_Alloc(strlen(errorCode) + 1); + resultPtr->errorCode = ckalloc(strlen(errorCode) + 1); strcpy(resultPtr->errorCode, errorCode); } if (errorInfo != NULL) { - resultPtr->errorInfo = Tcl_Alloc(strlen(errorInfo) + 1); + resultPtr->errorInfo = ckalloc(strlen(errorInfo) + 1); strcpy(resultPtr->errorInfo, errorInfo); } Tcl_ConditionNotify(&resultPtr->done); Tcl_MutexUnlock(&threadMutex); } @@ -1082,11 +1082,11 @@ static void ThreadFreeProc( ClientData clientData) { if (clientData) { - Tcl_Free(clientData); + ckfree(clientData); } } /* *------------------------------------------------------------------------ @@ -1110,11 +1110,11 @@ ThreadDeleteEvent( Tcl_Event *eventPtr, /* Really ThreadEvent */ ClientData clientData) /* dummy */ { if (eventPtr->proc == ThreadEventProc) { - Tcl_Free(((ThreadEvent *) eventPtr)->script); + ckfree(((ThreadEvent *) eventPtr)->script); return 1; } /* * If it was NULL, we were in the middle of servicing the event and it @@ -1157,18 +1157,18 @@ Tcl_MutexLock(&threadMutex); if (self == errorThreadId) { if (errorProcString) { /* Extra safety */ - Tcl_Free(errorProcString); + ckfree(errorProcString); errorProcString = NULL; } errorThreadId = 0; } if (threadEvalScript) { - Tcl_Free(threadEvalScript); + ckfree(threadEvalScript); threadEvalScript = NULL; } Tcl_DeleteEvents((Tcl_EventDeleteProc *) ThreadDeleteEvent, NULL); for (resultPtr = resultList ; resultPtr ; resultPtr = nextPtr) { @@ -1187,21 +1187,21 @@ if (resultPtr->nextPtr) { resultPtr->nextPtr->prevPtr = resultPtr->prevPtr; } resultPtr->nextPtr = resultPtr->prevPtr = 0; resultPtr->eventPtr->resultPtr = NULL; - Tcl_Free(resultPtr); + ckfree(resultPtr); } else if (resultPtr->dstThreadId == self) { /* * Dang. The target is going away. Unblock the caller. The result * string must be dynamically allocated because the main thread is * going to call free on it. */ const char *msg = "target thread died"; - resultPtr->result = Tcl_Alloc(strlen(msg) + 1); + resultPtr->result = ckalloc(strlen(msg) + 1); strcpy(resultPtr->result, msg); resultPtr->code = TCL_ERROR; Tcl_ConditionNotify(&resultPtr->done); } } Index: generic/tclTimer.c ================================================================== --- generic/tclTimer.c +++ generic/tclTimer.c @@ -89,11 +89,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 { +typedef struct ThreadSpecificData { TimerHandler *firstTimerHandlerPtr; /* First event in queue. */ int lastTimerId; /* Timer identifier of most recently created * timer. */ int timerPending; /* 1 if a timer event is in the queue. */ IdleHandler *idleList; /* First in list of all idle handlers. */ @@ -215,16 +215,16 @@ { ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); Tcl_DeleteEventSource(TimerSetupProc, TimerCheckProc, NULL); if (tsdPtr != NULL) { - register TimerHandler *timerHandlerPtr; + TimerHandler *timerHandlerPtr; timerHandlerPtr = tsdPtr->firstTimerHandlerPtr; while (timerHandlerPtr != NULL) { tsdPtr->firstTimerHandlerPtr = timerHandlerPtr->nextPtr; - Tcl_Free(timerHandlerPtr); + ckfree(timerHandlerPtr); timerHandlerPtr = tsdPtr->firstTimerHandlerPtr; } } } @@ -292,14 +292,14 @@ TclCreateAbsoluteTimerHandler( Tcl_Time *timePtr, Tcl_TimerProc *proc, ClientData clientData) { - register TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr; + TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr; ThreadSpecificData *tsdPtr = InitTimer(); - timerHandlerPtr = Tcl_Alloc(sizeof(TimerHandler)); + timerHandlerPtr = ckalloc(sizeof(TimerHandler)); /* * Fill in fields for the event. */ @@ -353,11 +353,11 @@ void Tcl_DeleteTimerHandler( Tcl_TimerToken token) /* Result previously returned by * Tcl_DeleteTimerHandler. */ { - register TimerHandler *timerHandlerPtr, *prevPtr; + TimerHandler *timerHandlerPtr, *prevPtr; ThreadSpecificData *tsdPtr = InitTimer(); if (token == NULL) { return; } @@ -371,11 +371,11 @@ if (prevPtr == NULL) { tsdPtr->firstTimerHandlerPtr = timerHandlerPtr->nextPtr; } else { prevPtr->nextPtr = timerHandlerPtr->nextPtr; } - Tcl_Free(timerHandlerPtr); + ckfree(timerHandlerPtr); return; } } /* @@ -486,11 +486,11 @@ */ if (blockTime.sec == 0 && blockTime.usec == 0 && !tsdPtr->timerPending) { tsdPtr->timerPending = 1; - timerEvPtr = Tcl_Alloc(sizeof(Tcl_Event)); + timerEvPtr = ckalloc(sizeof(Tcl_Event)); timerEvPtr->proc = TimerHandlerEventProc; Tcl_QueueEvent(timerEvPtr, TCL_QUEUE_TAIL); } } } @@ -589,11 +589,11 @@ * potential reentrancy problems. */ *nextPtrPtr = timerHandlerPtr->nextPtr; timerHandlerPtr->proc(timerHandlerPtr->clientData); - Tcl_Free(timerHandlerPtr); + ckfree(timerHandlerPtr); } TimerSetupProc(NULL, TCL_TIMER_EVENTS); return 1; } @@ -619,15 +619,15 @@ void Tcl_DoWhenIdle( Tcl_IdleProc *proc, /* Function to invoke. */ ClientData clientData) /* Arbitrary value to pass to proc. */ { - register IdleHandler *idlePtr; + IdleHandler *idlePtr; Tcl_Time blockTime; ThreadSpecificData *tsdPtr = InitTimer(); - idlePtr = Tcl_Alloc(sizeof(IdleHandler)); + idlePtr = ckalloc(sizeof(IdleHandler)); idlePtr->proc = proc; idlePtr->clientData = clientData; idlePtr->generation = tsdPtr->idleGeneration; idlePtr->nextPtr = NULL; if (tsdPtr->lastIdlePtr == NULL) { @@ -663,20 +663,20 @@ void Tcl_CancelIdleCall( Tcl_IdleProc *proc, /* Function that was previously registered. */ ClientData clientData) /* Arbitrary value to pass to proc. */ { - register IdleHandler *idlePtr, *prevPtr; + IdleHandler *idlePtr, *prevPtr; IdleHandler *nextPtr; ThreadSpecificData *tsdPtr = InitTimer(); for (prevPtr = NULL, idlePtr = tsdPtr->idleList; idlePtr != NULL; prevPtr = idlePtr, idlePtr = idlePtr->nextPtr) { while ((idlePtr->proc == proc) && (idlePtr->clientData == clientData)) { nextPtr = idlePtr->nextPtr; - Tcl_Free(idlePtr); + ckfree(idlePtr); idlePtr = nextPtr; if (prevPtr == NULL) { tsdPtr->idleList = idlePtr; } else { prevPtr->nextPtr = idlePtr; @@ -747,11 +747,11 @@ tsdPtr->idleList = idlePtr->nextPtr; if (tsdPtr->idleList == NULL) { tsdPtr->lastIdlePtr = NULL; } idlePtr->proc(idlePtr->clientData); - Tcl_Free(idlePtr); + ckfree(idlePtr); } if (tsdPtr->idleList) { blockTime.sec = 0; blockTime.usec = 0; Tcl_SetMaxBlockTime(&blockTime); @@ -786,12 +786,12 @@ { Tcl_WideInt ms = 0; /* Number of milliseconds to wait */ Tcl_Time wakeup; AfterInfo *afterPtr; AfterAssocData *assocPtr; - size_t length; - int index = -1; + int length; + int index; static const char *const afterSubCmds[] = { "cancel", "idle", "info", NULL }; enum afterSubCmds {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO}; ThreadSpecificData *tsdPtr = InitTimer(); @@ -806,24 +806,30 @@ * doesn't already exist. */ assocPtr = Tcl_GetAssocData(interp, "tclAfter", NULL); if (assocPtr == NULL) { - assocPtr = Tcl_Alloc(sizeof(AfterAssocData)); + assocPtr = ckalloc(sizeof(AfterAssocData)); assocPtr->interp = interp; assocPtr->firstAfterPtr = NULL; Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc, assocPtr); } /* * First lets see if the command was passed a number as the first argument. */ - if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) { - if (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0, &index) - != TCL_OK) { - const char *arg = TclGetString(objv[1]); + if (objv[1]->typePtr == &tclIntType +#ifndef TCL_WIDE_INT_IS_LONG + || objv[1]->typePtr == &tclWideIntType +#endif + || objv[1]->typePtr == &tclBignumType + || (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0, + &index) != TCL_OK)) { + index = -1; + if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) { + const char *arg = Tcl_GetString(objv[1]); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad argument \"%s\": must be" " cancel, idle, info, or an integer", arg)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "argument", @@ -843,11 +849,11 @@ ms = 0; } if (objc == 2) { return AfterDelay(interp, ms); } - afterPtr = Tcl_Alloc(sizeof(AfterInfo)); + afterPtr = ckalloc(sizeof(AfterInfo)); afterPtr->assocPtr = assocPtr; if (objc == 3) { afterPtr->commandPtr = objv[2]; } else { afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2); @@ -881,25 +887,25 @@ return TCL_OK; } case AFTER_CANCEL: { Tcl_Obj *commandPtr; const char *command, *tempCommand; - size_t tempLength; + int tempLength; if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "id|command"); return TCL_ERROR; } if (objc == 3) { commandPtr = objv[2]; } else { - commandPtr = Tcl_ConcatObj(objc-2, objv+2);; + commandPtr = Tcl_ConcatObj(objc-2, objv+2); } - command = TclGetStringFromObj(commandPtr, &length); + command = Tcl_GetStringFromObj(commandPtr, &length); for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; afterPtr = afterPtr->nextPtr) { - tempCommand = TclGetStringFromObj(afterPtr->commandPtr, + tempCommand = Tcl_GetStringFromObj(afterPtr->commandPtr, &tempLength); if ((length == tempLength) && !memcmp(command, tempCommand, length)) { break; } @@ -923,11 +929,11 @@ case AFTER_IDLE: if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "script ?script ...?"); return TCL_ERROR; } - afterPtr = Tcl_Alloc(sizeof(AfterInfo)); + afterPtr = ckalloc(sizeof(AfterInfo)); afterPtr->assocPtr = assocPtr; if (objc == 3) { afterPtr->commandPtr = objv[2]; } else { afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2); @@ -1037,10 +1043,15 @@ } } if (iPtr->limit.timeEvent == NULL || TCL_TIME_BEFORE(endTime, iPtr->limit.time)) { diff = TCL_TIME_DIFF_MS_CEILING(endTime, now); +#ifndef TCL_WIDE_INT_IS_LONG + if (diff > LONG_MAX) { + diff = LONG_MAX; + } +#endif if (diff > TCL_TIME_MAXIMUM_SLICE) { diff = TCL_TIME_MAXIMUM_SLICE; } if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) { diff = 1; @@ -1053,15 +1064,20 @@ } else { break; } } else { diff = TCL_TIME_DIFF_MS(iPtr->limit.time, now); +#ifndef TCL_WIDE_INT_IS_LONG + if (diff > LONG_MAX) { + diff = LONG_MAX; + } +#endif if (diff > TCL_TIME_MAXIMUM_SLICE) { diff = TCL_TIME_MAXIMUM_SLICE; } if (diff > 0) { - Tcl_Sleep((int) diff); + Tcl_Sleep((long) diff); } if (Tcl_AsyncReady()) { if (Tcl_AsyncInvoke(interp, TCL_OK) != TCL_OK) { return TCL_ERROR; } @@ -1071,11 +1087,11 @@ } if (Tcl_LimitCheck(interp) != TCL_OK) { return TCL_ERROR; } } - Tcl_GetTime(&now); + Tcl_GetTime(&now); } while (TCL_TIME_BEFORE(now, endTime)); return TCL_OK; } /* @@ -1188,11 +1204,11 @@ /* * Free the memory for the callback. */ Tcl_DecrRefCount(afterPtr->commandPtr); - Tcl_Free(afterPtr); + ckfree(afterPtr); } /* *---------------------------------------------------------------------- * @@ -1226,11 +1242,11 @@ /* Empty loop body. */ } prevPtr->nextPtr = afterPtr->nextPtr; } Tcl_DecrRefCount(afterPtr->commandPtr); - Tcl_Free(afterPtr); + ckfree(afterPtr); } /* *---------------------------------------------------------------------- * @@ -1265,13 +1281,13 @@ Tcl_DeleteTimerHandler(afterPtr->token); } else { Tcl_CancelIdleCall(AfterProc, afterPtr); } Tcl_DecrRefCount(afterPtr->commandPtr); - Tcl_Free(afterPtr); + ckfree(afterPtr); } - Tcl_Free(assocPtr); + ckfree(assocPtr); } /* * Local Variables: * mode: c Index: generic/tclTomMath.decls ================================================================== --- generic/tclTomMath.decls +++ generic/tclTomMath.decls @@ -28,17 +28,17 @@ declare 1 { int TclBN_revision(void) } declare 2 { - int TclBN_mp_add(const mp_int *a, const mp_int *b, mp_int *c) + mp_err TclBN_mp_add(const mp_int *a, const mp_int *b, mp_int *c) } declare 3 { - int TclBN_mp_add_d(const mp_int *a, mp_digit b, mp_int *c) + mp_err TclBN_mp_add_d(const mp_int *a, mp_digit b, mp_int *c) } declare 4 { - int TclBN_mp_and(const mp_int *a, const mp_int *b, mp_int *c) + mp_err TclBN_mp_and(const mp_int *a, const mp_int *b, mp_int *c) } declare 5 { void TclBN_mp_clamp(mp_int *a) } declare 6 { @@ -46,201 +46,231 @@ } declare 7 { void TclBN_mp_clear_multi(mp_int *a, ...) } declare 8 { - int TclBN_mp_cmp(const mp_int *a, const mp_int *b) + mp_ord TclBN_mp_cmp(const mp_int *a, const mp_int *b) } declare 9 { - int TclBN_mp_cmp_d(const mp_int *a, mp_digit b) + mp_ord TclBN_mp_cmp_d(const mp_int *a, mp_digit b) } declare 10 { - int TclBN_mp_cmp_mag(const mp_int *a, const mp_int *b) + mp_ord TclBN_mp_cmp_mag(const mp_int *a, const mp_int *b) } declare 11 { - int TclBN_mp_copy(const mp_int *a, mp_int *b) + mp_err TclBN_mp_copy(const mp_int *a, mp_int *b) } declare 12 { int TclBN_mp_count_bits(const mp_int *a) } declare 13 { - int TclBN_mp_div(const mp_int *a, const mp_int *b, mp_int *q, mp_int *r) + mp_err TclBN_mp_div(const mp_int *a, const mp_int *b, mp_int *q, mp_int *r) } declare 14 { - int TclBN_mp_div_d(const mp_int *a, mp_digit b, mp_int *q, mp_digit *r) + mp_err TclBN_mp_div_d(const mp_int *a, mp_digit b, mp_int *q, mp_digit *r) } declare 15 { - int TclBN_mp_div_2(const mp_int *a, mp_int *q) + mp_err TclBN_mp_div_2(const mp_int *a, mp_int *q) } declare 16 { - int TclBN_mp_div_2d(const mp_int *a, int b, mp_int *q, mp_int *r) + mp_err TclBN_mp_div_2d(const mp_int *a, int b, mp_int *q, mp_int *r) } declare 17 { - int TclBN_mp_div_3(const mp_int *a, mp_int *q, mp_digit *r) + mp_err TclBN_mp_div_3(const mp_int *a, mp_int *q, mp_digit *r) } declare 18 { void TclBN_mp_exch(mp_int *a, mp_int *b) } declare 19 { - int TclBN_mp_expt_d(const mp_int *a, mp_digit b, mp_int *c) + mp_err TclBN_mp_expt_d(const mp_int *a, unsigned int b, mp_int *c) } declare 20 { - int TclBN_mp_grow(mp_int *a, int size) + mp_err TclBN_mp_grow(mp_int *a, int size) } declare 21 { - int TclBN_mp_init(mp_int *a) + mp_err TclBN_mp_init(mp_int *a) } declare 22 { - int TclBN_mp_init_copy(mp_int *a, const mp_int *b) + mp_err TclBN_mp_init_copy(mp_int *a, const mp_int *b) } declare 23 { - int TclBN_mp_init_multi(mp_int *a, ...) + mp_err TclBN_mp_init_multi(mp_int *a, ...) } declare 24 { - int TclBN_mp_init_set(mp_int *a, mp_digit b) + mp_err TclBN_mp_init_set(mp_int *a, mp_digit b) } declare 25 { - int TclBN_mp_init_size(mp_int *a, int size) + mp_err TclBN_mp_init_size(mp_int *a, int size) } declare 26 { - int TclBN_mp_lshd(mp_int *a, int shift) + mp_err TclBN_mp_lshd(mp_int *a, int shift) } declare 27 { - int TclBN_mp_mod(const mp_int *a, const mp_int *b, mp_int *r) + mp_err TclBN_mp_mod(const mp_int *a, const mp_int *b, mp_int *r) } declare 28 { - int TclBN_mp_mod_2d(const mp_int *a, int b, mp_int *r) + mp_err TclBN_mp_mod_2d(const mp_int *a, int b, mp_int *r) } declare 29 { - int TclBN_mp_mul(const mp_int *a, const mp_int *b, mp_int *p) + mp_err TclBN_mp_mul(const mp_int *a, const mp_int *b, mp_int *p) } declare 30 { - int TclBN_mp_mul_d(const mp_int *a, mp_digit b, mp_int *p) + mp_err TclBN_mp_mul_d(const mp_int *a, mp_digit b, mp_int *p) } declare 31 { - int TclBN_mp_mul_2(const mp_int *a, mp_int *p) + mp_err TclBN_mp_mul_2(const mp_int *a, mp_int *p) } declare 32 { - int TclBN_mp_mul_2d(const mp_int *a, int d, mp_int *p) + mp_err TclBN_mp_mul_2d(const mp_int *a, int d, mp_int *p) } declare 33 { - int TclBN_mp_neg(const mp_int *a, mp_int *b) + mp_err TclBN_mp_neg(const mp_int *a, mp_int *b) } declare 34 { - int TclBN_mp_or(const mp_int *a, const mp_int *b, mp_int *c) + mp_err TclBN_mp_or(const mp_int *a, const mp_int *b, mp_int *c) } declare 35 { - int TclBN_mp_radix_size(const mp_int *a, int radix, int *size) + mp_err TclBN_mp_radix_size(const mp_int *a, int radix, int *size) } declare 36 { - int TclBN_mp_read_radix(mp_int *a, const char *str, int radix) + mp_err TclBN_mp_read_radix(mp_int *a, const char *str, int radix) } declare 37 { void TclBN_mp_rshd(mp_int *a, int shift) } declare 38 { - int TclBN_mp_shrink(mp_int *a) + mp_err TclBN_mp_shrink(mp_int *a) } declare 39 { void TclBN_mp_set(mp_int *a, mp_digit b) } declare 40 { - int TclBN_mp_sqr(const mp_int *a, mp_int *b) + mp_err TclBN_mp_sqr(const mp_int *a, mp_int *b) } declare 41 { - int TclBN_mp_sqrt(const mp_int *a, mp_int *b) + mp_err TclBN_mp_sqrt(const mp_int *a, mp_int *b) } declare 42 { - int TclBN_mp_sub(const mp_int *a, const mp_int *b, mp_int *c) + mp_err TclBN_mp_sub(const mp_int *a, const mp_int *b, mp_int *c) } declare 43 { - int TclBN_mp_sub_d(const mp_int *a, mp_digit b, mp_int *c) + mp_err TclBN_mp_sub_d(const mp_int *a, mp_digit b, mp_int *c) } declare 44 { - int TclBN_mp_to_unsigned_bin(const mp_int *a, unsigned char *b) + mp_err TclBN_mp_to_unsigned_bin(const mp_int *a, unsigned char *b) } declare 45 { - int TclBN_mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, + mp_err TclBN_mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen) } declare 46 { - int TclBN_mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen) + mp_err TclBN_mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen) } declare 47 { - int TclBN_mp_unsigned_bin_size(const mp_int *a) + size_t TclBN_mp_unsigned_bin_size(const mp_int *a) } declare 48 { - int TclBN_mp_xor(const mp_int *a, const mp_int *b, mp_int *c) + mp_err TclBN_mp_xor(const mp_int *a, const mp_int *b, mp_int *c) } declare 49 { void TclBN_mp_zero(mp_int *a) } + +# internal routines to libtommath - should not be called but must be +# exported to accommodate the "tommath" extension + +declare 50 { + void TclBN_reverse(unsigned char *s, int len) +} +declare 51 { + mp_err TclBN_fast_s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs) +} +declare 52 { + mp_err TclBN_fast_s_mp_sqr(const mp_int *a, mp_int *b) +} +declare 53 { + mp_err TclBN_mp_karatsuba_mul(const mp_int *a, const mp_int *b, mp_int *c) +} +declare 54 { + mp_err TclBN_mp_karatsuba_sqr(const mp_int *a, mp_int *b) +} +declare 55 { + mp_err TclBN_mp_toom_mul(const mp_int *a, const mp_int *b, mp_int *c) +} +declare 56 { + mp_err TclBN_mp_toom_sqr(const mp_int *a, mp_int *b) +} +declare 57 { + mp_err TclBN_s_mp_add(const mp_int *a, const mp_int *b, mp_int *c) +} +declare 58 { + mp_err TclBN_s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs) +} +declare 59 { + mp_err TclBN_s_mp_sqr(const mp_int *a, mp_int *b) +} +declare 60 { + mp_err TclBN_s_mp_sub(const mp_int *a, const mp_int *b, mp_int *c) +} declare 61 { - int TclBN_mp_init_set_int(mp_int *a, unsigned long i) + mp_err TclBN_mp_init_set_int(mp_int *a, unsigned long i) } declare 62 { - int TclBN_mp_set_int(mp_int *a, unsigned long i) + mp_err TclBN_mp_set_int(mp_int *a, unsigned long i) } declare 63 { int TclBN_mp_cnt_lsb(const mp_int *a) } - -# Formerly internal API to allow initialisation of bignums without knowing the -# typedefs of how a bignum works internally. -# Removed in 9.0 -#declare 64 { -# void TclBNInitBignumFromLong(mp_int *bignum, long initVal) -#} -# Removed in 9.0 -#declare 65 { -# void TclBNInitBignumFromWideInt(mp_int *bignum, Tcl_WideInt initVal) -#} -# Removed in 9.0 -#declare 66 { -# void TclBNInitBignumFromWideUInt(mp_int *bignum, Tcl_WideUInt initVal) -#} +declare 64 { + int TclBNInitBignumFromLong(mp_int *bignum, long initVal) +} +declare 65 { + int TclBNInitBignumFromWideInt(mp_int *bignum, Tcl_WideInt initVal) +} +declare 66 { + int TclBNInitBignumFromWideUInt(mp_int *bignum, Tcl_WideUInt initVal) +} # Added in libtommath 1.0 declare 67 { - int TclBN_mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast) + mp_err TclBN_mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast) } # Added in libtommath 1.0.1 declare 68 { - int TclBN_mp_set_long_long(mp_int *a, Tcl_WideUInt i) + void TclBN_mp_set_ull(mp_int *a, Tcl_WideUInt i) } declare 69 { - Tcl_WideUInt TclBN_mp_get_long_long(const mp_int *a) + Tcl_WideUInt TclBN_mp_get_mag_ull(const mp_int *a) } declare 70 { - int TclBN_mp_set_long(mp_int *a, unsigned long i) -} -declare 71 { - unsigned long TclBN_mp_get_long(const mp_int *a) -} -declare 72 { - unsigned long TclBN_mp_get_int(const mp_int *a) + void TclBN_mp_set_ll(mp_int *a, Tcl_WideInt i) } # Added in libtommath 1.1.0 -# No longer in use: replaced by mp_and() -#declare 73 { -# int TclBN_mp_tc_and(const mp_int *a, const mp_int *b, mp_int *c) -#} -# No longer in use: replaced by mp_or() -#declare 74 { -# int TclBN_mp_tc_or(const mp_int *a, const mp_int *b, mp_int *c) -#} -# No longer in use: replaced by mp_xor() -#declare 75 { -# int TclBN_mp_tc_xor(const mp_int *a, const mp_int *b, mp_int *c) -#} +declare 73 { + mp_err TclBN_mp_tc_and(const mp_int *a, const mp_int *b, mp_int *c) +} +declare 74 { + mp_err TclBN_mp_tc_or(const mp_int *a, const mp_int *b, mp_int *c) +} +declare 75 { + mp_err TclBN_mp_tc_xor(const mp_int *a, const mp_int *b, mp_int *c) +} declare 76 { - int TclBN_mp_signed_rsh(const mp_int *a, int b, mp_int *c) + mp_err TclBN_mp_signed_rsh(const mp_int *a, int b, mp_int *c) +} + +# Added in libtommath 1.2.0 +declare 78 { + int TclBN_mp_to_ubin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written) +} +declare 79 { + mp_err TclBN_mp_div_ld(const mp_int *a, Tcl_WideUInt b, mp_int *q, Tcl_WideUInt *r) } -declare 77 { - int TclBN_mp_get_bit(const mp_int *a, int b) +declare 80 { + int TclBN_mp_to_radix(const mp_int *a, char *str, size_t maxlen, size_t *written, int radix) } # Local Variables: # mode: tcl # End: Index: generic/tclTomMath.h ================================================================== --- generic/tclTomMath.h +++ generic/tclTomMath.h @@ -2,11 +2,10 @@ /* SPDX-License-Identifier: Unlicense */ #ifndef BN_H_ #define BN_H_ -#include "tclTomMathDecls.h" #ifndef MODULE_SCOPE #define MODULE_SCOPE extern #endif @@ -14,11 +13,11 @@ #ifdef __cplusplus extern "C" { #endif /* MS Visual C++ doesn't have a 128bit type for words, so fall back to 32bit MPI's (where words are 64bit) */ -#if defined(_WIN32) || defined(__LLP64__) || defined(__e2k__) || defined(__LCC__) +#if (defined(_WIN32) || defined(__LLP64__) || defined(__e2k__) || defined(__LCC__)) && !defined(MP_64BIT) # define MP_32BIT #endif /* detect 64-bit mode if possible */ #if defined(NEVER) @@ -30,53 +29,58 @@ /* otherwise we fall back to MP_32BIT even on 64bit platforms */ # define MP_32BIT # endif # endif #endif + +#ifdef MP_DIGIT_BIT +# error Defining MP_DIGIT_BIT is disallowed, use MP_8/16/31/32/64BIT +#endif /* some default configurations. * - * A "mp_digit" must be able to hold DIGIT_BIT + 1 bits - * A "mp_word" must be able to hold 2*DIGIT_BIT + 1 bits + * A "mp_digit" must be able to hold MP_DIGIT_BIT + 1 bits + * A "mp_word" must be able to hold 2*MP_DIGIT_BIT + 1 bits * * At the very least a mp_digit must be able to hold 7 bits * [any size beyond that is ok provided it doesn't overflow the data type] */ + #ifdef MP_8BIT #ifndef MP_DIGIT_DECLARED typedef unsigned char mp_digit; #define MP_DIGIT_DECLARED #endif #ifndef MP_WORD_DECLARED -typedef unsigned short mp_word; +typedef unsigned short private_mp_word; #define MP_WORD_DECLARED #endif # define MP_SIZEOF_MP_DIGIT 1 -# ifdef DIGIT_BIT -# error You must not define DIGIT_BIT when using MP_8BIT +# ifdef MP_DIGIT_BIT +# error You must not define MP_DIGIT_BIT when using MP_8BIT # endif #elif defined(MP_16BIT) #ifndef MP_DIGIT_DECLARED typedef unsigned short mp_digit; #define MP_DIGIT_DECLARED #endif #ifndef MP_WORD_DECLARED -typedef unsigned int mp_word; +typedef unsigned int private_mp_word; #define MP_WORD_DECLARED #endif # define MP_SIZEOF_MP_DIGIT 2 -# ifdef DIGIT_BIT -# error You must not define DIGIT_BIT when using MP_16BIT +# ifdef MP_DIGIT_BIT +# error You must not define MP_DIGIT_BIT when using MP_16BIT # endif #elif defined(MP_64BIT) /* for GCC only on supported platforms */ #ifndef MP_DIGIT_DECLARED typedef unsigned long long mp_digit; #define MP_DIGIT_DECLARED #endif -typedef unsigned long mp_word __attribute__((mode(TI))); -# define DIGIT_BIT 60 +typedef unsigned long private_mp_word __attribute__((mode(TI))); +# define MP_DIGIT_BIT 60 #else /* this is the default case, 28-bit digits */ /* this is to make porting into LibTomCrypt easier :-) */ #ifndef MP_DIGIT_DECLARED @@ -83,60 +87,117 @@ typedef unsigned int mp_digit; #define MP_DIGIT_DECLARED #endif #ifndef MP_WORD_DECLARED #ifdef _WIN32 -typedef unsigned __int64 mp_word; +typedef unsigned __int64 private_mp_word; #else -typedef unsigned long long mp_word; +typedef unsigned long long private_mp_word; #endif #define MP_WORD_DECLARED #endif # ifdef MP_31BIT -/* this is an extension that uses 31-bit digits */ -# define DIGIT_BIT 31 +/* + * This is an extension that uses 31-bit digits. + * Please be aware that not all functions support this size, especially s_mp_mul_digs_fast + * will be reduced to work on small numbers only: + * Up to 8 limbs, 248 bits instead of up to 512 limbs, 15872 bits with MP_28BIT. + */ +# define MP_DIGIT_BIT 31 # else /* default case is 28-bit digits, defines MP_28BIT as a handy macro to test */ -# define DIGIT_BIT 28 +# define MP_DIGIT_BIT 28 # define MP_28BIT # endif #endif /* otherwise the bits per digit is calculated automatically from the size of a mp_digit */ -#ifndef DIGIT_BIT -# define DIGIT_BIT (((CHAR_BIT * MP_SIZEOF_MP_DIGIT) - 1)) /* bits per digit */ +#ifndef MP_DIGIT_BIT +# define MP_DIGIT_BIT (((CHAR_BIT * MP_SIZEOF_MP_DIGIT) - 1)) /* bits per digit */ #endif -#define MP_DIGIT_BIT DIGIT_BIT -#define MP_MASK ((((mp_digit)1)<<((mp_digit)DIGIT_BIT))-((mp_digit)1)) +#define MP_MASK ((((mp_digit)1)<<((mp_digit)MP_DIGIT_BIT))-((mp_digit)1)) #define MP_DIGIT_MAX MP_MASK +/* Primality generation flags */ +#define MP_PRIME_BBS 0x0001 /* BBS style prime */ +#define MP_PRIME_SAFE 0x0002 /* Safe prime (p-1)/2 == prime */ +#define MP_PRIME_2MSB_ON 0x0008 /* force 2nd MSB to 1 */ + +#define LTM_PRIME_BBS (MP_DEPRECATED_PRAGMA("LTM_PRIME_BBS has been deprecated, use MP_PRIME_BBS") MP_PRIME_BBS) +#define LTM_PRIME_SAFE (MP_DEPRECATED_PRAGMA("LTM_PRIME_SAFE has been deprecated, use MP_PRIME_SAFE") MP_PRIME_SAFE) +#define LTM_PRIME_2MSB_ON (MP_DEPRECATED_PRAGMA("LTM_PRIME_2MSB_ON has been deprecated, use MP_PRIME_2MSB_ON") MP_PRIME_2MSB_ON) + +#ifdef MP_USE_ENUMS +typedef enum { + MP_ZPOS = 0, /* positive */ + MP_NEG = 1 /* negative */ +} mp_sign; +typedef enum { + MP_LT = -1, /* less than */ + MP_EQ = 0, /* equal */ + MP_GT = 1 /* greater than */ +} mp_ord; +typedef enum { + MP_NO = 0, + MP_YES = 1 +} mp_bool; +typedef enum { + MP_OKAY = 0, /* no error */ + MP_ERR = -1, /* unknown error */ + MP_MEM = -2, /* out of mem */ + MP_VAL = -3, /* invalid input */ + MP_ITER = -4, /* maximum iterations reached */ + MP_BUF = -5 /* buffer overflow, supplied buffer too small */ +} mp_err; +typedef enum { + MP_LSB_FIRST = -1, + MP_MSB_FIRST = 1 +} mp_order; +typedef enum { + MP_LITTLE_ENDIAN = -1, + MP_NATIVE_ENDIAN = 0, + MP_BIG_ENDIAN = 1 +} mp_endian; +#else typedef int mp_sign; #define MP_ZPOS 0 /* positive integer */ #define MP_NEG 1 /* negative */ typedef int mp_ord; #define MP_LT -1 /* less than */ #define MP_EQ 0 /* equal to */ #define MP_GT 1 /* greater than */ typedef int mp_bool; -#define MP_YES 1 /* yes response */ -#define MP_NO 0 /* no response */ +#define MP_YES 1 +#define MP_NO 0 typedef int mp_err; -#define MP_OKAY 0 /* ok result */ +#define MP_OKAY 0 /* no error */ #define MP_ERR -1 /* unknown error */ #define MP_MEM -2 /* out of mem */ #define MP_VAL -3 /* invalid input */ -#define MP_RANGE MP_VAL -#define MP_ITER -4 /* Max. iterations reached */ - -/* Primality generation flags */ -#define LTM_PRIME_BBS 0x0001 /* BBS style prime */ -#define LTM_PRIME_SAFE 0x0002 /* Safe prime (p-1)/2 == prime */ -#define LTM_PRIME_2MSB_ON 0x0008 /* force 2nd MSB to 1 */ +#define MP_RANGE (MP_DEPRECATED_PRAGMA("MP_RANGE has been deprecated in favor of MP_VAL") MP_VAL) +#define MP_ITER -4 /* maximum iterations reached */ +#define MP_BUF -5 /* buffer overflow, supplied buffer too small */ +typedef int mp_order; +#define MP_LSB_FIRST -1 +#define MP_MSB_FIRST 1 +typedef int mp_endian; +#define MP_LITTLE_ENDIAN -1 +#define MP_NATIVE_ENDIAN 0 +#define MP_BIG_ENDIAN 1 +#endif /* tunable cutoffs */ + +#ifndef MP_FIXED_CUTOFFS +extern int +KARATSUBA_MUL_CUTOFF, +KARATSUBA_SQR_CUTOFF, +TOOM_MUL_CUTOFF, +TOOM_SQR_CUTOFF; +#endif /* define this to use lower memory usage routines (exptmods mostly) */ /* #define MP_LOW_MEM */ /* default precision */ @@ -149,11 +210,17 @@ # define MP_PREC 8 /* default digits of precision */ # endif #endif /* size of comba arrays, should be at least 2 * 2**(BITS_PER_WORD - BITS_PER_DIGIT*2) */ -#define MP_WARRAY (1u << (((sizeof(mp_word) * CHAR_BIT) - (2 * DIGIT_BIT)) + 1)) +#define PRIVATE_MP_WARRAY (int)(1 << (((CHAR_BIT * sizeof(private_mp_word)) - (2 * MP_DIGIT_BIT)) + 1)) + +#if defined(__GNUC__) && __GNUC__ >= 4 +# define MP_NULL_TERMINATED __attribute__((sentinel)) +#else +# define MP_NULL_TERMINATED +#endif /* * MP_WUR - warn unused result * --------------------------- * @@ -174,22 +241,23 @@ # else # define MP_WUR # endif #endif -#if defined(__GNUC__) && (__GNUC__ * 100 + __GNUC_MINOR__ >= 301) +#if defined(__GNUC__) && (__GNUC__ * 100 + __GNUC_MINOR__ >= 405) # define MP_DEPRECATED(x) __attribute__((deprecated("replaced by " #x))) # define PRIVATE_MP_DEPRECATED_PRAGMA(s) _Pragma(#s) # define MP_DEPRECATED_PRAGMA(s) PRIVATE_MP_DEPRECATED_PRAGMA(GCC warning s) #elif defined(_MSC_VER) && _MSC_VER >= 1500 # define MP_DEPRECATED(x) __declspec(deprecated("replaced by " #x)) # define MP_DEPRECATED_PRAGMA(s) __pragma(message(s)) #else -# define MP_DEPRECATED +# define MP_DEPRECATED(s) # define MP_DEPRECATED_PRAGMA(s) #endif +#define DIGIT_BIT MP_DIGIT_BIT #define USED(m) ((m)->used) #define DIGIT(m,k) ((m)->dp[(k)]) #define SIGN(m) ((m)->sign) /* the infamous mp_int structure */ @@ -196,143 +264,252 @@ #ifndef MP_INT_DECLARED #define MP_INT_DECLARED typedef struct mp_int mp_int; #endif struct mp_int { - int used, alloc, sign; + int used, alloc; + mp_sign sign; mp_digit *dp; }; /* callback for mp_prime_random, should fill dst with random bytes and return how many read [upto len] */ -typedef int ltm_prime_callback(unsigned char *dst, int len, void *dat); - +typedef int private_mp_prime_callback(unsigned char *dst, int len, void *dat); +typedef private_mp_prime_callback MP_DEPRECATED(mp_rand_source) ltm_prime_callback; /* error code to char* string */ /* -const char *mp_error_to_string(mp_err code); +const char *mp_error_to_string(mp_err code) MP_WUR; */ /* ---> init and deinit bignum functions <--- */ /* init a bignum */ /* -mp_err mp_init(mp_int *a); +mp_err mp_init(mp_int *a) MP_WUR; */ /* free a bignum */ /* void mp_clear(mp_int *a); */ /* init a null terminated series of arguments */ /* -mp_err mp_init_multi(mp_int *mp, ...); +mp_err mp_init_multi(mp_int *mp, ...) MP_NULL_TERMINATED MP_WUR; */ /* clear a null terminated series of arguments */ /* -void mp_clear_multi(mp_int *mp, ...); +void mp_clear_multi(mp_int *mp, ...) MP_NULL_TERMINATED; */ /* exchange two ints */ /* void mp_exch(mp_int *a, mp_int *b); */ /* shrink ram required for a bignum */ /* -mp_err mp_shrink(mp_int *a); +mp_err mp_shrink(mp_int *a) MP_WUR; */ /* grow an int to a given size */ /* -mp_err mp_grow(mp_int *a, int size); +mp_err mp_grow(mp_int *a, int size) MP_WUR; */ /* init to a given number of digits */ /* -mp_err mp_init_size(mp_int *a, int size); +mp_err mp_init_size(mp_int *a, int size) MP_WUR; */ /* ---> Basic Manipulations <--- */ #define mp_iszero(a) (((a)->used == 0) ? MP_YES : MP_NO) +#define mp_isodd(a) (((a)->used != 0 && (((a)->dp[0] & 1) == 1)) ? MP_YES : MP_NO) #define mp_iseven(a) (((a)->used == 0 || (((a)->dp[0] & 1) == 0)) ? MP_YES : MP_NO) -#define mp_isodd(a) (((a)->used > 0 && (((a)->dp[0] & 1) == 1)) ? MP_YES : MP_NO) #define mp_isneg(a) (((a)->sign != MP_ZPOS) ? MP_YES : MP_NO) /* set to zero */ /* void mp_zero(mp_int *a); */ -/* set to a digit */ +/* get and set doubles */ +/* +double mp_get_double(const mp_int *a) MP_WUR; +*/ +/* +mp_err mp_set_double(mp_int *a, double b) MP_WUR; +*/ + +/* get integer, set integer and init with integer (int32_t) */ +#ifndef MP_NO_STDINT +/* +int32_t mp_get_i32(const mp_int *a) MP_WUR; +*/ +/* +void mp_set_i32(mp_int *a, int32_t b); +*/ +/* +mp_err mp_init_i32(mp_int *a, int32_t b) MP_WUR; +*/ + +/* get integer, set integer and init with integer, behaves like two complement for negative numbers (uint32_t) */ +#define mp_get_u32(a) ((uint32_t)mp_get_i32(a)) +/* +void mp_set_u32(mp_int *a, uint32_t b); +*/ +/* +mp_err mp_init_u32(mp_int *a, uint32_t b) MP_WUR; +*/ + +/* get integer, set integer and init with integer (int64_t) */ +/* +int64_t mp_get_i64(const mp_int *a) MP_WUR; +*/ +/* +void mp_set_i64(mp_int *a, int64_t b); +*/ +/* +mp_err mp_init_i64(mp_int *a, int64_t b) MP_WUR; +*/ + +/* get integer, set integer and init with integer, behaves like two complement for negative numbers (uint64_t) */ +#define mp_get_u64(a) ((uint64_t)mp_get_i64(a)) +/* +void mp_set_u64(mp_int *a, uint64_t b); +*/ +/* +mp_err mp_init_u64(mp_int *a, uint64_t b) MP_WUR; +*/ + +/* get magnitude */ +/* +uint32_t mp_get_mag_u32(const mp_int *a) MP_WUR; +*/ +/* +uint64_t mp_get_mag_u64(const mp_int *a) MP_WUR; +*/ +#endif +/* +unsigned long mp_get_mag_ul(const mp_int *a) MP_WUR; +*/ +/* +Tcl_WideUInt mp_get_mag_ull(const mp_int *a) MP_WUR; +*/ + +/* get integer, set integer (long) */ +/* +long mp_get_l(const mp_int *a) MP_WUR; +*/ +/* +void mp_set_l(mp_int *a, long b); +*/ +/* +mp_err mp_init_l(mp_int *a, long b) MP_WUR; +*/ + +/* get integer, set integer (unsigned long) */ +#define mp_get_ul(a) ((unsigned long)mp_get_l(a)) +/* +void mp_set_ul(mp_int *a, unsigned long b); +*/ +/* +mp_err mp_init_ul(mp_int *a, unsigned long b) MP_WUR; +*/ + +/* get integer, set integer (Tcl_WideInt) */ +/* +Tcl_WideInt mp_get_ll(const mp_int *a) MP_WUR; +*/ +/* +void mp_set_ll(mp_int *a, Tcl_WideInt b); +*/ +/* +mp_err mp_init_ll(mp_int *a, Tcl_WideInt b) MP_WUR; +*/ + +/* get integer, set integer (Tcl_WideUInt) */ +#define mp_get_ull(a) ((Tcl_WideUInt)mp_get_ll(a)) +/* +void mp_set_ull(mp_int *a, Tcl_WideUInt b); +*/ +/* +mp_err mp_init_ull(mp_int *a, Tcl_WideUInt b) MP_WUR; +*/ + +/* set to single unsigned digit, up to MP_DIGIT_MAX */ /* void mp_set(mp_int *a, mp_digit b); */ - -/* set a 32-bit const */ -/* -int mp_set_int(mp_int *a, unsigned long b); -*/ - -/* set a platform dependent unsigned long value */ -/* -int mp_set_long(mp_int *a, unsigned long b); -*/ - -/* set a platform dependent unsigned long long value */ -/* -int mp_set_long_long(mp_int *a, unsigned long long b); -*/ - -/* get a 32-bit value */ -/* -unsigned long mp_get_int(const mp_int *a); -*/ - -/* get a platform dependent unsigned long value */ -/* -unsigned long mp_get_long(const mp_int *a); -*/ - -/* get a platform dependent unsigned long long value */ -/* -unsigned long long mp_get_long_long(const mp_int *a); -*/ - -/* initialize and set a digit */ -/* -int mp_init_set(mp_int *a, mp_digit b); -*/ - -/* initialize and set 32-bit value */ -/* -int mp_init_set_int(mp_int *a, unsigned long b); +/* +mp_err mp_init_set(mp_int *a, mp_digit b) MP_WUR; +*/ + +/* get integer, set integer and init with integer (deprecated) */ +/* +MP_DEPRECATED(mp_get_mag_u32/mp_get_u32) unsigned long mp_get_int(const mp_int *a) MP_WUR; +*/ +/* +MP_DEPRECATED(mp_get_mag_ul/mp_get_ul) unsigned long mp_get_long(const mp_int *a) MP_WUR; +*/ +/* +MP_DEPRECATED(mp_get_mag_ull/mp_get_ull) Tcl_WideUInt mp_get_long_long(const mp_int *a) MP_WUR; +*/ +/* +MP_DEPRECATED(mp_set_ul) mp_err mp_set_int(mp_int *a, unsigned long b); +*/ +/* +MP_DEPRECATED(mp_set_ul) mp_err mp_set_long(mp_int *a, unsigned long b); +*/ +/* +MP_DEPRECATED(mp_set_ull) mp_err mp_set_long_long(mp_int *a, Tcl_WideUInt b); +*/ +/* +MP_DEPRECATED(mp_init_ul) mp_err mp_init_set_int(mp_int *a, unsigned long b) MP_WUR; */ /* copy, b = a */ /* -int mp_copy(const mp_int *a, mp_int *b); +mp_err mp_copy(const mp_int *a, mp_int *b) MP_WUR; */ /* inits and copies, a = b */ /* -int mp_init_copy(mp_int *a, const mp_int *b); +mp_err mp_init_copy(mp_int *a, const mp_int *b) MP_WUR; */ /* trim unused digits */ /* void mp_clamp(mp_int *a); */ -/* import binary data */ -/* -int mp_import(mp_int *rop, size_t count, int order, size_t size, int endian, size_t nails, const void *op); -*/ - /* export binary data */ /* -int mp_export(void *rop, size_t *countp, int order, size_t size, int endian, size_t nails, const mp_int *op); +MP_DEPRECATED(mp_pack) mp_err mp_export(void *rop, size_t *countp, int order, size_t size, + int endian, size_t nails, const mp_int *op) MP_WUR; +*/ + +/* import binary data */ +/* +MP_DEPRECATED(mp_unpack) mp_err mp_import(mp_int *rop, size_t count, int order, + size_t size, int endian, size_t nails, + const void *op) MP_WUR; +*/ + +/* unpack binary data */ +/* +mp_err mp_unpack(mp_int *rop, size_t count, mp_order order, size_t size, mp_endian endian, + size_t nails, const void *op) MP_WUR; +*/ + +/* pack binary data */ +/* +size_t mp_pack_count(const mp_int *a, size_t nails, size_t size) MP_WUR; +*/ +/* +mp_err mp_pack(void *rop, size_t maxcount, size_t *written, mp_order order, size_t size, + mp_endian endian, size_t nails, const mp_int *op) MP_WUR; */ /* ---> digit manipulation <--- */ /* right shift by "b" digits */ @@ -340,57 +517,66 @@ void mp_rshd(mp_int *a, int b); */ /* left shift by "b" digits */ /* -int mp_lshd(mp_int *a, int b); +mp_err mp_lshd(mp_int *a, int b) MP_WUR; */ /* c = a / 2**b, implemented as c = a >> b */ /* -int mp_div_2d(const mp_int *a, int b, mp_int *c, mp_int *d); +mp_err mp_div_2d(const mp_int *a, int b, mp_int *c, mp_int *d) MP_WUR; */ /* b = a/2 */ /* -int mp_div_2(const mp_int *a, mp_int *b); +mp_err mp_div_2(const mp_int *a, mp_int *b) MP_WUR; +*/ + +/* a/3 => 3c + d == a */ +/* +mp_err mp_div_3(const mp_int *a, mp_int *c, mp_digit *d) MP_WUR; */ /* c = a * 2**b, implemented as c = a << b */ /* -int mp_mul_2d(const mp_int *a, int b, mp_int *c); +mp_err mp_mul_2d(const mp_int *a, int b, mp_int *c) MP_WUR; */ /* b = a*2 */ /* -int mp_mul_2(const mp_int *a, mp_int *b); +mp_err mp_mul_2(const mp_int *a, mp_int *b) MP_WUR; */ /* c = a mod 2**b */ /* -int mp_mod_2d(const mp_int *a, int b, mp_int *c); +mp_err mp_mod_2d(const mp_int *a, int b, mp_int *c) MP_WUR; */ /* computes a = 2**b */ /* -int mp_2expt(mp_int *a, int b); +mp_err mp_2expt(mp_int *a, int b) MP_WUR; */ /* Counts the number of lsbs which are zero before the first zero bit */ /* -int mp_cnt_lsb(const mp_int *a); +int mp_cnt_lsb(const mp_int *a) MP_WUR; */ /* I Love Earth! */ /* makes a pseudo-random mp_int of a given size */ /* -int mp_rand(mp_int *a, int digits); +mp_err mp_rand(mp_int *a, int digits) MP_WUR; */ /* makes a pseudo-random small int of a given size */ /* -int mp_rand_digit(mp_digit *r); +MP_DEPRECATED(mp_rand) mp_err mp_rand_digit(mp_digit *r) MP_WUR; +*/ +/* use custom random data source instead of source provided the platform */ +/* +void mp_rand_source(mp_err(*source)(void *out, size_t size)); */ #ifdef MP_PRNG_ENABLE_LTM_RNG /* A last resort to provide random data on systems without any of the other * implemented ways to gather entropy. @@ -399,324 +585,365 @@ extern unsigned long (*ltm_rng)(unsigned char *out, unsigned long outlen, void (*callback)(void)); extern void (*ltm_rng_callback)(void); #endif /* ---> binary operations <--- */ -/* c = a XOR b */ -/* -int mp_xor(const mp_int *a, const mp_int *b, mp_int *c); -*/ - -/* c = a OR b */ -/* -int mp_or(const mp_int *a, const mp_int *b, mp_int *c); -*/ - -/* c = a AND b */ -/* -int mp_and(const mp_int *a, const mp_int *b, mp_int *c); -*/ - -/* right shift (two complement) */ -/* -int mp_signed_rsh(const mp_int *a, int b, mp_int *c); + +/* Checks the bit at position b and returns MP_YES + * if the bit is 1, MP_NO if it is 0 and MP_VAL + * in case of error + */ +/* +MP_DEPRECATED(s_mp_get_bit) int mp_get_bit(const mp_int *a, int b) MP_WUR; +*/ + +/* c = a XOR b (two complement) */ +/* +MP_DEPRECATED(mp_xor) mp_err mp_tc_xor(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; +*/ +/* +mp_err mp_xor(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; +*/ + +/* c = a OR b (two complement) */ +/* +MP_DEPRECATED(mp_or) mp_err mp_tc_or(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; +*/ +/* +mp_err mp_or(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; +*/ + +/* c = a AND b (two complement) */ +/* +MP_DEPRECATED(mp_and) mp_err mp_tc_and(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; +*/ +/* +mp_err mp_and(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; +*/ + +/* b = ~a (bitwise not, two complement) */ +/* +mp_err mp_complement(const mp_int *a, mp_int *b) MP_WUR; +*/ + +/* right shift with sign extension */ +/* +MP_DEPRECATED(mp_signed_rsh) mp_err mp_tc_div_2d(const mp_int *a, int b, mp_int *c) MP_WUR; +*/ +/* +mp_err mp_signed_rsh(const mp_int *a, int b, mp_int *c) MP_WUR; */ /* ---> Basic arithmetic <--- */ -/* b = ~a */ -/* -int mp_complement(const mp_int *a, mp_int *b); -*/ - /* b = -a */ /* -int mp_neg(const mp_int *a, mp_int *b); +mp_err mp_neg(const mp_int *a, mp_int *b) MP_WUR; */ /* b = |a| */ /* -int mp_abs(const mp_int *a, mp_int *b); +mp_err mp_abs(const mp_int *a, mp_int *b) MP_WUR; */ /* compare a to b */ /* -int mp_cmp(const mp_int *a, const mp_int *b); +mp_ord mp_cmp(const mp_int *a, const mp_int *b) MP_WUR; */ /* compare |a| to |b| */ /* -int mp_cmp_mag(const mp_int *a, const mp_int *b); +mp_ord mp_cmp_mag(const mp_int *a, const mp_int *b) MP_WUR; */ /* c = a + b */ /* -int mp_add(const mp_int *a, const mp_int *b, mp_int *c); +mp_err mp_add(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; */ /* c = a - b */ /* -int mp_sub(const mp_int *a, const mp_int *b, mp_int *c); +mp_err mp_sub(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; */ /* c = a * b */ /* -int mp_mul(const mp_int *a, const mp_int *b, mp_int *c); +mp_err mp_mul(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; */ /* b = a*a */ /* -int mp_sqr(const mp_int *a, mp_int *b); +mp_err mp_sqr(const mp_int *a, mp_int *b) MP_WUR; */ /* a/b => cb + d == a */ /* -int mp_div(const mp_int *a, const mp_int *b, mp_int *c, mp_int *d); +mp_err mp_div(const mp_int *a, const mp_int *b, mp_int *c, mp_int *d) MP_WUR; */ /* c = a mod b, 0 <= c < b */ /* -int mp_mod(const mp_int *a, const mp_int *b, mp_int *c); +mp_err mp_mod(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; +*/ + +/* Increment "a" by one like "a++". Changes input! */ +/* +mp_err mp_incr(mp_int *a) MP_WUR; +*/ + +/* Decrement "a" by one like "a--". Changes input! */ +/* +mp_err mp_decr(mp_int *a) MP_WUR; */ /* ---> single digit functions <--- */ /* compare against a single digit */ /* -int mp_cmp_d(const mp_int *a, mp_digit b); +mp_ord mp_cmp_d(const mp_int *a, mp_digit b) MP_WUR; */ /* c = a + b */ /* -int mp_add_d(const mp_int *a, mp_digit b, mp_int *c); +mp_err mp_add_d(const mp_int *a, mp_digit b, mp_int *c) MP_WUR; */ /* c = a - b */ /* -int mp_sub_d(const mp_int *a, mp_digit b, mp_int *c); +mp_err mp_sub_d(const mp_int *a, mp_digit b, mp_int *c) MP_WUR; */ /* c = a * b */ /* -int mp_mul_d(const mp_int *a, mp_digit b, mp_int *c); +mp_err mp_mul_d(const mp_int *a, mp_digit b, mp_int *c) MP_WUR; */ /* a/b => cb + d == a */ /* -int mp_div_d(const mp_int *a, mp_digit b, mp_int *c, mp_digit *d); -*/ - -/* a/3 => 3c + d == a */ -/* -int mp_div_3(const mp_int *a, mp_int *c, mp_digit *d); -*/ - -/* c = a**b */ -/* -int mp_expt_d(const mp_int *a, mp_digit b, mp_int *c); -*/ -/* -int mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast); +mp_err mp_div_d(const mp_int *a, mp_digit b, mp_int *c, mp_digit *d) MP_WUR; */ /* c = a mod b, 0 <= c < b */ /* -int mp_mod_d(const mp_int *a, mp_digit b, mp_digit *c); +mp_err mp_mod_d(const mp_int *a, mp_digit b, mp_digit *c) MP_WUR; */ /* ---> number theory <--- */ /* d = a + b (mod c) */ /* -int mp_addmod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d); +mp_err mp_addmod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d) MP_WUR; */ /* d = a - b (mod c) */ /* -int mp_submod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d); +mp_err mp_submod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d) MP_WUR; */ /* d = a * b (mod c) */ /* -int mp_mulmod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d); +mp_err mp_mulmod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d) MP_WUR; */ /* c = a * a (mod b) */ /* -int mp_sqrmod(const mp_int *a, const mp_int *b, mp_int *c); +mp_err mp_sqrmod(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; */ /* c = 1/a (mod b) */ /* -int mp_invmod(const mp_int *a, const mp_int *b, mp_int *c); +mp_err mp_invmod(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; */ /* c = (a, b) */ /* -int mp_gcd(const mp_int *a, const mp_int *b, mp_int *c); +mp_err mp_gcd(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; */ /* produces value such that U1*a + U2*b = U3 */ /* -int mp_exteuclid(const mp_int *a, const mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3); +mp_err mp_exteuclid(const mp_int *a, const mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3) MP_WUR; */ /* c = [a, b] or (a*b)/(a, b) */ /* -int mp_lcm(const mp_int *a, const mp_int *b, mp_int *c); +mp_err mp_lcm(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; */ /* finds one of the b'th root of a, such that |c|**b <= |a| * * returns error if a < 0 and b is even */ /* -int mp_n_root(const mp_int *a, mp_digit b, mp_int *c); +mp_err mp_root_u32(const mp_int *a, unsigned int b, mp_int *c) MP_WUR; +*/ +/* +MP_DEPRECATED(mp_root_u32) mp_err mp_n_root(const mp_int *a, mp_digit b, mp_int *c) MP_WUR; */ /* -int mp_n_root_ex(const mp_int *a, mp_digit b, mp_int *c, int fast); +MP_DEPRECATED(mp_root_u32) mp_err mp_n_root_ex(const mp_int *a, mp_digit b, mp_int *c, int fast) MP_WUR; */ /* special sqrt algo */ /* -int mp_sqrt(const mp_int *arg, mp_int *ret); +mp_err mp_sqrt(const mp_int *arg, mp_int *ret) MP_WUR; */ /* special sqrt (mod prime) */ /* -int mp_sqrtmod_prime(const mp_int *n, const mp_int *prime, mp_int *ret); +mp_err mp_sqrtmod_prime(const mp_int *n, const mp_int *prime, mp_int *ret) MP_WUR; */ /* is number a square? */ /* -int mp_is_square(const mp_int *arg, int *ret); +mp_err mp_is_square(const mp_int *arg, mp_bool *ret) MP_WUR; */ /* computes the jacobi c = (a | n) (or Legendre if b is prime) */ /* -int mp_jacobi(const mp_int *a, const mp_int *n, int *c); +MP_DEPRECATED(mp_kronecker) mp_err mp_jacobi(const mp_int *a, const mp_int *n, int *c) MP_WUR; +*/ + +/* computes the Kronecker symbol c = (a | p) (like jacobi() but with {a,p} in Z */ +/* +mp_err mp_kronecker(const mp_int *a, const mp_int *p, int *c) MP_WUR; */ /* used to setup the Barrett reduction for a given modulus b */ /* -int mp_reduce_setup(mp_int *a, const mp_int *b); +mp_err mp_reduce_setup(mp_int *a, const mp_int *b) MP_WUR; */ /* Barrett Reduction, computes a (mod b) with a precomputed value c * * Assumes that 0 < x <= m*m, note if 0 > x > -(m*m) then you can merely * compute the reduction as -1 * mp_reduce(mp_abs(x)) [pseudo code]. */ /* -int mp_reduce(mp_int *x, const mp_int *m, const mp_int *mu); +mp_err mp_reduce(mp_int *x, const mp_int *m, const mp_int *mu) MP_WUR; */ /* setups the montgomery reduction */ /* -int mp_montgomery_setup(const mp_int *n, mp_digit *rho); +mp_err mp_montgomery_setup(const mp_int *n, mp_digit *rho) MP_WUR; */ /* computes a = B**n mod b without division or multiplication useful for * normalizing numbers in a Montgomery system. */ /* -int mp_montgomery_calc_normalization(mp_int *a, const mp_int *b); +mp_err mp_montgomery_calc_normalization(mp_int *a, const mp_int *b) MP_WUR; */ /* computes x/R == x (mod N) via Montgomery Reduction */ /* -int mp_montgomery_reduce(mp_int *x, const mp_int *n, mp_digit rho); +mp_err mp_montgomery_reduce(mp_int *x, const mp_int *n, mp_digit rho) MP_WUR; */ /* returns 1 if a is a valid DR modulus */ /* -int mp_dr_is_modulus(const mp_int *a); +mp_bool mp_dr_is_modulus(const mp_int *a) MP_WUR; */ /* sets the value of "d" required for mp_dr_reduce */ /* void mp_dr_setup(const mp_int *a, mp_digit *d); */ /* reduces a modulo n using the Diminished Radix method */ /* -int mp_dr_reduce(mp_int *x, const mp_int *n, mp_digit k); +mp_err mp_dr_reduce(mp_int *x, const mp_int *n, mp_digit k) MP_WUR; */ /* returns true if a can be reduced with mp_reduce_2k */ /* -int mp_reduce_is_2k(const mp_int *a); +mp_bool mp_reduce_is_2k(const mp_int *a) MP_WUR; */ /* determines k value for 2k reduction */ /* -int mp_reduce_2k_setup(const mp_int *a, mp_digit *d); +mp_err mp_reduce_2k_setup(const mp_int *a, mp_digit *d) MP_WUR; */ /* reduces a modulo b where b is of the form 2**p - k [0 <= a] */ /* -int mp_reduce_2k(mp_int *a, const mp_int *n, mp_digit d); +mp_err mp_reduce_2k(mp_int *a, const mp_int *n, mp_digit d) MP_WUR; */ /* returns true if a can be reduced with mp_reduce_2k_l */ /* -int mp_reduce_is_2k_l(const mp_int *a); +mp_bool mp_reduce_is_2k_l(const mp_int *a) MP_WUR; */ /* determines k value for 2k reduction */ /* -int mp_reduce_2k_setup_l(const mp_int *a, mp_int *d); +mp_err mp_reduce_2k_setup_l(const mp_int *a, mp_int *d) MP_WUR; */ /* reduces a modulo b where b is of the form 2**p - k [0 <= a] */ /* -int mp_reduce_2k_l(mp_int *a, const mp_int *n, const mp_int *d); +mp_err mp_reduce_2k_l(mp_int *a, const mp_int *n, const mp_int *d) MP_WUR; */ /* Y = G**X (mod P) */ /* -int mp_exptmod(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y); +mp_err mp_exptmod(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y) MP_WUR; */ /* ---> Primes <--- */ /* number of primes */ #ifdef MP_8BIT -# define PRIME_SIZE 31 +# define PRIVATE_MP_PRIME_TAB_SIZE 31 #else -# define PRIME_SIZE 256 +# define PRIVATE_MP_PRIME_TAB_SIZE 256 #endif +#define PRIME_SIZE (MP_DEPRECATED_PRAGMA("PRIME_SIZE has been made internal") PRIVATE_MP_PRIME_TAB_SIZE) /* table of first PRIME_SIZE primes */ #if defined(BUILD_tcl) || !defined(_WIN32) -MODULE_SCOPE const mp_digit ltm_prime_tab[PRIME_SIZE]; +MODULE_SCOPE const mp_digit ltm_prime_tab[PRIVATE_MP_PRIME_TAB_SIZE]; #endif /* result=1 if a is divisible by one of the first PRIME_SIZE primes */ /* -int mp_prime_is_divisible(const mp_int *a, int *result); +MP_DEPRECATED(mp_prime_is_prime) mp_err mp_prime_is_divisible(const mp_int *a, mp_bool *result) MP_WUR; */ /* performs one Fermat test of "a" using base "b". * Sets result to 0 if composite or 1 if probable prime */ /* -int mp_prime_fermat(const mp_int *a, const mp_int *b, int *result); +mp_err mp_prime_fermat(const mp_int *a, const mp_int *b, mp_bool *result) MP_WUR; */ /* performs one Miller-Rabin test of "a" using base "b". * Sets result to 0 if composite or 1 if probable prime */ /* -int mp_prime_miller_rabin(const mp_int *a, const mp_int *b, int *result); +mp_err mp_prime_miller_rabin(const mp_int *a, const mp_int *b, mp_bool *result) MP_WUR; */ /* This gives [for a given bit size] the number of trials required * such that Miller-Rabin gives a prob of failure lower than 2^-96 */ /* -int mp_prime_rabin_miller_trials(int size); +int mp_prime_rabin_miller_trials(int size) MP_WUR; +*/ + +/* performs one strong Lucas-Selfridge test of "a". + * Sets result to 0 if composite or 1 if probable prime + */ +/* +mp_err mp_prime_strong_lucas_selfridge(const mp_int *a, mp_bool *result) MP_WUR; +*/ + +/* performs one Frobenius test of "a" as described by Paul Underwood. + * Sets result to 0 if composite or 1 if probable prime + */ +/* +mp_err mp_prime_frobenius_underwood(const mp_int *N, mp_bool *result) MP_WUR; */ /* performs t random rounds of Miller-Rabin on "a" additional to * bases 2 and 3. Also performs an initial sieve of trial * division. Determines if "a" is prime with probability @@ -730,20 +957,20 @@ * mp_prime_rabin_miller_trials(); * * Sets result to 1 if probably prime, 0 otherwise */ /* -int mp_prime_is_prime(const mp_int *a, int t, int *result); +mp_err mp_prime_is_prime(const mp_int *a, int t, mp_bool *result) MP_WUR; */ /* finds the next prime after the number "a" using "t" trials * of Miller-Rabin. * * bbs_style = 1 means the prime must be congruent to 3 mod 4 */ /* -int mp_prime_next_prime(mp_int *a, int t, int bbs_style); +mp_err mp_prime_next_prime(mp_int *a, int t, int bbs_style) MP_WUR; */ /* makes a truly random prime of a given size (bytes), * call with bbs = 1 if you want it to be congruent to 3 mod 4 * @@ -751,100 +978,145 @@ * have passed to the callback (e.g. a state or something). This function doesn't use "dat" itself * so it can be NULL * * The prime generated will be larger than 2^(8*size). */ -#define mp_prime_random(a, t, size, bbs, cb, dat) mp_prime_random_ex(a, t, ((size) * 8) + 1, (bbs==1)?LTM_PRIME_BBS:0, cb, dat) +#define mp_prime_random(a, t, size, bbs, cb, dat) (MP_DEPRECATED_PRAGMA("mp_prime_random has been deprecated, use mp_prime_rand instead") mp_prime_random_ex(a, t, ((size) * 8) + 1, (bbs==1)?MP_PRIME_BBS:0, cb, dat)) /* makes a truly random prime of a given size (bits), * * Flags are as follows: * - * LTM_PRIME_BBS - make prime congruent to 3 mod 4 - * LTM_PRIME_SAFE - make sure (p-1)/2 is prime as well (implies LTM_PRIME_BBS) - * LTM_PRIME_2MSB_ON - make the 2nd highest bit one + * MP_PRIME_BBS - make prime congruent to 3 mod 4 + * MP_PRIME_SAFE - make sure (p-1)/2 is prime as well (implies MP_PRIME_BBS) + * MP_PRIME_2MSB_ON - make the 2nd highest bit one * * You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can * have passed to the callback (e.g. a state or something). This function doesn't use "dat" itself * so it can be NULL * */ /* -int mp_prime_random_ex(mp_int *a, int t, int size, int flags, ltm_prime_callback cb, void *dat); +MP_DEPRECATED(mp_prime_rand) mp_err mp_prime_random_ex(mp_int *a, int t, int size, int flags, + private_mp_prime_callback cb, void *dat) MP_WUR; +*/ +/* +mp_err mp_prime_rand(mp_int *a, int t, int size, int flags) MP_WUR; +*/ + +/* Integer logarithm to integer base */ +/* +mp_err mp_log_u32(const mp_int *a, unsigned int base, unsigned int *c) MP_WUR; +*/ + +/* c = a**b */ +/* +mp_err mp_expt_u32(const mp_int *a, unsigned int b, mp_int *c) MP_WUR; +*/ +/* +MP_DEPRECATED(mp_expt_u32) mp_err mp_expt_d(const mp_int *a, mp_digit b, mp_int *c) MP_WUR; +*/ +/* +MP_DEPRECATED(mp_expt_u32) mp_err mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast) MP_WUR; */ /* ---> radix conversion <--- */ /* -int mp_count_bits(const mp_int *a); -*/ - -/* -int mp_unsigned_bin_size(const mp_int *a); -*/ -/* -int mp_read_unsigned_bin(mp_int *a, const unsigned char *b, int c); -*/ -/* -int mp_to_unsigned_bin(const mp_int *a, unsigned char *b); -*/ -/* -int mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen); -*/ - -/* -int mp_signed_bin_size(const mp_int *a); -*/ -/* -int mp_read_signed_bin(mp_int *a, const unsigned char *b, int c); -*/ -/* -int mp_to_signed_bin(const mp_int *a, unsigned char *b); -*/ -/* -int mp_to_signed_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen); -*/ - -/* -int mp_read_radix(mp_int *a, const char *str, int radix); -*/ -/* -int mp_toradix(const mp_int *a, char *str, int radix); -*/ -/* -int mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen); -*/ -/* -int mp_radix_size(const mp_int *a, int radix, int *size); -*/ - -#ifndef LTM_NO_FILE -/* -int mp_fread(mp_int *a, int radix, FILE *stream); -*/ -/* -int mp_fwrite(const mp_int *a, int radix, FILE *stream); +int mp_count_bits(const mp_int *a) MP_WUR; +*/ + + +/* +MP_DEPRECATED(mp_ubin_size) int mp_unsigned_bin_size(const mp_int *a) MP_WUR; +*/ +/* +MP_DEPRECATED(mp_from_ubin) mp_err mp_read_unsigned_bin(mp_int *a, const unsigned char *b, int c) MP_WUR; +*/ +/* +MP_DEPRECATED(mp_to_ubin) mp_err mp_to_unsigned_bin(const mp_int *a, unsigned char *b) MP_WUR; +*/ +/* +MP_DEPRECATED(mp_to_ubin) mp_err mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen) MP_WUR; +*/ + +/* +MP_DEPRECATED(mp_sbin_size) int mp_signed_bin_size(const mp_int *a) MP_WUR; +*/ +/* +MP_DEPRECATED(mp_from_sbin) mp_err mp_read_signed_bin(mp_int *a, const unsigned char *b, int c) MP_WUR; +*/ +/* +MP_DEPRECATED(mp_to_sbin) mp_err mp_to_signed_bin(const mp_int *a, unsigned char *b) MP_WUR; +*/ +/* +MP_DEPRECATED(mp_to_sbin) mp_err mp_to_signed_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen) MP_WUR; +*/ + +/* +size_t mp_ubin_size(const mp_int *a) MP_WUR; +*/ +/* +mp_err mp_from_ubin(mp_int *a, const unsigned char *buf, size_t size) MP_WUR; +*/ +/* +mp_err mp_to_ubin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written) MP_WUR; +*/ + +/* +size_t mp_sbin_size(const mp_int *a) MP_WUR; +*/ +/* +mp_err mp_from_sbin(mp_int *a, const unsigned char *buf, size_t size) MP_WUR; +*/ +/* +mp_err mp_to_sbin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written) MP_WUR; +*/ + +/* +mp_err mp_read_radix(mp_int *a, const char *str, int radix) MP_WUR; +*/ +/* +MP_DEPRECATED(mp_to_radix) mp_err mp_toradix(const mp_int *a, char *str, int radix) MP_WUR; +*/ +/* +MP_DEPRECATED(mp_to_radix) mp_err mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen) MP_WUR; +*/ +/* +mp_err mp_to_radix(const mp_int *a, char *str, size_t maxlen, size_t *written, int radix) MP_WUR; +*/ +/* +mp_err mp_radix_size(const mp_int *a, int radix, int *size) MP_WUR; +*/ + +#ifndef MP_NO_FILE +/* +mp_err mp_fread(mp_int *a, int radix, FILE *stream) MP_WUR; +*/ +/* +mp_err mp_fwrite(const mp_int *a, int radix, FILE *stream) MP_WUR; */ #endif -#define mp_read_raw(mp, str, len) mp_read_signed_bin((mp), (str), (len)) -#define mp_raw_size(mp) mp_signed_bin_size(mp) -#define mp_toraw(mp, str) mp_to_signed_bin((mp), (str)) -#define mp_read_mag(mp, str, len) mp_read_unsigned_bin((mp), (str), (len)) -#define mp_mag_size(mp) mp_unsigned_bin_size(mp) -#define mp_tomag(mp, str) mp_to_unsigned_bin((mp), (str)) - -#define mp_tobinary(M, S) mp_toradix((M), (S), 2) -#define mp_tooctal(M, S) mp_toradix((M), (S), 8) -#define mp_todecimal(M, S) mp_toradix((M), (S), 10) -#define mp_tohex(M, S) mp_toradix((M), (S), 16) +#define mp_read_raw(mp, str, len) (MP_DEPRECATED_PRAGMA("replaced by mp_read_signed_bin") mp_read_signed_bin((mp), (str), (len))) +#define mp_raw_size(mp) (MP_DEPRECATED_PRAGMA("replaced by mp_signed_bin_size") mp_signed_bin_size(mp)) +#define mp_toraw(mp, str) (MP_DEPRECATED_PRAGMA("replaced by mp_to_signed_bin") mp_to_signed_bin((mp), (str))) +#define mp_read_mag(mp, str, len) (MP_DEPRECATED_PRAGMA("replaced by mp_read_unsigned_bin") mp_read_unsigned_bin((mp), (str), (len)) +#define mp_mag_size(mp) (MP_DEPRECATED_PRAGMA("replaced by mp_unsigned_bin_size") mp_unsigned_bin_size(mp)) +#define mp_tomag(mp, str) (MP_DEPRECATED_PRAGMA("replaced by mp_to_unsigned_bin") mp_to_unsigned_bin((mp), (str))) + +#define mp_tobinary(M, S) (MP_DEPRECATED_PRAGMA("replaced by mp_to_binary") mp_toradix((M), (S), 2)) +#define mp_tooctal(M, S) (MP_DEPRECATED_PRAGMA("replaced by mp_to_octal") mp_toradix((M), (S), 8)) +#define mp_todecimal(M, S) (MP_DEPRECATED_PRAGMA("replaced by mp_to_decimal") mp_toradix((M), (S), 10)) +#define mp_tohex(M, S) (MP_DEPRECATED_PRAGMA("replaced by mp_to_hex") mp_toradix((M), (S), 16)) + +#define mp_to_binary(M, S, N) mp_to_radix((M), (S), (N), NULL, 2) +#define mp_to_octal(M, S, N) mp_to_radix((M), (S), (N), NULL, 8) +#define mp_to_decimal(M, S, N) mp_to_radix((M), (S), (N), NULL, 10) +#define mp_to_hex(M, S, N) mp_to_radix((M), (S), (N), NULL, 16) #ifdef __cplusplus } #endif -#endif +#include "tclTomMathDecls.h" - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ - +#endif Index: generic/tclTomMathDecls.h ================================================================== --- generic/tclTomMathDecls.h +++ generic/tclTomMathDecls.h @@ -14,10 +14,13 @@ #ifndef _TCLTOMMATHDECLS #define _TCLTOMMATHDECLS #include "tcl.h" +#ifndef BN_H_ +#include "tclTomMath.h" +#endif /* * Define the version of the Stubs table that's exported for tommath */ @@ -28,31 +31,28 @@ (TclTomMathInitializeStubs((interp),(version),\ TCLTOMMATH_EPOCH,TCLTOMMATH_REVISION)) /* Define custom memory allocation for libtommath */ - /* MODULE_SCOPE void* TclBNAlloc( size_t ); */ -#define TclBNAlloc(s) ((void*)Tcl_Alloc((size_t)(s))) +#define TclBNAlloc(s) ((void*)ckalloc((size_t)(s))) +/* MODULE_SCOPE void* TclBNCalloc( size_t, size_t ); */ +#define TclBNCalloc(m,s) memset(ckalloc((size_t)(m)*(size_t)(s)),0,(size_t)(m)*(size_t)(s)) /* MODULE_SCOPE void* TclBNRealloc( void*, size_t ); */ -#define TclBNRealloc(x,s) ((void*)Tcl_Realloc((char*)(x),(size_t)(s))) +#define TclBNRealloc(x,s) ((void*)ckrealloc((char*)(x),(size_t)(s))) /* MODULE_SCOPE void TclBNFree( void* ); */ -#define TclBNFree(x) (Tcl_Free((char*)(x))) +#define TclBNFree(x) (ckfree((char*)(x))) -#define XMALLOC(size) TclBNAlloc(size) -#define XFREE(mem, size) TclBNFree(mem) -#define XREALLOC(mem, oldsize, newsize) TclBNRealloc(mem, newsize) +#define MP_MALLOC(size) TclBNAlloc(size) +#define MP_CALLOC(nmemb, size) TclBNCalloc(nmemb, size) +#define MP_REALLOC(mem, oldsize, newsize) TclBNRealloc(mem, newsize) +#define MP_FREE(mem, size) TclBNFree(mem) /* Rename the global symbols in libtommath to avoid linkage conflicts */ #define bn_reverse TclBN_reverse -#define s_mp_reverse TclBN_reverse -#define fast_s_mp_mul_digs TclBN_fast_s_mp_mul_digs -#define s_mp_mul_digs_fast TclBN_fast_s_mp_mul_digs -#define fast_s_mp_sqr TclBN_fast_s_mp_sqr -#define s_mp_sqr_fast TclBN_fast_s_mp_sqr #define mp_add TclBN_mp_add #define mp_add_d TclBN_mp_add_d #define mp_and TclBN_mp_and #define mp_clamp TclBN_mp_clamp #define mp_clear TclBN_mp_clear @@ -69,26 +69,19 @@ #define mp_div_3 TclBN_mp_div_3 #define mp_div_d TclBN_mp_div_d #define mp_exch TclBN_mp_exch #define mp_expt_d TclBN_mp_expt_d #define mp_expt_d_ex TclBN_mp_expt_d_ex -#define mp_get_int TclBN_mp_get_int -#define mp_get_long TclBN_mp_get_long -#define mp_get_long_long TclBN_mp_get_long_long -#define mp_grow TclBN_mp_grow -#define s_mp_get_bit TclBN_mp_get_bit +#define mp_expt_u32 TclBN_mp_expt_d +#define mp_get_mag_ull TclBN_mp_get_mag_ull #define mp_grow TclBN_mp_grow #define mp_init TclBN_mp_init #define mp_init_copy TclBN_mp_init_copy #define mp_init_multi TclBN_mp_init_multi #define mp_init_set TclBN_mp_init_set #define mp_init_set_int TclBN_mp_init_set_int #define mp_init_size TclBN_mp_init_size -#define mp_karatsuba_mul TclBN_mp_karatsuba_mul -#define s_mp_karatsuba_mul TclBN_mp_karatsuba_mul -#define mp_karatsuba_sqr TclBN_mp_karatsuba_sqr -#define s_mp_karatsuba_sqr TclBN_mp_karatsuba_sqr #define mp_lshd TclBN_mp_lshd #define mp_mod TclBN_mp_mod #define mp_mod_2d TclBN_mp_mod_2d #define mp_mul TclBN_mp_mul #define mp_mul_2 TclBN_mp_mul_2 @@ -98,51 +91,47 @@ #define mp_or TclBN_mp_or #define mp_radix_size TclBN_mp_radix_size #define mp_read_radix TclBN_mp_read_radix #define mp_rshd TclBN_mp_rshd #define mp_set TclBN_mp_set -#define mp_set_int TclBN_mp_set_int -#define mp_set_long TclBN_mp_set_long -#define mp_set_long_long TclBN_mp_set_long_long +#define mp_set_int(a,b) (TclBN_mp_set_int(a,(unsigned int)(b)),MP_OKAY) +#define mp_set_ll TclBN_mp_set_ll +#define mp_set_long(a,b) (TclBN_mp_set_int(a,b),MP_OKAY) +#define mp_set_ul(a,b) (void)TclBN_mp_set_int(a,b) +#define mp_set_ull TclBN_mp_set_ull +#define mp_set_u64 TclBN_mp_set_ull #define mp_shrink TclBN_mp_shrink #define mp_sqr TclBN_mp_sqr #define mp_sqrt TclBN_mp_sqrt #define mp_sub TclBN_mp_sub #define mp_sub_d TclBN_mp_sub_d #define mp_signed_rsh TclBN_mp_signed_rsh +#define mp_tc_and TclBN_mp_and +#define mp_tc_div_2d TclBN_mp_signed_rsh +#define mp_tc_or TclBN_mp_or +#define mp_tc_xor TclBN_mp_xor #define mp_to_unsigned_bin TclBN_mp_to_unsigned_bin #define mp_to_unsigned_bin_n TclBN_mp_to_unsigned_bin_n -#define mp_toom_mul TclBN_mp_toom_mul -#define s_mp_toom_mul TclBN_mp_toom_mul -#define mp_toom_sqr TclBN_mp_toom_sqr -#define s_mp_toom_sqr TclBN_mp_toom_sqr #define mp_toradix_n TclBN_mp_toradix_n -#define mp_unsigned_bin_size TclBN_mp_unsigned_bin_size +#define mp_to_radix TclBN_mp_to_radix +#define mp_to_ubin TclBN_mp_to_ubin +#define mp_ubin_size TclBN_mp_unsigned_bin_size +#define mp_unsigned_bin_size(a) ((int)TclBN_mp_unsigned_bin_size(a)) #define mp_xor TclBN_mp_xor #define mp_zero TclBN_mp_zero #define s_mp_add TclBN_s_mp_add +#define s_mp_balance_mul TclBN_mp_balance_mul +#define s_mp_karatsuba_mul TclBN_mp_karatsuba_mul +#define s_mp_karatsuba_sqr TclBN_mp_karatsuba_sqr #define s_mp_mul_digs TclBN_s_mp_mul_digs +#define s_mp_mul_digs_fast TclBN_fast_s_mp_mul_digs +#define s_mp_reverse TclBN_s_mp_reverse #define s_mp_sqr TclBN_s_mp_sqr +#define s_mp_sqr_fast TclBN_fast_s_mp_sqr #define s_mp_sub TclBN_s_mp_sub - -MODULE_SCOPE void TclBN_reverse(unsigned char *s, int len); -MODULE_SCOPE int TclBN_fast_s_mp_mul_digs(const mp_int *a, - const mp_int *b, mp_int *c, int digs); -MODULE_SCOPE int TclBN_fast_s_mp_sqr(const mp_int *a, mp_int *b); -MODULE_SCOPE int TclBN_mp_karatsuba_mul(const mp_int *a, - const mp_int *b, mp_int *c); -MODULE_SCOPE int TclBN_mp_karatsuba_sqr(const mp_int *a, mp_int *b); -MODULE_SCOPE int TclBN_mp_toom_mul(const mp_int *a, const mp_int *b, - mp_int *c); -MODULE_SCOPE int TclBN_mp_toom_sqr(const mp_int *a, mp_int *b); -MODULE_SCOPE int TclBN_s_mp_add(const mp_int *a, const mp_int *b, - mp_int *c); -MODULE_SCOPE int TclBN_s_mp_mul_digs(const mp_int *a, const mp_int *b, - mp_int *c, int digs); -MODULE_SCOPE int TclBN_s_mp_sqr(const mp_int *a, mp_int *b); -MODULE_SCOPE int TclBN_s_mp_sub(const mp_int *a, const mp_int *b, - mp_int *c); +#define s_mp_toom_mul TclBN_mp_toom_mul +#define s_mp_toom_sqr TclBN_mp_toom_sqr #undef TCL_STORAGE_CLASS #ifdef BUILD_tcl # define TCL_STORAGE_CLASS DLLEXPORT #else @@ -172,249 +161,286 @@ /* 0 */ EXTERN int TclBN_epoch(void); /* 1 */ EXTERN int TclBN_revision(void); /* 2 */ -EXTERN int TclBN_mp_add(const mp_int *a, const mp_int *b, +EXTERN mp_err TclBN_mp_add(const mp_int *a, const mp_int *b, mp_int *c); /* 3 */ -EXTERN int TclBN_mp_add_d(const mp_int *a, mp_digit b, +EXTERN mp_err TclBN_mp_add_d(const mp_int *a, mp_digit b, mp_int *c); /* 4 */ -EXTERN int TclBN_mp_and(const mp_int *a, const mp_int *b, +EXTERN mp_err TclBN_mp_and(const mp_int *a, const mp_int *b, mp_int *c); /* 5 */ EXTERN void TclBN_mp_clamp(mp_int *a); /* 6 */ EXTERN void TclBN_mp_clear(mp_int *a); /* 7 */ EXTERN void TclBN_mp_clear_multi(mp_int *a, ...); /* 8 */ -EXTERN int TclBN_mp_cmp(const mp_int *a, const mp_int *b); +EXTERN mp_ord TclBN_mp_cmp(const mp_int *a, const mp_int *b); /* 9 */ -EXTERN int TclBN_mp_cmp_d(const mp_int *a, mp_digit b); +EXTERN mp_ord TclBN_mp_cmp_d(const mp_int *a, mp_digit b); /* 10 */ -EXTERN int TclBN_mp_cmp_mag(const mp_int *a, const mp_int *b); +EXTERN mp_ord TclBN_mp_cmp_mag(const mp_int *a, const mp_int *b); /* 11 */ -EXTERN int TclBN_mp_copy(const mp_int *a, mp_int *b); +EXTERN mp_err TclBN_mp_copy(const mp_int *a, mp_int *b); /* 12 */ EXTERN int TclBN_mp_count_bits(const mp_int *a); /* 13 */ -EXTERN int TclBN_mp_div(const mp_int *a, const mp_int *b, +EXTERN mp_err TclBN_mp_div(const mp_int *a, const mp_int *b, mp_int *q, mp_int *r); /* 14 */ -EXTERN int TclBN_mp_div_d(const mp_int *a, mp_digit b, +EXTERN mp_err TclBN_mp_div_d(const mp_int *a, mp_digit b, mp_int *q, mp_digit *r); /* 15 */ -EXTERN int TclBN_mp_div_2(const mp_int *a, mp_int *q); +EXTERN mp_err TclBN_mp_div_2(const mp_int *a, mp_int *q); /* 16 */ -EXTERN int TclBN_mp_div_2d(const mp_int *a, int b, mp_int *q, +EXTERN mp_err TclBN_mp_div_2d(const mp_int *a, int b, mp_int *q, mp_int *r); /* 17 */ -EXTERN int TclBN_mp_div_3(const mp_int *a, mp_int *q, +EXTERN mp_err TclBN_mp_div_3(const mp_int *a, mp_int *q, mp_digit *r); /* 18 */ EXTERN void TclBN_mp_exch(mp_int *a, mp_int *b); /* 19 */ -EXTERN int TclBN_mp_expt_d(const mp_int *a, mp_digit b, +EXTERN mp_err TclBN_mp_expt_d(const mp_int *a, unsigned int b, mp_int *c); /* 20 */ -EXTERN int TclBN_mp_grow(mp_int *a, int size); +EXTERN mp_err TclBN_mp_grow(mp_int *a, int size); /* 21 */ -EXTERN int TclBN_mp_init(mp_int *a); +EXTERN mp_err TclBN_mp_init(mp_int *a); /* 22 */ -EXTERN int TclBN_mp_init_copy(mp_int *a, const mp_int *b); +EXTERN mp_err TclBN_mp_init_copy(mp_int *a, const mp_int *b); /* 23 */ -EXTERN int TclBN_mp_init_multi(mp_int *a, ...); +EXTERN mp_err TclBN_mp_init_multi(mp_int *a, ...); /* 24 */ -EXTERN int TclBN_mp_init_set(mp_int *a, mp_digit b); +EXTERN mp_err TclBN_mp_init_set(mp_int *a, mp_digit b); /* 25 */ -EXTERN int TclBN_mp_init_size(mp_int *a, int size); +EXTERN mp_err TclBN_mp_init_size(mp_int *a, int size); /* 26 */ -EXTERN int TclBN_mp_lshd(mp_int *a, int shift); +EXTERN mp_err TclBN_mp_lshd(mp_int *a, int shift); /* 27 */ -EXTERN int TclBN_mp_mod(const mp_int *a, const mp_int *b, +EXTERN mp_err TclBN_mp_mod(const mp_int *a, const mp_int *b, mp_int *r); /* 28 */ -EXTERN int TclBN_mp_mod_2d(const mp_int *a, int b, mp_int *r); +EXTERN mp_err TclBN_mp_mod_2d(const mp_int *a, int b, mp_int *r); /* 29 */ -EXTERN int TclBN_mp_mul(const mp_int *a, const mp_int *b, +EXTERN mp_err TclBN_mp_mul(const mp_int *a, const mp_int *b, mp_int *p); /* 30 */ -EXTERN int TclBN_mp_mul_d(const mp_int *a, mp_digit b, +EXTERN mp_err TclBN_mp_mul_d(const mp_int *a, mp_digit b, mp_int *p); /* 31 */ -EXTERN int TclBN_mp_mul_2(const mp_int *a, mp_int *p); +EXTERN mp_err TclBN_mp_mul_2(const mp_int *a, mp_int *p); /* 32 */ -EXTERN int TclBN_mp_mul_2d(const mp_int *a, int d, mp_int *p); +EXTERN mp_err TclBN_mp_mul_2d(const mp_int *a, int d, mp_int *p); /* 33 */ -EXTERN int TclBN_mp_neg(const mp_int *a, mp_int *b); +EXTERN mp_err TclBN_mp_neg(const mp_int *a, mp_int *b); /* 34 */ -EXTERN int TclBN_mp_or(const mp_int *a, const mp_int *b, +EXTERN mp_err TclBN_mp_or(const mp_int *a, const mp_int *b, mp_int *c); /* 35 */ -EXTERN int TclBN_mp_radix_size(const mp_int *a, int radix, +EXTERN mp_err TclBN_mp_radix_size(const mp_int *a, int radix, int *size); /* 36 */ -EXTERN int TclBN_mp_read_radix(mp_int *a, const char *str, +EXTERN mp_err TclBN_mp_read_radix(mp_int *a, const char *str, int radix); /* 37 */ EXTERN void TclBN_mp_rshd(mp_int *a, int shift); /* 38 */ -EXTERN int TclBN_mp_shrink(mp_int *a); +EXTERN mp_err TclBN_mp_shrink(mp_int *a); /* 39 */ EXTERN void TclBN_mp_set(mp_int *a, mp_digit b); /* 40 */ -EXTERN int TclBN_mp_sqr(const mp_int *a, mp_int *b); +EXTERN mp_err TclBN_mp_sqr(const mp_int *a, mp_int *b); /* 41 */ -EXTERN int TclBN_mp_sqrt(const mp_int *a, mp_int *b); +EXTERN mp_err TclBN_mp_sqrt(const mp_int *a, mp_int *b); /* 42 */ -EXTERN int TclBN_mp_sub(const mp_int *a, const mp_int *b, +EXTERN mp_err TclBN_mp_sub(const mp_int *a, const mp_int *b, mp_int *c); /* 43 */ -EXTERN int TclBN_mp_sub_d(const mp_int *a, mp_digit b, +EXTERN mp_err TclBN_mp_sub_d(const mp_int *a, mp_digit b, mp_int *c); /* 44 */ -EXTERN int TclBN_mp_to_unsigned_bin(const mp_int *a, +EXTERN mp_err TclBN_mp_to_unsigned_bin(const mp_int *a, unsigned char *b); /* 45 */ -EXTERN int TclBN_mp_to_unsigned_bin_n(const mp_int *a, +EXTERN mp_err TclBN_mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen); /* 46 */ -EXTERN int TclBN_mp_toradix_n(const mp_int *a, char *str, +EXTERN mp_err TclBN_mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen); /* 47 */ -EXTERN int TclBN_mp_unsigned_bin_size(const mp_int *a); +EXTERN size_t TclBN_mp_unsigned_bin_size(const mp_int *a); /* 48 */ -EXTERN int TclBN_mp_xor(const mp_int *a, const mp_int *b, +EXTERN mp_err TclBN_mp_xor(const mp_int *a, const mp_int *b, mp_int *c); /* 49 */ EXTERN void TclBN_mp_zero(mp_int *a); -/* Slot 50 is reserved */ -/* Slot 51 is reserved */ -/* Slot 52 is reserved */ -/* Slot 53 is reserved */ -/* Slot 54 is reserved */ -/* Slot 55 is reserved */ -/* Slot 56 is reserved */ -/* Slot 57 is reserved */ -/* Slot 58 is reserved */ -/* Slot 59 is reserved */ -/* Slot 60 is reserved */ +/* 50 */ +EXTERN void TclBN_reverse(unsigned char *s, int len); +/* 51 */ +EXTERN mp_err TclBN_fast_s_mp_mul_digs(const mp_int *a, + const mp_int *b, mp_int *c, int digs); +/* 52 */ +EXTERN mp_err TclBN_fast_s_mp_sqr(const mp_int *a, mp_int *b); +/* 53 */ +EXTERN mp_err TclBN_mp_karatsuba_mul(const mp_int *a, + const mp_int *b, mp_int *c); +/* 54 */ +EXTERN mp_err TclBN_mp_karatsuba_sqr(const mp_int *a, mp_int *b); +/* 55 */ +EXTERN mp_err TclBN_mp_toom_mul(const mp_int *a, const mp_int *b, + mp_int *c); +/* 56 */ +EXTERN mp_err TclBN_mp_toom_sqr(const mp_int *a, mp_int *b); +/* 57 */ +EXTERN mp_err TclBN_s_mp_add(const mp_int *a, const mp_int *b, + mp_int *c); +/* 58 */ +EXTERN mp_err TclBN_s_mp_mul_digs(const mp_int *a, const mp_int *b, + mp_int *c, int digs); +/* 59 */ +EXTERN mp_err TclBN_s_mp_sqr(const mp_int *a, mp_int *b); +/* 60 */ +EXTERN mp_err TclBN_s_mp_sub(const mp_int *a, const mp_int *b, + mp_int *c); /* 61 */ -EXTERN int TclBN_mp_init_set_int(mp_int *a, unsigned long i); +EXTERN mp_err TclBN_mp_init_set_int(mp_int *a, unsigned long i); /* 62 */ -EXTERN int TclBN_mp_set_int(mp_int *a, unsigned long i); +EXTERN mp_err TclBN_mp_set_int(mp_int *a, unsigned long i); /* 63 */ EXTERN int TclBN_mp_cnt_lsb(const mp_int *a); -/* Slot 64 is reserved */ -/* Slot 65 is reserved */ -/* Slot 66 is reserved */ +/* 64 */ +EXTERN int TclBNInitBignumFromLong(mp_int *bignum, long initVal); +/* 65 */ +EXTERN int TclBNInitBignumFromWideInt(mp_int *bignum, + Tcl_WideInt initVal); +/* 66 */ +EXTERN int TclBNInitBignumFromWideUInt(mp_int *bignum, + Tcl_WideUInt initVal); /* 67 */ -EXTERN int TclBN_mp_expt_d_ex(const mp_int *a, mp_digit b, +EXTERN mp_err TclBN_mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast); /* 68 */ -EXTERN int TclBN_mp_set_long_long(mp_int *a, Tcl_WideUInt i); +EXTERN void TclBN_mp_set_ull(mp_int *a, Tcl_WideUInt i); /* 69 */ -EXTERN Tcl_WideUInt TclBN_mp_get_long_long(const mp_int *a); +EXTERN Tcl_WideUInt TclBN_mp_get_mag_ull(const mp_int *a); /* 70 */ -EXTERN int TclBN_mp_set_long(mp_int *a, unsigned long i); -/* 71 */ -EXTERN unsigned long TclBN_mp_get_long(const mp_int *a); -/* 72 */ -EXTERN unsigned long TclBN_mp_get_int(const mp_int *a); -/* Slot 73 is reserved */ -/* Slot 74 is reserved */ -/* Slot 75 is reserved */ +EXTERN void TclBN_mp_set_ll(mp_int *a, Tcl_WideInt i); +/* Slot 71 is reserved */ +/* Slot 72 is reserved */ +/* 73 */ +EXTERN mp_err TclBN_mp_tc_and(const mp_int *a, const mp_int *b, + mp_int *c); +/* 74 */ +EXTERN mp_err TclBN_mp_tc_or(const mp_int *a, const mp_int *b, + mp_int *c); +/* 75 */ +EXTERN mp_err TclBN_mp_tc_xor(const mp_int *a, const mp_int *b, + mp_int *c); /* 76 */ -EXTERN int TclBN_mp_signed_rsh(const mp_int *a, int b, +EXTERN mp_err TclBN_mp_signed_rsh(const mp_int *a, int b, mp_int *c); -/* 77 */ -EXTERN int TclBN_mp_get_bit(const mp_int *a, int b); +/* Slot 77 is reserved */ +/* 78 */ +EXTERN int TclBN_mp_to_ubin(const mp_int *a, unsigned char *buf, + size_t maxlen, size_t *written); +/* 79 */ +EXTERN mp_err TclBN_mp_div_ld(const mp_int *a, Tcl_WideUInt b, + mp_int *q, Tcl_WideUInt *r); +/* 80 */ +EXTERN int TclBN_mp_to_radix(const mp_int *a, char *str, + size_t maxlen, size_t *written, int radix); typedef struct TclTomMathStubs { int magic; void *hooks; int (*tclBN_epoch) (void); /* 0 */ int (*tclBN_revision) (void); /* 1 */ - int (*tclBN_mp_add) (const mp_int *a, const mp_int *b, mp_int *c); /* 2 */ - int (*tclBN_mp_add_d) (const mp_int *a, mp_digit b, mp_int *c); /* 3 */ - int (*tclBN_mp_and) (const mp_int *a, const mp_int *b, mp_int *c); /* 4 */ + mp_err (*tclBN_mp_add) (const mp_int *a, const mp_int *b, mp_int *c); /* 2 */ + mp_err (*tclBN_mp_add_d) (const mp_int *a, mp_digit b, mp_int *c); /* 3 */ + mp_err (*tclBN_mp_and) (const mp_int *a, const mp_int *b, mp_int *c); /* 4 */ void (*tclBN_mp_clamp) (mp_int *a); /* 5 */ void (*tclBN_mp_clear) (mp_int *a); /* 6 */ void (*tclBN_mp_clear_multi) (mp_int *a, ...); /* 7 */ - int (*tclBN_mp_cmp) (const mp_int *a, const mp_int *b); /* 8 */ - int (*tclBN_mp_cmp_d) (const mp_int *a, mp_digit b); /* 9 */ - int (*tclBN_mp_cmp_mag) (const mp_int *a, const mp_int *b); /* 10 */ - int (*tclBN_mp_copy) (const mp_int *a, mp_int *b); /* 11 */ + mp_ord (*tclBN_mp_cmp) (const mp_int *a, const mp_int *b); /* 8 */ + mp_ord (*tclBN_mp_cmp_d) (const mp_int *a, mp_digit b); /* 9 */ + mp_ord (*tclBN_mp_cmp_mag) (const mp_int *a, const mp_int *b); /* 10 */ + mp_err (*tclBN_mp_copy) (const mp_int *a, mp_int *b); /* 11 */ int (*tclBN_mp_count_bits) (const mp_int *a); /* 12 */ - int (*tclBN_mp_div) (const mp_int *a, const mp_int *b, mp_int *q, mp_int *r); /* 13 */ - int (*tclBN_mp_div_d) (const mp_int *a, mp_digit b, mp_int *q, mp_digit *r); /* 14 */ - int (*tclBN_mp_div_2) (const mp_int *a, mp_int *q); /* 15 */ - int (*tclBN_mp_div_2d) (const mp_int *a, int b, mp_int *q, mp_int *r); /* 16 */ - int (*tclBN_mp_div_3) (const mp_int *a, mp_int *q, mp_digit *r); /* 17 */ + mp_err (*tclBN_mp_div) (const mp_int *a, const mp_int *b, mp_int *q, mp_int *r); /* 13 */ + mp_err (*tclBN_mp_div_d) (const mp_int *a, mp_digit b, mp_int *q, mp_digit *r); /* 14 */ + mp_err (*tclBN_mp_div_2) (const mp_int *a, mp_int *q); /* 15 */ + mp_err (*tclBN_mp_div_2d) (const mp_int *a, int b, mp_int *q, mp_int *r); /* 16 */ + mp_err (*tclBN_mp_div_3) (const mp_int *a, mp_int *q, mp_digit *r); /* 17 */ void (*tclBN_mp_exch) (mp_int *a, mp_int *b); /* 18 */ - int (*tclBN_mp_expt_d) (const mp_int *a, mp_digit b, mp_int *c); /* 19 */ - int (*tclBN_mp_grow) (mp_int *a, int size); /* 20 */ - int (*tclBN_mp_init) (mp_int *a); /* 21 */ - int (*tclBN_mp_init_copy) (mp_int *a, const mp_int *b); /* 22 */ - int (*tclBN_mp_init_multi) (mp_int *a, ...); /* 23 */ - int (*tclBN_mp_init_set) (mp_int *a, mp_digit b); /* 24 */ - int (*tclBN_mp_init_size) (mp_int *a, int size); /* 25 */ - int (*tclBN_mp_lshd) (mp_int *a, int shift); /* 26 */ - int (*tclBN_mp_mod) (const mp_int *a, const mp_int *b, mp_int *r); /* 27 */ - int (*tclBN_mp_mod_2d) (const mp_int *a, int b, mp_int *r); /* 28 */ - int (*tclBN_mp_mul) (const mp_int *a, const mp_int *b, mp_int *p); /* 29 */ - int (*tclBN_mp_mul_d) (const mp_int *a, mp_digit b, mp_int *p); /* 30 */ - int (*tclBN_mp_mul_2) (const mp_int *a, mp_int *p); /* 31 */ - int (*tclBN_mp_mul_2d) (const mp_int *a, int d, mp_int *p); /* 32 */ - int (*tclBN_mp_neg) (const mp_int *a, mp_int *b); /* 33 */ - int (*tclBN_mp_or) (const mp_int *a, const mp_int *b, mp_int *c); /* 34 */ - int (*tclBN_mp_radix_size) (const mp_int *a, int radix, int *size); /* 35 */ - int (*tclBN_mp_read_radix) (mp_int *a, const char *str, int radix); /* 36 */ + mp_err (*tclBN_mp_expt_d) (const mp_int *a, unsigned int b, mp_int *c); /* 19 */ + mp_err (*tclBN_mp_grow) (mp_int *a, int size); /* 20 */ + mp_err (*tclBN_mp_init) (mp_int *a); /* 21 */ + mp_err (*tclBN_mp_init_copy) (mp_int *a, const mp_int *b); /* 22 */ + mp_err (*tclBN_mp_init_multi) (mp_int *a, ...); /* 23 */ + mp_err (*tclBN_mp_init_set) (mp_int *a, mp_digit b); /* 24 */ + mp_err (*tclBN_mp_init_size) (mp_int *a, int size); /* 25 */ + mp_err (*tclBN_mp_lshd) (mp_int *a, int shift); /* 26 */ + mp_err (*tclBN_mp_mod) (const mp_int *a, const mp_int *b, mp_int *r); /* 27 */ + mp_err (*tclBN_mp_mod_2d) (const mp_int *a, int b, mp_int *r); /* 28 */ + mp_err (*tclBN_mp_mul) (const mp_int *a, const mp_int *b, mp_int *p); /* 29 */ + mp_err (*tclBN_mp_mul_d) (const mp_int *a, mp_digit b, mp_int *p); /* 30 */ + mp_err (*tclBN_mp_mul_2) (const mp_int *a, mp_int *p); /* 31 */ + mp_err (*tclBN_mp_mul_2d) (const mp_int *a, int d, mp_int *p); /* 32 */ + mp_err (*tclBN_mp_neg) (const mp_int *a, mp_int *b); /* 33 */ + mp_err (*tclBN_mp_or) (const mp_int *a, const mp_int *b, mp_int *c); /* 34 */ + mp_err (*tclBN_mp_radix_size) (const mp_int *a, int radix, int *size); /* 35 */ + mp_err (*tclBN_mp_read_radix) (mp_int *a, const char *str, int radix); /* 36 */ void (*tclBN_mp_rshd) (mp_int *a, int shift); /* 37 */ - int (*tclBN_mp_shrink) (mp_int *a); /* 38 */ + mp_err (*tclBN_mp_shrink) (mp_int *a); /* 38 */ void (*tclBN_mp_set) (mp_int *a, mp_digit b); /* 39 */ - int (*tclBN_mp_sqr) (const mp_int *a, mp_int *b); /* 40 */ - int (*tclBN_mp_sqrt) (const mp_int *a, mp_int *b); /* 41 */ - int (*tclBN_mp_sub) (const mp_int *a, const mp_int *b, mp_int *c); /* 42 */ - int (*tclBN_mp_sub_d) (const mp_int *a, mp_digit b, mp_int *c); /* 43 */ - int (*tclBN_mp_to_unsigned_bin) (const mp_int *a, unsigned char *b); /* 44 */ - int (*tclBN_mp_to_unsigned_bin_n) (const mp_int *a, unsigned char *b, unsigned long *outlen); /* 45 */ - int (*tclBN_mp_toradix_n) (const mp_int *a, char *str, int radix, int maxlen); /* 46 */ - int (*tclBN_mp_unsigned_bin_size) (const mp_int *a); /* 47 */ - int (*tclBN_mp_xor) (const mp_int *a, const mp_int *b, mp_int *c); /* 48 */ + mp_err (*tclBN_mp_sqr) (const mp_int *a, mp_int *b); /* 40 */ + mp_err (*tclBN_mp_sqrt) (const mp_int *a, mp_int *b); /* 41 */ + mp_err (*tclBN_mp_sub) (const mp_int *a, const mp_int *b, mp_int *c); /* 42 */ + mp_err (*tclBN_mp_sub_d) (const mp_int *a, mp_digit b, mp_int *c); /* 43 */ + mp_err (*tclBN_mp_to_unsigned_bin) (const mp_int *a, unsigned char *b); /* 44 */ + mp_err (*tclBN_mp_to_unsigned_bin_n) (const mp_int *a, unsigned char *b, unsigned long *outlen); /* 45 */ + mp_err (*tclBN_mp_toradix_n) (const mp_int *a, char *str, int radix, int maxlen); /* 46 */ + size_t (*tclBN_mp_unsigned_bin_size) (const mp_int *a); /* 47 */ + mp_err (*tclBN_mp_xor) (const mp_int *a, const mp_int *b, mp_int *c); /* 48 */ void (*tclBN_mp_zero) (mp_int *a); /* 49 */ - void (*reserved50)(void); - void (*reserved51)(void); - void (*reserved52)(void); - void (*reserved53)(void); - void (*reserved54)(void); - void (*reserved55)(void); - void (*reserved56)(void); - void (*reserved57)(void); - void (*reserved58)(void); - void (*reserved59)(void); - void (*reserved60)(void); - int (*tclBN_mp_init_set_int) (mp_int *a, unsigned long i); /* 61 */ - int (*tclBN_mp_set_int) (mp_int *a, unsigned long i); /* 62 */ + void (*tclBN_reverse) (unsigned char *s, int len); /* 50 */ + mp_err (*tclBN_fast_s_mp_mul_digs) (const mp_int *a, const mp_int *b, mp_int *c, int digs); /* 51 */ + mp_err (*tclBN_fast_s_mp_sqr) (const mp_int *a, mp_int *b); /* 52 */ + mp_err (*tclBN_mp_karatsuba_mul) (const mp_int *a, const mp_int *b, mp_int *c); /* 53 */ + mp_err (*tclBN_mp_karatsuba_sqr) (const mp_int *a, mp_int *b); /* 54 */ + mp_err (*tclBN_mp_toom_mul) (const mp_int *a, const mp_int *b, mp_int *c); /* 55 */ + mp_err (*tclBN_mp_toom_sqr) (const mp_int *a, mp_int *b); /* 56 */ + mp_err (*tclBN_s_mp_add) (const mp_int *a, const mp_int *b, mp_int *c); /* 57 */ + mp_err (*tclBN_s_mp_mul_digs) (const mp_int *a, const mp_int *b, mp_int *c, int digs); /* 58 */ + mp_err (*tclBN_s_mp_sqr) (const mp_int *a, mp_int *b); /* 59 */ + mp_err (*tclBN_s_mp_sub) (const mp_int *a, const mp_int *b, mp_int *c); /* 60 */ + mp_err (*tclBN_mp_init_set_int) (mp_int *a, unsigned long i); /* 61 */ + mp_err (*tclBN_mp_set_int) (mp_int *a, unsigned long i); /* 62 */ int (*tclBN_mp_cnt_lsb) (const mp_int *a); /* 63 */ - void (*reserved64)(void); - void (*reserved65)(void); - void (*reserved66)(void); - int (*tclBN_mp_expt_d_ex) (const mp_int *a, mp_digit b, mp_int *c, int fast); /* 67 */ - int (*tclBN_mp_set_long_long) (mp_int *a, Tcl_WideUInt i); /* 68 */ - Tcl_WideUInt (*tclBN_mp_get_long_long) (const mp_int *a); /* 69 */ - int (*tclBN_mp_set_long) (mp_int *a, unsigned long i); /* 70 */ - unsigned long (*tclBN_mp_get_long) (const mp_int *a); /* 71 */ - unsigned long (*tclBN_mp_get_int) (const mp_int *a); /* 72 */ - void (*reserved73)(void); - void (*reserved74)(void); - void (*reserved75)(void); - int (*tclBN_mp_signed_rsh) (const mp_int *a, int b, mp_int *c); /* 76 */ - int (*tclBN_mp_get_bit) (const mp_int *a, int b); /* 77 */ + int (*tclBNInitBignumFromLong) (mp_int *bignum, long initVal); /* 64 */ + int (*tclBNInitBignumFromWideInt) (mp_int *bignum, Tcl_WideInt initVal); /* 65 */ + int (*tclBNInitBignumFromWideUInt) (mp_int *bignum, Tcl_WideUInt initVal); /* 66 */ + mp_err (*tclBN_mp_expt_d_ex) (const mp_int *a, mp_digit b, mp_int *c, int fast); /* 67 */ + void (*tclBN_mp_set_ull) (mp_int *a, Tcl_WideUInt i); /* 68 */ + Tcl_WideUInt (*tclBN_mp_get_mag_ull) (const mp_int *a); /* 69 */ + void (*tclBN_mp_set_ll) (mp_int *a, Tcl_WideInt i); /* 70 */ + void (*reserved71)(void); + void (*reserved72)(void); + mp_err (*tclBN_mp_tc_and) (const mp_int *a, const mp_int *b, mp_int *c); /* 73 */ + mp_err (*tclBN_mp_tc_or) (const mp_int *a, const mp_int *b, mp_int *c); /* 74 */ + mp_err (*tclBN_mp_tc_xor) (const mp_int *a, const mp_int *b, mp_int *c); /* 75 */ + mp_err (*tclBN_mp_signed_rsh) (const mp_int *a, int b, mp_int *c); /* 76 */ + void (*reserved77)(void); + int (*tclBN_mp_to_ubin) (const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written); /* 78 */ + mp_err (*tclBN_mp_div_ld) (const mp_int *a, Tcl_WideUInt b, mp_int *q, Tcl_WideUInt *r); /* 79 */ + int (*tclBN_mp_to_radix) (const mp_int *a, char *str, size_t maxlen, size_t *written, int radix); /* 80 */ } TclTomMathStubs; extern const TclTomMathStubs *tclTomMathStubsPtr; #ifdef __cplusplus @@ -525,53 +551,119 @@ (tclTomMathStubsPtr->tclBN_mp_unsigned_bin_size) /* 47 */ #define TclBN_mp_xor \ (tclTomMathStubsPtr->tclBN_mp_xor) /* 48 */ #define TclBN_mp_zero \ (tclTomMathStubsPtr->tclBN_mp_zero) /* 49 */ -/* Slot 50 is reserved */ -/* Slot 51 is reserved */ -/* Slot 52 is reserved */ -/* Slot 53 is reserved */ -/* Slot 54 is reserved */ -/* Slot 55 is reserved */ -/* Slot 56 is reserved */ -/* Slot 57 is reserved */ -/* Slot 58 is reserved */ -/* Slot 59 is reserved */ -/* Slot 60 is reserved */ +#define TclBN_reverse \ + (tclTomMathStubsPtr->tclBN_reverse) /* 50 */ +#define TclBN_fast_s_mp_mul_digs \ + (tclTomMathStubsPtr->tclBN_fast_s_mp_mul_digs) /* 51 */ +#define TclBN_fast_s_mp_sqr \ + (tclTomMathStubsPtr->tclBN_fast_s_mp_sqr) /* 52 */ +#define TclBN_mp_karatsuba_mul \ + (tclTomMathStubsPtr->tclBN_mp_karatsuba_mul) /* 53 */ +#define TclBN_mp_karatsuba_sqr \ + (tclTomMathStubsPtr->tclBN_mp_karatsuba_sqr) /* 54 */ +#define TclBN_mp_toom_mul \ + (tclTomMathStubsPtr->tclBN_mp_toom_mul) /* 55 */ +#define TclBN_mp_toom_sqr \ + (tclTomMathStubsPtr->tclBN_mp_toom_sqr) /* 56 */ +#define TclBN_s_mp_add \ + (tclTomMathStubsPtr->tclBN_s_mp_add) /* 57 */ +#define TclBN_s_mp_mul_digs \ + (tclTomMathStubsPtr->tclBN_s_mp_mul_digs) /* 58 */ +#define TclBN_s_mp_sqr \ + (tclTomMathStubsPtr->tclBN_s_mp_sqr) /* 59 */ +#define TclBN_s_mp_sub \ + (tclTomMathStubsPtr->tclBN_s_mp_sub) /* 60 */ #define TclBN_mp_init_set_int \ (tclTomMathStubsPtr->tclBN_mp_init_set_int) /* 61 */ #define TclBN_mp_set_int \ (tclTomMathStubsPtr->tclBN_mp_set_int) /* 62 */ #define TclBN_mp_cnt_lsb \ (tclTomMathStubsPtr->tclBN_mp_cnt_lsb) /* 63 */ -/* Slot 64 is reserved */ -/* Slot 65 is reserved */ -/* Slot 66 is reserved */ +#define TclBNInitBignumFromLong \ + (tclTomMathStubsPtr->tclBNInitBignumFromLong) /* 64 */ +#define TclBNInitBignumFromWideInt \ + (tclTomMathStubsPtr->tclBNInitBignumFromWideInt) /* 65 */ +#define TclBNInitBignumFromWideUInt \ + (tclTomMathStubsPtr->tclBNInitBignumFromWideUInt) /* 66 */ #define TclBN_mp_expt_d_ex \ (tclTomMathStubsPtr->tclBN_mp_expt_d_ex) /* 67 */ -#define TclBN_mp_set_long_long \ - (tclTomMathStubsPtr->tclBN_mp_set_long_long) /* 68 */ -#define TclBN_mp_get_long_long \ - (tclTomMathStubsPtr->tclBN_mp_get_long_long) /* 69 */ -#define TclBN_mp_set_long \ - (tclTomMathStubsPtr->tclBN_mp_set_long) /* 70 */ -#define TclBN_mp_get_long \ - (tclTomMathStubsPtr->tclBN_mp_get_long) /* 71 */ -#define TclBN_mp_get_int \ - (tclTomMathStubsPtr->tclBN_mp_get_int) /* 72 */ -/* Slot 73 is reserved */ -/* Slot 74 is reserved */ -/* Slot 75 is reserved */ +#define TclBN_mp_set_ull \ + (tclTomMathStubsPtr->tclBN_mp_set_ull) /* 68 */ +#define TclBN_mp_get_mag_ull \ + (tclTomMathStubsPtr->tclBN_mp_get_mag_ull) /* 69 */ +#define TclBN_mp_set_ll \ + (tclTomMathStubsPtr->tclBN_mp_set_ll) /* 70 */ +/* Slot 71 is reserved */ +/* Slot 72 is reserved */ +#define TclBN_mp_tc_and \ + (tclTomMathStubsPtr->tclBN_mp_tc_and) /* 73 */ +#define TclBN_mp_tc_or \ + (tclTomMathStubsPtr->tclBN_mp_tc_or) /* 74 */ +#define TclBN_mp_tc_xor \ + (tclTomMathStubsPtr->tclBN_mp_tc_xor) /* 75 */ #define TclBN_mp_signed_rsh \ (tclTomMathStubsPtr->tclBN_mp_signed_rsh) /* 76 */ -#define TclBN_mp_get_bit \ - (tclTomMathStubsPtr->tclBN_mp_get_bit) /* 77 */ +/* Slot 77 is reserved */ +#define TclBN_mp_to_ubin \ + (tclTomMathStubsPtr->tclBN_mp_to_ubin) /* 78 */ +#define TclBN_mp_div_ld \ + (tclTomMathStubsPtr->tclBN_mp_div_ld) /* 79 */ +#define TclBN_mp_to_radix \ + (tclTomMathStubsPtr->tclBN_mp_to_radix) /* 80 */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT +#ifdef USE_TCL_STUBS +#undef TclBNInitBignumFromLong +#define TclBNInitBignumFromLong(a,b) \ + do { \ + (a)->dp = NULL; \ + (void)tclTomMathStubsPtr->tclBNInitBignumFromLong((a),(b)); \ + if ((a)->dp == NULL) { \ + Tcl_Panic("initialization failure in TclBNInitBignumFromLong"); \ + } \ + } while (0) +#undef TclBNInitBignumFromWideInt +#define TclBNInitBignumFromWideInt(a,b) \ + do { \ + (a)->dp = NULL; \ + (void)tclTomMathStubsPtr->tclBNInitBignumFromWideInt((a),(b)); \ + if ((a)->dp == NULL) { \ + Tcl_Panic("initialization failure in TclBNInitBignumFromWideInt"); \ + } \ + } while (0) +#undef TclBNInitBignumFromWideUInt +#define TclBNInitBignumFromWideUInt(a,b) \ + do { \ + (a)->dp = NULL; \ + (void)tclTomMathStubsPtr->tclBNInitBignumFromWideUInt((a),(b)); \ + if ((a)->dp == NULL) { \ + Tcl_Panic("initialization failure in TclBNInitBignumFromWideUInt"); \ + } \ + } while (0) +#define mp_init_i32(a,b) (((a)->dp=NULL,tclTomMathStubsPtr->tclBNInitBignumFromLong((a),(int32_t)(b)),(a)->dp)?MP_OKAY:MP_ERR) +#define mp_init_l(a,b) (((a)->dp=NULL,tclTomMathStubsPtr->tclBNInitBignumFromLong((a),(b)),(a)->dp)?MP_OKAY:MP_ERR) +#define mp_init_ll(a,b) (((a)->dp=NULL,tclTomMathStubsPtr->tclBNInitBignumFromWideInt((a),(b)),(a)->dp)?MP_OKAY:MP_ERR) +#define mp_init_i64(a,b) (((a)->dp=NULL,tclTomMathStubsPtr->tclBNInitBignumFromWideInt((a),(b)),(a)->dp)?MP_OKAY:MP_ERR) +#define mp_init_u32(a,b) (((a)->dp=NULL,tclTomMathStubsPtr->tclBNInitBignumFromWideUInt((a),(uint32_t)(b)),(a)->dp)?MP_OKAY:MP_ERR) +#define mp_init_ul(a,b) (((a)->dp=NULL,tclTomMathStubsPtr->tclBNInitBignumFromWideUInt((a),(unsigned long)(b)),(a)->dp)?MP_OKAY:MP_ERR) +#define mp_init_ull(a,b) (((a)->dp=NULL,tclTomMathStubsPtr->tclBNInitBignumFromWideUInt((a),(b)),(a)->dp)?MP_OKAY:MP_ERR) +#define mp_init_u64(a,b) (((a)->dp=NULL,tclTomMathStubsPtr->tclBNInitBignumFromWideUInt((a),(b)),(a)->dp)?MP_OKAY:MP_ERR) +#else +#define mp_init_i32(a,b) (((a)->dp=NULL,(TclBNInitBignumFromLong)((a),(int32_t)(b)),(a)->dp)?MP_OKAY:MP_ERR) +#define mp_init_l(a,b) (((a)->dp=NULL,(TclBNInitBignumFromLong)((a),(b)),(a)->dp)?MP_OKAY:MP_ERR) +#define mp_init_ll(a,b) (((a)->dp=NULL,(TclBNInitBignumFromWideInt)((a),(b)),(a)->dp)?MP_OKAY:MP_ERR) +#define mp_init_i64(a,b) (((a)->dp=NULL,(TclBNInitBignumFromWideInt)((a),(b)),(a)->dp)?MP_OKAY:MP_ERR) +#define mp_init_u32(a,b) (((a)->dp=NULL,(TclBNInitBignumFromWideUInt)((a),(uint32_t)(b)),(a)->dp)?MP_OKAY:MP_ERR) +#define mp_init_ul(a,b) (((a)->dp=NULL,(TclBNInitBignumFromWideUInt)((a),(unsigned long)(b)),(a)->dp)?MP_OKAY:MP_ERR) +#define mp_init_ull(a,b) (((a)->dp=NULL,(TclBNInitBignumFromWideUInt)((a),(b)),(a)->dp)?MP_OKAY:MP_ERR) +#define mp_init_u64(a,b) (((a)->dp=NULL,(TclBNInitBignumFromWideUInt)((a),(b)),(a)->dp)?MP_OKAY:MP_ERR) +#endif /* USE_TCL_STUBS */ #endif /* _TCLINTDECLS */ Index: generic/tclTomMathInterface.c ================================================================== --- generic/tclTomMathInterface.c +++ generic/tclTomMathInterface.c @@ -91,11 +91,68 @@ } /* *---------------------------------------------------------------------- * - * TclInitBignumFromWideInt -- + * TclBNInitBignumFromLong -- + * + * Allocate and initialize a 'bignum' from a native 'long'. + * + * Results: + * None. + * + * Side effects: + * The 'bignum' is constructed. + * + *---------------------------------------------------------------------- + */ + +int +TclBNInitBignumFromLong( + mp_int *a, + long initVal) +{ + unsigned long v; + mp_digit *p; + + /* + * Allocate enough memory to hold the largest possible long + */ + + if (mp_init(a) != MP_OKAY) { + Tcl_Panic("initialization failure in TclBNInitBignumFromLong"); + } + + /* + * Convert arg to sign and magnitude. + */ + + if (initVal < 0) { + a->sign = MP_NEG; + v = -(unsigned long)initVal; + } else { + a->sign = MP_ZPOS; + v = initVal; + } + + /* + * Store the magnitude in the bignum. + */ + + p = a->dp; + while (v) { + *p++ = (mp_digit) (v & MP_MASK); + v >>= MP_DIGIT_BIT; + } + a->used = p - a->dp; + return MP_OKAY; +} + +/* + *---------------------------------------------------------------------- + * + * TclBNInitBignumFromWideInt -- * * Allocate and initialize a 'bignum' from a Tcl_WideInt * * Results: * None. @@ -104,30 +161,27 @@ * The 'bignum' is constructed. * *---------------------------------------------------------------------- */ -void -TclInitBignumFromWideInt( +int +TclBNInitBignumFromWideInt( mp_int *a, /* Bignum to initialize */ Tcl_WideInt v) /* Initial value */ { - if (mp_init(a) != MP_OKAY) { - Tcl_Panic("initialization failure in TclInitBignumFromWideInt"); - } - if (v < (Tcl_WideInt)0) { - mp_set_long_long(a, (Tcl_WideUInt)(-v)); - mp_neg(a, a); - } else { - mp_set_long_long(a, (Tcl_WideUInt)v); - } + if (v < 0) { + (void)TclBNInitBignumFromWideUInt(a, -(Tcl_WideUInt)v); + return mp_neg(a, a); + } + (void)TclBNInitBignumFromWideUInt(a, (Tcl_WideUInt)v); + return MP_OKAY; } /* *---------------------------------------------------------------------- * - * TclInitBignumFromWideUInt -- + * TclBNInitBignumFromWideUInt -- * * Allocate and initialize a 'bignum' from a Tcl_WideUInt * * Results: * None. @@ -136,23 +190,42 @@ * The 'bignum' is constructed. * *---------------------------------------------------------------------- */ -void -TclInitBignumFromWideUInt( +int +TclBNInitBignumFromWideUInt( mp_int *a, /* Bignum to initialize */ Tcl_WideUInt v) /* Initial value */ { - if (mp_init(a) != MP_OKAY) { - Tcl_Panic("initialization failure in TclInitBignumFromWideUInt"); - } - mp_set_long_long(a, v); + mp_digit *p; + + /* + * Allocate enough memory to hold the largest possible Tcl_WideUInt. + */ + + if (mp_init(a) != MP_OKAY) { + Tcl_Panic("initialization failure in TclBNInitBignumFromWideUInt"); + } + + a->sign = 0; + + /* + * Store the magnitude in the bignum. + */ + + p = a->dp; + while (v) { + *p++ = (mp_digit) (v & MP_MASK); + v >>= MP_DIGIT_BIT; + } + a->used = p - a->dp; + return MP_OKAY; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: generic/tclTomMathStubLib.c ================================================================== --- generic/tclTomMathStubLib.c +++ generic/tclTomMathStubLib.c @@ -53,13 +53,13 @@ if (actualVersion == NULL) { return NULL; } if (stubsPtr == NULL) { errMsg = "missing stub table pointer"; - } else if (stubsPtr->tclBN_epoch() != epoch) { + } else if(stubsPtr->tclBN_epoch() != epoch) { errMsg = "epoch number mismatch"; - } else if (stubsPtr->tclBN_revision() != revision) { + } else if(stubsPtr->tclBN_revision() != revision) { errMsg = "requires a later revision"; } else { tclTomMathStubsPtr = stubsPtr; return actualVersion; } Index: generic/tclTrace.c ================================================================== --- generic/tclTrace.c +++ generic/tclTrace.c @@ -50,11 +50,11 @@ char *startCmd; /* Used for bookkeeping with step execution * traces, store the command name which * invoked step trace */ int curFlags; /* Trace flags for the current command */ int curCode; /* Return code for the current command */ - size_t refCount; /* Used to ensure this structure is not + int 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[1]; /* Space for Tcl command to invoke. Actual * size will be as large as necessary to hold @@ -119,11 +119,11 @@ /* * Declarations for local functions to this file: */ static int CallTraceFunction(Tcl_Interp *interp, Trace *tracePtr, - Command *cmdPtr, const char *command, size_t numChars, + Command *cmdPtr, const char *command, int numChars, int objc, Tcl_Obj *const objv[]); static char * TraceVarProc(ClientData clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); static void TraceCommandProc(ClientData clientData, Tcl_Interp *interp, const char *oldName, @@ -134,18 +134,18 @@ const char *command, Tcl_Command commandInfo, int objc, Tcl_Obj *const objv[]); static void StringTraceDeleteProc(ClientData clientData); static void DisposeTraceResult(int flags, char *result); static int TraceVarEx(Tcl_Interp *interp, const char *part1, - const char *part2, register VarTrace *tracePtr); + const char *part2, VarTrace *tracePtr); /* * The following structure holds the client data for string-based * trace procs */ -typedef struct { +typedef struct StringTraceData { ClientData clientData; /* Client data from Tcl_CreateTrace */ Tcl_CmdTraceProc *proc; /* Trace function from Tcl_CreateTrace */ } StringTraceData; /* @@ -269,21 +269,20 @@ #ifndef TCL_REMOVE_OBSOLETE_TRACES case TRACE_OLD_VARIABLE: case TRACE_OLD_VDELETE: { Tcl_Obj *copyObjv[6]; Tcl_Obj *opsList; - int code; - size_t numFlags; + int code, numFlags; if (objc != 5) { Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); return TCL_ERROR; } - opsList = Tcl_NewObj(); + TclNewObj(opsList); Tcl_IncrRefCount(opsList); - flagOps = TclGetStringFromObj(objv[3], &numFlags); + flagOps = Tcl_GetStringFromObj(objv[3], &numFlags); if (numFlags == 0) { Tcl_DecrRefCount(opsList); goto badVarOps; } for (p = flagOps; *p != 0; p++) { @@ -321,12 +320,12 @@ if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "name"); return TCL_ERROR; } - resultListPtr = Tcl_NewObj(); - name = TclGetString(objv[2]); + TclNewObj(resultListPtr); + name = Tcl_GetString(objv[2]); FOREACH_VAR_TRACE(interp, name, clientData) { TraceVarInfo *tvarPtr = clientData; char *q = ops; pairObjPtr = Tcl_NewListObj(0, NULL); @@ -402,13 +401,13 @@ Tcl_Interp *interp, /* Current interpreter. */ int optionIndex, /* Add, info or remove */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int index; + int commandLength, index; const char *name, *command; - size_t commandLength, length; + size_t length; enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE }; static const char *const opStrings[] = { "enter", "leave", "enterstep", "leavestep", NULL @@ -465,15 +464,15 @@ case TRACE_EXEC_LEAVE_STEP: flags |= TCL_TRACE_LEAVE_DURING_EXEC; break; } } - command = TclGetStringFromObj(objv[5], &commandLength); - length = commandLength; + command = Tcl_GetStringFromObj(objv[5], &commandLength); + length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { - TraceCommandInfo *tcmdPtr = Tcl_Alloc( - offsetof(TraceCommandInfo, command) + 1 + length); + TraceCommandInfo *tcmdPtr = ckalloc( + TclOffset(TraceCommandInfo, command) + 1 + length); tcmdPtr->flags = flags; tcmdPtr->stepTrace = NULL; tcmdPtr->startLevel = 0; tcmdPtr->startCmd = NULL; @@ -483,14 +482,14 @@ if (flags & (TCL_TRACE_ENTER_DURING_EXEC | TCL_TRACE_LEAVE_DURING_EXEC)) { flags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); } memcpy(tcmdPtr->command, command, length+1); - name = TclGetString(objv[3]); + name = Tcl_GetString(objv[3]); if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, tcmdPtr) != TCL_OK) { - Tcl_Free(tcmdPtr); + ckfree(tcmdPtr); return TCL_ERROR; } } else { /* * Search through all of our traces on this command to see if @@ -502,11 +501,11 @@ /* * First ensure the name given is valid. */ - name = TclGetString(objv[3]); + name = Tcl_GetString(objv[3]); if (Tcl_FindCommand(interp,name,NULL,TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } FOREACH_COMMAND_TRACE(interp, name, clientData) { @@ -520,11 +519,11 @@ if ((tcmdPtr->length == length) && ((tcmdPtr->flags & (TCL_TRACE_ANY_EXEC | TCL_TRACE_RENAME | TCL_TRACE_DELETE)) == flags) && (strncmp(command, tcmdPtr->command, - length) == 0)) { + (size_t) length) == 0)) { flags |= TCL_TRACE_DELETE; if (flags & (TCL_TRACE_ENTER_DURING_EXEC | TCL_TRACE_LEAVE_DURING_EXEC)) { flags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); } @@ -536,21 +535,21 @@ * we created to allow 'step' traces. */ Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; - Tcl_Free(tcmdPtr->startCmd); + ckfree(tcmdPtr->startCmd); } if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { /* * Postpone deletion. */ tcmdPtr->flags = 0; } if (tcmdPtr->refCount-- <= 1) { - Tcl_Free(tcmdPtr); + ckfree(tcmdPtr); } break; } } } @@ -563,11 +562,11 @@ if (objc != 4) { Tcl_WrongNumArgs(interp, 3, objv, "name"); return TCL_ERROR; } - name = TclGetString(objv[3]); + name = Tcl_GetString(objv[3]); /* * First ensure the name given is valid. */ @@ -650,13 +649,13 @@ Tcl_Interp *interp, /* Current interpreter. */ int optionIndex, /* Add, info or remove */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int index; + int commandLength, index; const char *name, *command; - size_t commandLength, length; + size_t length; enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE }; static const char *const opStrings[] = { "delete", "rename", NULL }; enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME }; switch ((enum traceOptions) optionIndex) { @@ -702,28 +701,28 @@ flags |= TCL_TRACE_DELETE; break; } } - command = TclGetStringFromObj(objv[5], &commandLength); - length = commandLength; + command = Tcl_GetStringFromObj(objv[5], &commandLength); + length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { - TraceCommandInfo *tcmdPtr = Tcl_Alloc( - offsetof(TraceCommandInfo, command) + 1 + length); + TraceCommandInfo *tcmdPtr = ckalloc( + TclOffset(TraceCommandInfo, command) + 1 + length); tcmdPtr->flags = flags; tcmdPtr->stepTrace = NULL; tcmdPtr->startLevel = 0; tcmdPtr->startCmd = NULL; tcmdPtr->length = length; tcmdPtr->refCount = 1; flags |= TCL_TRACE_DELETE; memcpy(tcmdPtr->command, command, length+1); - name = TclGetString(objv[3]); + name = Tcl_GetString(objv[3]); if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, tcmdPtr) != TCL_OK) { - Tcl_Free(tcmdPtr); + ckfree(tcmdPtr); return TCL_ERROR; } } else { /* * Search through all of our traces on this command to see if @@ -735,26 +734,26 @@ /* * First ensure the name given is valid. */ - name = TclGetString(objv[3]); + name = Tcl_GetString(objv[3]); if (Tcl_FindCommand(interp,name,NULL,TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } FOREACH_COMMAND_TRACE(interp, name, clientData) { TraceCommandInfo *tcmdPtr = clientData; if ((tcmdPtr->length == length) && (tcmdPtr->flags == flags) && (strncmp(command, tcmdPtr->command, - length) == 0)) { + (size_t) length) == 0)) { Tcl_UntraceCommand(interp, name, flags | TCL_TRACE_DELETE, TraceCommandProc, clientData); tcmdPtr->flags |= TCL_TRACE_DESTROYED; if (tcmdPtr->refCount-- <= 1) { - Tcl_Free(tcmdPtr); + ckfree(tcmdPtr); } break; } } } @@ -771,11 +770,11 @@ /* * First ensure the name given is valid. */ - name = TclGetString(objv[3]); + name = Tcl_GetString(objv[3]); if (Tcl_FindCommand(interp, name, NULL, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } resultListPtr = Tcl_NewListObj(0, NULL); @@ -844,13 +843,13 @@ Tcl_Interp *interp, /* Current interpreter. */ int optionIndex, /* Add, info or remove */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int index; + int commandLength, index; const char *name, *command; - size_t commandLength, length; + size_t length; ClientData clientData; enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE }; static const char *const opStrings[] = { "array", "read", "unset", "write", NULL }; @@ -905,15 +904,15 @@ case TRACE_VAR_WRITE: flags |= TCL_TRACE_WRITES; break; } } - command = TclGetStringFromObj(objv[5], &commandLength); - length = commandLength; + command = Tcl_GetStringFromObj(objv[5], &commandLength); + length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { - CombinedTraceVarInfo *ctvarPtr = Tcl_Alloc( - offsetof(CombinedTraceVarInfo, traceCmdInfo.command) + CombinedTraceVarInfo *ctvarPtr = ckalloc( + TclOffset(CombinedTraceVarInfo, traceCmdInfo.command) + 1 + length); ctvarPtr->traceCmdInfo.flags = flags; #ifndef TCL_REMOVE_OBSOLETE_TRACES if (objv[0] == NULL) { @@ -924,24 +923,24 @@ flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT; memcpy(ctvarPtr->traceCmdInfo.command, command, length+1); ctvarPtr->traceInfo.traceProc = TraceVarProc; ctvarPtr->traceInfo.clientData = &ctvarPtr->traceCmdInfo; ctvarPtr->traceInfo.flags = flags; - name = TclGetString(objv[3]); + name = Tcl_GetString(objv[3]); if (TraceVarEx(interp, name, NULL, (VarTrace *) ctvarPtr) != TCL_OK) { - Tcl_Free(ctvarPtr); + ckfree(ctvarPtr); return TCL_ERROR; } } else { /* * Search through all of our traces on this variable to see if * there's one with the given command. If so, then delete the * first one that matches. */ - name = TclGetString(objv[3]); + name = Tcl_GetString(objv[3]); FOREACH_VAR_TRACE(interp, name, clientData) { TraceVarInfo *tvarPtr = clientData; if ((tvarPtr->length == length) && ((tvarPtr->flags @@ -948,11 +947,11 @@ #ifndef TCL_REMOVE_OBSOLETE_TRACES & ~TCL_TRACE_OLD_STYLE #endif )==flags) && (strncmp(command, tvarPtr->command, - length) == 0)) { + (size_t) length) == 0)) { Tcl_UntraceVar2(interp, name, NULL, flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT, TraceVarProc, clientData); break; } @@ -966,12 +965,12 @@ if (objc != 4) { Tcl_WrongNumArgs(interp, 3, objv, "name"); return TCL_ERROR; } - resultListPtr = Tcl_NewObj(); - name = TclGetString(objv[3]); + TclNewObj(resultListPtr); + name = Tcl_GetString(objv[3]); FOREACH_VAR_TRACE(interp, name, clientData) { Tcl_Obj *opObjPtr, *eachTraceObjPtr, *elemObjPtr; TraceVarInfo *tvarPtr = clientData; /* @@ -1048,11 +1047,11 @@ * this function, so this call will return the * next trace after that one. If NULL, this * call will return the first trace. */ { Command *cmdPtr; - register CommandTrace *tracePtr; + CommandTrace *tracePtr; cmdPtr = (Command *) Tcl_FindCommand(interp, cmdName, NULL, TCL_LEAVE_ERR_MSG); if (cmdPtr == NULL) { return NULL; @@ -1113,11 +1112,11 @@ Tcl_CommandTraceProc *proc, /* Function to call when specified ops are * invoked upon cmdName. */ ClientData clientData) /* Arbitrary argument to pass to proc. */ { Command *cmdPtr; - register CommandTrace *tracePtr; + CommandTrace *tracePtr; cmdPtr = (Command *) Tcl_FindCommand(interp, cmdName, NULL, TCL_LEAVE_ERR_MSG); if (cmdPtr == NULL) { return TCL_ERROR; @@ -1125,11 +1124,11 @@ /* * Set up trace information. */ - tracePtr = Tcl_Alloc(sizeof(CommandTrace)); + tracePtr = ckalloc(sizeof(CommandTrace)); tracePtr->traceProc = proc; tracePtr->clientData = clientData; tracePtr->flags = flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC); tracePtr->nextPtr = cmdPtr->tracePtr; @@ -1176,14 +1175,14 @@ * TCL_TRACE_RENAME, TCL_TRACE_DELETE, and any * of the TRACE_*_EXEC flags */ Tcl_CommandTraceProc *proc, /* Function assocated with trace. */ ClientData clientData) /* Arbitrary argument to pass to proc. */ { - register CommandTrace *tracePtr; + CommandTrace *tracePtr; CommandTrace *prevPtr; Command *cmdPtr; - Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *)interp; ActiveCommandTrace *activePtr; int hasExecTraces = 0; cmdPtr = (Command *) Tcl_FindCommand(interp, cmdName, NULL, TCL_LEAVE_ERR_MSG); @@ -1231,11 +1230,11 @@ prevPtr->nextPtr = tracePtr->nextPtr; } tracePtr->flags = 0; if (tracePtr->refCount-- <= 1) { - Tcl_Free(tracePtr); + ckfree(tracePtr); } if (hasExecTraces) { for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; tracePtr != NULL ; prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { @@ -1254,11 +1253,10 @@ /* * Bug 3484621: up the interp's epoch if this is a BC'ed command */ if (cmdPtr->compileProc != NULL) { - Interp *iPtr = (Interp *) interp; iPtr->compileEpoch++; } } } @@ -1304,11 +1302,11 @@ * Generate a command to execute by appending list elements for the * old and new command name and the operation. */ Tcl_DStringInit(&cmd); - Tcl_DStringAppend(&cmd, tcmdPtr->command, tcmdPtr->length); + Tcl_DStringAppend(&cmd, tcmdPtr->command, (int) tcmdPtr->length); Tcl_DStringAppendElement(&cmd, oldName); Tcl_DStringAppendElement(&cmd, (newName ? newName : "")); if (flags & TCL_TRACE_RENAME) { TclDStringAppendLiteral(&cmd, " rename"); } else if (flags & TCL_TRACE_DELETE) { @@ -1346,11 +1344,11 @@ Tcl_InterpState state; if (tcmdPtr->stepTrace != NULL) { Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; - Tcl_Free(tcmdPtr->startCmd); + ckfree(tcmdPtr->startCmd); } if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { /* * Postpone deletion, until exec trace returns. */ @@ -1388,11 +1386,11 @@ TraceCommandProc, clientData); Tcl_RestoreInterpState(interp, state); tcmdPtr->refCount--; } if (tcmdPtr->refCount-- <= 1) { - Tcl_Free(tcmdPtr); + ckfree(tcmdPtr); } } /* *---------------------------------------------------------------------- @@ -1422,11 +1420,11 @@ int TclCheckExecutionTraces( Tcl_Interp *interp, /* The current interpreter. */ const char *command, /* Pointer to beginning of the current command * string. */ - size_t numChars, /* The number of characters in 'command' which + int 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. */ int objc, /* Number of arguments for the command. */ @@ -1480,11 +1478,11 @@ state = Tcl_SaveInterpState(interp, code); } traceCode = TraceExecutionProc(tcmdPtr, interp, curLevel, command, (Tcl_Command) cmdPtr, objc, objv); if (tcmdPtr->refCount-- <= 1) { - Tcl_Free(tcmdPtr); + ckfree(tcmdPtr); } } } if (active.nextTracePtr) { lastTracePtr = active.nextTracePtr->nextPtr; @@ -1528,11 +1526,11 @@ int TclCheckInterpTraces( Tcl_Interp *interp, /* The current interpreter. */ const char *command, /* Pointer to beginning of the current command * string. */ - size_t numChars, /* The number of characters in 'command' which + int 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. */ int objc, /* Number of arguments for the command. */ @@ -1671,17 +1669,17 @@ */ static int CallTraceFunction( Tcl_Interp *interp, /* The current interpreter. */ - register 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. */ - size_t numChars, /* The number of characters in the command's + int numChars, /* The number of characters in the command's * source. */ - register int objc, /* Number of arguments for the command. */ + int objc, /* Number of arguments for the command. */ Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; char *commandCopy; int traceCode; @@ -1727,11 +1725,11 @@ ClientData clientData) { TraceCommandInfo *tcmdPtr = clientData; if (tcmdPtr->refCount-- <= 1) { - Tcl_Free(tcmdPtr); + ckfree(tcmdPtr); } } /* *---------------------------------------------------------------------- @@ -1809,11 +1807,11 @@ if ((flags & TCL_TRACE_LEAVE_EXEC) && (tcmdPtr->stepTrace != NULL) && (level == tcmdPtr->startLevel) && (strcmp(command, tcmdPtr->startCmd) == 0)) { Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; - Tcl_Free(tcmdPtr->startCmd); + ckfree(tcmdPtr->startCmd); } /* * Second, create the tcl callback, if required. */ @@ -1821,19 +1819,19 @@ if (call) { Tcl_DString cmd, sub; int i, saveInterpFlags; Tcl_DStringInit(&cmd); - Tcl_DStringAppend(&cmd, tcmdPtr->command, tcmdPtr->length); + Tcl_DStringAppend(&cmd, tcmdPtr->command, (int)tcmdPtr->length); /* * Append command with arguments. */ Tcl_DStringInit(&sub); for (i = 0; i < objc; i++) { - Tcl_DStringAppendElement(&sub, TclGetString(objv[i])); + Tcl_DStringAppendElement(&sub, Tcl_GetString(objv[i])); } Tcl_DStringAppendElement(&cmd, Tcl_DStringValue(&sub)); Tcl_DStringFree(&sub); if (flags & TCL_TRACE_ENTER_EXEC) { @@ -1852,12 +1850,12 @@ /* * Append result code. */ - resultCode = Tcl_NewIntObj(code); - resultCodeStr = TclGetString(resultCode); + TclNewIntObj(resultCode, code); + resultCodeStr = Tcl_GetString(resultCode); Tcl_DStringAppendElement(&cmd, resultCodeStr); Tcl_DecrRefCount(resultCode); /* * Append result string. @@ -1919,14 +1917,14 @@ */ if ((flags & TCL_TRACE_ENTER_EXEC) && (tcmdPtr->stepTrace == NULL) && (tcmdPtr->flags & (TCL_TRACE_ENTER_DURING_EXEC | TCL_TRACE_LEAVE_DURING_EXEC))) { - register unsigned len = strlen(command) + 1; + unsigned len = strlen(command) + 1; tcmdPtr->startLevel = level; - tcmdPtr->startCmd = Tcl_Alloc(len); + tcmdPtr->startCmd = ckalloc(len); memcpy(tcmdPtr->startCmd, command, len); tcmdPtr->refCount++; tcmdPtr->stepTrace = Tcl_CreateObjTrace(interp, 0, (tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2, TraceExecutionProc, tcmdPtr, CommandObjTraceDeleted); @@ -1934,16 +1932,16 @@ } if (flags & TCL_TRACE_DESTROYED) { if (tcmdPtr->stepTrace != NULL) { Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; - Tcl_Free(tcmdPtr->startCmd); + ckfree(tcmdPtr->startCmd); } } if (call) { if (tcmdPtr->refCount-- <= 1) { - Tcl_Free(tcmdPtr); + ckfree(tcmdPtr); } } return traceCode; } @@ -1990,18 +1988,18 @@ */ result = NULL; if ((tvarPtr->flags & flags) && !Tcl_InterpDeleted(interp) && !Tcl_LimitExceeded(interp)) { - if (tvarPtr->length) { + if (tvarPtr->length != (size_t) 0) { /* * Generate a command to execute by appending list elements for * the two variable names and the operation. */ Tcl_DStringInit(&cmd); - Tcl_DStringAppend(&cmd, tvarPtr->command, tvarPtr->length); + Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length); Tcl_DStringAppendElement(&cmd, name1); Tcl_DStringAppendElement(&cmd, (name2 ? name2 : "")); #ifndef TCL_REMOVE_OBSOLETE_TRACES if (tvarPtr->flags & TCL_TRACE_OLD_STYLE) { if (flags & TCL_TRACE_ARRAY) { @@ -2064,11 +2062,11 @@ } Tcl_DStringFree(&cmd); } } if (destroy && result != NULL) { - register Tcl_Obj *errMsgObj = (Tcl_Obj *) result; + Tcl_Obj *errMsgObj = (Tcl_Obj *) result; Tcl_DecrRefCount(errMsgObj); result = NULL; } return result; @@ -2141,12 +2139,12 @@ Tcl_CmdObjTraceProc *proc, /* Trace callback */ ClientData clientData, /* Client data for the callback */ Tcl_CmdObjTraceDeleteProc *delProc) /* Function to call when trace is deleted */ { - register Trace *tracePtr; - register Interp *iPtr = (Interp *) interp; + Trace *tracePtr; + Interp *iPtr = (Interp *) interp; /* * Test if this trace allows inline compilation of commands. */ @@ -2166,11 +2164,11 @@ iPtr->flags |= DONT_COMPILE_CMDS_INLINE; } iPtr->tracesForbiddingInline++; } - tracePtr = Tcl_Alloc(sizeof(Trace)); + tracePtr = ckalloc(sizeof(Trace)); tracePtr->level = level; tracePtr->proc = proc; tracePtr->clientData = clientData; tracePtr->delProc = delProc; tracePtr->nextPtr = iPtr->tracePtr; @@ -2229,11 +2227,11 @@ * level<=argument level (1=>top level). */ Tcl_CmdTraceProc *proc, /* Function to call before executing each * command. */ ClientData clientData) /* Arbitrary value word to pass to proc. */ { - StringTraceData *data = Tcl_Alloc(sizeof(StringTraceData)); + StringTraceData *data = ckalloc(sizeof(StringTraceData)); data->clientData = clientData; data->proc = proc; return Tcl_CreateObjTrace(interp, level, 0, StringTraceProc, data, StringTraceDeleteProc); @@ -2274,13 +2272,13 @@ * This is a bit messy because we have to emulate the old trace interface, * which uses strings for everything. */ argv = (const char **) TclStackAlloc(interp, - (objc + 1) * sizeof(const char *)); + (unsigned) ((objc + 1) * sizeof(const char *))); for (i = 0; i < objc; i++) { - argv[i] = TclGetString(objv[i]); + argv[i] = Tcl_GetString(objv[i]); } argv[objc] = 0; /* * Invoke the command function. Note that we cast away const-ness on two @@ -2313,11 +2311,11 @@ static void StringTraceDeleteProc( ClientData clientData) { - Tcl_Free(clientData); + ckfree(clientData); } /* *---------------------------------------------------------------------- * @@ -2341,11 +2339,11 @@ Tcl_Trace trace) /* Token for trace (returned previously by * Tcl_CreateTrace). */ { Interp *iPtr = (Interp *) interp; Trace *prevPtr, *tracePtr = (Trace *) trace; - register Trace **tracePtr2 = &iPtr->tracePtr; + Trace **tracePtr2 = &iPtr->tracePtr; ActiveInterpTrace *activePtr; /* * Locate the trace entry in the interpreter's trace list, and remove it * from the list. @@ -2533,11 +2531,11 @@ */ int TclObjCallVarTraces( Interp *iPtr, /* Interpreter containing variable. */ - register Var *arrayPtr, /* Pointer to array variable that contains the + Var *arrayPtr, /* Pointer to array variable that contains the * variable, or NULL if the variable isn't an * element of an array. */ Var *varPtr, /* Variable whose traces are to be invoked. */ Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, /* Variable's two-part name. */ @@ -2567,11 +2565,11 @@ } int TclCallVarTraces( Interp *iPtr, /* Interpreter containing variable. */ - register Var *arrayPtr, /* Pointer to array variable that contains the + Var *arrayPtr, /* Pointer to array variable that contains the * variable, or NULL if the variable isn't an * element of an array. */ Var *varPtr, /* Variable whose traces are to be invoked. */ const char *part1, const char *part2, /* Variable's two-part name. */ @@ -2580,11 +2578,11 @@ * TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY */ int leaveErrMsg) /* If true, and one of the traces indicates an * error, then leave an error message and * stack trace information in *iPTr. */ { - register VarTrace *tracePtr; + VarTrace *tracePtr; ActiveVarTrace active; char *result; const char *openParen, *p; Tcl_DString nameCopy; int copiedName; @@ -2779,11 +2777,11 @@ "\n (%s trace on \"%s%s%s%s\")", type, part1, (part2 ? "(" : ""), (part2 ? part2 : ""), (part2 ? ")" : "") )); if (disposeFlags & TCL_TRACE_RESULT_OBJECT) { TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, verb, - TclGetString((Tcl_Obj *) result)); + Tcl_GetString((Tcl_Obj *) result)); } else { TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, verb, result); } iPtr->flags &= ~(ERR_ALREADY_LOGGED); Tcl_DiscardInterpState(state); @@ -2838,15 +2836,48 @@ * proper disposal method. */ char *result) /* The result returned from a trace function * to be disposed. */ { if (flags & TCL_TRACE_RESULT_DYNAMIC) { - Tcl_Free(result); + ckfree(result); } else if (flags & TCL_TRACE_RESULT_OBJECT) { Tcl_DecrRefCount((Tcl_Obj *) result); } } + +/* + *---------------------------------------------------------------------- + * + * Tcl_UntraceVar -- + * + * Remove a previously-created trace for a variable. + * + * Results: + * None. + * + * Side effects: + * If there exists a trace for the variable given by varName with the + * given flags, proc, and clientData, then that trace is removed. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_UntraceVar +void +Tcl_UntraceVar( + Tcl_Interp *interp, /* Interpreter containing variable. */ + const char *varName, /* Name of variable; may end with "(index)" to + * signify an array reference. */ + int flags, /* OR-ed collection of bits describing current + * trace, including any of TCL_TRACE_READS, + * TCL_TRACE_WRITES, TCL_TRACE_UNSETS, + * TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY. */ + Tcl_VarTraceProc *proc, /* Function assocated with trace. */ + ClientData clientData) /* Arbitrary argument to pass to proc. */ +{ + Tcl_UntraceVar2(interp, varName, NULL, flags, proc, clientData); +} /* *---------------------------------------------------------------------- * * Tcl_UntraceVar2 -- @@ -2875,11 +2906,11 @@ * TCL_TRACE_WRITES, TCL_TRACE_UNSETS, * TCL_GLOBAL_ONLY, and TCL_NAMESPACE_ONLY. */ Tcl_VarTraceProc *proc, /* Function assocated with trace. */ ClientData clientData) /* Arbitrary argument to pass to proc. */ { - register VarTrace *tracePtr; + VarTrace *tracePtr; VarTrace *prevPtr, *nextPtr; Var *varPtr, *arrayPtr; Interp *iPtr = (Interp *) interp; ActiveVarTrace *activePtr; int flagMask, allFlags = 0; @@ -2977,10 +3008,51 @@ } /* *---------------------------------------------------------------------- * + * Tcl_VarTraceInfo -- + * + * Return the clientData value associated with a trace on a variable. + * This function can also be used to step through all of the traces on a + * particular variable that have the same trace function. + * + * Results: + * The return value is the clientData value associated with a trace on + * the given variable. Information will only be returned for a trace with + * proc as trace function. If the clientData argument is NULL then the + * first such trace is returned; otherwise, the next relevant one after + * the one given by clientData will be returned. If the variable doesn't + * exist, or if there are no (more) traces for it, then NULL is returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_VarTraceInfo +ClientData +Tcl_VarTraceInfo( + Tcl_Interp *interp, /* Interpreter containing variable. */ + const char *varName, /* Name of variable; may end with "(index)" to + * signify an array reference. */ + int flags, /* OR-ed combo or TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY (can be 0). */ + Tcl_VarTraceProc *proc, /* Function assocated with trace. */ + ClientData prevClientData) /* If non-NULL, gives last value returned by + * this function, so this call will return the + * next trace after that one. If NULL, this + * call will return the first trace. */ +{ + return Tcl_VarTraceInfo2(interp, varName, NULL, flags, proc, + prevClientData); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_VarTraceInfo2 -- * * Same as Tcl_VarTraceInfo, except takes name in two pieces instead of * one. * @@ -3024,11 +3096,11 @@ */ hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr); if (hPtr) { - register VarTrace *tracePtr = Tcl_GetHashValue(hPtr); + VarTrace *tracePtr = Tcl_GetHashValue(hPtr); if (prevClientData != NULL) { for (; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { if ((tracePtr->clientData == prevClientData) && (tracePtr->traceProc == proc)) { @@ -3043,10 +3115,49 @@ } } } return NULL; } + +/* + *---------------------------------------------------------------------- + * + * Tcl_TraceVar -- + * + * Arrange for reads and/or writes to a variable to cause a function to + * be invoked, which can monitor the operations and/or change their + * actions. + * + * Results: + * A standard Tcl return value. + * + * Side effects: + * A trace is set up on the variable given by varName, such that future + * references to the variable will be intermediated by proc. See the + * manual entry for complete details on the calling sequence for proc. + * The variable's flags are updated. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_TraceVar +int +Tcl_TraceVar( + Tcl_Interp *interp, /* Interpreter in which variable is to be + * traced. */ + const char *varName, /* Name of variable; may end with "(index)" to + * signify an array reference. */ + int flags, /* OR-ed collection of bits, including any of + * TCL_TRACE_READS, TCL_TRACE_WRITES, + * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and + * TCL_NAMESPACE_ONLY. */ + Tcl_VarTraceProc *proc, /* Function to call when specified ops are + * invoked upon varName. */ + ClientData clientData) /* Arbitrary argument to pass to proc. */ +{ + return Tcl_TraceVar2(interp, varName, NULL, flags, proc, clientData); +} /* *---------------------------------------------------------------------- * * Tcl_TraceVar2 -- @@ -3081,22 +3192,22 @@ * TCL_NAMESPACE_ONLY. */ Tcl_VarTraceProc *proc, /* Function to call when specified ops are * invoked upon varName. */ ClientData clientData) /* Arbitrary argument to pass to proc. */ { - register VarTrace *tracePtr; + VarTrace *tracePtr; int result; - tracePtr = Tcl_Alloc(sizeof(VarTrace)); + tracePtr = ckalloc(sizeof(VarTrace)); tracePtr->traceProc = proc; tracePtr->clientData = clientData; tracePtr->flags = flags; result = TraceVarEx(interp, part1, part2, tracePtr); if (result != TCL_OK) { - Tcl_Free(tracePtr); + ckfree(tracePtr); } return result; } /* @@ -3126,13 +3237,13 @@ * traced. */ const char *part1, /* Name of scalar variable or array. */ const char *part2, /* Name of element within array; NULL means * trace applies to scalar variable or array * as-a-whole. */ - register VarTrace *tracePtr)/* Structure containing flags, traceProc and + VarTrace *tracePtr)/* Structure containing flags, traceProc and * clientData fields. Others should be left - * blank. Will be Tcl_Free()d (eventually) if + * blank. Will be ckfree()d (eventually) if * this function returns TCL_OK, and up to * caller to free if this function returns * TCL_ERROR. */ { Interp *iPtr = (Interp *) interp; Index: generic/tclUniData.c ================================================================== --- generic/tclUniData.c +++ generic/tclUniData.c @@ -39,26 +39,26 @@ 3968, 1344, 4000, 1344, 4032, 4064, 4096, 4128, 4128, 4160, 4192, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 4224, 4256, 1344, 1344, 4288, 4320, 4352, 4384, 4416, 1344, 4448, 4480, 4512, 4544, 1344, 4576, 4608, 4640, 4672, 1344, 4704, 4736, 4768, 4800, 4832, 1344, 4864, 4896, 4928, 4960, 1344, - 4992, 5024, 5056, 5088, 1824, 1824, 5120, 5152, 5184, 5216, 5248, 5280, - 1344, 5312, 1344, 5344, 5376, 5408, 5440, 5472, 5504, 5536, 5568, 5600, - 5632, 5664, 5696, 5632, 704, 5728, 224, 224, 224, 224, 5760, 224, 224, - 224, 5792, 5824, 5856, 5888, 5920, 5952, 5984, 6016, 6048, 6080, 6112, - 6144, 6176, 6208, 6240, 6272, 6304, 6336, 6368, 6400, 6432, 6464, 6496, - 6528, 6560, 6560, 6560, 6560, 6560, 6560, 6560, 6560, 6592, 6624, 4928, - 6656, 6688, 6720, 6752, 6784, 4928, 6816, 6848, 6880, 6912, 6944, 6976, - 7008, 4928, 4928, 4928, 4928, 4928, 7040, 7072, 7104, 4928, 4928, 4928, - 7136, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 7168, 7200, 4928, 7232, - 7264, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 6560, 6560, 6560, - 6560, 7296, 6560, 7328, 7360, 6560, 6560, 6560, 6560, 6560, 6560, 6560, - 6560, 4928, 7392, 7424, 7456, 7488, 4928, 4928, 4928, 7520, 7552, 7584, - 7616, 224, 224, 224, 7648, 7680, 7712, 1344, 7744, 7776, 7808, 7808, - 704, 7840, 7872, 7904, 1824, 7936, 4928, 4928, 7968, 4928, 4928, 4928, - 4928, 4928, 4928, 8000, 8032, 8064, 8096, 3232, 1344, 8128, 4192, 1344, - 8160, 8192, 8224, 1344, 1344, 8256, 8288, 4928, 8320, 8352, 8384, 8416, + 4992, 5024, 5056, 5088, 5120, 1824, 5152, 5184, 5216, 5248, 5280, 5312, + 1344, 5344, 1344, 5376, 5408, 5440, 5472, 5504, 5536, 5568, 5600, 5632, + 5664, 5696, 5728, 5664, 704, 5760, 224, 224, 224, 224, 5792, 224, 224, + 224, 5824, 5856, 5888, 5920, 5952, 5984, 6016, 6048, 6080, 6112, 6144, + 6176, 6208, 6240, 6272, 6304, 6336, 6368, 6400, 6432, 6464, 6496, 6528, + 6560, 6592, 6592, 6592, 6592, 6592, 6592, 6592, 6592, 6624, 6656, 4928, + 6688, 6720, 6752, 6784, 6816, 4928, 6848, 6880, 6912, 6944, 6976, 7008, + 7040, 4928, 4928, 4928, 4928, 4928, 7072, 7104, 7136, 4928, 4928, 4928, + 7168, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 7200, 7232, 4928, 7264, + 7296, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 6592, 6592, 6592, + 6592, 7328, 6592, 7360, 7392, 6592, 6592, 6592, 6592, 6592, 6592, 6592, + 6592, 4928, 7424, 7456, 7488, 7520, 4928, 4928, 4928, 7552, 7584, 7616, + 7648, 224, 224, 224, 7680, 7712, 7744, 1344, 7776, 7808, 7840, 7840, + 704, 7872, 7904, 7936, 1824, 7968, 4928, 4928, 8000, 4928, 4928, 4928, + 4928, 4928, 4928, 8032, 8064, 8096, 8128, 3232, 1344, 8160, 4192, 1344, + 8192, 8224, 8256, 1344, 1344, 8288, 1344, 4928, 8320, 8352, 8384, 8416, 4928, 8384, 8448, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, @@ -73,11 +73,11 @@ 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 4704, 4928, 4928, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 4928, 4928, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, @@ -131,16 +131,16 @@ 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 8480, 8512, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 8544, 4928, 8576, 5408, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 8544, 4928, 8576, 5440, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 8608, 8640, 224, 8672, 8704, 1344, 1344, 8736, 8768, 8800, 224, 8832, 8864, 8896, 8928, 8960, 8992, 9024, 1344, 9056, 9088, 9120, 9152, - 9184, 1632, 9216, 9248, 9280, 1952, 9312, 9344, 9376, 1344, 9408, 9440, - 9472, 1344, 9504, 9536, 9568, 9600, 9632, 9664, 9696, 9728, 9728, 1344, - 9760, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 9184, 1632, 9216, 9248, 8480, 1952, 9280, 9312, 9344, 1344, 9376, 9408, + 9440, 1344, 9472, 9504, 9536, 9568, 9600, 9632, 9664, 9696, 9696, 1344, + 9728, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, @@ -165,216 +165,387 @@ 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 9792, 9824, 9856, 9888, 9888, 9888, 9888, 9888, 9888, 9888, + 1344, 1344, 9760, 9792, 9824, 9856, 9856, 9856, 9856, 9856, 9856, 9856, + 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, + 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, + 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, + 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, + 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9888, 9888, 9888, + 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, + 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, + 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, + 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, + 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, + 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, + 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, + 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, + 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, + 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, + 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, + 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, - 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9920, 9920, 9920, - 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, - 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, - 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, - 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, - 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, - 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, - 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, - 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, - 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, - 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, - 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, - 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, - 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, - 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, - 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, - 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, - 9920, 9920, 9920, 9920, 9920, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 9952, 1344, 1344, 9984, 1824, 10016, 10048, - 10080, 1344, 1344, 10112, 10144, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 10176, 10208, 1344, 10240, 1344, 10272, 10304, - 10336, 10368, 10400, 10432, 1344, 1344, 1344, 10464, 10496, 64, 10528, - 10560, 10592, 4736, 10624, 10656 -#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6 - ,10688, 10720, 10752, 1824, 1344, 1344, 1344, 8288, 10784, 10816, 10848, - 10880, 10912, 10944, 10976, 11008, 1824, 1824, 1824, 1824, 9280, 1344, - 11040, 11072, 1344, 11104, 11136, 11168, 11200, 1344, 11232, 1824, - 11264, 11296, 11328, 1344, 11360, 11392, 11424, 11456, 1344, 11488, - 1344, 11520, 1824, 1824, 1824, 1824, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 7776, 4704, 10272, 1824, 1824, 1824, 1824, - 11552, 11584, 11616, 11648, 4736, 11680, 1824, 11712, 11744, 11776, - 1824, 1824, 1344, 11808, 11840, 6880, 11872, 11904, 11936, 11968, 12000, - 1824, 12032, 12064, 1344, 12096, 12128, 12160, 12192, 12224, 1824, - 1824, 1344, 1344, 12256, 1824, 12288, 12320, 12352, 12384, 1344, 12416, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 12448, 1824, - 1824, 1824, 1824, 12000, 12480, 12512, 1824, 1824, 1824, 1824, 7776, - 12544, 12576, 12608, 12640, 5248, 12672, 12704, 12736, 12768, 12800, - 12832, 12864, 5248, 12896, 12928, 12960, 12992, 13024, 1824, 1824, - 13056, 13088, 13120, 13152, 13184, 13216, 13248, 13280, 1824, 1824, - 1824, 1824, 1344, 13312, 13344, 1824, 1344, 13376, 13408, 1824, 1824, - 1824, 1824, 1824, 1344, 13440, 13472, 1824, 1344, 13504, 13536, 13568, - 1344, 13600, 13632, 1824, 4032, 13664, 1824, 1824, 1824, 1824, 1824, - 1824, 1344, 13696, 1824, 1824, 1824, 13728, 13760, 13792, 1824, 1824, - 1824, 1824, 1824, 13824, 13856, 13888, 13920, 13952, 13984, 1344, 14016, - 14048, 1344, 4608, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 14080, 14112, 14144, 14176, 14208, 14240, 1824, 1824, 14272, 14304, - 14336, 14368, 14400, 13632, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 14432, 1824, 1824, 1824, 1824, 1824, 1824, 14464, 14496, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 9984, 1824, 1824, 1824, 10848, 10848, 10848, - 14528, 1344, 1344, 1344, 1344, 1344, 1344, 14560, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 14592, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 14624, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 4608, 4736, 14656, - 1824, 1824, 10208, 14688, 1344, 14720, 14752, 14784, 8480, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 13728, 13760, 14816, 1824, - 1824, 1824, 1344, 1344, 14848, 14880, 14912, 1824, 1824, 14944, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 14976, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 15008, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 4736, 1824, 15040, 15072, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 9856, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1344, 1344, 1344, - 15104, 15136, 15168, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 8000, 4928, 15200, - 4928, 15232, 15264, 15296, 4928, 15328, 4928, 4928, 15360, 1824, 1824, - 1824, 1824, 15392, 4928, 4928, 15424, 15456, 1824, 1824, 1824, 1824, - 15488, 15520, 15552, 15584, 15616, 15648, 15680, 15712, 15744, 15776, - 15808, 15840, 15872, 15488, 15520, 15904, 15584, 15936, 15968, 16000, - 15712, 16032, 16064, 16096, 16128, 16160, 16192, 16224, 16256, 16288, - 16320, 16352, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, - 4928, 4928, 4928, 4928, 4928, 4928, 4928, 704, 16384, 704, 16416, 16448, - 16480, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 16512, 16544, 1824, - 1824, 1824, 1824, 1824, 1824, 1344, 16576, 16608, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1344, 16640, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1344, 1344, 1344, 1344, 1344, 1344, 16672, 1824, - 16704, 16736, 16768, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 16800, 6880, 16832, 1824, 1824, 16864, 16896, - 1824, 1824, 1824, 1824, 1824, 1824, 16928, 16960, 16992, 17024, 17056, - 17088, 1824, 17120, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 4928, 17152, 4928, 4928, 7968, 17184, 17216, 8000, 17248, 4928, 4928, - 17280, 4928, 17312, 1824, 17344, 17376, 17408, 17440, 17472, 1824, - 1824, 1824, 1824, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 17504, - 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, - 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 8000, 17536, - 4928, 4928, 4928, 7968, 4928, 4928, 17568, 17600, 17152, 4928, 17632, - 4928, 17664, 17696, 1824, 1824, 17728, 4928, 4928, 17760, 4928, 17792, - 17824, 4928, 4928, 4928, 7968, 17856, 17888, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 9888, 9888, 9888, 9888, 9888, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 9920, 1344, 1344, 9952, 1824, 9984, 10016, + 10048, 1344, 1344, 10080, 10112, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 10144, 10176, 1344, 10208, 1344, 10240, 10272, + 10304, 10336, 10368, 10400, 1344, 1344, 1344, 10432, 10464, 64, 10496, + 10528, 10560, 4736, 10592, 10624 +#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6 + ,10656, 10688, 10720, 1824, 1344, 1344, 1344, 10752, 10784, 10816, + 10848, 10880, 10912, 10944, 10976, 11008, 1824, 1824, 1824, 1824, 8480, + 1344, 11040, 11072, 1344, 11104, 11136, 11168, 11200, 1344, 11232, + 1824, 11264, 11296, 11328, 1344, 11360, 11392, 11424, 11456, 1344, + 11488, 1344, 11520, 1824, 1824, 1824, 1824, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 7808, 4704, 10240, 1824, 1824, 1824, + 1824, 11552, 11584, 11616, 11648, 4736, 11680, 1824, 11712, 11744, + 11776, 1824, 1824, 1344, 11808, 11840, 6912, 11872, 11904, 11936, 11968, + 12000, 1824, 12032, 12064, 1344, 12096, 12128, 12160, 12192, 12224, + 1824, 1824, 1344, 1344, 12256, 1824, 12288, 12320, 12352, 12384, 1344, + 12416, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 12448, + 1344, 12480, 1824, 1824, 12000, 12512, 12544, 1824, 1824, 10176, 12576, + 7808, 12608, 12640, 12672, 12704, 5280, 12736, 12768, 12800, 12832, + 12864, 12896, 12928, 5280, 12960, 12992, 13024, 13056, 13088, 1824, + 1824, 13120, 13152, 13184, 13216, 13248, 13280, 13312, 13344, 1824, + 1824, 1824, 1824, 1344, 13376, 13408, 13440, 1344, 13472, 13504, 1824, + 1824, 1824, 1824, 1824, 1344, 13536, 13568, 1824, 1344, 13600, 13632, + 13664, 1344, 13696, 13728, 1824, 4032, 13760, 1824, 1824, 1824, 1824, + 1824, 1824, 1344, 13792, 1824, 1824, 1824, 13824, 13856, 13888, 13920, + 13952, 13984, 1824, 1824, 14016, 14048, 14080, 14112, 14144, 14176, + 1344, 14208, 14240, 1344, 4608, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 14272, 14304, 14336, 14368, 14400, 14432, 1824, 1824, 14464, + 14496, 14528, 14560, 14592, 13728, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 14624, 1824, 1824, 1824, 1824, 1824, 14656, 14688, + 14720, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 9952, 1824, 1824, 1824, 10848, + 10848, 10848, 14752, 1344, 1344, 1344, 1344, 1344, 1344, 14784, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 14816, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 14848, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 4608, 4736, + 14880, 1824, 1824, 10176, 14912, 1344, 14944, 14976, 15008, 15040, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 13824, 13856, + 15072, 1824, 1824, 1824, 1344, 1344, 15104, 15136, 15168, 1824, 1824, + 15200, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 15232, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 4704, 1824, 12256, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 4736, 1824, 15264, + 15296, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 9824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1344, 1344, 1344, 15328, 15360, 15392, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 4928, 4928, 4928, 4928, 4928, + 4928, 4928, 8032, 4928, 15424, 4928, 15456, 15488, 15520, 4928, 15552, + 4928, 4928, 15584, 1824, 1824, 1824, 1824, 15616, 4928, 4928, 15648, + 15680, 1824, 1824, 1824, 1824, 15712, 15744, 15776, 15808, 15840, 15872, + 15904, 15936, 15968, 16000, 16032, 16064, 16096, 15712, 15744, 16128, + 15808, 16160, 16192, 16224, 15936, 16256, 16288, 16320, 16352, 16384, + 16416, 16448, 16480, 16512, 16544, 16576, 4928, 4928, 4928, 4928, 4928, + 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 704, + 16608, 704, 16640, 16672, 16704, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 16736, 16768, 1824, 1824, 1824, 1824, 1824, 1824, 1344, 16800, 16832, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1344, + 16864, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1344, 1344, 1344, 1344, 1344, 1344, + 16896, 1824, 16928, 16960, 16992, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 17024, 6912, 17056, 1824, 1824, + 17088, 17120, 1824, 1824, 1824, 1824, 1824, 1824, 17152, 17184, 17216, + 17248, 17280, 17312, 1824, 17344, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 4928, 17376, 4928, 4928, 8000, 17408, 17440, 8032, 17472, + 4928, 4928, 4928, 4928, 17504, 1824, 17536, 17568, 17600, 17632, 17664, + 1824, 1824, 1824, 1824, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 17696, + 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, + 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 17728, + 17760, 4928, 4928, 4928, 8000, 4928, 4928, 17792, 17824, 17376, 4928, + 17856, 4928, 17888, 17920, 1824, 1824, 4928, 4928, 4928, 17952, 4928, + 4928, 17984, 4928, 4928, 4928, 8000, 18016, 18048, 18080, 18112, 1824, + 4928, 4928, 4928, 4928, 18144, 4928, 6880, 18176, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 11360, 1824, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 18208, 1344, 1344, 1344, + 1344, 1344, 1344, 11360, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 18240, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 18272, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 11360, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, @@ -383,165 +554,11 @@ 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 7776, 1824, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 17920, 1344, 1344, 1344, 1344, 1344, 1344, - 11360, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 17952, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 17984, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, - 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 11360 + 1344, 1344, 1344, 1344, 1344, 1792 #endif /* TCL_UTF_MAX > 3 */ }; /* * The groupMap is indexed by combining the alternate page number with @@ -656,111 +673,111 @@ 15, 93, 93, 93, 0, 0, 3, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, - 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 17, - 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, - 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 125, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 93, 125, 93, 15, 125, 125, 125, 93, 93, 93, 93, 93, 93, 93, - 93, 125, 125, 125, 125, 93, 125, 125, 15, 93, 93, 93, 93, 93, 93, 93, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 3, 3, 9, 9, 9, 9, 9, - 9, 9, 9, 9, 9, 3, 92, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 93, 125, 125, 0, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, - 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, - 0, 0, 0, 15, 15, 15, 15, 0, 0, 93, 15, 125, 125, 125, 93, 93, 93, 93, - 0, 0, 125, 125, 0, 0, 125, 125, 93, 15, 0, 0, 0, 0, 0, 0, 0, 0, 125, - 0, 0, 0, 0, 15, 15, 0, 15, 15, 15, 93, 93, 0, 0, 9, 9, 9, 9, 9, 9, - 9, 9, 9, 9, 15, 15, 4, 4, 18, 18, 18, 18, 18, 18, 14, 4, 15, 3, 93, - 0, 0, 93, 93, 125, 0, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 15, 15, 0, - 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, - 15, 15, 0, 15, 15, 0, 0, 93, 0, 125, 125, 125, 93, 93, 0, 0, 0, 0, - 93, 93, 0, 0, 93, 93, 93, 0, 0, 0, 93, 0, 0, 0, 0, 0, 0, 0, 15, 15, - 15, 15, 0, 15, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 93, - 93, 15, 15, 15, 93, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 93, 93, 125, 0, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 0, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 15, 15, 15, 15, 15, - 0, 0, 93, 15, 125, 125, 125, 93, 93, 93, 93, 93, 0, 93, 93, 125, 0, - 125, 125, 93, 0, 0, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 15, 15, 93, 93, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 4, 0, 0, 0, - 0, 0, 0, 0, 15, 93, 93, 93, 93, 93, 93, 0, 93, 125, 125, 0, 15, 15, - 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, - 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 15, 15, 15, 15, 15, 0, 0, - 93, 15, 125, 93, 125, 93, 93, 93, 93, 0, 0, 125, 125, 0, 0, 125, 125, - 93, 0, 0, 0, 0, 0, 0, 0, 0, 93, 125, 0, 0, 0, 0, 15, 15, 0, 15, 15, - 15, 93, 93, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 14, 15, 18, 18, 18, - 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 93, 15, 0, 15, 15, 15, 15, - 15, 15, 0, 0, 0, 15, 15, 15, 0, 15, 15, 15, 15, 0, 0, 0, 15, 15, 0, - 15, 0, 15, 15, 0, 0, 0, 15, 15, 0, 0, 0, 15, 15, 15, 0, 0, 0, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 125, 125, 93, 125, - 125, 0, 0, 0, 125, 125, 125, 0, 125, 125, 125, 93, 0, 0, 15, 0, 0, - 0, 0, 0, 0, 125, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, - 9, 9, 9, 9, 9, 9, 9, 18, 18, 18, 14, 14, 14, 14, 14, 14, 4, 14, 0, - 0, 0, 0, 0, 93, 125, 125, 125, 93, 15, 15, 15, 15, 15, 15, 15, 15, - 0, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 15, 93, 93, 93, 125, - 125, 125, 125, 0, 93, 93, 93, 0, 93, 93, 93, 93, 0, 0, 0, 0, 0, 0, - 0, 93, 93, 0, 15, 15, 15, 0, 0, 0, 0, 0, 15, 15, 93, 93, 0, 0, 9, 9, - 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 3, 18, 18, 18, 18, 18, - 18, 18, 14, 15, 93, 125, 125, 3, 15, 15, 15, 15, 15, 15, 15, 15, 0, - 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 0, 0, 93, 15, 125, 93, 125, - 125, 125, 125, 125, 0, 93, 125, 125, 0, 125, 125, 93, 93, 0, 0, 0, - 0, 0, 0, 0, 125, 125, 0, 0, 0, 0, 0, 0, 0, 15, 0, 15, 15, 93, 93, 0, - 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 93, 93, 125, 125, 0, 15, 15, 15, 15, 15, 15, 15, 15, - 0, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 15, 125, 125, 125, - 93, 93, 93, 93, 0, 125, 125, 125, 0, 125, 125, 125, 93, 15, 14, 0, - 0, 0, 0, 15, 15, 15, 125, 18, 18, 18, 18, 18, 18, 18, 15, 15, 15, 93, - 93, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 14, 15, 15, 15, 15, 15, 15, 0, 0, 125, 125, 0, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 0, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 93, 0, 0, 0, 0, 125, - 125, 125, 93, 93, 93, 0, 93, 0, 125, 125, 125, 125, 125, 125, 125, - 125, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 125, 125, - 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 93, 15, 15, 93, 93, 93, 93, 93, 93, 93, - 0, 0, 0, 0, 4, 15, 15, 15, 15, 15, 15, 92, 93, 93, 93, 93, 93, 93, - 93, 93, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 0, 0, 0, 0, 0, 15, 15, - 0, 15, 0, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, - 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 15, 15, 93, 93, 93, - 93, 93, 93, 93, 93, 93, 15, 0, 0, 15, 15, 15, 15, 15, 0, 92, 0, 93, - 93, 93, 93, 93, 93, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 15, 15, - 15, 15, 15, 14, 14, 14, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, - 14, 3, 14, 14, 14, 93, 93, 14, 14, 14, 14, 14, 14, 9, 9, 9, 9, 9, 9, - 9, 9, 9, 9, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 14, 93, 14, 93, - 14, 93, 5, 6, 5, 6, 125, 125, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 0, 0, 0, 0, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, - 93, 125, 93, 93, 93, 93, 93, 3, 93, 93, 15, 15, 15, 15, 15, 93, 93, - 93, 93, 93, 93, 93, 93, 93, 93, 93, 0, 93, 93, 93, 93, 93, 93, 93, - 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, - 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 0, 14, 14, 14, 14, - 14, 14, 14, 14, 93, 14, 14, 14, 14, 14, 14, 0, 14, 14, 3, 3, 3, 3, - 3, 14, 14, 14, 14, 3, 3, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 125, 125, 93, 93, 93, 93, 125, 93, 93, 93, 93, 93, - 93, 125, 93, 93, 125, 125, 93, 93, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, - 3, 3, 3, 3, 3, 3, 15, 15, 15, 15, 15, 15, 125, 125, 93, 93, 15, 15, - 15, 15, 93, 93, 93, 15, 125, 125, 125, 15, 15, 125, 125, 125, 125, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, + 93, 93, 17, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, + 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, + 93, 125, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 93, 125, 93, 15, 125, 125, 125, 93, 93, 93, 93, + 93, 93, 93, 93, 125, 125, 125, 125, 93, 125, 125, 15, 93, 93, 93, 93, + 93, 93, 93, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 3, 3, 9, + 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 92, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 93, 125, 125, 0, 15, 15, 15, 15, 15, 15, 15, + 15, 0, 0, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, + 15, 15, 0, 15, 0, 0, 0, 15, 15, 15, 15, 0, 0, 93, 15, 125, 125, 125, + 93, 93, 93, 93, 0, 0, 125, 125, 0, 0, 125, 125, 93, 15, 0, 0, 0, 0, + 0, 0, 0, 0, 125, 0, 0, 0, 0, 15, 15, 0, 15, 15, 15, 93, 93, 0, 0, 9, + 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 4, 4, 18, 18, 18, 18, 18, 18, 14, + 4, 15, 3, 93, 0, 0, 93, 93, 125, 0, 15, 15, 15, 15, 15, 15, 0, 0, 0, + 0, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, + 0, 15, 15, 0, 15, 15, 0, 15, 15, 0, 0, 93, 0, 125, 125, 125, 93, 93, + 0, 0, 0, 0, 93, 93, 0, 0, 93, 93, 93, 0, 0, 0, 93, 0, 0, 0, 0, 0, 0, + 0, 15, 15, 15, 15, 0, 15, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, + 9, 9, 9, 93, 93, 15, 15, 15, 93, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 93, + 93, 125, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 0, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 15, 15, + 15, 15, 15, 0, 0, 93, 15, 125, 125, 125, 93, 93, 93, 93, 93, 0, 93, + 93, 125, 0, 125, 125, 93, 0, 0, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 15, 15, 93, 93, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, + 4, 0, 0, 0, 0, 0, 0, 0, 15, 93, 93, 93, 93, 93, 93, 0, 93, 125, 125, + 0, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 0, 0, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 15, 15, 15, 15, + 15, 0, 0, 93, 15, 125, 93, 125, 93, 93, 93, 93, 0, 0, 125, 125, 0, + 0, 125, 125, 93, 0, 0, 0, 0, 0, 0, 0, 93, 93, 125, 0, 0, 0, 0, 15, + 15, 0, 15, 15, 15, 93, 93, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 14, + 15, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 93, 15, 0, + 15, 15, 15, 15, 15, 15, 0, 0, 0, 15, 15, 15, 0, 15, 15, 15, 15, 0, + 0, 0, 15, 15, 0, 15, 0, 15, 15, 0, 0, 0, 15, 15, 0, 0, 0, 15, 15, 15, + 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, + 125, 125, 93, 125, 125, 0, 0, 0, 125, 125, 125, 0, 125, 125, 125, 93, + 0, 0, 15, 0, 0, 0, 0, 0, 0, 125, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, 18, 18, 14, 14, 14, 14, 14, + 14, 4, 14, 0, 0, 0, 0, 0, 93, 125, 125, 125, 93, 15, 15, 15, 15, 15, + 15, 15, 15, 0, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 15, 93, + 93, 93, 125, 125, 125, 125, 0, 93, 93, 93, 0, 93, 93, 93, 93, 0, 0, + 0, 0, 0, 0, 0, 93, 93, 0, 15, 15, 15, 0, 0, 0, 0, 0, 15, 15, 93, 93, + 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 3, 18, 18, + 18, 18, 18, 18, 18, 14, 15, 93, 125, 125, 3, 15, 15, 15, 15, 15, 15, + 15, 15, 0, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 0, 0, 93, 15, 125, 93, + 125, 125, 125, 125, 125, 0, 93, 125, 125, 0, 125, 125, 93, 93, 0, 0, + 0, 0, 0, 0, 0, 125, 125, 0, 0, 0, 0, 0, 0, 0, 15, 0, 15, 15, 93, 93, + 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 15, 15, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 93, 93, 125, 125, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 0, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 15, 125, 125, + 125, 93, 93, 93, 93, 0, 125, 125, 125, 0, 125, 125, 125, 93, 15, 14, + 0, 0, 0, 0, 15, 15, 15, 125, 18, 18, 18, 18, 18, 18, 18, 15, 15, 15, + 93, 93, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 14, 15, 15, 15, 15, 15, 15, 0, 93, 125, 125, 0, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, + 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 0, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 93, 0, 0, 0, + 0, 125, 125, 125, 93, 93, 93, 0, 93, 0, 125, 125, 125, 125, 125, 125, + 125, 125, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 125, + 125, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 93, 15, 15, 93, 93, 93, 93, 93, 93, + 93, 0, 0, 0, 0, 4, 15, 15, 15, 15, 15, 15, 92, 93, 93, 93, 93, 93, + 93, 93, 93, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 0, 0, 0, 0, 0, 15, + 15, 0, 15, 0, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, + 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 15, 15, 93, 93, + 93, 93, 93, 93, 93, 93, 93, 15, 0, 0, 15, 15, 15, 15, 15, 0, 92, 0, + 93, 93, 93, 93, 93, 93, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 15, + 15, 15, 15, 15, 14, 14, 14, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 14, 3, 14, 14, 14, 93, 93, 14, 14, 14, 14, 14, 14, 9, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 14, 93, 14, + 93, 14, 93, 5, 6, 5, 6, 125, 125, 15, 15, 15, 15, 15, 15, 15, 15, 0, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 0, 0, 0, 0, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, + 93, 93, 125, 93, 93, 93, 93, 93, 3, 93, 93, 15, 15, 15, 15, 15, 93, + 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 0, 93, 93, 93, 93, 93, 93, + 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, + 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 0, 14, 14, 14, + 14, 14, 14, 14, 14, 93, 14, 14, 14, 14, 14, 14, 0, 14, 14, 3, 3, 3, + 3, 3, 14, 14, 14, 14, 3, 3, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 125, 125, 93, 93, 93, 93, 125, 93, 93, 93, 93, + 93, 93, 125, 93, 93, 125, 125, 93, 93, 15, 9, 9, 9, 9, 9, 9, 9, 9, + 9, 9, 3, 3, 3, 3, 3, 3, 15, 15, 15, 15, 15, 15, 125, 125, 93, 93, 15, + 15, 15, 15, 93, 93, 93, 15, 125, 125, 125, 15, 15, 125, 125, 125, 125, 125, 125, 125, 15, 15, 15, 93, 93, 93, 93, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 125, 125, 93, 93, 125, 125, 125, 125, 125, 125, 93, 15, 125, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 125, 125, 125, 93, 14, 14, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, @@ -836,213 +853,213 @@ 15, 15, 15, 15, 15, 125, 93, 125, 93, 93, 93, 93, 93, 93, 93, 0, 93, 125, 93, 125, 125, 93, 93, 93, 93, 93, 93, 93, 93, 125, 125, 125, 125, 125, 125, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 0, 0, 93, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 92, 3, 3, 3, 3, 3, 3, 0, 0, - 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 120, 0, 93, - 93, 93, 93, 125, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 93, 125, 93, 93, 93, 93, 93, 125, 93, 125, 125, 125, 125, 125, 93, - 125, 125, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, - 9, 9, 9, 9, 3, 3, 3, 3, 3, 3, 3, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 93, 93, 93, 93, 93, 93, 93, 93, 93, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 0, 0, 0, 93, 93, 125, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 125, 93, 93, 93, 93, 125, 125, 93, 93, 125, 93, 93, 93, - 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 93, 125, 93, 93, 125, 125, 125, 93, 125, 93, 93, 93, - 125, 125, 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 15, 15, 15, 15, 125, - 125, 125, 125, 125, 125, 125, 125, 93, 93, 93, 93, 93, 93, 93, 93, - 125, 125, 93, 93, 0, 0, 0, 3, 3, 3, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, - 9, 0, 0, 0, 15, 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 92, 92, 92, 92, 92, 92, 3, 3, 130, - 131, 132, 133, 133, 134, 135, 136, 137, 0, 0, 0, 0, 0, 0, 0, 138, 138, + 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 120, 93, 93, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 93, 93, 93, 93, 125, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 93, 125, 93, 93, 93, 93, 93, 125, 93, 125, + 125, 125, 125, 125, 93, 125, 125, 15, 15, 15, 15, 15, 15, 15, 0, 0, + 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 3, 3, 3, 3, 3, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 93, 93, 93, 93, 93, 93, 93, 93, 93, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 93, 93, 125, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 125, 93, 93, 93, 93, 125, 125, + 93, 93, 125, 93, 93, 93, 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 125, 93, 93, 125, 125, + 125, 93, 125, 93, 93, 93, 125, 125, 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, + 3, 15, 15, 15, 15, 125, 125, 125, 125, 125, 125, 125, 125, 93, 93, + 93, 93, 93, 93, 93, 93, 125, 125, 93, 93, 0, 0, 0, 3, 3, 3, 3, 3, 9, + 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 15, 15, 15, 9, 9, 9, 9, 9, 9, 9, + 9, 9, 9, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 92, 92, + 92, 92, 92, 92, 3, 3, 130, 131, 132, 133, 133, 134, 135, 136, 137, + 0, 0, 0, 0, 0, 0, 0, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, - 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 0, - 0, 138, 138, 138, 3, 3, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 93, - 93, 93, 3, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 125, - 93, 93, 93, 93, 93, 93, 93, 15, 15, 15, 15, 93, 15, 15, 15, 15, 15, - 15, 93, 15, 15, 125, 93, 93, 15, 0, 0, 0, 0, 0, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, + 138, 138, 138, 138, 138, 0, 0, 138, 138, 138, 3, 3, 3, 3, 3, 3, 3, + 3, 0, 0, 0, 0, 0, 0, 0, 0, 93, 93, 93, 3, 93, 93, 93, 93, 93, 93, 93, + 93, 93, 93, 93, 93, 93, 125, 93, 93, 93, 93, 93, 93, 93, 15, 15, 15, + 15, 93, 15, 15, 15, 15, 15, 15, 93, 15, 15, 125, 93, 93, 15, 0, 0, + 0, 0, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 92, 139, 21, 21, - 21, 140, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 141, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 92, 92, 92, - 92, 92, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, - 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 0, 93, 93, 93, 93, 93, - 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, - 24, 23, 24, 23, 24, 21, 21, 21, 21, 21, 142, 21, 21, 143, 21, 144, - 144, 144, 144, 144, 144, 144, 144, 145, 145, 145, 145, 145, 145, 145, - 145, 144, 144, 144, 144, 144, 144, 0, 0, 145, 145, 145, 145, 145, 145, - 0, 0, 144, 144, 144, 144, 144, 144, 144, 144, 145, 145, 145, 145, 145, - 145, 145, 145, 144, 144, 144, 144, 144, 144, 144, 144, 145, 145, 145, - 145, 145, 145, 145, 145, 144, 144, 144, 144, 144, 144, 0, 0, 145, 145, - 145, 145, 145, 145, 0, 0, 21, 144, 21, 144, 21, 144, 21, 144, 0, 145, - 0, 145, 0, 145, 0, 145, 144, 144, 144, 144, 144, 144, 144, 144, 145, - 145, 145, 145, 145, 145, 145, 145, 146, 146, 147, 147, 147, 147, 148, - 148, 149, 149, 150, 150, 151, 151, 0, 0, 144, 144, 144, 144, 144, 144, - 144, 144, 152, 152, 152, 152, 152, 152, 152, 152, 144, 144, 144, 144, - 144, 144, 144, 144, 152, 152, 152, 152, 152, 152, 152, 152, 144, 144, - 144, 144, 144, 144, 144, 144, 152, 152, 152, 152, 152, 152, 152, 152, - 144, 144, 21, 153, 21, 0, 21, 21, 145, 145, 154, 154, 155, 11, 156, - 11, 11, 11, 21, 153, 21, 0, 21, 21, 157, 157, 157, 157, 155, 11, 11, - 11, 144, 144, 21, 21, 0, 0, 21, 21, 145, 145, 158, 158, 0, 11, 11, - 11, 144, 144, 21, 21, 21, 114, 21, 21, 145, 145, 159, 159, 118, 11, - 11, 11, 0, 0, 21, 153, 21, 0, 21, 21, 160, 160, 161, 161, 155, 11, - 11, 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 17, 17, 17, 17, 17, 8, 8, 8, - 8, 8, 8, 3, 3, 16, 20, 5, 16, 16, 20, 5, 16, 3, 3, 3, 3, 3, 3, 3, 3, - 162, 163, 17, 17, 17, 17, 17, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 16, 20, - 3, 3, 3, 3, 12, 12, 3, 3, 3, 7, 5, 6, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, - 3, 7, 3, 12, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 2, 17, 17, 17, 17, 17, 0, - 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 18, 92, 0, 0, 18, 18, 18, 18, - 18, 18, 7, 7, 7, 5, 6, 92, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 7, 7, 7, 5, 6, 0, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, - 0, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, - 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, - 120, 120, 120, 120, 93, 120, 120, 120, 93, 93, 93, 93, 93, 93, 93, - 93, 93, 93, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, - 14, 108, 14, 14, 14, 14, 108, 14, 14, 21, 108, 108, 108, 21, 21, 108, - 108, 108, 21, 14, 108, 14, 14, 7, 108, 108, 108, 108, 108, 14, 14, - 14, 14, 14, 14, 108, 14, 164, 14, 108, 14, 165, 166, 108, 108, 14, - 21, 108, 108, 167, 108, 21, 15, 15, 15, 15, 21, 14, 14, 21, 21, 108, - 108, 7, 7, 7, 7, 7, 108, 21, 21, 21, 21, 14, 7, 14, 14, 168, 14, 18, - 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 169, 169, - 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, - 170, 170, 170, 170, 170, 170, 170, 170, 170, 170, 170, 170, 170, 170, - 170, 170, 129, 129, 129, 23, 24, 129, 129, 129, 129, 18, 14, 14, 0, - 0, 0, 0, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 7, 7, 14, 14, 14, 14, 7, - 14, 14, 7, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 7, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 14, 14, 7, 14, 7, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 7, + 92, 92, 92, 92, 92, 92, 92, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 92, 139, 21, 21, 21, 140, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 141, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 92, 92, 92, 92, 92, 93, 93, 93, 93, 93, 93, 93, 93, + 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, + 93, 0, 93, 93, 93, 93, 93, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, + 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 21, 21, 21, 21, 21, + 142, 21, 21, 143, 21, 144, 144, 144, 144, 144, 144, 144, 144, 145, + 145, 145, 145, 145, 145, 145, 145, 144, 144, 144, 144, 144, 144, 0, + 0, 145, 145, 145, 145, 145, 145, 0, 0, 144, 144, 144, 144, 144, 144, + 144, 144, 145, 145, 145, 145, 145, 145, 145, 145, 144, 144, 144, 144, + 144, 144, 144, 144, 145, 145, 145, 145, 145, 145, 145, 145, 144, 144, + 144, 144, 144, 144, 0, 0, 145, 145, 145, 145, 145, 145, 0, 0, 21, 144, + 21, 144, 21, 144, 21, 144, 0, 145, 0, 145, 0, 145, 0, 145, 144, 144, + 144, 144, 144, 144, 144, 144, 145, 145, 145, 145, 145, 145, 145, 145, + 146, 146, 147, 147, 147, 147, 148, 148, 149, 149, 150, 150, 151, 151, + 0, 0, 144, 144, 144, 144, 144, 144, 144, 144, 152, 152, 152, 152, 152, + 152, 152, 152, 144, 144, 144, 144, 144, 144, 144, 144, 152, 152, 152, + 152, 152, 152, 152, 152, 144, 144, 144, 144, 144, 144, 144, 144, 152, + 152, 152, 152, 152, 152, 152, 152, 144, 144, 21, 153, 21, 0, 21, 21, + 145, 145, 154, 154, 155, 11, 156, 11, 11, 11, 21, 153, 21, 0, 21, 21, + 157, 157, 157, 157, 155, 11, 11, 11, 144, 144, 21, 21, 0, 0, 21, 21, + 145, 145, 158, 158, 0, 11, 11, 11, 144, 144, 21, 21, 21, 114, 21, 21, + 145, 145, 159, 159, 118, 11, 11, 11, 0, 0, 21, 153, 21, 0, 21, 21, + 160, 160, 161, 161, 155, 11, 11, 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 17, 17, 17, 17, 17, 8, 8, 8, 8, 8, 8, 3, 3, 16, 20, 5, 16, 16, 20, + 5, 16, 3, 3, 3, 3, 3, 3, 3, 3, 162, 163, 17, 17, 17, 17, 17, 2, 3, + 3, 3, 3, 3, 3, 3, 3, 3, 16, 20, 3, 3, 3, 3, 12, 12, 3, 3, 3, 7, 5, + 6, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 7, 3, 12, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 3, 2, 17, 17, 17, 17, 17, 0, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 18, 92, 0, 0, 18, 18, 18, 18, 18, 18, 7, 7, 7, 5, 6, 92, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 7, 7, 7, 5, 6, 0, 92, 92, 92, 92, + 92, 92, 92, 92, 92, 92, 92, 92, 92, 0, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, + 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, + 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 93, 93, 93, 93, + 93, 93, 93, 93, 93, 93, 93, 93, 93, 120, 120, 120, 120, 93, 120, 120, + 120, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 108, 14, 14, 14, 14, 108, 14, + 14, 21, 108, 108, 108, 21, 21, 108, 108, 108, 21, 14, 108, 14, 14, + 7, 108, 108, 108, 108, 108, 14, 14, 14, 14, 14, 14, 108, 14, 164, 14, + 108, 14, 165, 166, 108, 108, 14, 21, 108, 108, 167, 108, 21, 15, 15, + 15, 15, 21, 14, 14, 21, 21, 108, 108, 7, 7, 7, 7, 7, 108, 21, 21, 21, + 21, 14, 7, 14, 14, 168, 14, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 169, 169, 169, 169, 169, 169, 169, 169, 169, + 169, 169, 169, 169, 169, 169, 169, 170, 170, 170, 170, 170, 170, 170, + 170, 170, 170, 170, 170, 170, 170, 170, 170, 129, 129, 129, 23, 24, + 129, 129, 129, 129, 18, 14, 14, 0, 0, 0, 0, 7, 7, 7, 7, 7, 14, 14, + 14, 14, 14, 7, 7, 14, 14, 14, 14, 7, 14, 14, 7, 14, 14, 7, 14, 14, + 14, 14, 14, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 7, 7, 14, 14, 7, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, - 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, - 14, 14, 14, 5, 6, 5, 6, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 14, 14, 14, 14, 14, 14, 14, - 5, 6, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 7, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 14, 14, 14, 5, 6, 5, 6, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 7, 7, 14, 14, 14, 14, 14, 14, 14, 5, 6, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, + 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 7, - 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 7, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 14, 14, + 18, 18, 18, 18, 18, 18, 18, 18, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 171, 171, 171, 171, 171, 171, 171, 171, 171, 171, 171, 171, 171, 171, 171, 171, 171, 171, 171, 171, 171, 171, - 171, 171, 171, 171, 172, 172, 172, 172, 172, 172, 172, 172, 172, 172, - 172, 172, 172, 172, 172, 172, 172, 172, 172, 172, 172, 172, 172, 172, - 172, 172, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 7, 7, 7, 7, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 7, 5, 6, 7, 7, 7, 7, 7, 7, 7, 7, - 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, - 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, - 7, 7, 7, 7, 7, 7, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, - 6, 5, 6, 5, 6, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, - 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 5, 6, 5, 6, 7, 7, 7, 7, 7, 7, - 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, - 7, 7, 7, 5, 6, 7, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, - 7, 7, 7, 7, 14, 14, 7, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14, 14, - 14, 14, 14, 14, 14, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, + 171, 171, 171, 171, 171, 171, 171, 171, 171, 171, 171, 171, 172, 172, + 172, 172, 172, 172, 172, 172, 172, 172, 172, 172, 172, 172, 172, 172, + 172, 172, 172, 172, 172, 172, 172, 172, 172, 172, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 7, 7, 7, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 5, 6, 5, 6, + 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 7, + 7, 7, 5, 6, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 5, 6, 5, 6, 5, + 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 5, 6, 5, 6, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 5, 6, 7, 7, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 14, 14, 7, 7, 7, 7, + 7, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 123, 123, + 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, - 123, 123, 123, 123, 123, 123, 123, 123, 123, 0, 124, 124, 124, 124, + 123, 123, 123, 0, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, - 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, - 124, 0, 23, 24, 173, 174, 175, 176, 177, 23, 24, 23, 24, 23, 24, 178, - 179, 180, 181, 21, 23, 24, 21, 23, 24, 21, 21, 21, 21, 21, 92, 92, - 182, 182, 23, 24, 23, 24, 21, 14, 14, 14, 14, 14, 14, 23, 24, 23, 24, - 93, 93, 93, 23, 24, 0, 0, 0, 0, 0, 3, 3, 3, 3, 18, 3, 3, 183, 183, + 124, 124, 124, 124, 124, 124, 124, 124, 124, 0, 23, 24, 173, 174, 175, + 176, 177, 23, 24, 23, 24, 23, 24, 178, 179, 180, 181, 21, 23, 24, 21, + 23, 24, 21, 21, 21, 21, 21, 92, 92, 182, 182, 23, 24, 23, 24, 21, 14, + 14, 14, 14, 14, 14, 23, 24, 23, 24, 93, 93, 93, 23, 24, 0, 0, 0, 0, + 0, 3, 3, 3, 3, 18, 3, 3, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, - 183, 183, 183, 183, 183, 183, 183, 183, 0, 183, 0, 0, 0, 0, 0, 183, - 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 92, 3, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 93, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, - 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, - 0, 3, 3, 16, 20, 16, 20, 3, 3, 3, 16, 20, 3, 16, 20, 3, 3, 3, 3, 3, - 3, 3, 3, 3, 8, 3, 3, 8, 3, 16, 20, 3, 3, 16, 20, 5, 6, 5, 6, 5, 6, - 5, 6, 3, 3, 3, 3, 3, 92, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 8, 8, 3, 3, - 3, 3, 8, 3, 5, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 0, 0, 0, 0, 2, 3, 3, 3, 14, 92, 15, 129, 5, 6, 5, 6, 5, - 6, 5, 6, 5, 6, 14, 14, 5, 6, 5, 6, 5, 6, 5, 6, 8, 5, 6, 6, 14, 129, - 129, 129, 129, 129, 129, 129, 129, 129, 93, 93, 93, 93, 125, 125, 8, - 92, 92, 92, 92, 92, 14, 14, 129, 129, 129, 92, 15, 3, 14, 14, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 0, 0, 93, 93, 11, 11, 92, 92, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 3, 92, 92, 92, 15, 0, 0, 0, 0, 0, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 0, 14, 14, 18, 18, 18, 18, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 14, - 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 0, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 18, 18, - 18, 18, 18, 18, 18, 18, 14, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 18, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 92, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 92, 3, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 23, 24, 23, 24, 23, 24, 23, + 183, 0, 183, 0, 0, 0, 0, 0, 183, 0, 0, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 0, 0, 0, 0, 0, 0, 0, 92, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 93, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, + 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, + 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 3, 3, 16, 20, 16, 20, + 3, 3, 3, 16, 20, 3, 16, 20, 3, 3, 3, 3, 3, 3, 3, 3, 3, 8, 3, 3, 8, + 3, 16, 20, 3, 3, 16, 20, 5, 6, 5, 6, 5, 6, 5, 6, 3, 3, 3, 3, 3, 92, + 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 8, 8, 3, 3, 3, 3, 8, 3, 5, 3, 3, 3, 3, + 3, 3, 3, 3, 3, 3, 3, 3, 3, 14, 14, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, + 2, 3, 3, 3, 14, 92, 15, 129, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 14, 14, + 5, 6, 5, 6, 5, 6, 5, 6, 8, 5, 6, 6, 14, 129, 129, 129, 129, 129, 129, + 129, 129, 129, 93, 93, 93, 93, 125, 125, 8, 92, 92, 92, 92, 92, 14, + 14, 129, 129, 129, 92, 15, 3, 14, 14, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 93, + 93, 11, 11, 92, 92, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 3, + 92, 92, 92, 15, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 14, 14, + 18, 18, 18, 18, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 18, 18, 18, 18, + 18, 18, 18, 18, 14, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 92, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 92, 3, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 15, 93, 120, 120, 120, 3, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 3, 92, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 92, 92, 93, 93, 15, 15, 15, 15, 15, 15, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 93, 93, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, @@ -1054,514 +1071,529 @@ 21, 21, 21, 21, 21, 21, 21, 23, 24, 23, 24, 184, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 92, 11, 11, 23, 24, 185, 21, 15, 23, 24, 23, 24, 186, 21, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 187, 188, 189, 190, 187, 21, 191, 192, 193, 194, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 0, 0, 23, 24, 195, - 196, 197, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 196, 197, 23, 24, 23, 24, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 15, 92, 92, 21, 15, 15, 15, 15, 15, 15, 15, 93, 15, - 15, 15, 93, 15, 15, 15, 15, 93, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 125, 125, 93, - 93, 125, 14, 14, 14, 14, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 14, 14, - 4, 14, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, - 0, 125, 125, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, - 125, 125, 125, 125, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 9, 9, 9, - 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 93, 93, 93, 93, 93, 93, 93, - 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 15, 15, 15, 15, 15, 15, - 3, 3, 3, 15, 3, 15, 15, 93, 15, 15, 15, 15, 15, 15, 93, 93, 93, 93, - 93, 93, 93, 93, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 93, 93, 93, 93, - 93, 93, 93, 93, 93, 125, 125, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 125, - 125, 93, 93, 93, 93, 125, 125, 93, 93, 125, 125, 125, 3, 3, 3, 3, 3, - 3, 3, 3, 3, 3, 3, 3, 3, 0, 92, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, - 0, 0, 3, 3, 15, 15, 15, 15, 15, 93, 92, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, 15, 0, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 93, 93, 93, 93, 93, 93, 125, 125, 93, 93, - 125, 125, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 93, 15, 15, - 15, 15, 15, 15, 15, 15, 93, 125, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, - 0, 0, 3, 3, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 92, 15, 15, 15, 15, 15, 15, 14, 14, 14, 15, 125, 93, 125, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 93, 15, 93, 93, 93, 15, 15, 93, 93, 15, 15, 15, 15, 15, 93, 93, - 15, 93, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 15, 15, 92, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 125, 93, 93, 125, 125, 3, 3, 15, 92, 92, 125, 93, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, - 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, - 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 21, 21, 21, + 0, 0, 0, 0, 0, 23, 24, 15, 92, 92, 21, 15, 15, 15, 15, 15, 15, 15, + 93, 15, 15, 15, 93, 15, 15, 15, 15, 93, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 125, + 125, 93, 93, 125, 14, 14, 14, 14, 93, 0, 0, 0, 18, 18, 18, 18, 18, + 18, 14, 14, 4, 14, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 3, 3, 3, 3, 0, 0, 0, + 0, 0, 0, 0, 0, 125, 125, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, + 125, 125, 125, 125, 125, 125, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, + 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 93, 93, 93, 93, 93, + 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 15, 15, 15, 15, + 15, 15, 3, 3, 3, 15, 3, 15, 15, 93, 15, 15, 15, 15, 15, 15, 93, 93, + 93, 93, 93, 93, 93, 93, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 93, 93, + 93, 93, 93, 93, 93, 93, 93, 125, 125, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 93, 125, 125, 93, 93, 93, 93, 125, 125, 93, 93, 125, 125, + 125, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 0, 92, 9, 9, 9, 9, 9, 9, + 9, 9, 9, 9, 0, 0, 0, 0, 3, 3, 15, 15, 15, 15, 15, 93, 92, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, + 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 93, 93, 93, 93, + 125, 125, 93, 93, 125, 125, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, + 15, 15, 93, 15, 15, 15, 15, 15, 15, 15, 15, 93, 125, 0, 0, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 9, 0, 0, 3, 3, 3, 3, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 92, 15, 15, 15, 15, 15, 15, 14, + 14, 14, 15, 125, 93, 125, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 93, 15, 93, 93, 93, 15, 15, 93, 93, 15, + 15, 15, 15, 15, 93, 93, 15, 93, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 92, 3, 3, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 125, 93, 93, 125, 125, 3, 3, 15, 92, + 92, 125, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, + 0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, + 15, 15, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 198, 21, - 21, 21, 21, 21, 21, 21, 11, 92, 92, 92, 92, 21, 21, 21, 21, 21, 21, - 21, 21, 0, 0, 0, 0, 0, 0, 0, 0, 199, 199, 199, 199, 199, 199, 199, + 21, 21, 21, 21, 198, 21, 21, 21, 21, 21, 21, 21, 11, 92, 92, 92, 92, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 92, 11, 11, 0, 0, 0, 0, 199, 199, + 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, - 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 15, - 15, 15, 125, 125, 93, 125, 125, 93, 125, 125, 3, 125, 93, 0, 0, 9, - 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, - 200, 200, 200, 200, 200, 200, 200, 200, 200, 200, 200, 200, 200, 200, - 200, 200, 200, 200, 200, 200, 200, 200, 200, 200, 200, 200, 200, 200, - 200, 200, 200, 200, 201, 201, 201, 201, 201, 201, 201, 201, 201, 201, + 199, 199, 199, 199, 15, 15, 15, 125, 125, 93, 125, 125, 93, 125, 125, + 3, 125, 93, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 15, + 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 0, 0, 0, 0, 200, 200, 200, 200, 200, 200, 200, 200, 200, 200, + 200, 200, 200, 200, 200, 200, 200, 200, 200, 200, 200, 200, 200, 200, + 200, 200, 200, 200, 200, 200, 200, 200, 201, 201, 201, 201, 201, 201, 201, 201, 201, 201, 201, 201, 201, 201, 201, 201, 201, 201, 201, 201, - 201, 201, 201, 201, 201, 201, 201, 201, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, - 0, 0, 0, 0, 0, 21, 21, 21, 21, 21, 21, 21, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 21, 21, 21, 21, 21, 0, 0, 0, 0, 0, 15, 93, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 7, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 0, 15, 0, 15, 15, 0, 15, 15, - 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 11, 11, 11, 11, 11, 11, - 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 6, 5, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 4, 14, 0, 0, 93, 93, 93, 93, 93, 93, 93, 93, 93, - 93, 93, 93, 93, 93, 93, 93, 3, 3, 3, 3, 3, 3, 3, 5, 6, 3, 0, 0, 0, - 0, 0, 0, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, - 93, 3, 8, 8, 12, 12, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, - 3, 3, 5, 6, 3, 3, 3, 3, 12, 12, 12, 3, 3, 3, 0, 3, 3, 3, 3, 8, 5, 6, - 5, 6, 5, 6, 3, 3, 3, 7, 8, 7, 7, 7, 0, 3, 4, 3, 3, 0, 0, 0, 0, 15, - 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 17, 0, 3, 3, 3, 4, 3, - 3, 3, 5, 6, 3, 7, 3, 8, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 7, - 7, 7, 3, 11, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, - 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 5, 7, 6, 7, 5, 6, 3, - 5, 6, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 92, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 92, 92, 0, 0, 15, 15, 15, 15, 15, 15, - 0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 15, - 15, 15, 0, 0, 0, 4, 4, 7, 11, 14, 4, 4, 0, 14, 7, 7, 7, 7, 14, 14, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, 17, 14, 14, 0, 0 + 201, 201, 201, 201, 201, 201, 201, 201, 201, 201, 201, 201, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 21, 21, 21, 21, 21, 21, 21, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 21, 21, 21, 21, 21, 0, 0, 0, 0, 0, 15, + 93, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 7, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 0, 15, 0, 15, + 15, 0, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 11, 11, 11, + 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 6, 5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 4, 14, 0, 0, 93, 93, 93, 93, 93, + 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 3, 3, 3, 3, 3, 3, 3, 5, + 6, 3, 0, 0, 0, 0, 0, 0, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, + 93, 93, 93, 93, 93, 3, 8, 8, 12, 12, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, + 5, 6, 5, 6, 5, 6, 3, 3, 5, 6, 3, 3, 3, 3, 12, 12, 12, 3, 3, 3, 0, 3, + 3, 3, 3, 8, 5, 6, 5, 6, 5, 6, 3, 3, 3, 7, 8, 7, 7, 7, 0, 3, 4, 3, 3, + 0, 0, 0, 0, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 17, 0, + 3, 3, 3, 4, 3, 3, 3, 5, 6, 3, 7, 3, 8, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, + 9, 9, 3, 3, 7, 7, 7, 3, 11, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, + 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 5, + 7, 6, 7, 5, 6, 3, 5, 6, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 92, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 92, 92, 0, 0, 15, 15, + 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, + 15, 15, 0, 0, 15, 15, 15, 0, 0, 0, 4, 4, 7, 11, 14, 4, 4, 0, 14, 7, + 7, 7, 7, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, 17, 14, 14, + 0, 0 #if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6 ,15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 0, 0, 3, 3, 3, 0, 0, 0, 0, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, - 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, - 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, - 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 18, - 18, 18, 18, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 18, 18, 14, 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 0, 0, 0, 0, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 93, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 93, - 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 18, 18, 18, 18, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 129, 15, 15, 15, 15, 15, 15, - 15, 15, 129, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 93, 93, 93, 0, - 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, - 3, 15, 15, 15, 15, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 3, 129, - 129, 129, 129, 129, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 202, 202, 202, 202, - 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, - 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, - 202, 202, 202, 202, 202, 202, 202, 202, 203, 203, 203, 203, 203, 203, - 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, - 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, - 203, 203, 203, 203, 203, 203, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 202, - 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, - 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, - 202, 202, 202, 202, 202, 202, 202, 0, 0, 0, 0, 203, 203, 203, 203, - 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, - 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, - 203, 203, 203, 203, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 0, - 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, - 15, 0, 0, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, - 0, 0, 0, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 3, 18, 18, 18, 18, 18, - 18, 18, 18, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 14, 14, 18, 18, 18, 18, 18, 18, - 18, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 0, 0, - 0, 0, 18, 18, 18, 18, 18, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 18, 18, 18, 18, 18, 18, - 0, 0, 0, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 3, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 18, 18, 15, 15, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 15, 93, 93, 93, 0, 93, 93, - 0, 0, 0, 0, 0, 93, 93, 93, 93, 15, 15, 15, 15, 0, 15, 15, 15, 0, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 93, 93, 93, 0, 0, - 0, 0, 93, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, - 3, 3, 3, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 18, 18, 3, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 18, 18, 18, 15, 15, 15, 15, 15, 15, 15, 15, 14, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 0, 0, 0, 0, 18, - 18, 18, 18, 18, 3, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, - 0, 18, 18, 18, 18, 18, 18, 18, 18, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 18, 18, - 18, 18, 18, 18, 18, 18, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, + 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 0, 0, 0, 0, 0, 3, 3, 3, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 129, 129, + 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, + 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, + 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, + 129, 129, 129, 129, 129, 129, 129, 129, 129, 18, 18, 18, 18, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 18, 18, + 14, 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 0, 0, 0, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 93, 0, + 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 93, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 18, 18, 18, 18, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 129, 15, 15, 15, 15, 15, 15, 15, 15, 129, 0, + 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 93, 93, 93, 93, 93, 0, 0, 0, 0, 0, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 3, 15, 15, 15, 15, + 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 3, 129, 129, 129, 129, + 129, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 202, 202, 202, 202, 202, 202, 202, + 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, + 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, + 202, 202, 202, 202, 202, 203, 203, 203, 203, 203, 203, 203, 203, 203, + 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, + 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, + 203, 203, 203, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, + 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 202, 202, 202, 202, + 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, + 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, + 202, 202, 202, 202, 0, 0, 0, 0, 203, 203, 203, 203, 203, 203, 203, + 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, + 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, + 203, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, + 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 15, + 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 0, 0, 15, + 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 0, 3, 18, 18, 18, 18, 18, 18, 18, 18, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 14, 14, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, + 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 0, 0, 0, 0, 18, 18, 18, + 18, 18, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 18, 18, 18, 18, 18, 18, 0, 0, 0, 3, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 3, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 0, 0, 0, 0, 18, 18, 15, 15, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 15, 93, 93, 93, 0, 93, 93, 0, 0, 0, 0, 0, 93, + 93, 93, 93, 15, 15, 15, 15, 0, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 0, 0, 93, 93, 93, 0, 0, 0, 0, 93, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 3, + 3, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 18, 18, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 18, + 18, 18, 15, 15, 15, 15, 15, 15, 15, 15, 14, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 93, 93, 0, 0, 0, 0, 18, 18, 18, 18, 18, 3, 3, 3, + 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, + 3, 3, 3, 3, 3, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 18, 18, 18, 18, 18, 18, + 18, 18, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, - 98, 98, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 103, 103, 103, 103, - 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, - 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, - 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, - 103, 103, 103, 103, 103, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, - 15, 15, 15, 15, 93, 93, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, - 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 0, 18, 18, 18, 18, 18, 18, 18, 15, 0, 0, 0, - 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 93, 93, 93, 93, 93, 93, - 93, 93, 93, 18, 18, 18, 18, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 125, 93, - 125, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, - 93, 3, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 9, 9, 9, 9, 9, 9, 9, - 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 93, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 125, 125, 125, - 93, 93, 93, 93, 125, 125, 93, 93, 3, 3, 17, 3, 3, 3, 3, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 17, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, - 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 93, - 93, 93, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 93, 93, 93, 93, 93, 125, 93, 93, 93, 93, 93, 93, 93, - 93, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 3, 3, 15, 125, 125, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 93, 3, 3, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 125, 125, 125, 93, 93, 93, 93, 93, 93, 93, 93, 93, 125, 125, 15, - 15, 15, 15, 3, 3, 3, 3, 93, 93, 93, 93, 3, 0, 0, 9, 9, 9, 9, 9, 9, - 9, 9, 9, 9, 15, 3, 15, 3, 3, 3, 0, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 125, 125, 125, - 93, 93, 93, 125, 125, 93, 125, 93, 93, 3, 3, 3, 3, 3, 3, 93, 0, 15, - 15, 15, 15, 15, 15, 15, 0, 15, 0, 15, 15, 15, 15, 0, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 3, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 93, 125, 125, 125, 93, 93, 93, 93, 93, 93, - 93, 93, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, - 0, 93, 93, 125, 125, 0, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, - 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, - 15, 15, 15, 15, 15, 0, 93, 93, 15, 125, 125, 93, 125, 125, 125, 125, - 0, 0, 125, 125, 0, 0, 125, 125, 125, 0, 0, 15, 0, 0, 0, 0, 0, 0, 125, + 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, + 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, + 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, + 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 0, 0, 0, + 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 15, 15, 15, 15, 93, 93, 93, 93, + 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, + 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 93, 93, 8, 0, 0, 15, 15, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, + 15, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 93, 93, 93, + 93, 93, 93, 93, 93, 93, 18, 18, 18, 18, 3, 3, 3, 3, 3, 0, 0, 0, 0, + 0, 0, 15, 15, 15, 15, 15, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 125, 93, 125, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 3, 3, 3, + 3, 3, 3, 3, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 93, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 125, 125, 125, 93, 93, 93, + 93, 125, 125, 93, 93, 3, 3, 17, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 17, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, + 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 93, 93, 93, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 93, 93, 93, 93, 93, 125, 93, 93, 93, 93, 93, 93, 93, 93, 0, 9, + 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 3, 3, 15, 125, 125, 15, 0, 0, 0, 0, + 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 93, 3, 3, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 125, + 125, 125, 93, 93, 93, 93, 93, 93, 93, 93, 93, 125, 125, 15, 15, 15, + 15, 3, 3, 3, 3, 93, 93, 93, 93, 3, 125, 93, 9, 9, 9, 9, 9, 9, 9, 9, + 9, 9, 15, 3, 15, 3, 3, 3, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 125, 125, 125, 93, 93, + 93, 125, 125, 93, 125, 93, 93, 3, 3, 3, 3, 3, 3, 93, 0, 15, 15, 15, + 15, 15, 15, 15, 0, 15, 0, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 3, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 93, 125, 125, 125, 93, 93, 93, 93, 93, 93, 93, 93, + 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 93, + 93, 125, 125, 0, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 0, 0, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 15, + 15, 15, 15, 15, 0, 93, 93, 15, 125, 125, 93, 125, 125, 125, 125, 0, + 0, 125, 125, 0, 0, 125, 125, 125, 0, 0, 15, 0, 0, 0, 0, 0, 0, 125, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 125, 125, 0, 0, 93, 93, 93, 93, 93, 93, 93, 0, 0, 0, 93, 93, 93, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 125, 125, 125, 93, 93, 93, 93, 93, 93, 93, 93, 125, 125, 93, 93, 93, 125, 93, 15, 15, 15, 15, 3, 3, 3, 3, 3, 9, 9, - 9, 9, 9, 9, 9, 9, 9, 9, 0, 3, 0, 3, 93, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 125, 125, 125, 93, 93, 93, - 93, 93, 93, 125, 93, 125, 125, 125, 125, 93, 93, 125, 93, 93, 15, 15, - 3, 15, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, - 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 125, 125, 125, 93, 93, 93, 93, 0, 0, 125, 125, 125, 125, 93, 93, - 125, 93, 93, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, - 3, 3, 3, 3, 3, 15, 15, 15, 15, 93, 93, 0, 0, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 125, 125, 125, 93, 93, 93, - 93, 93, 93, 93, 93, 125, 125, 93, 125, 93, 93, 3, 3, 3, 15, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, - 0, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 93, 125, 93, 125, 125, 93, 93, 93, 93, 93, 93, 125, 93, 15, 0, - 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 125, 125, 93, 93, 93, - 93, 125, 93, 93, 93, 93, 93, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, - 9, 18, 18, 3, 3, 3, 14, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 125, 125, 125, 93, 93, 93, 93, 93, 93, 93, 93, 93, 125, 93, 93, - 3, 0, 0, 0, 0, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, + 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 0, 3, 93, 15, 15, 15, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 125, 125, 125, 93, 93, 93, 93, 93, 93, 125, 93, 125, 125, 125, 125, + 93, 93, 125, 93, 93, 15, 15, 3, 15, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 125, 125, 125, 93, 93, 93, 93, 0, 0, + 125, 125, 125, 125, 93, 93, 125, 93, 93, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 15, 15, 15, 15, 93, 93, 0, + 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 125, 125, 125, 93, 93, 93, 93, 93, 93, 93, 93, 125, 125, 93, 125, 93, + 93, 3, 3, 3, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, + 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 93, 125, 93, 125, 125, 93, 93, 93, + 93, 93, 93, 125, 93, 15, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, + 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 125, 125, 93, 93, 93, 93, 125, 93, 93, 93, 93, 93, 0, 0, 0, 0, + 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, 18, 3, 3, 3, 14, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 125, 125, 125, 93, 93, 93, 93, 93, + 93, 93, 93, 93, 125, 93, 93, 3, 0, 0, 0, 0, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, - 10, 10, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, + 10, 10, 10, 10, 10, 10, 10, 10, 10, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, - 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 125, 125, 125, 93, 93, 93, 93, 0, 0, 93, 93, - 125, 125, 125, 125, 93, 15, 3, 15, 125, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 93, 93, 93, - 93, 93, 93, 93, 93, 93, 93, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 93, 93, - 93, 93, 125, 15, 93, 93, 93, 93, 3, 3, 3, 3, 3, 3, 3, 3, 93, 0, 0, - 0, 0, 0, 0, 0, 0, 15, 93, 93, 93, 93, 93, 93, 125, 125, 93, 93, 93, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 93, - 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 125, 93, 93, 3, 3, 3, 15, 3, - 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 125, 93, 93, 93, 93, 93, 93, 93, 0, 93, 93, 93, 93, 93, - 93, 125, 93, 15, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, - 9, 9, 9, 9, 9, 9, 9, 9, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 3, 3, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 93, 93, 93, 93, 93, 93, 93, 93, - 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 0, 125, 93, - 93, 93, 93, 93, 93, 93, 125, 93, 93, 125, 93, 93, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 93, 93, 93, 93, 93, 93, 0, 0, 0, 93, 0, 93, 93, 0, 93, 93, 93, 93, - 93, 93, 93, 15, 93, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, - 9, 9, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 125, 125, 125, - 125, 125, 0, 93, 93, 0, 125, 125, 93, 125, 93, 15, 0, 0, 0, 0, 0, 0, - 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 93, 93, 125, 125, 3, 3, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 14, 14, 14, 14, 14, 14, 14, 14, 4, 4, 4, 4, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 3, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, - 129, 129, 129, 129, 129, 0, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 0, 17, 17, 17, 17, 17, 17, 17, 17, - 17, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, - 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 0, 0, 93, 93, 93, 93, 93, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, - 93, 93, 93, 93, 93, 3, 3, 3, 3, 3, 14, 14, 14, 14, 92, 92, 92, 92, - 3, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, - 0, 18, 18, 18, 18, 18, 18, 18, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 15, - 15, 15, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 18, 3, 3, 3, 3, 0, 0, 0, 0, 0, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 93, 15, 125, 125, 125, + 13, 13, 13, 13, 13, 13, 13, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, + 15, 15, 15, 15, 15, 15, 0, 0, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, + 15, 0, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 125, 125, 125, 125, 125, + 125, 0, 125, 125, 0, 0, 93, 93, 125, 93, 15, 125, 15, 125, 93, 3, 3, + 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, + 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 125, 125, 125, 93, 93, 93, 93, 0, 0, 93, 93, 125, 125, 125, 125, 93, + 15, 3, 15, 125, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 93, 93, 93, 93, 93, 93, 93, 93, 93, + 93, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 93, 93, 93, 93, 93, 93, 125, 15, 93, 93, + 93, 93, 3, 3, 3, 3, 3, 3, 3, 3, 93, 0, 0, 0, 0, 0, 0, 0, 0, 15, 93, + 93, 93, 93, 93, 93, 125, 125, 93, 93, 93, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, + 93, 93, 93, 125, 93, 93, 3, 3, 3, 15, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 125, 93, 93, 93, + 93, 93, 93, 93, 0, 93, 93, 93, 93, 93, 93, 125, 93, 15, 3, 3, 3, 3, + 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 0, 0, 0, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 0, 0, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, + 93, 93, 93, 93, 93, 93, 93, 0, 125, 93, 93, 93, 93, 93, 93, 93, 125, + 93, 93, 125, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, + 15, 15, 0, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 93, 93, 93, 93, 0, 0, 0, + 93, 0, 93, 93, 0, 93, 93, 93, 93, 93, 93, 93, 15, 93, 0, 0, 0, 0, 0, + 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 15, 15, 15, + 15, 15, 15, 0, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 125, 125, 125, 125, 125, 0, 93, 93, 0, 125, 125, 93, + 125, 93, 15, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 125, 125, 3, 3, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 14, 14, + 14, 14, 14, 14, 14, 14, 4, 4, 4, 4, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 3, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, + 129, 129, 129, 0, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, + 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 0, 17, 17, 17, 17, 17, 17, 17, 17, 17, 0, 0, 0, + 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, + 9, 9, 9, 0, 0, 0, 0, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, + 93, 93, 93, 93, 93, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 93, 93, 93, + 93, 93, 3, 3, 3, 3, 3, 14, 14, 14, 14, 92, 92, 92, 92, 3, 14, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 18, 18, 18, + 18, 18, 18, 18, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 3, + 3, 3, 3, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 0, 0, 0, 0, 93, 15, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, - 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 0, 0, 0, 0, 0, 0, - 0, 93, 93, 93, 93, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, - 92, 92, 92, 3, 92, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, - 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 0, 0, 0, - 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, - 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 0, 0, 14, 93, 93, 3, 17, 17, 17, 17, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 125, 125, 93, 93, 93, 14, 14, 14, 125, 125, 125, - 125, 125, 125, 17, 17, 17, 17, 17, 17, 17, 17, 93, 93, 93, 93, 93, - 93, 93, 93, 14, 14, 93, 93, 93, 93, 93, 93, 93, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 93, 93, 93, 93, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 14, 14, 93, 93, 93, 14, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, - 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, - 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 108, 108, 108, 108, 108, 108, 108, 108, - 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, - 108, 108, 108, 108, 21, 21, 21, 21, 21, 21, 21, 0, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 108, 108, 108, - 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, - 108, 108, 108, 108, 108, 108, 108, 108, 108, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 108, 0, 108, 108, 0, 0, 108, 0, 0, 108, 108, 0, 0, 108, - 108, 108, 108, 0, 108, 108, 108, 108, 108, 108, 108, 108, 21, 21, 21, - 21, 0, 21, 0, 21, 21, 21, 21, 21, 21, 21, 0, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, - 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, - 108, 108, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 108, 108, 0, 108, 108, - 108, 108, 0, 0, 108, 108, 108, 108, 108, 108, 108, 108, 0, 108, 108, - 108, 108, 108, 108, 108, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 108, - 108, 0, 108, 108, 108, 108, 0, 108, 108, 108, 108, 108, 0, 108, 0, - 0, 0, 108, 108, 108, 108, 108, 108, 108, 0, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, - 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, - 108, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 108, 108, 108, 108, 108, 108, - 108, 108, 108, 108, 108, 108, 108, 108, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 108, 108, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, - 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, - 108, 108, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 108, 108, 108, 108, 108, + 125, 125, 125, 0, 0, 0, 0, 0, 0, 0, 93, 93, 93, 93, 92, 92, 92, 92, + 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 3, 92, 93, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 125, 125, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, + 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 0, 0, 14, 93, 93, 3, 17, 17, 17, 17, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, + 14, 14, 14, 14, 14, 14, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 125, 125, 93, 93, 93, 14, 14, 14, 125, 125, 125, 125, 125, 125, + 17, 17, 17, 17, 17, 17, 17, 17, 93, 93, 93, 93, 93, 93, 93, 93, 14, + 14, 93, 93, 93, 93, 93, 93, 93, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 93, 93, 93, 93, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 14, 14, 93, 93, 93, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 108, 108, + 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, + 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, + 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, + 108, 21, 21, 21, 21, 21, 21, 21, 0, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 108, 108, 108, 108, 108, 108, + 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, + 108, 108, 108, 108, 108, 108, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 108, + 0, 108, 108, 0, 0, 108, 0, 0, 108, 108, 0, 0, 108, 108, 108, 108, 0, + 108, 108, 108, 108, 108, 108, 108, 108, 21, 21, 21, 21, 0, 21, 0, 21, + 21, 21, 21, 21, 21, 21, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, + 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 108, 108, 0, 108, 108, 108, 108, 0, + 0, 108, 108, 108, 108, 108, 108, 108, 108, 0, 108, 108, 108, 108, 108, + 108, 108, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 108, 108, 0, 108, 108, + 108, 108, 0, 108, 108, 108, 108, 108, 0, 108, 0, 0, 0, 108, 108, 108, + 108, 108, 108, 108, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 108, 108, + 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, + 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, + 108, 108, 108, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 108, 108, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 108, + 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 21, 21, 21, - 21, 21, 21, 0, 0, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, - 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, - 108, 7, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 7, 21, 21, 21, 21, 21, 21, - 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, - 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 7, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 7, 21, 21, 21, 21, 21, 21, 108, 108, 108, 108, - 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, - 108, 108, 108, 108, 108, 108, 108, 7, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 7, 21, 21, 21, 21, 21, 21, 108, 108, 108, 108, 108, 108, 108, 108, - 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, - 108, 108, 108, 7, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 7, 21, 21, 21, 21, - 21, 21, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, - 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 7, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 7, 21, 21, 21, 21, 21, 21, 108, 21, - 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 108, 108, 108, 108, 108, 108, 108, 108, 108, + 108, 108, 108, 108, 108, 108, 108, 21, 21, 21, 21, 21, 21, 0, 0, 108, + 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, + 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 7, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 7, 21, 21, 21, 21, 21, 21, 108, 108, 108, 108, 108, + 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, + 108, 108, 108, 108, 108, 108, 7, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 7, + 21, 21, 21, 21, 21, 21, 108, 108, 108, 108, 108, 108, 108, 108, 108, + 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, + 108, 108, 7, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 7, 21, 21, 21, 21, 21, + 21, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, + 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 7, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 7, 21, 21, 21, 21, 21, 21, 108, 108, 108, + 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, + 108, 108, 108, 108, 108, 108, 108, 108, 7, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 7, 21, 21, 21, 21, 21, 21, 108, 21, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, - 9, 9, 9, 9, 9, 9, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, - 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 14, 14, 14, 14, 93, 93, 93, - 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 14, 14, - 14, 14, 14, 14, 14, 14, 93, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 93, 14, 14, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 93, 93, 93, 93, 93, 0, 93, 93, 93, 93, 93, 93, - 93, 93, 93, 93, 93, 93, 93, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 93, 93, 93, 93, 93, 93, 93, 0, 93, 93, 93, 93, 93, 93, - 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 0, 0, 93, 93, 93, 93, 93, - 93, 93, 0, 93, 93, 0, 93, 93, 93, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 93, + 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, + 93, 93, 93, 93, 93, 14, 14, 14, 14, 93, 93, 93, 93, 93, 93, 93, 93, + 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 14, 14, 14, 14, 14, 14, 14, + 14, 93, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 93, + 14, 14, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 93, 93, 93, 93, 93, 0, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, + 93, 93, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 93, + 93, 93, 93, 93, 93, 93, 0, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, + 93, 93, 93, 93, 93, 93, 93, 0, 0, 93, 93, 93, 93, 93, 93, 93, 0, 93, + 93, 0, 93, 93, 93, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 0, 0, 0, 93, 93, 93, 93, 93, 93, 93, 92, 92, 92, 92, 92, 92, 92, + 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 15, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 0, 0, 0, 93, 93, 93, 93, 93, 93, 93, 92, 92, 92, - 92, 92, 92, 92, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 15, - 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 93, 93, 9, 9, 9, 9, 9, 9, 9, - 9, 9, 9, 0, 0, 0, 0, 0, 4, 15, 15, 15, 15, 15, 0, 0, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 93, 93, 93, 93, 93, 93, 93, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, + 15, 15, 15, 15, 93, 93, 93, 93, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, + 0, 0, 0, 4, 15, 15, 15, 15, 15, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 93, 93, 93, 93, 93, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, 204, 204, + 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, - 204, 204, 204, 204, 204, 204, 204, 205, 205, 205, 205, 205, 205, 205, + 204, 204, 204, 204, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205, - 205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 93, - 93, 93, 93, 93, 93, 93, 92, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, - 9, 0, 0, 0, 0, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 14, 18, 18, 18, 4, 18, - 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, + 205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 93, 93, 93, 93, 93, + 93, 93, 92, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 3, + 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 14, 18, 18, 18, 4, 18, 18, 18, 18, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 14, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 0, 0, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 0, 15, 15, 0, 15, 0, 0, 15, 0, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 0, 15, 0, 15, 0, 0, 0, 0, 0, - 0, 15, 0, 0, 0, 0, 15, 0, 15, 0, 15, 0, 15, 15, 15, 0, 15, 15, 0, 15, - 0, 0, 15, 0, 15, 0, 15, 0, 15, 0, 15, 0, 15, 15, 0, 15, 0, 0, 15, 15, - 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 0, 15, 15, - 15, 15, 0, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, - 0, 0, 15, 15, 15, 0, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 7, 7, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, - 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 18, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, - 0, 0, 0, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, + 18, 14, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 0, 0, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, + 15, 15, 0, 15, 0, 0, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 0, 15, 15, 15, 15, 0, 15, 0, 15, 0, 0, 0, 0, 0, 0, 15, 0, 0, 0, 0, + 15, 0, 15, 0, 15, 0, 15, 15, 15, 0, 15, 15, 0, 15, 0, 0, 15, 0, 15, + 0, 15, 0, 15, 0, 15, 0, 15, 15, 0, 15, 0, 0, 15, 15, 15, 15, 0, 15, + 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 0, 15, 15, 15, 15, 0, 15, + 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 15, 15, + 15, 0, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 7, 7, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, + 0, 0, 0, 0, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 11, 11, 11, 11, 11, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, - 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, - 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, - 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 14, 0, 0, 0, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 0, 0, 14, 14, 14, 14, 14, 14, 0, 0, 0, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14, 14, 14, 0, 0, - 0, 0, 14, 14, 14, 0, 0, 0, 0, 0, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, + 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 14, 14, 14, + 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14, + 14, 14, 14, 0, 0, 0, 14, 14, 14, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, + 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, + 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 @@ -1612,13 +1644,13 @@ -10818751, 237633, -12223, -10830527, -9058239, 237698, 9949314, 18, 17, 10305, 10370, 8769, 8834 }; #if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6 -# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1fffff) >= 0x2fa20) +# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1FFFFF) >= 0x31360) #else -# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1f0000) != 0) +# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1F0000) != 0) #endif /* * The following constants are used to determine the category of a * Unicode character. @@ -1661,19 +1693,19 @@ * The following macros extract the fields of the character info. The * GetDelta() macro is complicated because we can't rely on the C compiler * to do sign extension on right shifts. */ -#define GetCaseType(info) (((info) & 0xe0) >> 5) -#define GetCategory(ch) (GetUniCharInfo(ch) & 0x1f) +#define GetCaseType(info) (((info) & 0xE0) >> 5) +#define GetCategory(ch) (GetUniCharInfo(ch) & 0x1F) #define GetDelta(info) ((info) >> 8) /* * This macro extracts the information about a character from the * Unicode character tables. */ #if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6 -# define GetUniCharInfo(ch) (groups[groupMap[pageMap[((ch) & 0x1fffff) >> OFFSET_BITS] | ((ch) & ((1 << OFFSET_BITS)-1))]]) +# define GetUniCharInfo(ch) (groups[groupMap[pageMap[((ch) & 0x1FFFFF) >> OFFSET_BITS] | ((ch) & ((1 << OFFSET_BITS)-1))]]) #else -# define GetUniCharInfo(ch) (groups[groupMap[pageMap[((ch) & 0xffff) >> OFFSET_BITS] | ((ch) & ((1 << OFFSET_BITS)-1))]]) +# define GetUniCharInfo(ch) (groups[groupMap[pageMap[((ch) & 0xFFFF) >> OFFSET_BITS] | ((ch) & ((1 << OFFSET_BITS)-1))]]) #endif Index: generic/tclUtf.c ================================================================== --- generic/tclUtf.c +++ generic/tclUtf.c @@ -64,18 +64,52 @@ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, - 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, - 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,4,4,4,4,4,1,1,1,1,1,1,1,1,1,1,1 + 2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, + 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3, +#if TCL_UTF_MAX > 3 + 4,4,4,4,4, +#else + 1,1,1,1,1, +#endif + 1,1,1,1,1,1,1,1,1,1,1 +}; + +static const unsigned char complete[256] = { + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, +/* Tcl_UtfCharComplete() might point to 2nd byte of valid 4-byte sequence */ + 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3, + 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3, +/* End of "continuation byte section" */ + 2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, + 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3, +#if TCL_UTF_MAX > 3 + 4,4,4,4,4, +#else + 3,3,3,3,3, +#endif + 1,1,1,1,1,1,1,1,1,1,1 }; + +/* + * Functions used only in this module. + */ + +static int UtfCount(int ch); +static int Invalid(const char *src); +static int UCS4ToUpper(int ch); +static int UCS4ToTitle(int ch); /* *--------------------------------------------------------------------------- * - * TclUtfCount -- + * UtfCount -- * * Find the number of bytes in the Utf character "ch". * * Results: * The return values is the number of bytes in the Utf character "ch". @@ -84,47 +118,97 @@ * None. * *--------------------------------------------------------------------------- */ -size_t -TclUtfCount( +static inline int +UtfCount( int ch) /* The Unicode character whose size is returned. */ { if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) { return 1; } if (ch <= 0x7FF) { return 2; } +#if TCL_UTF_MAX > 3 if (((unsigned)(ch - 0x10000) <= 0xFFFFF)) { return 4; } +#endif return 3; } + +/* + *--------------------------------------------------------------------------- + * + * Invalid -- + * + * Given a pointer to a two-byte prefix of a well-formed UTF-8 byte + * sequence (a lead byte followed by a trail byte) this routine + * examines those two bytes to determine whether the sequence is + * invalid in UTF-8. This might be because it is an overlong + * encoding, or because it encodes something out of the proper range. + * + * Given a pointer to the bytes \xF8 or \xFC , this routine will + * try to read beyond the end of the "bounds" table. Callers must + * prevent this. + * + * Given a pointer to something else (an ASCII byte, a trail byte, + * or another byte that can never begin a valid byte sequence such + * as \xF5) this routine returns false. That makes the routine poorly + * named, as it does not detect and report all invalid sequences. + * + * Callers have to take care that this routine does something useful + * for their needs. + * + * Results: + * A boolean. + *--------------------------------------------------------------------------- + */ +static const unsigned char bounds[28] = { + 0x80, 0x80, /* \xC0 accepts \x80 only */ + 0x80, 0xBF, 0x80, 0xBF, 0x80, 0xBF, 0x80, 0xBF, 0x80, 0xBF, 0x80, 0xBF, + 0x80, 0xBF, /* (\xC4 - \xDC) -- all sequences valid */ + 0xA0, 0xBF, /* \xE0\x80 through \xE0\x9F are invalid prefixes */ + 0x80, 0xBF, 0x80, 0xBF, 0x80, 0xBF, /* (\xE4 - \xEC) -- all valid */ +#if TCL_UTF_MAX > 3 + 0x90, 0xBF, /* \xF0\x80 through \xF0\x8F are invalid prefixes */ + 0x80, 0x8F /* \xF4\x90 and higher are invalid prefixes */ +#else + 0xC0, 0xBF, /* Not used, but reject all again for safety. */ + 0xC0, 0xBF /* Not used, but reject all again for safety. */ +#endif +}; + +static int +Invalid( + const char *src) /* Points to lead byte of a UTF-8 byte sequence */ +{ + unsigned char byte = UCHAR(*src); + int index; + + if ((byte & 0xC3) == 0xC0) { + /* Only lead bytes 0xC0, 0xE0, 0xF0, 0xF4 need examination */ + index = (byte - 0xC0) >> 1; + if (UCHAR(src[1]) < bounds[index] || UCHAR(src[1]) > bounds[index+1]) { + /* Out of bounds - report invalid. */ + return 1; + } + } + return 0; +} + /* *--------------------------------------------------------------------------- * * Tcl_UniCharToUtf -- * * Store the given Tcl_UniChar as a sequence of UTF-8 bytes in the * provided buffer. Equivalent to Plan 9 runetochar(). * - * Special handling of Surrogate pairs is handled as follows: - * When this function is called for ch being a high surrogate, - * the first byte of the 4-byte UTF-8 sequence is produced and - * the function returns 1. Calling the function again with a - * low surrogate, the remaining 3 bytes of the 4-byte UTF-8 - * sequence is produced, and the function returns 3. The buffer - * is used to remember the high surrogate between the two calls. - * - * If no low surrogate follows the high surrogate (which is actually - * illegal), this can be handled reasonably by calling Tcl_UniCharToUtf - * again with ch = -1. This will produce a 3-byte UTF-8 sequence - * representing the high surrogate. - * * Results: * The return values is the number of bytes in the buffer that were * consumed. * * Side effects: @@ -138,11 +222,11 @@ int ch, /* The Tcl_UniChar to be stored in the * buffer. */ char *buf) /* Buffer in which the UTF-8 representation of * the Tcl_UniChar is stored. Buffer must be * large enough to hold the UTF-8 character - * (at most 4 bytes). */ + * (at most TCL_UTF_MAX bytes). */ { if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) { buf[0] = (char) ch; return 1; } @@ -151,10 +235,11 @@ buf[1] = (char) ((ch | 0x80) & 0xBF); buf[0] = (char) ((ch >> 6) | 0xC0); return 2; } if (ch <= 0xFFFF) { +#if TCL_UTF_MAX > 3 if ((ch & 0xF800) == 0xD800) { if (ch & 0x0400) { /* Low surrogate */ if (((buf[0] & 0xC0) == 0x80) && ((buf[1] & 0xCF) == 0)) { /* Previous Tcl_UniChar was a high surrogate, so combine */ @@ -172,12 +257,15 @@ buf[1] = (char) (((ch >> 2) & 0x3F) | 0x80); buf[0] = (char) (((ch >> 8) & 0x07) | 0xF0); return 1; } } +#endif goto three; } + +#if TCL_UTF_MAX > 3 if (ch <= 0x10FFFF) { buf[3] = (char) ((ch | 0x80) & 0xBF); buf[2] = (char) (((ch >> 6) | 0x80) & 0xBF); buf[1] = (char) (((ch >> 12) | 0x80) & 0xBF); buf[0] = (char) ((ch >> 18) | 0xF0); @@ -191,10 +279,11 @@ buf[1] = (char) ((ch | 0x80) & 0xBF); buf[0] = (char) (((ch >> 6) | 0x80) & 0xBF); buf[-1] = (char) ((ch >> 12) | 0xE0); return 2; } +#endif } ch = 0xFFFD; three: buf[2] = (char) ((ch | 0x80) & 0xBF); @@ -222,95 +311,39 @@ */ char * Tcl_UniCharToUtfDString( const Tcl_UniChar *uniStr, /* Unicode string to convert to UTF-8. */ - size_t uniLength, /* Length of Unicode string in Tcl_UniChars + int uniLength, /* Length of Unicode string in Tcl_UniChars * (must be >= 0). */ Tcl_DString *dsPtr) /* UTF-8 representation of string is appended * to this previously initialized DString. */ { const Tcl_UniChar *w, *wEnd; char *p, *string; - size_t oldLength; - int len = 1; + int oldLength; /* - * UTF-8 string length in bytes will be <= Unicode string length * 4. + * UTF-8 string length in bytes will be <= Unicode string length * + * TCL_UTF_MAX. */ oldLength = Tcl_DStringLength(dsPtr); - Tcl_DStringSetLength(dsPtr, oldLength + (uniLength + 1) * 4); + Tcl_DStringSetLength(dsPtr, oldLength + (uniLength + 1) * TCL_UTF_MAX); string = Tcl_DStringValue(dsPtr) + oldLength; p = string; wEnd = uniStr + uniLength; for (w = uniStr; w < wEnd; ) { - if (!len && ((*w & 0xFC00) != 0xDC00)) { - /* Special case for handling high surrogates. */ - p += Tcl_UniCharToUtf(-1, p); - } - len = Tcl_UniCharToUtf(*w, p); - p += len; - if ((*w >= 0xD800) && (len < 3)) { - len = 0; /* Indication that high surrogate was found */ - } + p += Tcl_UniCharToUtf(*w, p); w++; } - if (!len) { - /* Special case for handling high surrogates. */ - p += Tcl_UniCharToUtf(-1, p); - } Tcl_DStringSetLength(dsPtr, oldLength + (p - string)); return string; } -#if (TCL_UTF_MAX > 4) && (defined(__CYGWIN__) || defined(_WIN32)) -char * -TclWCharToUtfDString( - const WCHAR *uniStr, /* WCHAR string to convert to UTF-8. */ - int uniLength, /* Length of WCHAR string in Tcl_UniChars - * (must be >= 0). */ - Tcl_DString *dsPtr) /* UTF-8 representation of string is appended - * to this previously initialized DString. */ -{ - const WCHAR *w, *wEnd; - char *p, *string; - int oldLength, len = 1; - - /* - * UTF-8 string length in bytes will be <= Unicode string length * 4. - */ - - oldLength = Tcl_DStringLength(dsPtr); - Tcl_DStringSetLength(dsPtr, oldLength + (uniLength + 1) * 4); - string = Tcl_DStringValue(dsPtr) + oldLength; - - p = string; - wEnd = uniStr + uniLength; - for (w = uniStr; w < wEnd; ) { - if (!len && ((*w & 0xFC00) != 0xDC00)) { - /* Special case for handling high surrogates. */ - p += Tcl_UniCharToUtf(-1, p); - } - len = Tcl_UniCharToUtf(*w, p); - p += len; - if ((*w >= 0xD800) && (len < 3)) { - len = 0; /* Indication that high surrogate was found */ - } - w++; - } - if (!len) { - /* Special case for handling high surrogates. */ - p += Tcl_UniCharToUtf(-1, p); - } - Tcl_DStringSetLength(dsPtr, oldLength + (p - string)); - - return string; -} -#endif /* *--------------------------------------------------------------------------- * * Tcl_UtfToUniChar -- * @@ -323,11 +356,11 @@ * looking for trail bytes. If the source buffer is known to be '\0' * terminated, this cannot happen. Otherwise, the caller should call * Tcl_UtfCharComplete() before calling this routine to ensure that * enough bytes remain in the string. * - * Special handling of Surrogate pairs is handled as follows: + * If TCL_UTF_MAX <= 4, special handling of Surrogate pairs is done: * For any UTF-8 string containing a character outside of the BMP, the * first call to this function will fill *chPtr with the high surrogate * and generate a return value of 1. Calling Tcl_UtfToUniChar again * will produce the low surrogate and a return value of 3. Because *chPtr * is used to remember whether the high surrogate is already produced, it @@ -342,167 +375,45 @@ * None. * *--------------------------------------------------------------------------- */ -static const unsigned short cp1252[32] = { - 0x20ac, 0x81, 0x201A, 0x0192, 0x201E, 0x2026, 0x2020, 0x2021, - 0x02C6, 0x2030, 0x0160, 0x2039, 0x0152, 0x8D, 0x017D, 0x8F, - 0x90, 0x2018, 0x2019, 0x201C, 0x201D, 0x2022, 0x2013, 0x2014, - 0x2DC, 0x2122, 0x0161, 0x203A, 0x0153, 0x9D, 0x017E, 0x0178 -}; - int Tcl_UtfToUniChar( - register const char *src, /* The UTF-8 string. */ - register Tcl_UniChar *chPtr)/* Filled with the Tcl_UniChar represented by + const char *src, /* The UTF-8 string. */ + Tcl_UniChar *chPtr)/* Filled with the Tcl_UniChar represented by * the UTF-8 string. */ { Tcl_UniChar byte; /* - * Unroll 1 to 4 byte UTF-8 sequences. + * Unroll 1 to 3 (or 4) byte UTF-8 sequences. */ - byte = *((unsigned char *) src); + byte = UCHAR(*src); if (byte < 0xC0) { /* * Handles properly formed UTF-8 characters between 0x01 and 0x7F. - * Treats naked trail bytes 0x80 to 0x9F as valid characters from - * the cp1252 table. See: - * Also treats \0 and other naked trail bytes 0xA0 to 0xBF as valid + * Also treats \0 and naked trail bytes 0x80 to 0xBF as valid * characters representing themselves. */ #if TCL_UTF_MAX <= 4 /* If *chPtr contains a high surrogate (produced by a previous * Tcl_UtfToUniChar() call) and the next 3 bytes are UTF-8 continuation * bytes, then we must produce a follow-up low surrogate. We only * do that if the high surrogate matches the bits we encounter. */ - if ((byte >= 0x80) - && (((((byte - 0x10) << 2) & 0xFC) | 0xD800) == (*chPtr & 0xFCFC)) - && ((src[1] & 0xF0) == (((*chPtr << 4) & 0x30) | 0x80)) - && ((src[2] & 0xC0) == 0x80)) { - *chPtr = ((src[1] & 0x0F) << 6) + (src[2] & 0x3F) + 0xDC00; - return 3; - } -#endif - if ((unsigned)(byte-0x80) < (unsigned)0x20) { - *chPtr = cp1252[byte-0x80]; - } else { - *chPtr = byte; - } - return 1; - } else if (byte < 0xE0) { - if ((src[1] & 0xC0) == 0x80) { - /* - * Two-byte-character lead-byte followed by a trail-byte. - */ - - *chPtr = (((byte & 0x1F) << 6) | (src[1] & 0x3F)); - if ((unsigned)(*chPtr - 1) >= (UNICODE_SELF - 1)) { - return 2; - } - } - - /* - * A two-byte-character lead-byte not followed by trail-byte - * represents itself. - */ - } else if (byte < 0xF0) { - if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80)) { - /* - * Three-byte-character lead byte followed by two trail bytes. - */ - - *chPtr = (((byte & 0x0F) << 12) - | ((src[1] & 0x3F) << 6) | (src[2] & 0x3F)); - if (*chPtr > 0x7FF) { - return 3; - } - } - - /* - * A three-byte-character lead-byte not followed by two trail-bytes - * represents itself. - */ - } - else if (byte < 0xF8) { - if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80) && ((src[3] & 0xC0) == 0x80)) { - /* - * Four-byte-character lead byte followed by three trail bytes. - */ -#if TCL_UTF_MAX <= 4 - Tcl_UniChar high = (((byte & 0x07) << 8) | ((src[1] & 0x3F) << 2) - | ((src[2] & 0x3F) >> 4)) - 0x40; - if (high >= 0x400) { - /* out of range, < 0x10000 or > 0x10ffff */ - } else { - /* produce high surrogate, advance source pointer */ - *chPtr = 0xD800 + high; - return 1; - } -#else - *chPtr = (((byte & 0x07) << 18) | ((src[1] & 0x3F) << 12) - | ((src[2] & 0x3F) << 6) | (src[3] & 0x3F)); - if ((unsigned)(*chPtr - 0x10000) <= 0xFFFFF) { - return 4; - } -#endif - } - - /* - * A four-byte-character lead-byte not followed by three trail-bytes - * represents itself. - */ - } - - *chPtr = byte; - return 1; -} - -#if (TCL_UTF_MAX > 4) && (defined(__CYGWIN__) || defined(_WIN32)) -int -TclUtfToWChar( - const char *src, /* The UTF-8 string. */ - WCHAR *chPtr)/* Filled with the WCHAR represented by - * the UTF-8 string. */ -{ - WCHAR byte; - - /* - * Unroll 1 to 4 byte UTF-8 sequences. - */ - - byte = *((unsigned char *) src); - if (byte < 0xC0) { - /* - * Handles properly formed UTF-8 characters between 0x01 and 0x7F. - * Treats naked trail bytes 0x80 to 0x9F as valid characters from - * the cp1252 table. See: - * Also treats \0 and other naked trail bytes 0xA0 to 0xBF as valid - * characters representing themselves. - */ - - /* If *chPtr contains a high surrogate (produced by a previous - * Tcl_UtfToUniChar() call) and the next 3 bytes are UTF-8 continuation - * bytes, then we must produce a follow-up low surrogate. We only - * do that if the high surrogate matches the bits we encounter. - */ - if ((byte >= 0x80) - && (((((byte - 0x10) << 2) & 0xFC) | 0xD800) == (*chPtr & 0xFCFC)) - && ((src[1] & 0xF0) == (((*chPtr << 4) & 0x30) | 0x80)) - && ((src[2] & 0xC0) == 0x80)) { - *chPtr = ((src[1] & 0x0F) << 6) + (src[2] & 0x3F) + 0xDC00; - return 3; - } - if ((unsigned)(byte-0x80) < (unsigned)0x20) { - *chPtr = cp1252[byte-0x80]; - } else { - *chPtr = byte; - } + 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 = ((src[1] & 0x0F) << 6) + (src[2] & 0x3F) + 0xDC00; + return 3; + } +#endif + *chPtr = byte; return 1; } else if (byte < 0xE0) { if ((src[1] & 0xC0) == 0x80) { /* * Two-byte-character lead-byte followed by a trail-byte. @@ -534,24 +445,34 @@ /* * A three-byte-character lead-byte not followed by two trail-bytes * represents itself. */ } - else if (byte < 0xF8) { - if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80) && ((src[3] & 0xC0) == 0x80)) { + else if (byte < 0xF5) { + if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80)) { /* - * Four-byte-character lead byte followed by three trail bytes. + * Four-byte-character lead byte followed by at least two trail bytes. + * We don't test the validity of 3th trail byte, see [ed29806ba] */ - WCHAR high = (((byte & 0x07) << 8) | ((src[1] & 0x3F) << 2) +#if TCL_UTF_MAX <= 4 + Tcl_UniChar high = (((byte & 0x07) << 8) | ((src[1] & 0x3F) << 2) | ((src[2] & 0x3F) >> 4)) - 0x40; - if (high >= 0x400) { - /* out of range, < 0x10000 or > 0x10ffff */ - } else { + if (high < 0x400) { /* produce high surrogate, advance source pointer */ *chPtr = 0xD800 + high; return 1; } + /* out of range, < 0x10000 or > 0x10FFFF */ +#else + if ((src[3] & 0xC0) == 0x80) { + *chPtr = (((byte & 0x07) << 18) | ((src[1] & 0x3F) << 12) + | ((src[2] & 0x3F) << 6) | (src[3] & 0x3F)); + if ((unsigned)(*chPtr - 0x10000) <= 0xFFFFF) { + return 4; + } + } +#endif } /* * A four-byte-character lead-byte not followed by three trail-bytes * represents itself. @@ -559,12 +480,11 @@ } *chPtr = byte; return 1; } -#endif - + /* *--------------------------------------------------------------------------- * * Tcl_UtfToUniCharDString -- * @@ -582,71 +502,23 @@ */ Tcl_UniChar * Tcl_UtfToUniCharDString( const char *src, /* UTF-8 string to convert to Unicode. */ - size_t length, /* Length of UTF-8 string in bytes, or -1 for + int length, /* Length of UTF-8 string in bytes, or -1 for * strlen(). */ Tcl_DString *dsPtr) /* Unicode representation of string is * appended to this previously initialized * DString. */ { Tcl_UniChar ch = 0, *w, *wString; - const char *p, *end; - size_t oldLength; - - if (length == TCL_AUTO_LENGTH) { - length = strlen(src); - } - - /* - * Unicode string length in Tcl_UniChars will be <= UTF-8 string length in - * bytes. - */ - - oldLength = Tcl_DStringLength(dsPtr); - - Tcl_DStringSetLength(dsPtr, - oldLength + (int) ((length + 1) * sizeof(Tcl_UniChar))); - wString = (Tcl_UniChar *) (Tcl_DStringValue(dsPtr) + oldLength); - - w = wString; - p = src; - end = src + length - 4; - while (p < end) { - p += TclUtfToUniChar(p, &ch); - *w++ = ch; - } - end += 4; - while (p < end) { - if (Tcl_UtfCharComplete(p, end-p)) { - p += TclUtfToUniChar(p, &ch); - } else { - ch = UCHAR(*p++); - } - *w++ = ch; - } - *w = '\0'; - Tcl_DStringSetLength(dsPtr, - oldLength + ((char *) w - (char *) wString)); - - return wString; -} - -#if (TCL_UTF_MAX > 4) && (defined(__CYGWIN__) || defined(_WIN32)) -WCHAR * -TclUtfToWCharDString( - const char *src, /* UTF-8 string to convert to Unicode. */ - int length, /* Length of UTF-8 string in bytes, or -1 for - * strlen(). */ - Tcl_DString *dsPtr) /* Unicode representation of string is - * appended to this previously initialized - * DString. */ -{ - WCHAR ch = 0, *w, *wString; - const char *p, *end; + const char *p; int oldLength; + /* Pointer to the end of string. Never read endPtr[0] */ + const char *endPtr = src + length; + /* Pointer to last byte where optimization still can be used */ + const char *optPtr = endPtr - TCL_UTF_MAX; if (length < 0) { length = strlen(src); } @@ -656,36 +528,36 @@ */ oldLength = Tcl_DStringLength(dsPtr); Tcl_DStringSetLength(dsPtr, - oldLength + (int) ((length + 1) * sizeof(WCHAR))); - wString = (WCHAR *) (Tcl_DStringValue(dsPtr) + oldLength); + oldLength + ((length + 1) * sizeof(Tcl_UniChar))); + wString = (Tcl_UniChar *) (Tcl_DStringValue(dsPtr) + oldLength); w = wString; p = src; - end = src + length - 4; - while (p < end) { - p += TclUtfToWChar(p, &ch); + endPtr = src + length; + optPtr = endPtr - TCL_UTF_MAX; + while (p <= optPtr) { + p += TclUtfToUniChar(p, &ch); *w++ = ch; } - end += 4; - while (p < end) { - if (Tcl_UtfCharComplete(p, end-p)) { - p += TclUtfToWChar(p, &ch); + while (p < endPtr) { + if (Tcl_UtfCharComplete(p, endPtr-p)) { + p += TclUtfToUniChar(p, &ch); + *w++ = ch; } else { - ch = UCHAR(*p++); + *w++ = UCHAR(*p++); } - *w++ = ch; } *w = '\0'; Tcl_DStringSetLength(dsPtr, oldLength + ((char *) w - (char *) wString)); return wString; } -#endif + /* *--------------------------------------------------------------------------- * * Tcl_UtfCharComplete -- * @@ -705,13 +577,13 @@ int Tcl_UtfCharComplete( const char *src, /* String to check if first few bytes contain * a complete UTF-8 character. */ - size_t length) /* Length of above string in bytes. */ + int length) /* Length of above string in bytes. */ { - return length >= totalBytes[(unsigned char)*src]; + return length >= complete[UCHAR(*src)]; } /* *--------------------------------------------------------------------------- * @@ -728,45 +600,57 @@ * None. * *--------------------------------------------------------------------------- */ -size_t +int Tcl_NumUtfChars( - register const char *src, /* The UTF-8 string to measure. */ - size_t length) /* The length of the string in bytes, or -1 - * for strlen(string). */ + const char *src, /* The UTF-8 string to measure. */ + int length) /* The length of the string in bytes, or -1 + * for strlen(string). */ { Tcl_UniChar ch = 0; - register size_t i = 0; - - /* - * The separate implementations are faster. - * - * Since this is a time-sensitive function, we also do the check for the - * single-byte char case specially. - */ - - if (length == TCL_AUTO_LENGTH) { - while (*src != '\0') { + int i = 0; + + if (length < 0) { + /* string is NUL-terminated, so TclUtfToUniChar calls are safe. */ + while ((*src != '\0') && (i < INT_MAX)) { src += TclUtfToUniChar(src, &ch); i++; } } else { - register const char *endPtr = src + length - 4; - - while (src < endPtr) { - src += TclUtfToUniChar(src, &ch); - i++; - } - endPtr += 4; - while ((src < endPtr) && Tcl_UtfCharComplete(src, endPtr - src)) { + /* Will return value between 0 and length. No overflow checks. */ + + /* Pointer to the end of string. Never read endPtr[0] */ + const char *endPtr = src + length; + /* Pointer to last byte where optimization still can be used */ + const char *optPtr = endPtr - TCL_UTF_MAX; + + /* + * Optimize away the call in this loop. Justified because... + * when (src <= optPtr), (endPtr - src) >= (endPtr - optPtr) + * By initialization above (endPtr - optPtr) = TCL_UTF_MAX + * So (endPtr - src) >= TCL_UTF_MAX, and passing that to + * Tcl_UtfCharComplete we know will cause return of 1. + */ + while (src <= optPtr + /* && Tcl_UtfCharComplete(src, endPtr - src) */ ) { src += TclUtfToUniChar(src, &ch); i++; } - if (src < endPtr) { - i += endPtr - src; + /* Loop over the remaining string where call must happen */ + while (src < endPtr) { + if (Tcl_UtfCharComplete(src, endPtr - src)) { + src += TclUtfToUniChar(src, &ch); + } else { + /* + * src points to incomplete UTF-8 sequence + * Treat first byte as character and count it + */ + src++; + } + i++; } } return i; } @@ -773,11 +657,11 @@ /* *--------------------------------------------------------------------------- * * Tcl_UtfFindFirst -- * - * Returns a pointer to the first occurance of the given Unicode character + * Returns a pointer to the first occurrence of the given Unicode character * in the NULL-terminated UTF-8 string. The NULL terminator is considered * part of the UTF-8 string. Equivalent to Plan 9 utfrune(). * * Results: * As above. If the Unicode character does not exist in the given string, @@ -792,24 +676,14 @@ const char * Tcl_UtfFindFirst( const char *src, /* The UTF-8 string to be searched. */ int ch) /* The Unicode character to search for. */ { - size_t len; - int fullchar; - Tcl_UniChar find = 0; - while (1) { - len = TclUtfToUniChar(src, &find); - fullchar = find; -#if TCL_UTF_MAX <= 4 - if ((ch >= 0xD800) && (len < 3)) { - len += TclUtfToUniChar(src + len, &find); - fullchar = (((fullchar & 0x3ff) << 10) | (find & 0x3ff)) + 0x10000; - } -#endif - if (fullchar == ch) { + int find, len = TclUtfToUCS4(src, &find); + + if (find == ch) { return src; } if (*src == '\0') { return NULL; } @@ -820,11 +694,11 @@ /* *--------------------------------------------------------------------------- * * Tcl_UtfFindLast -- * - * Returns a pointer to the last occurance of the given Unicode character + * Returns a pointer to the last occurrence of the given Unicode character * in the NULL-terminated UTF-8 string. The NULL terminator is considered * part of the UTF-8 string. Equivalent to Plan 9 utfrrune(). * * Results: * As above. If the Unicode character does not exist in the given string, the @@ -839,26 +713,16 @@ const char * Tcl_UtfFindLast( const char *src, /* The UTF-8 string to be searched. */ int ch) /* The Unicode character to search for. */ { - size_t len; - int fullchar; - Tcl_UniChar find = 0; - const char *last; + const char *last = NULL; - last = NULL; while (1) { - len = TclUtfToUniChar(src, &find); - fullchar = find; -#if TCL_UTF_MAX <= 4 - if ((ch >= 0xD800) && (len < 3)) { - len += TclUtfToUniChar(src + len, &find); - fullchar = (((fullchar & 0x3ff) << 10) | (find & 0x3ff)) + 0x10000; - } -#endif - if (fullchar == ch) { + int find, len = TclUtfToUCS4(src, &find); + + if (find == ch) { last = src; } if (*src == '\0') { break; } @@ -870,13 +734,15 @@ /* *--------------------------------------------------------------------------- * * Tcl_UtfNext -- * - * Given a pointer to some current location in a UTF-8 string, move - * forward one character. The caller must ensure that they are not asking - * for the next character after the last character in the string. + * Given a pointer to some location in a UTF-8 string, Tcl_UtfNext + * returns a pointer to the next UTF-8 character in the string. + * The caller must not ask for the next character after the last + * character in the string if the string is not terminated by a null + * character. * * Results: * The return value is the pointer to the next character in the UTF-8 * string. * @@ -888,19 +754,37 @@ const char * Tcl_UtfNext( const char *src) /* The current location in the string. */ { - Tcl_UniChar ch = 0; - size_t len = TclUtfToUniChar(src, &ch); - -#if TCL_UTF_MAX <= 4 - if ((ch >= 0xD800) && (len < 3)) { - len += TclUtfToUniChar(src + len, &ch); - } -#endif - return src + len; + int left; + const char *next; + + left = totalBytes[UCHAR(*src)]; + next = src + 1; + while (--left) { + if ((*next & 0xC0) != 0x80) { + /* + * src points to non-trail byte; We ran out of trail bytes + * before the needs of the lead byte were satisfied. + * Let the (malformed) lead byte alone be a character + */ + return src + 1; + } + next++; + } + /* + * Call Invalid() here only if required conditions are met: + * src[0] is known a lead byte. + * src[1] is known a trail byte. + * Especially important to prevent calls when src[0] == '\xF8' or '\xFC' + * See tests utf-6.37 through utf-6.43 through valgrind or similar tool. + */ + if ((next == src + 1) || Invalid(src)) { + return src + 1; + } + return next; } /* *--------------------------------------------------------------------------- * @@ -922,35 +806,99 @@ *--------------------------------------------------------------------------- */ const char * Tcl_UtfPrev( - const char *src, /* The current location in the string. */ - const char *start) /* Pointer to the beginning of the string, to - * avoid going backwards too far. */ -{ - const char *look; - int i, byte; - - look = --src; - for (i = 0; i < 4; i++) { - if (look < start) { - if (src < start) { - src = start; - } - break; - } - byte = *((unsigned char *) look); + const char *src, /* A location in a UTF-8 string. */ + const char *start) /* Pointer to the beginning of the string */ +{ + int trailBytesSeen = 0; /* How many trail bytes have been verified? */ + const char *fallback = src - 1; + /* If we cannot find a lead byte that might + * start a prefix of a valid UTF byte sequence, + * we will fallback to a one-byte back step */ + const char *look = fallback; + /* Start search at the fallback position */ + + /* Quick boundary case exit. */ + if (fallback <= start) { + return start; + } + + do { + unsigned char byte = UCHAR(look[0]); + if (byte < 0x80) { - break; + /* + * Single byte character. Either this is a correct previous + * character, or it is followed by at least one trail byte + * which indicates a malformed sequence. In either case the + * correct result is to return the fallback. + */ + return fallback; } if (byte >= 0xC0) { - return look; + /* Non-trail byte; May be multibyte lead. */ + + if ((trailBytesSeen == 0) + /* + * We've seen no trailing context to use to check + * anything. From what we know, this non-trail byte + * is a prefix of a previous character, and accepting + * it (the fallback) is correct. + */ + + || (trailBytesSeen >= totalBytes[byte])) { + /* + * That is, (1 + trailBytesSeen > needed). + * We've examined more bytes than needed to complete + * this lead byte. No matter about well-formedness or + * validity, the sequence starting with this lead byte + * will never include the fallback location, so we must + * return the fallback location. See test utf-7.17 + */ + return fallback; + } + + /* + * trailBytesSeen > 0, so we can examine look[1] safely. + * Use that capability to screen out invalid sequences. + */ + + if (Invalid(look)) { + /* Reject */ + return fallback; + } + return (const char *)look; + } + + /* We saw a trail byte. */ + trailBytesSeen++; + + if ((const char *)look == start) { + /* + * Do not read before the start of the string + * + * If we get here, we've examined bytes at every location + * >= start and < src and all of them are trail bytes, + * including (*start). We need to return our fallback + * and exit this loop before we run past the start of the string. + */ + return fallback; } + + /* Continue the search backwards... */ look--; - } - return src; + } while (trailBytesSeen < 3); + + /* + * We've seen 3 trail bytes, so we know there will not be a + * properly formed byte sequence to find, and we can stop looking, + * accepting the fallback. + */ + + return fallback; } /* *--------------------------------------------------------------------------- * @@ -966,49 +914,30 @@ * None. * *--------------------------------------------------------------------------- */ -int +Tcl_UniChar Tcl_UniCharAtIndex( - register const char *src, /* The UTF-8 string to dereference. */ - register size_t index) /* The position of the desired character. */ + const char *src, /* The UTF-8 string to dereference. */ + int index) /* The position of the desired character. */ { Tcl_UniChar ch = 0; - int fullchar = 0; -#if TCL_UTF_MAX <= 4 - size_t len = 0; -#endif - - src += TclUtfToUniChar(src, &ch); - while (index--) { -#if TCL_UTF_MAX <= 4 - src += (len = TclUtfToUniChar(src, &ch)); -#else - src += TclUtfToUniChar(src, &ch); -#endif - } - fullchar = ch; -#if TCL_UTF_MAX <= 4 - if ((ch >= 0xD800) && (len < 3)) { - /* If last Tcl_UniChar was a high surrogate, combine with low surrogate */ - (void)TclUtfToUniChar(src, &ch); - fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; - } -#endif - return fullchar; + + while (index-- >= 0) { + src += TclUtfToUniChar(src, &ch); + } + return ch; } /* *--------------------------------------------------------------------------- * * Tcl_UtfAtIndex -- * * Returns a pointer to the specified character (not byte) position in - * the UTF-8 string. If TCL_UTF_MAX <= 4, characters > U+FFFF count as - * 2 positions, but then the pointer should never be placed between - * the two positions. + * the UTF-8 string. * * Results: * As above. * * Side effects: @@ -1017,33 +946,26 @@ *--------------------------------------------------------------------------- */ const char * Tcl_UtfAtIndex( - register const char *src, /* The UTF-8 string. */ - register size_t index) /* The position of the desired character. */ + const char *src, /* The UTF-8 string. */ + int index) /* The position of the desired character. */ { Tcl_UniChar ch = 0; -#if TCL_UTF_MAX <= 4 - size_t len = 0; -#endif - - if (index != TCL_INDEX_NONE) { - while (index--) { -#if TCL_UTF_MAX <= 4 - src += (len = TclUtfToUniChar(src, &ch)); -#else - src += TclUtfToUniChar(src, &ch); -#endif - } -#if TCL_UTF_MAX <= 4 + int len = 0; + + while (index-- > 0) { + len = TclUtfToUniChar(src, &ch); + src += len; + } +#if TCL_UTF_MAX == 4 if ((ch >= 0xD800) && (len < 3)) { /* Index points at character following high Surrogate */ src += TclUtfToUniChar(src, &ch); } #endif - } return src; } /* *--------------------------------------------------------------------------- @@ -1069,21 +991,22 @@ * buffer overruns should occur. * *--------------------------------------------------------------------------- */ -size_t +int Tcl_UtfBackslash( const char *src, /* Points to the backslash character of a * backslash sequence. */ int *readPtr, /* Fill in with number of characters read from * src, unless NULL. */ char *dst) /* Filled with the bytes represented by the * backslash sequence. */ { #define LINE_LENGTH 128 - size_t numRead, result; + int numRead; + int result; result = TclParseBackslash(src, LINE_LENGTH, &numRead, dst); if (numRead == LINE_LENGTH) { /* * We ate a whole line. Pay the price of a strlen() @@ -1117,43 +1040,34 @@ int Tcl_UtfToUpper( char *str) /* String to convert in place. */ { - Tcl_UniChar ch = 0; - int upChar; + int ch, upChar; char *src, *dst; - size_t len; + int len; /* * Iterate over the string until we hit the terminating null. */ src = dst = str; while (*src) { - len = TclUtfToUniChar(src, &ch); - upChar = ch; -#if TCL_UTF_MAX <= 4 - if ((ch >= 0xD800) && (len < 3)) { - len += TclUtfToUniChar(src + len, &ch); - /* Combine surrogates */ - upChar = (((upChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; - } -#endif - upChar = Tcl_UniCharToUpper(upChar); + len = TclUtfToUCS4(src, &ch); + upChar = UCS4ToUpper(ch); /* * To keep badly formed Utf strings from getting inflated by the * conversion (thereby causing a segfault), only copy the upper case * char to dst if its size is <= the original char. */ - if ((len < TclUtfCount(upChar)) || ((upChar & 0xF800) == 0xD800)) { + if (len < UtfCount(upChar)) { memmove(dst, src, len); dst += len; } else { - dst += Tcl_UniCharToUtf(upChar, dst); + dst += TclUCS4ToUtf(upChar, dst); } src += len; } *dst = '\0'; return (dst - str); @@ -1179,43 +1093,34 @@ int Tcl_UtfToLower( char *str) /* String to convert in place. */ { - Tcl_UniChar ch = 0; - int lowChar; + int ch, lowChar; char *src, *dst; - size_t len; + int len; /* * Iterate over the string until we hit the terminating null. */ src = dst = str; while (*src) { - len = TclUtfToUniChar(src, &ch); - lowChar = ch; -#if TCL_UTF_MAX <= 4 - if ((ch >= 0xD800) && (len < 3)) { - len += TclUtfToUniChar(src + len, &ch); - /* Combine surrogates */ - lowChar = (((lowChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; - } -#endif - lowChar = Tcl_UniCharToLower(lowChar); + len = TclUtfToUCS4(src, &ch); + lowChar = TclUCS4ToLower(ch); /* * To keep badly formed Utf strings from getting inflated by the * conversion (thereby causing a segfault), only copy the lower case * char to dst if its size is <= the original char. */ - if ((len < TclUtfCount(lowChar)) || ((lowChar & 0xF800) == 0xD800)) { + if (len < UtfCount(lowChar)) { memmove(dst, src, len); dst += len; } else { - dst += Tcl_UniCharToUtf(lowChar, dst); + dst += TclUCS4ToUtf(lowChar, dst); } src += len; } *dst = '\0'; return (dst - str); @@ -1242,62 +1147,46 @@ int Tcl_UtfToTitle( char *str) /* String to convert in place. */ { - Tcl_UniChar ch = 0; - int titleChar, lowChar; + int ch, titleChar, lowChar; char *src, *dst; - size_t len; + int len; /* * Capitalize the first character and then lowercase the rest of the * characters until we get to a null. */ src = dst = str; if (*src) { - len = TclUtfToUniChar(src, &ch); - titleChar = ch; -#if TCL_UTF_MAX <= 4 - if ((ch >= 0xD800) && (len < 3)) { - len += TclUtfToUniChar(src + len, &ch); - /* Combine surrogates */ - titleChar = (((titleChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; - } -#endif - titleChar = Tcl_UniCharToTitle(titleChar); - - if ((len < TclUtfCount(titleChar)) || ((titleChar & 0xF800) == 0xD800)) { + len = TclUtfToUCS4(src, &ch); + titleChar = UCS4ToTitle(ch); + + if (len < UtfCount(titleChar)) { memmove(dst, src, len); dst += len; } else { - dst += Tcl_UniCharToUtf(titleChar, dst); + dst += TclUCS4ToUtf(titleChar, dst); } src += len; } while (*src) { - len = TclUtfToUniChar(src, &ch); + len = TclUtfToUCS4(src, &ch); lowChar = ch; -#if TCL_UTF_MAX <= 4 - if ((ch >= 0xD800) && (len < 3)) { - len += TclUtfToUniChar(src + len, &ch); - /* Combine surrogates */ - lowChar = (((lowChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; - } -#endif /* Special exception for Georgian Asomtavruli chars, no titlecase. */ if ((unsigned)(lowChar - 0x1C90) >= 0x30) { - lowChar = Tcl_UniCharToLower(lowChar); + lowChar = TclUCS4ToLower(lowChar); } - if ((len < TclUtfCount(lowChar)) || ((lowChar & 0xF800) == 0xD800)) { + if (len < UtfCount(lowChar)) { memmove(dst, src, len); dst += len; } else { - dst += Tcl_UniCharToUtf(lowChar, dst); + dst += TclUCS4ToUtf(lowChar, dst); } src += len; } *dst = '\0'; return (dst - str); @@ -1322,19 +1211,19 @@ int TclpUtfNcmp2( const char *cs, /* UTF string to compare to ct. */ const char *ct, /* UTF string cs is compared to. */ - size_t numBytes) /* Number of *bytes* to compare. */ + unsigned long numBytes) /* Number of *bytes* to compare. */ { /* * We can't simply call 'memcmp(cs, ct, numBytes);' because we need to * check for Tcl's \xC0\x80 non-utf-8 null encoding. Otherwise utf-8 lexes * fine in the strcmp manner. */ - register int result = 0; + int result = 0; for ( ; numBytes != 0; numBytes--, cs++, ct++) { if (*cs != *ct) { result = UCHAR(*cs) - UCHAR(*ct); break; @@ -1369,11 +1258,11 @@ int Tcl_UtfNcmp( const char *cs, /* UTF string to compare to ct. */ const char *ct, /* UTF string cs is compared to. */ - size_t numChars) /* Number of UTF chars to compare. */ + unsigned long numChars) /* Number of UTF chars to compare. */ { Tcl_UniChar ch1 = 0, ch2 = 0; /* * Cannot use 'memcmp(cs, ct, n);' as byte representation of \u0000 (the @@ -1389,17 +1278,17 @@ */ cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); if (ch1 != ch2) { -#if TCL_UTF_MAX <= 4 +#if TCL_UTF_MAX == 4 /* Surrogates always report higher than non-surrogates */ - if (((ch1 & 0xFC00) == 0xD800)) { - if ((ch2 & 0xFC00) != 0xD800) { + if (((ch1 & ~0x3FF) == 0xD800)) { + if ((ch2 & ~0x3FF) != 0xD800) { return ch1; } - } else if ((ch2 & 0xFC00) == 0xD800) { + } else if ((ch2 & ~0x3FF) == 0xD800) { return -ch2; } #endif return (ch1 - ch2); } @@ -1427,11 +1316,11 @@ int Tcl_UtfNcasecmp( const char *cs, /* UTF string to compare to ct. */ const char *ct, /* UTF string cs is compared to. */ - size_t numChars) /* Number of UTF chars to compare. */ + unsigned long numChars) /* Number of UTF chars to compare. */ { Tcl_UniChar ch1 = 0, ch2 = 0; while (numChars-- > 0) { /* @@ -1440,11 +1329,11 @@ * at least n chars long (no need for \0 check) */ cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); if (ch1 != ch2) { -#if TCL_UTF_MAX <= 4 +#if TCL_UTF_MAX == 4 /* Surrogates always report higher than non-surrogates */ if (((ch1 & 0xFC00) == 0xD800)) { if ((ch2 & 0xFC00) != 0xD800) { return ch1; } @@ -1459,56 +1348,10 @@ } } } return 0; } - -/* - *---------------------------------------------------------------------- - * - * Tcl_UtfCmp -- - * - * Compare UTF chars of string cs to string ct case sensitively. - * Replacement for strcmp in Tcl core, in places where UTF-8 should - * be handled. - * - * Results: - * Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclUtfCmp( - const char *cs, /* UTF string to compare to ct. */ - const char *ct) /* UTF string cs is compared to. */ -{ - Tcl_UniChar ch1 = 0, ch2 = 0; - - while (*cs && *ct) { - cs += TclUtfToUniChar(cs, &ch1); - ct += TclUtfToUniChar(ct, &ch2); - if (ch1 != ch2) { -#if TCL_UTF_MAX <= 4 - /* Surrogates always report higher than non-surrogates */ - if (((ch1 & 0xFC00) == 0xD800)) { - if ((ch2 & 0xFC00) != 0xD800) { - return ch1; - } - } else if ((ch2 & 0xFC00) == 0xD800) { - return -ch2; - } -#endif - return ch1 - ch2; - } - } - return UCHAR(*cs) - UCHAR(*ct); -} - /* *---------------------------------------------------------------------- * * TclUtfCasecmp -- @@ -1535,11 +1378,11 @@ while (*cs && *ct) { cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); if (ch1 != ch2) { -#if TCL_UTF_MAX <= 4 +#if TCL_UTF_MAX == 4 /* Surrogates always report higher than non-surrogates */ if (((ch1 & 0xFC00) == 0xD800)) { if ((ch2 & 0xFC00) != 0xD800) { return ch1; } @@ -1572,23 +1415,31 @@ * None. * *---------------------------------------------------------------------- */ -int -Tcl_UniCharToUpper( +static int +UCS4ToUpper( int ch) /* Unicode character to convert. */ { if (!UNICODE_OUT_OF_RANGE(ch)) { int info = GetUniCharInfo(ch); if (GetCaseType(info) & 0x04) { ch -= GetDelta(info); } } + /* Clear away extension bits, if any */ return ch & 0x1FFFFF; } + +Tcl_UniChar +Tcl_UniCharToUpper( + int ch) /* Unicode character to convert. */ +{ + return (Tcl_UniChar) UCS4ToUpper(ch); +} /* *---------------------------------------------------------------------- * * Tcl_UniCharToLower -- @@ -1603,11 +1454,11 @@ * *---------------------------------------------------------------------- */ int -Tcl_UniCharToLower( +TclUCS4ToLower( int ch) /* Unicode character to convert. */ { if (!UNICODE_OUT_OF_RANGE(ch)) { int info = GetUniCharInfo(ch); int mode = GetCaseType(info); @@ -1614,12 +1465,20 @@ if ((mode & 0x02) && (mode != 0x7)) { ch += GetDelta(info); } } + /* Clear away extension bits, if any */ return ch & 0x1FFFFF; } + +Tcl_UniChar +Tcl_UniCharToLower( + int ch) /* Unicode character to convert. */ +{ + return (Tcl_UniChar) TclUCS4ToLower(ch); +} /* *---------------------------------------------------------------------- * * Tcl_UniCharToTitle -- @@ -1633,12 +1492,12 @@ * None. * *---------------------------------------------------------------------- */ -int -Tcl_UniCharToTitle( +static int +UCS4ToTitle( int ch) /* Unicode character to convert. */ { if (!UNICODE_OUT_OF_RANGE(ch)) { int info = GetUniCharInfo(ch); int mode = GetCaseType(info); @@ -1653,12 +1512,20 @@ } } else if (mode == 0x4) { ch -= GetDelta(info); } } + /* Clear away extension bits, if any */ return ch & 0x1FFFFF; } + +Tcl_UniChar +Tcl_UniCharToTitle( + int ch) /* Unicode character to convert. */ +{ + return (Tcl_UniChar) UCS4ToTitle(ch); +} /* *---------------------------------------------------------------------- * * Tcl_UniCharLen -- @@ -1673,15 +1540,15 @@ * None. * *---------------------------------------------------------------------- */ -size_t +int Tcl_UniCharLen( const Tcl_UniChar *uniStr) /* Unicode string to find length of. */ { - size_t len = 0; + int len = 0; while (*uniStr != '\0') { len++; uniStr++; } @@ -1707,11 +1574,11 @@ int Tcl_UniCharNcmp( const Tcl_UniChar *ucs, /* Unicode string to compare to uct. */ const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */ - size_t numChars) /* Number of unichars to compare. */ + unsigned long numChars) /* Number of unichars to compare. */ { #ifdef WORDS_BIGENDIAN /* * We are definitely on a big-endian machine; memcmp() is safe */ @@ -1752,11 +1619,11 @@ int Tcl_UniCharNcasecmp( const Tcl_UniChar *ucs, /* Unicode string to compare to uct. */ const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */ - size_t numChars) /* Number of unichars to compare. */ + unsigned long numChars) /* Number of unichars to compare. */ { for ( ; numChars != 0; numChars--, ucs++, uct++) { if (*ucs != *uct) { Tcl_UniChar lcs = Tcl_UniCharToLower(*ucs); Tcl_UniChar lct = Tcl_UniCharToLower(*uct); @@ -1787,13 +1654,15 @@ int Tcl_UniCharIsAlnum( int ch) /* Unicode character to test. */ { +#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { return 0; } +#endif return (((ALPHA_BITS | DIGIT_BITS) >> GetCategory(ch)) & 1); } /* *---------------------------------------------------------------------- @@ -1813,13 +1682,15 @@ int Tcl_UniCharIsAlpha( int ch) /* Unicode character to test. */ { +#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { return 0; } +#endif return ((ALPHA_BITS >> GetCategory(ch)) & 1); } /* *---------------------------------------------------------------------- @@ -1839,20 +1710,23 @@ int Tcl_UniCharIsControl( int ch) /* Unicode character to test. */ { +#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { + /* Clear away extension bits, if any */ ch &= 0x1FFFFF; - if ((ch == 0xE0001) || ((ch >= 0xE0020) && (ch <= 0xE007f))) { + if ((ch == 0xE0001) || ((ch >= 0xE0020) && (ch <= 0xE007F))) { return 1; } if ((ch >= 0xF0000) && ((ch & 0xFFFF) <= 0xFFFD)) { return 1; } return 0; } +#endif return ((CONTROL_BITS >> GetCategory(ch)) & 1); } /* *---------------------------------------------------------------------- @@ -1872,13 +1746,15 @@ int Tcl_UniCharIsDigit( int ch) /* Unicode character to test. */ { +#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { return 0; } +#endif return (GetCategory(ch) == DECIMAL_DIGIT_NUMBER); } /* *---------------------------------------------------------------------- @@ -1898,14 +1774,15 @@ int Tcl_UniCharIsGraph( int ch) /* Unicode character to test. */ { +#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { - ch &= 0x1FFFFF; - return (ch >= 0xE0100) && (ch <= 0xE01EF); + return ((unsigned)((ch & 0x1FFFFF) - 0xE0100) <= 0xEF); } +#endif return ((GRAPH_BITS >> GetCategory(ch)) & 1); } /* *---------------------------------------------------------------------- @@ -1925,13 +1802,15 @@ int Tcl_UniCharIsLower( int ch) /* Unicode character to test. */ { +#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { return 0; } +#endif return (GetCategory(ch) == LOWERCASE_LETTER); } /* *---------------------------------------------------------------------- @@ -1951,14 +1830,15 @@ int Tcl_UniCharIsPrint( int ch) /* Unicode character to test. */ { +#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { - ch &= 0x1FFFFF; - return (ch >= 0xE0100) && (ch <= 0xE01EF); + return ((unsigned)((ch & 0x1FFFFF) - 0xE0100) <= 0xEF); } +#endif return (((GRAPH_BITS|SPACE_BITS) >> GetCategory(ch)) & 1); } /* *---------------------------------------------------------------------- @@ -1978,13 +1858,15 @@ int Tcl_UniCharIsPunct( int ch) /* Unicode character to test. */ { +#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { return 0; } +#endif return ((PUNCT_BITS >> GetCategory(ch)) & 1); } /* *---------------------------------------------------------------------- @@ -2004,22 +1886,29 @@ int Tcl_UniCharIsSpace( int ch) /* Unicode character to test. */ { +#if TCL_UTF_MAX > 3 /* Ignore upper 11 bits. */ ch &= 0x1FFFFF; +#else + /* Ignore upper 16 bits. */ + ch &= 0xFFFF; +#endif /* * If the character is within the first 127 characters, just use the * standard C function, otherwise consult the Unicode table. */ if (ch < 0x80) { - return TclIsSpaceProc((char) ch); + return TclIsSpaceProcM((char) ch); +#if TCL_UTF_MAX > 3 } else if (UNICODE_OUT_OF_RANGE(ch)) { return 0; +#endif } else if (ch == 0x0085 || ch == 0x180E || ch == 0x200B || ch == 0x202F || ch == 0x2060 || ch == 0xFEFF) { return 1; } else { return ((SPACE_BITS >> GetCategory(ch)) & 1); @@ -2044,13 +1933,15 @@ int Tcl_UniCharIsUpper( int ch) /* Unicode character to test. */ { +#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { return 0; } +#endif return (GetCategory(ch) == UPPERCASE_LETTER); } /* *---------------------------------------------------------------------- @@ -2070,13 +1961,15 @@ int Tcl_UniCharIsWordChar( int ch) /* Unicode character to test. */ { +#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { return 0; } +#endif return ((WORD_BITS >> GetCategory(ch)) & 1); } /* *---------------------------------------------------------------------- @@ -2158,11 +2051,11 @@ */ if ((p != '[') && (p != '?') && (p != '\\')) { if (nocase) { while (*uniStr && (p != *uniStr) - && (p != (Tcl_UniChar)Tcl_UniCharToLower(*uniStr))) { + && (p != Tcl_UniCharToLower(*uniStr))) { uniStr++; } } else { while (*uniStr && (p != *uniStr)) { uniStr++; @@ -2198,25 +2091,25 @@ if (p == '[') { Tcl_UniChar startChar, endChar; uniPattern++; - ch1 = (nocase ? (Tcl_UniChar)Tcl_UniCharToLower(*uniStr) : *uniStr); + ch1 = (nocase ? Tcl_UniCharToLower(*uniStr) : *uniStr); uniStr++; while (1) { if ((*uniPattern == ']') || (*uniPattern == 0)) { return 0; } - startChar = (nocase ? (Tcl_UniChar)Tcl_UniCharToLower(*uniPattern) + startChar = (nocase ? Tcl_UniCharToLower(*uniPattern) : *uniPattern); uniPattern++; if (*uniPattern == '-') { uniPattern++; if (*uniPattern == 0) { return 0; } - endChar = (nocase ? (Tcl_UniChar)Tcl_UniCharToLower(*uniPattern) + endChar = (nocase ? Tcl_UniCharToLower(*uniPattern) : *uniPattern); uniPattern++; if (((startChar <= ch1) && (ch1 <= endChar)) || ((endChar <= ch1) && (ch1 <= startChar))) { /* @@ -2290,14 +2183,14 @@ */ int TclUniCharMatch( const Tcl_UniChar *string, /* Unicode String. */ - size_t strLen, /* Length of String */ + int strLen, /* Length of String */ const Tcl_UniChar *pattern, /* Pattern, which may contain special * characters. */ - size_t ptnLen, /* Length of Pattern */ + int ptnLen, /* Length of Pattern */ int nocase) /* 0 for case sensitive, 1 for insensitive */ { const Tcl_UniChar *stringEnd, *patternEnd; Tcl_UniChar p; @@ -2350,11 +2243,11 @@ */ if ((p != '[') && (p != '?') && (p != '\\')) { if (nocase) { while ((string < stringEnd) && (p != *string) - && (p != (Tcl_UniChar)Tcl_UniCharToLower(*string))) { + && (p != Tcl_UniCharToLower(*string))) { string++; } } else { while ((string < stringEnd) && (p != *string)) { string++; @@ -2391,24 +2284,24 @@ if (p == '[') { Tcl_UniChar ch1, startChar, endChar; pattern++; - ch1 = (nocase ? (Tcl_UniChar)Tcl_UniCharToLower(*string) : *string); + ch1 = (nocase ? Tcl_UniCharToLower(*string) : *string); string++; while (1) { if ((*pattern == ']') || (pattern == patternEnd)) { return 0; } - startChar = (nocase ? (Tcl_UniChar)Tcl_UniCharToLower(*pattern) : *pattern); + startChar = (nocase ? Tcl_UniCharToLower(*pattern) : *pattern); pattern++; if (*pattern == '-') { pattern++; if (pattern == patternEnd) { return 0; } - endChar = (nocase ? (Tcl_UniChar)Tcl_UniCharToLower(*pattern) + endChar = (nocase ? Tcl_UniCharToLower(*pattern) : *pattern); pattern++; if (((startChar <= ch1) && (ch1 <= endChar)) || ((endChar <= ch1) && (ch1 <= startChar))) { /* @@ -2457,12 +2350,125 @@ string++; pattern++; } } +/* + *--------------------------------------------------------------------------- + * + * TclUtfToUCS4 -- + * + * Extract the 4-byte codepoint from the leading bytes of the + * Modified UTF-8 string "src". This is a utility routine to + * contain the surrogate gymnastics in one place. + * + * The caller must ensure that the source buffer is long enough that this + * routine does not run off the end and dereference non-existent memory + * looking for trail bytes. If the source buffer is known to be '\0' + * terminated, this cannot happen. Otherwise, the caller should call + * TclUCS4Complete() before calling this routine to ensure that + * enough bytes remain in the string. + * + * Results: + * *usc4Ptr is filled with the UCS4 code point, and the return value is + * the number of bytes from the UTF-8 string that were consumed. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +int +TclUtfToUCS4( + const char *src, /* The UTF-8 string. */ + int *ucs4Ptr) /* Filled with the UCS4 codepoint represented + * by the UTF-8 string. */ +{ + Tcl_UniChar ch = 0; + int len = Tcl_UtfToUniChar(src, &ch); + +#if TCL_UTF_MAX <= 4 + if ((ch & ~0x3FF) == 0xD800) { + Tcl_UniChar low = ch; + int len2 = Tcl_UtfToUniChar(src+len, &low); + if ((low & ~0x3FF) == 0xDC00) { + *ucs4Ptr = (((ch & 0x3FF) << 10) | (low & 0x3FF)) + 0x10000; + return len + len2; + } + } +#endif + *ucs4Ptr = (int)ch; + return len; +} + +#if TCL_UTF_MAX == 4 +int +TclUniCharToUCS4( + const Tcl_UniChar *src, /* The Tcl_UniChar string. */ + int *ucs4Ptr) /* Filled with the UCS4 codepoint represented + * by the Tcl_UniChar string. */ +{ + if (((src[0] & 0xFC00) == 0xD800) && ((src[1] & 0xFC00) == 0xDC00)) { + *ucs4Ptr = (((src[0] & 0x3FF) << 10) | (src[01] & 0x3FF)) + 0x10000; + return 2; + } + *ucs4Ptr = src[0]; + return 1; +} +#endif + +/* + *--------------------------------------------------------------------------- + * + * TclUCS4ToUtf -- + * + * Store the given Unicode character as a sequence of UTF-8 bytes in the + * provided buffer. Might output 6 bytes, if the code point > 0xFFFF. + * + * Results: + * The return values is the number of bytes in the buffer that were + * consumed. If ch == -1, this function outputs 0 bytes (empty string), + * since TclGetUCS4 returns -1 for out-of-range indices. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +int +TclUCS4ToUtf( + int ch, /* Unicode character to be stored in the + * buffer. */ + char *buf) /* Buffer in which the UTF-8 representation of + * the Unicode character is stored. Buffer must be + * large enough to hold the UTF-8 character(s) + * (at most 6 bytes). */ +{ +#if TCL_UTF_MAX <= 4 + if (((unsigned)(ch - 0x10000) <= 0xFFFFF)) { + /* Spit out a 4-byte UTF-8 character or 2 x 3-byte UTF-8 characters, depending on Tcl + * version and/or TCL_UTF_MAX build value */ + int len = Tcl_UniCharToUtf(0xD800 | ((ch - 0x10000) >> 10), buf); + return len + Tcl_UniCharToUtf(0xDC00 | (ch & 0x7FF), buf + len); + } +#endif + if ((ch & ~0x7FF) == 0xD800) { + buf[2] = (char) ((ch | 0x80) & 0xBF); + buf[1] = (char) (((ch >> 6) | 0x80) & 0xBF); + buf[0] = (char) ((ch >> 12) | 0xE0); + return 3; + } + if (ch == -1) { + return 0; + } + return Tcl_UniCharToUtf(ch, buf); +} + /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: generic/tclUtil.c ================================================================== --- generic/tclUtil.c +++ generic/tclUtil.c @@ -13,11 +13,10 @@ */ #include "tclInt.h" #include "tclParse.h" #include "tclStringTrim.h" -#include "tommath.h" #include /* * The absolute pathname of the executable in which this Tcl library is * running. @@ -92,44 +91,48 @@ #define CONVERT_BRACE 2 #define CONVERT_ESCAPE 4 #define CONVERT_MASK (CONVERT_BRACE | CONVERT_ESCAPE) #define CONVERT_ANY 16 +/* + * The following key is used by Tcl_PrintDouble and TclPrecTraceProc to + * access the precision to be used for double formatting. + */ + +static Tcl_ThreadDataKey precisionKey; + /* * Prototypes for functions defined later in this file. */ static void ClearHash(Tcl_HashTable *tablePtr); static void FreeProcessGlobalValue(ClientData clientData); static void FreeThreadHash(ClientData clientData); -static int GetEndOffsetFromObj(Tcl_Obj *objPtr, - size_t endValue, Tcl_WideInt *indexPtr); +static int GetEndOffsetFromObj(Tcl_Obj *objPtr, int endValue, + int *indexPtr); static Tcl_HashTable * GetThreadHash(Tcl_ThreadDataKey *keyPtr); -static int GetWideForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, - size_t endValue, Tcl_WideInt *widePtr); +static int SetEndOffsetFromAny(Tcl_Interp *interp, + Tcl_Obj *objPtr); +static void UpdateStringOfEndOffset(Tcl_Obj *objPtr); static int FindElement(Tcl_Interp *interp, const char *string, int stringLength, const char *typeStr, const char *typeCode, const char **elementPtr, - const char **nextPtr, size_t *sizePtr, + const char **nextPtr, int *sizePtr, int *literalPtr); /* * The following is the Tcl object type definition for an object that * represents a list index in the form, "end-offset". It is used as a - * performance optimization in Tcl_GetIntForIndex. The internal rep is - * stored directly in the wideValue, so no memory management is required - * for it. This is a caching intrep, keeping the result of a parse - * around. This type is only created from a pre-existing string, so an - * updateStringProc will never be called and need not exist. The type - * is unregistered, so has no need of a setFromAnyProc either. + * performance optimization in TclGetIntForIndex. The internal rep is an + * integer, so no memory management is required for it. */ -static const Tcl_ObjType endOffsetType = { +const Tcl_ObjType tclEndOffsetType = { "end-offset", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ - NULL, /* updateStringProc */ - NULL /* setFromAnyProc */ + UpdateStringOfEndOffset, /* updateStringProc */ + SetEndOffsetFromAny }; /* * * STRING REPRESENTATION OF LISTS * * * * @@ -385,61 +388,61 @@ */ int TclMaxListLength( const char *bytes, - size_t numBytes, + int numBytes, const char **endPtr) { - size_t count = 0; + int count = 0; - if ((numBytes == 0) || ((numBytes == TCL_AUTO_LENGTH) && (*bytes == '\0'))) { + if ((numBytes == 0) || ((numBytes == -1) && (*bytes == '\0'))) { /* Empty string case - quick exit */ goto done; } /* * No list element before leading white space. */ - count += 1 - TclIsSpaceProc(*bytes); + count += 1 - TclIsSpaceProcM(*bytes); /* * Count white space runs as potential element separators. */ while (numBytes) { - if ((numBytes == TCL_AUTO_LENGTH) && (*bytes == '\0')) { + if ((numBytes == -1) && (*bytes == '\0')) { break; } - if (TclIsSpaceProc(*bytes)) { + if (TclIsSpaceProcM(*bytes)) { /* * Space run started; bump count. */ count++; do { bytes++; - numBytes -= (numBytes != TCL_AUTO_LENGTH); - } while (numBytes && TclIsSpaceProc(*bytes)); - if ((numBytes == 0) || ((numBytes == TCL_AUTO_LENGTH) && (*bytes == '\0'))) { + numBytes -= (numBytes != -1); + } while (numBytes && TclIsSpaceProcM(*bytes)); + if ((numBytes == 0) || ((numBytes == -1) && (*bytes == '\0'))) { break; } /* * (*bytes) is non-space; return to counting state. */ } bytes++; - numBytes -= (numBytes != TCL_AUTO_LENGTH); + numBytes -= (numBytes != -1); } /* * No list element following trailing white space. */ - count -= TclIsSpaceProc(bytes[-1]); + count -= TclIsSpaceProcM(bytes[-1]); done: if (endPtr) { *endPtr = bytes; } @@ -497,11 +500,11 @@ const char **elementPtr, /* Where to put address of first significant * character in first element of list. */ const char **nextPtr, /* Fill in with location of character just * after all white space following end of * argument (next arg or end of list). */ - size_t *sizePtr, /* If non-zero, fill in with size of + int *sizePtr, /* If non-zero, fill in with size of * element. */ int *literalPtr) /* If non-zero, fill in with non-zero/zero to * indicate that the substring of *sizePtr * bytes starting at **elementPtr is/is not * the literal list element and therefore @@ -526,11 +529,11 @@ * character in the first element (i.e., key * or value) of dict. */ const char **nextPtr, /* Fill in with location of character just * after all white space following end of * element (next arg or end of list). */ - size_t *sizePtr, /* If non-zero, fill in with size of + int *sizePtr, /* If non-zero, fill in with size of * element. */ int *literalPtr) /* If non-zero, fill in with non-zero/zero to * indicate that the substring of *sizePtr * bytes starting at **elementPtr is/is not * the literal key or value and therefore @@ -558,11 +561,11 @@ const char **elementPtr, /* Where to put address of first significant * character in first element. */ const char **nextPtr, /* Fill in with location of character just * after all white space following end of * argument (next arg or end of list/dict). */ - size_t *sizePtr, /* If non-zero, fill in with size of + int *sizePtr, /* If non-zero, fill in with size of * element. */ int *literalPtr) /* If non-zero, fill in with non-zero/zero to * indicate that the substring of *sizePtr * bytes starting at **elementPtr is/is not * the literal list/dict element and therefore @@ -572,12 +575,12 @@ const char *p = string; const char *elemStart; /* Points to first byte of first element. */ const char *limit; /* Points just after list/dict's last byte. */ int openBraces = 0; /* Brace nesting level during parse. */ int inQuotes = 0; - int size = 0; /* lint. */ - size_t numChars; + int size = 0; + int numChars; int literal = 1; const char *p2; /* * Skim off leading white space and check for an opening brace or quote. @@ -584,11 +587,11 @@ * We treat embedded NULLs in the list/dict as bytes belonging to a list * element (or dictionary key or value). */ limit = (string + stringLength); - while ((p < limit) && (TclIsSpaceProc(*p))) { + while ((p < limit) && (TclIsSpaceProcM(*p))) { p++; } if (p == limit) { /* no element found */ elemStart = limit; goto done; @@ -629,21 +632,21 @@ if (openBraces > 1) { openBraces--; } else if (openBraces == 1) { size = (p - elemStart); p++; - if ((p >= limit) || TclIsSpaceProc(*p)) { + if ((p >= limit) || TclIsSpaceProcM(*p)) { goto done; } /* * Garbage after the closing brace; return an error. */ if (interp != NULL) { p2 = p; - while ((p2 < limit) && (!TclIsSpaceProc(*p2)) + while ((p2 < limit) && (!TclIsSpaceProcM(*p2)) && (p2 < p+20)) { p2++; } Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s element in braces followed by \"%.*s\" " @@ -673,46 +676,29 @@ } TclParseBackslash(p, limit - p, &numChars, NULL); p += (numChars - 1); break; - /* - * Space: ignore if element is in braces or quotes; otherwise - * terminate element. - */ - - case ' ': - case '\f': - case '\n': - case '\r': - case '\t': - case '\v': - if ((openBraces == 0) && !inQuotes) { - size = (p - elemStart); - goto done; - } - break; - /* * Double-quote: if element is in quotes then terminate it. */ case '"': if (inQuotes) { size = (p - elemStart); p++; - if ((p >= limit) || TclIsSpaceProc(*p)) { + if ((p >= limit) || TclIsSpaceProcM(*p)) { goto done; } /* * Garbage after the closing quote; return an error. */ if (interp != NULL) { p2 = p; - while ((p2 < limit) && (!TclIsSpaceProc(*p2)) + while ((p2 < limit) && (!TclIsSpaceProcM(*p2)) && (p2 < p+20)) { p2++; } Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s element in quotes followed by \"%.*s\" " @@ -721,10 +707,24 @@ NULL); } return TCL_ERROR; } break; + + default: + if (TclIsSpaceProcM(*p)) { + /* + * Space: ignore if element is in braces or quotes; + * otherwise terminate element. + */ + if ((openBraces == 0) && !inQuotes) { + size = (p - elemStart); + goto done; + } + } + break; + } p++; } /* @@ -751,11 +751,11 @@ } size = (p - elemStart); } done: - while ((p < limit) && (TclIsSpaceProc(*p))) { + while ((p < limit) && (TclIsSpaceProcM(*p))) { p++; } *elementPtr = elemStart; *nextPtr = p; if (sizePtr != 0) { @@ -784,24 +784,24 @@ * None. * *---------------------------------------------------------------------- */ -size_t +int TclCopyAndCollapse( - size_t count, /* Number of byte to copy from src. */ + int count, /* Number of byte to copy from src. */ const char *src, /* Copy from here... */ char *dst) /* ... to here. */ { - size_t newCount = 0; + int newCount = 0; while (count > 0) { char c = *src; if (c == '\\') { - size_t numRead; - size_t backslashCount = TclParseBackslash(src, count, &numRead, dst); + int numRead; + int backslashCount = TclParseBackslash(src, count, &numRead, dst); dst += backslashCount; newCount += backslashCount; src += numRead; count -= numRead; @@ -855,12 +855,11 @@ const char ***argvPtr) /* Pointer to place to store pointer to array * of pointers to list elements. */ { const char **argv, *end, *element; char *p; - int length, size, i, result; - size_t elSize; + int length, size, i, result, elSize; /* * Allocate enough space to work in. A (const char *) for each (possible) * list element plus one more for terminating NULL, plus as many bytes as * in the original string value, plus one more for a terminating '\0'. @@ -868,11 +867,11 @@ * string gets re-purposed to hold '\0' characters in the argv array. */ size = TclMaxListLength(list, -1, &end) + 1; length = end - list; - argv = Tcl_Alloc((size * sizeof(char *)) + length + 1); + argv = (const char **)ckalloc((size * sizeof(char *)) + length + 1); for (i = 0, p = ((char *) argv) + size*sizeof(char *); *list != 0; i++) { const char *prevList = list; int literal; @@ -879,18 +878,18 @@ result = TclFindElement(interp, list, length, &element, &list, &elSize, &literal); length -= (list - prevList); if (result != TCL_OK) { - Tcl_Free((void *)argv); + ckfree(argv); return result; } if (*element == 0) { break; } if (i >= size) { - Tcl_Free((void *)argv); + ckfree(argv); if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "internal error in Tcl_SplitList", -1)); Tcl_SetErrorCode(interp, "TCL", "INTERNAL", "Tcl_SplitList", NULL); @@ -933,15 +932,15 @@ * None. * *---------------------------------------------------------------------- */ -size_t +int Tcl_ScanElement( const char *src, /* String to convert to list element. */ int *flagPtr) /* Where to store information to guide - * Tcl_ConvertCountedElement. */ + * Tcl_ConvertCountedElement. */ { return Tcl_ScanCountedElement(src, -1, flagPtr); } /* @@ -965,14 +964,14 @@ * None. * *---------------------------------------------------------------------- */ -size_t +int Tcl_ScanCountedElement( const char *src, /* String to convert to Tcl list element. */ - size_t length, /* Number of bytes in src, or -1. */ + int length, /* Number of bytes in src, or -1. */ int *flagPtr) /* Where to store information to guide * Tcl_ConvertElement. */ { char flags = CONVERT_ANY; int numBytes = TclScanElement(src, length, &flags); @@ -1009,14 +1008,14 @@ * None. * *---------------------------------------------------------------------- */ -size_t +int TclScanElement( const char *src, /* String to convert to Tcl list element. */ - size_t length, /* Number of bytes in src, or -1. */ + int length, /* Number of bytes in src, or -1. */ char *flagPtr) /* Where to store information to guide * Tcl_ConvertElement. */ { const char *p = src; int nestingLevel = 0; /* Brace nesting count */ @@ -1025,19 +1024,19 @@ int requireEscape = 0; /* Force use of CONVERT_ESCAPE mode. For some * reason bare or brace-quoted form fails. */ int extra = 0; /* Count of number of extra bytes needed for * formatted element, assuming we use escape * sequences in formatting. */ - size_t bytesNeeded; /* Buffer length computed to complete the + int bytesNeeded; /* Buffer length computed to complete the * element formatting in the selected mode. */ #if COMPAT int preferEscape = 0; /* Use preferences to track whether to use */ int preferBrace = 0; /* CONVERT_MASK mode. */ int braceCount = 0; /* Count of all braces '{' '}' seen. */ #endif /* COMPAT */ - if ((p == NULL) || (length == 0) || ((*p == '\0') && (length == TCL_AUTO_LENGTH))) { + if ((p == NULL) || (length == 0) || ((*p == '\0') && (length == -1))) { /* * Empty string element must be brace quoted. */ *flagPtr = CONVERT_BRACE; @@ -1108,25 +1107,19 @@ /* FLOW THROUGH */ #endif /* COMPAT */ case '[': /* TYPE_SUBS */ case '$': /* TYPE_SUBS */ case ';': /* TYPE_COMMAND_END */ - case ' ': /* TYPE_SPACE */ - case '\f': /* TYPE_SPACE */ - case '\n': /* TYPE_COMMAND_END */ - case '\r': /* TYPE_SPACE */ - case '\t': /* TYPE_SPACE */ - case '\v': /* TYPE_SPACE */ 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_AUTO_LENGTH) && (p[1] == '\0'))) { + if ((length == 1) || ((length == -1) && (p[1] == '\0'))) { /* * Final backslash. Cannot format with brace quoting. */ requireEscape = 1; @@ -1153,18 +1146,27 @@ #if COMPAT preferBrace = 1; #endif /* COMPAT */ break; case '\0': /* TYPE_SUBS */ - if (length == TCL_AUTO_LENGTH) { + if (length == -1) { 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+1 > 1); + length -= (length > 0); p++; } endOfString: if (nestingLevel != 0) { @@ -1195,11 +1197,11 @@ if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) { bytesNeeded++; } *flagPtr = CONVERT_ESCAPE; - return bytesNeeded; + goto overflowCheck; } if (*flagPtr & CONVERT_ANY) { /* * The caller has not let us know what flags it will pass to * TclConvertElement() so compute the max size we might need for any @@ -1243,11 +1245,11 @@ if (*flagPtr & TCL_DONT_USE_BRACES) { bytesNeeded += braceCount; } *flagPtr = CONVERT_MASK; - return bytesNeeded; + goto overflowCheck; } #endif /* COMPAT */ if (*flagPtr & TCL_DONT_USE_BRACES) { /* * If the caller reports it will direct TclConvertElement() to @@ -1269,11 +1271,11 @@ */ bytesNeeded += 2; } *flagPtr = CONVERT_BRACE; - return bytesNeeded; + goto overflowCheck; } /* * So far, no need to quote or escape anything. */ @@ -1284,10 +1286,15 @@ */ bytesNeeded += 2; } *flagPtr = CONVERT_NONE; + + overflowCheck: + if (bytesNeeded < 0) { + Tcl_Panic("TclScanElement: string length overflow"); + } return bytesNeeded; } /* *---------------------------------------------------------------------- @@ -1308,11 +1315,11 @@ * None. * *---------------------------------------------------------------------- */ -size_t +int Tcl_ConvertElement( const char *src, /* Source information for list element. */ char *dst, /* Place to put list-ified element. */ int flags) /* Flags produced by Tcl_ScanElement. */ { @@ -1338,18 +1345,18 @@ * None. * *---------------------------------------------------------------------- */ -size_t +int Tcl_ConvertCountedElement( - register const char *src, /* Source information for list element. */ - size_t length, /* Number of bytes in src, or -1. */ + const char *src, /* Source information for list element. */ + int length, /* Number of bytes in src, or -1. */ char *dst, /* Place to put list-ified element. */ int flags) /* Flags produced by Tcl_ScanElement. */ { - size_t numBytes = TclConvertElement(src, length, dst, flags); + int numBytes = TclConvertElement(src, length, dst, flags); dst[numBytes] = '\0'; return numBytes; } /* @@ -1371,14 +1378,14 @@ * None. * *---------------------------------------------------------------------- */ -size_t +int TclConvertElement( - register const char *src, /* Source information for list element. */ - size_t length, /* Number of bytes in src, or -1. */ + const char *src, /* Source information for list element. */ + int length, /* Number of bytes in src, or -1. */ char *dst, /* Place to put list-ified element. */ int flags) /* Flags produced by Tcl_ScanElement. */ { int conversion = flags & CONVERT_MASK; char *p = dst; @@ -1393,14 +1400,14 @@ /* * No matter what the caller demands, empty string must be braced! */ - if ((src == NULL) || (length == 0) || (*src == '\0' && length == TCL_AUTO_LENGTH)) { - p[0] = '{'; - p[1] = '}'; - return 2; + if ((src == NULL) || (length == 0) || (*src == '\0' && length == -1)) { + src = tclEmptyStringRep; + length = 0; + conversion = CONVERT_BRACE; } /* * Escape leading hash as needed and requested. */ @@ -1409,11 +1416,11 @@ if (conversion == CONVERT_ESCAPE) { p[0] = '\\'; p[1] = '#'; p += 2; src++; - length -= (length+1 > 1); + length -= (length > 0); } else { conversion = CONVERT_BRACE; } } @@ -1420,11 +1427,11 @@ /* * No escape or quoting needed. Copy the literal string value. */ if (conversion == CONVERT_NONE) { - if (length == TCL_AUTO_LENGTH) { + if (length == -1) { /* TODO: INT_MAX overflow? */ while (*src) { *p++ = *src++; } return p - dst; @@ -1439,11 +1446,11 @@ */ if (conversion == CONVERT_BRACE) { *p = '{'; p++; - if (length == TCL_AUTO_LENGTH) { + if (length == -1) { /* TODO: INT_MAX overflow? */ while (*src) { *p++ = *src++; } } else { @@ -1450,20 +1457,20 @@ memcpy(p, src, length); p += length; } *p = '}'; p++; - return (size_t)(p - dst); + return p - dst; } /* conversion == CONVERT_ESCAPE or CONVERT_MASK */ /* * Formatted string is original string converted to escape sequences. */ - for ( ; length; src++, length -= (length+1 > 1)) { + for ( ; length; src++, length -= (length > 0)) { switch (*src) { case ']': case '[': case '$': case ';': @@ -1512,12 +1519,12 @@ p++; *p = 'v'; p++; continue; case '\0': - if (length == TCL_AUTO_LENGTH) { - return (size_t)(p - dst); + if (length == -1) { + return p - dst; } /* * If we reach this point, there's an embedded NULL in the string * range being processed, which should not happen when the @@ -1529,11 +1536,11 @@ break; } *p = *src; p++; } - return (size_t)(p - dst); + return p - dst; } /* *---------------------------------------------------------------------- * @@ -1559,21 +1566,20 @@ int argc, /* How many strings to merge. */ const char *const *argv) /* Array of string values. */ { #define LOCAL_SIZE 64 char localFlags[LOCAL_SIZE], *flagPtr = NULL; - int i; - size_t bytesNeeded = 0; + int i, bytesNeeded = 0; char *result, *dst; /* * Handle empty list case first, so logic of the general case can be * simpler. */ if (argc == 0) { - result = Tcl_Alloc(1); + result = (char *)ckalloc(1); result[0] = '\0'; return result; } /* @@ -1581,23 +1587,29 @@ */ if (argc <= LOCAL_SIZE) { flagPtr = localFlags; } else { - flagPtr = Tcl_Alloc(argc); + flagPtr = (char *)ckalloc(argc); } for (i = 0; i < argc; i++) { flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 ); bytesNeeded += TclScanElement(argv[i], -1, &flagPtr[i]); + if (bytesNeeded < 0) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } + } + if (bytesNeeded > INT_MAX - argc + 1) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } bytesNeeded += argc; /* * Pass two: copy into the result area. */ - result = Tcl_Alloc(bytesNeeded); + result = (char *)ckalloc(bytesNeeded); dst = result; for (i = 0; i < argc; i++) { flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 ); dst += TclConvertElement(argv[i], -1, dst, flagPtr[i]); *dst = ' '; @@ -1604,51 +1616,49 @@ dst++; } dst[-1] = 0; if (flagPtr != localFlags) { - Tcl_Free(flagPtr); + ckfree(flagPtr); } return result; } /* *---------------------------------------------------------------------- * - * UtfWellFormedEnd -- - * Checks the end of utf string is malformed, if yes - wraps bytes - * to the given buffer (as well-formed NTS string). The buffer - * argument should be initialized by the caller and ready to use. + * Tcl_Backslash -- + * + * Figure out how to handle a backslash sequence. * * Results: - * The bytes with well-formed end of the string. + * The return value is the character that should be substituted in place + * of the backslash sequence that starts at src. If readPtr isn't NULL + * then it is filled in with a count of the number of characters in the + * backslash sequence. * * Side effects: - * Buffer (DString) may be allocated, so must be released. + * None. * *---------------------------------------------------------------------- */ -static inline const char* -UtfWellFormedEnd( - Tcl_DString *buffer, /* Buffer used to hold well-formed string. */ - const char *bytes, /* Pointer to the beginning of the string. */ - int length) /* Length of the string. */ -{ - const char *l = bytes + length; - const char *p = Tcl_UtfPrev(l, bytes); - - if (Tcl_UtfCharComplete(p, l - p)) { - return bytes; - } - /* - * Malformed utf-8 end, be sure we've NTS to safe compare of end-character, - * avoid segfault by access violation out of range. - */ - Tcl_DStringAppend(buffer, bytes, length); - return Tcl_DStringValue(buffer); -} +char +Tcl_Backslash( + const char *src, /* Points to the backslash character of a + * backslash sequence. */ + int *readPtr) /* Fill in with number of characters read from + * src, unless NULL. */ +{ + char buf[4] = ""; + Tcl_UniChar ch = 0; + + Tcl_UtfBackslash(src, readPtr, buf); + TclUtfToUniChar(buf, &ch); + return (char) ch; +} + /* *---------------------------------------------------------------------- * * TclTrimRight -- * Takes two counted strings in the Tcl encoding. Conceptually @@ -1662,38 +1672,50 @@ * None. * *---------------------------------------------------------------------- */ -static inline size_t -TrimRight( - const char *bytes, /* String to be trimmed... */ - size_t numBytes, /* ...and its length in bytes */ - const char *trim, /* String of trim characters... */ - size_t numTrim) /* ...and its length in bytes */ -{ - const char *p = bytes + numBytes; - size_t pInc; - Tcl_UniChar ch1 = 0, ch2 = 0; +int +TclTrimRight( + const char *bytes, /* String to be trimmed... */ + int numBytes, /* ...and its length in bytes */ + /* Calls to TclUtfToUniChar() in this routine + * rely on (bytes[numBytes] == '\0'). */ + const char *trim, /* String of trim characters... */ + int numTrim) /* ...and its length in bytes */ + /* Calls to TclUtfToUniChar() in this routine + * rely on (trim[numTrim] == '\0'). */ +{ + const char *pp, *p = bytes + numBytes; + Tcl_UniChar ch1 = 0; + + /* Empty strings -> nothing to do */ + if ((numBytes == 0) || (numTrim == 0)) { + return 0; + } /* * Outer loop: iterate over string to be trimmed. */ do { const char *q = trim; - size_t bytesLeft = numTrim; + int pInc = 0, bytesLeft = numTrim; + Tcl_UniChar ch2 = 0; - p = Tcl_UtfPrev(p, bytes); - pInc = TclUtfToUniChar(p, &ch1); + pp = TclUtfPrev(p, bytes); + do { + pp += pInc; + pInc = TclUtfToUniChar(pp, &ch1); + } while (pp + pInc < p); /* * Inner loop: scan trim string for match to current character. */ do { - size_t qInc = TclUtfToUniChar(q, &ch2); + int qInc = TclUtfToUniChar(q, &ch2); if (ch1 == ch2) { break; } @@ -1704,48 +1726,17 @@ if (bytesLeft == 0) { /* * No match; trim task done; *p is last non-trimmed char. */ - p += pInc; break; } + p = pp; } while (p > bytes); return numBytes - (p - bytes); } - -size_t -TclTrimRight( - const char *bytes, /* String to be trimmed... */ - size_t numBytes, /* ...and its length in bytes */ - const char *trim, /* String of trim characters... */ - size_t numTrim) /* ...and its length in bytes */ -{ - size_t res; - Tcl_DString bytesBuf, trimBuf; - - /* Empty strings -> nothing to do */ - if ((numBytes == 0) || (numTrim == 0)) { - return 0; - } - - Tcl_DStringInit(&bytesBuf); - Tcl_DStringInit(&trimBuf); - bytes = UtfWellFormedEnd(&bytesBuf, bytes, numBytes); - trim = UtfWellFormedEnd(&trimBuf, trim, numTrim); - - res = TrimRight(bytes, numBytes, trim, numTrim); - if (res > numBytes) { - res = numBytes; - } - - Tcl_DStringFree(&bytesBuf); - Tcl_DStringFree(&trimBuf); - - return res; -} /* *---------------------------------------------------------------------- * * TclTrimLeft -- @@ -1761,35 +1752,45 @@ * None. * *---------------------------------------------------------------------- */ -static inline size_t -TrimLeft( - const char *bytes, /* String to be trimmed... */ - size_t numBytes, /* ...and its length in bytes */ - const char *trim, /* String of trim characters... */ - size_t numTrim) /* ...and its length in bytes */ +int +TclTrimLeft( + const char *bytes, /* String to be trimmed... */ + int numBytes, /* ...and its length in bytes */ + /* Calls to TclUtfToUniChar() in this routine + * rely on (bytes[numBytes] == '\0'). */ + const char *trim, /* String of trim characters... */ + int numTrim) /* ...and its length in bytes */ + /* Calls to TclUtfToUniChar() in this routine + * rely on (trim[numTrim] == '\0'). */ { const char *p = bytes; - Tcl_UniChar ch1 = 0, ch2 = 0; + Tcl_UniChar ch1 = 0; + + /* Empty strings -> nothing to do */ + if ((numBytes == 0) || (numTrim == 0)) { + return 0; + } /* * Outer loop: iterate over string to be trimmed. */ do { - size_t pInc = TclUtfToUniChar(p, &ch1); + Tcl_UniChar ch2 = 0; + int pInc = TclUtfToUniChar(p, &ch1); const char *q = trim; - size_t bytesLeft = numTrim; + int bytesLeft = numTrim; /* * Inner loop: scan trim string for match to current character. */ do { - size_t qInc = TclUtfToUniChar(q, &ch2); + int qInc = TclUtfToUniChar(q, &ch2); if (ch1 == ch2) { break; } @@ -1809,41 +1810,10 @@ numBytes -= pInc; } while (numBytes > 0); return p - bytes; } - -size_t -TclTrimLeft( - const char *bytes, /* String to be trimmed... */ - size_t numBytes, /* ...and its length in bytes */ - const char *trim, /* String of trim characters... */ - size_t numTrim) /* ...and its length in bytes */ -{ - size_t res; - Tcl_DString bytesBuf, trimBuf; - - /* Empty strings -> nothing to do */ - if ((numBytes == 0) || (numTrim == 0)) { - return 0; - } - - Tcl_DStringInit(&bytesBuf); - Tcl_DStringInit(&trimBuf); - bytes = UtfWellFormedEnd(&bytesBuf, bytes, numBytes); - trim = UtfWellFormedEnd(&trimBuf, trim, numTrim); - - res = TrimLeft(bytes, numBytes, trim, numTrim); - if (res > numBytes) { - res = numBytes; - } - - Tcl_DStringFree(&bytesBuf); - Tcl_DStringFree(&trimBuf); - - return res; -} /* *---------------------------------------------------------------------- * * TclTrim -- @@ -1857,49 +1827,47 @@ * None. * *---------------------------------------------------------------------- */ -size_t +int TclTrim( const char *bytes, /* String to be trimmed... */ - size_t numBytes, /* ...and its length in bytes */ + int numBytes, /* ...and its length in bytes */ + /* Calls in this routine + * rely on (bytes[numBytes] == '\0'). */ const char *trim, /* String of trim characters... */ - size_t numTrim, /* ...and its length in bytes */ - size_t *trimRight) /* Offset from the end of the string. */ + int numTrim, /* ...and its length in bytes */ + /* Calls in this routine + * rely on (trim[numTrim] == '\0'). */ + int *trimRightPtr) /* Offset from the end of the string. */ { - size_t trimLeft; - Tcl_DString bytesBuf, trimBuf; + int trimLeft = 0, trimRight = 0; - *trimRight = 0; /* Empty strings -> nothing to do */ - if ((numBytes == 0) || (numTrim == 0)) { - return 0; - } - - Tcl_DStringInit(&bytesBuf); - Tcl_DStringInit(&trimBuf); - bytes = UtfWellFormedEnd(&bytesBuf, bytes, numBytes); - trim = UtfWellFormedEnd(&trimBuf, trim, numTrim); - - trimLeft = TrimLeft(bytes, numBytes, trim, numTrim); - if (trimLeft > numBytes) { - trimLeft = numBytes; - } - numBytes -= trimLeft; - /* have to trim yet (first char was already verified within TrimLeft) */ - if (numBytes > 1) { - bytes += trimLeft; - *trimRight = TrimRight(bytes, numBytes, trim, numTrim); - if (*trimRight > numBytes) { - *trimRight = numBytes; - } - } - - Tcl_DStringFree(&bytesBuf); - Tcl_DStringFree(&trimBuf); - + if ((numBytes > 0) && (numTrim > 0)) { + + /* When bytes is NUL-terminated, returns 0 <= trimLeft <= numBytes */ + trimLeft = TclTrimLeft(bytes, numBytes, trim, numTrim); + numBytes -= trimLeft; + + /* If we did not trim the whole string, it starts with a character + * that we will not trim. Skip over it. */ + if (numBytes > 0) { + int ch; + const char *first = bytes + trimLeft; + bytes += TclUtfToUCS4(first, &ch); + numBytes -= (bytes - first); + + if (numBytes > 0) { + /* When bytes is NUL-terminated, returns + * 0 <= trimRight <= numBytes */ + trimRight = TclTrimRight(bytes, numBytes, trim, numTrim); + } + } + } + *trimRightPtr = trimRight; return trimLeft; } /* *---------------------------------------------------------------------- @@ -1919,27 +1887,26 @@ * *---------------------------------------------------------------------- */ /* The whitespace characters trimmed during [concat] operations */ -#define CONCAT_WS_SIZE (sizeof(CONCAT_TRIM_SET "") - 1) +#define CONCAT_WS_SIZE (int) (sizeof(CONCAT_TRIM_SET "") - 1) char * Tcl_Concat( int argc, /* Number of strings to concatenate. */ const char *const *argv) /* Array of strings to concatenate. */ { - int i; - size_t needSpace = 0, bytesNeeded = 0; + int i, needSpace = 0, bytesNeeded = 0; char *result, *p; /* * Dispose of the empty result corner case first to simplify later code. */ if (argc == 0) { - result = (char *) Tcl_Alloc(1); + result = (char *) ckalloc(1); result[0] = '\0'; return result; } /* @@ -1946,20 +1913,31 @@ * First allocate the result buffer at the size required. */ for (i = 0; i < argc; i++) { bytesNeeded += strlen(argv[i]); + if (bytesNeeded < 0) { + Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded"); + } + } + if (bytesNeeded + argc - 1 < 0) { + /* + * Panic test could be tighter, but not going to bother for this + * legacy routine. + */ + + Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded"); } /* * All element bytes + (argc - 1) spaces + 1 terminating NULL. */ - result = Tcl_Alloc(bytesNeeded + argc); + result = (char *)ckalloc(bytesNeeded + argc); for (p = result, i = 0; i < argc; i++) { - size_t triml, trimr, elemLength; + int triml, trimr, elemLength; const char *element; element = argv[i]; elemLength = strlen(argv[i]); @@ -2016,12 +1994,11 @@ Tcl_Obj * Tcl_ConcatObj( int objc, /* Number of objects to concatenate. */ Tcl_Obj *const objv[]) /* Array of objects to concatenate. */ { - int i, needSpace = 0; - size_t bytesNeeded = 0, elemLength; + int i, elemLength, needSpace = 0, bytesNeeded = 0; const char *element; Tcl_Obj *objPtr, *resPtr; /* * Check first to see if all the items are of list type or empty. If so, @@ -2028,26 +2005,26 @@ * we will concat them together as lists, and return a list object. This * is only valid when the lists are in canonical form. */ for (i = 0; i < objc; i++) { - size_t length; + int length; objPtr = objv[i]; if (TclListObjIsCanonical(objPtr)) { continue; } - (void)TclGetStringFromObj(objPtr, &length); + Tcl_GetStringFromObj(objPtr, &length); if (length > 0) { break; } } if (i == objc) { resPtr = NULL; for (i = 0; i < objc; i++) { objPtr = objv[i]; - if (!TclListObjIsCanonical(objPtr)) { + if (objPtr->bytes && objPtr->length == 0) { continue; } if (resPtr) { if (TCL_OK != Tcl_ListObjAppendList(NULL, resPtr, objPtr)) { /* Abandon ship! */ @@ -2057,11 +2034,11 @@ } else { resPtr = TclListObjCopy(NULL, objPtr); } } if (!resPtr) { - resPtr = Tcl_NewObj(); + TclNewObj(resPtr); } return resPtr; } slow: @@ -2073,10 +2050,13 @@ */ for (i = 0; i < objc; i++) { element = TclGetStringFromObj(objv[i], &elemLength); bytesNeeded += elemLength; + if (bytesNeeded < 0) { + break; + } } /* * Does not matter if this fails, will simply try later to build up the * string with each Append reallocating as needed with the usual string @@ -2086,11 +2066,11 @@ TclNewObj(resPtr); (void) Tcl_AttemptSetObjLength(resPtr, bytesNeeded + objc - 1); Tcl_SetObjLength(resPtr, 0); for (i = 0; i < objc; i++) { - size_t triml, trimr; + int triml, trimr; element = TclGetStringFromObj(objv[i], &elemLength); /* Trim away the leading/trailing whitespace. */ triml = TclTrim(element, elemLength, CONCAT_TRIM_SET, @@ -2123,10 +2103,37 @@ } /* *---------------------------------------------------------------------- * + * Tcl_StringMatch -- + * + * See if a particular string matches a particular pattern. + * + * Results: + * The return value is 1 if string matches pattern, and 0 otherwise. The + * matching operation permits the following special characters in the + * pattern: *?\[] (see the manual entry for details on what these mean). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_StringMatch( + const char *str, /* String. */ + const char *pattern) /* Pattern, which may contain special + * characters. */ +{ + return Tcl_StringCaseMatch(str, pattern, 0); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_StringCaseMatch -- * * See if a particular string matches a particular pattern. Allows case * insensitivity. * @@ -2147,12 +2154,11 @@ const char *pattern, /* Pattern, which may contain special * characters. */ int nocase) /* 0 for case sensitive, 1 for insensitive */ { int p, charLen; - const char *pstart = pattern; - Tcl_UniChar ch1 = 0, ch2 = 0; + int ch1 = 0, ch2 = 0; while (1) { p = *pattern; /* @@ -2189,16 +2195,16 @@ /* * This is a special case optimization for single-byte utf. */ if (UCHAR(*pattern) < 0x80) { - ch2 = (Tcl_UniChar) + ch2 = (int) (nocase ? tolower(UCHAR(*pattern)) : UCHAR(*pattern)); } else { - Tcl_UtfToUniChar(pattern, &ch2); + TclUtfToUCS4(pattern, &ch2); if (nocase) { - ch2 = Tcl_UniCharToLower(ch2); + ch2 = TclUCS4ToLower(ch2); } } while (1) { /* @@ -2208,12 +2214,12 @@ */ if ((p != '[') && (p != '?') && (p != '\\')) { if (nocase) { while (*str) { - charLen = TclUtfToUniChar(str, &ch1); - if (ch2==ch1 || ch2==(Tcl_UniChar)Tcl_UniCharToLower(ch1)) { + charLen = TclUtfToUCS4(str, &ch1); + if (ch2==ch1 || ch2==TclUCS4ToLower(ch1)) { break; } str += charLen; } } else { @@ -2222,11 +2228,11 @@ * shorter, as the number of bytes you want to compare * each time is non-constant. */ while (*str) { - charLen = TclUtfToUniChar(str, &ch1); + charLen = TclUtfToUCS4(str, &ch1); if (ch2 == ch1) { break; } str += charLen; } @@ -2236,11 +2242,11 @@ return 1; } if (*str == '\0') { return 0; } - str += TclUtfToUniChar(str, &ch1); + str += TclUtfToUCS4(str, &ch1); } } /* * Check for a "?" as the next pattern character. It matches any @@ -2247,11 +2253,11 @@ * single character. */ if (p == '?') { pattern++; - str += TclUtfToUniChar(str, &ch1); + str += TclUtfToUCS4(str, &ch1); continue; } /* * Check for a "[" as the next pattern character. It is followed by a @@ -2258,50 +2264,50 @@ * list of characters that are acceptable, or by a range (two * characters separated by "-"). */ if (p == '[') { - Tcl_UniChar startChar = 0, endChar = 0; + int startChar = 0, endChar = 0; pattern++; if (UCHAR(*str) < 0x80) { - ch1 = (Tcl_UniChar) + ch1 = (int) (nocase ? tolower(UCHAR(*str)) : UCHAR(*str)); str++; } else { - str += Tcl_UtfToUniChar(str, &ch1); + str += TclUtfToUCS4(str, &ch1); if (nocase) { - ch1 = Tcl_UniCharToLower(ch1); + ch1 = TclUCS4ToLower(ch1); } } while (1) { if ((*pattern == ']') || (*pattern == '\0')) { return 0; } if (UCHAR(*pattern) < 0x80) { - startChar = (Tcl_UniChar) (nocase + startChar = (int) (nocase ? tolower(UCHAR(*pattern)) : UCHAR(*pattern)); pattern++; } else { - pattern += Tcl_UtfToUniChar(pattern, &startChar); + pattern += TclUtfToUCS4(pattern, &startChar); if (nocase) { - startChar = Tcl_UniCharToLower(startChar); + startChar = TclUCS4ToLower(startChar); } } if (*pattern == '-') { pattern++; if (*pattern == '\0') { return 0; } if (UCHAR(*pattern) < 0x80) { - endChar = (Tcl_UniChar) (nocase + endChar = (int) (nocase ? tolower(UCHAR(*pattern)) : UCHAR(*pattern)); pattern++; } else { - pattern += Tcl_UtfToUniChar(pattern, &endChar); + pattern += TclUtfToUCS4(pattern, &endChar); if (nocase) { - endChar = Tcl_UniCharToLower(endChar); + endChar = TclUCS4ToLower(endChar); } } if (((startChar <= ch1) && (ch1 <= endChar)) || ((endChar <= ch1) && (ch1 <= startChar))) { /* @@ -2312,14 +2318,17 @@ } } else if (startChar == ch1) { break; } } + /* If we reach here, we matched. Need to move past closing ] */ while (*pattern != ']') { if (*pattern == '\0') { - pattern = Tcl_UtfPrev(pattern, pstart); - break; + /* We ran out of pattern after matching something in + * (unclosed!) brackets. So long as we ran out of string + * at the same time, we have a match. Otherwise, not. */ + return (*str == '\0'); } pattern++; } pattern++; continue; @@ -2340,14 +2349,14 @@ /* * There's no special character. Just make sure that the next bytes of * each string match. */ - str += TclUtfToUniChar(str, &ch1); - pattern += TclUtfToUniChar(pattern, &ch2); + str += TclUtfToUCS4(str, &ch1); + pattern += TclUtfToUCS4(pattern, &ch2); if (nocase) { - if (Tcl_UniCharToLower(ch1) != Tcl_UniCharToLower(ch2)) { + if (TclUCS4ToLower(ch1) != TclUCS4ToLower(ch2)) { return 0; } } else if (ch1 != ch2) { return 0; } @@ -2375,15 +2384,15 @@ */ int TclByteArrayMatch( const unsigned char *string,/* String. */ - size_t strLen, /* Length of String */ + int strLen, /* Length of String */ const unsigned char *pattern, /* Pattern, which may contain special * characters. */ - size_t ptnLen, /* Length of Pattern */ + int ptnLen, /* Length of Pattern */ int flags) { const unsigned char *stringEnd, *patternEnd; unsigned char p; @@ -2556,32 +2565,31 @@ Tcl_Obj *strObj, /* string object. */ Tcl_Obj *ptnObj, /* pattern object. */ int flags) /* Only TCL_MATCH_NOCASE should be passed, or * 0. */ { - int match; - size_t length = 0, plen = 0; + int match, length, plen; /* * Promote based on the type of incoming object. * XXX: Currently doesn't take advantage of exact-ness that * XXX: TclReToGlob tells us about trivial = nocase ? 0 : TclMatchIsTrivial(TclGetString(ptnObj)); */ - if (TclHasIntRep(strObj, &tclStringType) || (strObj->typePtr == NULL)) { + if ((strObj->typePtr == &tclStringType) || (strObj->typePtr == NULL)) { Tcl_UniChar *udata, *uptn; - udata = TclGetUnicodeFromObj(strObj, &length); - uptn = TclGetUnicodeFromObj(ptnObj, &plen); + udata = Tcl_GetUnicodeFromObj(strObj, &length); + uptn = Tcl_GetUnicodeFromObj(ptnObj, &plen); match = TclUniCharMatch(udata, length, uptn, plen, flags); } else if (TclIsPureByteArray(strObj) && TclIsPureByteArray(ptnObj) && !flags) { unsigned char *data, *ptn; - data = TclGetByteArrayFromObj(strObj, &length); - ptn = TclGetByteArrayFromObj(ptnObj, &plen); + data = Tcl_GetByteArrayFromObj(strObj, &length); + ptn = Tcl_GetByteArrayFromObj(ptnObj, &plen); match = TclByteArrayMatch(data, length, ptn, plen, 0); } else { match = Tcl_StringCaseMatch(TclGetString(strObj), TclGetString(ptnObj), flags); } @@ -2635,19 +2643,19 @@ */ char * Tcl_DStringAppend( Tcl_DString *dsPtr, /* Structure describing dynamic string. */ - const char *bytes, /* String to append. If length is - * TCL_AUTO_LENGTH then this must be null-terminated. */ - size_t length) /* Number of bytes from "bytes" to append. If - * TCL_AUTO_LENGTH, then append all of bytes, up to null + const char *bytes, /* String to append. If length is -1 then this + * must be null-terminated. */ + int length) /* Number of bytes from "bytes" to append. If + * < 0, then append all of bytes, up to null * at end. */ { - size_t newSize; + int newSize; - if (length == TCL_AUTO_LENGTH) { + if (length < 0) { length = strlen(bytes); } newSize = length + dsPtr->length; /* @@ -2657,27 +2665,27 @@ */ if (newSize >= dsPtr->spaceAvl) { dsPtr->spaceAvl = newSize * 2; if (dsPtr->string == dsPtr->staticSpace) { - char *newString = Tcl_Alloc(dsPtr->spaceAvl); + char *newString = (char *)ckalloc(dsPtr->spaceAvl); memcpy(newString, dsPtr->string, dsPtr->length); dsPtr->string = newString; } else { - size_t index = TCL_INDEX_NONE; + int offset = -1; /* See [16896d49fd] */ if (bytes >= dsPtr->string && bytes <= dsPtr->string + dsPtr->length) { - index = bytes - dsPtr->string; + offset = bytes - dsPtr->string; } - dsPtr->string = Tcl_Realloc(dsPtr->string, dsPtr->spaceAvl); + dsPtr->string = (char *)ckrealloc(dsPtr->string, dsPtr->spaceAvl); - if (index != TCL_INDEX_NONE) { - bytes = dsPtr->string + index; + if (offset >= 0) { + bytes = dsPtr->string + offset; } } } /* @@ -2704,12 +2712,12 @@ char * TclDStringAppendObj( Tcl_DString *dsPtr, Tcl_Obj *objPtr) { - size_t length; - const char *bytes = TclGetStringFromObj(objPtr, &length); + int length; + char *bytes = Tcl_GetStringFromObj(objPtr, &length); return Tcl_DStringAppend(dsPtr, bytes, length); } char * @@ -2745,13 +2753,41 @@ const char *element) /* String to append. Must be * null-terminated. */ { char *dst = dsPtr->string + dsPtr->length; int needSpace = TclNeedSpace(dsPtr->string, dst); - char flags = needSpace ? TCL_DONT_QUOTE_HASH : 0; - size_t newSize = dsPtr->length + needSpace - + TclScanElement(element, -1, &flags); + char flags = 0; + int quoteHash = 1, newSize; + + if (needSpace) { + /* + * If we need a space to separate the new element from something + * already ending the string, we're not appending the first element + * of any list, so we need not quote any leading hash character. + */ + quoteHash = 0; + } else { + /* + * We don't need a space, maybe because there's some already there. + * Checking whether we might be appending a first element is a bit + * more involved. + * + * Backtrack over all whitespace. + */ + while ((--dst >= dsPtr->string) && TclIsSpaceProcM(*dst)) { + } + + /* Call again without whitespace to confound things. */ + quoteHash = !TclNeedSpace(dsPtr->string, dst+1); + } + if (!quoteHash) { + flags |= TCL_DONT_QUOTE_HASH; + } + newSize = dsPtr->length + needSpace + TclScanElement(element, -1, &flags); + if (!quoteHash) { + flags |= TCL_DONT_QUOTE_HASH; + } /* * Allocate a larger buffer for the string if the current one isn't large * enough. Allocate extra space in the new buffer so that there will be * room to grow before we have to allocate again. SPECIAL NOTE: must use @@ -2760,11 +2796,11 @@ */ if (newSize >= dsPtr->spaceAvl) { dsPtr->spaceAvl = newSize * 2; if (dsPtr->string == dsPtr->staticSpace) { - char *newString = Tcl_Alloc(dsPtr->spaceAvl); + char *newString = (char *)ckalloc(dsPtr->spaceAvl); memcpy(newString, dsPtr->string, dsPtr->length); dsPtr->string = newString; } else { int offset = -1; @@ -2773,18 +2809,18 @@ if (element >= dsPtr->string && element <= dsPtr->string + dsPtr->length) { offset = element - dsPtr->string; } - dsPtr->string = Tcl_Realloc(dsPtr->string, dsPtr->spaceAvl); + dsPtr->string = (char *)ckrealloc(dsPtr->string, dsPtr->spaceAvl); if (offset >= 0) { element = dsPtr->string + offset; } } - dst = dsPtr->string + dsPtr->length; } + dst = dsPtr->string + dsPtr->length; /* * Convert the new string to a list element and copy it into the buffer at * the end, with a space, if needed. */ @@ -2791,19 +2827,12 @@ if (needSpace) { *dst = ' '; dst++; dsPtr->length++; - - /* - * If we need a space to separate this element from preceding stuff, - * then this element will not lead a list, and need not have it's - * leading '#' quoted. - */ - - flags |= TCL_DONT_QUOTE_HASH; - } + } + dsPtr->length += TclConvertElement(element, -1, dst, flags); dsPtr->string[dsPtr->length] = '\0'; return dsPtr->string; } @@ -2818,22 +2847,26 @@ * Results: * None. * * Side effects: * The length of dsPtr is changed to length and a null byte is stored at - * that position in the string. + * that position in the string. If length is larger than the space + * allocated for dsPtr, then a panic occurs. * *---------------------------------------------------------------------- */ void Tcl_DStringSetLength( Tcl_DString *dsPtr, /* Structure describing dynamic string. */ - size_t length) /* New length for dynamic string. */ + int length) /* New length for dynamic string. */ { - size_t newsize; + int newsize; + if (length < 0) { + length = 0; + } if (length >= dsPtr->spaceAvl) { /* * There are two interesting cases here. In the first case, the user * may be trying to allocate a large buffer of a specific size. It * would be wasteful to overallocate that buffer, so we just allocate @@ -2850,16 +2883,16 @@ dsPtr->spaceAvl = newsize; } else { dsPtr->spaceAvl = length + 1; } if (dsPtr->string == dsPtr->staticSpace) { - char *newString = Tcl_Alloc(dsPtr->spaceAvl); + char *newString = (char *)ckalloc(dsPtr->spaceAvl); memcpy(newString, dsPtr->string, dsPtr->length); dsPtr->string = newString; } else { - dsPtr->string = Tcl_Realloc(dsPtr->string, dsPtr->spaceAvl); + dsPtr->string = (char *)ckrealloc(dsPtr->string, dsPtr->spaceAvl); } } dsPtr->length = length; dsPtr->string[length] = 0; } @@ -2885,11 +2918,11 @@ void Tcl_DStringFree( Tcl_DString *dsPtr) /* Structure describing dynamic string. */ { if (dsPtr->string != dsPtr->staticSpace) { - Tcl_Free(dsPtr->string); + ckfree(dsPtr->string); } dsPtr->string = dsPtr->staticSpace; dsPtr->length = 0; dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; dsPtr->staticSpace[0] = '\0'; @@ -2918,10 +2951,11 @@ Tcl_DStringResult( Tcl_Interp *interp, /* Interpreter whose result is to be reset. */ Tcl_DString *dsPtr) /* Dynamic string that is to become the * result of interp. */ { + Tcl_ResetResult(interp); Tcl_SetObjResult(interp, TclDStringToObj(dsPtr)); } /* *---------------------------------------------------------------------- @@ -2947,16 +2981,81 @@ Tcl_DStringGetResult( Tcl_Interp *interp, /* Interpreter whose result is to be reset. */ Tcl_DString *dsPtr) /* Dynamic string that is to become the result * of interp. */ { - Tcl_Obj *obj = Tcl_GetObjResult(interp); - char *bytes = TclGetString(obj); + Interp *iPtr = (Interp *) interp; - Tcl_DStringFree(dsPtr); - Tcl_DStringAppend(dsPtr, bytes, obj->length); - Tcl_ResetResult(interp); + if (dsPtr->string != dsPtr->staticSpace) { + ckfree(dsPtr->string); + } + + /* + * Do more efficient transfer when we know the result is a Tcl_Obj. When + * there's no string result, we only have to deal with two cases: + * + * 1. When the string rep is the empty string, when we don't copy but + * instead use the staticSpace in the DString to hold an empty string. + + * 2. When the string rep is not there or there's a real string rep, when + * we use Tcl_GetString to fetch (or generate) the string rep - which + * we know to have been allocated with ckalloc() - and use it to + * populate the DString space. Then, we free the internal rep. and set + * the object's string representation back to the canonical empty + * string. + */ + + if (!iPtr->result[0] && iPtr->objResultPtr + && !Tcl_IsShared(iPtr->objResultPtr)) { + if (iPtr->objResultPtr->bytes == tclEmptyStringRep) { + dsPtr->string = dsPtr->staticSpace; + dsPtr->string[0] = 0; + dsPtr->length = 0; + dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; + } else { + dsPtr->string = TclGetString(iPtr->objResultPtr); + dsPtr->length = iPtr->objResultPtr->length; + dsPtr->spaceAvl = dsPtr->length + 1; + TclFreeIntRep(iPtr->objResultPtr); + iPtr->objResultPtr->bytes = tclEmptyStringRep; + iPtr->objResultPtr->length = 0; + } + return; + } + + /* + * If the string result is empty, move the object result to the string + * result, then reset the object result. + */ + + (void) Tcl_GetStringResult(interp); + + dsPtr->length = strlen(iPtr->result); + if (iPtr->freeProc != NULL) { + if (iPtr->freeProc == TCL_DYNAMIC) { + dsPtr->string = iPtr->result; + dsPtr->spaceAvl = dsPtr->length+1; + } else { + dsPtr->string = (char *)ckalloc(dsPtr->length+1); + memcpy(dsPtr->string, iPtr->result, dsPtr->length+1); + iPtr->freeProc(iPtr->result); + } + dsPtr->spaceAvl = dsPtr->length+1; + iPtr->freeProc = NULL; + } else { + if (dsPtr->length < TCL_DSTRING_STATIC_SIZE) { + dsPtr->string = dsPtr->staticSpace; + dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; + } else { + dsPtr->string = (char *)ckalloc(dsPtr->length+1); + dsPtr->spaceAvl = dsPtr->length + 1; + } + memcpy(dsPtr->string, iPtr->result, dsPtr->length+1); + } + + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = 0; } /* *---------------------------------------------------------------------- * @@ -3078,32 +3177,36 @@ * * Given a floating-point value, this function converts it to an ASCII * string using. * * Results: - * The ASCII equivalent of "value" is written at "dst". It is guaranteed - * to contain a decimal point or exponent, so that it looks like a - * floating-point value and not an integer. + * The ASCII equivalent of "value" is written at "dst". It is written + * using the current precision, and it is guaranteed to contain a decimal + * point or exponent, so that it looks like a floating-point value and + * not an integer. * * Side effects: * None. * *---------------------------------------------------------------------- */ void Tcl_PrintDouble( - Tcl_Interp *interp, /* Not used */ + Tcl_Interp *interp, /* Interpreter whose tcl_precision variable + * used to be used to control printing. It's + * ignored now. */ double value, /* Value to print as string. */ char *dst) /* Where to store converted value; must have * at least TCL_DOUBLE_SPACE characters. */ { char *p, c; int exponent; int signum; char *digits; char *end; + int *precisionPtr = (int *)Tcl_GetThreadData(&precisionKey, sizeof(int)); /* * Handle NaN. */ @@ -3131,12 +3234,57 @@ /* * Ordinary (normal and denormal) values. */ - digits = TclDoubleDigits(value, -1, TCL_DD_SHORTEST, - &exponent, &signum, &end); + if (*precisionPtr == 0) { + digits = TclDoubleDigits(value, -1, TCL_DD_SHORTEST, + &exponent, &signum, &end); + } else { + /* + * There are at least two possible interpretations for tcl_precision. + * + * The first is, "choose the decimal representation having + * $tcl_precision digits of significance that is nearest to the given + * number, breaking ties by rounding to even, and then trimming + * trailing zeros." This gives the greatest possible precision in the + * decimal string, but offers the anomaly that [expr 0.1] will be + * "0.10000000000000001". + * + * The second is "choose the decimal representation having at most + * $tcl_precision digits of significance that is nearest to the given + * number. If no such representation converts exactly to the given + * number, choose the one that is closest, breaking ties by rounding + * to even. If more than one such representation converts exactly to + * the given number, choose the shortest, breaking ties in favour of + * the nearest, breaking remaining ties in favour of the one ending in + * an even digit." + * + * Tcl 8.4 implements the first of these, which gives rise to + * anomalies in formatting: + * + * % expr 0.1 + * 0.10000000000000001 + * % expr 0.01 + * 0.01 + * % expr 1e-7 + * 9.9999999999999995e-08 + * + * For human readability, it appears better to choose the second rule, + * and let [expr 0.1] return 0.1. But for 8.4 compatibility, we prefer + * the first (the recommended zero value for tcl_precision avoids the + * problem entirely). + * + * Uncomment TCL_DD_SHORTEN_FLAG in the next call to prefer the method + * that allows floating point values to be shortened if it can be done + * without loss of precision. + */ + + digits = TclDoubleDigits(value, *precisionPtr, + TCL_DD_E_FORMAT /* | TCL_DD_SHORTEN_FLAG */, + &exponent, &signum, &end); + } if (signum) { *dst++ = '-'; } p = digits; if (exponent < -4 || exponent > 16) { @@ -3152,11 +3300,20 @@ *dst++ = c; c = *++p; } } - sprintf(dst, "e%+d", exponent); + /* + * Tcl 8.4 appears to format with at least a two-digit exponent; + * preserve that behaviour when tcl_precision != 0 + */ + + if (*precisionPtr == 0) { + sprintf(dst, "e%+d", exponent); + } else { + sprintf(dst, "e%+03d", exponent); + } } else { /* * F format for others. */ @@ -3184,11 +3341,88 @@ c = *++p; } } *dst++ = '\0'; } - Tcl_Free(digits); + ckfree(digits); +} + +/* + *---------------------------------------------------------------------- + * + * TclPrecTraceProc -- + * + * This function is invoked whenever the variable "tcl_precision" is + * written. + * + * Results: + * Returns NULL if all went well, or an error message if the new value + * for the variable doesn't make sense. + * + * Side effects: + * If the new value doesn't make sense then this function undoes the + * effect of the variable modification. Otherwise it modifies the format + * string that's used by Tcl_PrintDouble. + * + *---------------------------------------------------------------------- + */ + +char * +TclPrecTraceProc( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Interpreter containing variable. */ + const char *name1, /* Name of variable. */ + const char *name2, /* Second part of variable name. */ + int flags) /* Information about what happened. */ +{ + Tcl_Obj *value; + int prec; + int *precisionPtr = (int *)Tcl_GetThreadData(&precisionKey, sizeof(int)); + + /* + * If the variable is unset, then recreate the trace. + */ + + if (flags & TCL_TRACE_UNSETS) { + if ((flags & TCL_TRACE_DESTROYED) && !Tcl_InterpDeleted(interp)) { + Tcl_TraceVar2(interp, name1, name2, + TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES + |TCL_TRACE_UNSETS, TclPrecTraceProc, clientData); + } + return NULL; + } + + /* + * When the variable is read, reset its value from our shared value. This + * is needed in case the variable was modified in some other interpreter + * so that this interpreter's value is out of date. + */ + + + if (flags & TCL_TRACE_READS) { + Tcl_SetVar2Ex(interp, name1, name2, Tcl_NewIntObj(*precisionPtr), + flags & TCL_GLOBAL_ONLY); + return NULL; + } + + /* + * The variable is being written. Check the new value and disallow it if + * it isn't reasonable or if this is a safe interpreter (we don't want + * safe interpreters messing up the precision of other interpreters). + */ + + if (Tcl_IsSafe(interp)) { + return (char *) "can't modify precision from a safe interpreter"; + } + value = Tcl_GetVar2Ex(interp, name1, name2, flags & TCL_GLOBAL_ONLY); + if (value == NULL + || Tcl_GetIntFromObj(NULL, value, &prec) != TCL_OK + || prec < 0 || prec > TCL_MAX_PREC) { + return (char *) "improper value for precision"; + } + *precisionPtr = prec; + return NULL; } /* *---------------------------------------------------------------------- * @@ -3213,67 +3447,73 @@ * added, if appropriate). */ { /* * A space is needed unless either: * (a) we're at the start of the string, or - */ + * + * (NOTE: This check is now absorbed into the loop below.) + * if (end == start) { return 0; } + * + */ + /* * (b) we're at the start of a nested list-element, quoted with an open * curly brace; we can be nested arbitrarily deep, so long as the * first curly brace starts an element, so backtrack over open curly * braces that are trailing characters of the string; and - */ + * + * (NOTE: Every character our parser is looking for is a proper + * single-byte encoding of an ASCII value. It does not accept + * overlong encodings. Given that, there's no benefit using + * Tcl_UtfPrev. If it would find what we seek, so would byte-by-byte + * backward scan. Save routine call overhead and risk of wrong + * results should the behavior of Tcl_UtfPrev change in unexpected ways. + * Reconsider this if we ever start treating non-ASCII Unicode + * characters as meaningful list syntax, expanded Unicode spaces as + * element separators, for example.) + * end = Tcl_UtfPrev(end, start); while (*end == '{') { - if (end == start) { - return 0; - } - end = Tcl_UtfPrev(end, start); + if (end == start) { + return 0; + } + end = Tcl_UtfPrev(end, start); + } + + * + */ + + while ((--end >= start) && (*end == '{')) { + } + if (end < start) { + return 0; } /* * (c) the trailing character of the string is already a list-element - * separator (according to TclFindElement); that is, one of these - * characters: - * \u0009 \t TAB - * \u000A \n NEWLINE - * \u000B \v VERTICAL TAB - * \u000C \f FORM FEED - * \u000D \r CARRIAGE RETURN - * \u0020 SPACE - * with the condition that the penultimate character is not a - * backslash. - */ - - if (*end > 0x20) { - /* - * Performance tweak. All ASCII spaces are <= 0x20. So get a quick - * answer for most characters before comparing against all spaces in - * the switch below. - * - * NOTE: Remove this if other Unicode spaces ever get accepted as - * list-element separators. - */ - - return 1; - } - switch (*end) { - case ' ': - case '\t': - case '\n': - case '\r': - case '\v': - case '\f': - if ((end == start) || (end[-1] != '\\')) { - return 0; - } + * separator, Use the same testing routine as TclFindElement to + * enforce consistency. + */ + + if (TclIsSpaceProcM(*end)) { + int result = 0; + + /* + * Trailing whitespace might be part of a backslash escape + * sequence. Handle that possibility. + */ + + while ((--end >= start) && (*end == '\\')) { + result = !result; + } + return result; } return 1; } /* @@ -3299,58 +3539,35 @@ * the "buffer" argument. * *---------------------------------------------------------------------- */ -size_t +int TclFormatInt( char *buffer, /* Points to the storage into which the * formatted characters are written. */ - Tcl_WideInt n) /* The integer to format. */ -{ - Tcl_WideInt intVal; - size_t i, numFormatted, j; - const char *digits = "0123456789"; - - /* - * Check first whether "n" is zero. - */ - - if (n == 0) { - buffer[0] = '0'; - buffer[1] = 0; - return 1; - } - - /* - * Check whether "n" is the maximum negative value. This is -2^(m-1) for - * an m-bit word, and has no positive equivalent; negating it produces the - * same value. - */ - - intVal = -n; /* [Bug 3390638] Workaround for*/ - if (n == -n || intVal == n) { /* broken compiler optimizers. */ - return sprintf(buffer, "%" TCL_LL_MODIFIER "d", n); - } + long n) /* The integer to format. */ +{ + unsigned long intVal; + int i = 0; + int numFormatted, j; + static const char digits[] = "0123456789"; /* * Generate the characters of the result backwards in the buffer. */ - intVal = (n < 0? -n : n); - i = 0; - buffer[0] = '\0'; + intVal = (n < 0 ? -(unsigned long)n : (unsigned long)n); do { - i++; - buffer[i] = digits[intVal % 10]; - intVal = intVal/10; + buffer[i++] = digits[intVal % 10]; + intVal = intVal / 10; } while (intVal > 0); if (n < 0) { - i++; - buffer[i] = '-'; + buffer[i++] = '-'; } - numFormatted = i; + buffer[i] = '\0'; + numFormatted = i--; /* * Now reverse the characters. */ @@ -3364,207 +3581,11 @@ } /* *---------------------------------------------------------------------- * - * GetWideForIndex -- - * - * This function produces a wide integer value corresponding to the - * index value held in *objPtr. The parsing supports all values - * recognized as any size of integer, and the syntaxes end[-+]$integer - * and $integer[-+]$integer. The argument endValue is used to give - * the meaning of the literal index value "end". Index arithmetic - * on arguments outside the wide integer range are only accepted - * when interp is a working interpreter, not NULL. - * - * Results: - * When parsing of *objPtr successfully recognizes an index value, - * TCL_OK is returned, and the wide integer value corresponding to - * the recognized index value is written to *widePtr. When parsing - * fails, TCL_ERROR is returned and error information is written to - * interp, if non-NULL. - * - * Side effects: - * The type of *objPtr may change. - * - *---------------------------------------------------------------------- - */ - -static int -GetWideForIndex( - Tcl_Interp *interp, /* Interpreter to use for error reporting. If - * NULL, then no error message is left after - * errors. */ - Tcl_Obj *objPtr, /* Points to the value to be parsed */ - size_t endValue, /* The value to be stored at *widePtr if - * objPtr holds "end". - * NOTE: this value may be TCL_INDEX_NONE. */ - Tcl_WideInt *widePtr) /* Location filled in with a wide integer - * representing an index. */ -{ - ClientData cd; - const char *opPtr; - int numType, length, t1 = 0, t2 = 0; - int code = TclGetNumberFromObj(NULL, objPtr, &cd, &numType); - - if (code == TCL_OK) { - if (numType == TCL_NUMBER_INT) { - /* objPtr holds an integer in the signed wide range */ - *widePtr = *(Tcl_WideInt *)cd; - return TCL_OK; - } - if (numType != TCL_NUMBER_BIG) { - /* Must be a double -> not a valid index */ - goto parseError; - } - - /* objPtr holds an integer outside the signed wide range */ - /* Truncate to the signed wide range. */ - *widePtr = (((mp_int *)cd)->sign != MP_ZPOS) ? WIDE_MIN : WIDE_MAX; - return TCL_OK; - } - - /* objPtr does not hold a number, check the end+/- format... */ - if (GetEndOffsetFromObj(objPtr, endValue, widePtr) == TCL_OK) { - return TCL_OK; - } - - /* If we reach here, the string rep of objPtr exists. */ - - /* - * The valid index syntax does not include any value that is - * a list of more than one element. This is necessary so that - * lists of index values can be reliably distinguished from any - * single index value. - */ - - /* - * Quick scan to see if multi-value list is even possible. - * This relies on TclGetString() returning a NUL-terminated string. - */ - if ((TclMaxListLength(TclGetString(objPtr), -1, NULL) > 1) - - /* If it's possible, do the full list parse. */ - && (TCL_OK == Tcl_ListObjLength(NULL, objPtr, &length)) - && (length > 1)) { - goto parseError; - } - - /* Passed the list screen, so parse for index arithmetic expression */ - if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, NULL, -1, &opPtr, - TCL_PARSE_INTEGER_ONLY)) { - Tcl_WideInt w1=0, w2=0; - - /* value starts with valid integer... */ - - if ((*opPtr == '-') || (*opPtr == '+')) { - /* ... value continues with [-+] ... */ - - /* Save first integer as wide if possible */ - TclGetNumberFromObj(NULL, objPtr, &cd, &t1); - if (t1 == TCL_NUMBER_INT) { - w1 = (*(Tcl_WideInt *)cd); - } - - if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, opPtr + 1, - -1, NULL, TCL_PARSE_INTEGER_ONLY)) { - /* ... value concludes with second valid integer */ - - /* Save second integer as wide if possible */ - TclGetNumberFromObj(NULL, objPtr, &cd, &t2); - if (t2 == TCL_NUMBER_INT) { - w2 = (*(Tcl_WideInt *)cd); - } - } - } - /* Clear invalid intreps left by TclParseNumber */ - TclFreeIntRep(objPtr); - - if (t1 && t2) { - /* We have both integer values */ - if ((t1 == TCL_NUMBER_INT) && (t2 == TCL_NUMBER_INT)) { - /* Both are wide, do wide-integer math */ - if (*opPtr == '-') { - if ((w2 == WIDE_MIN) && (interp != NULL)) { - goto extreme; - } - w2 = -w2; - } - - if ((w1 ^ w2) < 0) { - /* Different signs, sum cannot overflow */ - *widePtr = w1 + w2; - } else if (w1 >= 0) { - if (w1 < WIDE_MAX - w2) { - *widePtr = w1 + w2; - } else { - *widePtr = WIDE_MAX; - } - } else { - if (w1 > WIDE_MIN - w2) { - *widePtr = w1 + w2; - } else { - *widePtr = WIDE_MIN; - } - } - } else if (interp == NULL) { - /* - * We use an interp to do bignum index calculations. - * If we don't get one, call all indices with bignums errors, - * and rely on callers to handle it. - */ - return TCL_ERROR; - } else { - /* - * At least one is big, do bignum math. Little reason to - * value performance here. Re-use code. Parse has verified - * objPtr is an expression. Compute it. - */ - - Tcl_Obj *sum; - - extreme: - Tcl_ExprObj(interp, objPtr, &sum); - TclGetNumberFromObj(NULL, sum, &cd, &numType); - - if (numType == TCL_NUMBER_INT) { - /* sum holds an integer in the signed wide range */ - *widePtr = *(Tcl_WideInt *)cd; - } else { - /* sum holds an integer outside the signed wide range */ - /* Truncate to the signed wide range. */ - if (((mp_int *)cd)->sign != MP_ZPOS) { - *widePtr = WIDE_MIN; - } else { - *widePtr = WIDE_MAX; - } - } - Tcl_DecrRefCount(sum); - } - return TCL_OK; - } - } - - /* Report a parse error. */ - parseError: - if (interp != NULL) { - char * bytes = TclGetString(objPtr); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad index \"%s\": must be integer?[+-]integer? or" - " end?[+-]integer?", bytes)); - if (!strncmp(bytes, "end-", 4)) { - bytes += 4; - } - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); - } - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetIntForIndex -- + * TclGetIntForIndex -- * * Provides an integer corresponding to the list index held in a Tcl * object. The string value 'objPtr' is expected have the format * integer([+-]integer)? or end([+-]integer)?. * @@ -3587,37 +3608,129 @@ * *---------------------------------------------------------------------- */ int -Tcl_GetIntForIndex( +TclGetIntForIndex( Tcl_Interp *interp, /* Interpreter to use for error reporting. If * NULL, then no error message is left after * errors. */ Tcl_Obj *objPtr, /* Points to an object containing either "end" * or an integer. */ - size_t endValue, /* The value to be stored at "indexPtr" if + int endValue, /* The value to be stored at "indexPtr" if * "objPtr" holds "end". */ - size_t *indexPtr) /* Location filled in with an integer + int *indexPtr) /* Location filled in with an integer * representing an index. */ { - Tcl_WideInt wide; - - /* Use platform-related size_t to wide-int to consider negative value - * TCL_INDEX_NONE if wide-int and size_t have different dimensions. */ - if (GetWideForIndex(interp, objPtr, endValue, &wide) == TCL_ERROR) { - return TCL_ERROR; - } - if (wide < 0) { - *indexPtr = TCL_INDEX_NONE; - } else if ((Tcl_WideUInt)wide > TCL_INDEX_END) { - *indexPtr = TCL_INDEX_END; - } else { - *indexPtr = (size_t) wide; - } - return TCL_OK; -} + int length; + char *opPtr; + const char *bytes; + + if (TclGetIntFromObj(NULL, objPtr, indexPtr) == TCL_OK) { + return TCL_OK; + } + + if (GetEndOffsetFromObj(objPtr, endValue, indexPtr) == TCL_OK) { + return TCL_OK; + } + + bytes = TclGetStringFromObj(objPtr, &length); + + /* + * Leading whitespace is acceptable in an index. + */ + + while (length && TclIsSpaceProcM(*bytes)) { + bytes++; + length--; + } + + if (TclParseNumber(NULL, NULL, NULL, bytes, length, (const char **)&opPtr, + TCL_PARSE_INTEGER_ONLY | TCL_PARSE_NO_WHITESPACE) == TCL_OK) { + int code, first, second; + char savedOp = *opPtr; + + if ((savedOp != '+') && (savedOp != '-')) { + goto parseError; + } + if (TclIsSpaceProcM(opPtr[1])) { + goto parseError; + } + *opPtr = '\0'; + code = Tcl_GetInt(interp, bytes, &first); + *opPtr = savedOp; + if (code == TCL_ERROR) { + goto parseError; + } + if (TCL_ERROR == Tcl_GetInt(interp, opPtr+1, &second)) { + goto parseError; + } + if (savedOp == '+') { + *indexPtr = first + second; + } else { + *indexPtr = first - second; + } + return TCL_OK; + } + + /* + * Report a parse error. + */ + + parseError: + if (interp != NULL) { + bytes = TclGetString(objPtr); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad index \"%s\": must be integer?[+-]integer? or" + " end?[+-]integer?", bytes)); + if (!strncmp(bytes, "end-", 4)) { + bytes += 4; + } + TclCheckBadOctal(interp, bytes); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); + } + + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfEndOffset -- + * + * Update the string rep of a Tcl object holding an "end-offset" + * expression. + * + * Results: + * None. + * + * Side effects: + * Stores a valid string in the object's string rep. + * + * This function does NOT free any earlier string rep. If it is called on an + * object that already has a valid string rep, it will leak memory. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateStringOfEndOffset( + Tcl_Obj *objPtr) +{ + char buffer[TCL_INTEGER_SPACE + 5]; + int len = 3; + + memcpy(buffer, "end", 4); + if (objPtr->internalRep.longValue != 0) { + buffer[len++] = '-'; + len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue)); + } + objPtr->bytes = (char *)ckalloc(len+1); + memcpy(objPtr->bytes, buffer, len+1); + objPtr->length = len; +} + /* *---------------------------------------------------------------------- * * GetEndOffsetFromObj -- * @@ -3634,90 +3747,121 @@ */ static int GetEndOffsetFromObj( Tcl_Obj *objPtr, /* Pointer to the object to parse */ - size_t endValue, /* The value to be stored at "indexPtr" if + int endValue, /* The value to be stored at "indexPtr" if * "objPtr" holds "end". */ - Tcl_WideInt *widePtr) /* Location filled in with an integer + int *indexPtr) /* Location filled in with an integer * representing an index. */ { - Tcl_ObjIntRep *irPtr; - Tcl_WideInt offset = 0; /* Offset in the "end-offset" expression */ - - while ((irPtr = TclFetchIntRep(objPtr, &endOffsetType)) == NULL) { - Tcl_ObjIntRep ir; - size_t length; - const char *bytes = TclGetStringFromObj(objPtr, &length); - - if ((length < 3) || (length == 4)) { - /* Too short to be "end" or to be "end-$integer" */ - return TCL_ERROR; - } - if ((*bytes != 'e') || (strncmp(bytes, "end", 3) != 0)) { - /* Value doesn't start with "end" */ - return TCL_ERROR; - } - - if (length > 4) { - ClientData cd; - int t; - - /* Parse for the "end-..." or "end+..." formats */ - - if ((bytes[3] != '-') && (bytes[3] != '+')) { - /* No operator where we need one */ - return TCL_ERROR; - } - if (TclIsSpaceProc(bytes[4])) { - /* Space after + or - not permitted. */ - return TCL_ERROR; - } - - /* Parse the integer offset */ - if (TCL_OK != TclParseNumber(NULL, objPtr, NULL, - bytes+4, length-4, NULL, TCL_PARSE_INTEGER_ONLY)) { - /* Not a recognized integer format */ - return TCL_ERROR; - } - - /* Got an integer offset; pull it from where parser left it. */ - TclGetNumberFromObj(NULL, objPtr, &cd, &t); - - if (t == TCL_NUMBER_BIG) { - /* Truncate to the signed wide range. */ - if (((mp_int *)cd)->sign != MP_ZPOS) { - offset = (bytes[3] == '-') ? WIDE_MAX : WIDE_MIN; - } else { - offset = (bytes[3] == '-') ? WIDE_MIN : WIDE_MAX; - } - } else { - /* assert (t == TCL_NUMBER_INT); */ - offset = (*(Tcl_WideInt *)cd); - if (bytes[3] == '-') { - offset = (offset == WIDE_MIN) ? WIDE_MAX : -offset; - } - } - } - - /* Success. Store the new internal rep. */ - ir.wideValue = offset; - Tcl_StoreIntRep(objPtr, &endOffsetType, &ir); - } - - offset = irPtr->wideValue; - - if (endValue == TCL_INDEX_NONE) { - *widePtr = offset - 1; - } else if (offset < 0) { - /* Different signs, sum cannot overflow */ - *widePtr = endValue + offset; - } else if (endValue < (Tcl_WideUInt)WIDE_MAX - offset) { - *widePtr = endValue + offset; - } else { - *widePtr = WIDE_MAX; - } + if (SetEndOffsetFromAny(NULL, objPtr) != TCL_OK) { + return TCL_ERROR; + } + + /* TODO: Handle overflow cases sensibly */ + *indexPtr = endValue + (int)objPtr->internalRep.longValue; + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * + * SetEndOffsetFromAny -- + * + * Look for a string of the form "end[+-]offset" and convert it to an + * internal representation holding the offset. + * + * Results: + * Returns TCL_OK if ok, TCL_ERROR if the string was badly formed. + * + * Side effects: + * If interp is not NULL, stores an error message in the interpreter + * result. + * + *---------------------------------------------------------------------- + */ + +static int +SetEndOffsetFromAny( + Tcl_Interp *interp, /* Tcl interpreter or NULL */ + Tcl_Obj *objPtr) /* Pointer to the object to parse */ +{ + int offset; /* Offset in the "end-offset" expression */ + const char *bytes; /* String rep of the object */ + int length; /* Length of the object's string rep */ + + /* + * If it's already the right type, we're fine. + */ + + if (objPtr->typePtr == &tclEndOffsetType) { + return TCL_OK; + } + + /* + * Check for a string rep of the right form. + */ + + bytes = TclGetStringFromObj(objPtr, &length); + if ((*bytes != 'e') || (strncmp(bytes, "end", + (size_t)((length > 3) ? 3 : length)) != 0)) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad index \"%s\": must be end?[+-]integer?", bytes)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); + } + return TCL_ERROR; + } + + /* + * Convert the string rep. + */ + + if (length <= 3) { + offset = 0; + } else if ((length > 4) && ((bytes[3] == '-') || (bytes[3] == '+'))) { + /* + * This is our limited string expression evaluator. Pass everything + * after "end-" to Tcl_GetInt, then reverse for offset. + */ + + if (TclIsSpaceProcM(bytes[4])) { + goto badIndexFormat; + } + if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) { + return TCL_ERROR; + } + if (bytes[3] == '-') { + + /* TODO: Review overflow concerns here! */ + offset = -offset; + } + } else { + /* + * Conversion failed. Report the error. + */ + + badIndexFormat: + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad index \"%s\": must be end?[+-]integer?", bytes)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); + } + return TCL_ERROR; + } + + /* + * The conversion succeeded. Free the old internal rep and set the new + * one. + */ + + TclFreeIntRep(objPtr); + objPtr->internalRep.longValue = offset; + objPtr->typePtr = &tclEndOffsetType; + return TCL_OK; } /* *---------------------------------------------------------------------- @@ -3729,22 +3873,22 @@ * index value in the C signed int range. Note that this includes * index values that are integers as presented and it includes index * arithmetic expressions. The absolute index values that can be * directly meaningful as an index into either a list or a string are * those integer values >= TCL_INDEX_START (0) - * and < INT_MAX. + * and < TCL_INDEX_AFTER (INT_MAX). * The largest string supported in Tcl 8 has bytelength INT_MAX. * This means the largest supported character length is also INT_MAX, * and the index of the last character in a string of length INT_MAX * is INT_MAX-1. * * Any absolute index value parsed outside that range is encoded * using the before and after values passed in by the * caller as the encoding to use for indices that are either - * less than or greater than the usable index range. TCL_INDEX_NONE + * less than or greater than the usable index range. TCL_INDEX_AFTER * is available as a good choice for most callers to use for - * after. Likewise, the value TCL_INDEX_NONE is good for + * after. Likewise, the value TCL_INDEX_BEFORE is good for * most callers to use for before. Other values are possible * when the caller knows it is helpful in producing its own behavior * for indices before and after the indexed item. * * A token can also be parsed as an end-relative index expression. @@ -3751,15 +3895,15 @@ * All end-relative expressions that indicate an index larger * than end (end+2, end--5) point beyond the end of the indexed * collection, and can be encoded as after. The end-relative * expressions that indicate an index less than or equal to end * are encoded relative to the value TCL_INDEX_END (-2). The - * index "end" is encoded as -2, down to the index "end-0x7ffffffe" + * index "end" is encoded as -2, down to the index "end-0x7FFFFFFE" * which is encoded as INT_MIN. Since the largest index into a - * string possible in Tcl 8 is 0x7ffffffe, the interpretation of - * "end-0x7ffffffe" for that largest string would be 0. Thus, - * if the tokens "end-0x7fffffff" or "end+-0x80000000" are parsed, + * string possible in Tcl 8 is 0x7FFFFFFE, the interpretation of + * "end-0x7FFFFFFE" for that largest string would be 0. Thus, + * if the tokens "end-0x7FFFFFFF" or "end+-0x80000000" are parsed, * they can be encoded with the before value. * * These details will require re-examination whenever string and * list length limits are increased, but that will likely also * mean a revised routine capable of returning Tcl_WideInt values. @@ -3776,56 +3920,51 @@ int TclIndexEncode( Tcl_Interp *interp, /* For error reporting, may be NULL */ Tcl_Obj *objPtr, /* Index value to parse */ - size_t before, /* Value to return for index before beginning */ - size_t after, /* Value to return for index after end */ + int before, /* Value to return for index before beginning */ + int after, /* Value to return for index after end */ int *indexPtr) /* Where to write the encoded answer, not NULL */ { - ClientData cd; - Tcl_WideInt wide; - int idx, numType, code = TclGetNumberFromObj(NULL, objPtr, &cd, &numType); + int idx; - if ((code == TCL_OK) && (numType == TCL_NUMBER_INT)) { - /* We parsed a value in the range WIDE_MIN...WIDE_MAX */ - wide = (*(Tcl_WideInt *)cd); + if (TCL_OK == TclGetIntFromObj(NULL, objPtr, &idx)) { + /* We parsed a value in the range INT_MIN...INT_MAX */ integerEncode: - if (wide < 0) { + if (idx < TCL_INDEX_START) { /* All negative absolute indices are "before the beginning" */ idx = before; - } else if (wide >= INT_MAX) { + } else if (idx == INT_MAX) { /* This index value is always "after the end" */ idx = after; - } else { - idx = (int) wide; - } + } /* usual case, the absolute index value encodes itself */ - } else if (TCL_OK == GetEndOffsetFromObj(objPtr, 0, &wide)) { + } else if (TCL_OK == GetEndOffsetFromObj(objPtr, 0, &idx)) { /* * We parsed an end+offset index value. - * wide holds the offset value in the range WIDE_MIN...WIDE_MAX. + * idx holds the offset value in the range INT_MIN...INT_MAX. */ - if (wide > 0) { + if (idx > 0) { /* - * All end+positive or end-negative expressions + * All end+postive or end-negative expressions * always indicate "after the end". */ - idx = (int) after; - } else if (wide < INT_MIN - (int) TCL_INDEX_END) { + idx = after; + } else if (idx < INT_MIN - TCL_INDEX_END) { /* These indices always indicate "before the beginning */ - idx = (int) before; + idx = before; } else { /* Encoded end-positive (or end+negative) are offset */ - idx = (int) wide + (int) TCL_INDEX_END; + idx += TCL_INDEX_END; } /* TODO: Consider flag to suppress repeated end-offset parse. */ - } else if (TCL_OK == GetWideForIndex(interp, objPtr, 0, &wide)) { + } else if (TCL_OK == TclGetIntForIndexM(interp, objPtr, 0, &idx)) { /* * Only reach this case when the index value is a - * constant index arithmetic expression, and wide + * constant index arithmetic expression, and idx * holds the result. Treat it the same as if it were * parsed as an absolute integer value. */ goto integerEncode; } else { @@ -3848,22 +3987,86 @@ * The decoded index value. * *---------------------------------------------------------------------- */ -size_t +int TclIndexDecode( int encoded, /* Value to decode */ - size_t endValue) /* Meaning of "end" to use, > TCL_INDEX_END */ -{ - if (encoded > (int)TCL_INDEX_END) { - return encoded; - } - if (endValue >= TCL_INDEX_END - encoded) { - return endValue + encoded - TCL_INDEX_END; - } - return TCL_INDEX_NONE; + int endValue) /* Meaning of "end" to use, > TCL_INDEX_END */ +{ + if (encoded <= TCL_INDEX_END) { + return (encoded - TCL_INDEX_END) + endValue; + } + return encoded; +} + +/* + *---------------------------------------------------------------------- + * + * TclCheckBadOctal -- + * + * This function checks for a bad octal value and appends a meaningful + * error to the interp's result. + * + * Results: + * 1 if the argument was a bad octal, else 0. + * + * Side effects: + * The interpreter's result is modified. + * + *---------------------------------------------------------------------- + */ + +int +TclCheckBadOctal( + Tcl_Interp *interp, /* Interpreter to use for error reporting. If + * NULL, then no error message is left after + * errors. */ + const char *value) /* String to check. */ +{ + const char *p = value; + + /* + * A frequent mistake is invalid octal values due to an unwanted leading + * zero. Try to generate a meaningful error message. + */ + + while (TclIsSpaceProcM(*p)) { + p++; + } + if (*p == '+' || *p == '-') { + p++; + } + if (*p == '0') { + if ((p[1] == 'o') || p[1] == 'O') { + p += 2; + } + while (isdigit(UCHAR(*p))) { /* INTL: digit. */ + p++; + } + while (TclIsSpaceProcM(*p)) { + p++; + } + if (*p == '\0') { + /* + * Reached end of string. + */ + + if (interp != NULL) { + /* + * Don't reset the result here because we want this result to + * be added to an existing error message as extra info. + */ + + Tcl_AppendToObj(Tcl_GetObjResult(interp), + " (looks like invalid octal number)", -1); + } + return 1; + } + } + return 0; } /* *---------------------------------------------------------------------- * @@ -3881,11 +4084,11 @@ Tcl_HashSearch search; Tcl_HashEntry *hPtr; for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - Tcl_Obj *objPtr = Tcl_GetHashValue(hPtr); + Tcl_Obj *objPtr = (Tcl_Obj *)Tcl_GetHashValue(hPtr); Tcl_DecrRefCount(objPtr); Tcl_DeleteHashEntry(hPtr); } } @@ -3911,14 +4114,14 @@ static Tcl_HashTable * GetThreadHash( Tcl_ThreadDataKey *keyPtr) { Tcl_HashTable **tablePtrPtr = - Tcl_GetThreadData(keyPtr, sizeof(Tcl_HashTable *)); + (Tcl_HashTable **)Tcl_GetThreadData(keyPtr, sizeof(Tcl_HashTable *)); if (NULL == *tablePtrPtr) { - *tablePtrPtr = Tcl_Alloc(sizeof(Tcl_HashTable)); + *tablePtrPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); Tcl_CreateThreadExitHandler(FreeThreadHash, *tablePtrPtr); Tcl_InitHashTable(*tablePtrPtr, TCL_ONE_WORD_KEYS); } return *tablePtrPtr; } @@ -3939,15 +4142,15 @@ static void FreeThreadHash( ClientData clientData) { - Tcl_HashTable *tablePtr = clientData; + Tcl_HashTable *tablePtr = (Tcl_HashTable *)clientData; ClearHash(tablePtr); Tcl_DeleteHashTable(tablePtr); - Tcl_Free(tablePtr); + ckfree(tablePtr); } /* *---------------------------------------------------------------------- * @@ -3961,15 +4164,15 @@ static void FreeProcessGlobalValue( ClientData clientData) { - ProcessGlobalValue *pgvPtr = clientData; + ProcessGlobalValue *pgvPtr = (ProcessGlobalValue *)clientData; pgvPtr->epoch++; pgvPtr->numBytes = 0; - Tcl_Free(pgvPtr->value); + ckfree(pgvPtr->value); pgvPtr->value = NULL; if (pgvPtr->encoding) { Tcl_FreeEncoding(pgvPtr->encoding); pgvPtr->encoding = NULL; } @@ -4004,17 +4207,16 @@ * Fill the global string value. */ pgvPtr->epoch++; if (NULL != pgvPtr->value) { - Tcl_Free(pgvPtr->value); + ckfree(pgvPtr->value); } else { Tcl_CreateExitHandler(FreeProcessGlobalValue, pgvPtr); } - bytes = TclGetString(newValue); - pgvPtr->numBytes = newValue->length; - pgvPtr->value = Tcl_Alloc(pgvPtr->numBytes + 1); + bytes = Tcl_GetStringFromObj(newValue, &pgvPtr->numBytes); + pgvPtr->value = (char *)ckalloc(pgvPtr->numBytes + 1); memcpy(pgvPtr->value, bytes, pgvPtr->numBytes + 1); if (pgvPtr->encoding) { Tcl_FreeEncoding(pgvPtr->encoding); } pgvPtr->encoding = encoding; @@ -4026,11 +4228,11 @@ */ Tcl_IncrRefCount(newValue); cacheMap = GetThreadHash(&pgvPtr->key); ClearHash(cacheMap); - hPtr = Tcl_CreateHashEntry(cacheMap, (void *)(pgvPtr->epoch), &dummy); + hPtr = Tcl_CreateHashEntry(cacheMap, INT2PTR(pgvPtr->epoch), &dummy); Tcl_SetHashValue(hPtr, newValue); Tcl_MutexUnlock(&pgvPtr->mutex); } /* @@ -4052,19 +4254,19 @@ ProcessGlobalValue *pgvPtr) { Tcl_Obj *value = NULL; Tcl_HashTable *cacheMap; Tcl_HashEntry *hPtr; - size_t epoch = pgvPtr->epoch; + int epoch = pgvPtr->epoch; if (pgvPtr->encoding) { Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL); if (pgvPtr->encoding != current) { /* - * The system encoding has changed since the master string value - * was saved. Convert the master value to be based on the new + * The system encoding has changed since the global string value + * was saved. Convert the global value to be based on the new * system encoding. */ Tcl_DString native, newValue; @@ -4073,12 +4275,12 @@ Tcl_UtfToExternalDString(pgvPtr->encoding, pgvPtr->value, pgvPtr->numBytes, &native); Tcl_ExternalToUtfDString(current, Tcl_DStringValue(&native), Tcl_DStringLength(&native), &newValue); Tcl_DStringFree(&native); - Tcl_Free(pgvPtr->value); - pgvPtr->value = Tcl_Alloc(Tcl_DStringLength(&newValue) + 1); + ckfree(pgvPtr->value); + pgvPtr->value = (char *)ckalloc(Tcl_DStringLength(&newValue) + 1); memcpy(pgvPtr->value, Tcl_DStringValue(&newValue), Tcl_DStringLength(&newValue) + 1); Tcl_DStringFree(&newValue); Tcl_FreeEncoding(pgvPtr->encoding); pgvPtr->encoding = current; @@ -4086,11 +4288,11 @@ } else { Tcl_FreeEncoding(current); } } cacheMap = GetThreadHash(&pgvPtr->key); - hPtr = Tcl_FindHashEntry(cacheMap, (void *) (epoch)); + hPtr = Tcl_FindHashEntry(cacheMap, INT2PTR(epoch)); if (NULL == hPtr) { int dummy; /* * No cache for the current epoch - must be a new one. @@ -4119,16 +4321,16 @@ * Store a copy of the shared value in our epoch-indexed cache. */ value = Tcl_NewStringObj(pgvPtr->value, pgvPtr->numBytes); hPtr = Tcl_CreateHashEntry(cacheMap, - (void *)(pgvPtr->epoch), &dummy); + INT2PTR(pgvPtr->epoch), &dummy); Tcl_MutexUnlock(&pgvPtr->mutex); Tcl_SetHashValue(hPtr, value); Tcl_IncrRefCount(value); } - return Tcl_GetHashValue(hPtr); + return (Tcl_Obj *)Tcl_GetHashValue(hPtr); } /* *---------------------------------------------------------------------- * @@ -4202,18 +4404,44 @@ */ const char * Tcl_GetNameOfExecutable(void) { - Tcl_Obj *obj = TclGetObjNameOfExecutable(); - const char *bytes = TclGetString(obj); + int numBytes; + const char *bytes = + Tcl_GetStringFromObj(TclGetObjNameOfExecutable(), &numBytes); - if (obj->length == 0) { + if (numBytes == 0) { return NULL; } return bytes; } + +/* + *---------------------------------------------------------------------- + * + * TclpGetTime -- + * + * Deprecated synonym for Tcl_GetTime. This function is provided for the + * benefit of extensions written before Tcl_GetTime was exported from the + * library. + * + * Results: + * None. + * + * Side effects: + * Stores current time in the buffer designated by "timePtr" + * + *---------------------------------------------------------------------- + */ + +void +TclpGetTime( + Tcl_Time *timePtr) +{ + Tcl_GetTime(timePtr); +} /* *---------------------------------------------------------------------- * * TclGetPlatform -- @@ -4258,11 +4486,11 @@ int TclReToGlob( Tcl_Interp *interp, const char *reStr, - size_t reStrLen, + int reStrLen, Tcl_DString *dsPtr, int *exactPtr, int *quantifiersFoundPtr) { int anchorLeft, anchorRight, lastIsStar, numStars; Index: generic/tclVar.c ================================================================== --- generic/tclVar.c +++ generic/tclVar.c @@ -43,11 +43,11 @@ Tcl_HashSearch *searchPtr); static inline Var * VarHashNextVar(Tcl_HashSearch *searchPtr); static inline void CleanupVar(Var *varPtr, Var *arrayPtr); #define VarHashGetValue(hPtr) \ - ((Var *) ((char *)hPtr - offsetof(VarInHash, entry))) + ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry))) /* * NOTE: VarHashCreateVar increments the recount of its key argument. * All callers that will call Tcl_DecrRefCount on that argument must * call Tcl_IncrRefCount on it before passing it in. This requirement @@ -58,16 +58,18 @@ VarHashCreateVar( TclVarHashTable *tablePtr, Tcl_Obj *key, int *newPtr) { - Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&tablePtr->table, key, newPtr); + Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&tablePtr->table, + key, newPtr); - if (!hPtr) { + if (hPtr) { + return VarHashGetValue(hPtr); + } else { return NULL; } - return VarHashGetValue(hPtr); } #define VarHashFindVar(tablePtr, key) \ VarHashCreateVar((tablePtr), (key), NULL) @@ -88,26 +90,28 @@ TclVarHashTable *tablePtr, Tcl_HashSearch *searchPtr) { Tcl_HashEntry *hPtr = VarHashFirstEntry(tablePtr, searchPtr); - if (!hPtr) { + if (hPtr) { + return VarHashGetValue(hPtr); + } else { return NULL; } - return VarHashGetValue(hPtr); } static inline Var * VarHashNextVar( Tcl_HashSearch *searchPtr) { Tcl_HashEntry *hPtr = VarHashNextEntry(searchPtr); - if (!hPtr) { + if (hPtr) { + return VarHashGetValue(hPtr); + } else { return NULL; } - return VarHashGetValue(hPtr); } #define VarHashGetKey(varPtr) \ (((VarInHash *)(varPtr))->entry.key.objPtr) @@ -117,21 +121,21 @@ /* * The strings below are used to indicate what went wrong when a variable * access is denied. */ -static const char *noSuchVar = "no such variable"; -static const char *isArray = "variable is array"; -static const char *needArray = "variable isn't array"; -static const char *noSuchElement = "no such element in array"; -static const char *danglingElement = +static const char NOSUCHVAR[] = "no such variable"; +static const char ISARRAY[] = "variable is array"; +static const char NEEDARRAY[] = "variable isn't array"; +static const char NOSUCHELEMENT[] = "no such element in array"; +static const char DANGLINGELEMENT[] = "upvar refers to element in deleted array"; -static const char *danglingVar = +static const char DANGLINGVAR[] = "upvar refers to variable in deleted namespace"; -static const char *badNamespace = "parent namespace doesn't exist"; -static const char *missingName = "missing variable name"; -static const char *isArrayElement = +static const char BADNAMESPACE[] = "parent namespace doesn't exist"; +static const char MISSINGNAME[] = "missing variable name"; +static const char ISARRAYELEMENT[] = "name refers to an element in an array"; /* * A test to see if we are in a call frame that has local variables. This is * true if we are inside a procedure body. @@ -143,11 +147,10 @@ * The following structure describes an enumerative search in progress on an * array variable; this are invoked with options to the "array" command. */ typedef struct ArraySearch { - Tcl_Obj *name; /* Name of this search */ int id; /* Integer id used to distinguish among * multiple concurrent searches for the same * array. */ struct Var *varPtr; /* Pointer to array variable that's being * searched. */ @@ -162,36 +165,16 @@ struct ArraySearch *nextPtr;/* Next in list of all active searches for * this variable, or NULL if this is the last * one. */ } ArraySearch; -/* - * TIP #508: [array default] - * - * The following structure extends the regular TclVarHashTable used by array - * variables to store their optional default value. - */ - -typedef struct ArrayVarHashTable { - TclVarHashTable table; - Tcl_Obj *defaultObj; -} ArrayVarHashTable; - /* * Forward references to functions defined later in this file: */ static void AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *patternPtr, int includeLinks); -static void ArrayPopulateSearch(Tcl_Interp *interp, - Tcl_Obj *arrayNameObj, Var *varPtr, - ArraySearch *searchPtr); -static void ArrayDoneSearch(Interp *iPtr, Var *varPtr, - ArraySearch *searchPtr); -static Tcl_NRPostProc ArrayForLoopCallback; -static int ArrayForNRCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const *objv); static void DeleteSearches(Interp *iPtr, Var *arrayVarPtr); static void DeleteArray(Interp *iPtr, Tcl_Obj *arrayNamePtr, Var *varPtr, int flags, int index); static int LocateArray(Tcl_Interp *interp, Tcl_Obj *name, Var **varPtrPtr, int *isArrayPtr); @@ -206,20 +189,12 @@ static ArraySearch * ParseSearchId(Tcl_Interp *interp, const Var *varPtr, Tcl_Obj *varNamePtr, Tcl_Obj *handleObj); static void UnsetVarStruct(Var *varPtr, Var *arrayPtr, Interp *iPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags, int index); - -/* - * TIP #508: [array default] - */ - -static int ArrayDefaultCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static void DeleteArrayVar(Var *arrayPtr); -static void SetArrayDefault(Var *arrayPtr, Tcl_Obj *defaultObj); +static int SetArraySearchObj(Tcl_Interp *interp, + Tcl_Obj *objPtr); /* * Functions defined in this file that may be exported in the future for use * by the bytecode compiler and engine or to the public interface. */ @@ -228,13 +203,18 @@ Tcl_Obj *varNamePtr, int flags, const int create, const char **errMsgPtr, int *indexPtr); static Tcl_DupInternalRepProc DupLocalVarName; static Tcl_FreeInternalRepProc FreeLocalVarName; +static Tcl_UpdateStringProc PanicOnUpdateVarName; static Tcl_FreeInternalRepProc FreeParsedVarName; static Tcl_DupInternalRepProc DupParsedVarName; +static Tcl_UpdateStringProc UpdateParsedVarName; + +static Tcl_UpdateStringProc PanicOnUpdateVarName; +static Tcl_SetFromAnyProc PanicOnSetVarName; /* * Types of Tcl_Objs used to cache variable lookups. * * localVarName - INTERNALREP DEFINITION: @@ -249,56 +229,34 @@ * Tcl_Obj), or NULL if it is a scalar variable */ static const Tcl_ObjType localVarNameType = { "localVarName", - FreeLocalVarName, DupLocalVarName, NULL, NULL -}; - -#define LocalSetIntRep(objPtr, index, namePtr) \ - do { \ - Tcl_ObjIntRep ir; \ - Tcl_Obj *ptr = (namePtr); \ - if (ptr) {Tcl_IncrRefCount(ptr);} \ - ir.twoPtrValue.ptr1 = ptr; \ - ir.twoPtrValue.ptr2 = INT2PTR(index); \ - Tcl_StoreIntRep((objPtr), &localVarNameType, &ir); \ - } while (0) - -#define LocalGetIntRep(objPtr, index, name) \ - do { \ - const Tcl_ObjIntRep *irPtr; \ - irPtr = TclFetchIntRep((objPtr), &localVarNameType); \ - (name) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ - (index) = irPtr ? PTR2INT(irPtr->twoPtrValue.ptr2) : -1; \ - } while (0) - -static const Tcl_ObjType parsedVarNameType = { - "parsedVarName", - FreeParsedVarName, DupParsedVarName, NULL, NULL -}; - -#define ParsedSetIntRep(objPtr, arrayPtr, elem) \ - do { \ - Tcl_ObjIntRep ir; \ - Tcl_Obj *ptr1 = (arrayPtr); \ - Tcl_Obj *ptr2 = (elem); \ - if (ptr1) {Tcl_IncrRefCount(ptr1);} \ - if (ptr2) {Tcl_IncrRefCount(ptr2);} \ - ir.twoPtrValue.ptr1 = ptr1; \ - ir.twoPtrValue.ptr2 = ptr2; \ - Tcl_StoreIntRep((objPtr), &parsedVarNameType, &ir); \ - } while (0) - -#define ParsedGetIntRep(objPtr, parsed, array, elem) \ - do { \ - const Tcl_ObjIntRep *irPtr; \ - irPtr = TclFetchIntRep((objPtr), &parsedVarNameType); \ - (parsed) = (irPtr != NULL); \ - (array) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ - (elem) = irPtr ? irPtr->twoPtrValue.ptr2 : NULL; \ - } while (0) + FreeLocalVarName, DupLocalVarName, PanicOnUpdateVarName, PanicOnSetVarName +}; + +static const Tcl_ObjType tclParsedVarNameType = { + "parsedVarName", + FreeParsedVarName, DupParsedVarName, UpdateParsedVarName, PanicOnSetVarName +}; + +/* + * Type of Tcl_Objs used to speed up array searches. + * + * INTERNALREP DEFINITION: + * twoPtrValue.ptr1: searchIdNumber (cast to pointer) + * twoPtrValue.ptr2: variableNameStartInString (cast to pointer) + * + * Note that the value stored in ptr2 is the offset into the string of the + * start of the variable name and not the address of the variable name itself, + * as this can be safely copied. + */ + +const Tcl_ObjType tclArraySearchType = { + "array search", + NULL, NULL, NULL, SetArraySearchObj +}; Var * TclVarHashCreateVar( TclVarHashTable *tablePtr, const char *key, @@ -341,11 +299,11 @@ static int NotArrayError( Tcl_Interp *interp, Tcl_Obj *name) { - const char *nameStr = TclGetString(name); + const char *nameStr = Tcl_GetString(name); Tcl_SetObjResult(interp, Tcl_ObjPrintf("\"%s\" isn't an array", nameStr)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", nameStr, NULL); return TCL_ERROR; @@ -380,24 +338,22 @@ Var *arrayPtr) /* Array that contains the variable, or NULL * if this variable isn't an array element. */ { if (TclIsVarUndefined(varPtr) && TclIsVarInHash(varPtr) && !TclIsVarTraced(varPtr) - && (VarHashRefCount(varPtr) == (unsigned) - !TclIsVarDeadHash(varPtr))) { + && (VarHashRefCount(varPtr) == !TclIsVarDeadHash(varPtr))) { if (VarHashRefCount(varPtr) == 0) { - Tcl_Free(varPtr); + ckfree(varPtr); } else { VarHashDeleteEntry(varPtr); } } if (arrayPtr != NULL && TclIsVarUndefined(arrayPtr) && TclIsVarInHash(arrayPtr) && !TclIsVarTraced(arrayPtr) && - (VarHashRefCount(arrayPtr) == (unsigned) - !TclIsVarDeadHash(arrayPtr))) { + (VarHashRefCount(arrayPtr) == !TclIsVarDeadHash(arrayPtr))) { if (VarHashRefCount(arrayPtr) == 0) { - Tcl_Free(arrayPtr); + ckfree(arrayPtr); } else { VarHashDeleteEntry(arrayPtr); } } } @@ -519,22 +475,23 @@ * a variable that has been unset but it only being kept in existence (if * VAR_UNDEFINED) by a trace. * * Side effects: * New hashtable entries may be created if createPart1 or createPart2 - * are 1. The object part1Ptr is converted to one of localVarNameType - * or parsedVarNameType and caches as much of the lookup as it can. + * are 1. The object part1Ptr is converted to one of localVarNameType, + * tclNsVarNameType or tclParsedVarNameType and caches as much of the + * lookup as it can. * When createPart1 is 1, callers must IncrRefCount part1Ptr if they * plan to DecrRefCount it. * *---------------------------------------------------------------------- */ Var * TclObjLookupVar( Tcl_Interp *interp, /* Interpreter to use for lookup. */ - register Tcl_Obj *part1Ptr, /* If part2 isn't NULL, this is the name of an + Tcl_Obj *part1Ptr, /* If part2 isn't NULL, this is the name of an * array. Otherwise, this is a full variable * name that could include a parenthesized * array element. */ const char *part2, /* Name of element within array, or NULL. */ int flags, /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, @@ -602,32 +559,37 @@ * array, *arrayPtrPtr gets filled in with * address of array variable. Otherwise this * is set to NULL. */ { Interp *iPtr = (Interp *) interp; - CallFrame *varFramePtr = iPtr->varFramePtr; - register Var *varPtr; /* Points to the variable's in-frame Var + Var *varPtr; /* Points to the variable's in-frame Var * structure. */ + const char *part1; + int index, len1, len2; + int parsed = 0; + Tcl_Obj *objPtr; + const Tcl_ObjType *typePtr = part1Ptr->typePtr; const char *errMsg = NULL; - int index, parsed = 0; - - int localIndex; - Tcl_Obj *namePtr, *arrayPtr, *elem; - + CallFrame *varFramePtr = iPtr->varFramePtr; + const char *part2 = part2Ptr? TclGetString(part2Ptr):NULL; + char *newPart2 = NULL; *arrayPtrPtr = NULL; - restart: - LocalGetIntRep(part1Ptr, localIndex, namePtr); - if (localIndex >= 0) { + if (typePtr == &localVarNameType) { + int localIndex; + + localVarNameTypeHandling: + localIndex = PTR2INT(part1Ptr->internalRep.twoPtrValue.ptr2); if (HasLocalVars(varFramePtr) && !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) && (localIndex < varFramePtr->numCompiledLocals)) { /* * Use the cached index if the names coincide. */ - Tcl_Obj *checkNamePtr = localName(varFramePtr, localIndex); + Tcl_Obj *namePtr = part1Ptr->internalRep.twoPtrValue.ptr1; + Tcl_Obj *checkNamePtr = localName(iPtr->varFramePtr, localIndex); if ((!namePtr && (checkNamePtr == part1Ptr)) || (namePtr && (checkNamePtr == namePtr))) { varPtr = (Var *) &(varFramePtr->compiledLocals[localIndex]); goto donePart1; @@ -635,80 +597,132 @@ } goto doneParsing; } /* - * If part1Ptr is a parsedVarNameType, retrieve the pre-parsed parts. + * If part1Ptr is a tclParsedVarNameType, separate it into the pre-parsed + * parts. */ - ParsedGetIntRep(part1Ptr, parsed, arrayPtr, elem); - if (parsed && arrayPtr) { + if (typePtr == &tclParsedVarNameType) { + if (part1Ptr->internalRep.twoPtrValue.ptr1 != NULL) { if (part2Ptr != NULL) { /* * ERROR: part1Ptr is already an array element, cannot specify * a part2. */ if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, - noSuchVar, -1); + NOSUCHVAR, -1); Tcl_SetErrorCode(interp, "TCL", "VALUE", "VARNAME", NULL); } return NULL; } - part2Ptr = elem; - part1Ptr = arrayPtr; - goto restart; + part2 = newPart2 = part1Ptr->internalRep.twoPtrValue.ptr2; + if (newPart2) { + part2Ptr = Tcl_NewStringObj(newPart2, -1); + if (createPart2) { + Tcl_IncrRefCount(part2Ptr); + } + } + part1Ptr = part1Ptr->internalRep.twoPtrValue.ptr1; + typePtr = part1Ptr->typePtr; + if (typePtr == &localVarNameType) { + goto localVarNameTypeHandling; + } + } + parsed = 1; } + part1 = TclGetStringFromObj(part1Ptr, &len1); - if (!parsed) { + if (!parsed && len1 && (*(part1 + len1 - 1) == ')')) { /* * part1Ptr is possibly an unparsed array element. */ - size_t len; - const char *part1 = TclGetStringFromObj(part1Ptr, &len); + int i; - if ((len > 1) && (part1[len - 1] == ')')) { - const char *part2 = strchr(part1, '('); - - if (part2) { + len2 = -1; + for (i = 0; i < len1; i++) { + if (*(part1 + i) == '(') { if (part2Ptr != NULL) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, - needArray, -1); + NEEDARRAY, -1); Tcl_SetErrorCode(interp, "TCL", "VALUE", "VARNAME", NULL); } return NULL; } - arrayPtr = Tcl_NewStringObj(part1, (part2 - part1)); - part2Ptr = Tcl_NewStringObj(part2 + 1, - len - (part2 - part1) - 2); + /* + * part1Ptr points to an array element; first copy the element + * name to a new string part2. + */ - ParsedSetIntRep(part1Ptr, arrayPtr, part2Ptr); + part2 = part1 + i + 1; + len2 = len1 - i - 2; + len1 = i; - part1Ptr = arrayPtr; + newPart2 = ckalloc(len2 + 1); + memcpy(newPart2, part2, len2); + *(newPart2+len2) = '\0'; + part2 = newPart2; + part2Ptr = Tcl_NewStringObj(newPart2, -1); + if (createPart2) { + Tcl_IncrRefCount(part2Ptr); + } + + /* + * Free the internal rep of the original part1Ptr, now renamed + * objPtr, and set it to tclParsedVarNameType. + */ + + objPtr = part1Ptr; + TclFreeIntRep(objPtr); + objPtr->typePtr = &tclParsedVarNameType; + + /* + * Define a new string object to hold the new part1Ptr, i.e., + * the array name. Set the internal rep of objPtr, reset + * typePtr and part1 to contain the references to the array + * name. + */ + + TclNewStringObj(part1Ptr, part1, len1); + Tcl_IncrRefCount(part1Ptr); + + objPtr->internalRep.twoPtrValue.ptr1 = part1Ptr; + objPtr->internalRep.twoPtrValue.ptr2 = (void *) part2; + + typePtr = part1Ptr->typePtr; + part1 = TclGetString(part1Ptr); + break; } } } doneParsing: /* * part1Ptr is not an array element; look it up, and convert it to one of * the cached types if possible. */ + + TclFreeIntRep(part1Ptr); varPtr = TclLookupSimpleVar(interp, part1Ptr, flags, createPart1, &errMsg, &index); if (varPtr == NULL) { if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, errMsg, -1); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", TclGetString(part1Ptr), NULL); } + if (newPart2) { + Tcl_DecrRefCount(part2Ptr); + } return NULL; } /* * Cache the newly found variable if possible. @@ -716,50 +730,32 @@ if (index >= 0) { /* * An indexed local variable. */ + Tcl_Obj *cachedNamePtr = localName(iPtr->varFramePtr, index); - Tcl_Obj *cachedNamePtr = localName(varFramePtr, index); - - if (part1Ptr == cachedNamePtr) { - LocalSetIntRep(part1Ptr, index, NULL); + part1Ptr->typePtr = &localVarNameType; + if (part1Ptr != cachedNamePtr) { + part1Ptr->internalRep.twoPtrValue.ptr1 = cachedNamePtr; + Tcl_IncrRefCount(cachedNamePtr); + if (cachedNamePtr->typePtr != &localVarNameType + || cachedNamePtr->internalRep.twoPtrValue.ptr1 != NULL) { + TclFreeIntRep(cachedNamePtr); + } } else { - /* - * [80304238ac] Trickiness here. We will store and incr the - * refcount on cachedNamePtr. Trouble is that it's possible - * (see test var-22.1) for cachedNamePtr to have an intrep - * that contains a stored and refcounted part1Ptr. This - * would be a reference cycle which leads to a memory leak. - * - * The solution here is to wipe away all intrep(s) in - * cachedNamePtr and leave it as string only. This is - * radical and destructive, so a better idea would be welcome. - */ - - /* - * Firstly set cached local var reference (avoid free before set, - * see [45b9faf103f2]) - */ - LocalSetIntRep(part1Ptr, index, cachedNamePtr); - - /* Then wipe it */ - TclFreeIntRep(cachedNamePtr); - - /* - * Now go ahead and convert it the the "localVarName" type, - * since we suspect at least some use of the value as a - * varname and we want to resolve it quickly. - */ - LocalSetIntRep(cachedNamePtr, index, NULL); - } + part1Ptr->internalRep.twoPtrValue.ptr1 = NULL; + } + part1Ptr->internalRep.twoPtrValue.ptr2 = INT2PTR(index); } else { /* * At least mark part1Ptr as already parsed. */ - ParsedSetIntRep(part1Ptr, NULL, NULL); + part1Ptr->typePtr = &tclParsedVarNameType; + part1Ptr->internalRep.twoPtrValue.ptr1 = NULL; + part1Ptr->internalRep.twoPtrValue.ptr2 = NULL; } donePart1: while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; @@ -771,10 +767,13 @@ */ *arrayPtrPtr = varPtr; varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, flags, msg, createPart1, createPart2, varPtr, -1); + if (newPart2) { + Tcl_DecrRefCount(part2Ptr); + } } return varPtr; } /* @@ -845,12 +844,11 @@ Tcl_Var var; /* Used to search for global names. */ Var *varPtr; /* Points to the Var structure returned for * the variable. */ Namespace *varNsPtr, *cxtNsPtr, *dummy1Ptr, *dummy2Ptr; ResolverScheme *resPtr; - int isNew, i, result; - size_t varLen; + int isNew, i, result, varLen; const char *varName = TclGetStringFromObj(varNamePtr, &varLen); varPtr = NULL; varNsPtr = NULL; /* Set non-NULL if a nonlocal variable. */ *indexPtr = -3; @@ -919,12 +917,16 @@ if (lookGlobal) { *indexPtr = -1; flags = (flags | TCL_GLOBAL_ONLY) & ~TCL_NAMESPACE_ONLY; } else { - flags = (flags | TCL_NAMESPACE_ONLY); - *indexPtr = -2; + if (flags & TCL_AVOID_RESOLVERS) { + flags = (flags | TCL_NAMESPACE_ONLY); + } + if (flags & TCL_NAMESPACE_ONLY) { + *indexPtr = -2; + } } /* * Don't pass TCL_LEAVE_ERR_MSG, we may yet create the variable, or * otherwise generate our own error! @@ -934,56 +936,53 @@ (Tcl_Namespace *) cxtNsPtr, (flags | TCL_AVOID_RESOLVERS) & ~TCL_LEAVE_ERR_MSG); if (varPtr == NULL) { Tcl_Obj *tailPtr; - if (!create) { /* Var wasn't found and not to create it. */ - *errMsgPtr = noSuchVar; - return NULL; - } - - /* - * Var wasn't found so create it. - */ - - TclGetNamespaceForQualName(interp, varName, cxtNsPtr, flags, - &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail); - if (varNsPtr == NULL) { - *errMsgPtr = badNamespace; - return NULL; - } else if (tail == NULL) { - *errMsgPtr = missingName; - return NULL; - } - if (tail != varName) { - tailPtr = Tcl_NewStringObj(tail, -1); - } else { - tailPtr = varNamePtr; - } - varPtr = VarHashCreateVar(&varNsPtr->varTable, tailPtr, &isNew); - if (lookGlobal) { - /* - * The variable was created starting from the global - * namespace: a global reference is returned even if it wasn't - * explicitly requested. - */ - - *indexPtr = -1; - } else { - *indexPtr = -2; + if (create) { /* Var wasn't found so create it. */ + TclGetNamespaceForQualName(interp, varName, cxtNsPtr, + flags, &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail); + if (varNsPtr == NULL) { + *errMsgPtr = BADNAMESPACE; + return NULL; + } else if (tail == NULL) { + *errMsgPtr = MISSINGNAME; + return NULL; + } + if (tail != varName) { + tailPtr = Tcl_NewStringObj(tail, -1); + } else { + tailPtr = varNamePtr; + } + varPtr = VarHashCreateVar(&varNsPtr->varTable, tailPtr, + &isNew); + if (lookGlobal) { + /* + * The variable was created starting from the global + * namespace: a global reference is returned even if it + * wasn't explicitly requested. + */ + + *indexPtr = -1; + } else { + *indexPtr = -2; + } + } else { /* Var wasn't found and not to create it. */ + *errMsgPtr = NOSUCHVAR; + return NULL; } } } else { /* Local var: look in frame varFramePtr. */ int localCt = varFramePtr->numCompiledLocals; if (localCt > 0) { Tcl_Obj **objPtrPtr = &varFramePtr->localCachePtr->varName0; const char *localNameStr; - size_t localLen; + int localLen; for (i=0 ; ivarTablePtr; if (create) { if (tablePtr == NULL) { - tablePtr = Tcl_Alloc(sizeof(TclVarHashTable)); + tablePtr = ckalloc(sizeof(TclVarHashTable)); TclInitVarHashTable(tablePtr, NULL); varFramePtr->varTablePtr = tablePtr; } varPtr = VarHashCreateVar(tablePtr, varNamePtr, &isNew); } else { @@ -1006,11 +1005,11 @@ varPtr = NULL; if (tablePtr != NULL) { varPtr = VarHashFindVar(tablePtr, varNamePtr); } if (varPtr == NULL) { - *errMsgPtr = noSuchVar; + *errMsgPtr = NOSUCHVAR; } } } return varPtr; } @@ -1074,10 +1073,12 @@ Var *arrayPtr, /* Pointer to the array's Var structure. */ int index) /* If >=0, the index of the local array. */ { int isNew; Var *varPtr; + TclVarHashTable *tablePtr; + Namespace *nsPtr; /* * We're dealing with an array element. Make sure the variable is an array * and look up the element (create the element if desired). */ @@ -1084,11 +1085,11 @@ if (TclIsVarUndefined(arrayPtr) && !TclIsVarArrayElement(arrayPtr)) { if (!createArray) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, - noSuchVar, index); + NOSUCHVAR, index); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", arrayNamePtr?TclGetString(arrayNamePtr):NULL, NULL); } return NULL; } @@ -1099,21 +1100,30 @@ */ if (TclIsVarDeadHash(arrayPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, - danglingVar, index); + DANGLINGVAR, index); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", arrayNamePtr?TclGetString(arrayNamePtr):NULL, NULL); } return NULL; } - TclInitArrayVar(arrayPtr); + TclSetVarArray(arrayPtr); + tablePtr = ckalloc(sizeof(TclVarHashTable)); + arrayPtr->value.tablePtr = tablePtr; + + if (TclIsVarInHash(arrayPtr) && TclGetVarNsPtr(arrayPtr)) { + nsPtr = TclGetVarNsPtr(arrayPtr); + } else { + nsPtr = NULL; + } + TclInitVarHashTable(arrayPtr->value.tablePtr, nsPtr); } else if (!TclIsVarArray(arrayPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { - TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, needArray, + TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, NEEDARRAY, index); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", arrayNamePtr?TclGetString(arrayNamePtr):NULL, NULL); } return NULL; @@ -1131,18 +1141,61 @@ } else { varPtr = VarHashFindVar(arrayPtr->value.tablePtr, elNamePtr); if (varPtr == NULL) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, - noSuchElement, index); + NOSUCHELEMENT, index); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ELEMENT", TclGetString(elNamePtr), NULL); } } } return varPtr; } + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetVar -- + * + * Return the value of a Tcl variable as a string. + * + * Results: + * The return value points to the current value of varName as a string. + * If the variable is not defined or can't be read because of a clash in + * array usage then a NULL pointer is returned and an error message is + * left in the interp's result if the TCL_LEAVE_ERR_MSG flag is set. + * Note: the return value is only valid up until the next change to the + * variable; if you depend on the value lasting longer than that, then + * make yourself a private copy. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_GetVar +const char * +Tcl_GetVar( + Tcl_Interp *interp, /* Command interpreter in which varName is to + * be looked up. */ + const char *varName, /* Name of a variable in interp. */ + int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY or TCL_LEAVE_ERR_MSG + * bits. */ +{ + Tcl_Obj *varNamePtr = Tcl_NewStringObj(varName, -1); + Tcl_Obj *resultPtr = Tcl_ObjGetVar2(interp, varNamePtr, NULL, flags); + + TclDecrRefCount(varNamePtr); + + if (resultPtr == NULL) { + return NULL; + } + return TclGetString(resultPtr); +} /* *---------------------------------------------------------------------- * * Tcl_GetVar2 -- @@ -1275,14 +1328,14 @@ Tcl_Obj * Tcl_ObjGetVar2( Tcl_Interp *interp, /* Command interpreter in which variable is to * be looked up. */ - register Tcl_Obj *part1Ptr, /* Points to an object holding the name of an + Tcl_Obj *part1Ptr, /* Points to an object holding the name of an * array (if part2 is non-NULL) or the name of * a variable. */ - register Tcl_Obj *part2Ptr, /* If non-null, points to an object holding + Tcl_Obj *part2Ptr, /* If non-null, points to an object holding * the name of an element in the array * part1Ptr. */ int flags) /* OR-ed combination of TCL_GLOBAL_ONLY and * TCL_LEAVE_ERR_MSG bits. */ { @@ -1373,11 +1426,11 @@ Tcl_Obj * TclPtrGetVarIdx( Tcl_Interp *interp, /* Command interpreter in which variable is to * be looked up. */ - register Var *varPtr, /* The variable to be read.*/ + Var *varPtr, /* The variable to be read.*/ Var *arrayPtr, /* NULL for scalar variables, pointer to the * containing array otherwise. */ Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or * the name of a variable. */ Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element @@ -1411,40 +1464,18 @@ if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) { return varPtr->value.objPtr; } - /* - * Return the array default value if any. - */ - - if (arrayPtr && TclIsVarArray(arrayPtr) && TclGetArrayDefault(arrayPtr)) { - return TclGetArrayDefault(arrayPtr); - } - if (TclIsVarArrayElement(varPtr) && !arrayPtr) { - /* - * UGLY! Peek inside the implementation of things. This lets us get - * the default of an array even when we've been [upvar]ed to just an - * element of the array. - */ - - ArrayVarHashTable *avhtPtr = (ArrayVarHashTable *) - ((VarInHash *) varPtr)->entry.tablePtr; - - if (avhtPtr->defaultObj) { - return avhtPtr->defaultObj; - } - } - if (flags & TCL_LEAVE_ERR_MSG) { if (TclIsVarUndefined(varPtr) && arrayPtr && !TclIsVarUndefined(arrayPtr)) { - msg = noSuchElement; + msg = NOSUCHELEMENT; } else if (TclIsVarArray(varPtr)) { - msg = isArray; + msg = ISARRAY; } else { - msg = noSuchVar; + msg = NOSUCHVAR; } TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "read", msg, index); } /* @@ -1479,11 +1510,11 @@ /* ARGSUSED */ int Tcl_SetObjCmd( ClientData dummy, /* Not used. */ - register Tcl_Interp *interp,/* Current interpreter. */ + Tcl_Interp *interp,/* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Obj *varValueObj; @@ -1505,10 +1536,59 @@ } else { Tcl_WrongNumArgs(interp, 1, objv, "varName ?newValue?"); return TCL_ERROR; } } + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetVar -- + * + * Change the value of a variable. + * + * Results: + * Returns a pointer to the malloc'ed string which is the character + * representation of the variable's new value. The caller must not modify + * this string. If the write operation was disallowed then NULL is + * returned; if the TCL_LEAVE_ERR_MSG flag is set, then an explanatory + * message will be left in the interp's result. Note that the returned + * string may not be the same as newValue; this is because variable + * traces may modify the variable's value. + * + * Side effects: + * If varName is defined as a local or global variable in interp, its + * value is changed to newValue. If varName isn't currently defined, then + * a new global variable by that name is created. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_SetVar +const char * +Tcl_SetVar( + Tcl_Interp *interp, /* Command interpreter in which varName is to + * be looked up. */ + const char *varName, /* Name of a variable in interp. */ + const char *newValue, /* New value for varName. */ + int flags) /* Various flags that tell how to set value: + * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, + * TCL_APPEND_VALUE, TCL_LIST_ELEMENT, + * TCL_LEAVE_ERR_MSG. */ +{ + Tcl_Obj *varValuePtr, *varNamePtr = Tcl_NewStringObj(varName, -1); + + Tcl_IncrRefCount(varNamePtr); + varValuePtr = Tcl_ObjSetVar2(interp, varNamePtr, NULL, + Tcl_NewStringObj(newValue, -1), flags); + Tcl_DecrRefCount(varNamePtr); + + if (varValuePtr == NULL) { + return NULL; + } + return TclGetString(varValuePtr); +} /* *---------------------------------------------------------------------- * * Tcl_SetVar2 -- @@ -1656,14 +1736,14 @@ Tcl_Obj * Tcl_ObjSetVar2( Tcl_Interp *interp, /* Command interpreter in which variable is to * be found. */ - register Tcl_Obj *part1Ptr, /* Points to an object holding the name of an + Tcl_Obj *part1Ptr, /* Points to an object holding the name of an * array (if part2 is non-NULL) or the name of * a variable. */ - register Tcl_Obj *part2Ptr, /* If non-NULL, points to an object holding + Tcl_Obj *part2Ptr, /* If non-NULL, points to an object holding * the name of an element in the array * part1Ptr. */ Tcl_Obj *newValuePtr, /* New value for variable. */ int flags) /* Various flags that tell how to set value: * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, @@ -1746,134 +1826,10 @@ } /* *---------------------------------------------------------------------- * - * ListAppendInVar, StringAppendInVar -- - * - * Support functions for TclPtrSetVarIdx that implement various types of - * appending operations. - * - * Results: - * ListAppendInVar returns a Tcl result code (from the core list append - * operation). StringAppendInVar has no return value. - * - * Side effects: - * The variable or element of the array is updated. This may make the - * variable/element exist. Reference counts of values may be updated. - * - *---------------------------------------------------------------------- - */ - -static inline int -ListAppendInVar( - Tcl_Interp *interp, - Var *varPtr, - Var *arrayPtr, - Tcl_Obj *oldValuePtr, - Tcl_Obj *newValuePtr) -{ - if (oldValuePtr == NULL) { - /* - * No previous value. Check for defaults if there's an array we can - * ask this of. - */ - - if (arrayPtr) { - Tcl_Obj *defValuePtr = TclGetArrayDefault(arrayPtr); - - if (defValuePtr) { - oldValuePtr = Tcl_DuplicateObj(defValuePtr); - } - } - - if (oldValuePtr == NULL) { - /* - * No default. [lappend] semantics say this is like being an empty - * string. - */ - - TclNewObj(oldValuePtr); - } - varPtr->value.objPtr = oldValuePtr; - Tcl_IncrRefCount(oldValuePtr); /* Since var is referenced. */ - } else if (Tcl_IsShared(oldValuePtr)) { - varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); - TclDecrRefCount(oldValuePtr); - oldValuePtr = varPtr->value.objPtr; - Tcl_IncrRefCount(oldValuePtr); /* Since var is referenced. */ - } - - return Tcl_ListObjAppendElement(interp, oldValuePtr, newValuePtr); -} - -static inline void -StringAppendInVar( - Var *varPtr, - Var *arrayPtr, - Tcl_Obj *oldValuePtr, - Tcl_Obj *newValuePtr) -{ - /* - * If there was no previous value, either we use the array's default (if - * this is an array with a default at all) or we treat this as a simple - * set. - */ - - if (oldValuePtr == NULL) { - if (arrayPtr) { - Tcl_Obj *defValuePtr = TclGetArrayDefault(arrayPtr); - - if (defValuePtr) { - /* - * This is *almost* the same as the shared path below, except - * that the original value reference in defValuePtr is not - * decremented. - */ - - Tcl_Obj *valuePtr = Tcl_DuplicateObj(defValuePtr); - - varPtr->value.objPtr = valuePtr; - TclContinuationsCopy(valuePtr, defValuePtr); - Tcl_IncrRefCount(valuePtr); - Tcl_AppendObjToObj(valuePtr, newValuePtr); - if (newValuePtr->refCount == 0) { - Tcl_DecrRefCount(newValuePtr); - } - return; - } - } - varPtr->value.objPtr = newValuePtr; - Tcl_IncrRefCount(newValuePtr); - return; - } - - /* - * We append newValuePtr's bytes but don't change its ref count. Unless - * the reference is shared, when we have to duplicate in order to be safe - * to modify at all. - */ - - if (Tcl_IsShared(oldValuePtr)) { /* Append to copy. */ - varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); - - TclContinuationsCopy(varPtr->value.objPtr, oldValuePtr); - - TclDecrRefCount(oldValuePtr); - oldValuePtr = varPtr->value.objPtr; - Tcl_IncrRefCount(oldValuePtr); /* Since var is ref */ - } - - Tcl_AppendObjToObj(oldValuePtr, newValuePtr); - if (newValuePtr->refCount == 0) { - Tcl_DecrRefCount(newValuePtr); - } -} - -/* - *---------------------------------------------------------------------- - * * TclPtrSetVarIdx -- * * This function is the same as Tcl_SetVar2Ex above, except that it * requires pointers to the variable's Var structs in addition to the * variable names. @@ -1896,11 +1852,11 @@ Tcl_Obj * TclPtrSetVarIdx( Tcl_Interp *interp, /* Command interpreter in which variable is to * be looked up. */ - register Var *varPtr, /* Reference to the variable to set. */ + Var *varPtr, /* Reference to the variable to set. */ Var *arrayPtr, /* Reference to the array containing the * variable, or NULL if the variable is a * scalar. */ Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or * the name of a variable. NULL if the 'index' @@ -1929,15 +1885,15 @@ if (TclIsVarDeadHash(varPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { if (TclIsVarArrayElement(varPtr)) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", - danglingElement, index); + DANGLINGELEMENT, index); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ELEMENT", NULL); } else { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", - danglingVar, index); + DANGLINGVAR, index); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", NULL); } } goto earlyError; } @@ -1946,11 +1902,11 @@ * It's an error to try to set an array variable itself. */ if (TclIsVarArray(varPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { - TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", isArray,index); + TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", ISARRAY,index); Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); } goto earlyError; } @@ -1982,17 +1938,48 @@ if (flags & TCL_LIST_ELEMENT && !(flags & TCL_APPEND_VALUE)) { varPtr->value.objPtr = NULL; } if (flags & (TCL_APPEND_VALUE|TCL_LIST_ELEMENT)) { if (flags & TCL_LIST_ELEMENT) { /* Append list element. */ - result = ListAppendInVar(interp, varPtr, arrayPtr, oldValuePtr, + if (oldValuePtr == NULL) { + TclNewObj(oldValuePtr); + varPtr->value.objPtr = oldValuePtr; + Tcl_IncrRefCount(oldValuePtr); /* Since var is referenced. */ + } else if (Tcl_IsShared(oldValuePtr)) { + varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); + TclDecrRefCount(oldValuePtr); + oldValuePtr = varPtr->value.objPtr; + Tcl_IncrRefCount(oldValuePtr); /* Since var is referenced. */ + } + result = Tcl_ListObjAppendElement(interp, oldValuePtr, newValuePtr); if (result != TCL_OK) { goto earlyError; } } else { /* Append string. */ - StringAppendInVar(varPtr, arrayPtr, oldValuePtr, newValuePtr); + /* + * We append newValuePtr's bytes but don't change its ref count. + */ + + if (oldValuePtr == NULL) { + varPtr->value.objPtr = newValuePtr; + Tcl_IncrRefCount(newValuePtr); + } else { + if (Tcl_IsShared(oldValuePtr)) { /* Append to copy. */ + varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); + + TclContinuationsCopy(varPtr->value.objPtr, oldValuePtr); + + TclDecrRefCount(oldValuePtr); + oldValuePtr = varPtr->value.objPtr; + Tcl_IncrRefCount(oldValuePtr); /* Since var is ref */ + } + Tcl_AppendObjToObj(oldValuePtr, newValuePtr); + if (newValuePtr->refCount == 0) { + Tcl_DecrRefCount(newValuePtr); + } + } } } else if (newValuePtr != oldValuePtr) { /* * In this case we are replacing the value, so we don't need to do * more than swap the objects. @@ -2216,11 +2203,11 @@ * TCL_LEAVE_ERR_MSG. */ int index) /* Index into the local variable table of the * variable, or -1. Only used when part1Ptr is * NULL. */ { - register Tcl_Obj *varValuePtr; + Tcl_Obj *varValuePtr; if (TclIsVarInHash(varPtr)) { VarHashRefCount(varPtr)++; } varValuePtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, part1Ptr, @@ -2227,11 +2214,11 @@ part2Ptr, flags, index); if (TclIsVarInHash(varPtr)) { VarHashRefCount(varPtr)--; } if (varValuePtr == NULL) { - varValuePtr = Tcl_NewIntObj(0); + TclNewIntObj(varValuePtr, 0); } if (Tcl_IsShared(varValuePtr)) { /* Copy on write */ varValuePtr = Tcl_DuplicateObj(varValuePtr); @@ -2243,10 +2230,11 @@ return NULL; } } else { /* Unshared - can Incr in place */ if (TCL_OK == TclIncrObj(interp, varValuePtr, incrPtr)) { + /* * This seems dumb to write the incremeted value into the var * after we just adjusted the value in place, but the spec for * [incr] requires that write traces fire, and making this call * is the way to make that happen. @@ -2257,10 +2245,59 @@ } else { return NULL; } } } + +/* + *---------------------------------------------------------------------- + * + * Tcl_UnsetVar -- + * + * Delete a variable, so that it may not be accessed anymore. + * + * Results: + * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR if + * the variable can't be unset. In the event of an error, if the + * TCL_LEAVE_ERR_MSG flag is set then an error message is left in the + * interp's result. + * + * Side effects: + * If varName is defined as a local or global variable in interp, it is + * deleted. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_UnsetVar +int +Tcl_UnsetVar( + Tcl_Interp *interp, /* Command interpreter in which varName is to + * be looked up. */ + const char *varName, /* Name of a variable in interp. May be either + * a scalar name or an array name or an + * element in an array. */ + int flags) /* OR-ed combination of any of + * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY or + * TCL_LEAVE_ERR_MSG. */ +{ + int result; + Tcl_Obj *varNamePtr; + + varNamePtr = Tcl_NewStringObj(varName, -1); + Tcl_IncrRefCount(varNamePtr); + + /* + * Filter to pass through only the flags this interface supports. + */ + + flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG); + result = TclObjUnsetVar2(interp, varNamePtr, NULL, flags); + + Tcl_DecrRefCount(varNamePtr); + return result; +} /* *---------------------------------------------------------------------- * * Tcl_UnsetVar2 -- @@ -2426,11 +2463,11 @@ int TclPtrUnsetVarIdx( Tcl_Interp *interp, /* Command interpreter in which varName is to * be looked up. */ - register Var *varPtr, /* The variable to be unset. */ + Var *varPtr, /* The variable to be unset. */ Var *arrayPtr, /* NULL for scalar variables, pointer to the * containing array otherwise. */ Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or * the name of a variable. */ Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element @@ -2463,11 +2500,11 @@ */ if (result != TCL_OK) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "unset", - ((arrayPtr == NULL) ? noSuchVar : noSuchElement), index); + ((arrayPtr == NULL) ? NOSUCHVAR : NOSUCHELEMENT), index); Tcl_SetErrorCode(interp, "TCL", "UNSET", "VARNAME", NULL); } } /* @@ -2680,12 +2717,12 @@ ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - register int i, flags = TCL_LEAVE_ERR_MSG; - register const char *name; + int i, flags = TCL_LEAVE_ERR_MSG; + const char *name; if (objc == 1) { /* * Do nothing if no arguments supplied, so as to match command * documentation. @@ -2749,11 +2786,11 @@ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Var *varPtr, *arrayPtr; - register Tcl_Obj *varValuePtr = NULL; + Tcl_Obj *varValuePtr = NULL; /* Initialized to avoid compiler warning. */ int i; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "varName ?value ...?"); @@ -2933,314 +2970,10 @@ } /* *---------------------------------------------------------------------- * - * ArrayForObjCmd, ArrayForNRCmd, ArrayForLoopCallback, ArrayObjNext -- - * - * These functions implement the "array for" Tcl command. - * array for {k v} a {} - * The array for command iterates over the array, setting the the - * specified loop variables, and executing the body each iteration. - * - * ArrayForObjCmd() is the standard wrapper around ArrayForNRCmd(). - * - * ArrayForNRCmd() sets up the ArraySearch structure, sets arrayNamePtr - * inside the structure and calls VarHashFirstEntry to start the hash - * iteration. - * - * ArrayForNRCmd() does not execute the body or set the loop variables, - * it only initializes the iterator. - * - * ArrayForLoopCallback() iterates over the entire array, executing the - * body each time. - * - *---------------------------------------------------------------------- - */ - -static int -ArrayObjNext( - Tcl_Interp *interp, - Tcl_Obj *arrayNameObj, /* array */ - Var *varPtr, /* array */ - ArraySearch *searchPtr, - Tcl_Obj **keyPtrPtr, /* Pointer to a variable to have the key - * written into, or NULL. */ - Tcl_Obj **valuePtrPtr) /* Pointer to a variable to have the - * value written into, or NULL.*/ -{ - Tcl_Obj *keyObj; - Tcl_Obj *valueObj = NULL; - int gotValue; - int donerc; - - donerc = TCL_BREAK; - - if ((varPtr->flags & VAR_SEARCH_ACTIVE) != VAR_SEARCH_ACTIVE) { - donerc = TCL_ERROR; - return donerc; - } - - gotValue = 0; - while (1) { - Tcl_HashEntry *hPtr = searchPtr->nextEntry; - - if (hPtr != NULL) { - searchPtr->nextEntry = NULL; - } else { - hPtr = Tcl_NextHashEntry(&searchPtr->search); - if (hPtr == NULL) { - gotValue = 0; - break; - } - } - varPtr = VarHashGetValue(hPtr); - if (!TclIsVarUndefined(varPtr)) { - gotValue = 1; - break; - } - } - - if (!gotValue) { - return donerc; - } - - donerc = TCL_CONTINUE; - - keyObj = VarHashGetKey(varPtr); - *keyPtrPtr = keyObj; - valueObj = Tcl_ObjGetVar2(interp, arrayNameObj, keyObj, - TCL_LEAVE_ERR_MSG); - *valuePtrPtr = valueObj; - - return donerc; -} - -static int -ArrayForObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - return Tcl_NRCallObjProc(interp, ArrayForNRCmd, dummy, objc, objv); -} - -static int -ArrayForNRCmd( - ClientData dummy, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - Tcl_Obj *varListObj, *arrayNameObj, *scriptObj; - ArraySearch *searchPtr = NULL; - Var *varPtr; - int isArray, numVars; - - /* - * array for {k v} a body - */ - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 1, objv, "{key value} arrayName script"); - return TCL_ERROR; - } - - /* - * Parse arguments. - */ - - if (Tcl_ListObjLength(interp, objv[1], &numVars) != TCL_OK) { - return TCL_ERROR; - } - - if (numVars != 2) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "must have two variable names", -1)); - Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "array", "for", NULL); - return TCL_ERROR; - } - - arrayNameObj = objv[2]; - - if (TCL_ERROR == LocateArray(interp, arrayNameObj, &varPtr, &isArray)) { - return TCL_ERROR; - } - - if (!isArray) { - return NotArrayError(interp, arrayNameObj); - } - - /* - * Make a new array search, put it on the stack. - */ - - searchPtr = Tcl_Alloc(sizeof(ArraySearch)); - ArrayPopulateSearch(interp, arrayNameObj, varPtr, searchPtr); - - /* - * Make sure that these objects (which we need throughout the body of the - * loop) don't vanish. - */ - - varListObj = TclListObjCopy(NULL, objv[1]); - scriptObj = objv[3]; - Tcl_IncrRefCount(scriptObj); - - /* - * Run the script. - */ - - TclNRAddCallback(interp, ArrayForLoopCallback, searchPtr, varListObj, - arrayNameObj, scriptObj); - return TCL_OK; -} - -static int -ArrayForLoopCallback( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - Interp *iPtr = (Interp *) interp; - ArraySearch *searchPtr = data[0]; - Tcl_Obj *varListObj = data[1]; - Tcl_Obj *arrayNameObj = data[2]; - Tcl_Obj *scriptObj = data[3]; - Tcl_Obj **varv; - Tcl_Obj *keyObj, *valueObj; - Var *varPtr; - Var *arrayPtr; - int done, varc; - - /* - * Process the result from the previous execution of the script body. - */ - - done = TCL_ERROR; - - if (result == TCL_CONTINUE) { - result = TCL_OK; - } else if (result != TCL_OK) { - if (result == TCL_BREAK) { - Tcl_ResetResult(interp); - result = TCL_OK; - } else if (result == TCL_ERROR) { - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"array for\" body line %d)", - Tcl_GetErrorLine(interp))); - } - goto arrayfordone; - } - - /* - * Get the next mapping from the array. - */ - - keyObj = NULL; - valueObj = NULL; - varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - if (varPtr == NULL) { - done = TCL_ERROR; - } else { - done = ArrayObjNext(interp, arrayNameObj, varPtr, searchPtr, &keyObj, - &valueObj); - } - - result = TCL_OK; - if (done != TCL_CONTINUE) { - Tcl_ResetResult(interp); - if (done == TCL_ERROR) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "array changed during iteration", -1)); - Tcl_SetErrorCode(interp, "TCL", "READ", "array", "for", NULL); - varPtr->flags |= TCL_LEAVE_ERR_MSG; - result = done; - } - goto arrayfordone; - } - - Tcl_ListObjGetElements(NULL, varListObj, &varc, &varv); - if (Tcl_ObjSetVar2(interp, varv[0], NULL, keyObj, - TCL_LEAVE_ERR_MSG) == NULL) { - result = TCL_ERROR; - goto arrayfordone; - } - if (valueObj != NULL) { - if (Tcl_ObjSetVar2(interp, varv[1], NULL, valueObj, - TCL_LEAVE_ERR_MSG) == NULL) { - result = TCL_ERROR; - goto arrayfordone; - } - } - - /* - * Run the script. - */ - - TclNRAddCallback(interp, ArrayForLoopCallback, searchPtr, varListObj, - arrayNameObj, scriptObj); - return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3); - - /* - * For unwinding everything once the iterating is done. - */ - - arrayfordone: - if (done != TCL_ERROR) { - /* - * If the search was terminated by an array change, the - * VAR_SEARCH_ACTIVE flag will no longer be set. - */ - - ArrayDoneSearch(iPtr, varPtr, searchPtr); - Tcl_DecrRefCount(searchPtr->name); - Tcl_Free(searchPtr); - } - - TclDecrRefCount(varListObj); - TclDecrRefCount(scriptObj); - return result; -} - -/* - * ArrayPopulateSearch - */ - -static void -ArrayPopulateSearch( - Tcl_Interp *interp, - Tcl_Obj *arrayNameObj, - Var *varPtr, - ArraySearch *searchPtr) -{ - Interp *iPtr = (Interp *) interp; - Tcl_HashEntry *hPtr; - int isNew; - - hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew); - if (isNew) { - searchPtr->id = 1; - varPtr->flags |= VAR_SEARCH_ACTIVE; - searchPtr->nextPtr = NULL; - } else { - searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1; - searchPtr->nextPtr = Tcl_GetHashValue(hPtr); - } - searchPtr->varPtr = varPtr; - searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr, - &searchPtr->search); - Tcl_SetHashValue(hPtr, searchPtr); - searchPtr->name = Tcl_ObjPrintf("s-%d-%s", searchPtr->id, - TclGetString(arrayNameObj)); - Tcl_IncrRefCount(searchPtr->name); -} -/* - *---------------------------------------------------------------------- - * * ArrayStartSearchCmd -- * * This object-based function is invoked to process the "array * startsearch" Tcl command. See the user documentation for details on * what it does. @@ -3253,21 +2986,23 @@ * *---------------------------------------------------------------------- */ /* ARGSUSED */ - static int ArrayStartSearchCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { + Interp *iPtr = (Interp *)interp; Var *varPtr; - int isArray; + Tcl_HashEntry *hPtr; + int isNew, isArray; ArraySearch *searchPtr; + const char *varName; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName"); return TCL_ERROR; } @@ -3282,58 +3017,28 @@ /* * Make a new array search with a free name. */ - searchPtr = Tcl_Alloc(sizeof(ArraySearch)); - ArrayPopulateSearch(interp, objv[1], varPtr, searchPtr); - Tcl_SetObjResult(interp, searchPtr->name); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * ArrayDoneSearch -- - * - * Removes the search from the hash of active searches. - * - *---------------------------------------------------------------------- - */ -static void -ArrayDoneSearch( - Interp *iPtr, - Var *varPtr, - ArraySearch *searchPtr) -{ - Tcl_HashEntry *hPtr; - ArraySearch *prevPtr; - - /* - * Unhook the search from the list of searches associated with the - * variable. - */ - - hPtr = Tcl_FindHashEntry(&iPtr->varSearches, varPtr); - if (hPtr == NULL) { - return; - } - if (searchPtr == Tcl_GetHashValue(hPtr)) { - if (searchPtr->nextPtr) { - Tcl_SetHashValue(hPtr, searchPtr->nextPtr); - } else { - varPtr->flags &= ~VAR_SEARCH_ACTIVE; - Tcl_DeleteHashEntry(hPtr); - } - } else { - for (prevPtr=Tcl_GetHashValue(hPtr) ;; prevPtr=prevPtr->nextPtr) { - if (prevPtr->nextPtr == searchPtr) { - prevPtr->nextPtr = searchPtr->nextPtr; - break; - } - } - } + varName = TclGetString(objv[1]); + searchPtr = ckalloc(sizeof(ArraySearch)); + hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew); + if (isNew) { + searchPtr->id = 1; + varPtr->flags |= VAR_SEARCH_ACTIVE; + searchPtr->nextPtr = NULL; + } else { + searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1; + searchPtr->nextPtr = Tcl_GetHashValue(hPtr); + } + searchPtr->varPtr = varPtr; + searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr, + &searchPtr->search); + Tcl_SetHashValue(hPtr, searchPtr); + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("s-%d-%s", searchPtr->id, varName)); + return TCL_OK; } /* *---------------------------------------------------------------------- * @@ -3357,11 +3062,11 @@ ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *)interp; Var *varPtr; Tcl_Obj *varNameObj, *searchObj; int gotValue, isArray; ArraySearch *searchPtr; @@ -3517,14 +3222,15 @@ ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *)interp; Var *varPtr; + Tcl_HashEntry *hPtr; Tcl_Obj *varNameObj, *searchObj; - ArraySearch *searchPtr; + ArraySearch *searchPtr, *prevPtr; int isArray; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId"); return TCL_ERROR; @@ -3547,13 +3253,32 @@ searchPtr = ParseSearchId(interp, varPtr, varNameObj, searchObj); if (searchPtr == NULL) { return TCL_ERROR; } - ArrayDoneSearch(iPtr, varPtr, searchPtr); - Tcl_DecrRefCount(searchPtr->name); - Tcl_Free(searchPtr); + /* + * Unhook the search from the list of searches associated with the + * variable. + */ + + hPtr = Tcl_FindHashEntry(&iPtr->varSearches, varPtr); + if (searchPtr == Tcl_GetHashValue(hPtr)) { + if (searchPtr->nextPtr) { + Tcl_SetHashValue(hPtr, searchPtr->nextPtr); + } else { + varPtr->flags &= ~VAR_SEARCH_ACTIVE; + Tcl_DeleteHashEntry(hPtr); + } + } else { + for (prevPtr=Tcl_GetHashValue(hPtr) ;; prevPtr=prevPtr->nextPtr) { + if (prevPtr->nextPtr == searchPtr) { + prevPtr->nextPtr = searchPtr->nextPtr; + break; + } + } + } + ckfree(searchPtr); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -3970,11 +3695,11 @@ if (varPtr == NULL) { return TCL_ERROR; } if (arrayPtr) { CleanupVar(varPtr, arrayPtr); - TclObjVarErrMsg(interp, arrayNameObj, NULL, "set", needArray, -1); + TclObjVarErrMsg(interp, arrayNameObj, NULL, "set", NEEDARRAY, -1); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", TclGetString(arrayNameObj), NULL); return TCL_ERROR; } @@ -3981,11 +3706,11 @@ /* * Install the contents of the dictionary or list into the array. */ arrayElemObj = objv[2]; - if (TclHasIntRep(arrayElemObj, &tclDictType) && arrayElemObj->bytes == NULL) { + if (arrayElemObj->typePtr == &tclDictType && arrayElemObj->bytes == NULL) { Tcl_Obj *keyPtr, *valuePtr; Tcl_DictSearch search; int done; if (Tcl_DictObjSize(interp, arrayElemObj, &done) != TCL_OK) { @@ -4059,12 +3784,11 @@ Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj, elemPtrs[i], TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1); if ((elemVarPtr == NULL) || (TclPtrSetVarIdx(interp, elemVarPtr, varPtr, arrayNameObj, - elemPtrs[i], elemPtrs[i+1], TCL_LEAVE_ERR_MSG, - -1) == NULL)) { + elemPtrs[i],elemPtrs[i+1],TCL_LEAVE_ERR_MSG,-1) == NULL)){ result = TCL_ERROR; break; } } Tcl_DecrRefCount(copyListObj); @@ -4089,16 +3813,18 @@ /* * Either an array element, or a scalar: lose! */ TclObjVarErrMsg(interp, arrayNameObj, NULL, "array set", - needArray, -1); + NEEDARRAY, -1); Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); return TCL_ERROR; } } - TclInitArrayVar(varPtr); + TclSetVarArray(varPtr); + varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable)); + TclInitVarHashTable(varPtr->value.tablePtr, TclGetVarNsPtr(varPtr)); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -4209,11 +3935,11 @@ Tcl_SetObjResult(interp, Tcl_NewStringObj( "error reading array statistics", -1)); return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewStringObj(stats, -1)); - Tcl_Free(stats); + ckfree(stats); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -4374,14 +4100,12 @@ TclInitArrayCmd( Tcl_Interp *interp) /* Current interpreter. */ { static const EnsembleImplMap arrayImplMap[] = { {"anymore", ArrayAnyMoreCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"default", ArrayDefaultCmd, TclCompileBasic2Or3ArgCmd, NULL, NULL, 0}, {"donesearch", ArrayDoneSearchCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"exists", ArrayExistsCmd, TclCompileArrayExistsCmd, NULL, NULL, 0}, - {"for", ArrayForObjCmd, TclCompileBasic3ArgCmd, ArrayForNRCmd, NULL, 0}, {"get", ArrayGetCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {"names", ArrayNamesCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, {"nextelement", ArrayNextElementCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"set", ArraySetCmd, TclCompileArraySetCmd, NULL, NULL, 0}, {"size", ArraySizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, @@ -4402,11 +4126,11 @@ * This function does all of the work of the "global" and "upvar" * commands. * * Results: * A standard Tcl completion code. If an error occurs then an error - * message is left in interp. + * message is left in iPtr->result. * * Side effects: * The variable given by myName is linked to the variable in framePtr * given by otherP1 and otherP2, so that references to myName are * redirected to the other variable like a symbolic link. @@ -4496,11 +4220,11 @@ * This procedure does all of the work of the "global" and "upvar" * commands. * * Results: * A standard Tcl completion code. If an error occurs then an error - * message is left in interp. + * message is left in iPtr->result. * * Side effects: * The variable given by myName is linked to the variable in framePtr * given by otherP1 and otherP2, so that references to myName are * redirected to the other variable like a symbolic link. @@ -4669,10 +4393,65 @@ } /* *---------------------------------------------------------------------- * + * Tcl_UpVar -- + * + * This function links one variable to another, just like the "upvar" + * command. + * + * Results: + * A standard Tcl completion code. If an error occurs then an error + * message is left in the interp's result. + * + * Side effects: + * The variable in frameName whose name is given by varName becomes + * accessible under the name localNameStr, so that references to + * localNameStr are redirected to the other variable like a symbolic + * link. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_UpVar +int +Tcl_UpVar( + Tcl_Interp *interp, /* Command interpreter in which varName is to + * be looked up. */ + const char *frameName, /* Name of the frame containing the source + * variable, such as "1" or "#0". */ + const char *varName, /* Name of a variable in interp to link to. + * May be either a scalar name or an element + * in an array. */ + const char *localNameStr, /* Name of link variable. */ + int flags) /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: + * indicates scope of localNameStr. */ +{ + int result; + CallFrame *framePtr; + Tcl_Obj *varNamePtr, *localNamePtr; + + if (TclGetFrame(interp, frameName, &framePtr) == -1) { + return TCL_ERROR; + } + + varNamePtr = Tcl_NewStringObj(varName, -1); + Tcl_IncrRefCount(varNamePtr); + localNamePtr = Tcl_NewStringObj(localNameStr, -1); + Tcl_IncrRefCount(localNamePtr); + + result = ObjMakeUpvar(interp, framePtr, varNamePtr, NULL, 0, + localNamePtr, flags, -1); + Tcl_DecrRefCount(varNamePtr); + Tcl_DecrRefCount(localNamePtr); + return result; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_UpVar2 -- * * This function links one variable to another, just like the "upvar" * command. * @@ -4748,11 +4527,11 @@ * previous call to Tcl_FindNamespaceVar. */ Tcl_Obj *objPtr) /* Points to the object onto which the * variable's full name is appended. */ { Interp *iPtr = (Interp *) interp; - register Var *varPtr = (Var *) variable; + Var *varPtr = (Var *) variable; Tcl_Obj *namePtr; Namespace *nsPtr; if (!varPtr || TclIsVarArrayElement(varPtr)) { return; @@ -4808,13 +4587,13 @@ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Interp *iPtr = (Interp *) interp; - register Tcl_Obj *objPtr, *tailPtr; + Tcl_Obj *objPtr, *tailPtr; const char *varName; - register const char *tail; + const char *tail; int result, i; /* * If we are not executing inside a Tcl procedure, just return. */ @@ -4937,11 +4716,11 @@ * Variable cannot be an element in an array. If arrayPtr is * non-NULL, it is, so throw up an error and return. */ TclObjVarErrMsg(interp, varNamePtr, NULL, "define", - isArrayElement, -1); + ISARRAYELEMENT, -1); Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", NULL); return TCL_ERROR; } if (varPtr == NULL) { @@ -5120,19 +4899,92 @@ } /* *---------------------------------------------------------------------- * + * SetArraySearchObj -- + * + * This function converts the given tcl object into one that has the + * "array search" internal type. + * + * Results: + * TCL_OK if the conversion succeeded, and TCL_ERROR if it failed (when + * an error message will be placed in the interpreter's result.) + * + * Side effects: + * Updates the internal type and representation of the object to make + * this an array-search object. See the tclArraySearchType declaration + * above for details of the internal representation. + * + *---------------------------------------------------------------------- + */ + +static int +SetArraySearchObj( + Tcl_Interp *interp, + Tcl_Obj *objPtr) +{ + const char *string; + char *end; /* Can't be const due to strtoul defn. */ + int id; + size_t offset; + + /* + * Get the string representation. Make it up-to-date if necessary. + */ + + string = TclGetString(objPtr); + + /* + * Parse the id into the three parts separated by dashes. + */ + + if ((string[0] != 's') || (string[1] != '-')) { + goto syntax; + } + id = strtoul(string+2, &end, 10); + if ((end == (string+2)) || (*end != '-')) { + goto syntax; + } + + /* + * Can't perform value check in this context, so place reference to place + * in string to use for the check in the object instead. + */ + + end++; + offset = end - string; + + TclFreeIntRep(objPtr); + objPtr->typePtr = &tclArraySearchType; + objPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(id); + objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(offset); + return TCL_OK; + + syntax: + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "illegal search identifier \"%s\"", string)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * * ParseSearchId -- * * This function translates from a tcl object to a pointer to an active * array search (if there is one that matches the string). * * Results: * The return value is a pointer to the array search indicated by string, * or NULL if there isn't one. If NULL is returned, the interp's result * contains an error message. + * + * Side effects: + * The tcl object might have its internal type and representation + * modified. * *---------------------------------------------------------------------- */ static ArraySearch * @@ -5145,47 +4997,69 @@ * form "search-num-var" where "num" is a * decimal number and "var" is a variable * name. */ { Interp *iPtr = (Interp *) interp; + const char *string; + size_t offset; + int id; ArraySearch *searchPtr; - const char *handle = TclGetString(handleObj); - char *end; + const char *varName = TclGetString(varNamePtr); + + /* + * Parse the id. + */ + + if ((handleObj->typePtr != &tclArraySearchType) + && (SetArraySearchObj(interp, handleObj) != TCL_OK)) { + return NULL; + } + + /* + * Extract the information out of the Tcl_Obj. + */ + + id = PTR2INT(handleObj->internalRep.twoPtrValue.ptr1); + string = TclGetString(handleObj); + offset = PTR2INT(handleObj->internalRep.twoPtrValue.ptr2); + + /* + * This test cannot be placed inside the Tcl_Obj machinery, since it is + * dependent on the variable context. + */ + + if (strcmp(string+offset, varName) != 0) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "search identifier \"%s\" isn't for variable \"%s\"", + string, varName)); + goto badLookup; + } + + /* + * Search through the list of active searches on the interpreter to see if + * the desired one exists. + * + * Note that we cannot store the searchPtr directly in the Tcl_Obj as that + * would run into trouble when DeleteSearches() was called so we must scan + * this list every time. + */ if (varPtr->flags & VAR_SEARCH_ACTIVE) { Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&iPtr->varSearches, varPtr); - /* First look for same (Tcl_Obj *) */ - for (searchPtr = Tcl_GetHashValue(hPtr); searchPtr != NULL; - searchPtr = searchPtr->nextPtr) { - if (searchPtr->name == handleObj) { - return searchPtr; - } - } - /* Fallback: do string compares. */ - for (searchPtr = Tcl_GetHashValue(hPtr); searchPtr != NULL; - searchPtr = searchPtr->nextPtr) { - if (strcmp(TclGetString(searchPtr->name), handle) == 0) { - return searchPtr; - } - } - } - if ((handle[0] != 's') || (handle[1] != '-') - || (strtoul(handle + 2, &end, 10), end == (handle + 2)) - || (*end != '-')) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "illegal search identifier \"%s\"", handle)); - } else if (strcmp(end + 1, TclGetString(varNamePtr)) != 0) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "search identifier \"%s\" isn't for variable \"%s\"", - handle, TclGetString(varNamePtr))); - } else { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't find search \"%s\"", handle)); - } - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", handle, NULL); + for (searchPtr = Tcl_GetHashValue(hPtr); searchPtr != NULL; + searchPtr = searchPtr->nextPtr) { + if (searchPtr->id == id) { + return searchPtr; + } + } + } + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't find search \"%s\"", string)); + badLookup: + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, NULL); return NULL; } /* *---------------------------------------------------------------------- @@ -5205,11 +5079,11 @@ */ static void DeleteSearches( Interp *iPtr, - register Var *arrayVarPtr) /* Variable whose searches are to be + Var *arrayVarPtr) /* Variable whose searches are to be * deleted. */ { ArraySearch *searchPtr, *nextPtr; Tcl_HashEntry *sPtr; @@ -5216,12 +5090,11 @@ if (arrayVarPtr->flags & VAR_SEARCH_ACTIVE) { sPtr = Tcl_FindHashEntry(&iPtr->varSearches, arrayVarPtr); for (searchPtr = Tcl_GetHashValue(sPtr); searchPtr != NULL; searchPtr = nextPtr) { nextPtr = searchPtr->nextPtr; - Tcl_DecrRefCount(searchPtr->name); - Tcl_Free(searchPtr); + ckfree(searchPtr); } arrayVarPtr->flags &= ~VAR_SEARCH_ACTIVE; Tcl_DeleteHashEntry(sPtr); } } @@ -5265,11 +5138,12 @@ flags = TCL_NAMESPACE_ONLY; } for (varPtr = VarHashFirstVar(tablePtr, &search); varPtr != NULL; varPtr = VarHashFirstVar(tablePtr, &search)) { - Tcl_Obj *objPtr = Tcl_NewObj(); + Tcl_Obj *objPtr; + TclNewObj(objPtr); VarHashRefCount(varPtr)++; /* Make sure we get to remove from * hash. */ Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr); UnsetVarStruct(varPtr, NULL, iPtr, /* part1 */ objPtr, NULL, flags, -1); @@ -5347,11 +5221,11 @@ TclVarHashTable *tablePtr) /* Hash table containing variables to * delete. */ { Tcl_Interp *interp = (Tcl_Interp *) iPtr; Tcl_HashSearch search; - register Var *varPtr; + Var *varPtr; int flags; Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); /* * Determine what flags to pass to the trace callback functions. @@ -5399,11 +5273,11 @@ TclDeleteCompiledLocalVars( Interp *iPtr, /* Interpreter to which variables belong. */ CallFrame *framePtr) /* Procedure call frame containing compiler- * assigned local variables to delete. */ { - register Var *varPtr; + Var *varPtr; int numLocals, i; Tcl_Obj **namePtrPtr; numLocals = framePtr->numCompiledLocals; varPtr = framePtr->compiledLocals; @@ -5448,11 +5322,11 @@ * TCL_NAMESPACE_ONLY or TCL_GLOBAL_ONLY. */ int index) { Tcl_HashSearch search; Tcl_HashEntry *tPtr; - register Var *elPtr; + Var *elPtr; ActiveVarTrace *activePtr; Tcl_Obj *objPtr; VarTrace *tracePtr; for (elPtr = VarHashFirstVar(varPtr->value.tablePtr, &search); @@ -5508,11 +5382,12 @@ * the corresponding Var struct, and is otherwise harmless. */ TclClearVarNamespaceVar(elPtr); } - DeleteArrayVar(varPtr); + VarHashDeleteTable(varPtr->value.tablePtr); + ckfree(varPtr->value.tablePtr); } /* *---------------------------------------------------------------------- * @@ -5584,10 +5459,32 @@ * * Internal functions for variable name object types -- * *---------------------------------------------------------------------- */ + +/* + * Panic functions that should never be called in normal operation. + */ + +static void +PanicOnUpdateVarName( + Tcl_Obj *objPtr) +{ + Tcl_Panic("%s of type %s should not be called", "updateStringProc", + objPtr->typePtr->name); +} + +static int +PanicOnSetVarName( + Tcl_Interp *interp, + Tcl_Obj *objPtr) +{ + Tcl_Panic("%s of type %s should not be called", "setFromAnyProc", + objPtr->typePtr->name); + return TCL_ERROR; +} /* * localVarName - * * INTERNALREP DEFINITION: @@ -5598,34 +5495,34 @@ static void FreeLocalVarName( Tcl_Obj *objPtr) { - int index; - Tcl_Obj *namePtr; + Tcl_Obj *namePtr = objPtr->internalRep.twoPtrValue.ptr1; - LocalGetIntRep(objPtr, index, namePtr); - - index++; /* Compiler warning bait. */ if (namePtr) { Tcl_DecrRefCount(namePtr); } + objPtr->typePtr = NULL; } static void DupLocalVarName( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { - int index; - Tcl_Obj *namePtr; + Tcl_Obj *namePtr = srcPtr->internalRep.twoPtrValue.ptr1; - LocalGetIntRep(srcPtr, index, namePtr); if (!namePtr) { namePtr = srcPtr; } - LocalSetIntRep(dupPtr, index, namePtr); + dupPtr->internalRep.twoPtrValue.ptr1 = namePtr; + Tcl_IncrRefCount(namePtr); + + dupPtr->internalRep.twoPtrValue.ptr2 = + srcPtr->internalRep.twoPtrValue.ptr2; + dupPtr->typePtr = &localVarNameType; } /* * parsedVarName - * @@ -5637,34 +5534,77 @@ static void FreeParsedVarName( Tcl_Obj *objPtr) { - register Tcl_Obj *arrayPtr, *elem; - int parsed; + Tcl_Obj *arrayPtr = objPtr->internalRep.twoPtrValue.ptr1; + char *elem = objPtr->internalRep.twoPtrValue.ptr2; - ParsedGetIntRep(objPtr, parsed, arrayPtr, elem); - - parsed++; /* Silence compiler. */ if (arrayPtr != NULL) { TclDecrRefCount(arrayPtr); - TclDecrRefCount(elem); + ckfree(elem); } + objPtr->typePtr = NULL; } static void DupParsedVarName( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { - register Tcl_Obj *arrayPtr, *elem; - int parsed; + Tcl_Obj *arrayPtr = srcPtr->internalRep.twoPtrValue.ptr1; + char *elem = srcPtr->internalRep.twoPtrValue.ptr2; + char *elemCopy; + unsigned elemLen; - ParsedGetIntRep(srcPtr, parsed, arrayPtr, elem); + if (arrayPtr != NULL) { + Tcl_IncrRefCount(arrayPtr); + elemLen = strlen(elem); + elemCopy = ckalloc(elemLen + 1); + memcpy(elemCopy, elem, elemLen); + *(elemCopy + elemLen) = '\0'; + elem = elemCopy; + } - parsed++; /* Silence compiler. */ - ParsedSetIntRep(dupPtr, arrayPtr, elem); + dupPtr->internalRep.twoPtrValue.ptr1 = arrayPtr; + dupPtr->internalRep.twoPtrValue.ptr2 = elem; + dupPtr->typePtr = &tclParsedVarNameType; +} + +static void +UpdateParsedVarName( + Tcl_Obj *objPtr) +{ + Tcl_Obj *arrayPtr = objPtr->internalRep.twoPtrValue.ptr1; + char *part2 = objPtr->internalRep.twoPtrValue.ptr2; + const char *part1; + char *p; + int len1, len2, totalLen; + + if (arrayPtr == NULL) { + /* + * This is a parsed scalar name: what is it doing here? + */ + + Tcl_Panic("scalar parsedVarName without a string rep"); + } + + part1 = TclGetStringFromObj(arrayPtr, &len1); + len2 = strlen(part2); + + totalLen = len1 + len2 + 2; + p = ckalloc(totalLen + 1); + objPtr->bytes = p; + objPtr->length = totalLen; + + memcpy(p, part1, len1); + p += len1; + *p++ = '('; + memcpy(p, part2, len2); + p += len2; + *p++ = ')'; + *p = '\0'; } /* *---------------------------------------------------------------------- * @@ -5743,11 +5683,11 @@ Interp *iPtr = (Interp *) interp; ResolverScheme *resPtr; Namespace *nsPtr[2], *cxtNsPtr; const char *simpleName; Var *varPtr; - register int search; + int search; int result; Tcl_Var var; Tcl_Obj *simpleNamePtr; const char *name = TclGetString(namePtr); @@ -5793,14 +5733,10 @@ /* * Find the namespace(s) that contain the variable. */ - if (!(flags & TCL_GLOBAL_ONLY)) { - flags |= TCL_NAMESPACE_ONLY; - } - TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); /* * Look for the variable in the variable table of its namespace. Be sure @@ -5938,11 +5874,11 @@ varPtr = VarHashFindVar(&nsPtr->varTable, simplePatternPtr); if (varPtr) { if (!TclIsVarUndefined(varPtr) || TclIsVarNamespaceVar(varPtr)) { if (specificNsInPattern) { - elemObjPtr = Tcl_NewObj(); + TclNewObj(elemObjPtr); Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, elemObjPtr); } else { elemObjPtr = VarHashGetKey(varPtr); } @@ -5971,11 +5907,11 @@ varNamePtr = VarHashGetKey(varPtr); varName = TclGetString(varNamePtr); if ((simplePattern == NULL) || Tcl_StringMatch(varName, simplePattern)) { if (specificNsInPattern) { - elemObjPtr = Tcl_NewObj(); + TclNewObj(elemObjPtr); Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, elemObjPtr); } else { elemObjPtr = varNamePtr; } @@ -5993,11 +5929,11 @@ * only those variables that aren't hidden by a variable in the * effective namespace. */ if ((nsPtr != globalNsPtr) && !specificNsInPattern) { - varPtr = VarHashFirstVar(&globalNsPtr->varTable, &search); + varPtr = VarHashFirstVar(&globalNsPtr->varTable,&search); while (varPtr) { if (!TclIsVarUndefined(varPtr) || TclIsVarNamespaceVar(varPtr)) { varNamePtr = VarHashGetKey(varPtr); varName = TclGetString(varNamePtr); @@ -6289,53 +6225,28 @@ if (!includeLinks) { return; } if (iPtr->varFramePtr->isProcCallFrame & FRAME_IS_METHOD) { - Method *mPtr = (Method *) - Tcl_ObjectContextMethod(iPtr->varFramePtr->clientData); - PrivateVariableMapping *privatePtr; + CallContext *contextPtr = iPtr->varFramePtr->clientData; + Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; if (mPtr->declaringObjectPtr) { - Object *oPtr = mPtr->declaringObjectPtr; - - FOREACH(objNamePtr, oPtr->variables) { + FOREACH(objNamePtr, mPtr->declaringObjectPtr->variables) { Tcl_CreateHashEntry(&addedTable, objNamePtr, &added); if (added && (!pattern || Tcl_StringMatch(TclGetString(objNamePtr), pattern))) { Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); } - } - FOREACH_STRUCT(privatePtr, oPtr->privateVariables) { - Tcl_CreateHashEntry(&addedTable, privatePtr->variableObj, - &added); - if (added && (!pattern || - Tcl_StringMatch(TclGetString(privatePtr->variableObj), - pattern))) { - Tcl_ListObjAppendElement(interp, listPtr, - privatePtr->variableObj); - } } } else { - Class *clsPtr = mPtr->declaringClassPtr; - - FOREACH(objNamePtr, clsPtr->variables) { + FOREACH(objNamePtr, mPtr->declaringClassPtr->variables) { Tcl_CreateHashEntry(&addedTable, objNamePtr, &added); if (added && (!pattern || Tcl_StringMatch(TclGetString(objNamePtr), pattern))) { Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); } - } - FOREACH_STRUCT(privatePtr, clsPtr->privateVariables) { - Tcl_CreateHashEntry(&addedTable, privatePtr->variableObj, - &added); - if (added && (!pattern || - Tcl_StringMatch(TclGetString(privatePtr->variableObj), - pattern))) { - Tcl_ListObjAppendElement(interp, listPtr, - privatePtr->variableObj); - } } } } Tcl_DeleteHashTable(&addedTable); } @@ -6357,15 +6268,15 @@ static Tcl_HashEntry * AllocVarEntry( Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key to store in the hash table entry. */ { - Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr; + Tcl_Obj *objPtr = keyPtr; Tcl_HashEntry *hPtr; Var *varPtr; - varPtr = Tcl_Alloc(sizeof(VarInHash)); + varPtr = ckalloc(sizeof(VarInHash)); varPtr->flags = VAR_IN_HASHTABLE; varPtr->value.objPtr = NULL; VarHashRefCount(varPtr) = 1; hPtr = &(((VarInHash *) varPtr)->entry); @@ -6383,11 +6294,11 @@ Var *varPtr = VarHashGetValue(hPtr); Tcl_Obj *objPtr = hPtr->key.objPtr; if (TclIsVarUndefined(varPtr) && !TclIsVarTraced(varPtr) && (VarHashRefCount(varPtr) == 1)) { - Tcl_Free(varPtr); + ckfree(varPtr); } else { VarHashInvalidateEntry(varPtr); TclSetVarUndefined(varPtr); VarHashRefCount(varPtr)--; } @@ -6394,24 +6305,24 @@ Tcl_DecrRefCount(objPtr); } static int CompareVarKeys( - void *keyPtr, /* New key to compare. */ + void *keyPtr, /* New key to compare. */ Tcl_HashEntry *hPtr) /* Existing key to compare. */ { - Tcl_Obj *objPtr1 = (Tcl_Obj *)keyPtr; + Tcl_Obj *objPtr1 = keyPtr; Tcl_Obj *objPtr2 = hPtr->key.objPtr; - register const char *p1, *p2; - register size_t l1, l2; + const char *p1, *p2; + int l1, l2; /* * If the object pointers are the same then they match. * OPT: this comparison was moved to the caller - * - * if (objPtr1 == objPtr2) return 1; - */ + + if (objPtr1 == objPtr2) return 1; + */ /* * Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being in a * register. */ @@ -6425,271 +6336,13 @@ * Only compare string representations of the same length. */ return ((l1 == l2) && !memcmp(p1, p2, l1)); } - -/*---------------------------------------------------------------------- - * - * ArrayDefaultCmd -- - * - * This function implements the 'array default' Tcl command. - * Refer to the user documentation for details on what it does. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -ArrayDefaultCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - static const char *const options[] = { - "get", "set", "exists", "unset", NULL - }; - enum options { OPT_GET, OPT_SET, OPT_EXISTS, OPT_UNSET }; - Tcl_Obj *arrayNameObj, *defaultValueObj; - Var *varPtr, *arrayPtr; - int isArray, option; - - /* - * Parse arguments. - */ - - if (objc != 3 && objc != 4) { - Tcl_WrongNumArgs(interp, 1, objv, "option arrayName ?value?"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", - 0, &option) != TCL_OK) { - return TCL_ERROR; - } - - arrayNameObj = objv[2]; - - if (TCL_ERROR == LocateArray(interp, arrayNameObj, &varPtr, &isArray)) { - return TCL_ERROR; - } - - switch (option) { - case OPT_GET: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); - return TCL_ERROR; - } - if (!varPtr || TclIsVarUndefined(varPtr) || !isArray) { - return NotArrayError(interp, arrayNameObj); - } - - defaultValueObj = TclGetArrayDefault(varPtr); - if (!defaultValueObj) { - /* Array default must exist. */ - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "array has no default value", -1)); - Tcl_SetErrorCode(interp, "TCL", "READ", "ARRAY", "DEFAULT", NULL); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, defaultValueObj); - return TCL_OK; - - case OPT_SET: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "arrayName value"); - return TCL_ERROR; - } - - /* - * Attempt to create array if needed. - */ - varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, - /*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "array default set", - /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); - if (varPtr == NULL) { - return TCL_ERROR; - } - if (arrayPtr) { - /* - * Not a valid array name. - */ - - CleanupVar(varPtr, arrayPtr); - TclObjVarErrMsg(interp, arrayNameObj, NULL, "array default set", - needArray, -1); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", - TclGetString(arrayNameObj), NULL); - return TCL_ERROR; - } - if (!TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { - /* - * Not an array. - */ - - TclObjVarErrMsg(interp, arrayNameObj, NULL, "array default set", - needArray, -1); - Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); - return TCL_ERROR; - } - - if (!TclIsVarArray(varPtr)) { - TclInitArrayVar(varPtr); - } - defaultValueObj = objv[3]; - SetArrayDefault(varPtr, defaultValueObj); - return TCL_OK; - - case OPT_EXISTS: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); - return TCL_ERROR; - } - - /* - * Undefined variables (whether or not they have storage allocated) do - * not have defaults, and this is not an error case. - */ - - if (!varPtr || TclIsVarUndefined(varPtr)) { - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); - } else if (!isArray) { - return NotArrayError(interp, arrayNameObj); - } else { - defaultValueObj = TclGetArrayDefault(varPtr); - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(!!defaultValueObj)); - } - return TCL_OK; - - case OPT_UNSET: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); - return TCL_ERROR; - } - - if (varPtr && !TclIsVarUndefined(varPtr)) { - if (!isArray) { - return NotArrayError(interp, arrayNameObj); - } - SetArrayDefault(varPtr, NULL); - } - return TCL_OK; - } - - /* Unreached */ - return TCL_ERROR; -} - -/* - * Initialize array variable. - */ - -void -TclInitArrayVar( - Var *arrayPtr) -{ - ArrayVarHashTable *tablePtr = Tcl_Alloc(sizeof(ArrayVarHashTable)); - - /* - * Mark the variable as an array. - */ - - TclSetVarArray(arrayPtr); - - /* - * Regular TclVarHashTable initialization. - */ - - arrayPtr->value.tablePtr = (TclVarHashTable *) tablePtr; - TclInitVarHashTable(arrayPtr->value.tablePtr, TclGetVarNsPtr(arrayPtr)); - - /* - * Default value initialization. - */ - - tablePtr->defaultObj = NULL; -} - -/* - * Cleanup array variable. - */ - -static void -DeleteArrayVar( - Var *arrayPtr) -{ - ArrayVarHashTable *tablePtr = (ArrayVarHashTable *) - arrayPtr->value.tablePtr; - - /* - * Default value cleanup. - */ - - SetArrayDefault(arrayPtr, NULL); - - /* - * Regular TclVarHashTable cleanup. - */ - - VarHashDeleteTable(arrayPtr->value.tablePtr); - Tcl_Free(tablePtr); -} - -/* - * Get array default value if any. - */ - -Tcl_Obj * -TclGetArrayDefault( - Var *arrayPtr) -{ - ArrayVarHashTable *tablePtr = (ArrayVarHashTable *) - arrayPtr->value.tablePtr; - - return tablePtr->defaultObj; -} - -/* - * Set/replace/unset array default value. - */ - -static void -SetArrayDefault( - Var *arrayPtr, - Tcl_Obj *defaultObj) -{ - ArrayVarHashTable *tablePtr = (ArrayVarHashTable *) - arrayPtr->value.tablePtr; - - /* - * Increment/decrement refcount twice to ensure that the object is shared, - * so that it doesn't get modified accidentally by the folling code: - * - * array default set v 1 - * lappend v(a) 2; # returns a new object {1 2} - * set v(b); # returns the original default object "1" - */ - - if (tablePtr->defaultObj) { - Tcl_DecrRefCount(tablePtr->defaultObj); - Tcl_DecrRefCount(tablePtr->defaultObj); - } - tablePtr->defaultObj = defaultObj; - if (tablePtr->defaultObj) { - Tcl_IncrRefCount(tablePtr->defaultObj); - Tcl_IncrRefCount(tablePtr->defaultObj); - } -} /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ DELETED generic/tclZipfs.c Index: generic/tclZipfs.c ================================================================== --- generic/tclZipfs.c +++ /dev/null @@ -1,5033 +0,0 @@ -/* - * tclZipfs.c -- - * - * Implementation of the ZIP filesystem used in TIP 430 - * Adapted from the implentation for AndroWish. - * - * Copyright (c) 2016-2017 Sean Woods - * Copyright (c) 2013-2015 Christian Werner - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * This file is distributed in two ways: - * generic/tclZipfs.c file in the TIP430-enabled Tcl cores. - * compat/tclZipfs.c file in the tclconfig (TEA) file system, for pre-tip430 - * projects. - */ - -#include "tclInt.h" -#include "tclFileSystem.h" - -#ifndef _WIN32 -#include -#endif /* _WIN32*/ - -#ifndef MAP_FILE -#define MAP_FILE 0 -#endif /* !MAP_FILE */ - -#ifdef HAVE_ZLIB -#include "zlib.h" -#include "crypt.h" - -#ifdef CFG_RUNTIME_DLLFILE - -/* -** We are compiling as part of the core. -** TIP430 style zipfs prefix -*/ - -#define ZIPFS_VOLUME "//zipfs:/" -#define ZIPFS_VOLUME_LEN 9 -#define ZIPFS_APP_MOUNT "//zipfs:/app" -#define ZIPFS_ZIP_MOUNT "//zipfs:/lib/tcl" - -#else /* !CFG_RUNTIME_DLLFILE */ - -/* -** We are compiling from the /compat folder of tclconfig -** Pre TIP430 style zipfs prefix -** //zipfs:/ doesn't work straight out of the box on either windows or Unix -** without other changes made to tip 430 -*/ - -#define ZIPFS_VOLUME "zipfs:/" -#define ZIPFS_VOLUME_LEN 7 -#define ZIPFS_APP_MOUNT "zipfs:/app" -#define ZIPFS_ZIP_MOUNT "zipfs:/lib/tcl" - -#endif /* CFG_RUNTIME_DLLFILE */ - -/* - * Various constants and offsets found in ZIP archive files - */ - -#define ZIP_SIG_LEN 4 - -/* - * Local header of ZIP archive member (at very beginning of each member). - */ - -#define ZIP_LOCAL_HEADER_SIG 0x04034b50 -#define ZIP_LOCAL_HEADER_LEN 30 -#define ZIP_LOCAL_SIG_OFFS 0 -#define ZIP_LOCAL_VERSION_OFFS 4 -#define ZIP_LOCAL_FLAGS_OFFS 6 -#define ZIP_LOCAL_COMPMETH_OFFS 8 -#define ZIP_LOCAL_MTIME_OFFS 10 -#define ZIP_LOCAL_MDATE_OFFS 12 -#define ZIP_LOCAL_CRC32_OFFS 14 -#define ZIP_LOCAL_COMPLEN_OFFS 18 -#define ZIP_LOCAL_UNCOMPLEN_OFFS 22 -#define ZIP_LOCAL_PATHLEN_OFFS 26 -#define ZIP_LOCAL_EXTRALEN_OFFS 28 - -/* - * Central header of ZIP archive member at end of ZIP file. - */ - -#define ZIP_CENTRAL_HEADER_SIG 0x02014b50 -#define ZIP_CENTRAL_HEADER_LEN 46 -#define ZIP_CENTRAL_SIG_OFFS 0 -#define ZIP_CENTRAL_VERSIONMADE_OFFS 4 -#define ZIP_CENTRAL_VERSION_OFFS 6 -#define ZIP_CENTRAL_FLAGS_OFFS 8 -#define ZIP_CENTRAL_COMPMETH_OFFS 10 -#define ZIP_CENTRAL_MTIME_OFFS 12 -#define ZIP_CENTRAL_MDATE_OFFS 14 -#define ZIP_CENTRAL_CRC32_OFFS 16 -#define ZIP_CENTRAL_COMPLEN_OFFS 20 -#define ZIP_CENTRAL_UNCOMPLEN_OFFS 24 -#define ZIP_CENTRAL_PATHLEN_OFFS 28 -#define ZIP_CENTRAL_EXTRALEN_OFFS 30 -#define ZIP_CENTRAL_FCOMMENTLEN_OFFS 32 -#define ZIP_CENTRAL_DISKFILE_OFFS 34 -#define ZIP_CENTRAL_IATTR_OFFS 36 -#define ZIP_CENTRAL_EATTR_OFFS 38 -#define ZIP_CENTRAL_LOCALHDR_OFFS 42 - -/* - * Central end signature at very end of ZIP file. - */ - -#define ZIP_CENTRAL_END_SIG 0x06054b50 -#define ZIP_CENTRAL_END_LEN 22 -#define ZIP_CENTRAL_END_SIG_OFFS 0 -#define ZIP_CENTRAL_DISKNO_OFFS 4 -#define ZIP_CENTRAL_DISKDIR_OFFS 6 -#define ZIP_CENTRAL_ENTS_OFFS 8 -#define ZIP_CENTRAL_TOTALENTS_OFFS 10 -#define ZIP_CENTRAL_DIRSIZE_OFFS 12 -#define ZIP_CENTRAL_DIRSTART_OFFS 16 -#define ZIP_CENTRAL_COMMENTLEN_OFFS 20 - -#define ZIP_MIN_VERSION 20 -#define ZIP_COMPMETH_STORED 0 -#define ZIP_COMPMETH_DEFLATED 8 - -#define ZIP_PASSWORD_END_SIG 0x5a5a4b50 - -#define DEFAULT_WRITE_MAX_SIZE (2 * 1024 * 1024) - -/* - * Macros to report errors only if an interp is present. - */ - -#define ZIPFS_ERROR(interp,errstr) \ - do { \ - if (interp) { \ - Tcl_SetObjResult(interp, Tcl_NewStringObj(errstr, -1)); \ - } \ - } while (0) -#define ZIPFS_POSIX_ERROR(interp,errstr) \ - do { \ - if (interp) { \ - Tcl_SetObjResult(interp, Tcl_ObjPrintf( \ - "%s: %s", errstr, Tcl_PosixError(interp))); \ - } \ - } while (0) - -/* - * Macros to read and write 16 and 32 bit integers from/to ZIP archives. - */ - -#define ZipReadInt(p) \ - ((p)[0] | ((p)[1] << 8) | ((p)[2] << 16) | ((p)[3] << 24)) -#define ZipReadShort(p) \ - ((p)[0] | ((p)[1] << 8)) - -#define ZipWriteInt(p, v) \ - do { \ - (p)[0] = (v) & 0xff; \ - (p)[1] = ((v) >> 8) & 0xff; \ - (p)[2] = ((v) >> 16) & 0xff; \ - (p)[3] = ((v) >> 24) & 0xff; \ - } while (0) -#define ZipWriteShort(p, v) \ - do { \ - (p)[0] = (v) & 0xff; \ - (p)[1] = ((v) >> 8) & 0xff; \ - } while (0) - -/* - * Windows drive letters. - */ - -#ifdef _WIN32 -static const char drvletters[] = - "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"; -#endif /* _WIN32 */ - -/* - * Mutex to protect localtime(3) when no reentrant version available. - */ - -#if !defined(_WIN32) && !defined(HAVE_LOCALTIME_R) && TCL_THREADS -TCL_DECLARE_MUTEX(localtimeMutex) -#endif /* !_WIN32 && !HAVE_LOCALTIME_R && TCL_THREADS */ - -/* - * In-core description of mounted ZIP archive file. - */ - -typedef struct ZipFile { - char *name; /* Archive name */ - size_t nameLength; /* Length of archive name */ - char isMemBuffer; /* When true, not a file but a memory buffer */ - Tcl_Channel chan; /* Channel handle or NULL */ - unsigned char *data; /* Memory mapped or malloc'ed file */ - size_t length; /* Length of memory mapped file */ - void *ptrToFree; /* Non-NULL if malloc'ed file */ - size_t numFiles; /* Number of files in archive */ - size_t baseOffset; /* Archive start */ - size_t passOffset; /* Password start */ - size_t directoryOffset; /* Archive directory start */ - unsigned char passBuf[264]; /* Password buffer */ - size_t numOpen; /* Number of open files on archive */ - struct ZipEntry *entries; /* List of files in archive */ - struct ZipEntry *topEnts; /* List of top-level dirs in archive */ - char *mountPoint; /* Mount point name */ - size_t mountPointLen; /* Length of mount point name */ -#ifdef _WIN32 - HANDLE mountHandle; /* Handle used for direct file access. */ -#endif /* _WIN32 */ -} ZipFile; - -/* - * In-core description of file contained in mounted ZIP archive. - */ - -typedef struct ZipEntry { - char *name; /* The full pathname of the virtual file */ - ZipFile *zipFilePtr; /* The ZIP file holding this virtual file */ - Tcl_WideInt offset; /* Data offset into memory mapped ZIP file */ - int numBytes; /* Uncompressed size of the virtual file */ - int numCompressedBytes; /* Compressed size of the virtual file */ - int compressMethod; /* Compress method */ - int isDirectory; /* Set to 1 if directory, or -1 if root */ - int depth; /* Number of slashes in path. */ - int crc32; /* CRC-32 */ - int timestamp; /* Modification time */ - int isEncrypted; /* True if data is encrypted */ - unsigned char *data; /* File data if written */ - struct ZipEntry *next; /* Next file in the same archive */ - struct ZipEntry *tnext; /* Next top-level dir in archive */ -} ZipEntry; - -/* - * File channel for file contained in mounted ZIP archive. - */ - -typedef struct ZipChannel { - ZipFile *zipFilePtr; /* The ZIP file holding this channel */ - ZipEntry *zipEntryPtr; /* Pointer back to virtual file */ - size_t maxWrite; /* Maximum size for write */ - size_t numBytes; /* Number of bytes of uncompressed data */ - size_t numRead; /* Position of next byte to be read from the - * channel */ - unsigned char *ubuf; /* Pointer to the uncompressed data */ - int iscompr; /* True if data is compressed */ - int isDirectory; /* Set to 1 if directory, or -1 if root */ - int isEncrypted; /* True if data is encrypted */ - int isWriting; /* True if open for writing */ - unsigned long keys[3]; /* Key for decryption */ -} ZipChannel; - -/* - * Global variables. - * - * Most are kept in single ZipFS struct. When build with threading support - * this struct is protected by the ZipFSMutex (see below). - * - * The "fileHash" component is the process wide global table of all known ZIP - * archive members in all mounted ZIP archives. - * - * The "zipHash" components is the process wide global table of all mounted - * ZIP archive files. - */ - -static struct { - int initialized; /* True when initialized */ - int lock; /* RW lock, see below */ - int waiters; /* RW lock, see below */ - int wrmax; /* Maximum write size of a file */ - int idCount; /* Counter for channel names */ - Tcl_HashTable fileHash; /* File name to ZipEntry mapping */ - Tcl_HashTable zipHash; /* Mount to ZipFile mapping */ -} ZipFS = { - 0, 0, 0, DEFAULT_WRITE_MAX_SIZE, 0, -}; - -/* - * For password rotation. - */ - -static const char pwrot[16] = - "\x00\x80\x40\xC0\x20\xA0\x60\xE0" - "\x10\x90\x50\xD0\x30\xB0\x70\xF0"; - -/* - * Table to compute CRC32. - */ -#ifdef Z_U4 - typedef Z_U4 z_crc_t; -#else - typedef unsigned long z_crc_t; -#endif - -static const z_crc_t crc32tab[256] = { - 0x00000000, 0x77073096, 0xee0e612c, 0x990951ba, 0x076dc419, - 0x706af48f, 0xe963a535, 0x9e6495a3, 0x0edb8832, 0x79dcb8a4, - 0xe0d5e91e, 0x97d2d988, 0x09b64c2b, 0x7eb17cbd, 0xe7b82d07, - 0x90bf1d91, 0x1db71064, 0x6ab020f2, 0xf3b97148, 0x84be41de, - 0x1adad47d, 0x6ddde4eb, 0xf4d4b551, 0x83d385c7, 0x136c9856, - 0x646ba8c0, 0xfd62f97a, 0x8a65c9ec, 0x14015c4f, 0x63066cd9, - 0xfa0f3d63, 0x8d080df5, 0x3b6e20c8, 0x4c69105e, 0xd56041e4, - 0xa2677172, 0x3c03e4d1, 0x4b04d447, 0xd20d85fd, 0xa50ab56b, - 0x35b5a8fa, 0x42b2986c, 0xdbbbc9d6, 0xacbcf940, 0x32d86ce3, - 0x45df5c75, 0xdcd60dcf, 0xabd13d59, 0x26d930ac, 0x51de003a, - 0xc8d75180, 0xbfd06116, 0x21b4f4b5, 0x56b3c423, 0xcfba9599, - 0xb8bda50f, 0x2802b89e, 0x5f058808, 0xc60cd9b2, 0xb10be924, - 0x2f6f7c87, 0x58684c11, 0xc1611dab, 0xb6662d3d, 0x76dc4190, - 0x01db7106, 0x98d220bc, 0xefd5102a, 0x71b18589, 0x06b6b51f, - 0x9fbfe4a5, 0xe8b8d433, 0x7807c9a2, 0x0f00f934, 0x9609a88e, - 0xe10e9818, 0x7f6a0dbb, 0x086d3d2d, 0x91646c97, 0xe6635c01, - 0x6b6b51f4, 0x1c6c6162, 0x856530d8, 0xf262004e, 0x6c0695ed, - 0x1b01a57b, 0x8208f4c1, 0xf50fc457, 0x65b0d9c6, 0x12b7e950, - 0x8bbeb8ea, 0xfcb9887c, 0x62dd1ddf, 0x15da2d49, 0x8cd37cf3, - 0xfbd44c65, 0x4db26158, 0x3ab551ce, 0xa3bc0074, 0xd4bb30e2, - 0x4adfa541, 0x3dd895d7, 0xa4d1c46d, 0xd3d6f4fb, 0x4369e96a, - 0x346ed9fc, 0xad678846, 0xda60b8d0, 0x44042d73, 0x33031de5, - 0xaa0a4c5f, 0xdd0d7cc9, 0x5005713c, 0x270241aa, 0xbe0b1010, - 0xc90c2086, 0x5768b525, 0x206f85b3, 0xb966d409, 0xce61e49f, - 0x5edef90e, 0x29d9c998, 0xb0d09822, 0xc7d7a8b4, 0x59b33d17, - 0x2eb40d81, 0xb7bd5c3b, 0xc0ba6cad, 0xedb88320, 0x9abfb3b6, - 0x03b6e20c, 0x74b1d29a, 0xead54739, 0x9dd277af, 0x04db2615, - 0x73dc1683, 0xe3630b12, 0x94643b84, 0x0d6d6a3e, 0x7a6a5aa8, - 0xe40ecf0b, 0x9309ff9d, 0x0a00ae27, 0x7d079eb1, 0xf00f9344, - 0x8708a3d2, 0x1e01f268, 0x6906c2fe, 0xf762575d, 0x806567cb, - 0x196c3671, 0x6e6b06e7, 0xfed41b76, 0x89d32be0, 0x10da7a5a, - 0x67dd4acc, 0xf9b9df6f, 0x8ebeeff9, 0x17b7be43, 0x60b08ed5, - 0xd6d6a3e8, 0xa1d1937e, 0x38d8c2c4, 0x4fdff252, 0xd1bb67f1, - 0xa6bc5767, 0x3fb506dd, 0x48b2364b, 0xd80d2bda, 0xaf0a1b4c, - 0x36034af6, 0x41047a60, 0xdf60efc3, 0xa867df55, 0x316e8eef, - 0x4669be79, 0xcb61b38c, 0xbc66831a, 0x256fd2a0, 0x5268e236, - 0xcc0c7795, 0xbb0b4703, 0x220216b9, 0x5505262f, 0xc5ba3bbe, - 0xb2bd0b28, 0x2bb45a92, 0x5cb36a04, 0xc2d7ffa7, 0xb5d0cf31, - 0x2cd99e8b, 0x5bdeae1d, 0x9b64c2b0, 0xec63f226, 0x756aa39c, - 0x026d930a, 0x9c0906a9, 0xeb0e363f, 0x72076785, 0x05005713, - 0x95bf4a82, 0xe2b87a14, 0x7bb12bae, 0x0cb61b38, 0x92d28e9b, - 0xe5d5be0d, 0x7cdcefb7, 0x0bdbdf21, 0x86d3d2d4, 0xf1d4e242, - 0x68ddb3f8, 0x1fda836e, 0x81be16cd, 0xf6b9265b, 0x6fb077e1, - 0x18b74777, 0x88085ae6, 0xff0f6a70, 0x66063bca, 0x11010b5c, - 0x8f659eff, 0xf862ae69, 0x616bffd3, 0x166ccf45, 0xa00ae278, - 0xd70dd2ee, 0x4e048354, 0x3903b3c2, 0xa7672661, 0xd06016f7, - 0x4969474d, 0x3e6e77db, 0xaed16a4a, 0xd9d65adc, 0x40df0b66, - 0x37d83bf0, 0xa9bcae53, 0xdebb9ec5, 0x47b2cf7f, 0x30b5ffe9, - 0xbdbdf21c, 0xcabac28a, 0x53b39330, 0x24b4a3a6, 0xbad03605, - 0xcdd70693, 0x54de5729, 0x23d967bf, 0xb3667a2e, 0xc4614ab8, - 0x5d681b02, 0x2a6f2b94, 0xb40bbe37, 0xc30c8ea1, 0x5a05df1b, - 0x2d02ef8d, -}; - -static const char *zipfs_literal_tcl_library = NULL; - -/* Function prototypes */ - -static inline int DescribeMounted(Tcl_Interp *interp, - const char *mountPoint); -static inline int ListMountPoints(Tcl_Interp *interp); -static int ZipfsAppHookFindTclInit(const char *archive); -static int ZipFSPathInFilesystemProc(Tcl_Obj *pathPtr, - void **clientDataPtr); -static Tcl_Obj * ZipFSFilesystemPathTypeProc(Tcl_Obj *pathPtr); -static Tcl_Obj * ZipFSFilesystemSeparatorProc(Tcl_Obj *pathPtr); -static int ZipFSStatProc(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); -static int ZipFSAccessProc(Tcl_Obj *pathPtr, int mode); -static Tcl_Channel ZipFSOpenFileChannelProc(Tcl_Interp *interp, - Tcl_Obj *pathPtr, int mode, int permissions); -static int ZipFSMatchInDirectoryProc(Tcl_Interp *interp, - Tcl_Obj *result, Tcl_Obj *pathPtr, - const char *pattern, Tcl_GlobTypeData *types); -static Tcl_Obj * ZipFSListVolumesProc(void); -static const char *const *ZipFSFileAttrStringsProc(Tcl_Obj *pathPtr, - Tcl_Obj **objPtrRef); -static int ZipFSFileAttrsGetProc(Tcl_Interp *interp, int index, - Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); -static int ZipFSFileAttrsSetProc(Tcl_Interp *interp, int index, - Tcl_Obj *pathPtr, Tcl_Obj *objPtr); -static int ZipFSLoadFile(Tcl_Interp *interp, Tcl_Obj *path, - Tcl_LoadHandle *loadHandle, - Tcl_FSUnloadFileProc **unloadProcPtr, int flags); -static void ZipfsExitHandler(ClientData clientData); -static void ZipfsSetup(void); -static int ZipChannelClose(void *instanceData, - Tcl_Interp *interp); -static int ZipChannelGetFile(void *instanceData, - int direction, void **handlePtr); -static int ZipChannelRead(void *instanceData, char *buf, - int toRead, int *errloc); -static int ZipChannelSeek(void *instanceData, long offset, - int mode, int *errloc); -static void ZipChannelWatchChannel(void *instanceData, - int mask); -static int ZipChannelWrite(void *instanceData, - const char *buf, int toWrite, int *errloc); - -/* - * Define the ZIP filesystem dispatch table. - */ - -MODULE_SCOPE const Tcl_Filesystem zipfsFilesystem; - -const Tcl_Filesystem zipfsFilesystem = { - "zipfs", - sizeof(Tcl_Filesystem), - TCL_FILESYSTEM_VERSION_2, - ZipFSPathInFilesystemProc, - NULL, /* dupInternalRepProc */ - NULL, /* freeInternalRepProc */ - NULL, /* internalToNormalizedProc */ - NULL, /* createInternalRepProc */ - NULL, /* normalizePathProc */ - ZipFSFilesystemPathTypeProc, - ZipFSFilesystemSeparatorProc, - ZipFSStatProc, - ZipFSAccessProc, - ZipFSOpenFileChannelProc, - ZipFSMatchInDirectoryProc, - NULL, /* utimeProc */ - NULL, /* linkProc */ - ZipFSListVolumesProc, - ZipFSFileAttrStringsProc, - ZipFSFileAttrsGetProc, - ZipFSFileAttrsSetProc, - NULL, /* createDirectoryProc */ - NULL, /* removeDirectoryProc */ - NULL, /* deleteFileProc */ - NULL, /* copyFileProc */ - NULL, /* renameFileProc */ - NULL, /* copyDirectoryProc */ - NULL, /* lstatProc */ - (Tcl_FSLoadFileProc *) ZipFSLoadFile, - NULL, /* getCwdProc */ - NULL, /* chdirProc */ -}; - -/* - * The channel type/driver definition used for ZIP archive members. - */ - -static Tcl_ChannelType ZipChannelType = { - "zip", /* Type name. */ - TCL_CHANNEL_VERSION_5, - ZipChannelClose, /* Close channel, clean instance data */ - ZipChannelRead, /* Handle read request */ - ZipChannelWrite, /* Handle write request */ - ZipChannelSeek, /* Move location of access point, NULL'able */ - NULL, /* Set options, NULL'able */ - NULL, /* Get options, NULL'able */ - ZipChannelWatchChannel, /* Initialize notifier */ - ZipChannelGetFile, /* Get OS handle from the channel */ - NULL, /* 2nd version of close channel, NULL'able */ - NULL, /* Set blocking mode for raw channel, NULL'able */ - NULL, /* Function to flush channel, NULL'able */ - NULL, /* Function to handle event, NULL'able */ - NULL, /* Wide seek function, NULL'able */ - NULL, /* Thread action function, NULL'able */ - NULL, /* Truncate function, NULL'able */ -}; - -/* - *------------------------------------------------------------------------- - * - * ReadLock, WriteLock, Unlock -- - * - * POSIX like rwlock functions to support multiple readers and single - * writer on internal structs. - * - * Limitations: - * - a read lock cannot be promoted to a write lock - * - a write lock may not be nested - * - *------------------------------------------------------------------------- - */ - -TCL_DECLARE_MUTEX(ZipFSMutex) - -#if TCL_THREADS - -static Tcl_Condition ZipFSCond; - -static void -ReadLock(void) -{ - Tcl_MutexLock(&ZipFSMutex); - while (ZipFS.lock < 0) { - ZipFS.waiters++; - Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, NULL); - ZipFS.waiters--; - } - ZipFS.lock++; - Tcl_MutexUnlock(&ZipFSMutex); -} - -static void -WriteLock(void) -{ - Tcl_MutexLock(&ZipFSMutex); - while (ZipFS.lock != 0) { - ZipFS.waiters++; - Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, NULL); - ZipFS.waiters--; - } - ZipFS.lock = -1; - Tcl_MutexUnlock(&ZipFSMutex); -} - -static void -Unlock(void) -{ - Tcl_MutexLock(&ZipFSMutex); - if (ZipFS.lock > 0) { - --ZipFS.lock; - } else if (ZipFS.lock < 0) { - ZipFS.lock = 0; - } - if ((ZipFS.lock == 0) && (ZipFS.waiters > 0)) { - Tcl_ConditionNotify(&ZipFSCond); - } - Tcl_MutexUnlock(&ZipFSMutex); -} - -#else /* !TCL_THREADS */ -#define ReadLock() do {} while (0) -#define WriteLock() do {} while (0) -#define Unlock() do {} while (0) -#endif /* TCL_THREADS */ - -/* - *------------------------------------------------------------------------- - * - * DosTimeDate, ToDosTime, ToDosDate -- - * - * Functions to perform conversions between DOS time stamps and POSIX - * time_t. - * - *------------------------------------------------------------------------- - */ - -static time_t -DosTimeDate( - int dosDate, - int dosTime) -{ - struct tm tm; - time_t ret; - - memset(&tm, 0, sizeof(tm)); - tm.tm_isdst = -1; /* let mktime() deal with DST */ - tm.tm_year = ((dosDate & 0xfe00) >> 9) + 80; - tm.tm_mon = ((dosDate & 0x1e0) >> 5) - 1; - tm.tm_mday = dosDate & 0x1f; - tm.tm_hour = (dosTime & 0xf800) >> 11; - tm.tm_min = (dosTime & 0x7e0) >> 5; - tm.tm_sec = (dosTime & 0x1f) << 1; - ret = mktime(&tm); - if (ret == (time_t) -1) { - /* fallback to 1980-01-01T00:00:00+00:00 (DOS epoch) */ - ret = (time_t) 315532800; - } - return ret; -} - -static int -ToDosTime( - time_t when) -{ - struct tm *tmp, tm; - -#if !TCL_THREADS || defined(_WIN32) - /* Not threaded, or on Win32 which uses thread local storage */ - tmp = localtime(&when); - tm = *tmp; -#elif defined(HAVE_LOCALTIME_R) - /* Threaded, have reentrant API */ - tmp = &tm; - localtime_r(&when, tmp); -#else /* TCL_THREADS && !_WIN32 && !HAVE_LOCALTIME_R */ - /* Only using a mutex is safe. */ - Tcl_MutexLock(&localtimeMutex); - tmp = localtime(&when); - tm = *tmp; - Tcl_MutexUnlock(&localtimeMutex); -#endif - return (tm.tm_hour << 11) | (tm.tm_min << 5) | (tm.tm_sec >> 1); -} - -static int -ToDosDate( - time_t when) -{ - struct tm *tmp, tm; - -#if !TCL_THREADS || defined(_WIN32) - /* Not threaded, or on Win32 which uses thread local storage */ - tmp = localtime(&when); - tm = *tmp; -#elif /* TCL_THREADS && !_WIN32 && */ defined(HAVE_LOCALTIME_R) - /* Threaded, have reentrant API */ - tmp = &tm; - localtime_r(&when, tmp); -#else /* TCL_THREADS && !_WIN32 && !HAVE_LOCALTIME_R */ - /* Only using a mutex is safe. */ - Tcl_MutexLock(&localtimeMutex); - tmp = localtime(&when); - tm = *tmp; - Tcl_MutexUnlock(&localtimeMutex); -#endif - return ((tm.tm_year - 80) << 9) | ((tm.tm_mon + 1) << 5) | tm.tm_mday; -} - -/* - *------------------------------------------------------------------------- - * - * CountSlashes -- - * - * This function counts the number of slashes in a pathname string. - * - * Results: - * Number of slashes found in string. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -CountSlashes( - const char *string) -{ - int count = 0; - const char *p = string; - - while (*p != '\0') { - if (*p == '/') { - count++; - } - p++; - } - return count; -} - -/* - *------------------------------------------------------------------------- - * - * CanonicalPath -- - * - * This function computes the canonical path from a directory and file - * name components into the specified Tcl_DString. - * - * Results: - * Returns the pointer to the canonical path contained in the specified - * Tcl_DString. - * - * Side effects: - * Modifies the specified Tcl_DString. - * - *------------------------------------------------------------------------- - */ - -static char * -CanonicalPath( - const char *root, - const char *tail, - Tcl_DString *dsPtr, - int inZipfs) -{ - char *path; - int i, j, c, isUNC = 0, isVfs = 0, n = 0; - int haveZipfsPath = 1; - -#ifdef _WIN32 - if (tail[0] != '\0' && strchr(drvletters, tail[0]) && tail[1] == ':') { - tail += 2; - haveZipfsPath = 0; - } - /* UNC style path */ - if (tail[0] == '\\') { - root = ""; - ++tail; - haveZipfsPath = 0; - } - if (tail[0] == '\\') { - root = "/"; - ++tail; - haveZipfsPath = 0; - } -#endif /* _WIN32 */ - - if (haveZipfsPath) { - /* UNC style path */ - if (root && strncmp(root, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) == 0) { - isVfs = 1; - } else if (tail && - strncmp(tail, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) == 0) { - isVfs = 2; - } - if (isVfs != 1 && (root[0] == '/') && (root[1] == '/')) { - isUNC = 1; - } - } - - if (isVfs != 2) { - if (tail[0] == '/') { - if (isVfs != 1) { - root = ""; - } - ++tail; - isUNC = 0; - } - if (tail[0] == '/') { - if (isVfs != 1) { - root = "/"; - } - ++tail; - isUNC = 1; - } - } - i = strlen(root); - j = strlen(tail); - - switch (isVfs) { - case 1: - if (i > ZIPFS_VOLUME_LEN) { - Tcl_DStringSetLength(dsPtr, i + j + 1); - path = Tcl_DStringValue(dsPtr); - memcpy(path, root, i); - path[i++] = '/'; - memcpy(path + i, tail, j); - } else { - Tcl_DStringSetLength(dsPtr, i + j); - path = Tcl_DStringValue(dsPtr); - memcpy(path, root, i); - memcpy(path + i, tail, j); - } - break; - case 2: - Tcl_DStringSetLength(dsPtr, j); - path = Tcl_DStringValue(dsPtr); - memcpy(path, tail, j); - break; - default: - if (inZipfs) { - Tcl_DStringSetLength(dsPtr, i + j + ZIPFS_VOLUME_LEN); - path = Tcl_DStringValue(dsPtr); - memcpy(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN); - memcpy(path + ZIPFS_VOLUME_LEN + i , tail, j); - } else { - Tcl_DStringSetLength(dsPtr, i + j + 1); - path = Tcl_DStringValue(dsPtr); - memcpy(path, root, i); - path[i++] = '/'; - memcpy(path + i, tail, j); - } - break; - } - -#ifdef _WIN32 - for (i = 0; path[i] != '\0'; i++) { - if (path[i] == '\\') { - path[i] = '/'; - } - } -#endif /* _WIN32 */ - - if (inZipfs) { - n = ZIPFS_VOLUME_LEN; - } else { - n = 0; - } - - for (i = j = n; (c = path[i]) != '\0'; i++) { - if (c == '/') { - int c2 = path[i + 1]; - - if (c2 == '\0' || c2 == '/') { - continue; - } - if (c2 == '.') { - int c3 = path[i + 2]; - - if ((c3 == '/') || (c3 == '\0')) { - i++; - continue; - } - if ((c3 == '.') - && ((path[i + 3] == '/') || (path[i + 3] == '\0'))) { - i += 2; - while ((j > 0) && (path[j - 1] != '/')) { - j--; - } - if (j > isUNC) { - --j; - while ((j > 1 + isUNC) && (path[j - 2] == '/')) { - j--; - } - } - continue; - } - } - } - path[j++] = c; - } - if (j == 0) { - path[j++] = '/'; - } - path[j] = 0; - Tcl_DStringSetLength(dsPtr, j); - return Tcl_DStringValue(dsPtr); -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSLookup -- - * - * This function returns the ZIP entry struct corresponding to the ZIP - * archive member of the given file name. Caller must hold the right - * lock. - * - * Results: - * Returns the pointer to ZIP entry struct or NULL if the the given file - * name could not be found in the global list of ZIP archive members. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static ZipEntry * -ZipFSLookup( - char *filename) -{ - Tcl_HashEntry *hPtr; - ZipEntry *z = NULL; - - hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, filename); - if (hPtr) { - z = Tcl_GetHashValue(hPtr); - } - return z; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSLookupMount -- - * - * This function returns an indication if the given file name corresponds - * to a mounted ZIP archive file. - * - * Results: - * Returns true, if the given file name is a mounted ZIP archive file. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -#ifdef NEVER_USED -static int -ZipFSLookupMount( - char *filename) -{ - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; - - for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr; - hPtr = Tcl_NextHashEntry(&search)) { - ZipFile *zf = Tcl_GetHashValue(hPtr); - - if (strcmp(zf->mountPoint, filename) == 0) { - return 1; - } - } - return 0; -} -#endif /* NEVER_USED */ - -/* - *------------------------------------------------------------------------- - * - * ZipFSCloseArchive -- - * - * This function closes a mounted ZIP archive file. - * - * Results: - * None. - * - * Side effects: - * A memory mapped ZIP archive is unmapped, allocated memory is released. - * The ZipFile pointer is *NOT* deallocated by this function. - * - *------------------------------------------------------------------------- - */ - -static void -ZipFSCloseArchive( - Tcl_Interp *interp, /* Current interpreter. */ - ZipFile *zf) -{ - if (zf->nameLength) { - Tcl_Free(zf->name); - } - if (zf->isMemBuffer) { - /* Pointer to memory */ - if (zf->ptrToFree) { - Tcl_Free(zf->ptrToFree); - zf->ptrToFree = NULL; - } - zf->data = NULL; - return; - } - -#ifdef _WIN32 - if (zf->data && !zf->ptrToFree) { - UnmapViewOfFile(zf->data); - zf->data = NULL; - } - if (zf->mountHandle != INVALID_HANDLE_VALUE) { - CloseHandle(zf->mountHandle); - } -#else /* !_WIN32 */ - if ((zf->data != MAP_FAILED) && !zf->ptrToFree) { - munmap(zf->data, zf->length); - zf->data = MAP_FAILED; - } -#endif /* _WIN32 */ - - if (zf->ptrToFree) { - Tcl_Free(zf->ptrToFree); - zf->ptrToFree = NULL; - } - if (zf->chan) { - Tcl_Close(interp, zf->chan); - zf->chan = NULL; - } -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSFindTOC -- - * - * This function takes a memory mapped zip file and indexes the contents. - * When "needZip" is zero an embedded ZIP archive in an executable file - * is accepted. - * - * Results: - * TCL_OK on success, TCL_ERROR otherwise with an error message placed - * into the given "interp" if it is not NULL. - * - * Side effects: - * The given ZipFile struct is filled with information about the ZIP - * archive file. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSFindTOC( - Tcl_Interp *interp, /* Current interpreter. NULLable. */ - int needZip, - ZipFile *zf) -{ - size_t i; - unsigned char *p, *q; - - p = zf->data + zf->length - ZIP_CENTRAL_END_LEN; - while (p >= zf->data) { - if (*p == (ZIP_CENTRAL_END_SIG & 0xFF)) { - if (ZipReadInt(p) == ZIP_CENTRAL_END_SIG) { - break; - } - p -= ZIP_SIG_LEN; - } else { - --p; - } - } - if (p < zf->data) { - if (!needZip) { - zf->baseOffset = zf->passOffset = zf->length; - return TCL_OK; - } - ZIPFS_ERROR(interp, "wrong end signature"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "END_SIG", NULL); - } - goto error; - } - zf->numFiles = ZipReadShort(p + ZIP_CENTRAL_ENTS_OFFS); - if (zf->numFiles == 0) { - if (!needZip) { - zf->baseOffset = zf->passOffset = zf->length; - return TCL_OK; - } - ZIPFS_ERROR(interp, "empty archive"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "EMPTY", NULL); - } - goto error; - } - q = zf->data + ZipReadInt(p + ZIP_CENTRAL_DIRSTART_OFFS); - p -= ZipReadInt(p + ZIP_CENTRAL_DIRSIZE_OFFS); - if ((p < zf->data) || (p > zf->data + zf->length) - || (q < zf->data) || (q > zf->data + zf->length)) { - if (!needZip) { - zf->baseOffset = zf->passOffset = zf->length; - return TCL_OK; - } - ZIPFS_ERROR(interp, "archive directory not found"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_DIR", NULL); - } - goto error; - } - zf->baseOffset = zf->passOffset = p - q; - zf->directoryOffset = p - zf->data; - q = p; - for (i = 0; i < zf->numFiles; i++) { - int pathlen, comlen, extra; - - if (q + ZIP_CENTRAL_HEADER_LEN > zf->data + zf->length) { - ZIPFS_ERROR(interp, "wrong header length"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "HDR_LEN", NULL); - } - goto error; - } - if (ZipReadInt(q) != ZIP_CENTRAL_HEADER_SIG) { - ZIPFS_ERROR(interp, "wrong header signature"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "HDR_SIG", NULL); - } - goto error; - } - pathlen = ZipReadShort(q + ZIP_CENTRAL_PATHLEN_OFFS); - comlen = ZipReadShort(q + ZIP_CENTRAL_FCOMMENTLEN_OFFS); - extra = ZipReadShort(q + ZIP_CENTRAL_EXTRALEN_OFFS); - q += pathlen + comlen + extra + ZIP_CENTRAL_HEADER_LEN; - } - q = zf->data + zf->baseOffset; - if ((zf->baseOffset >= 6) && (ZipReadInt(q - 4) == ZIP_PASSWORD_END_SIG)) { - i = q[-5]; - if (q - 5 - i > zf->data) { - zf->passBuf[0] = i; - memcpy(zf->passBuf + 1, q - 5 - i, i); - zf->passOffset -= i ? (5 + i) : 0; - } - } - return TCL_OK; - - error: - ZipFSCloseArchive(interp, zf); - return TCL_ERROR; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSOpenArchive -- - * - * This function opens a ZIP archive file for reading. An attempt is made - * to memory map that file. Otherwise it is read into an allocated memory - * buffer. The ZIP archive header is verified and must be valid for the - * function to succeed. When "needZip" is zero an embedded ZIP archive in - * an executable file is accepted. - * - * Results: - * TCL_OK on success, TCL_ERROR otherwise with an error message placed - * into the given "interp" if it is not NULL. - * - * Side effects: - * ZIP archive is memory mapped or read into allocated memory, the given - * ZipFile struct is filled with information about the ZIP archive file. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSOpenArchive( - Tcl_Interp *interp, /* Current interpreter. NULLable. */ - const char *zipname, /* Path to ZIP file to open. */ - int needZip, - ZipFile *zf) -{ - size_t i; - void *handle; - - zf->nameLength = 0; - zf->isMemBuffer = 0; -#ifdef _WIN32 - zf->data = NULL; - zf->mountHandle = INVALID_HANDLE_VALUE; -#else /* !_WIN32 */ - zf->data = MAP_FAILED; -#endif /* _WIN32 */ - zf->length = 0; - zf->numFiles = 0; - zf->baseOffset = zf->passOffset = 0; - zf->ptrToFree = NULL; - zf->passBuf[0] = 0; - zf->chan = Tcl_OpenFileChannel(interp, zipname, "rb", 0); - if (!zf->chan) { - return TCL_ERROR; - } - if (Tcl_GetChannelHandle(zf->chan, TCL_READABLE, &handle) != TCL_OK) { - zf->length = Tcl_Seek(zf->chan, 0, SEEK_END); - if (zf->length == TCL_IO_FAILURE) { - ZIPFS_POSIX_ERROR(interp, "seek error"); - goto error; - } - if ((zf->length - ZIP_CENTRAL_END_LEN) - > (64 * 1024 * 1024 - ZIP_CENTRAL_END_LEN)) { - ZIPFS_ERROR(interp, "illegal file size"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "FILE_SIZE", NULL); - } - goto error; - } - if (Tcl_Seek(zf->chan, 0, SEEK_SET) == -1) { - ZIPFS_POSIX_ERROR(interp, "seek error"); - goto error; - } - zf->ptrToFree = zf->data = Tcl_AttemptAlloc(zf->length); - if (!zf->ptrToFree) { - ZIPFS_ERROR(interp, "out of memory"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); - } - goto error; - } - i = Tcl_Read(zf->chan, (char *) zf->data, zf->length); - if (i != zf->length) { - ZIPFS_POSIX_ERROR(interp, "file read error"); - goto error; - } - Tcl_Close(interp, zf->chan); - zf->chan = NULL; - } else { -#ifdef _WIN32 - int readSuccessful; -# ifdef _WIN64 - i = GetFileSizeEx((HANDLE) handle, (PLARGE_INTEGER) &zf->length); - readSuccessful = (i != 0); -# else /* !_WIN64 */ - zf->length = GetFileSize((HANDLE) handle, 0); - readSuccessful = (zf->length != (size_t) INVALID_FILE_SIZE); -# endif /* _WIN64 */ - if (!readSuccessful || (zf->length < ZIP_CENTRAL_END_LEN)) { - ZIPFS_POSIX_ERROR(interp, "invalid file size"); - goto error; - } - zf->mountHandle = CreateFileMapping((HANDLE) handle, 0, PAGE_READONLY, - 0, zf->length, 0); - if (zf->mountHandle == INVALID_HANDLE_VALUE) { - ZIPFS_POSIX_ERROR(interp, "file mapping failed"); - goto error; - } - zf->data = MapViewOfFile(zf->mountHandle, FILE_MAP_READ, 0, 0, - zf->length); - if (!zf->data) { - ZIPFS_POSIX_ERROR(interp, "file mapping failed"); - goto error; - } -#else /* !_WIN32 */ - zf->length = lseek(PTR2INT(handle), 0, SEEK_END); - if (zf->length == TCL_IO_FAILURE || zf->length < ZIP_CENTRAL_END_LEN) { - ZIPFS_POSIX_ERROR(interp, "invalid file size"); - goto error; - } - lseek(PTR2INT(handle), 0, SEEK_SET); - zf->data = (unsigned char *) mmap(0, zf->length, PROT_READ, - MAP_FILE | MAP_PRIVATE, PTR2INT(handle), 0); - if (zf->data == MAP_FAILED) { - ZIPFS_POSIX_ERROR(interp, "file mapping failed"); - goto error; - } -#endif /* _WIN32 */ - } - return ZipFSFindTOC(interp, needZip, zf); - - error: - ZipFSCloseArchive(interp, zf); - return TCL_ERROR; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSRootNode -- - * - * This function generates the root node for a ZIPFS filesystem. - * - * Results: - * TCL_OK on success, TCL_ERROR otherwise with an error message placed - * into the given "interp" if it is not NULL. - * - * Side effects: - * ... - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSCatalogFilesystem( - Tcl_Interp *interp, /* Current interpreter. NULLable. */ - ZipFile *zf0, - const char *mountPoint, /* Mount point path. */ - const char *passwd, /* Password for opening the ZIP, or NULL if - * the ZIP is unprotected. */ - const char *zipname) /* Path to ZIP file to build a catalog of. */ -{ - int pwlen, isNew; - size_t i; - ZipFile *zf; - ZipEntry *z; - Tcl_HashEntry *hPtr; - Tcl_DString ds, dsm, fpBuf; - unsigned char *q; - - /* - * Basic verification of the password for sanity. - */ - - pwlen = 0; - if (passwd) { - pwlen = strlen(passwd); - if ((pwlen > 255) || strchr(passwd, 0xff)) { - if (interp) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("illegal password", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_PASS", NULL); - } - return TCL_ERROR; - } - } - - WriteLock(); - - /* - * Mount point sometimes is a relative or otherwise denormalized path. - * But an absolute name is needed as mount point here. - */ - - Tcl_DStringInit(&ds); - Tcl_DStringInit(&dsm); - if (strcmp(mountPoint, "/") == 0) { - mountPoint = ""; - } else { - mountPoint = CanonicalPath("", mountPoint, &dsm, 1); - } - hPtr = Tcl_CreateHashEntry(&ZipFS.zipHash, mountPoint, &isNew); - if (!isNew) { - if (interp) { - zf = Tcl_GetHashValue(hPtr); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%s is already mounted on %s", zf->name, mountPoint)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "MOUNTED", NULL); - } - Unlock(); - ZipFSCloseArchive(interp, zf0); - return TCL_ERROR; - } - zf = Tcl_AttemptAlloc(sizeof(ZipFile) + strlen(mountPoint) + 1); - if (!zf) { - if (interp) { - Tcl_AppendResult(interp, "out of memory", (char *) NULL); - Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); - } - Unlock(); - ZipFSCloseArchive(interp, zf0); - return TCL_ERROR; - } - Unlock(); - - *zf = *zf0; - zf->mountPoint = Tcl_GetHashKey(&ZipFS.zipHash, hPtr); - Tcl_CreateExitHandler(ZipfsExitHandler, (ClientData)zf); - zf->mountPointLen = strlen(zf->mountPoint); - zf->nameLength = strlen(zipname); - zf->name = Tcl_Alloc(zf->nameLength + 1); - memcpy(zf->name, zipname, zf->nameLength + 1); - zf->entries = NULL; - zf->topEnts = NULL; - zf->numOpen = 0; - Tcl_SetHashValue(hPtr, zf); - if ((zf->passBuf[0] == 0) && pwlen) { - int k = 0; - - zf->passBuf[k++] = pwlen; - for (i = pwlen; i-- > 0 ;) { - zf->passBuf[k++] = (passwd[i] & 0x0f) - | pwrot[(passwd[i] >> 4) & 0x0f]; - } - zf->passBuf[k] = '\0'; - } - if (mountPoint[0] != '\0') { - hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, mountPoint, &isNew); - if (isNew) { - z = Tcl_Alloc(sizeof(ZipEntry)); - Tcl_SetHashValue(hPtr, z); - - z->tnext = NULL; - z->depth = CountSlashes(mountPoint); - z->zipFilePtr = zf; - z->isDirectory = (zf->baseOffset == 0) ? 1 : -1; /* root marker */ - z->isEncrypted = 0; - z->offset = zf->baseOffset; - z->crc32 = 0; - z->timestamp = 0; - z->numBytes = z->numCompressedBytes = 0; - z->compressMethod = ZIP_COMPMETH_STORED; - z->data = NULL; - z->name = Tcl_GetHashKey(&ZipFS.fileHash, hPtr); - z->next = zf->entries; - zf->entries = z; - } - } - q = zf->data + zf->directoryOffset; - Tcl_DStringInit(&fpBuf); - for (i = 0; i < zf->numFiles; i++) { - int extra, isdir = 0, dosTime, dosDate, nbcompr; - size_t offs, pathlen, comlen; - unsigned char *lq, *gq = NULL; - char *fullpath, *path; - - pathlen = ZipReadShort(q + ZIP_CENTRAL_PATHLEN_OFFS); - comlen = ZipReadShort(q + ZIP_CENTRAL_FCOMMENTLEN_OFFS); - extra = ZipReadShort(q + ZIP_CENTRAL_EXTRALEN_OFFS); - Tcl_DStringSetLength(&ds, 0); - Tcl_DStringAppend(&ds, (char *) q + ZIP_CENTRAL_HEADER_LEN, pathlen); - path = Tcl_DStringValue(&ds); - if ((pathlen > 0) && (path[pathlen - 1] == '/')) { - Tcl_DStringSetLength(&ds, pathlen - 1); - path = Tcl_DStringValue(&ds); - isdir = 1; - } - if ((strcmp(path, ".") == 0) || (strcmp(path, "..") == 0)) { - goto nextent; - } - lq = zf->data + zf->baseOffset - + ZipReadInt(q + ZIP_CENTRAL_LOCALHDR_OFFS); - if ((lq < zf->data) || (lq > zf->data + zf->length)) { - goto nextent; - } - nbcompr = ZipReadInt(lq + ZIP_LOCAL_COMPLEN_OFFS); - if (!isdir && (nbcompr == 0) - && (ZipReadInt(lq + ZIP_LOCAL_UNCOMPLEN_OFFS) == 0) - && (ZipReadInt(lq + ZIP_LOCAL_CRC32_OFFS) == 0)) { - gq = q; - nbcompr = ZipReadInt(gq + ZIP_CENTRAL_COMPLEN_OFFS); - } - offs = (lq - zf->data) - + ZIP_LOCAL_HEADER_LEN - + ZipReadShort(lq + ZIP_LOCAL_PATHLEN_OFFS) - + ZipReadShort(lq + ZIP_LOCAL_EXTRALEN_OFFS); - if (offs + nbcompr > zf->length) { - goto nextent; - } - if (!isdir && (mountPoint[0] == '\0') && !CountSlashes(path)) { -#ifdef ANDROID - /* - * When mounting the ZIP archive on the root directory try to - * remap top level regular files of the archive to - * /assets/.root/... since this directory should not be in a valid - * APK due to the leading dot in the file name component. This - * trick should make the files AndroidManifest.xml, - * resources.arsc, and classes.dex visible to Tcl. - */ - Tcl_DString ds2; - - Tcl_DStringInit(&ds2); - Tcl_DStringAppend(&ds2, "assets/.root/", -1); - Tcl_DStringAppend(&ds2, path, -1); - hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, Tcl_DStringValue(&ds2)); - if (hPtr) { - /* should not happen but skip it anyway */ - Tcl_DStringFree(&ds2); - goto nextent; - } - Tcl_DStringSetLength(&ds, 0); - Tcl_DStringAppend(&ds, Tcl_DStringValue(&ds2), - Tcl_DStringLength(&ds2)); - path = Tcl_DStringValue(&ds); - Tcl_DStringFree(&ds2); -#else /* !ANDROID */ - /* - * Regular files skipped when mounting on root. - */ - goto nextent; -#endif /* ANDROID */ - } - Tcl_DStringSetLength(&fpBuf, 0); - fullpath = CanonicalPath(mountPoint, path, &fpBuf, 1); - z = Tcl_Alloc(sizeof(ZipEntry)); - z->name = NULL; - z->tnext = NULL; - z->depth = CountSlashes(fullpath); - z->zipFilePtr = zf; - z->isDirectory = isdir; - z->isEncrypted = (ZipReadShort(lq + ZIP_LOCAL_FLAGS_OFFS) & 1) - && (nbcompr > 12); - z->offset = offs; - if (gq) { - z->crc32 = ZipReadInt(gq + ZIP_CENTRAL_CRC32_OFFS); - dosDate = ZipReadShort(gq + ZIP_CENTRAL_MDATE_OFFS); - dosTime = ZipReadShort(gq + ZIP_CENTRAL_MTIME_OFFS); - z->timestamp = DosTimeDate(dosDate, dosTime); - z->numBytes = ZipReadInt(gq + ZIP_CENTRAL_UNCOMPLEN_OFFS); - z->compressMethod = ZipReadShort(gq + ZIP_CENTRAL_COMPMETH_OFFS); - } else { - z->crc32 = ZipReadInt(lq + ZIP_LOCAL_CRC32_OFFS); - dosDate = ZipReadShort(lq + ZIP_LOCAL_MDATE_OFFS); - dosTime = ZipReadShort(lq + ZIP_LOCAL_MTIME_OFFS); - z->timestamp = DosTimeDate(dosDate, dosTime); - z->numBytes = ZipReadInt(lq + ZIP_LOCAL_UNCOMPLEN_OFFS); - z->compressMethod = ZipReadShort(lq + ZIP_LOCAL_COMPMETH_OFFS); - } - z->numCompressedBytes = nbcompr; - z->data = NULL; - hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, fullpath, &isNew); - if (!isNew) { - /* should not happen but skip it anyway */ - Tcl_Free(z); - } else { - Tcl_SetHashValue(hPtr, z); - z->name = Tcl_GetHashKey(&ZipFS.fileHash, hPtr); - z->next = zf->entries; - zf->entries = z; - if (isdir && (mountPoint[0] == '\0') && (z->depth == 1)) { - z->tnext = zf->topEnts; - zf->topEnts = z; - } - if (!z->isDirectory && (z->depth > 1)) { - char *dir, *end; - ZipEntry *zd; - - Tcl_DStringSetLength(&ds, strlen(z->name) + 8); - Tcl_DStringSetLength(&ds, 0); - Tcl_DStringAppend(&ds, z->name, -1); - dir = Tcl_DStringValue(&ds); - for (end = strrchr(dir, '/'); end && (end != dir); - end = strrchr(dir, '/')) { - Tcl_DStringSetLength(&ds, end - dir); - hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, dir, &isNew); - if (!isNew) { - break; - } - zd = Tcl_Alloc(sizeof(ZipEntry)); - zd->name = NULL; - zd->tnext = NULL; - zd->depth = CountSlashes(dir); - zd->zipFilePtr = zf; - zd->isDirectory = 1; - zd->isEncrypted = 0; - zd->offset = z->offset; - zd->crc32 = 0; - zd->timestamp = z->timestamp; - zd->numBytes = zd->numCompressedBytes = 0; - zd->compressMethod = ZIP_COMPMETH_STORED; - zd->data = NULL; - Tcl_SetHashValue(hPtr, zd); - zd->name = Tcl_GetHashKey(&ZipFS.fileHash, hPtr); - zd->next = zf->entries; - zf->entries = zd; - if ((mountPoint[0] == '\0') && (zd->depth == 1)) { - zd->tnext = zf->topEnts; - zf->topEnts = zd; - } - } - } - } - nextent: - q += pathlen + comlen + extra + ZIP_CENTRAL_HEADER_LEN; - } - Tcl_DStringFree(&fpBuf); - Tcl_DStringFree(&ds); - Tcl_FSMountsChanged(NULL); - Unlock(); - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * ZipfsSetup -- - * - * Common initialisation code. ZipFS.initialized must *not* be set prior - * to the call. - * - *------------------------------------------------------------------------- - */ - -static void -ZipfsSetup(void) -{ -#if TCL_THREADS - static const Tcl_Time t = { 0, 0 }; - - /* - * Inflate condition variable. - */ - - Tcl_MutexLock(&ZipFSMutex); - Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, &t); - Tcl_MutexUnlock(&ZipFSMutex); -#endif /* TCL_THREADS */ - - Tcl_FSRegister(NULL, &zipfsFilesystem); - Tcl_InitHashTable(&ZipFS.fileHash, TCL_STRING_KEYS); - Tcl_InitHashTable(&ZipFS.zipHash, TCL_STRING_KEYS); - ZipFS.idCount = 1; - ZipFS.wrmax = DEFAULT_WRITE_MAX_SIZE; - ZipFS.initialized = 1; -} - -/* - *------------------------------------------------------------------------- - * - * ListMountPoints -- - * - * This procedure lists the mount points and what's mounted there, or - * reports whether there are any mounts (if there's no interpreter). The - * read lock must be held by the caller. - * - * Results: - * A standard Tcl result. TCL_OK (or TCL_BREAK if no mounts and no - * interpreter). - * - * Side effects: - * Interpreter result may be updated. - * - *------------------------------------------------------------------------- - */ - -static inline int -ListMountPoints( - Tcl_Interp *interp) -{ - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; - ZipFile *zf; - - for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr; - hPtr = Tcl_NextHashEntry(&search)) { - if (!interp) { - return TCL_OK; - } - zf = Tcl_GetHashValue(hPtr); - Tcl_AppendElement(interp, zf->mountPoint); - Tcl_AppendElement(interp, zf->name); - } - return (interp ? TCL_OK : TCL_BREAK); -} - -/* - *------------------------------------------------------------------------- - * - * DescribeMounted -- - * - * This procedure describes what is mounted at the given the mount point. - * The interpreter result is not updated if there is nothing mounted at - * the given point. The read lock must be held by the caller. - * - * Results: - * A standard Tcl result. TCL_OK (or TCL_BREAK if nothing mounted there - * and no interpreter). - * - * Side effects: - * Interpreter result may be updated. - * - *------------------------------------------------------------------------- - */ - -static inline int -DescribeMounted( - Tcl_Interp *interp, - const char *mountPoint) -{ - Tcl_HashEntry *hPtr; - ZipFile *zf; - - if (interp) { - hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mountPoint); - if (hPtr) { - zf = Tcl_GetHashValue(hPtr); - Tcl_SetObjResult(interp, Tcl_NewStringObj(zf->name, -1)); - return TCL_OK; - } - } - return (interp ? TCL_OK : TCL_BREAK); -} - -/* - *------------------------------------------------------------------------- - * - * TclZipfs_Mount -- - * - * This procedure is invoked to mount a given ZIP archive file on a given - * mountpoint with optional ZIP password. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * A ZIP archive file is read, analyzed and mounted, resources are - * allocated. - * - *------------------------------------------------------------------------- - */ - -int -TclZipfs_Mount( - Tcl_Interp *interp, /* Current interpreter. NULLable. */ - const char *mountPoint, /* Mount point path. */ - const char *zipname, /* Path to ZIP file to mount. */ - const char *passwd) /* Password for opening the ZIP, or NULL if - * the ZIP is unprotected. */ -{ - ZipFile *zf; - - ReadLock(); - if (!ZipFS.initialized) { - ZipfsSetup(); - } - - /* - * No mount point, so list all mount points and what is mounted there. - */ - - if (!mountPoint) { - int ret = ListMountPoints(interp); - Unlock(); - return ret; - } - - /* - * Mount point but no file, so describe what is mounted at that mount - * point. - */ - - if (!zipname) { - DescribeMounted(interp, mountPoint); - Unlock(); - return TCL_OK; - } - Unlock(); - - /* - * Have both a mount point and a file (name) to mount there. - */ - - if (passwd) { - if ((strlen(passwd) > 255) || strchr(passwd, 0xff)) { - if (interp) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("illegal password", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_PASS", NULL); - } - return TCL_ERROR; - } - } - zf = Tcl_AttemptAlloc(sizeof(ZipFile) + strlen(mountPoint) + 1); - if (!zf) { - if (interp) { - Tcl_AppendResult(interp, "out of memory", (char *) NULL); - Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); - } - return TCL_ERROR; - } - if (ZipFSOpenArchive(interp, zipname, 1, zf) != TCL_OK) { - Tcl_Free(zf); - return TCL_ERROR; - } - if (ZipFSCatalogFilesystem(interp, zf, mountPoint, passwd, zipname) - != TCL_OK) { - Tcl_Free(zf); - return TCL_ERROR; - } - Tcl_Free(zf); - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * TclZipfs_MountBuffer -- - * - * This procedure is invoked to mount a given ZIP archive file on a given - * mountpoint with optional ZIP password. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * A ZIP archive file is read, analyzed and mounted, resources are - * allocated. - * - *------------------------------------------------------------------------- - */ - -int -TclZipfs_MountBuffer( - Tcl_Interp *interp, /* Current interpreter. NULLable. */ - const char *mountPoint, /* Mount point path. */ - unsigned char *data, - size_t datalen, - int copy) -{ - ZipFile *zf; - int result; - - ReadLock(); - if (!ZipFS.initialized) { - ZipfsSetup(); - } - - /* - * No mount point, so list all mount points and what is mounted there. - */ - - if (!mountPoint) { - int ret = ListMountPoints(interp); - Unlock(); - return ret; - } - - /* - * Mount point but no data, so describe what is mounted at that mount - * point. - */ - - if (!data) { - DescribeMounted(interp, mountPoint); - Unlock(); - return TCL_OK; - } - Unlock(); - - /* - * Have both a mount point and data to mount there. - */ - - zf = Tcl_AttemptAlloc(sizeof(ZipFile) + strlen(mountPoint) + 1); - if (!zf) { - if (interp) { - Tcl_AppendResult(interp, "out of memory", (char *) NULL); - Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); - } - return TCL_ERROR; - } - zf->isMemBuffer = 1; - zf->length = datalen; - if (copy) { - zf->data = Tcl_AttemptAlloc(datalen); - if (!zf->data) { - if (interp) { - Tcl_AppendResult(interp, "out of memory", (char *) NULL); - Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); - } - return TCL_ERROR; - } - memcpy(zf->data, data, datalen); - zf->ptrToFree = zf->data; - } else { - zf->data = data; - zf->ptrToFree = NULL; - } - zf->passBuf[0] = 0; /* stop valgrind cries */ - if (ZipFSFindTOC(interp, 0, zf) != TCL_OK) { - return TCL_ERROR; - } - result = ZipFSCatalogFilesystem(interp, zf, mountPoint, NULL, - "Memory Buffer"); - Tcl_Free(zf); - return result; -} - -/* - *------------------------------------------------------------------------- - * - * TclZipfs_Unmount -- - * - * This procedure is invoked to unmount a given ZIP archive. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * A mounted ZIP archive file is unmounted, resources are free'd. - * - *------------------------------------------------------------------------- - */ - -int -TclZipfs_Unmount( - Tcl_Interp *interp, /* Current interpreter. NULLable. */ - const char *mountPoint) /* Mount point path. */ -{ - ZipFile *zf; - ZipEntry *z, *znext; - Tcl_HashEntry *hPtr; - Tcl_DString dsm; - int ret = TCL_OK, unmounted = 0; - - WriteLock(); - if (!ZipFS.initialized) { - goto done; - } - - /* - * Mount point sometimes is a relative or otherwise denormalized path. - * But an absolute name is needed as mount point here. - */ - - Tcl_DStringInit(&dsm); - mountPoint = CanonicalPath("", mountPoint, &dsm, 1); - - hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mountPoint); - /* don't report no-such-mount as an error */ - if (!hPtr) { - goto done; - } - - zf = Tcl_GetHashValue(hPtr); - if (zf->numOpen > 0) { - ZIPFS_ERROR(interp, "filesystem is busy"); - ret = TCL_ERROR; - goto done; - } - Tcl_DeleteHashEntry(hPtr); - for (z = zf->entries; z; z = znext) { - znext = z->next; - hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, z->name); - if (hPtr) { - Tcl_DeleteHashEntry(hPtr); - } - if (z->data) { - Tcl_Free(z->data); - } - Tcl_Free(z); - } - ZipFSCloseArchive(interp, zf); - Tcl_DeleteExitHandler(ZipfsExitHandler, (ClientData)zf); - Tcl_Free(zf); - unmounted = 1; - done: - Unlock(); - if (unmounted) { - Tcl_FSMountsChanged(NULL); - } - return ret; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSMountObjCmd -- - * - * This procedure is invoked to process the [zipfs mount] command. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * A ZIP archive file is mounted, resources are allocated. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSMountObjCmd( - void *clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - if (objc > 4) { - Tcl_WrongNumArgs(interp, 1, objv, - "?mountpoint? ?zipfile? ?password?"); - return TCL_ERROR; - } - - return TclZipfs_Mount(interp, (objc > 1) ? TclGetString(objv[1]) : NULL, - (objc > 2) ? TclGetString(objv[2]) : NULL, - (objc > 3) ? TclGetString(objv[3]) : NULL); -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSMountBufferObjCmd -- - * - * This procedure is invoked to process the [zipfs mount_data] command. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * A ZIP archive file is mounted, resources are allocated. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSMountBufferObjCmd( - void *clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - const char *mountPoint; /* Mount point path. */ - unsigned char *data; - size_t length = 0; - - if (objc > 3) { - Tcl_WrongNumArgs(interp, 1, objv, "?mountpoint? ?data?"); - return TCL_ERROR; - } - if (objc < 2) { - int ret; - - ReadLock(); - ret = ListMountPoints(interp); - Unlock(); - return ret; - } - - mountPoint = TclGetString(objv[1]); - if (objc < 3) { - ReadLock(); - DescribeMounted(interp, mountPoint); - Unlock(); - return TCL_OK; - } - - data = TclGetByteArrayFromObj(objv[2], &length); - return TclZipfs_MountBuffer(interp, mountPoint, data, length, 1); -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSRootObjCmd -- - * - * This procedure is invoked to process the [zipfs root] command. It - * returns the root that all zipfs file systems are mounted under. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSRootObjCmd( - void *clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_SetObjResult(interp, Tcl_NewStringObj(ZIPFS_VOLUME, -1)); - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSUnmountObjCmd -- - * - * This procedure is invoked to process the [zipfs unmount] command. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * A mounted ZIP archive file is unmounted, resources are free'd. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSUnmountObjCmd( - void *clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "zipfile"); - return TCL_ERROR; - } - return TclZipfs_Unmount(interp, TclGetString(objv[1])); -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSMkKeyObjCmd -- - * - * This procedure is invoked to process the [zipfs mkkey] command. It - * produces a rotated password to be embedded into an image file. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSMkKeyObjCmd( - void *clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - int len, i = 0; - char *pw, passBuf[264]; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "password"); - return TCL_ERROR; - } - pw = TclGetString(objv[1]); - len = strlen(pw); - if (len == 0) { - return TCL_OK; - } - if ((len > 255) || strchr(pw, 0xff)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("illegal password", -1)); - return TCL_ERROR; - } - while (len > 0) { - int ch = pw[len - 1]; - - passBuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; - i++; - len--; - } - passBuf[i] = i; - ++i; - passBuf[i++] = (char) ZIP_PASSWORD_END_SIG; - passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 8); - passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 16); - passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 24); - passBuf[i] = '\0'; - Tcl_AppendResult(interp, passBuf, (char *) NULL); - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * ZipAddFile -- - * - * This procedure is used by ZipFSMkZipOrImgCmd() to add a single file to - * the output ZIP archive file being written. A ZipEntry struct about the - * input file is added to the given fileHash table for later creation of - * the central ZIP directory. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Input file is read and (compressed and) written to the output ZIP - * archive file. - * - *------------------------------------------------------------------------- - */ - -static int -ZipAddFile( - Tcl_Interp *interp, /* Current interpreter. */ - const char *path, - const char *name, - Tcl_Channel out, - const char *passwd, /* Password for encoding the file, or NULL if - * the file is to be unprotected. */ - char *buf, - int bufsize, - Tcl_HashTable *fileHash) -{ - Tcl_Channel in; - Tcl_HashEntry *hPtr; - ZipEntry *z; - z_stream stream; - const char *zpath; - int crc, flush, zpathlen; - size_t nbyte, nbytecompr, len, olen, align = 0; - Tcl_WideInt pos[3]; - int mtime = 0, isNew, compMeth; - unsigned long keys[3], keys0[3]; - char obuf[4096]; - - /* - * Trim leading '/' characters. If this results in an empty string, we've - * nothing to do. - */ - - zpath = name; - while (zpath && zpath[0] == '/') { - zpath++; - } - if (!zpath || (zpath[0] == '\0')) { - return TCL_OK; - } - - zpathlen = strlen(zpath); - if (zpathlen + ZIP_CENTRAL_HEADER_LEN > bufsize) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "path too long for \"%s\"", path)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "PATH_LEN", NULL); - return TCL_ERROR; - } - in = Tcl_OpenFileChannel(interp, path, "rb", 0); - if (!in) { -#ifdef _WIN32 - /* hopefully a directory */ - if (strcmp("permission denied", Tcl_PosixError(interp)) == 0) { - Tcl_Close(interp, in); - return TCL_OK; - } -#endif /* _WIN32 */ - Tcl_Close(interp, in); - return TCL_ERROR; - } else { - Tcl_Obj *pathObj = Tcl_NewStringObj(path, -1); - Tcl_StatBuf statBuf; - - Tcl_IncrRefCount(pathObj); - if (Tcl_FSStat(pathObj, &statBuf) != -1) { - mtime = statBuf.st_mtime; - } - Tcl_DecrRefCount(pathObj); - } - Tcl_ResetResult(interp); - crc = 0; - nbyte = nbytecompr = 0; - while (1) { - len = Tcl_Read(in, buf, bufsize); - if (len == TCL_IO_FAILURE) { - if (nbyte == 0 && errno == EISDIR) { - Tcl_Close(interp, in); - return TCL_OK; - } - Tcl_SetObjResult(interp, Tcl_ObjPrintf("read error on \"%s\": %s", - path, Tcl_PosixError(interp))); - Tcl_Close(interp, in); - return TCL_ERROR; - } - if (len == 0) { - break; - } - crc = crc32(crc, (unsigned char *) buf, len); - nbyte += len; - } - if (Tcl_Seek(in, 0, SEEK_SET) == -1) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf("seek error on \"%s\": %s", - path, Tcl_PosixError(interp))); - Tcl_Close(interp, in); - return TCL_ERROR; - } - pos[0] = Tcl_Tell(out); - memset(buf, '\0', ZIP_LOCAL_HEADER_LEN); - memcpy(buf + ZIP_LOCAL_HEADER_LEN, zpath, zpathlen); - len = zpathlen + ZIP_LOCAL_HEADER_LEN; - if (Tcl_Write(out, buf, len) != len) { - wrerr: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "write error on %s: %s", path, Tcl_PosixError(interp))); - Tcl_Close(interp, in); - return TCL_ERROR; - } - if ((len + pos[0]) & 3) { - unsigned char abuf[8]; - - /* - * Align payload to next 4-byte boundary using a dummy extra entry - * similar to the zipalign tool from Android's SDK. - */ - - align = 4 + ((len + pos[0]) & 3); - ZipWriteShort(abuf, 0xffff); - ZipWriteShort(abuf + 2, align - 4); - ZipWriteInt(abuf + 4, 0x03020100); - if (Tcl_Write(out, (const char *) abuf, align) != align) { - goto wrerr; - } - } - if (passwd) { - int i, ch, tmp; - unsigned char kvbuf[24]; - Tcl_Obj *ret; - - init_keys(passwd, keys, crc32tab); - for (i = 0; i < 12 - 2; i++) { - double r; - - if (Tcl_EvalEx(interp, "::tcl::mathfunc::rand", -1, 0) != TCL_OK) { - Tcl_Obj *eiPtr = Tcl_ObjPrintf( - "\n (evaluating PRNG step %d for password encoding)", - i); - - Tcl_AppendObjToErrorInfo(interp, eiPtr); - Tcl_Close(interp, in); - return TCL_ERROR; - } - ret = Tcl_GetObjResult(interp); - if (Tcl_GetDoubleFromObj(interp, ret, &r) != TCL_OK) { - Tcl_Obj *eiPtr = Tcl_ObjPrintf( - "\n (evaluating PRNG step %d for password encoding)", - i); - - Tcl_AppendObjToErrorInfo(interp, eiPtr); - Tcl_Close(interp, in); - return TCL_ERROR; - } - ch = (int) (r * 256); - kvbuf[i + 12] = (unsigned char) zencode(keys, crc32tab, ch, tmp); - } - Tcl_ResetResult(interp); - init_keys(passwd, keys, crc32tab); - for (i = 0; i < 12 - 2; i++) { - kvbuf[i] = (unsigned char) - zencode(keys, crc32tab, kvbuf[i + 12], tmp); - } - kvbuf[i++] = (unsigned char) zencode(keys, crc32tab, crc >> 16, tmp); - kvbuf[i++] = (unsigned char) zencode(keys, crc32tab, crc >> 24, tmp); - len = Tcl_Write(out, (char *) kvbuf, 12); - memset(kvbuf, 0, 24); - if (len != 12) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "write error on %s: %s", path, Tcl_PosixError(interp))); - Tcl_Close(interp, in); - return TCL_ERROR; - } - memcpy(keys0, keys, sizeof(keys0)); - nbytecompr += 12; - } - Tcl_Flush(out); - pos[2] = Tcl_Tell(out); - compMeth = ZIP_COMPMETH_DEFLATED; - memset(&stream, 0, sizeof(z_stream)); - stream.zalloc = Z_NULL; - stream.zfree = Z_NULL; - stream.opaque = Z_NULL; - if (deflateInit2(&stream, 9, Z_DEFLATED, -15, 8, - Z_DEFAULT_STRATEGY) != Z_OK) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "compression init error on \"%s\"", path)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "DEFLATE_INIT", NULL); - Tcl_Close(interp, in); - return TCL_ERROR; - } - do { - len = Tcl_Read(in, buf, bufsize); - if (len == TCL_IO_FAILURE) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "read error on %s: %s", path, Tcl_PosixError(interp))); - deflateEnd(&stream); - Tcl_Close(interp, in); - return TCL_ERROR; - } - stream.avail_in = len; - stream.next_in = (unsigned char *) buf; - flush = Tcl_Eof(in) ? Z_FINISH : Z_NO_FLUSH; - do { - stream.avail_out = sizeof(obuf); - stream.next_out = (unsigned char *) obuf; - len = deflate(&stream, flush); - if (len == (size_t) Z_STREAM_ERROR) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "deflate error on %s", path)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "DEFLATE", NULL); - deflateEnd(&stream); - Tcl_Close(interp, in); - return TCL_ERROR; - } - olen = sizeof(obuf) - stream.avail_out; - if (passwd) { - size_t i; - int tmp; - - for (i = 0; i < olen; i++) { - obuf[i] = (char) zencode(keys, crc32tab, obuf[i], tmp); - } - } - if (olen && (Tcl_Write(out, obuf, olen) != olen)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "write error: %s", Tcl_PosixError(interp))); - deflateEnd(&stream); - Tcl_Close(interp, in); - return TCL_ERROR; - } - nbytecompr += olen; - } while (stream.avail_out == 0); - } while (flush != Z_FINISH); - deflateEnd(&stream); - Tcl_Flush(out); - pos[1] = Tcl_Tell(out); - if (nbyte - nbytecompr <= 0) { - /* - * Compressed file larger than input, write it again uncompressed. - */ - if (Tcl_Seek(in, 0, SEEK_SET) != 0) { - goto seekErr; - } - if (Tcl_Seek(out, pos[2], SEEK_SET) != pos[2]) { - seekErr: - Tcl_Close(interp, in); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "seek error: %s", Tcl_PosixError(interp))); - return TCL_ERROR; - } - nbytecompr = (passwd ? 12 : 0); - while (1) { - len = Tcl_Read(in, buf, bufsize); - if (len == TCL_IO_FAILURE) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "read error on \"%s\": %s", - path, Tcl_PosixError(interp))); - Tcl_Close(interp, in); - return TCL_ERROR; - } else if (len == 0) { - break; - } - if (passwd) { - size_t i; - int tmp; - - for (i = 0; i < len; i++) { - buf[i] = (char) zencode(keys0, crc32tab, buf[i], tmp); - } - } - if (Tcl_Write(out, buf, len) != len) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "write error: %s", Tcl_PosixError(interp))); - Tcl_Close(interp, in); - return TCL_ERROR; - } - nbytecompr += len; - } - compMeth = ZIP_COMPMETH_STORED; - Tcl_Flush(out); - pos[1] = Tcl_Tell(out); - Tcl_TruncateChannel(out, pos[1]); - } - Tcl_Close(interp, in); - - hPtr = Tcl_CreateHashEntry(fileHash, zpath, &isNew); - if (!isNew) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "non-unique path name \"%s\"", path)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "DUPLICATE_PATH", NULL); - return TCL_ERROR; - } - - z = Tcl_Alloc(sizeof(ZipEntry)); - Tcl_SetHashValue(hPtr, z); - z->name = NULL; - z->tnext = NULL; - z->depth = 0; - z->zipFilePtr = NULL; - z->isDirectory = 0; - z->isEncrypted = (passwd ? 1 : 0); - z->offset = pos[0]; - z->crc32 = crc; - z->timestamp = mtime; - z->numBytes = nbyte; - z->numCompressedBytes = nbytecompr; - z->compressMethod = compMeth; - z->data = NULL; - z->name = Tcl_GetHashKey(fileHash, hPtr); - z->next = NULL; - - /* - * Write final local header information. - */ - ZipWriteInt(buf + ZIP_LOCAL_SIG_OFFS, ZIP_LOCAL_HEADER_SIG); - ZipWriteShort(buf + ZIP_LOCAL_VERSION_OFFS, ZIP_MIN_VERSION); - ZipWriteShort(buf + ZIP_LOCAL_FLAGS_OFFS, z->isEncrypted); - ZipWriteShort(buf + ZIP_LOCAL_COMPMETH_OFFS, z->compressMethod); - ZipWriteShort(buf + ZIP_LOCAL_MTIME_OFFS, ToDosTime(z->timestamp)); - ZipWriteShort(buf + ZIP_LOCAL_MDATE_OFFS, ToDosDate(z->timestamp)); - ZipWriteInt(buf + ZIP_LOCAL_CRC32_OFFS, z->crc32); - ZipWriteInt(buf + ZIP_LOCAL_COMPLEN_OFFS, z->numCompressedBytes); - ZipWriteInt(buf + ZIP_LOCAL_UNCOMPLEN_OFFS, z->numBytes); - ZipWriteShort(buf + ZIP_LOCAL_PATHLEN_OFFS, zpathlen); - ZipWriteShort(buf + ZIP_LOCAL_EXTRALEN_OFFS, align); - if (Tcl_Seek(out, pos[0], SEEK_SET) != pos[0]) { - Tcl_DeleteHashEntry(hPtr); - Tcl_Free(z); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "seek error: %s", Tcl_PosixError(interp))); - return TCL_ERROR; - } - if (Tcl_Write(out, buf, ZIP_LOCAL_HEADER_LEN) != ZIP_LOCAL_HEADER_LEN) { - Tcl_DeleteHashEntry(hPtr); - Tcl_Free(z); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "write error: %s", Tcl_PosixError(interp))); - return TCL_ERROR; - } - Tcl_Flush(out); - if (Tcl_Seek(out, pos[1], SEEK_SET) != pos[1]) { - Tcl_DeleteHashEntry(hPtr); - Tcl_Free(z); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "seek error: %s", Tcl_PosixError(interp))); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSMkZipOrImgObjCmd -- - * - * This procedure is creates a new ZIP archive file or image file given - * output filename, input directory of files to be archived, optional - * password, and optional image to be prepended to the output ZIP archive - * file. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * A new ZIP archive file or image file is written. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSMkZipOrImgObjCmd( - Tcl_Interp *interp, /* Current interpreter. */ - int isImg, - int isList, - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Channel out; - int pwlen = 0, count, ret = TCL_ERROR, lobjc; - size_t len, slen = 0, i = 0; - Tcl_WideInt pos[3]; - Tcl_Obj **lobjv, *list = NULL; - ZipEntry *z; - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; - Tcl_HashTable fileHash; - char *strip = NULL, *pw = NULL, passBuf[264], buf[4096]; - - /* - * Caller has verified that the number of arguments is correct. - */ - - passBuf[0] = 0; - if (objc > (isList ? 3 : 4)) { - pw = TclGetString(objv[isList ? 3 : 4]); - pwlen = strlen(pw); - if ((pwlen > 255) || strchr(pw, 0xff)) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("illegal password", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_PASS", NULL); - return TCL_ERROR; - } - } - if (isList) { - list = objv[2]; - Tcl_IncrRefCount(list); - } else { - Tcl_Obj *cmd[3]; - - cmd[1] = Tcl_NewStringObj("::tcl::zipfs::find", -1); - cmd[2] = objv[2]; - cmd[0] = Tcl_NewListObj(2, cmd + 1); - Tcl_IncrRefCount(cmd[0]); - if (Tcl_EvalObjEx(interp, cmd[0], TCL_EVAL_DIRECT) != TCL_OK) { - Tcl_DecrRefCount(cmd[0]); - return TCL_ERROR; - } - Tcl_DecrRefCount(cmd[0]); - list = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(list); - } - if (Tcl_ListObjGetElements(interp, list, &lobjc, &lobjv) != TCL_OK) { - Tcl_DecrRefCount(list); - return TCL_ERROR; - } - if (isList && (lobjc % 2)) { - Tcl_DecrRefCount(list); - Tcl_SetObjResult(interp, - Tcl_NewStringObj("need even number of elements", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "LIST_LENGTH", NULL); - return TCL_ERROR; - } - if (lobjc == 0) { - Tcl_DecrRefCount(list); - Tcl_SetObjResult(interp, Tcl_NewStringObj("empty archive", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "EMPTY", NULL); - return TCL_ERROR; - } - out = Tcl_OpenFileChannel(interp, TclGetString(objv[1]), "wb", 0755); - if (out == NULL) { - Tcl_DecrRefCount(list); - return TCL_ERROR; - } - if (pwlen <= 0) { - pw = NULL; - pwlen = 0; - } - if (isImg) { - ZipFile *zf, zf0; - int isMounted = 0; - const char *imgName; - - if (isList) { - imgName = (objc > 4) ? TclGetString(objv[4]) : - Tcl_GetNameOfExecutable(); - } else { - imgName = (objc > 5) ? TclGetString(objv[5]) : - Tcl_GetNameOfExecutable(); - } - if (pwlen) { - i = 0; - for (len = pwlen; len-- > 0;) { - int ch = pw[len]; - - passBuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; - i++; - } - passBuf[i] = i; - ++i; - passBuf[i++] = (char) ZIP_PASSWORD_END_SIG; - passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 8); - passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 16); - passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 24); - passBuf[i] = '\0'; - } - - /* - * Check for mounted image. - */ - - WriteLock(); - for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr; - hPtr = Tcl_NextHashEntry(&search)) { - zf = Tcl_GetHashValue(hPtr); - if (strcmp(zf->name, imgName) == 0) { - isMounted = 1; - zf->numOpen++; - break; - } - } - Unlock(); - if (!isMounted) { - zf = &zf0; - } - if (isMounted || ZipFSOpenArchive(interp, imgName, 0, zf) == TCL_OK) { - if (Tcl_Write(out, (char *) zf->data, - zf->passOffset) != zf->passOffset) { - memset(passBuf, 0, sizeof(passBuf)); - Tcl_DecrRefCount(list); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "write error: %s", Tcl_PosixError(interp))); - Tcl_Close(interp, out); - if (zf == &zf0) { - ZipFSCloseArchive(interp, zf); - } else { - WriteLock(); - zf->numOpen--; - Unlock(); - } - return TCL_ERROR; - } - if (zf == &zf0) { - ZipFSCloseArchive(interp, zf); - } else { - WriteLock(); - zf->numOpen--; - Unlock(); - } - } else { - size_t k; - int m, n; - Tcl_Channel in; - const char *errMsg = "seek error"; - - /* - * Fall back to read it as plain file which hopefully is a static - * tclsh or wish binary with proper zipfs infrastructure built in. - */ - - Tcl_ResetResult(interp); - in = Tcl_OpenFileChannel(interp, imgName, "rb", 0644); - if (!in) { - memset(passBuf, 0, sizeof(passBuf)); - Tcl_DecrRefCount(list); - Tcl_Close(interp, out); - return TCL_ERROR; - } - i = Tcl_Seek(in, 0, SEEK_END); - if (i == TCL_IO_FAILURE) { - cperr: - memset(passBuf, 0, sizeof(passBuf)); - Tcl_DecrRefCount(list); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%s: %s", errMsg, Tcl_PosixError(interp))); - Tcl_Close(interp, out); - Tcl_Close(interp, in); - return TCL_ERROR; - } - Tcl_Seek(in, 0, SEEK_SET); - for (k = 0; k < i; k += m) { - m = i - k; - if (m > (int) sizeof(buf)) { - m = (int) sizeof(buf); - } - n = Tcl_Read(in, buf, m); - if (n == -1) { - errMsg = "read error"; - goto cperr; - } else if (n == 0) { - break; - } - m = Tcl_Write(out, buf, n); - if (m != n) { - errMsg = "write error"; - goto cperr; - } - } - Tcl_Close(interp, in); - } - len = strlen(passBuf); - if (len > 0) { - i = Tcl_Write(out, passBuf, len); - if (i != len) { - Tcl_DecrRefCount(list); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "write error: %s", Tcl_PosixError(interp))); - Tcl_Close(interp, out); - return TCL_ERROR; - } - } - memset(passBuf, 0, sizeof(passBuf)); - Tcl_Flush(out); - } - Tcl_InitHashTable(&fileHash, TCL_STRING_KEYS); - pos[0] = Tcl_Tell(out); - if (!isList && (objc > 3)) { - strip = TclGetString(objv[3]); - slen = strlen(strip); - } - for (i = 0; i < (size_t) lobjc; i += (isList ? 2 : 1)) { - const char *path, *name; - - path = TclGetString(lobjv[i]); - if (isList) { - name = TclGetString(lobjv[i + 1]); - } else { - name = path; - if (slen > 0) { - len = strlen(name); - if ((len <= slen) || (strncmp(strip, name, slen) != 0)) { - continue; - } - name += slen; - } - } - while (name[0] == '/') { - ++name; - } - if (name[0] == '\0') { - continue; - } - if (ZipAddFile(interp, path, name, out, pw, buf, sizeof(buf), - &fileHash) != TCL_OK) { - goto done; - } - } - pos[1] = Tcl_Tell(out); - count = 0; - for (i = 0; i < (size_t) lobjc; i += (isList ? 2 : 1)) { - const char *path, *name; - - path = TclGetString(lobjv[i]); - if (isList) { - name = TclGetString(lobjv[i + 1]); - } else { - name = path; - if (slen > 0) { - len = strlen(name); - if ((len <= slen) || (strncmp(strip, name, slen) != 0)) { - continue; - } - name += slen; - } - } - while (name[0] == '/') { - ++name; - } - if (name[0] == '\0') { - continue; - } - hPtr = Tcl_FindHashEntry(&fileHash, name); - if (!hPtr) { - continue; - } - z = Tcl_GetHashValue(hPtr); - len = strlen(z->name); - ZipWriteInt(buf + ZIP_CENTRAL_SIG_OFFS, ZIP_CENTRAL_HEADER_SIG); - ZipWriteShort(buf + ZIP_CENTRAL_VERSIONMADE_OFFS, ZIP_MIN_VERSION); - ZipWriteShort(buf + ZIP_CENTRAL_VERSION_OFFS, ZIP_MIN_VERSION); - ZipWriteShort(buf + ZIP_CENTRAL_FLAGS_OFFS, z->isEncrypted); - ZipWriteShort(buf + ZIP_CENTRAL_COMPMETH_OFFS, z->compressMethod); - ZipWriteShort(buf + ZIP_CENTRAL_MTIME_OFFS, ToDosTime(z->timestamp)); - ZipWriteShort(buf + ZIP_CENTRAL_MDATE_OFFS, ToDosDate(z->timestamp)); - ZipWriteInt(buf + ZIP_CENTRAL_CRC32_OFFS, z->crc32); - ZipWriteInt(buf + ZIP_CENTRAL_COMPLEN_OFFS, z->numCompressedBytes); - ZipWriteInt(buf + ZIP_CENTRAL_UNCOMPLEN_OFFS, z->numBytes); - ZipWriteShort(buf + ZIP_CENTRAL_PATHLEN_OFFS, len); - ZipWriteShort(buf + ZIP_CENTRAL_EXTRALEN_OFFS, 0); - ZipWriteShort(buf + ZIP_CENTRAL_FCOMMENTLEN_OFFS, 0); - ZipWriteShort(buf + ZIP_CENTRAL_DISKFILE_OFFS, 0); - ZipWriteShort(buf + ZIP_CENTRAL_IATTR_OFFS, 0); - ZipWriteInt(buf + ZIP_CENTRAL_EATTR_OFFS, 0); - ZipWriteInt(buf + ZIP_CENTRAL_LOCALHDR_OFFS, z->offset - pos[0]); - if ((Tcl_Write(out, buf, - ZIP_CENTRAL_HEADER_LEN) != ZIP_CENTRAL_HEADER_LEN) - || (Tcl_Write(out, z->name, len) != len)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "write error: %s", Tcl_PosixError(interp))); - goto done; - } - count++; - } - Tcl_Flush(out); - pos[2] = Tcl_Tell(out); - ZipWriteInt(buf + ZIP_CENTRAL_END_SIG_OFFS, ZIP_CENTRAL_END_SIG); - ZipWriteShort(buf + ZIP_CENTRAL_DISKNO_OFFS, 0); - ZipWriteShort(buf + ZIP_CENTRAL_DISKDIR_OFFS, 0); - ZipWriteShort(buf + ZIP_CENTRAL_ENTS_OFFS, count); - ZipWriteShort(buf + ZIP_CENTRAL_TOTALENTS_OFFS, count); - ZipWriteInt(buf + ZIP_CENTRAL_DIRSIZE_OFFS, pos[2] - pos[1]); - ZipWriteInt(buf + ZIP_CENTRAL_DIRSTART_OFFS, pos[1] - pos[0]); - ZipWriteShort(buf + ZIP_CENTRAL_COMMENTLEN_OFFS, 0); - if (Tcl_Write(out, buf, ZIP_CENTRAL_END_LEN) != ZIP_CENTRAL_END_LEN) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "write error: %s", Tcl_PosixError(interp))); - goto done; - } - Tcl_Flush(out); - ret = TCL_OK; - - done: - if (ret == TCL_OK) { - ret = Tcl_Close(interp, out); - } else { - Tcl_Close(interp, out); - } - Tcl_DecrRefCount(list); - for (hPtr = Tcl_FirstHashEntry(&fileHash, &search); hPtr; - hPtr = Tcl_NextHashEntry(&search)) { - z = Tcl_GetHashValue(hPtr); - Tcl_Free(z); - Tcl_DeleteHashEntry(hPtr); - } - Tcl_DeleteHashTable(&fileHash); - return ret; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSMkZipObjCmd, ZipFSLMkZipObjCmd -- - * - * These procedures are invoked to process the [zipfs mkzip] and [zipfs - * lmkzip] commands. See description of ZipFSMkZipOrImgCmd(). - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See description of ZipFSMkZipOrImgCmd(). - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSMkZipObjCmd( - void *clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - if (objc < 3 || objc > 5) { - Tcl_WrongNumArgs(interp, 1, objv, "outfile indir ?strip? ?password?"); - return TCL_ERROR; - } - if (Tcl_IsSafe(interp)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "operation not permitted in a safe interpreter", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "SAFE_INTERP", NULL); - return TCL_ERROR; - } - return ZipFSMkZipOrImgObjCmd(interp, 0, 0, objc, objv); -} - -static int -ZipFSLMkZipObjCmd( - void *clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - if (objc < 3 || objc > 4) { - Tcl_WrongNumArgs(interp, 1, objv, "outfile inlist ?password?"); - return TCL_ERROR; - } - if (Tcl_IsSafe(interp)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "operation not permitted in a safe interpreter", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "SAFE_INTERP", NULL); - return TCL_ERROR; - } - return ZipFSMkZipOrImgObjCmd(interp, 0, 1, objc, objv); -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSMkImgObjCmd, ZipFSLMkImgObjCmd -- - * - * These procedures are invoked to process the [zipfs mkimg] and [zipfs - * lmkimg] commands. See description of ZipFSMkZipOrImgCmd(). - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See description of ZipFSMkZipOrImgCmd(). - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSMkImgObjCmd( - void *clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - if (objc < 3 || objc > 6) { - Tcl_WrongNumArgs(interp, 1, objv, - "outfile indir ?strip? ?password? ?infile?"); - return TCL_ERROR; - } - if (Tcl_IsSafe(interp)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "operation not permitted in a safe interpreter", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "SAFE_INTERP", NULL); - return TCL_ERROR; - } - return ZipFSMkZipOrImgObjCmd(interp, 1, 0, objc, objv); -} - -static int -ZipFSLMkImgObjCmd( - void *clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - if (objc < 3 || objc > 5) { - Tcl_WrongNumArgs(interp, 1, objv, "outfile inlist ?password infile?"); - return TCL_ERROR; - } - if (Tcl_IsSafe(interp)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "operation not permitted in a safe interpreter", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "SAFE_INTERP", NULL); - return TCL_ERROR; - } - return ZipFSMkZipOrImgObjCmd(interp, 1, 1, objc, objv); -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSCanonicalObjCmd -- - * - * This procedure is invoked to process the [zipfs canonical] command. - * It returns the canonical name for a file within zipfs - * - * Results: - * Always TCL_OK provided the right number of arguments are supplied. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSCanonicalObjCmd( - void *clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - char *mntpoint = NULL; - char *filename = NULL; - char *result; - Tcl_DString dPath; - - if (objc < 2 || objc > 4) { - Tcl_WrongNumArgs(interp, 1, objv, "?mountpoint? filename ?inZipfs?"); - return TCL_ERROR; - } - Tcl_DStringInit(&dPath); - if (objc == 2) { - filename = TclGetString(objv[1]); - result = CanonicalPath("", filename, &dPath, 1); - } else if (objc == 3) { - mntpoint = TclGetString(objv[1]); - filename = TclGetString(objv[2]); - result = CanonicalPath(mntpoint, filename, &dPath, 1); - } else { - int zipfs = 0; - - if (Tcl_GetBooleanFromObj(interp, objv[3], &zipfs)) { - return TCL_ERROR; - } - mntpoint = TclGetString(objv[1]); - filename = TclGetString(objv[2]); - result = CanonicalPath(mntpoint, filename, &dPath, zipfs); - } - Tcl_SetObjResult(interp, Tcl_NewStringObj(result, -1)); - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSExistsObjCmd -- - * - * This procedure is invoked to process the [zipfs exists] command. It - * tests for the existence of a file in the ZIP filesystem and places a - * boolean into the interp's result. - * - * Results: - * Always TCL_OK provided the right number of arguments are supplied. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSExistsObjCmd( - void *clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - char *filename; - int exists; - Tcl_DString ds; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "filename"); - return TCL_ERROR; - } - - /* - * Prepend ZIPFS_VOLUME to filename, eliding the final / - */ - - filename = TclGetString(objv[1]); - Tcl_DStringInit(&ds); - Tcl_DStringAppend(&ds, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN - 1); - Tcl_DStringAppend(&ds, filename, -1); - filename = Tcl_DStringValue(&ds); - - ReadLock(); - exists = ZipFSLookup(filename) != NULL; - Unlock(); - - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(exists)); - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSInfoObjCmd -- - * - * This procedure is invoked to process the [zipfs info] command. On - * success, it returns a Tcl list made up of name of ZIP archive file, - * size uncompressed, size compressed, and archive offset of a file in - * the ZIP filesystem. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSInfoObjCmd( - void *clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - char *filename; - ZipEntry *z; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "filename"); - return TCL_ERROR; - } - filename = TclGetString(objv[1]); - ReadLock(); - z = ZipFSLookup(filename); - if (z) { - Tcl_Obj *result = Tcl_GetObjResult(interp); - - Tcl_ListObjAppendElement(interp, result, - Tcl_NewStringObj(z->zipFilePtr->name, -1)); - Tcl_ListObjAppendElement(interp, result, - Tcl_NewWideIntObj(z->numBytes)); - Tcl_ListObjAppendElement(interp, result, - Tcl_NewWideIntObj(z->numCompressedBytes)); - Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(z->offset)); - } - Unlock(); - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSListObjCmd -- - * - * This procedure is invoked to process the [zipfs list] command. On - * success, it returns a Tcl list of files of the ZIP filesystem which - * match a search pattern (glob or regexp). - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSListObjCmd( - void *clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - char *pattern = NULL; - Tcl_RegExp regexp = NULL; - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; - Tcl_Obj *result = Tcl_GetObjResult(interp); - - if (objc > 3) { - Tcl_WrongNumArgs(interp, 1, objv, "?(-glob|-regexp)? ?pattern?"); - return TCL_ERROR; - } - if (objc == 3) { - size_t n; - char *what = TclGetStringFromObj(objv[1], &n); - - if ((n >= 2) && (strncmp(what, "-glob", n) == 0)) { - pattern = TclGetString(objv[2]); - } else if ((n >= 2) && (strncmp(what, "-regexp", n) == 0)) { - regexp = Tcl_RegExpCompile(interp, TclGetString(objv[2])); - if (!regexp) { - return TCL_ERROR; - } - } else { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unknown option \"%s\"", what)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_OPT", NULL); - return TCL_ERROR; - } - } else if (objc == 2) { - pattern = TclGetString(objv[1]); - } - ReadLock(); - if (pattern) { - for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - ZipEntry *z = Tcl_GetHashValue(hPtr); - - if (Tcl_StringMatch(z->name, pattern)) { - Tcl_ListObjAppendElement(interp, result, - Tcl_NewStringObj(z->name, -1)); - } - } - } else if (regexp) { - for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); - hPtr; hPtr = Tcl_NextHashEntry(&search)) { - ZipEntry *z = Tcl_GetHashValue(hPtr); - - if (Tcl_RegExpExec(interp, regexp, z->name, z->name)) { - Tcl_ListObjAppendElement(interp, result, - Tcl_NewStringObj(z->name, -1)); - } - } - } else { - for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); - hPtr; hPtr = Tcl_NextHashEntry(&search)) { - ZipEntry *z = Tcl_GetHashValue(hPtr); - - Tcl_ListObjAppendElement(interp, result, - Tcl_NewStringObj(z->name, -1)); - } - } - Unlock(); - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * TclZipfs_TclLibrary -- - * - * This procedure gets (and possibly finds) the root that Tcl's library - * files are mounted under. - * - * Results: - * A Tcl object holding the location (with zero refcount), or NULL if no - * Tcl library can be found. - * - * Side effects: - * May initialise the cache of where such library files are to be found. - * This cache is never cleared. - * - *------------------------------------------------------------------------- - */ - -#ifdef _WIN32 -#define LIBRARY_SIZE 64 -#endif /* _WIN32 */ - -Tcl_Obj * -TclZipfs_TclLibrary(void) -{ - Tcl_Obj *vfsInitScript; - int found; -#ifdef _WIN32 - HMODULE hModule; - WCHAR wName[MAX_PATH + LIBRARY_SIZE]; - char dllName[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX]; -#endif /* _WIN32 */ - - /* - * Use the cached value if that has been set; we don't want to repeat the - * searching and mounting. - */ - - if (zipfs_literal_tcl_library) { - return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); - } - - /* - * Look for the library file system within the executable. - */ - - vfsInitScript = Tcl_NewStringObj(ZIPFS_APP_MOUNT "/tcl_library/init.tcl", - -1); - Tcl_IncrRefCount(vfsInitScript); - found = Tcl_FSAccess(vfsInitScript, F_OK); - Tcl_DecrRefCount(vfsInitScript); - if (found == TCL_OK) { - zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library"; - return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); - } - - /* - * Look for the library file system within the DLL/shared library. Note - * that we must mount the zip file and dll before releasing to search. - */ - -#if defined(_WIN32) - hModule = TclWinGetTclInstance(); - GetModuleFileNameW(hModule, wName, MAX_PATH); - WideCharToMultiByte(CP_UTF8, 0, wName, -1, dllName, sizeof(dllName), NULL, NULL); - - if (ZipfsAppHookFindTclInit(dllName) == TCL_OK) { - return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); - } -#elif /* !_WIN32 && */ defined(CFG_RUNTIME_DLLFILE) - if (ZipfsAppHookFindTclInit( - CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_DLLFILE) == TCL_OK) { - return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); - } -#endif /* _WIN32 || CFG_RUNTIME_DLLFILE */ - - /* - * If we're configured to know about a ZIP archive we should use, do that. - */ - -#ifdef CFG_RUNTIME_ZIPFILE - if (ZipfsAppHookFindTclInit( - CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_ZIPFILE) == TCL_OK) { - return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); - } - if (ZipfsAppHookFindTclInit( - CFG_RUNTIME_SCRDIR "/" CFG_RUNTIME_ZIPFILE) == TCL_OK) { - return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); - } - if (ZipfsAppHookFindTclInit(CFG_RUNTIME_ZIPFILE) == TCL_OK) { - return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); - } -#endif /* CFG_RUNTIME_ZIPFILE */ - - /* - * If anything set the cache (but subsequently failed) go with that - * anyway. - */ - - if (zipfs_literal_tcl_library) { - return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); - } - return NULL; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSTclLibraryObjCmd -- - * - * This procedure is invoked to process the - * [::tcl::zipfs::tcl_library_init] command, usually called during the - * execution of Tcl's interpreter startup. It returns the root that Tcl's - * library files are mounted under. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * May initialise the cache of where such library files are to be found. - * This cache is never cleared. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSTclLibraryObjCmd( - void *clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - if (!Tcl_IsSafe(interp)) { - Tcl_Obj *pResult = TclZipfs_TclLibrary(); - - if (!pResult) { - pResult = Tcl_NewObj(); - } - Tcl_SetObjResult(interp, pResult); - } - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * ZipChannelClose -- - * - * This function is called to close a channel. - * - * Results: - * Always TCL_OK. - * - * Side effects: - * Resources are free'd. - * - *------------------------------------------------------------------------- - */ - -static int -ZipChannelClose( - void *instanceData, - Tcl_Interp *interp) /* Current interpreter. */ -{ - ZipChannel *info = instanceData; - - if (info->iscompr && info->ubuf) { - Tcl_Free(info->ubuf); - info->ubuf = NULL; - } - if (info->isEncrypted) { - info->isEncrypted = 0; - memset(info->keys, 0, sizeof(info->keys)); - } - if (info->isWriting) { - ZipEntry *z = info->zipEntryPtr; - unsigned char *newdata = Tcl_AttemptRealloc(info->ubuf, info->numRead); - - if (newdata) { - if (z->data) { - Tcl_Free(z->data); - } - z->data = newdata; - z->numBytes = z->numCompressedBytes = info->numBytes; - z->compressMethod = ZIP_COMPMETH_STORED; - z->timestamp = time(NULL); - z->isDirectory = 0; - z->isEncrypted = 0; - z->offset = 0; - z->crc32 = 0; - } else { - Tcl_Free(info->ubuf); - } - } - WriteLock(); - info->zipFilePtr->numOpen--; - Unlock(); - Tcl_Free(info); - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * ZipChannelRead -- - * - * This function is called to read data from channel. - * - * Results: - * Number of bytes read or -1 on error with error number set. - * - * Side effects: - * Data is read and file pointer is advanced. - * - *------------------------------------------------------------------------- - */ - -static int -ZipChannelRead( - void *instanceData, - char *buf, - int toRead, - int *errloc) -{ - ZipChannel *info = (ZipChannel *) instanceData; - unsigned long nextpos; - - if (info->isDirectory < 0) { - /* - * Special case: when executable combined with ZIP archive file read - * data in front of ZIP, i.e. the executable itself. - */ - - nextpos = info->numRead + toRead; - if (nextpos > info->zipFilePtr->baseOffset) { - toRead = info->zipFilePtr->baseOffset - info->numRead; - nextpos = info->zipFilePtr->baseOffset; - } - if (toRead == 0) { - return 0; - } - memcpy(buf, info->zipFilePtr->data, toRead); - info->numRead = nextpos; - *errloc = 0; - return toRead; - } - if (info->isDirectory) { - *errloc = EISDIR; - return -1; - } - nextpos = info->numRead + toRead; - if (nextpos > info->numBytes) { - toRead = info->numBytes - info->numRead; - nextpos = info->numBytes; - } - if (toRead == 0) { - return 0; - } - if (info->isEncrypted) { - int i; - - for (i = 0; i < toRead; i++) { - int ch = info->ubuf[i + info->numRead]; - - buf[i] = zdecode(info->keys, crc32tab, ch); - } - } else { - memcpy(buf, info->ubuf + info->numRead, toRead); - } - info->numRead = nextpos; - *errloc = 0; - return toRead; -} - -/* - *------------------------------------------------------------------------- - * - * ZipChannelWrite -- - * - * This function is called to write data into channel. - * - * Results: - * Number of bytes written or -1 on error with error number set. - * - * Side effects: - * Data is written and file pointer is advanced. - * - *------------------------------------------------------------------------- - */ - -static int -ZipChannelWrite( - void *instanceData, - const char *buf, - int toWrite, - int *errloc) -{ - ZipChannel *info = (ZipChannel *) instanceData; - unsigned long nextpos; - - if (!info->isWriting) { - *errloc = EINVAL; - return -1; - } - nextpos = info->numRead + toWrite; - if (nextpos > info->maxWrite) { - toWrite = info->maxWrite - info->numRead; - nextpos = info->maxWrite; - } - if (toWrite == 0) { - return 0; - } - memcpy(info->ubuf + info->numRead, buf, toWrite); - info->numRead = nextpos; - if (info->numRead > info->numBytes) { - info->numBytes = info->numRead; - } - *errloc = 0; - return toWrite; -} - -/* - *------------------------------------------------------------------------- - * - * ZipChannelSeek -- - * - * This function is called to position file pointer of channel. - * - * Results: - * New file position or -1 on error with error number set. - * - * Side effects: - * File pointer is repositioned according to offset and mode. - * - *------------------------------------------------------------------------- - */ - -static int -ZipChannelSeek( - void *instanceData, - long offset, - int mode, - int *errloc) -{ - ZipChannel *info = (ZipChannel *) instanceData; - unsigned long end; - - if (!info->isWriting && (info->isDirectory < 0)) { - /* - * Special case: when executable combined with ZIP archive file, seek - * within front of ZIP, i.e. the executable itself. - */ - end = info->zipFilePtr->baseOffset; - } else if (info->isDirectory) { - *errloc = EINVAL; - return -1; - } else { - end = info->numBytes; - } - switch (mode) { - case SEEK_CUR: - offset += info->numRead; - break; - case SEEK_END: - offset += end; - break; - case SEEK_SET: - break; - default: - *errloc = EINVAL; - return -1; - } - if (offset < 0) { - *errloc = EINVAL; - return -1; - } - if (info->isWriting) { - if ((unsigned long) offset > info->maxWrite) { - *errloc = EINVAL; - return -1; - } - if ((unsigned long) offset > info->numBytes) { - info->numBytes = offset; - } - } else if ((unsigned long) offset > end) { - *errloc = EINVAL; - return -1; - } - info->numRead = (unsigned long) offset; - return info->numRead; -} - -/* - *------------------------------------------------------------------------- - * - * ZipChannelWatchChannel -- - * - * This function is called for event notifications on channel. Does - * nothing. - * - * Results: - * None. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static void -ZipChannelWatchChannel( - void *instanceData, - int mask) -{ - return; -} - -/* - *------------------------------------------------------------------------- - * - * ZipChannelGetFile -- - * - * This function is called to retrieve OS handle for channel. - * - * Results: - * Always TCL_ERROR since there's never an OS handle for a file within a - * ZIP archive. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -ZipChannelGetFile( - void *instanceData, - int direction, - void **handlePtr) -{ - return TCL_ERROR; -} - -/* - *------------------------------------------------------------------------- - * - * ZipChannelOpen -- - * - * This function opens a Tcl_Channel on a file from a mounted ZIP archive - * according to given open mode. - * - * Results: - * Tcl_Channel on success, or NULL on error. - * - * Side effects: - * Memory is allocated, the file from the ZIP archive is uncompressed. - * - *------------------------------------------------------------------------- - */ - -static Tcl_Channel -ZipChannelOpen( - Tcl_Interp *interp, /* Current interpreter. */ - char *filename, - int mode, - int permissions) -{ - ZipEntry *z; - ZipChannel *info; - int i, ch, trunc, wr, flags = 0; - char cname[128]; - - if ((mode & O_APPEND) - || ((ZipFS.wrmax <= 0) && (mode & (O_WRONLY | O_RDWR)))) { - if (interp) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("unsupported open mode", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_MODE", NULL); - } - return NULL; - } - WriteLock(); - z = ZipFSLookup(filename); - if (!z) { - Tcl_SetErrno(ENOENT); - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "file not found \"%s\": %s", filename, - Tcl_PosixError(interp))); - } - goto error; - } - trunc = (mode & O_TRUNC) != 0; - wr = (mode & (O_WRONLY | O_RDWR)) != 0; - if ((z->compressMethod != ZIP_COMPMETH_STORED) - && (z->compressMethod != ZIP_COMPMETH_DEFLATED)) { - ZIPFS_ERROR(interp, "unsupported compression method"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "COMP_METHOD", NULL); - } - goto error; - } - if (wr && z->isDirectory) { - ZIPFS_ERROR(interp, "unsupported file type"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "FILE_TYPE", NULL); - } - goto error; - } - if (!trunc) { - flags |= TCL_READABLE; - if (z->isEncrypted && (z->zipFilePtr->passBuf[0] == 0)) { - ZIPFS_ERROR(interp, "decryption failed"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "DECRYPT", NULL); - } - goto error; - } else if (wr && !z->data && (z->numBytes > ZipFS.wrmax)) { - ZIPFS_ERROR(interp, "file too large"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "FILE_SIZE", NULL); - } - goto error; - } - } else { - flags = TCL_WRITABLE; - } - info = Tcl_AttemptAlloc(sizeof(ZipChannel)); - if (!info) { - ZIPFS_ERROR(interp, "out of memory"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); - } - goto error; - } - info->zipFilePtr = z->zipFilePtr; - info->zipEntryPtr = z; - info->numRead = 0; - if (wr) { - flags |= TCL_WRITABLE; - info->isWriting = 1; - info->isDirectory = 0; - info->maxWrite = ZipFS.wrmax; - info->iscompr = 0; - info->isEncrypted = 0; - info->ubuf = Tcl_AttemptAlloc(info->maxWrite); - if (!info->ubuf) { - merror0: - if (info->ubuf) { - Tcl_Free(info->ubuf); - } - Tcl_Free(info); - ZIPFS_ERROR(interp, "out of memory"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); - } - goto error; - } - memset(info->ubuf, 0, info->maxWrite); - if (trunc) { - info->numBytes = 0; - } else if (z->data) { - size_t j = z->numBytes; - - if (j > info->maxWrite) { - j = info->maxWrite; - } - memcpy(info->ubuf, z->data, j); - info->numBytes = j; - } else { - unsigned char *zbuf = z->zipFilePtr->data + z->offset; - - if (z->isEncrypted) { - int len = z->zipFilePtr->passBuf[0] & 0xFF; - char passBuf[260]; - - for (i = 0; i < len; i++) { - ch = z->zipFilePtr->passBuf[len - i]; - passBuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; - } - passBuf[i] = '\0'; - init_keys(passBuf, info->keys, crc32tab); - memset(passBuf, 0, sizeof(passBuf)); - for (i = 0; i < 12; i++) { - ch = info->ubuf[i]; - zdecode(info->keys, crc32tab, ch); - } - zbuf += i; - } - if (z->compressMethod == ZIP_COMPMETH_DEFLATED) { - z_stream stream; - int err; - unsigned char *cbuf = NULL; - - memset(&stream, 0, sizeof(z_stream)); - stream.zalloc = Z_NULL; - stream.zfree = Z_NULL; - stream.opaque = Z_NULL; - stream.avail_in = z->numCompressedBytes; - if (z->isEncrypted) { - size_t j; - - stream.avail_in -= 12; - cbuf = Tcl_AttemptAlloc(stream.avail_in); - if (!cbuf) { - goto merror0; - } - for (j = 0; j < stream.avail_in; j++) { - ch = info->ubuf[j]; - cbuf[j] = zdecode(info->keys, crc32tab, ch); - } - stream.next_in = cbuf; - } else { - stream.next_in = zbuf; - } - stream.next_out = info->ubuf; - stream.avail_out = info->maxWrite; - if (inflateInit2(&stream, -15) != Z_OK) { - goto cerror0; - } - err = inflate(&stream, Z_SYNC_FLUSH); - inflateEnd(&stream); - if ((err == Z_STREAM_END) - || ((err == Z_OK) && (stream.avail_in == 0))) { - if (cbuf) { - memset(info->keys, 0, sizeof(info->keys)); - Tcl_Free(cbuf); - } - goto wrapchan; - } - cerror0: - if (cbuf) { - memset(info->keys, 0, sizeof(info->keys)); - Tcl_Free(cbuf); - } - if (info->ubuf) { - Tcl_Free(info->ubuf); - } - Tcl_Free(info); - ZIPFS_ERROR(interp, "decompression error"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "CORRUPT", NULL); - } - goto error; - } else if (z->isEncrypted) { - for (i = 0; i < z->numBytes - 12; i++) { - ch = zbuf[i]; - info->ubuf[i] = zdecode(info->keys, crc32tab, ch); - } - } else { - memcpy(info->ubuf, zbuf, z->numBytes); - } - memset(info->keys, 0, sizeof(info->keys)); - goto wrapchan; - } - } else if (z->data) { - flags |= TCL_READABLE; - info->isWriting = 0; - info->iscompr = 0; - info->isDirectory = 0; - info->isEncrypted = 0; - info->numBytes = z->numBytes; - info->maxWrite = 0; - info->ubuf = z->data; - } else { - flags |= TCL_READABLE; - info->isWriting = 0; - info->iscompr = (z->compressMethod == ZIP_COMPMETH_DEFLATED); - info->ubuf = z->zipFilePtr->data + z->offset; - info->isDirectory = z->isDirectory; - info->isEncrypted = z->isEncrypted; - info->numBytes = z->numBytes; - info->maxWrite = 0; - if (info->isEncrypted) { - int len = z->zipFilePtr->passBuf[0] & 0xFF; - char passBuf[260]; - - for (i = 0; i < len; i++) { - ch = z->zipFilePtr->passBuf[len - i]; - passBuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; - } - passBuf[i] = '\0'; - init_keys(passBuf, info->keys, crc32tab); - memset(passBuf, 0, sizeof(passBuf)); - for (i = 0; i < 12; i++) { - ch = info->ubuf[i]; - zdecode(info->keys, crc32tab, ch); - } - info->ubuf += i; - } - if (info->iscompr) { - z_stream stream; - int err; - unsigned char *ubuf = NULL; - size_t j; - - memset(&stream, 0, sizeof(z_stream)); - stream.zalloc = Z_NULL; - stream.zfree = Z_NULL; - stream.opaque = Z_NULL; - stream.avail_in = z->numCompressedBytes; - if (info->isEncrypted) { - stream.avail_in -= 12; - ubuf = Tcl_AttemptAlloc(stream.avail_in); - if (!ubuf) { - info->ubuf = NULL; - goto merror; - } - for (j = 0; j < stream.avail_in; j++) { - ch = info->ubuf[j]; - ubuf[j] = zdecode(info->keys, crc32tab, ch); - } - stream.next_in = ubuf; - } else { - stream.next_in = info->ubuf; - } - stream.next_out = info->ubuf = Tcl_AttemptAlloc(info->numBytes); - if (!info->ubuf) { - merror: - if (ubuf) { - info->isEncrypted = 0; - memset(info->keys, 0, sizeof(info->keys)); - Tcl_Free(ubuf); - } - Tcl_Free(info); - if (interp) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("out of memory", -1)); - Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); - } - goto error; - } - stream.avail_out = info->numBytes; - if (inflateInit2(&stream, -15) != Z_OK) { - goto cerror; - } - err = inflate(&stream, Z_SYNC_FLUSH); - inflateEnd(&stream); - if ((err == Z_STREAM_END) - || ((err == Z_OK) && (stream.avail_in == 0))) { - if (ubuf) { - info->isEncrypted = 0; - memset(info->keys, 0, sizeof(info->keys)); - Tcl_Free(ubuf); - } - goto wrapchan; - } - cerror: - if (ubuf) { - info->isEncrypted = 0; - memset(info->keys, 0, sizeof(info->keys)); - Tcl_Free(ubuf); - } - if (info->ubuf) { - Tcl_Free(info->ubuf); - } - Tcl_Free(info); - ZIPFS_ERROR(interp, "decompression error"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "CORRUPT", NULL); - } - goto error; - } else if (info->isEncrypted) { - unsigned char *ubuf = NULL; - size_t j, len; - - /* - * Decode encrypted but uncompressed file, since we support - * Tcl_Seek() on it, and it can be randomly accessed later. - */ - - len = z->numCompressedBytes - 12; - ubuf = (unsigned char *) Tcl_AttemptAlloc(len); - if (ubuf == NULL) { - Tcl_Free((char *) info); - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("out of memory", -1)); - } - goto error; - } - for (j = 0; j < len; j++) { - ch = info->ubuf[j]; - ubuf[j] = zdecode(info->keys, crc32tab, ch); - } - info->ubuf = ubuf; - info->isEncrypted = 0; - } - } - - wrapchan: - sprintf(cname, "zipfs_%" TCL_LL_MODIFIER "x_%d", z->offset, - ZipFS.idCount++); - z->zipFilePtr->numOpen++; - Unlock(); - return Tcl_CreateChannel(&ZipChannelType, cname, info, flags); - - error: - Unlock(); - return NULL; -} - -/* - *------------------------------------------------------------------------- - * - * ZipEntryStat -- - * - * This function implements the ZIP filesystem specific version of the - * library version of stat. - * - * Results: - * See stat documentation. - * - * Side effects: - * See stat documentation. - * - *------------------------------------------------------------------------- - */ - -static int -ZipEntryStat( - char *path, - Tcl_StatBuf *buf) -{ - ZipEntry *z; - int ret = -1; - - ReadLock(); - z = ZipFSLookup(path); - if (z) { - memset(buf, 0, sizeof(Tcl_StatBuf)); - if (z->isDirectory) { - buf->st_mode = S_IFDIR | 0555; - } else { - buf->st_mode = S_IFREG | 0555; - } - buf->st_size = z->numBytes; - buf->st_mtime = z->timestamp; - buf->st_ctime = z->timestamp; - buf->st_atime = z->timestamp; - ret = 0; - } - Unlock(); - return ret; -} - -/* - *------------------------------------------------------------------------- - * - * ZipEntryAccess -- - * - * This function implements the ZIP filesystem specific version of the - * library version of access. - * - * Results: - * See access documentation. - * - * Side effects: - * See access documentation. - * - *------------------------------------------------------------------------- - */ - -static int -ZipEntryAccess( - char *path, - int mode) -{ - ZipEntry *z; - - if (mode & 3) { - return -1; - } - ReadLock(); - z = ZipFSLookup(path); - Unlock(); - return (z ? 0 : -1); -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSOpenFileChannelProc -- - * - * Results: - * - * Side effects: - * - *------------------------------------------------------------------------- - */ - -static Tcl_Channel -ZipFSOpenFileChannelProc( - Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Obj *pathPtr, - int mode, - int permissions) -{ - pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); - if (!pathPtr) { - return NULL; - } - return ZipChannelOpen(interp, TclGetString(pathPtr), mode, - permissions); -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSStatProc -- - * - * This function implements the ZIP filesystem specific version of the - * library version of stat. - * - * Results: - * See stat documentation. - * - * Side effects: - * See stat documentation. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSStatProc( - Tcl_Obj *pathPtr, - Tcl_StatBuf *buf) -{ - - pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); - if (!pathPtr) { - return -1; - } - return ZipEntryStat(TclGetString(pathPtr), buf); -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSAccessProc -- - * - * This function implements the ZIP filesystem specific version of the - * library version of access. - * - * Results: - * See access documentation. - * - * Side effects: - * See access documentation. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSAccessProc( - Tcl_Obj *pathPtr, - int mode) -{ - pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); - if (!pathPtr) { - return -1; - } - return ZipEntryAccess(TclGetString(pathPtr), mode); -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSFilesystemSeparatorProc -- - * - * This function returns the separator to be used for a given path. The - * object returned should have a refCount of zero - * - * Results: - * A Tcl object, with a refCount of zero. If the caller needs to retain a - * reference to the object, it should call Tcl_IncrRefCount, and should - * otherwise free the object. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static Tcl_Obj * -ZipFSFilesystemSeparatorProc( - Tcl_Obj *pathPtr) -{ - return Tcl_NewStringObj("/", -1); -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSMatchInDirectoryProc -- - * - * This routine is used by the globbing code to search a directory for - * all files which match a given pattern. - * - * Results: - * The return value is a standard Tcl result indicating whether an error - * occurred in globbing. Errors are left in interp, good results are - * lappend'ed to resultPtr (which must be a valid object). - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSMatchInDirectoryProc( - Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Obj *result, - Tcl_Obj *pathPtr, - const char *pattern, - Tcl_GlobTypeData *types) -{ - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; - Tcl_Obj *normPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); - int scnt, l, dirOnly = -1, strip = 0; - size_t len, prefixLen; - char *pat, *prefix, *path; - Tcl_DString dsPref; - - if (!normPathPtr) { - return -1; - } - if (types) { - dirOnly = (types->type & TCL_GLOB_TYPE_DIR) == TCL_GLOB_TYPE_DIR; - } - - /* - * The prefix that gets prepended to results. - */ - - prefix = TclGetStringFromObj(pathPtr, &prefixLen); - - /* - * The (normalized) path we're searching. - */ - - path = TclGetStringFromObj(normPathPtr, &len); - - Tcl_DStringInit(&dsPref); - Tcl_DStringAppend(&dsPref, prefix, prefixLen); - - if (strcmp(prefix, path) == 0) { - prefix = NULL; - } else { - strip = len + 1; - } - if (prefix) { - Tcl_DStringAppend(&dsPref, "/", 1); - prefixLen++; - prefix = Tcl_DStringValue(&dsPref); - } - ReadLock(); - if (types && (types->type == TCL_GLOB_TYPE_MOUNT)) { - l = CountSlashes(path); - if (path[len - 1] == '/') { - len--; - } else { - l++; - } - if (!pattern || (pattern[0] == '\0')) { - pattern = "*"; - } - for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr; - hPtr = Tcl_NextHashEntry(&search)) { - ZipFile *zf = Tcl_GetHashValue(hPtr); - - if (zf->mountPointLen == 0) { - ZipEntry *z; - - for (z = zf->topEnts; z; z = z->tnext) { - size_t lenz = strlen(z->name); - - if ((lenz > len + 1) && (strncmp(z->name, path, len) == 0) - && (z->name[len] == '/') - && (CountSlashes(z->name) == l) - && Tcl_StringCaseMatch(z->name + len + 1, pattern, - 0)) { - if (prefix) { - Tcl_DStringAppend(&dsPref, z->name, lenz); - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(Tcl_DStringValue(&dsPref), - Tcl_DStringLength(&dsPref))); - Tcl_DStringSetLength(&dsPref, prefixLen); - } else { - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(z->name, lenz)); - } - } - } - } else if ((zf->mountPointLen > len + 1) - && (strncmp(zf->mountPoint, path, len) == 0) - && (zf->mountPoint[len] == '/') - && (CountSlashes(zf->mountPoint) == l) - && Tcl_StringCaseMatch(zf->mountPoint + len + 1, - pattern, 0)) { - if (prefix) { - Tcl_DStringAppend(&dsPref, zf->mountPoint, - zf->mountPointLen); - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(Tcl_DStringValue(&dsPref), - Tcl_DStringLength(&dsPref))); - Tcl_DStringSetLength(&dsPref, prefixLen); - } else { - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(zf->mountPoint, - zf->mountPointLen)); - } - } - } - goto end; - } - - if (!pattern || (pattern[0] == '\0')) { - hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, path); - if (hPtr) { - ZipEntry *z = Tcl_GetHashValue(hPtr); - - if ((dirOnly < 0) || (!dirOnly && !z->isDirectory) - || (dirOnly && z->isDirectory)) { - if (prefix) { - Tcl_DStringAppend(&dsPref, z->name, -1); - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(Tcl_DStringValue(&dsPref), - Tcl_DStringLength(&dsPref))); - Tcl_DStringSetLength(&dsPref, prefixLen); - } else { - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(z->name, -1)); - } - } - } - goto end; - } - - l = strlen(pattern); - pat = Tcl_Alloc(len + l + 2); - memcpy(pat, path, len); - while ((len > 1) && (pat[len - 1] == '/')) { - --len; - } - if ((len > 1) || (pat[0] != '/')) { - pat[len] = '/'; - ++len; - } - memcpy(pat + len, pattern, l + 1); - scnt = CountSlashes(pat); - for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); - hPtr; hPtr = Tcl_NextHashEntry(&search)) { - ZipEntry *z = Tcl_GetHashValue(hPtr); - - if ((dirOnly >= 0) && ((dirOnly && !z->isDirectory) - || (!dirOnly && z->isDirectory))) { - continue; - } - if ((z->depth == scnt) && Tcl_StringCaseMatch(z->name, pat, 0)) { - if (prefix) { - Tcl_DStringAppend(&dsPref, z->name + strip, -1); - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(Tcl_DStringValue(&dsPref), - Tcl_DStringLength(&dsPref))); - Tcl_DStringSetLength(&dsPref, prefixLen); - } else { - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(z->name + strip, -1)); - } - } - } - Tcl_Free(pat); - - end: - Unlock(); - Tcl_DStringFree(&dsPref); - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSPathInFilesystemProc -- - * - * This function determines if the given path object is in the ZIP - * filesystem. - * - * Results: - * TCL_OK when the path object is in the ZIP filesystem, -1 otherwise. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSPathInFilesystemProc( - Tcl_Obj *pathPtr, - void **clientDataPtr) -{ - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; - int ret = -1; - size_t len; - char *path; - - pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); - if (!pathPtr) { - return -1; - } - - path = TclGetStringFromObj(pathPtr, &len); - if (strncmp(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) != 0) { - return -1; - } - - ReadLock(); - hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, path); - if (hPtr) { - ret = TCL_OK; - goto endloop; - } - - for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr; - hPtr = Tcl_NextHashEntry(&search)) { - ZipFile *zf = Tcl_GetHashValue(hPtr); - - if (zf->mountPointLen == 0) { - ZipEntry *z; - - for (z = zf->topEnts; z != NULL; z = z->tnext) { - size_t lenz = strlen(z->name); - - if ((len >= lenz) && (strncmp(path, z->name, lenz) == 0)) { - ret = TCL_OK; - goto endloop; - } - } - } else if ((len >= zf->mountPointLen) && - (strncmp(path, zf->mountPoint, zf->mountPointLen) == 0)) { - ret = TCL_OK; - break; - } - } - - endloop: - Unlock(); - return ret; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSListVolumesProc -- - * - * Lists the currently mounted ZIP filesystem volumes. - * - * Results: - * The list of volumes. - * - * Side effects: - * None - * - *------------------------------------------------------------------------- - */ - -static Tcl_Obj * -ZipFSListVolumesProc(void) -{ - return Tcl_NewStringObj(ZIPFS_VOLUME, -1); -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSFileAttrStringsProc -- - * - * This function implements the ZIP filesystem dependent 'file - * attributes' subcommand, for listing the set of possible attribute - * strings. - * - * Results: - * An array of strings - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static const char *const * -ZipFSFileAttrStringsProc( - Tcl_Obj *pathPtr, - Tcl_Obj **objPtrRef) -{ - static const char *const attrs[] = { - "-uncompsize", - "-compsize", - "-offset", - "-mount", - "-archive", - "-permissions", - NULL, - }; - return attrs; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSFileAttrsGetProc -- - * - * This function implements the ZIP filesystem specific 'file attributes' - * subcommand, for 'get' operations. - * - * Results: - * Standard Tcl return code. The object placed in objPtrRef (if TCL_OK - * was returned) is likely to have a refCount of zero. Either way we must - * either store it somewhere (e.g. the Tcl result), or Incr/Decr its - * refCount to ensure it is properly freed. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSFileAttrsGetProc( - Tcl_Interp *interp, /* Current interpreter. */ - int index, - Tcl_Obj *pathPtr, - Tcl_Obj **objPtrRef) -{ - int ret = TCL_OK; - char *path; - ZipEntry *z; - - pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); - if (!pathPtr) { - return -1; - } - path = TclGetString(pathPtr); - ReadLock(); - z = ZipFSLookup(path); - if (!z) { - Tcl_SetErrno(ENOENT); - ZIPFS_POSIX_ERROR(interp, "file not found"); - ret = TCL_ERROR; - goto done; - } - switch (index) { - case 0: - *objPtrRef = Tcl_NewWideIntObj(z->numBytes); - break; - case 1: - *objPtrRef = Tcl_NewWideIntObj(z->numCompressedBytes); - break; - case 2: - *objPtrRef = Tcl_NewWideIntObj(z->offset); - break; - case 3: - *objPtrRef = Tcl_NewStringObj(z->zipFilePtr->mountPoint, - z->zipFilePtr->mountPointLen); - break; - case 4: - *objPtrRef = Tcl_NewStringObj(z->zipFilePtr->name, -1); - break; - case 5: - *objPtrRef = Tcl_NewStringObj("0o555", -1); - break; - default: - ZIPFS_ERROR(interp, "unknown attribute"); - ret = TCL_ERROR; - } - - done: - Unlock(); - return ret; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSFileAttrsSetProc -- - * - * This function implements the ZIP filesystem specific 'file attributes' - * subcommand, for 'set' operations. - * - * Results: - * Standard Tcl return code. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSFileAttrsSetProc( - Tcl_Interp *interp, /* Current interpreter. */ - int index, - Tcl_Obj *pathPtr, - Tcl_Obj *objPtr) -{ - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("unsupported operation", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "UNSUPPORTED_OP", NULL); - } - return TCL_ERROR; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSFilesystemPathTypeProc -- - * - * Results: - * - * Side effects: - * - *------------------------------------------------------------------------- - */ - -static Tcl_Obj * -ZipFSFilesystemPathTypeProc( - Tcl_Obj *pathPtr) -{ - return Tcl_NewStringObj("zip", -1); -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSLoadFile -- - * - * This functions deals with loading native object code. If the given - * path object refers to a file within the ZIP filesystem, an approriate - * error code is returned to delegate loading to the caller (by copying - * the file to temp store and loading from there). As fallback when the - * file refers to the ZIP file system but is not present, it is looked up - * relative to the executable and loaded from there when available. - * - * Results: - * TCL_OK on success, TCL_ERROR otherwise with error message left. - * - * Side effects: - * Loads native code into the process address space. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSLoadFile( - Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Obj *path, - Tcl_LoadHandle *loadHandle, - Tcl_FSUnloadFileProc **unloadProcPtr, - int flags) -{ - Tcl_FSLoadFileProc2 *loadFileProc; -#ifdef ANDROID - /* - * Force loadFileProc to native implementation since the package manager - * already extracted the shared libraries from the APK at install time. - */ - - loadFileProc = (Tcl_FSLoadFileProc2 *) tclNativeFilesystem.loadFileProc; - if (loadFileProc) { - return loadFileProc(interp, path, loadHandle, unloadProcPtr, flags); - } - Tcl_SetErrno(ENOENT); - ZIPFS_ERROR(interp, Tcl_PosixError(interp)); - return TCL_ERROR; -#else /* !ANDROID */ - Tcl_Obj *altPath = NULL; - int ret = TCL_ERROR; - Tcl_Obj *objs[2] = { NULL, NULL }; - - if (Tcl_FSAccess(path, R_OK) == 0) { - /* - * EXDEV should trigger loading by copying to temp store. - */ - - Tcl_SetErrno(EXDEV); - ZIPFS_ERROR(interp, Tcl_PosixError(interp)); - return ret; - } - - objs[1] = TclPathPart(interp, path, TCL_PATH_DIRNAME); - if (objs[1] && (ZipFSAccessProc(objs[1], R_OK) == 0)) { - const char *execName = Tcl_GetNameOfExecutable(); - - /* - * Shared object is not in ZIP but its path prefix is, thus try to - * load from directory where the executable came from. - */ - - TclDecrRefCount(objs[1]); - objs[1] = TclPathPart(interp, path, TCL_PATH_TAIL); - - /* - * Get directory name of executable manually to deal with cases where - * [file dirname [info nameofexecutable]] is equal to [info - * nameofexecutable] due to VFS effects. - */ - - if (execName) { - const char *p = strrchr(execName, '/'); - - if (p > execName + 1) { - --p; - objs[0] = Tcl_NewStringObj(execName, p - execName); - } - } - if (!objs[0]) { - objs[0] = TclPathPart(interp, TclGetObjNameOfExecutable(), - TCL_PATH_DIRNAME); - } - if (objs[0]) { - altPath = TclJoinPath(2, objs, 0); - if (altPath) { - Tcl_IncrRefCount(altPath); - if (Tcl_FSAccess(altPath, R_OK) == 0) { - path = altPath; - } - } - } - } - if (objs[0]) { - Tcl_DecrRefCount(objs[0]); - } - if (objs[1]) { - Tcl_DecrRefCount(objs[1]); - } - - loadFileProc = (Tcl_FSLoadFileProc2 *) tclNativeFilesystem.loadFileProc; - if (loadFileProc) { - ret = loadFileProc(interp, path, loadHandle, unloadProcPtr, flags); - } else { - Tcl_SetErrno(ENOENT); - ZIPFS_ERROR(interp, Tcl_PosixError(interp)); - } - if (altPath) { - Tcl_DecrRefCount(altPath); - } - return ret; -#endif /* ANDROID */ -} - -#endif /* HAVE_ZLIB */ - -/* - *------------------------------------------------------------------------- - * - * TclZipfs_Init -- - * - * Perform per interpreter initialization of this module. - * - * Results: - * The return value is a standard Tcl result. - * - * Side effects: - * Initializes this module if not already initialized, and adds module - * related commands to the given interpreter. - * - *------------------------------------------------------------------------- - */ - -MODULE_SCOPE int -TclZipfs_Init( - Tcl_Interp *interp) /* Current interpreter. */ -{ -#ifdef HAVE_ZLIB - static const EnsembleImplMap initMap[] = { - {"mkimg", ZipFSMkImgObjCmd, NULL, NULL, NULL, 1}, - {"mkzip", ZipFSMkZipObjCmd, NULL, NULL, NULL, 1}, - {"lmkimg", ZipFSLMkImgObjCmd, NULL, NULL, NULL, 1}, - {"lmkzip", ZipFSLMkZipObjCmd, NULL, NULL, NULL, 1}, - /* The 4 entries above are not available in safe interpreters */ - {"mount", ZipFSMountObjCmd, NULL, NULL, NULL, 1}, - {"mount_data", ZipFSMountBufferObjCmd, NULL, NULL, NULL, 1}, - {"unmount", ZipFSUnmountObjCmd, NULL, NULL, NULL, 1}, - {"mkkey", ZipFSMkKeyObjCmd, NULL, NULL, NULL, 1}, - {"exists", ZipFSExistsObjCmd, NULL, NULL, NULL, 0}, - {"info", ZipFSInfoObjCmd, NULL, NULL, NULL, 0}, - {"list", ZipFSListObjCmd, NULL, NULL, NULL, 0}, - {"canonical", ZipFSCanonicalObjCmd, NULL, NULL, NULL, 0}, - {"root", ZipFSRootObjCmd, NULL, NULL, NULL, 0}, - {NULL, NULL, NULL, NULL, NULL, 0} - }; - static const char findproc[] = - "namespace eval ::tcl::zipfs {}\n" - "proc ::tcl::zipfs::Find dir {\n" - " set result {}\n" - " if {[catch {glob -directory $dir -nocomplain * .*} list]} {\n" - " return $result\n" - " }\n" - " foreach file $list {\n" - " if {[file tail $file] in {. ..}} {\n" - " continue\n" - " }\n" - " lappend result $file {*}[Find $file]\n" - " }\n" - " return $result\n" - "}\n" - "proc ::tcl::zipfs::find {directoryName} {\n" - " return [lsort [Find $directoryName]]\n" - "}\n"; - - /* - * One-time initialization. - */ - - WriteLock(); - if (!ZipFS.initialized) { - ZipfsSetup(); - } - Unlock(); - - if (interp) { - Tcl_Command ensemble; - Tcl_Obj *mapObj; - - Tcl_EvalEx(interp, findproc, -1, TCL_EVAL_GLOBAL); - Tcl_LinkVar(interp, "::tcl::zipfs::wrmax", (char *) &ZipFS.wrmax, - TCL_LINK_INT); - ensemble = TclMakeEnsemble(interp, "zipfs", - Tcl_IsSafe(interp) ? (initMap + 4) : initMap); - - /* - * Add the [zipfs find] subcommand. - */ - - Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj); - Tcl_DictObjPut(NULL, mapObj, Tcl_NewStringObj("find", -1), - Tcl_NewStringObj("::tcl::zipfs::find", -1)); - Tcl_CreateObjCommand(interp, "::tcl::zipfs::tcl_library_init", - ZipFSTclLibraryObjCmd, NULL, NULL); - Tcl_PkgProvideEx(interp, "zipfs", "2.0", NULL); - } - return TCL_OK; -#else /* !HAVE_ZLIB */ - ZIPFS_ERROR(interp, "no zlib available"); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_ZLIB", NULL); - return TCL_ERROR; -#endif /* HAVE_ZLIB */ -} - -static int -ZipfsAppHookFindTclInit( - const char *archive) -{ - Tcl_Obj *vfsInitScript; - int found; - - if (zipfs_literal_tcl_library) { - return TCL_ERROR; - } - if (TclZipfs_Mount(NULL, ZIPFS_ZIP_MOUNT, archive, NULL)) { - /* Either the file doesn't exist or it is not a zip archive */ - return TCL_ERROR; - } - - TclNewLiteralStringObj(vfsInitScript, ZIPFS_ZIP_MOUNT "/init.tcl"); - Tcl_IncrRefCount(vfsInitScript); - found = Tcl_FSAccess(vfsInitScript, F_OK); - Tcl_DecrRefCount(vfsInitScript); - if (found == 0) { - zipfs_literal_tcl_library = ZIPFS_ZIP_MOUNT; - return TCL_OK; - } - - TclNewLiteralStringObj(vfsInitScript, - ZIPFS_ZIP_MOUNT "/tcl_library/init.tcl"); - Tcl_IncrRefCount(vfsInitScript); - found = Tcl_FSAccess(vfsInitScript, F_OK); - Tcl_DecrRefCount(vfsInitScript); - if (found == 0) { - zipfs_literal_tcl_library = ZIPFS_ZIP_MOUNT "/tcl_library"; - return TCL_OK; - } - - return TCL_ERROR; -} - -static void -ZipfsExitHandler( - ClientData clientData) -{ - ZipFile *zf = (ZipFile *)clientData; - - if (TCL_OK != TclZipfs_Unmount(NULL, zf->mountPoint)) { - Tcl_Panic("tried to unmount busy filesystem"); - } -} - -/* - *------------------------------------------------------------------------- - * - * TclZipfs_AppHook -- - * - * Performs the argument munging for the shell - * - *------------------------------------------------------------------------- - */ - -int -TclZipfs_AppHook( - int *argcPtr, /* Pointer to argc */ -#ifdef _WIN32 - WCHAR -#else /* !_WIN32 */ - char -#endif /* _WIN32 */ - ***argvPtr) /* Pointer to argv */ -{ - char *archive; - - Tcl_FindExecutable((*argvPtr)[0]); - archive = (char *) Tcl_GetNameOfExecutable(); - TclZipfs_Init(NULL); - - /* - * Look for init.tcl in one of the locations mounted later in this - * function. - */ - - if (!TclZipfs_Mount(NULL, ZIPFS_APP_MOUNT, archive, NULL)) { - int found; - Tcl_Obj *vfsInitScript; - - TclNewLiteralStringObj(vfsInitScript, ZIPFS_APP_MOUNT "/main.tcl"); - Tcl_IncrRefCount(vfsInitScript); - if (Tcl_FSAccess(vfsInitScript, F_OK) == 0) { - /* - * Startup script should be set before calling Tcl_AppInit - */ - - Tcl_SetStartupScript(vfsInitScript, NULL); - } else { - Tcl_DecrRefCount(vfsInitScript); - } - - /* - * Set Tcl Encodings - */ - - if (!zipfs_literal_tcl_library) { - TclNewLiteralStringObj(vfsInitScript, - ZIPFS_APP_MOUNT "/tcl_library/init.tcl"); - Tcl_IncrRefCount(vfsInitScript); - found = Tcl_FSAccess(vfsInitScript, F_OK); - Tcl_DecrRefCount(vfsInitScript); - if (found == TCL_OK) { - zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library"; - return TCL_OK; - } - } -#ifdef SUPPORT_BUILTIN_ZIP_INSTALL - } else if (*argcPtr > 1) { - /* - * If the first argument is "install", run the supplied installer - * script. - */ - -#ifdef _WIN32 - Tcl_DString ds; - - archive = Tcl_WinTCharToUtf((*argvPtr)[1], -1, &ds); -#else /* !_WIN32 */ - archive = (*argvPtr)[1]; -#endif /* _WIN32 */ - if (strcmp(archive, "install") == 0) { - Tcl_Obj *vfsInitScript; - - /* - * Run this now to ensure the file is present by the time Tcl_Main - * wants it. - */ - - TclZipfs_TclLibrary(); - TclNewLiteralStringObj(vfsInitScript, - ZIPFS_ZIP_MOUNT "/tcl_library/install.tcl"); - Tcl_IncrRefCount(vfsInitScript); - if (Tcl_FSAccess(vfsInitScript, F_OK) == 0) { - Tcl_SetStartupScript(vfsInitScript, NULL); - } - return TCL_OK; - } else if (!TclZipfs_Mount(NULL, ZIPFS_APP_MOUNT, archive, NULL)) { - int found; - Tcl_Obj *vfsInitScript; - - TclNewLiteralStringObj(vfsInitScript, ZIPFS_APP_MOUNT "/main.tcl"); - Tcl_IncrRefCount(vfsInitScript); - if (Tcl_FSAccess(vfsInitScript, F_OK) == 0) { - /* - * Startup script should be set before calling Tcl_AppInit - */ - - Tcl_SetStartupScript(vfsInitScript, NULL); - } else { - Tcl_DecrRefCount(vfsInitScript); - } - /* Set Tcl Encodings */ - TclNewLiteralStringObj(vfsInitScript, - ZIPFS_APP_MOUNT "/tcl_library/init.tcl"); - Tcl_IncrRefCount(vfsInitScript); - found = Tcl_FSAccess(vfsInitScript, F_OK); - Tcl_DecrRefCount(vfsInitScript); - if (found == TCL_OK) { - zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library"; - return TCL_OK; - } - } -#ifdef _WIN32 - Tcl_DStringFree(&ds); -#endif /* _WIN32 */ -#endif /* SUPPORT_BUILTIN_ZIP_INSTALL */ - } - return TCL_OK; -} - -#ifndef HAVE_ZLIB - -/* - *------------------------------------------------------------------------- - * - * TclZipfs_Mount, TclZipfs_MountBuffer, TclZipfs_Unmount -- - * - * Dummy version when no ZLIB support available. - * - *------------------------------------------------------------------------- - */ - -int -TclZipfs_Mount( - Tcl_Interp *interp, /* Current interpreter. */ - const char *mountPoint, /* Mount point path. */ - const char *zipname, /* Path to ZIP file to mount. */ - const char *passwd) /* Password for opening the ZIP, or NULL if - * the ZIP is unprotected. */ -{ - ZIPFS_ERROR(interp, "no zlib available"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_ZLIB", NULL); - } - return TCL_ERROR; -} - -int -TclZipfs_MountBuffer( - Tcl_Interp *interp, /* Current interpreter. NULLable. */ - const char *mountPoint, /* Mount point path. */ - unsigned char *data, - size_t datalen, - int copy) -{ - ZIPFS_ERROR(interp, "no zlib available"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_ZLIB", NULL); - } - return TCL_ERROR; -} - -int -TclZipfs_Unmount( - Tcl_Interp *interp, /* Current interpreter. */ - const char *mountPoint) /* Mount point path. */ -{ - ZIPFS_ERROR(interp, "no zlib available"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_ZLIB", NULL); - } - return TCL_ERROR; -} -#endif /* !HAVE_ZLIB */ - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ Index: generic/tclZlib.c ================================================================== --- generic/tclZlib.c +++ generic/tclZlib.c @@ -62,11 +62,11 @@ z_stream stream; /* The interface to the zlib library. */ int streamEnd; /* If we've got to end-of-stream. */ Tcl_Obj *inData, *outData; /* Input / output buffers (lists) */ Tcl_Obj *currentInput; /* Pointer to what is currently being * inflated. */ - size_t outPos; + int outPos; int mode; /* Either TCL_ZLIB_STREAM_DEFLATE or * TCL_ZLIB_STREAM_INFLATE. */ int format; /* Flags from the TCL_ZLIB_FORMAT_* */ int level; /* Default 5, 0-9 */ int flush; /* Stores the flush param for deferred the @@ -115,18 +115,17 @@ z_stream inStream; /* Structure used by zlib for decompression of * input. */ z_stream outStream; /* Structure used by zlib for compression of * output. */ char *inBuffer, *outBuffer; /* Working buffers. */ - size_t inAllocated, outAllocated; + int inAllocated, outAllocated; /* Sizes of working buffers. */ GzipHeader inHeader; /* Header read from input stream, when * decompressing a gzip stream. */ GzipHeader outHeader; /* Header to write to an output stream, when * compressing a gzip stream. */ Tcl_TimerToken timer; /* Timer used for keeping events fresh. */ - Tcl_DString decompressed; /* Buffer for decompression results. */ Tcl_Obj *compDictObj; /* Byte-array object containing compression * dictionary (not dictObj!) to use if * necessary. */ } ZlibChannelData; @@ -135,15 +134,19 @@ * ASYNC - Whether this is an asynchronous channel. * IN_HEADER - Whether the inHeader field has been registered with * the input compressor. * OUT_HEADER - Whether the outputHeader field has been registered * with the output decompressor. + * STREAM_DECOMPRESS - Signal decompress pending data. + * STREAM_DONE - Flag to signal stream end up to transform input. */ -#define ASYNC 0x1 -#define IN_HEADER 0x2 -#define OUT_HEADER 0x4 +#define ASYNC 0x01 +#define IN_HEADER 0x02 +#define OUT_HEADER 0x04 +#define STREAM_DECOMPRESS 0x08 +#define STREAM_DONE 0x10 /* * Size of buffers allocated by default, and the range it can be set to. The * same sorts of values apply to streams, except with different limits (they * permit byte-level activity). Channels always use bytes unless told to use @@ -176,37 +179,35 @@ static void ConvertError(Tcl_Interp *interp, int code, uLong adler); static Tcl_Obj * ConvertErrorToList(int code, uLong adler); static inline int Deflate(z_streamp strm, void *bufferPtr, - size_t bufferSize, int flush, size_t *writtenPtr); + int bufferSize, int flush, int *writtenPtr); static void ExtractHeader(gz_header *headerPtr, Tcl_Obj *dictObj); static int GenerateHeader(Tcl_Interp *interp, Tcl_Obj *dictObj, GzipHeader *headerPtr, int *extraSizePtr); static int ZlibPushSubcmd(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static inline int ResultCopy(ZlibChannelData *cd, char *buf, - size_t toRead); -static int ResultGenerate(ZlibChannelData *cd, int n, int flush, - int *errorCodePtr); +static int ResultDecompress(ZlibChannelData *cd, char *buf, + int toRead, int flush, int *errorCodePtr); static Tcl_Channel ZlibStackChannelTransform(Tcl_Interp *interp, int mode, int format, int level, int limit, Tcl_Channel channel, Tcl_Obj *gzipHeaderDictPtr, Tcl_Obj *compDictObj); static void ZlibStreamCleanup(ZlibStreamHandle *zshPtr); static int ZlibStreamSubcmd(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static inline void ZlibTransformEventTimerKill(ZlibChannelData *cd); -static void ZlibTransformTimerRun(void *clientData); +static void ZlibTransformTimerRun(ClientData clientData); /* * Type of zlib-based compressing and decompressing channels. */ static const Tcl_ChannelType zlibChannelType = { "zlib", - TCL_CHANNEL_VERSION_3, + TCL_CHANNEL_VERSION_5, ZlibTransformClose, ZlibTransformInput, ZlibTransformOutput, NULL, /* seekProc */ ZlibTransformSetOption, @@ -420,12 +421,10 @@ int *extraSizePtr) /* Variable to add the length of header * strings (filename, comment) to. */ { Tcl_Obj *value; int len, result = TCL_ERROR; - size_t length; - Tcl_WideInt wideValue = 0; const char *valueStr; Tcl_Encoding latin1enc; static const char *const types[] = { "binary", "text" }; @@ -440,12 +439,12 @@ } if (GetValue(interp, dictObj, "comment", &value) != TCL_OK) { goto error; } else if (value != NULL) { - valueStr = TclGetStringFromObj(value, &length); - Tcl_UtfToExternal(NULL, latin1enc, valueStr, length, 0, NULL, + valueStr = Tcl_GetStringFromObj(value, &len); + Tcl_UtfToExternal(NULL, latin1enc, valueStr, len, 0, NULL, headerPtr->nativeCommentBuf, MAX_COMMENT_LEN-1, NULL, &len, NULL); headerPtr->nativeCommentBuf[len] = '\0'; headerPtr->header.comment = (Bytef *) headerPtr->nativeCommentBuf; if (extraSizePtr != NULL) { @@ -461,12 +460,12 @@ } if (GetValue(interp, dictObj, "filename", &value) != TCL_OK) { goto error; } else if (value != NULL) { - valueStr = TclGetStringFromObj(value, &length); - Tcl_UtfToExternal(NULL, latin1enc, valueStr, length, 0, NULL, + valueStr = Tcl_GetStringFromObj(value, &len); + Tcl_UtfToExternal(NULL, latin1enc, valueStr, len, 0, NULL, headerPtr->nativeFilenameBuf, MAXPATHLEN-1, NULL, &len, NULL); headerPtr->nativeFilenameBuf[len] = '\0'; headerPtr->header.name = (Bytef *) headerPtr->nativeFilenameBuf; if (extraSizePtr != NULL) { *extraSizePtr += len; @@ -485,15 +484,14 @@ * input data. */ if (GetValue(interp, dictObj, "time", &value) != TCL_OK) { goto error; - } else if (value != NULL && Tcl_GetWideIntFromObj(interp, value, - &wideValue) != TCL_OK) { + } else if (value != NULL && Tcl_GetLongFromObj(interp, value, + (long *) &headerPtr->header.time) != TCL_OK) { goto error; } - headerPtr->header.time = wideValue; if (GetValue(interp, dictObj, "type", &value) != TCL_OK) { goto error; } else if (value != NULL && Tcl_GetIndexFromObj(interp, value, types, "type", TCL_EXACT, &headerPtr->header.text) != TCL_OK) { @@ -566,14 +564,14 @@ Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->name, -1, &tmp); SetValue(dictObj, "filename", TclDStringToObj(&tmp)); } if (headerPtr->os != 255) { - SetValue(dictObj, "os", Tcl_NewWideIntObj(headerPtr->os)); + SetValue(dictObj, "os", Tcl_NewIntObj(headerPtr->os)); } if (headerPtr->time != 0 /* magic - no time */) { - SetValue(dictObj, "time", Tcl_NewWideIntObj(headerPtr->time)); + SetValue(dictObj, "time", Tcl_NewLongObj((long) headerPtr->time)); } if (headerPtr->text != Z_UNKNOWN) { SetValue(dictObj, "type", Tcl_NewStringObj(headerPtr->text ? "text" : "binary", -1)); } @@ -591,12 +589,12 @@ SetInflateDictionary( z_streamp strm, Tcl_Obj *compDictObj) { if (compDictObj != NULL) { - size_t length = 0; - unsigned char *bytes = TclGetByteArrayFromObj(compDictObj, &length); + int length; + unsigned char *bytes = Tcl_GetByteArrayFromObj(compDictObj, &length); return inflateSetDictionary(strm, bytes, length); } return Z_OK; } @@ -605,12 +603,12 @@ SetDeflateDictionary( z_streamp strm, Tcl_Obj *compDictObj) { if (compDictObj != NULL) { - size_t length = 0; - unsigned char *bytes = TclGetByteArrayFromObj(compDictObj, &length); + int length; + unsigned char *bytes = Tcl_GetByteArrayFromObj(compDictObj, &length); return deflateSetDictionary(strm, bytes, length); } return Z_OK; } @@ -617,13 +615,13 @@ static inline int Deflate( z_streamp strm, void *bufferPtr, - size_t bufferSize, + int bufferSize, int flush, - size_t *writtenPtr) + int *writtenPtr) { int e; strm->next_out = (Bytef *) bufferPtr; strm->avail_out = bufferSize; @@ -636,11 +634,11 @@ static inline void AppendByteArray( Tcl_Obj *listObj, void *buffer, - size_t size) + int size) { if (size > 0) { Tcl_Obj *baObj = Tcl_NewByteArrayObj((unsigned char *) buffer, size); Tcl_ListObjAppendElement(NULL, listObj, baObj); @@ -698,15 +696,15 @@ wbits = WBITS_RAW; break; case TCL_ZLIB_FORMAT_GZIP: wbits = WBITS_GZIP; if (dictObj) { - gzHeaderPtr = Tcl_Alloc(sizeof(GzipHeader)); + gzHeaderPtr = (GzipHeader *)ckalloc(sizeof(GzipHeader)); memset(gzHeaderPtr, 0, sizeof(GzipHeader)); if (GenerateHeader(interp, dictObj, gzHeaderPtr, NULL) != TCL_OK) { - Tcl_Free(gzHeaderPtr); + ckfree(gzHeaderPtr); return TCL_ERROR; } } break; case TCL_ZLIB_FORMAT_ZLIB: @@ -732,11 +730,11 @@ case TCL_ZLIB_FORMAT_RAW: wbits = WBITS_RAW; break; case TCL_ZLIB_FORMAT_GZIP: wbits = WBITS_GZIP; - gzHeaderPtr = Tcl_Alloc(sizeof(GzipHeader)); + gzHeaderPtr = (GzipHeader *)ckalloc(sizeof(GzipHeader)); memset(gzHeaderPtr, 0, sizeof(GzipHeader)); gzHeaderPtr->header.name = (Bytef *) gzHeaderPtr->nativeFilenameBuf; gzHeaderPtr->header.name_max = MAXPATHLEN - 1; gzHeaderPtr->header.comment = (Bytef *) @@ -758,11 +756,11 @@ default: Tcl_Panic("bad mode, must be TCL_ZLIB_STREAM_DEFLATE or" " TCL_ZLIB_STREAM_INFLATE"); } - zshPtr = Tcl_Alloc(sizeof(ZlibStreamHandle)); + zshPtr = (ZlibStreamHandle *)ckalloc(sizeof(ZlibStreamHandle)); zshPtr->interp = interp; zshPtr->mode = mode; zshPtr->format = format; zshPtr->level = level; zshPtr->wbits = wbits; @@ -858,13 +856,13 @@ error: if (zshPtr->compDictObj) { Tcl_DecrRefCount(zshPtr->compDictObj); } if (zshPtr->gzHeaderPtr) { - Tcl_Free(zshPtr->gzHeaderPtr); + ckfree(zshPtr->gzHeaderPtr); } - Tcl_Free(zshPtr); + ckfree(zshPtr); return TCL_ERROR; } /* *---------------------------------------------------------------------- @@ -883,13 +881,13 @@ *---------------------------------------------------------------------- */ static void ZlibStreamCmdDelete( - void *cd) + ClientData cd) { - ZlibStreamHandle *zshPtr = cd; + ZlibStreamHandle *zshPtr = (ZlibStreamHandle *)cd; zshPtr->cmd = NULL; ZlibStreamCleanup(zshPtr); } @@ -971,14 +969,14 @@ } if (zshPtr->compDictObj) { Tcl_DecrRefCount(zshPtr->compDictObj); } if (zshPtr->gzHeaderPtr) { - Tcl_Free(zshPtr->gzHeaderPtr); + ckfree(zshPtr->gzHeaderPtr); } - Tcl_Free(zshPtr); + ckfree(zshPtr); } /* *---------------------------------------------------------------------- * @@ -1189,12 +1187,11 @@ int flush) /* TCL_ZLIB_NO_FLUSH, TCL_ZLIB_FLUSH, * TCL_ZLIB_FULLFLUSH, or TCL_ZLIB_FINALIZE */ { ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle; char *dataTmp = NULL; - int e; - size_t size = 0, outSize, toStore; + int e, size, outSize, toStore; if (zshPtr->streamEnd) { if (zshPtr->interp) { Tcl_SetObjResult(zshPtr->interp, Tcl_NewStringObj( "already past compressed stream end", -1)); @@ -1202,11 +1199,11 @@ } return TCL_ERROR; } if (zshPtr->mode == TCL_ZLIB_STREAM_DEFLATE) { - zshPtr->stream.next_in = TclGetByteArrayFromObj(data, &size); + zshPtr->stream.next_in = Tcl_GetByteArrayFromObj(data, &size); zshPtr->stream.avail_in = size; /* * Must not do a zero-length compress unless finalizing. [Bug 25842c161] */ @@ -1233,11 +1230,11 @@ outSize = deflateBound(&zshPtr->stream, size) + 100; if (outSize > BUFFER_SIZE_LIMIT) { outSize = BUFFER_SIZE_LIMIT; } - dataTmp = Tcl_Alloc(outSize); + dataTmp = (char *)ckalloc(outSize); while (1) { e = Deflate(&zshPtr->stream, dataTmp, outSize, flush, &toStore); /* @@ -1267,20 +1264,20 @@ AppendByteArray(zshPtr->outData, dataTmp, outSize); if (outSize < BUFFER_SIZE_LIMIT) { outSize = BUFFER_SIZE_LIMIT; /* There may be *lots* of data left to output... */ - dataTmp = Tcl_Realloc(dataTmp, outSize); + dataTmp = (char *)ckrealloc(dataTmp, outSize); } } /* * And append the final data block to the outData list. */ AppendByteArray(zshPtr->outData, dataTmp, toStore); - Tcl_Free(dataTmp); + ckfree(dataTmp); } else { /* * This is easy. Just append to the inData list. */ @@ -1309,32 +1306,31 @@ int Tcl_ZlibStreamGet( Tcl_ZlibStream zshandle, /* As obtained from Tcl_ZlibStreamInit */ Tcl_Obj *data, /* A place to append the data. */ - size_t count) /* Number of bytes to grab as a maximum, you + int count) /* Number of bytes to grab as a maximum, you * may get less! */ { ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle; - int e, i, listLen; - size_t itemLen = 0, dataPos = 0; + int e, i, listLen, itemLen, dataPos = 0; Tcl_Obj *itemObj; unsigned char *dataPtr, *itemPtr; - size_t existing = 0; + int existing; /* * Getting beyond the of stream, just return empty string. */ if (zshPtr->streamEnd) { return TCL_OK; } - (void) TclGetByteArrayFromObj(data, &existing); + (void) Tcl_GetByteArrayFromObj(data, &existing); if (zshPtr->mode == TCL_ZLIB_STREAM_INFLATE) { - if (count == TCL_AUTO_LENGTH) { + if (count == -1) { /* * The only safe thing to do is restict to 65k. We might cause a * panic for out of memory if we just kept growing the buffer. */ @@ -1370,11 +1366,11 @@ Tcl_ListObjIndex(NULL, zshPtr->inData, 0, &itemObj); if (Tcl_IsShared(itemObj)) { itemObj = Tcl_DuplicateObj(itemObj); } - itemPtr = TclGetByteArrayFromObj(itemObj, &itemLen); + itemPtr = Tcl_GetByteArrayFromObj(itemObj, &itemLen); Tcl_IncrRefCount(itemObj); zshPtr->currentInput = itemObj; zshPtr->stream.next_in = itemPtr; zshPtr->stream.avail_in = itemLen; @@ -1442,11 +1438,11 @@ Tcl_ListObjIndex(zshPtr->interp, zshPtr->inData, 0, &itemObj); if (Tcl_IsShared(itemObj)) { itemObj = Tcl_DuplicateObj(itemObj); } - itemPtr = TclGetByteArrayFromObj(itemObj, &itemLen); + itemPtr = Tcl_GetByteArrayFromObj(itemObj, &itemLen); Tcl_IncrRefCount(itemObj); zshPtr->currentInput = itemObj; zshPtr->stream.next_in = itemPtr; zshPtr->stream.avail_in = itemLen; @@ -1487,15 +1483,15 @@ } inflateEnd(&zshPtr->stream); } } else { Tcl_ListObjLength(NULL, zshPtr->outData, &listLen); - if (count == TCL_AUTO_LENGTH) { + if (count == -1) { count = 0; for (i=0; ioutData, i, &itemObj); - (void) TclGetByteArrayFromObj(itemObj, &itemLen); + (void) Tcl_GetByteArrayFromObj(itemObj, &itemLen); if (i == 0) { count += itemLen - zshPtr->outPos; } else { count += itemLen; } @@ -1516,22 +1512,22 @@ * Get the next chunk off our list of chunks and grab the data out * of it. */ Tcl_ListObjIndex(NULL, zshPtr->outData, 0, &itemObj); - itemPtr = TclGetByteArrayFromObj(itemObj, &itemLen); - if (itemLen-zshPtr->outPos + dataPos >= count) { - size_t len = count - dataPos; + itemPtr = Tcl_GetByteArrayFromObj(itemObj, &itemLen); + if (itemLen-zshPtr->outPos >= count-dataPos) { + unsigned len = count - dataPos; memcpy(dataPtr + dataPos, itemPtr + zshPtr->outPos, len); zshPtr->outPos += len; dataPos += len; if (zshPtr->outPos == itemLen) { zshPtr->outPos = 0; } } else { - size_t len = itemLen - zshPtr->outPos; + unsigned len = itemLen - zshPtr->outPos; memcpy(dataPtr + dataPos, itemPtr + zshPtr->outPos, len); dataPos += len; zshPtr->outPos = 0; } @@ -1563,12 +1559,11 @@ int format, Tcl_Obj *data, int level, Tcl_Obj *gzipHeaderDictObj) { - int wbits = 0, e = 0, extraSize = 0; - size_t inLen = 0; + int wbits = 0, inLen = 0, e = 0, extraSize = 0; Byte *inData = NULL; z_stream stream; GzipHeader header; gz_header *headerPtr = NULL; Tcl_Obj *obj; @@ -1624,13 +1619,13 @@ /* * Obtain the pointer to the byte array, we'll pass this pointer straight * to the deflate command. */ - inData = TclGetByteArrayFromObj(data, &inLen); + inData = Tcl_GetByteArrayFromObj(data, &inLen); memset(&stream, 0, sizeof(z_stream)); - stream.avail_in = inLen; + stream.avail_in = (uInt) inLen; stream.next_in = inData; /* * No output buffer available yet, will alloc after deflateInit2. */ @@ -1711,15 +1706,14 @@ int Tcl_ZlibInflate( Tcl_Interp *interp, int format, Tcl_Obj *data, - size_t bufferSize, + int bufferSize, Tcl_Obj *gzipHeaderDictObj) { - int wbits = 0, e = 0; - size_t inLen = 0, newBufferSize; + int wbits = 0, inLen = 0, e = 0, newBufferSize; Byte *inData = NULL, *outData = NULL, *newOutData = NULL; z_stream stream; gz_header header, *headerPtr = NULL; Tcl_Obj *obj; char *nameBuf = NULL, *commentBuf = NULL; @@ -1755,19 +1749,19 @@ } if (gzipHeaderDictObj) { headerPtr = &header; memset(headerPtr, 0, sizeof(gz_header)); - nameBuf = Tcl_Alloc(MAXPATHLEN); + nameBuf = (char *)ckalloc(MAXPATHLEN); header.name = (Bytef *) nameBuf; header.name_max = MAXPATHLEN - 1; - commentBuf = Tcl_Alloc(MAX_COMMENT_LEN); + commentBuf = (char *)ckalloc(MAX_COMMENT_LEN); header.comment = (Bytef *) commentBuf; header.comm_max = MAX_COMMENT_LEN - 1; } - inData = TclGetByteArrayFromObj(data, &inLen); + inData = Tcl_GetByteArrayFromObj(data, &inLen); if (bufferSize < 1) { /* * Start with a buffer (up to) 3 times the size of the input data. */ @@ -1781,11 +1775,11 @@ } TclNewObj(obj); outData = Tcl_SetByteArrayLength(obj, bufferSize); memset(&stream, 0, sizeof(z_stream)); - stream.avail_in = inLen+1; /* +1 because zlib can "over-request" + stream.avail_in = (uInt) inLen+1; /* +1 because zlib can "over-request" * input (but ignore it!) */ stream.next_in = inData; stream.avail_out = bufferSize; stream.next_out = outData; @@ -1863,25 +1857,25 @@ Tcl_SetByteArrayLength(obj, stream.total_out); if (headerPtr != NULL) { ExtractHeader(&header, gzipHeaderDictObj); SetValue(gzipHeaderDictObj, "size", - Tcl_NewWideIntObj(stream.total_out)); - Tcl_Free(nameBuf); - Tcl_Free(commentBuf); + Tcl_NewLongObj(stream.total_out)); + ckfree(nameBuf); + ckfree(commentBuf); } Tcl_SetObjResult(interp, obj); return TCL_OK; error: TclDecrRefCount(obj); ConvertError(interp, e, stream.adler); if (nameBuf) { - Tcl_Free(nameBuf); + ckfree(nameBuf); } if (commentBuf) { - Tcl_Free(commentBuf); + ckfree(commentBuf); } return TCL_ERROR; } /* @@ -1896,21 +1890,21 @@ unsigned int Tcl_ZlibCRC32( unsigned int crc, const unsigned char *buf, - size_t len) + int len) { /* Nothing much to do, just wrap the crc32(). */ return crc32(crc, (Bytef *) buf, len); } unsigned int Tcl_ZlibAdler32( unsigned int adler, const unsigned char *buf, - size_t len) + int len) { return adler32(adler, (Bytef *) buf, len); } /* @@ -1923,18 +1917,17 @@ *---------------------------------------------------------------------- */ static int ZlibCmd( - void *notUsed, + ClientData notUsed, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - int command, i, option, level = -1; - size_t dlen = 0, start, buffersize = 0; - Tcl_WideInt wideLen; + int command, dlen, i, option, level = -1; + unsigned start, buffersize = 0; Byte *data; Tcl_Obj *headerDictObj; const char *extraInfoStr = NULL; static const char *const commands[] = { "adler32", "compress", "crc32", "decompress", "deflate", "gunzip", @@ -1967,11 +1960,11 @@ return TCL_ERROR; } if (objc < 4) { start = Tcl_ZlibAdler32(0, NULL, 0); } - data = TclGetByteArrayFromObj(objv[2], &dlen); + data = Tcl_GetByteArrayFromObj(objv[2], &dlen); Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) (uLong) Tcl_ZlibAdler32(start, data, dlen))); return TCL_OK; case CMD_CRC: /* crc32 str ?startvalue? * -> checksum */ @@ -1984,11 +1977,11 @@ return TCL_ERROR; } if (objc < 4) { start = Tcl_ZlibCRC32(0, NULL, 0); } - data = TclGetByteArrayFromObj(objv[2], &dlen); + data = Tcl_GetByteArrayFromObj(objv[2], &dlen); Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) (uLong) Tcl_ZlibCRC32(start, data, dlen))); return TCL_OK; case CMD_DEFLATE: /* deflate data ?level? * -> rawCompressedData */ @@ -2077,19 +2070,18 @@ if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 2, objv, "data ?bufferSize?"); return TCL_ERROR; } if (objc > 3) { - if (Tcl_GetWideIntFromObj(interp, objv[3], - &wideLen) != TCL_OK) { + if (Tcl_GetIntFromObj(interp, objv[3], + (int *) &buffersize) != TCL_OK) { return TCL_ERROR; } - if (wideLen < MIN_NONSTREAM_BUFFER_SIZE - || wideLen > MAX_BUFFER_SIZE) { + if (buffersize < MIN_NONSTREAM_BUFFER_SIZE + || buffersize > MAX_BUFFER_SIZE) { goto badBuffer; } - buffersize = wideLen; } return Tcl_ZlibInflate(interp, TCL_ZLIB_FORMAT_RAW, objv[2], buffersize, NULL); case CMD_DECOMPRESS: /* decompress zlibcomprdata \ * ?bufferSize? @@ -2097,19 +2089,18 @@ if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 2, objv, "data ?bufferSize?"); return TCL_ERROR; } if (objc > 3) { - if (Tcl_GetWideIntFromObj(interp, objv[3], - &wideLen) != TCL_OK) { + if (Tcl_GetIntFromObj(interp, objv[3], + (int *) &buffersize) != TCL_OK) { return TCL_ERROR; } - if (wideLen < MIN_NONSTREAM_BUFFER_SIZE - || wideLen > MAX_BUFFER_SIZE) { + if (buffersize < MIN_NONSTREAM_BUFFER_SIZE + || buffersize > MAX_BUFFER_SIZE) { goto badBuffer; } - buffersize = wideLen; } return Tcl_ZlibInflate(interp, TCL_ZLIB_FORMAT_ZLIB, objv[2], buffersize, NULL); case CMD_GUNZIP: { /* gunzip gzippeddata ?bufferSize? * -> decompressedData */ @@ -2129,23 +2120,22 @@ &option) != TCL_OK) { return TCL_ERROR; } switch (option) { case 0: - if (Tcl_GetWideIntFromObj(interp, objv[i+1], - &wideLen) != TCL_OK) { + if (Tcl_GetIntFromObj(interp, objv[i+1], + (int *) &buffersize) != TCL_OK) { return TCL_ERROR; } - if (wideLen < MIN_NONSTREAM_BUFFER_SIZE - || wideLen > MAX_BUFFER_SIZE) { + if (buffersize < MIN_NONSTREAM_BUFFER_SIZE + || buffersize > MAX_BUFFER_SIZE) { goto badBuffer; } - buffersize = wideLen; break; case 1: headerVarObj = objv[i+1]; - headerDictObj = Tcl_NewObj(); + TclNewObj(headerDictObj); break; } } if (Tcl_ZlibInflate(interp, TCL_ZLIB_FORMAT_GZIP, objv[2], buffersize, headerDictObj) != TCL_OK) { @@ -2373,11 +2363,11 @@ "-dictionary", "-header", "-level", "-limit", NULL }; const char *const *pushOptions = pushDecompressOptions; enum pushOptions {poDictionary, poHeader, poLevel, poLimit}; Tcl_Obj *headerObj = NULL, *compDictObj = NULL; - int limit = 1, dummy; + int limit = DEFAULT_BUFFER_SIZE, dummy; if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, "mode channel ?options...?"); return TCL_ERROR; } @@ -2523,16 +2513,16 @@ *---------------------------------------------------------------------- */ static int ZlibStreamCmd( - void *cd, + ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - Tcl_ZlibStream zstream = cd; + Tcl_ZlibStream zstream = (Tcl_ZlibStream)cd; int command, count, code; Tcl_Obj *obj; static const char *const cmds[] = { "add", "checksum", "close", "eof", "finalize", "flush", "fullflush", "get", "header", "put", "reset", @@ -2626,11 +2616,11 @@ case zs_eof: /* $strm eof */ if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_ZlibStreamEof(zstream))); + Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_ZlibStreamEof(zstream))); return TCL_OK; case zs_checksum: /* $strm checksum */ if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; @@ -2649,16 +2639,16 @@ return TCL_OK; } static int ZlibStreamAddCmd( - void *cd, + ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - Tcl_ZlibStream zstream = cd; + Tcl_ZlibStream zstream = (Tcl_ZlibStream)cd; int index, code, buffersize = -1, flush = -1, i; Tcl_Obj *obj, *compDictObj = NULL; static const char *const add_options[] = { "-buffer", "-dictionary", "-finalize", "-flush", "-fullflush", NULL }; @@ -2672,25 +2662,25 @@ return TCL_ERROR; } switch ((enum addOptions) index) { case ao_flush: /* -flush */ - if (flush > -1) { + if (flush >= 0) { flush = -2; } else { flush = Z_SYNC_FLUSH; } break; case ao_fullflush: /* -fullflush */ - if (flush > -1) { + if (flush >= 0) { flush = -2; } else { flush = Z_FULL_FLUSH; } break; case ao_finalize: /* -finalize */ - if (flush > -1) { + if (flush >= 0) { flush = -2; } else { flush = Z_FINISH; } break; @@ -2740,13 +2730,13 @@ /* * Set the compression dictionary if requested. */ if (compDictObj != NULL) { - size_t len = 0; + int len; - (void) TclGetByteArrayFromObj(compDictObj, &len); + (void) Tcl_GetByteArrayFromObj(compDictObj, &len); if (len == 0) { compDictObj = NULL; } Tcl_ZlibStreamSetCompressionDictionary(zstream, compDictObj); } @@ -2773,16 +2763,16 @@ return code; } static int ZlibStreamPutCmd( - void *cd, + ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - Tcl_ZlibStream zstream = cd; + Tcl_ZlibStream zstream = (Tcl_ZlibStream)cd; int index, flush = -1, i; Tcl_Obj *compDictObj = NULL; static const char *const put_options[] = { "-dictionary", "-finalize", "-flush", "-fullflush", NULL }; @@ -2796,25 +2786,25 @@ return TCL_ERROR; } switch ((enum putOptions) index) { case po_flush: /* -flush */ - if (flush > -1) { + if (flush >= 0) { flush = -2; } else { flush = Z_SYNC_FLUSH; } break; case po_fullflush: /* -fullflush */ - if (flush > -1) { + if (flush >= 0) { flush = -2; } else { flush = Z_FULL_FLUSH; } break; case po_finalize: /* -finalize */ - if (flush > -1) { + if (flush >= 0) { flush = -2; } else { flush = Z_FINISH; } break; @@ -2844,13 +2834,13 @@ /* * Set the compression dictionary if requested. */ if (compDictObj != NULL) { - size_t len = 0; + int len; - (void) TclGetByteArrayFromObj(compDictObj, &len); + (void) Tcl_GetByteArrayFromObj(compDictObj, &len); if (len == 0) { compDictObj = NULL; } Tcl_ZlibStreamSetCompressionDictionary(zstream, compDictObj); } @@ -2862,16 +2852,16 @@ return Tcl_ZlibStreamPut(zstream, objv[objc-1], flush); } static int ZlibStreamHeaderCmd( - void *cd, + ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - ZlibStreamHandle *zshPtr = cd; + ZlibStreamHandle *zshPtr = (ZlibStreamHandle *)cd; Tcl_Obj *resultObj; if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; @@ -2901,16 +2891,15 @@ *---------------------------------------------------------------------- */ static int ZlibTransformClose( - void *instanceData, + ClientData instanceData, Tcl_Interp *interp) { - ZlibChannelData *cd = instanceData; - int e, result = TCL_OK; - size_t written; + ZlibChannelData *cd = (ZlibChannelData *)instanceData; + int e, written, result = TCL_OK; /* * Delete the support timer. */ @@ -2941,11 +2930,11 @@ ConvertError(interp, e, cd->outStream.adler); } result = TCL_ERROR; break; } - if (written && Tcl_WriteRaw(cd->parent, cd->outBuffer, written) == TCL_IO_FAILURE) { + if (written && Tcl_WriteRaw(cd->parent, cd->outBuffer, written) < 0) { /* TODO: is this the right way to do errors on close? * Note: when close is called from FinalizeIOSubsystem then * interp may be NULL */ if (!TclInThreadExit() && interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -2956,10 +2945,19 @@ break; } } while (e != Z_STREAM_END); (void) deflateEnd(&cd->outStream); } else { + /* + * If we have unused bytes from the read input (overshot by + * Z_STREAM_END or on possible error), unget them back to the parent + * channel, so that they appear as not being read yet. + */ + if (cd->inStream.avail_in) { + Tcl_Ungets (cd->parent, (char *)cd->inStream.next_in, cd->inStream.avail_in, 0); + } + (void) inflateEnd(&cd->inStream); } /* * Release all memory. @@ -2967,21 +2965,20 @@ if (cd->compDictObj) { Tcl_DecrRefCount(cd->compDictObj); cd->compDictObj = NULL; } - Tcl_DStringFree(&cd->decompressed); if (cd->inBuffer) { - Tcl_Free(cd->inBuffer); + ckfree(cd->inBuffer); cd->inBuffer = NULL; } if (cd->outBuffer) { - Tcl_Free(cd->outBuffer); + ckfree(cd->outBuffer); cd->outBuffer = NULL; } - Tcl_Free(cd); + ckfree(cd); return result; } /* *---------------------------------------------------------------------- @@ -2993,109 +2990,130 @@ *---------------------------------------------------------------------- */ static int ZlibTransformInput( - void *instanceData, + ClientData instanceData, char *buf, int toRead, int *errorCodePtr) { - ZlibChannelData *cd = instanceData; + ZlibChannelData *cd = (ZlibChannelData *)instanceData; Tcl_DriverInputProc *inProc = Tcl_ChannelInputProc(Tcl_GetChannelType(cd->parent)); - int readBytes, gotBytes, copied; + int readBytes, gotBytes; if (cd->mode == TCL_ZLIB_STREAM_DEFLATE) { return inProc(Tcl_GetChannelInstanceData(cd->parent), buf, toRead, errorCodePtr); } gotBytes = 0; - while (toRead > 0) { + readBytes = cd->inStream.avail_in; /* how many bytes in buffer now */ + while (!(cd->flags & STREAM_DONE) && toRead > 0) { + int n, decBytes; + + /* if starting from scratch or continuation after full decompression */ + if (!cd->inStream.avail_in) { + /* buffer to start, we can read to whole available buffer */ + cd->inStream.next_in = (Bytef *) cd->inBuffer; + } /* - * Loop until the request is satisfied (or no data available from - * below, possibly EOF). + * If done - no read needed anymore, check we have to copy rest of + * decompressed data, otherwise return with size (or 0 for Eof) */ - - copied = ResultCopy(cd, buf, toRead); - toRead -= copied; - buf += copied; - gotBytes += copied; - - if (toRead == 0) { - return gotBytes; - } - + if (cd->flags & STREAM_DECOMPRESS) { + goto copyDecompressed; + } /* * The buffer is exhausted, but the caller wants even more. We now * have to go to the underlying channel, get more bytes and then * transform them for delivery. We may not get what we want (full EOF * or temporarily out of data). - * - * Length (cd->decompressed) == 0, toRead > 0 here. - * - * The zlib transform allows us to read at most one character from the - * underlying channel to properly identify Z_STREAM_END without - * reading over the border. */ - readBytes = Tcl_ReadRaw(cd->parent, cd->inBuffer, cd->readAheadLimit); + /* Check free buffer size and adjust size of next chunk to read. */ + n = cd->inAllocated - ((char *)cd->inStream.next_in - cd->inBuffer); + if (n <= 0) { + /* Normally unreachable: not enough input buffer to uncompress. + * Todo: firstly try to realloc inBuffer upto MAX_BUFFER_SIZE. + */ + *errorCodePtr = ENOBUFS; + return -1; + } + if (n > cd->readAheadLimit) { + n = cd->readAheadLimit; + } + readBytes = Tcl_ReadRaw(cd->parent, (char *)cd->inStream.next_in, n); /* * Three cases here: * 1. Got some data from the underlying channel (readBytes > 0) so * it should be fed through the decompression engine. - * 2. Got an error (readBytes == -1) which we should report up except + * 2. Got an error (readBytes < 0) which we should report up except * for the case where we can convert it to a short read. * 3. Got an end-of-data from EOF or blocking (readBytes == 0). If * it is EOF, try flushing the data out of the decompressor. */ - if (readBytes == -1) { + if (readBytes < 0) { /* See ReflectInput() in tclIORTrans.c */ if (Tcl_InputBlocked(cd->parent) && (gotBytes > 0)) { - return gotBytes; + break; } *errorCodePtr = Tcl_GetErrno(); return -1; } - if (readBytes == 0) { - /* - * Eof in parent. - * - * Now this is a bit different. The partial data waiting is - * converted and returned. - */ - - if (ResultGenerate(cd, 0, Z_SYNC_FLUSH, errorCodePtr) != TCL_OK) { - return -1; - } - - if (Tcl_DStringLength(&cd->decompressed) == 0) { - /* - * The drain delivered nothing. Time to deliver what we've - * got. - */ - - return gotBytes; - } - } else /* readBytes > 0 */ { - /* - * Transform the read chunk, which was not empty. Anything we get - * back is a transformation result to be put into our buffers, and - * the next iteration will put it into the result. - */ - - if (ResultGenerate(cd, readBytes, Z_NO_FLUSH, - errorCodePtr) != TCL_OK) { - return -1; - } - } - } + + /* more bytes (or Eof if readBytes == 0) */ + cd->inStream.avail_in += readBytes; + +copyDecompressed: + + /* + * Transform the read chunk, if not empty. Anything we get + * back is a transformation result to be put into our buffers, and + * the next iteration will put it into the result. + * For the case readBytes is 0 which signaling Eof in parent, the + * partial data waiting is converted and returned. + */ + + decBytes = ResultDecompress(cd, buf, toRead, + (readBytes != 0) ? Z_NO_FLUSH : Z_SYNC_FLUSH, + errorCodePtr); + if (decBytes == -1) { + return -1; + } + gotBytes += decBytes; + buf += decBytes; + toRead -= decBytes; + + if (((decBytes == 0) || (cd->flags & STREAM_DECOMPRESS))) { + /* + * The drain delivered nothing (or buffer too small to decompress). + * Time to deliver what we've got. + */ + if (!gotBytes && !(cd->flags & STREAM_DONE)) { + /* if no-data, but not ready - avoid signaling Eof, + * continue in blocking mode, otherwise EAGAIN */ + if (Tcl_InputBlocked(cd->parent)) { + continue; + } + *errorCodePtr = EAGAIN; + return -1; + } + break; + } + + /* + * Loop until the request is satisfied (or no data available from + * above, possibly EOF). + */ + } + return gotBytes; } /* *---------------------------------------------------------------------- @@ -3107,20 +3125,19 @@ *---------------------------------------------------------------------- */ static int ZlibTransformOutput( - void *instanceData, + ClientData instanceData, const char *buf, int toWrite, int *errorCodePtr) { - ZlibChannelData *cd = instanceData; + ZlibChannelData *cd = (ZlibChannelData *)instanceData; Tcl_DriverOutputProc *outProc = Tcl_ChannelOutputProc(Tcl_GetChannelType(cd->parent)); - int e; - size_t produced; + int e, produced; Tcl_Obj *errObj; if (cd->mode == TCL_ZLIB_STREAM_INFLATE) { return outProc(Tcl_GetChannelInstanceData(cd->parent), buf, toWrite, errorCodePtr); @@ -3141,11 +3158,11 @@ Z_NO_FLUSH, &produced); if (e != Z_OK || produced == 0) { break; } - if (Tcl_WriteRaw(cd->parent, cd->outBuffer, produced) == TCL_IO_FAILURE) { + if (Tcl_WriteRaw(cd->parent, cd->outBuffer, produced) < 0) { *errorCodePtr = Tcl_GetErrno(); return -1; } } @@ -3178,12 +3195,11 @@ ZlibTransformFlush( Tcl_Interp *interp, ZlibChannelData *cd, int flushType) { - int e; - size_t len; + int e, len; cd->outStream.avail_in = 0; do { /* * Get the bytes to go out of the compression engine. @@ -3198,11 +3214,11 @@ /* * Write the bytes we've received to the next layer. */ - if (len > 0 && Tcl_WriteRaw(cd->parent, cd->outBuffer, len) == TCL_IO_FAILURE) { + if (len > 0 && Tcl_WriteRaw(cd->parent, cd->outBuffer, len) < 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "problem flushing channel: %s", Tcl_PosixError(interp))); return TCL_ERROR; } @@ -3230,16 +3246,16 @@ *---------------------------------------------------------------------- */ static int ZlibTransformSetOption( /* not used */ - void *instanceData, + ClientData instanceData, Tcl_Interp *interp, const char *optionName, const char *value) { - ZlibChannelData *cd = instanceData; + ZlibChannelData *cd = (ZlibChannelData *)instanceData; Tcl_DriverSetOptionProc *setOptionProc = Tcl_ChannelSetOptionProc(Tcl_GetChannelType(cd->parent)); static const char *compressChanOptions = "dictionary flush"; static const char *gzipChanOptions = "flush"; static const char *decompressChanOptions = "dictionary limit"; @@ -3251,11 +3267,11 @@ Tcl_Obj *compDictObj; int code; TclNewStringObj(compDictObj, value, strlen(value)); Tcl_IncrRefCount(compDictObj); - Tcl_GetByteArrayFromObj(compDictObj, NULL); + (void) Tcl_GetByteArrayFromObj(compDictObj, NULL); if (cd->compDictObj) { TclDecrRefCount(cd->compDictObj); } cd->compDictObj = compDictObj; code = Z_OK; @@ -3343,16 +3359,16 @@ *---------------------------------------------------------------------- */ static int ZlibTransformGetOption( - void *instanceData, + ClientData instanceData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr) { - ZlibChannelData *cd = instanceData; + ZlibChannelData *cd = (ZlibChannelData *)instanceData; Tcl_DriverGetOptionProc *getOptionProc = Tcl_ChannelGetOptionProc(Tcl_GetChannelType(cd->parent)); static const char *compressChanOptions = "checksum dictionary"; static const char *gzipChanOptions = "checksum"; static const char *decompressChanOptions = "checksum dictionary limit"; @@ -3392,20 +3408,20 @@ if (optionName == NULL) { Tcl_DStringAppendElement(dsPtr, "-dictionary"); if (cd->compDictObj) { Tcl_DStringAppendElement(dsPtr, - TclGetString(cd->compDictObj)); + Tcl_GetString(cd->compDictObj)); } else { Tcl_DStringAppendElement(dsPtr, ""); } } else { if (cd->compDictObj) { - size_t length; - const char *str = TclGetStringFromObj(cd->compDictObj, &length); + int len; + const char *str = Tcl_GetStringFromObj(cd->compDictObj, &len); - Tcl_DStringAppend(dsPtr, str, length); + Tcl_DStringAppend(dsPtr, str, len); } return TCL_OK; } } @@ -3414,16 +3430,17 @@ * reports the header that has been read from the start of the stream. */ if ((cd->flags & IN_HEADER) && ((optionName == NULL) || (strcmp(optionName, "-header") == 0))) { - Tcl_Obj *tmpObj = Tcl_NewObj(); + Tcl_Obj *tmpObj; + TclNewObj(tmpObj); ExtractHeader(&cd->inHeader.header, tmpObj); if (optionName == NULL) { Tcl_DStringAppendElement(dsPtr, "-header"); - Tcl_DStringAppendElement(dsPtr, TclGetString(tmpObj)); + Tcl_DStringAppendElement(dsPtr, Tcl_GetString(tmpObj)); Tcl_DecrRefCount(tmpObj); } else { TclDStringAppendObj(dsPtr, tmpObj); Tcl_DecrRefCount(tmpObj); return TCL_OK; @@ -3463,37 +3480,37 @@ *---------------------------------------------------------------------- */ static void ZlibTransformWatch( - void *instanceData, + ClientData instanceData, int mask) { - ZlibChannelData *cd = instanceData; + ZlibChannelData *cd = (ZlibChannelData *)instanceData; Tcl_DriverWatchProc *watchProc; /* * This code is based on the code in tclIORTrans.c */ watchProc = Tcl_ChannelWatchProc(Tcl_GetChannelType(cd->parent)); watchProc(Tcl_GetChannelInstanceData(cd->parent), mask); - if (!(mask & TCL_READABLE) || Tcl_DStringLength(&cd->decompressed) == 0) { + if (!(mask & TCL_READABLE) || !(cd->flags & STREAM_DECOMPRESS)) { ZlibTransformEventTimerKill(cd); } else if (cd->timer == NULL) { cd->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, ZlibTransformTimerRun, cd); } } static int ZlibTransformEventHandler( - void *instanceData, + ClientData instanceData, int interestMask) { - ZlibChannelData *cd = instanceData; + ZlibChannelData *cd = (ZlibChannelData *)instanceData; ZlibTransformEventTimerKill(cd); return interestMask; } @@ -3507,13 +3524,13 @@ } } static void ZlibTransformTimerRun( - void *clientData) + ClientData clientData) { - ZlibChannelData *cd = clientData; + ZlibChannelData *cd = (ZlibChannelData *)clientData; cd->timer = NULL; Tcl_NotifyChannel(cd->chan, TCL_READABLE); } @@ -3528,15 +3545,15 @@ *---------------------------------------------------------------------- */ static int ZlibTransformGetHandle( - void *instanceData, + ClientData instanceData, int direction, - void **handlePtr) + ClientData *handlePtr) { - ZlibChannelData *cd = instanceData; + ZlibChannelData *cd = (ZlibChannelData *)instanceData; return Tcl_GetChannelHandle(cd->parent, direction, handlePtr); } /* @@ -3549,14 +3566,14 @@ *---------------------------------------------------------------------- */ static int ZlibTransformBlockMode( - void *instanceData, + ClientData instanceData, int mode) { - ZlibChannelData *cd = instanceData; + ZlibChannelData *cd = (ZlibChannelData *)instanceData; if (mode == TCL_MODE_NONBLOCKING) { cd->flags |= ASYNC; } else { cd->flags &= ~ASYNC; @@ -3602,11 +3619,11 @@ * to produce gzip-format data. */ Tcl_Obj *compDictObj) /* Byte-array object containing compression * dictionary (not dictObj!) to use if * necessary. */ { - ZlibChannelData *cd = Tcl_Alloc(sizeof(ZlibChannelData)); + ZlibChannelData *cd = (ZlibChannelData *)ckalloc(sizeof(ZlibChannelData)); Tcl_Channel chan; int wbits = 0; if (mode != TCL_ZLIB_STREAM_DEFLATE && mode != TCL_ZLIB_STREAM_INFLATE) { Tcl_Panic("unknown mode: %d", mode); @@ -3662,11 +3679,14 @@ if (mode == TCL_ZLIB_STREAM_INFLATE) { if (inflateInit2(&cd->inStream, wbits) != Z_OK) { goto error; } cd->inAllocated = DEFAULT_BUFFER_SIZE; - cd->inBuffer = Tcl_Alloc(cd->inAllocated); + if (cd->inAllocated < cd->readAheadLimit) { + cd->inAllocated = cd->readAheadLimit; + } + cd->inBuffer = (char *)ckalloc(cd->inAllocated); if (cd->flags & IN_HEADER) { if (inflateGetHeader(&cd->inStream, &cd->inHeader.header) != Z_OK) { goto error; } } @@ -3679,11 +3699,11 @@ if (deflateInit2(&cd->outStream, level, Z_DEFLATED, wbits, MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY) != Z_OK) { goto error; } cd->outAllocated = DEFAULT_BUFFER_SIZE; - cd->outBuffer = Tcl_Alloc(cd->outAllocated); + cd->outBuffer = (char *)ckalloc(cd->outAllocated); if (cd->flags & OUT_HEADER) { if (deflateSetHeader(&cd->outStream, &cd->outHeader.header) != Z_OK) { goto error; } } @@ -3692,12 +3712,10 @@ goto error; } } } - Tcl_DStringInit(&cd->decompressed); - chan = Tcl_StackChannel(interp, &zlibChannelType, cd, Tcl_GetChannelMode(channel), channel); if (chan == NULL) { goto error; } @@ -3706,150 +3724,95 @@ Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1)); return chan; error: if (cd->inBuffer) { - Tcl_Free(cd->inBuffer); + ckfree(cd->inBuffer); inflateEnd(&cd->inStream); } if (cd->outBuffer) { - Tcl_Free(cd->outBuffer); + ckfree(cd->outBuffer); deflateEnd(&cd->outStream); } if (cd->compDictObj) { Tcl_DecrRefCount(cd->compDictObj); } - Tcl_Free(cd); + ckfree(cd); return NULL; } /* *---------------------------------------------------------------------- * - * ResultCopy -- - * - * Copies the requested number of bytes from the buffer into the - * specified array and removes them from the buffer afterward. Copies - * less if there is not enough data in the buffer. - * - * Side effects: - * See above. - * - * Result: - * The number of actually copied bytes, possibly less than 'toRead'. - * - *---------------------------------------------------------------------- - */ - -static inline int -ResultCopy( - ZlibChannelData *cd, /* The location of the buffer to read from. */ - char *buf, /* The buffer to copy into */ - size_t toRead) /* Number of requested bytes */ -{ - size_t have = Tcl_DStringLength(&cd->decompressed); - - if (have == 0) { - /* - * Nothing to copy in the case of an empty buffer. - */ - - return 0; - } else if (have > toRead) { - /* - * The internal buffer contains more than requested. Copy the - * requested subset to the caller, shift the remaining bytes down, and - * truncate. - */ - - char *src = Tcl_DStringValue(&cd->decompressed); - - memcpy(buf, src, toRead); - memmove(src, src + toRead, have - toRead); - - Tcl_DStringSetLength(&cd->decompressed, have - toRead); - return toRead; - } else /* have <= toRead */ { - /* - * There is just or not enough in the buffer to fully satisfy the - * caller, so take everything as best effort. - */ - - memcpy(buf, Tcl_DStringValue(&cd->decompressed), have); - TclDStringClear(&cd->decompressed); - return have; - } -} - -/* - *---------------------------------------------------------------------- - * - * ResultGenerate -- - * - * Extract uncompressed bytes from the compression engine and store them - * in our working buffer. - * - * Result: - * TCL_OK/TCL_ERROR (with *errorCodePtr updated with reason). - * - * Side effects: - * See above. + * ResultDecompress -- + * + * Extract uncompressed bytes from the compression engine and store them + * in our buffer (buf) up to toRead bytes. + * + * Result: + * Number of bytes decompressed or -1 if error (with *errorCodePtr updated with reason). + * + * Side effects: + * After execution it updates cd->inStream (next_in, avail_in) to reflect + * the data that has been decompressed. * *---------------------------------------------------------------------- */ static int -ResultGenerate( +ResultDecompress( ZlibChannelData *cd, - int n, + char *buf, + int toRead, int flush, int *errorCodePtr) { -#define MAXBUF 1024 - unsigned char buf[MAXBUF]; - int e, written; + int e, written, resBytes = 0; Tcl_Obj *errObj; - cd->inStream.next_in = (Bytef *) cd->inBuffer; - cd->inStream.avail_in = n; - while (1) { - cd->inStream.next_out = (Bytef *) buf; - cd->inStream.avail_out = MAXBUF; + cd->flags &= ~STREAM_DECOMPRESS; + cd->inStream.next_out = (Bytef *) buf; + cd->inStream.avail_out = toRead; + while (cd->inStream.avail_out > 0) { e = inflate(&cd->inStream, flush); if (e == Z_NEED_DICT && cd->compDictObj) { e = SetInflateDictionary(&cd->inStream, cd->compDictObj); if (e == Z_OK) { /* * A repetition of Z_NEED_DICT is just an error. */ - - cd->inStream.next_out = (Bytef *) buf; - cd->inStream.avail_out = MAXBUF; e = inflate(&cd->inStream, flush); } } /* * avail_out is now the left over space in the output. Therefore - * "MAXBUF - avail_out" is the amount of bytes generated. + * "toRead - avail_out" is the amount of bytes generated. */ - written = MAXBUF - cd->inStream.avail_out; - if (written) { - Tcl_DStringAppend(&cd->decompressed, (char *) buf, written); - } + written = toRead - cd->inStream.avail_out; /* * The cases where we're definitely done. */ - if (((flush == Z_SYNC_FLUSH) && (e == Z_BUF_ERROR)) - || (e == Z_STREAM_END) - || (e == Z_OK && cd->inStream.avail_out == 0)) { - return TCL_OK; + if (e == Z_STREAM_END) { + cd->flags |= STREAM_DONE; + resBytes += written; + break; + } + if (e == Z_OK) { + if (written == 0) { + break; + } + resBytes += written; + } + + if ((flush == Z_SYNC_FLUSH) && (e == Z_BUF_ERROR)) { + break; } /* * Z_BUF_ERROR can be ignored as per http://www.zlib.net/zlib_how.html * @@ -3866,13 +3829,23 @@ /* * Check if the inflate stopped early. */ if (cd->inStream.avail_in <= 0 && flush != Z_SYNC_FLUSH) { - return TCL_OK; + break; + } + } + + if (!(cd->flags & STREAM_DONE)) { + /* if we have pending input data, but no available output buffer */ + if (cd->inStream.avail_in && !cd->inStream.avail_out) { + /* next time try to decompress it got readable (new output buffer) */ + cd->flags |= STREAM_DECOMPRESS; } } + + return resBytes; handleError: errObj = Tcl_NewListObj(0, NULL); Tcl_ListObjAppendElement(NULL, errObj, Tcl_NewStringObj("-errorcode",-1)); Tcl_ListObjAppendElement(NULL, errObj, @@ -3879,11 +3852,11 @@ ConvertErrorToList(e, cd->inStream.adler)); Tcl_ListObjAppendElement(NULL, errObj, Tcl_NewStringObj(cd->inStream.msg, -1)); Tcl_SetChannelError(cd->parent, errObj); *errorCodePtr = EINVAL; - return TCL_ERROR; + return -1; } /* *---------------------------------------------------------------------- * Finally, the TclZlibInit function. Used to install the zlib API. @@ -3920,21 +3893,15 @@ cfg[0].key = "zlibVersion"; cfg[0].value = zlibVersion(); cfg[1].key = NULL; Tcl_RegisterConfig(interp, "zlib", cfg, "iso8859-1"); - /* - * Allow command type introspection to do something sensible with streams. - */ - - TclRegisterCommandTypeName(ZlibStreamCmd, "zlibStream"); - /* * Formally provide the package as a Tcl built-in. */ - return Tcl_PkgProvideEx(interp, "zlib", TCL_ZLIB_VERSION, NULL); + return Tcl_PkgProvide(interp, "zlib", TCL_ZLIB_VERSION); } /* *---------------------------------------------------------------------- * Stubs used when a suitable zlib installation was not found during @@ -4005,11 +3972,11 @@ int Tcl_ZlibStreamGet( Tcl_ZlibStream zshandle, Tcl_Obj *data, - size_t count) + int count) { return TCL_OK; } int @@ -4030,11 +3997,11 @@ int Tcl_ZlibInflate( Tcl_Interp *interp, int format, Tcl_Obj *data, - size_t bufferSize, + int bufferSize, Tcl_Obj *gzipHeaderDictObj) { if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1)); Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL); @@ -4043,21 +4010,21 @@ } unsigned int Tcl_ZlibCRC32( unsigned int crc, - const unsigned char *buf, - size_t len) + const char *buf, + int len) { return 0; } unsigned int Tcl_ZlibAdler32( unsigned int adler, - const unsigned char *buf, - size_t len) + const char *buf, + int len) { return 0; } void Index: library/auto.tcl ================================================================== --- library/auto.tcl +++ library/auto.tcl @@ -72,61 +72,10 @@ if {[info exists env($enVarName)]} { lappend dirs $env($enVarName) } - catch { - set found 0 - set root [zipfs root] - set mountpoint [file join $root lib [string tolower $basename]] - lappend dirs [file join $root app ${basename}_library] - lappend dirs [file join $root lib $mountpoint ${basename}_library] - lappend dirs [file join $root lib $mountpoint] - if {![zipfs exists [file join $root app ${basename}_library]] \ - && ![zipfs exists $mountpoint]} { - set found 0 - foreach pkgdat [info loaded] { - lassign $pkgdat dllfile dllpkg - if {[string tolower $dllpkg] ne [string tolower $basename]} continue - if {$dllfile eq {}} { - # Loaded statically - break - } - set found 1 - zipfs mount $mountpoint $dllfile - break - } - if {!$found} { - set paths {} - lappend paths [file join $root app] - lappend paths [::${basename}::pkgconfig get libdir,runtime] - lappend paths [::${basename}::pkgconfig get bindir,runtime] - if {[catch {::${basename}::pkgconfig get zipfile,runtime} zipfile]} { - set zipfile [string tolower \ - "lib${basename}_[join [list {*}[split $version .] {*}$patch] _].zip"] - } - lappend paths [file dirname [file join [pwd] [info nameofexecutable]]] - foreach path $paths { - set archive [file join $path $zipfile] - if {![file exists $archive]} continue - zipfs mount $mountpoint $archive - if {[zipfs exists [file join $mountpoint ${basename}_library $initScript]]} { - lappend dirs [file join $mountpoint ${basename}_library] - set found 1 - break - } elseif {[zipfs exists [file join $mountpoint $initScript]]} { - lappend dirs [file join $mountpoint $initScript] - set found 1 - break - } else { - catch {zipfs unmount $archive} - } - } - } - } - } - # 2. In the package script directory registered within the # configuration of the package itself. catch { lappend dirs [::${basename}::pkgconfig get scriptdir,runtime] @@ -289,10 +238,11 @@ } foreach file [lsort [glob -- {*}$args]] { set f "" set error [catch { set f [open $file] + fconfigure $f -eofchar \032 while {[gets $f line] >= 0} { if {[regexp {^proc[ ]+([^ ]*)} $line match procName]} { set procName [lindex [auto_qualify $procName "::"] 0] append index "set [list auto_index($procName)]" append index " \[list source \[file join \$dir [list $file]\]\]\n" @@ -399,10 +349,11 @@ variable imports set scriptFile $file set fid [open $file] + fconfigure $fid -eofchar \032 set contents [read $fid] close $fid # There is one problem with sourcing files into the safe interpreter: # references like "$x" will fail since code is not really being executed @@ -425,31 +376,31 @@ return $index } # auto_mkindex_parser::hook command # -# Registers a Tcl command to evaluate when initializing the slave interpreter -# used by the mkindex parser. The command is evaluated in the master +# Registers a Tcl command to evaluate when initializing the child interpreter +# used by the mkindex parser. The command is evaluated in the parent # interpreter, and can use the variable auto_mkindex_parser::parser to get to -# the slave +# the child proc auto_mkindex_parser::hook {cmd} { variable initCommands lappend initCommands $cmd } # auto_mkindex_parser::slavehook command # -# Registers a Tcl command to evaluate when initializing the slave interpreter -# used by the mkindex parser. The command is evaluated in the slave +# Registers a Tcl command to evaluate when initializing the child interpreter +# used by the mkindex parser. The command is evaluated in the child # interpreter. proc auto_mkindex_parser::slavehook {cmd} { variable initCommands - # The $parser variable is defined to be the name of the slave interpreter + # The $parser variable is defined to be the name of the child interpreter # when this command is used later. lappend initCommands "\$parser eval [list $cmd]" } @@ -599,11 +550,11 @@ indexEntry $name } # Conditionally add support for Tcl byte code files. There are some tricky # details here. First, we need to get the tbcload library initialized in the -# current interpreter. We cannot load tbcload into the slave until we have +# current interpreter. We cannot load tbcload into the child until we have # done so because it needs access to the tcl_patchLevel variable. Second, # because the package index file may defer loading the library until we invoke # a command, we need to explicitly invoke auto_load to force it to be loaded. # This should be a noop if the package has already been loaded Index: library/clock.tcl ================================================================== --- library/clock.tcl +++ library/clock.tcl @@ -3302,11 +3302,11 @@ if { [info exists TZData($fileName)] } { return } - # Since an unsafe interp uses the [clock] command in the master, this code + # Since an unsafe interp uses the [clock] command in the parent, this code # is security sensitive. Make sure that the path name cannot escape the # given directory. if { ![regexp {^[[.-.][:alpha:]_]+(?:/[[.-.][:alpha:]_]+)*$} $fileName] } { return -code error \ @@ -3342,11 +3342,11 @@ #---------------------------------------------------------------------- proc ::tcl::clock::LoadZoneinfoFile { fileName } { variable ZoneinfoPaths - # Since an unsafe interp uses the [clock] command in the master, this code + # Since an unsafe interp uses the [clock] command in the parent, this code # is security sensitive. Make sure that the path name cannot escape the # given directory. if { ![regexp {^[[.-.][:alpha:]_]+(?:/[[.-.][:alpha:]_]+)*$} $fileName] } { return -code error \ @@ -3450,11 +3450,11 @@ binary scan $d @${seek}${iformat}${nTime}c${nTime} times tempCodes incr seek [expr { ($ilen + 1) * $nTime }] set times [linsert $times 0 $MINWIDE] set codes {} foreach c $tempCodes { - lappend codes [expr { $c & 0xff }] + lappend codes [expr { $c & 0xFF }] } set codes [linsert $codes 0 0] # Next come ${nType} time type descriptions, each of which has an offset # (seconds east of GMT), a DST indicator, and an index into the Index: library/dde/pkgIndex.tcl ================================================================== --- library/dde/pkgIndex.tcl +++ library/dde/pkgIndex.tcl @@ -1,7 +1,7 @@ -if {([info commands ::tcl::pkgconfig] eq "") - || ([info sharedlibextension] ne ".dll")} return +if {![package vsatisfies [package provide Tcl] 8.5]} return +if {[info sharedlibextension] != ".dll"} return if {[::tcl::pkgconfig get debug]} { - package ifneeded dde 1.4.1 [list load [file join $dir tcldde14g.dll] dde] + package ifneeded dde 1.4.3 [list load [file join $dir tcldde14g.dll] Dde] } else { - package ifneeded dde 1.4.1 [list load [file join $dir tcldde14.dll] dde] + package ifneeded dde 1.4.3 [list load [file join $dir tcldde14.dll] Dde] } Index: library/encoding/tis-620.enc ================================================================== --- library/encoding/tis-620.enc +++ library/encoding/tis-620.enc DELETED library/http/cookiejar.tcl Index: library/http/cookiejar.tcl ================================================================== --- library/http/cookiejar.tcl +++ /dev/null @@ -1,745 +0,0 @@ -# cookiejar.tcl -- -# -# Implementation of an HTTP cookie storage engine using SQLite. The -# implementation is done as a TclOO class, and includes a punycode -# encoder and decoder (though only the encoder is currently used). -# -# See the file "license.terms" for information on usage and redistribution of -# this file, and for a DISCLAIMER OF ALL WARRANTIES. - -# Dependencies -package require Tcl 8.6- -package require http 2.8.4 -package require sqlite3 -package require tcl::idna 1.0 - -# -# Configuration for the cookiejar package, plus basic support procedures. -# - -# This is the class that we are creating -if {![llength [info commands ::http::cookiejar]]} { - ::oo::class create ::http::cookiejar -} - -namespace eval [info object namespace ::http::cookiejar] { - proc setInt {*var val} { - upvar 1 ${*var} var - if {[catch {incr dummy $val} msg]} { - return -code error $msg - } - set var $val - } - proc setInterval {trigger *var val} { - upvar 1 ${*var} var - if {![string is integer -strict $val] || $val < 1} { - return -code error "expected positive integer but got \"$val\"" - } - set var $val - {*}$trigger - } - proc setBool {*var val} { - upvar 1 ${*var} var - if {[catch {if {$val} {}} msg]} { - return -code error $msg - } - set var [expr {!!$val}] - } - - proc setLog {*var val} { - upvar 1 ${*var} var - set var [::tcl::prefix match -message "log level" \ - {debug info warn error} $val] - } - - # Keep this in sync with pkgIndex.tcl and with the install directories in - # Makefiles - variable version 0.1 - - variable domainlist \ - http://publicsuffix.org/list/effective_tld_names.dat - variable domainfile \ - [file join [file dirname [info script]] effective_tld_names.txt.gz] - # The list is directed to from http://publicsuffix.org/list/ - variable loglevel info - variable vacuumtrigger 200 - variable retainlimit 100 - variable offline false - variable purgeinterval 60000 - variable refreshinterval 10000000 - variable domaincache {} - - # Some support procedures, none particularly useful in general - namespace eval support { - # Set up a logger if the http package isn't actually loaded yet. - if {![llength [info commands ::http::Log]]} { - proc ::http::Log args { - # Do nothing by default... - } - } - - namespace export * - proc locn {secure domain path {key ""}} { - if {$key eq ""} { - format "%s://%s%s" [expr {$secure?"https":"http"}] \ - [::tcl::idna encode $domain] $path - } else { - format "%s://%s%s?%s" \ - [expr {$secure?"https":"http"}] [::tcl::idna encode $domain] \ - $path $key - } - } - proc splitDomain domain { - set pieces [split $domain "."] - for {set i [llength $pieces]} {[incr i -1] >= 0} {} { - lappend result [join [lrange $pieces $i end] "."] - } - return $result - } - proc splitPath path { - set pieces [split [string trimleft $path "/"] "/"] - for {set j -1} {$j < [llength $pieces]} {incr j} { - lappend result /[join [lrange $pieces 0 $j] "/"] - } - return $result - } - proc isoNow {} { - set ms [clock milliseconds] - set ts [expr {$ms / 1000}] - set ms [format %03d [expr {$ms % 1000}]] - clock format $ts -format "%Y%m%dT%H%M%S.${ms}Z" -gmt 1 - } - proc log {level msg args} { - namespace upvar [info object namespace ::http::cookiejar] \ - loglevel loglevel - set who [uplevel 1 self class] - set mth [uplevel 1 self method] - set map {debug 0 info 1 warn 2 error 3} - if {[string map $map $level] >= [string map $map $loglevel]} { - set msg [format $msg {*}$args] - set LVL [string toupper $level] - ::http::Log "[isoNow] $LVL $who $mth - $msg" - } - } - } -} - -# Now we have enough information to provide the package. -package provide cookiejar \ - [set [info object namespace ::http::cookiejar]::version] - -# The implementation of the cookiejar package -::oo::define ::http::cookiejar { - self { - method configure {{optionName "\u0000\u0000"} {optionValue "\u0000\u0000"}} { - set tbl { - -domainfile {domainfile set} - -domainlist {domainlist set} - -domainrefresh {refreshinterval setInterval} - -loglevel {loglevel setLog} - -offline {offline setBool} - -purgeold {purgeinterval setInterval} - -retain {retainlimit setInt} - -vacuumtrigger {vacuumtrigger setInt} - } - dict lappend tbl -domainrefresh [namespace code { - my IntervalTrigger PostponeRefresh - }] - dict lappend tbl -purgeold [namespace code { - my IntervalTrigger PostponePurge - }] - if {$optionName eq "\u0000\u0000"} { - return [dict keys $tbl] - } - set opt [::tcl::prefix match -message "option" \ - [dict keys $tbl] $optionName] - set setter [lassign [dict get $tbl $opt] varname] - namespace upvar [namespace current] $varname var - if {$optionValue ne "\u0000\u0000"} { - {*}$setter var $optionValue - } - return $var - } - - method IntervalTrigger {method} { - # TODO: handle subclassing - foreach obj [info class instances [self]] { - [info object namespace $obj]::my $method - } - } - } - - variable purgeTimer deletions refreshTimer - constructor {{path ""}} { - namespace import [info object namespace [self class]]::support::* - - if {$path eq ""} { - sqlite3 [namespace current]::db :memory: - set storeorigin "constructed cookie store in memory" - } else { - sqlite3 [namespace current]::db $path - db timeout 500 - set storeorigin "loaded cookie store from $path" - } - - set deletions 0 - db transaction { - db eval { - --;# Store the persistent cookies in this table. - --;# Deletion policy: once they expire, or if explicitly - --;# killed. - CREATE TABLE IF NOT EXISTS persistentCookies ( - id INTEGER PRIMARY KEY, - secure INTEGER NOT NULL, - domain TEXT NOT NULL COLLATE NOCASE, - path TEXT NOT NULL, - key TEXT NOT NULL, - value TEXT NOT NULL, - originonly INTEGER NOT NULL, - expiry INTEGER NOT NULL, - lastuse INTEGER NOT NULL, - creation INTEGER NOT NULL); - CREATE UNIQUE INDEX IF NOT EXISTS persistentUnique - ON persistentCookies (domain, path, key); - CREATE INDEX IF NOT EXISTS persistentLookup - ON persistentCookies (domain, path); - - --;# Store the session cookies in this table. - --;# Deletion policy: at cookiejar instance deletion, if - --;# explicitly killed, or if the number of session cookies is - --;# too large and the cookie has not been used recently. - CREATE TEMP TABLE sessionCookies ( - id INTEGER PRIMARY KEY, - secure INTEGER NOT NULL, - domain TEXT NOT NULL COLLATE NOCASE, - path TEXT NOT NULL, - key TEXT NOT NULL, - originonly INTEGER NOT NULL, - value TEXT NOT NULL, - lastuse INTEGER NOT NULL, - creation INTEGER NOT NULL); - CREATE UNIQUE INDEX sessionUnique - ON sessionCookies (domain, path, key); - CREATE INDEX sessionLookup ON sessionCookies (domain, path); - - --;# View to allow for simple looking up of a cookie. - --;# Deletion policy: NOT SUPPORTED via this view. - CREATE TEMP VIEW cookies AS - SELECT id, domain, ( - CASE originonly WHEN 1 THEN path ELSE '.' || path END - ) AS path, key, value, secure, 1 AS persistent - FROM persistentCookies - UNION - SELECT id, domain, ( - CASE originonly WHEN 1 THEN path ELSE '.' || path END - ) AS path, key, value, secure, 0 AS persistent - FROM sessionCookies; - - --;# Encoded domain permission policy; if forbidden is 1, no - --;# cookie may be ever set for the domain, and if forbidden - --;# is 0, cookies *may* be created for the domain (overriding - --;# the forbiddenSuper table). - --;# Deletion policy: normally not modified. - CREATE TABLE IF NOT EXISTS domains ( - domain TEXT PRIMARY KEY NOT NULL, - forbidden INTEGER NOT NULL); - - --;# Domains that may not have a cookie defined for direct - --;# child domains of them. - --;# Deletion policy: normally not modified. - CREATE TABLE IF NOT EXISTS forbiddenSuper ( - domain TEXT PRIMARY KEY); - - --;# When we last retrieved the domain list. - CREATE TABLE IF NOT EXISTS domainCacheMetadata ( - id INTEGER PRIMARY KEY, - retrievalDate INTEGER, - installDate INTEGER); - } - - set cookieCount "no" - db eval { - SELECT COUNT(*) AS cookieCount FROM persistentCookies - } - log info "%s with %s entries" $storeorigin $cookieCount - - my PostponePurge - - if {$path ne ""} { - if {[db exists {SELECT 1 FROM domains}]} { - my RefreshDomains - } else { - my InitDomainList - my PostponeRefresh - } - } else { - set data [my GetDomainListOffline metadata] - my InstallDomainData $data $metadata - my PostponeRefresh - } - } - } - - method PostponePurge {} { - namespace upvar [info object namespace [self class]] \ - purgeinterval interval - catch {after cancel $purgeTimer} - set purgeTimer [after $interval [namespace code {my PurgeCookies}]] - } - - method PostponeRefresh {} { - namespace upvar [info object namespace [self class]] \ - refreshinterval interval - catch {after cancel $refreshTimer} - set refreshTimer [after $interval [namespace code {my RefreshDomains}]] - } - - method RefreshDomains {} { - # TODO: domain list refresh policy - my PostponeRefresh - } - - method HttpGet {url {timeout 0} {maxRedirects 5}} { - for {set r 0} {$r < $maxRedirects} {incr r} { - set tok [::http::geturl $url -timeout $timeout] - try { - if {[::http::status $tok] eq "timeout"} { - return -code error "connection timed out" - } elseif {[::http::ncode $tok] == 200} { - return [::http::data $tok] - } elseif {[::http::ncode $tok] >= 400} { - return -code error [::http::error $tok] - } elseif {[dict exists [::http::meta $tok] Location]} { - set url [dict get [::http::meta $tok] Location] - continue - } - return -code error \ - "unexpected state: [::http::code $tok]" - } finally { - ::http::cleanup $tok - } - } - return -code error "too many redirects" - } - method GetDomainListOnline {metaVar} { - upvar 1 $metaVar meta - namespace upvar [info object namespace [self class]] \ - domainlist url domaincache cache - lassign $cache when data - if {$when > [clock seconds] - 3600} { - log debug "using cached value created at %s" \ - [clock format $when -format {%Y%m%dT%H%M%SZ} -gmt 1] - dict set meta retrievalDate $when - return $data - } - log debug "loading domain list from %s" $url - try { - set when [clock seconds] - set data [my HttpGet $url] - set cache [list $when $data] - # TODO: Should we use the Last-Modified header instead? - dict set meta retrievalDate $when - return $data - } on error msg { - log error "failed to fetch list of forbidden cookie domains from %s: %s" \ - $url $msg - return {} - } - } - method GetDomainListOffline {metaVar} { - upvar 1 $metaVar meta - namespace upvar [info object namespace [self class]] \ - domainfile filename - log debug "loading domain list from %s" $filename - try { - set f [open $filename] - try { - if {[string match *.gz $filename]} { - zlib push gunzip $f - } - fconfigure $f -encoding utf-8 - dict set meta retrievalDate [file mtime $filename] - return [read $f] - } finally { - close $f - } - } on error {msg opt} { - log error "failed to read list of forbidden cookie domains from %s: %s" \ - $filename $msg - return -options $opt $msg - } - } - method InitDomainList {} { - namespace upvar [info object namespace [self class]] \ - offline offline - if {!$offline} { - try { - set data [my GetDomainListOnline metadata] - if {[string length $data]} { - my InstallDomainData $data $metadata - return - } - } on error {} { - log warn "attempting to fall back to built in version" - } - } - set data [my GetDomainListOffline metadata] - my InstallDomainData $data $metadata - } - - method InstallDomainData {data meta} { - set n [db total_changes] - db transaction { - foreach line [split $data "\n"] { - if {[string trim $line] eq ""} { - continue - } elseif {[string match //* $line]} { - continue - } elseif {[string match !* $line]} { - set line [string range $line 1 end] - set idna [string tolower [::tcl::idna encode $line]] - set utf [::tcl::idna decode [string tolower $line]] - db eval { - INSERT OR REPLACE INTO domains (domain, forbidden) - VALUES ($utf, 0); - } - if {$idna ne $utf} { - db eval { - INSERT OR REPLACE INTO domains (domain, forbidden) - VALUES ($idna, 0); - } - } - } else { - if {[string match {\*.*} $line]} { - set line [string range $line 2 end] - set idna [string tolower [::tcl::idna encode $line]] - set utf [::tcl::idna decode [string tolower $line]] - db eval { - INSERT OR REPLACE INTO forbiddenSuper (domain) - VALUES ($utf); - } - if {$idna ne $utf} { - db eval { - INSERT OR REPLACE INTO forbiddenSuper (domain) - VALUES ($idna); - } - } - } else { - set idna [string tolower [::tcl::idna encode $line]] - set utf [::tcl::idna decode [string tolower $line]] - } - db eval { - INSERT OR REPLACE INTO domains (domain, forbidden) - VALUES ($utf, 1); - } - if {$idna ne $utf} { - db eval { - INSERT OR REPLACE INTO domains (domain, forbidden) - VALUES ($idna, 1); - } - } - } - if {$utf ne [::tcl::idna decode [string tolower $idna]]} { - log warn "mismatch in IDNA handling for %s (%d, %s, %s)" \ - $idna $line $utf [::tcl::idna decode $idna] - } - } - - dict with meta { - set installDate [clock seconds] - db eval { - INSERT OR REPLACE INTO domainCacheMetadata - (id, retrievalDate, installDate) - VALUES (1, $retrievalDate, $installDate); - } - } - } - set n [expr {[db total_changes] - $n}] - log info "constructed domain info with %d entries" $n - } - - # This forces the rebuild of the domain data, loading it from - method forceLoadDomainData {} { - db transaction { - db eval { - DELETE FROM domains; - DELETE FROM forbiddenSuper; - INSERT OR REPLACE INTO domainCacheMetadata - (id, retrievalDate, installDate) - VALUES (1, -1, -1); - } - my InitDomainList - } - } - - destructor { - catch { - after cancel $purgeTimer - } - catch { - after cancel $refreshTimer - } - catch { - db close - } - return - } - - method GetCookiesForHostAndPath {listVar secure host path fullhost} { - upvar 1 $listVar result - log debug "check for cookies for %s" [locn $secure $host $path] - set exact [expr {$host eq $fullhost}] - db eval { - SELECT key, value FROM persistentCookies - WHERE domain = $host AND path = $path AND secure <= $secure - AND (NOT originonly OR domain = $fullhost) - AND originonly = $exact - } { - lappend result $key $value - db eval { - UPDATE persistentCookies SET lastuse = $now WHERE id = $id - } - } - set now [clock seconds] - db eval { - SELECT id, key, value FROM sessionCookies - WHERE domain = $host AND path = $path AND secure <= $secure - AND (NOT originonly OR domain = $fullhost) - AND originonly = $exact - } { - lappend result $key $value - db eval { - UPDATE sessionCookies SET lastuse = $now WHERE id = $id - } - } - } - - method getCookies {proto host path} { - set result {} - set paths [splitPath $path] - if {[regexp {[^0-9.]} $host]} { - set domains [splitDomain [string tolower [::tcl::idna encode $host]]] - } else { - # Ugh, it's a numeric domain! Restrict it to just itself... - set domains [list $host] - } - set secure [string equal -nocase $proto "https"] - # Open question: how to move these manipulations into the database - # engine (if that's where they *should* be). - # - # Suggestion from kbk: - #LENGTH(theColumn) <= LENGTH($queryStr) AND - #SUBSTR(theColumn, LENGTH($queryStr) LENGTH(theColumn)+1) = $queryStr - # - # However, we instead do most of the work in Tcl because that lets us - # do the splitting exactly right, and it's far easier to work with - # strings in Tcl than in SQL. - db transaction { - foreach domain $domains { - foreach p $paths { - my GetCookiesForHostAndPath result $secure $domain $p $host - } - } - return $result - } - } - - method BadDomain options { - if {![dict exists $options domain]} { - log error "no domain present in options" - return 0 - } - dict with options {} - if {$domain ne $origin} { - log debug "cookie domain varies from origin (%s, %s)" \ - $domain $origin - if {[string match .* $domain]} { - set dotd $domain - } else { - set dotd .$domain - } - if {![string equal -length [string length $dotd] \ - [string reverse $dotd] [string reverse $origin]]} { - log warn "bad cookie: domain not suffix of origin" - return 1 - } - } - if {![regexp {[^0-9.]} $domain]} { - if {$domain eq $origin} { - # May set for itself - return 0 - } - log warn "bad cookie: for a numeric address" - return 1 - } - db eval { - SELECT forbidden FROM domains WHERE domain = $domain - } { - if {$forbidden} { - log warn "bad cookie: for a forbidden address" - } - return $forbidden - } - if {[regexp {^[^.]+\.(.+)$} $domain -> super] && [db exists { - SELECT 1 FROM forbiddenSuper WHERE domain = $super - }]} then { - log warn "bad cookie: for a forbidden address" - return 1 - } - return 0 - } - - # A defined extension point to allow users to easily impose extra policies - # on whether to accept cookies from a particular domain and path. - method policyAllow {operation domain path} { - return true - } - - method storeCookie {options} { - db transaction { - if {[my BadDomain $options]} { - return - } - set now [clock seconds] - set persistent [dict exists $options expires] - dict with options {} - if {!$persistent} { - if {![my policyAllow session $domain $path]} { - log warn "bad cookie: $domain prohibited by user policy" - return - } - db eval { - INSERT OR REPLACE INTO sessionCookies ( - secure, domain, path, key, value, originonly, creation, - lastuse) - VALUES ($secure, $domain, $path, $key, $value, $hostonly, - $now, $now); - DELETE FROM persistentCookies - WHERE domain = $domain AND path = $path AND key = $key - AND secure <= $secure AND originonly = $hostonly - } - incr deletions [db changes] - log debug "defined session cookie for %s" \ - [locn $secure $domain $path $key] - } elseif {$expires < $now} { - if {![my policyAllow delete $domain $path]} { - log warn "bad cookie: $domain prohibited by user policy" - return - } - db eval { - DELETE FROM persistentCookies - WHERE domain = $domain AND path = $path AND key = $key - AND secure <= $secure AND originonly = $hostonly - } - set del [db changes] - db eval { - DELETE FROM sessionCookies - WHERE domain = $domain AND path = $path AND key = $key - AND secure <= $secure AND originonly = $hostonly - } - incr deletions [incr del [db changes]] - log debug "deleted %d cookies for %s" \ - $del [locn $secure $domain $path $key] - } else { - if {![my policyAllow set $domain $path]} { - log warn "bad cookie: $domain prohibited by user policy" - return - } - db eval { - INSERT OR REPLACE INTO persistentCookies ( - secure, domain, path, key, value, originonly, expiry, - creation, lastuse) - VALUES ($secure, $domain, $path, $key, $value, $hostonly, - $expires, $now, $now); - DELETE FROM sessionCookies - WHERE domain = $domain AND path = $path AND key = $key - AND secure <= $secure AND originonly = $hostonly - } - incr deletions [db changes] - log debug "defined persistent cookie for %s, expires at %s" \ - [locn $secure $domain $path $key] \ - [clock format $expires] - } - } - } - - method PurgeCookies {} { - namespace upvar [info object namespace [self class]] \ - vacuumtrigger trigger retainlimit retain - my PostponePurge - set now [clock seconds] - log debug "purging cookies that expired before %s" [clock format $now] - db transaction { - db eval { - DELETE FROM persistentCookies WHERE expiry < $now - } - incr deletions [db changes] - db eval { - DELETE FROM persistentCookies WHERE id IN ( - SELECT id FROM persistentCookies ORDER BY lastuse ASC - LIMIT -1 OFFSET $retain) - } - incr deletions [db changes] - db eval { - DELETE FROM sessionCookies WHERE id IN ( - SELECT id FROM sessionCookies ORDER BY lastuse - LIMIT -1 OFFSET $retain) - } - incr deletions [db changes] - } - - # Once we've deleted a fair bit, vacuum the database. Must be done - # outside a transaction. - if {$deletions > $trigger} { - set deletions 0 - log debug "vacuuming cookie database" - catch { - db eval { - VACUUM - } - } - } - } - - forward Database db - - method lookup {{host ""} {key ""}} { - set host [string tolower [::tcl::idna encode $host]] - db transaction { - if {$host eq ""} { - set result {} - db eval { - SELECT DISTINCT domain FROM cookies - ORDER BY domain - } { - lappend result [::tcl::idna decode [string tolower $domain]] - } - return $result - } elseif {$key eq ""} { - set result {} - db eval { - SELECT DISTINCT key FROM cookies - WHERE domain = $host - ORDER BY key - } { - lappend result $key - } - return $result - } else { - db eval { - SELECT value FROM cookies - WHERE domain = $host AND key = $key - LIMIT 1 - } { - return $value - } - return -code error "no such key for that host" - } - } - } -} - -# Local variables: -# mode: tcl -# fill-column: 78 -# End: DELETED library/http/effective_tld_names.txt.gz Index: library/http/effective_tld_names.txt.gz ================================================================== --- library/http/effective_tld_names.txt.gz +++ /dev/null cannot compute difference between binary files Index: library/http/http.tcl ================================================================== --- library/http/http.tcl +++ library/http/http.tcl @@ -9,20 +9,19 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. package require Tcl 8.6- # Keep this in sync with pkgIndex.tcl and with the install directories in # Makefiles -package provide http 2.9.0 +package provide http 2.9.5 namespace eval http { # Allow resourcing to not clobber existing data variable http if {![info exists http]} { array set http { -accept */* - -cookiejar {} -pipeline 1 -postfresh 0 -proxyhost {} -proxyport {} -proxyfilter http::ProxyRequired @@ -124,22 +123,10 @@ # Let user control default keepalive for compatibility variable defaultKeepalive if {![info exists defaultKeepalive]} { set defaultKeepalive 0 - } - - # Regular expression used to parse cookies - variable CookieRE {(?x) # EXPANDED SYNTAX - \s* # Ignore leading spaces - ([^][\u0000- ()<>@,;:\\""/?={}\u007f-\uffff]+) # Match the name - = # LITERAL: Equal sign - ([!\u0023-+\u002D-:<-\u005B\u005D-~]*) # Match the value - (?: - \s* ; \s* # LITERAL: semicolon - ([^\u0000]+) # Match the options - )? } namespace export geturl config reset wait formatQuery quoteString namespace export register unregister registerError # - Useful, but not exported: data, size, status, code, cleanup, error, @@ -542,11 +529,11 @@ set connId $state(socketinfo) } } else { set map [array get socketMapping] set ndx [lsearch -exact $map $s] - if {$ndx != -1} { + if {$ndx >= 0} { incr ndx -1 set connId [lindex $map $ndx] } } if { ($connId ne {}) @@ -732,11 +719,11 @@ queryoffset 0 type text/html body {} status "" http "" - connection close + connection keep-alive } set state(-keepalive) $defaultKeepalive set state(-strict) $strict # These flags have their types verified [Bug 811170] array set type { @@ -744,10 +731,11 @@ -blocksize integer -queryblocksize integer -strict boolean -timeout integer -validate boolean + -headers dict } set state(charset) $defaultCharset set options { -binary -blocksize -channel -command -handler -headers -keepalive -method -myaddr -progress -protocol -query -queryblocksize @@ -757,13 +745,12 @@ set options [string map {- ""} $options] set pat ^-(?:[join $options |])$ foreach {flag value} $args { if {[regexp -- $pat $flag]} { # Validate numbers - if { - [info exists type($flag)] && - ![string is $type($flag) -strict $value] + if {($flag eq "-headers") ? [catch {dict size $value}] : + ([info exists type($flag)] && ![string is $type($flag) -strict $value]) } { unset $token return -code error \ "Bad value for $flag ($value), must be $type($flag)" } @@ -903,16 +890,12 @@ return -code error \ "Illegal encoding character usage \"$bad\" in URL path" } return -code error "Illegal characters in URL path" } - if {![regexp {^[^?#]+} $srvurl state(path)]} { - set state(path) / - } } else { set srvurl / - set state(path) / } if {$proto eq ""} { set proto http } set lower [string tolower $proto] @@ -980,10 +963,22 @@ } } else { # It's a GET or HEAD. set state(-pipeline) $http(-pipeline) } + + # We cannot handle chunked encodings with -handler, so force HTTP/1.0 + # until we can manage this. + if {[info exists state(-handler)]} { + set state(-protocol) 1.0 + } + + # RFC 7320 A.1 - HTTP/1.0 Keep-Alive is problematic. We do not support it. + if {$state(-protocol) eq "1.0"} { + set state(connection) close + set state(-keepalive) 0 + } # See if we are supposed to use a previously opened channel. # - In principle, ANY call to http::geturl could use a previously opened # channel if it is available - the "Connection: keep-alive" header is a # request to leave the channel open AFTER completion of this call. @@ -1052,11 +1047,11 @@ set sock $socketMapping($state(socketinfo)) Log "reusing socket $sock for $state(socketinfo) - token $token" } # Do not automatically close the connection socket. - set state(connection) {} + set state(connection) keep-alive } } if {$reusing} { # Define state(tmpState) and state(tmpOpenCmd) for use @@ -1347,56 +1342,53 @@ set how HEAD } elseif {$isQueryChannel} { set how POST # The query channel must be blocking for the async Write to # work properly. - lassign [fconfigure $sock -translation] trRead trWrite - fconfigure $state(-querychannel) -blocking 1 \ - -translation [list $trRead binary] + fconfigure $state(-querychannel) -blocking 1 -translation binary set contDone 0 } if {[info exists state(-method)] && ($state(-method) ne "")} { set how $state(-method) } - # We cannot handle chunked encodings with -handler, so force HTTP/1.0 - # until we can manage this. - if {[info exists state(-handler)]} { - set state(-protocol) 1.0 - } set accept_types_seen 0 Log ^B$tk begin sending request - token $token if {[catch { set state(method) $how puts $sock "$how $srvurl HTTP/$state(-protocol)" if {[dict exists $state(-headers) Host]} { # Allow Host spoofing. [Bug 928154] - set hostHdr [dict get $state(-headers) Host] - regexp {^[^:]+} $hostHdr state(host) - puts $sock "Host: $hostHdr" + puts $sock "Host: [dict get $state(-headers) Host]" } elseif {$port == $defport} { # Don't add port in this case, to handle broken servers. [Bug # #504508] - set state(host) $host puts $sock "Host: $host" } else { - set state(host) $host puts $sock "Host: $host:$port" } puts $sock "User-Agent: $http(-useragent)" - if {($state(-protocol) >= 1.0) && $state(-keepalive)} { + if {($state(-protocol) > 1.0) && $state(-keepalive)} { # Send this header, because a 1.1 server is not compelled to treat # this as the default. puts $sock "Connection: keep-alive" } if {($state(-protocol) > 1.0) && !$state(-keepalive)} { puts $sock "Connection: close" ;# RFC2616 sec 8.1.2.1 } - if {[info exists phost] && ($phost ne "") && $state(-keepalive)} { - puts $sock "Proxy-Connection: Keep-Alive" + if {($state(-protocol) < 1.1)} { + # RFC7230 A.1 + # Some server implementations of HTTP/1.0 have a faulty + # implementation of RFC 2068 Keep-Alive. + # Don't leave this to chance. + # For HTTP/1.0 we have already "set state(connection) close" + # and "state(-keepalive) 0". + puts $sock "Connection: close" } + # RFC7230 A.1 - "clients are encouraged not to send the + # Proxy-Connection header field in any requests" set accept_encoding_seen 0 set content_type_seen 0 dict for {key value} $state(-headers) { set value [string map [list \n "" \r ""] $value] set key [string map {" " -} [string trim $key]] @@ -1440,26 +1432,10 @@ set state(querylength) \ [expr {[tell $state(-querychannel)] - $start}] seek $state(-querychannel) $start } - # Note that we don't do Cookie2; that's much nastier and not normally - # observed in practice either. It also doesn't fix the multitude of - # bugs in the basic cookie spec. - if {$http(-cookiejar) ne ""} { - set cookies "" - set separator "" - foreach {key value} [{*}$http(-cookiejar) \ - getCookies $proto $host $state(path)] { - append cookies $separator $key = $value - set separator "; " - } - if {$cookies ne ""} { - puts $sock "Cookie: $cookies" - } - } - # Flush the request header and set up the fileevent that will either # push the POST data or read the response. # # fileevent note: # @@ -1668,12 +1644,54 @@ fconfigure $sock -translation [list auto $trWrite] \ -buffersize $state(-blocksize) Log ^D$tk begin receiving response - token $token coroutine ${token}EventCoroutine http::Event $sock $token - fileevent $sock readable ${token}EventCoroutine + if {[info exists state(-handler)] || [info exists state(-progress)]} { + fileevent $sock readable [list http::EventGateway $sock $token] + } else { + fileevent $sock readable ${token}EventCoroutine + } + return +} + + +# http::EventGateway +# +# Bug [c2dc1da315]. +# - Recursive launch of the coroutine can occur if a -handler or -progress +# callback is used, and the callback command enters the event loop. +# - To prevent this, the fileevent "binding" is disabled while the +# coroutine is in flight. +# - If a recursive call occurs despite these precautions, it is not +# trapped and discarded here, because it is better to report it as a +# bug. +# - Although this solution is believed to be sufficiently general, it is +# used only if -handler or -progress is specified. In other cases, +# the coroutine is called directly. + +proc http::EventGateway {sock token} { + variable $token + upvar 0 $token state + fileevent $sock readable {} + catch {${token}EventCoroutine} res opts + if {[info commands ${token}EventCoroutine] ne {}} { + # The coroutine can be deleted by completion (a non-yield return), by + # http::Finish (when there is a premature end to the transaction), by + # http::reset or http::cleanup, or if the caller set option -channel + # but not option -handler: in the last case reading from the socket is + # now managed by commands ::http::Copy*, http::ReceiveChunked, and + # http::make-transformation-chunked. + # + # Catch in case the coroutine has closed the socket. + catch {fileevent $sock readable [list http::EventGateway $sock $token]} + } + + # If there was an error, re-throw it. + return -options $opts $res } + # http::NextPipelinedWrite # # - Connecting a socket to a token for writing is done by this command and by # command KeepSocket. @@ -2725,17 +2743,36 @@ set state(transfer) \ [string trim [string tolower $value]] } proxy-connection - connection { - set state(connection) \ - [string trim [string tolower $value]] - } - set-cookie { - if {$http(-cookiejar) ne ""} { - ParseCookie $token [string trim $value] + set tmpHeader [string trim [string tolower $value]] + # RFC 7230 Section 6.1 states that a comma-separated + # list is an acceptable value. According to + # https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Connection + # any comma-separated list implies keep-alive, but I + # don't see this in the RFC so we'll play safe and + # scan any list for "close". + if {$tmpHeader in {close keep-alive}} { + # The common cases, continue. + } elseif {[string first , $tmpHeader] < 0} { + # Not a comma-separated list, not "close", + # therefore "keep-alive". + set tmpHeader keep-alive + } else { + set tmpResult keep-alive + set tmpCsl [split $tmpHeader ,] + # Optional whitespace either side of separator. + foreach el $tmpCsl { + if {[string trim $el] eq {close}} { + set tmpResult close + break + } + } + set tmpHeader $tmpResult } + set state(connection) $tmpHeader } } lappend state(meta) $key [string trim $value] } } @@ -3018,11 +3055,11 @@ } # There's a bunch of XML-as-application-format things about. See RFC 3023 # and so on. if {$major eq "application"} { set minor [string trimright $minor] - if {$minor in {"xml" "xml-external-parsed-entity" "xml-dtd"}} { + if {$minor in {"json" "xml" "xml-external-parsed-entity" "xml-dtd"}} { return false } } # Not just application/foobar+xml but also image/svg+xml, so let us not # restrict things for now... @@ -3030,87 +3067,10 @@ return false } return true } -proc http::ParseCookie {token value} { - variable http - variable CookieRE - variable $token - upvar 0 $token state - - if {![regexp $CookieRE $value -> cookiename cookieval opts]} { - # Bad cookie! No biscuit! - return - } - - # Convert the options into a list before feeding into the cookie store; - # ugly, but quite easy. - set realopts {hostonly 1 path / secure 0 httponly 0} - dict set realopts origin $state(host) - dict set realopts domain $state(host) - foreach option [split [regsub -all {;\s+} $opts \u0000] \u0000] { - regexp {^(.*?)(?:=(.*))?$} $option -> optname optval - switch -exact -- [string tolower $optname] { - expires { - if {[catch { - #Sun, 06 Nov 1994 08:49:37 GMT - dict set realopts expires \ - [clock scan $optval -format "%a, %d %b %Y %T %Z"] - }] && [catch { - # Google does this one - #Mon, 01-Jan-1990 00:00:00 GMT - dict set realopts expires \ - [clock scan $optval -format "%a, %d-%b-%Y %T %Z"] - }] && [catch { - # This is in the RFC, but it is also in the original - # Netscape cookie spec, now online at: - # - #Sunday, 06-Nov-94 08:49:37 GMT - dict set realopts expires \ - [clock scan $optval -format "%A, %d-%b-%y %T %Z"] - }]} {catch { - #Sun Nov 6 08:49:37 1994 - dict set realopts expires \ - [clock scan $optval -gmt 1 -format "%a %b %d %T %Y"] - }} - } - max-age { - # Normalize - if {[string is integer -strict $optval]} { - dict set realopts expires [expr {[clock seconds] + $optval}] - } - } - domain { - # From the domain-matches definition [RFC 2109, section 2]: - # Host A's name domain-matches host B's if [...] - # A is a FQDN string and has the form NB, where N is a - # non-empty name string, B has the form .B', and B' is a - # FQDN string. (So, x.y.com domain-matches .y.com but - # not y.com.) - if {$optval ne "" && ![string match *. $optval]} { - dict set realopts domain [string trimleft $optval "."] - dict set realopts hostonly [expr { - ! [string match .* $optval] - }] - } - } - path { - if {[string match /* $optval]} { - dict set realopts path $optval - } - } - secure - httponly { - dict set realopts [string tolower $optname] 1 - } - } - } - dict set realopts key $cookiename - dict set realopts value $cookieval - {*}$http(-cookiejar) storeCookie $realopts -} - # http::getTextLine -- # # Get one line with the stream in crlf mode. # Used if Transfer-Encoding is chunked. # Empty line is not distinguished from eof. The caller must DELETED library/http/idna.tcl Index: library/http/idna.tcl ================================================================== --- library/http/idna.tcl +++ /dev/null @@ -1,292 +0,0 @@ -# cookiejar.tcl -- -# -# Implementation of IDNA (Internationalized Domain Names for -# Applications) encoding/decoding system, built on a punycode engine -# developed directly from the code in RFC 3492, Appendix C (with -# substantial modifications). -# -# This implementation includes code from that RFC, translated to Tcl; the -# other parts are: -# Copyright (c) 2014 Donal K. Fellows -# -# See the file "license.terms" for information on usage and redistribution of -# this file, and for a DISCLAIMER OF ALL WARRANTIES. - -namespace eval ::tcl::idna { - namespace ensemble create -command puny -map { - encode punyencode - decode punydecode - } - namespace ensemble create -command ::tcl::idna -map { - encode IDNAencode - decode IDNAdecode - puny puny - version {::apply {{} {package present tcl::idna} ::}} - } - - proc IDNAencode hostname { - set parts {} - # Split term from RFC 3490, Sec 3.1 - foreach part [split $hostname "\u002E\u3002\uFF0E\uFF61"] { - if {[regexp {[^-A-Za-z0-9]} $part]} { - if {[regexp {[^-A-Za-z0-9\u00a1-\uffff]} $part ch]} { - scan $ch %c c - if {$ch < "!" || $ch > "~"} { - set ch [format "\\u%04x" $c] - } - throw [list IDNA INVALID_NAME_CHARACTER $ch] \ - "bad character \"$ch\" in DNS name" - } - set part xn--[punyencode $part] - # Length restriction from RFC 5890, Sec 2.3.1 - if {[string length $part] > 63} { - throw [list IDNA OVERLONG_PART $part] \ - "hostname part too long" - } - } - lappend parts $part - } - return [join $parts .] - } - proc IDNAdecode hostname { - set parts {} - # Split term from RFC 3490, Sec 3.1 - foreach part [split $hostname "\u002E\u3002\uFF0E\uFF61"] { - if {[string match -nocase "xn--*" $part]} { - set part [punydecode [string range $part 4 end]] - } - lappend parts $part - } - return [join $parts .] - } - - variable digits [split "abcdefghijklmnopqrstuvwxyz0123456789" ""] - # Bootstring parameters for Punycode - variable base 36 - variable tmin 1 - variable tmax 26 - variable skew 38 - variable damp 700 - variable initial_bias 72 - variable initial_n 0x80 - - variable max_codepoint 0x10FFFF - - proc adapt {delta first numchars} { - variable base - variable tmin - variable tmax - variable damp - variable skew - - set delta [expr {$delta / ($first ? $damp : 2)}] - incr delta [expr {$delta / $numchars}] - set k 0 - while {$delta > ($base - $tmin) * $tmax / 2} { - set delta [expr {$delta / ($base-$tmin)}] - incr k $base - } - return [expr {$k + ($base-$tmin+1) * $delta / ($delta+$skew)}] - } - - # Main punycode encoding function - proc punyencode {string {case ""}} { - variable digits - variable tmin - variable tmax - variable base - variable initial_n - variable initial_bias - - if {![string is boolean $case]} { - return -code error "\"$case\" must be boolean" - } - - set in {} - foreach char [set string [split $string ""]] { - scan $char "%c" ch - lappend in $ch - } - set output {} - - # Initialize the state: - set n $initial_n - set delta 0 - set bias $initial_bias - - # Handle the basic code points: - foreach ch $string { - if {$ch < "\u0080"} { - if {$case eq ""} { - append output $ch - } elseif {[string is true $case]} { - append output [string toupper $ch] - } elseif {[string is false $case]} { - append output [string tolower $ch] - } - } - } - - set b [string length $output] - - # h is the number of code points that have been handled, b is the - # number of basic code points. - - if {$b > 0} { - append output "-" - } - - # Main encoding loop: - - for {set h $b} {$h < [llength $in]} {incr delta; incr n} { - # All non-basic code points < n have been handled already. Find - # the next larger one: - - set m inf - foreach ch $in { - if {$ch >= $n && $ch < $m} { - set m $ch - } - } - - # Increase delta enough to advance the decoder's state to - # , but guard against overflow: - - if {$m-$n > (0xffffffff-$delta)/($h+1)} { - throw {PUNYCODE OVERFLOW} "overflow in delta computation" - } - incr delta [expr {($m-$n) * ($h+1)}] - set n $m - - foreach ch $in { - if {$ch < $n && ([incr delta] & 0xffffffff) == 0} { - throw {PUNYCODE OVERFLOW} "overflow in delta computation" - } - - if {$ch != $n} { - continue - } - - # Represent delta as a generalized variable-length integer: - - for {set q $delta; set k $base} true {incr k $base} { - set t [expr {min(max($k-$bias, $tmin), $tmax)}] - if {$q < $t} { - break - } - append output \ - [lindex $digits [expr {$t + ($q-$t)%($base-$t)}]] - set q [expr {($q-$t) / ($base-$t)}] - } - - append output [lindex $digits $q] - set bias [adapt $delta [expr {$h==$b}] [expr {$h+1}]] - set delta 0 - incr h - } - } - - return $output - } - - # Main punycode decode function - proc punydecode {string {case ""}} { - variable tmin - variable tmax - variable base - variable initial_n - variable initial_bias - variable max_codepoint - - if {![string is boolean $case]} { - return -code error "\"$case\" must be boolean" - } - - # Initialize the state: - - set n $initial_n - set i 0 - set first 1 - set bias $initial_bias - - # Split the string into the "real" ASCII characters and the ones to - # feed into the main decoder. Note that we don't need to check the - # result of [regexp] because that RE will technically match any string - # at all. - - regexp {^(?:(.*)-)?([^-]*)$} $string -> pre post - if {[string is true -strict $case]} { - set pre [string toupper $pre] - } elseif {[string is false -strict $case]} { - set pre [string tolower $pre] - } - set output [split $pre ""] - set out [llength $output] - - # Main decoding loop: - - for {set in 0} {$in < [string length $post]} {incr in} { - # Decode a generalized variable-length integer into delta, which - # gets added to i. The overflow checking is easier if we increase - # i as we go, then subtract off its starting value at the end to - # obtain delta. - - for {set oldi $i; set w 1; set k $base} 1 {incr in} { - if {[set ch [string index $post $in]] eq ""} { - throw {PUNYCODE BAD_INPUT LENGTH} "exceeded input data" - } - if {[string match -nocase {[a-z]} $ch]} { - scan [string toupper $ch] %c digit - incr digit -65 - } elseif {[string match {[0-9]} $ch]} { - set digit [expr {$ch + 26}] - } else { - throw {PUNYCODE BAD_INPUT CHAR} \ - "bad decode character \"$ch\"" - } - incr i [expr {$digit * $w}] - set t [expr {min(max($tmin, $k-$bias), $tmax)}] - if {$digit < $t} { - set bias [adapt [expr {$i-$oldi}] $first [incr out]] - set first 0 - break - } - if {[set w [expr {$w * ($base - $t)}]] > 0x7fffffff} { - throw {PUNYCODE OVERFLOW} \ - "excessively large integer computed in digit decode" - } - incr k $base - } - - # i was supposed to wrap around from out+1 to 0, incrementing n - # each time, so we'll fix that now: - - if {[incr n [expr {$i / $out}]] > 0x7fffffff} { - throw {PUNYCODE OVERFLOW} \ - "excessively large integer computed in character choice" - } elseif {$n > $max_codepoint} { - if {$n >= 0x00d800 && $n < 0x00e000} { - # Bare surrogate?! - throw {PUNYCODE NON_BMP} \ - [format "unsupported character U+%06x" $n] - } - throw {PUNYCODE NON_UNICODE} "bad codepoint $n" - } - set i [expr {$i % $out}] - - # Insert n at position i of the output: - - set output [linsert $output $i [format "%c" $n]] - incr i - } - - return [join $output ""] - } -} - -package provide tcl::idna 1.0 - -# Local variables: -# mode: tcl -# fill-column: 78 -# End: Index: library/http/pkgIndex.tcl ================================================================== --- library/http/pkgIndex.tcl +++ library/http/pkgIndex.tcl @@ -1,4 +1,2 @@ if {![package vsatisfies [package provide Tcl] 8.6-]} {return} -package ifneeded http 2.9.0 [list tclPkgSetup $dir http 2.9.0 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] -package ifneeded cookiejar 0.1 [list source [file join $dir cookiejar.tcl]] -package ifneeded tcl::idna 1.0 [list source [file join $dir idna.tcl]] +package ifneeded http 2.9.5 [list tclPkgSetup $dir http 2.9.5 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] ADDED library/http1.0/http.tcl Index: library/http1.0/http.tcl ================================================================== --- /dev/null +++ library/http1.0/http.tcl @@ -0,0 +1,377 @@ +# http.tcl +# Client-side HTTP for GET, POST, and HEAD commands. +# These routines can be used in untrusted code that uses the Safesock +# security policy. +# These procedures use a callback interface to avoid using vwait, +# which is not defined in the safe base. +# +# See the http.n man page for documentation + +package provide http 1.0 + +array set http { + -accept */* + -proxyhost {} + -proxyport {} + -useragent {Tcl http client package 1.0} + -proxyfilter httpProxyRequired +} +proc http_config {args} { + global http + set options [lsort [array names http -*]] + set usage [join $options ", "] + if {[llength $args] == 0} { + set result {} + foreach name $options { + lappend result $name $http($name) + } + return $result + } + regsub -all -- - $options {} options + set pat ^-([join $options |])$ + if {[llength $args] == 1} { + set flag [lindex $args 0] + if {[regexp -- $pat $flag]} { + return $http($flag) + } else { + return -code error "Unknown option $flag, must be: $usage" + } + } else { + foreach {flag value} $args { + if {[regexp -- $pat $flag]} { + set http($flag) $value + } else { + return -code error "Unknown option $flag, must be: $usage" + } + } + } +} + + proc httpFinish { token {errormsg ""} } { + upvar #0 $token state + global errorInfo errorCode + if {[string length $errormsg] != 0} { + set state(error) [list $errormsg $errorInfo $errorCode] + set state(status) error + } + catch {close $state(sock)} + catch {after cancel $state(after)} + if {[info exists state(-command)]} { + if {[catch {eval $state(-command) {$token}} err]} { + if {[string length $errormsg] == 0} { + set state(error) [list $err $errorInfo $errorCode] + set state(status) error + } + } + unset state(-command) + } +} +proc http_reset { token {why reset} } { + upvar #0 $token state + set state(status) $why + catch {fileevent $state(sock) readable {}} + httpFinish $token + if {[info exists state(error)]} { + set errorlist $state(error) + unset state(error) + eval error $errorlist + } +} +proc http_get { url args } { + global http + if {![info exists http(uid)]} { + set http(uid) 0 + } + set token http#[incr http(uid)] + upvar #0 $token state + http_reset $token + array set state { + -blocksize 8192 + -validate 0 + -headers {} + -timeout 0 + state header + meta {} + currentsize 0 + totalsize 0 + type text/html + body {} + status "" + } + set options {-blocksize -channel -command -handler -headers \ + -progress -query -validate -timeout} + set usage [join $options ", "] + regsub -all -- - $options {} options + set pat ^-([join $options |])$ + foreach {flag value} $args { + if {[regexp $pat $flag]} { + # Validate numbers + if {[info exists state($flag)] && \ + [regexp {^[0-9]+$} $state($flag)] && \ + ![regexp {^[0-9]+$} $value]} { + return -code error "Bad value for $flag ($value), must be integer" + } + set state($flag) $value + } else { + return -code error "Unknown option $flag, can be: $usage" + } + } + if {! [regexp -nocase {^(http://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \ + x proto host y port srvurl]} { + error "Unsupported URL: $url" + } + if {[string length $port] == 0} { + set port 80 + } + if {[string length $srvurl] == 0} { + set srvurl / + } + if {[string length $proto] == 0} { + set url http://$url + } + set state(url) $url + if {![catch {$http(-proxyfilter) $host} proxy]} { + set phost [lindex $proxy 0] + set pport [lindex $proxy 1] + } + if {$state(-timeout) > 0} { + set state(after) [after $state(-timeout) [list http_reset $token timeout]] + } + if {[info exists phost] && [string length $phost]} { + set srvurl $url + set s [socket $phost $pport] + } else { + set s [socket $host $port] + } + set state(sock) $s + + # Send data in cr-lf format, but accept any line terminators + + fconfigure $s -translation {auto crlf} -buffersize $state(-blocksize) + + # The following is disallowed in safe interpreters, but the socket + # is already in non-blocking mode in that case. + + catch {fconfigure $s -blocking off} + set len 0 + set how GET + if {[info exists state(-query)]} { + set len [string length $state(-query)] + if {$len > 0} { + set how POST + } + } elseif {$state(-validate)} { + set how HEAD + } + puts $s "$how $srvurl HTTP/1.0" + puts $s "Accept: $http(-accept)" + puts $s "Host: $host" + puts $s "User-Agent: $http(-useragent)" + foreach {key value} $state(-headers) { + regsub -all \[\n\r\] $value {} value + set key [string trim $key] + if {[string length $key]} { + puts $s "$key: $value" + } + } + if {$len > 0} { + puts $s "Content-Length: $len" + puts $s "Content-Type: application/x-www-form-urlencoded" + puts $s "" + fconfigure $s -translation {auto binary} + puts -nonewline $s $state(-query) + } else { + puts $s "" + } + flush $s + fileevent $s readable [list httpEvent $token] + if {! [info exists state(-command)]} { + http_wait $token + } + return $token +} +proc http_data {token} { + upvar #0 $token state + return $state(body) +} +proc http_status {token} { + upvar #0 $token state + return $state(status) +} +proc http_code {token} { + upvar #0 $token state + return $state(http) +} +proc http_size {token} { + upvar #0 $token state + return $state(currentsize) +} + + proc httpEvent {token} { + upvar #0 $token state + set s $state(sock) + + if {[eof $s]} { + httpEof $token + return + } + if {$state(state) == "header"} { + set n [gets $s line] + if {$n == 0} { + set state(state) body + if {![regexp -nocase ^text $state(type)]} { + # Turn off conversions for non-text data + fconfigure $s -translation binary + if {[info exists state(-channel)]} { + fconfigure $state(-channel) -translation binary + } + } + if {[info exists state(-channel)] && + ![info exists state(-handler)]} { + # Initiate a sequence of background fcopies + fileevent $s readable {} + httpCopyStart $s $token + } + } elseif {$n > 0} { + if {[regexp -nocase {^content-type:(.+)$} $line x type]} { + set state(type) [string trim $type] + } + if {[regexp -nocase {^content-length:(.+)$} $line x length]} { + set state(totalsize) [string trim $length] + } + if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} { + lappend state(meta) $key $value + } elseif {[regexp ^HTTP $line]} { + set state(http) $line + } + } + } else { + if {[catch { + if {[info exists state(-handler)]} { + set n [eval $state(-handler) {$s $token}] + } else { + set block [read $s $state(-blocksize)] + set n [string length $block] + if {$n >= 0} { + append state(body) $block + } + } + if {$n >= 0} { + incr state(currentsize) $n + } + } err]} { + httpFinish $token $err + } else { + if {[info exists state(-progress)]} { + eval $state(-progress) {$token $state(totalsize) $state(currentsize)} + } + } + } +} + proc httpCopyStart {s token} { + upvar #0 $token state + if {[catch { + fcopy $s $state(-channel) -size $state(-blocksize) -command \ + [list httpCopyDone $token] + } err]} { + httpFinish $token $err + } +} + proc httpCopyDone {token count {error {}}} { + upvar #0 $token state + set s $state(sock) + incr state(currentsize) $count + if {[info exists state(-progress)]} { + eval $state(-progress) {$token $state(totalsize) $state(currentsize)} + } + if {([string length $error] != 0)} { + httpFinish $token $error + } elseif {[eof $s]} { + httpEof $token + } else { + httpCopyStart $s $token + } +} + proc httpEof {token} { + upvar #0 $token state + if {$state(state) == "header"} { + # Premature eof + set state(status) eof + } else { + set state(status) ok + } + set state(state) eof + httpFinish $token +} +proc http_wait {token} { + upvar #0 $token state + if {![info exists state(status)] || [string length $state(status)] == 0} { + vwait $token\(status) + } + if {[info exists state(error)]} { + set errorlist $state(error) + unset state(error) + eval error $errorlist + } + return $state(status) +} + +# Call http_formatQuery with an even number of arguments, where the first is +# a name, the second is a value, the third is another name, and so on. + +proc http_formatQuery {args} { + set result "" + set sep "" + foreach i $args { + append result $sep [httpMapReply $i] + if {$sep != "="} { + set sep = + } else { + set sep & + } + } + return $result +} + +# do x-www-urlencoded character mapping +# The spec says: "non-alphanumeric characters are replaced by '%HH'" +# 1 leave alphanumerics characters alone +# 2 Convert every other character to an array lookup +# 3 Escape constructs that are "special" to the tcl parser +# 4 "subst" the result, doing all the array substitutions + + proc httpMapReply {string} { + global httpFormMap + set alphanumeric a-zA-Z0-9 + if {![info exists httpFormMap]} { + + for {set i 1} {$i <= 256} {incr i} { + set c [format %c $i] + if {![string match \[$alphanumeric\] $c]} { + set httpFormMap($c) %[format %.2x $i] + } + } + # These are handled specially + array set httpFormMap { + " " + \n %0d%0a + } + } + regsub -all \[^$alphanumeric\] $string {$httpFormMap(&)} string + regsub -all \n $string {\\n} string + regsub -all \t $string {\\t} string + regsub -all {[][{})\\]\)} $string {\\&} string + return [subst $string] +} + +# Default proxy filter. + proc httpProxyRequired {host} { + global http + if {[info exists http(-proxyhost)] && [string length $http(-proxyhost)]} { + if {![info exists http(-proxyport)] || ![string length $http(-proxyport)]} { + set http(-proxyport) 8080 + } + return [list $http(-proxyhost) $http(-proxyport)] + } else { + return {} + } +} ADDED library/http1.0/pkgIndex.tcl Index: library/http1.0/pkgIndex.tcl ================================================================== --- /dev/null +++ library/http1.0/pkgIndex.tcl @@ -0,0 +1,11 @@ +# Tcl package index file, version 1.0 +# This file is generated by the "pkg_mkIndex" command +# and sourced either when an application starts up or +# by a "package unknown" script. It invokes the +# "package ifneeded" command to set up package-related +# information so that packages will be loaded automatically +# in response to "package require" commands. When this +# script is sourced, the variable $dir must contain the +# full path name of this file's directory. + +package ifneeded http 1.0 [list tclPkgSetup $dir http 1.0 {{http.tcl source {httpCopyDone httpCopyStart httpEof httpEvent httpFinish httpMapReply httpProxyRequired http_code http_config http_data http_formatQuery http_get http_reset http_size http_status http_wait}}}] Index: library/init.tcl ================================================================== --- library/init.tcl +++ library/init.tcl @@ -4,24 +4,21 @@ # "unknown" procedure and auto-load facilities. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 Scriptics Corporation. -# Copyright (c) 2004 by Kevin B. Kenny. -# Copyright (c) 2018 by Sean Woods -# -# All rights reserved. +# Copyright (c) 2004 by Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # This test intentionally written in pre-7.5 Tcl if {[info commands package] == ""} { error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" } -package require -exact Tcl 9.0a0 +package require -exact Tcl 8.6.10 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: # # The environment variable TCLLIBPATH @@ -38,50 +35,126 @@ # same architecture as the current executable. # # tcl_pkgPath, which is set by the platform-specific initialization routines # On UNIX it is compiled in # On Windows, it is not used +# +# (Ticket 41c9857bdd) In a safe interpreter, this file does not set +# ::auto_path (other than to {} if it is undefined). The caller, typically +# a Safe Base command, is responsible for setting ::auto_path. if {![info exists auto_path]} { - if {[info exists env(TCLLIBPATH)]} { + if {[info exists env(TCLLIBPATH)] && (![interp issafe])} { set auto_path $env(TCLLIBPATH) } else { set auto_path "" } } namespace eval tcl { - variable Dir - foreach Dir [list $::tcl_library [file dirname $::tcl_library]] { - if {$Dir ni $::auto_path} { - lappend ::auto_path $Dir - } - } - set Dir [file join [file dirname [file dirname \ - [info nameofexecutable]]] lib] - if {$Dir ni $::auto_path} { - lappend ::auto_path $Dir - } - catch { - foreach Dir $::tcl_pkgPath { - if {$Dir ni $::auto_path} { - lappend ::auto_path $Dir - } - } - } - - if {![interp issafe]} { - variable Path [encoding dirs] - set Dir [file join $::tcl_library encoding] - if {$Dir ni $Path} { - lappend Path $Dir - encoding dirs $Path - } - } -} - -namespace eval tcl::Pkg {} - + if {![interp issafe]} { + variable Dir + foreach Dir [list $::tcl_library [file dirname $::tcl_library]] { + if {$Dir ni $::auto_path} { + lappend ::auto_path $Dir + } + } + set Dir [file join [file dirname [file dirname \ + [info nameofexecutable]]] lib] + if {$Dir ni $::auto_path} { + lappend ::auto_path $Dir + } + if {[info exists ::tcl_pkgPath]} { catch { + foreach Dir $::tcl_pkgPath { + if {$Dir ni $::auto_path} { + lappend ::auto_path $Dir + } + } + }} + + variable Path [encoding dirs] + set Dir [file join $::tcl_library encoding] + if {$Dir ni $Path} { + lappend Path $Dir + encoding dirs $Path + } + unset Dir Path + } + + # TIP #255 min and max functions + namespace eval mathfunc { + proc min {args} { + if {![llength $args]} { + return -code error \ + "not enough arguments to math function \"min\"" + } + set val Inf + foreach arg $args { + # This will handle forcing the numeric value without + # ruining the internal type of a numeric object + if {[catch {expr {double($arg)}} err]} { + return -code error $err + } + if {$arg < $val} {set val $arg} + } + return $val + } + proc max {args} { + if {![llength $args]} { + return -code error \ + "not enough arguments to math function \"max\"" + } + set val -Inf + foreach arg $args { + # This will handle forcing the numeric value without + # ruining the internal type of a numeric object + if {[catch {expr {double($arg)}} err]} { + return -code error $err + } + if {$arg > $val} {set val $arg} + } + return $val + } + namespace export min max + } +} + +# Windows specific end of initialization + +if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} { + namespace eval tcl { + proc EnvTraceProc {lo n1 n2 op} { + global env + set x $env($n2) + set env($lo) $x + set env([string toupper $lo]) $x + } + proc InitWinEnv {} { + global env tcl_platform + foreach p [array names env] { + set u [string toupper $p] + if {$u ne $p} { + switch -- $u { + COMSPEC - + PATH { + set temp $env($p) + unset env($p) + set env($u) $temp + trace add variable env($p) write \ + [namespace code [list EnvTraceProc $p]] + trace add variable env($u) write \ + [namespace code [list EnvTraceProc $p]] + } + } + } + } + if {![info exists env(COMSPEC)]} { + set env(COMSPEC) cmd.exe + } + } + InitWinEnv + } +} # Setup the unknown package handler if {[interp issafe]} { @@ -238,11 +311,11 @@ return -options $opts $msg } set errInfo [string range $errInfo 0 $last-1] set tail "\"$cinfo\"" set last [string last $tail $errInfo] - if {$last + [string length $tail] != [string length $errInfo]} { + if {$last < 0 || $last + [string length $tail] != [string length $errInfo]} { return -code error -errorcode $errCode \ -errorinfo $errInfo $msg } set errInfo [string range $errInfo 0 $last-1] set tail "\n invoked from within\n" @@ -388,26 +461,10 @@ } } return 0 } -# ::tcl::Pkg::source -- -# This procedure provides an alternative "source" command, which doesn't -# register the file for the "package files" command. Safe interpreters -# don't have to do anything special. -# -# Arguments: -# filename - -proc ::tcl::Pkg::source {filename} { - if {[interp issafe]} { - uplevel 1 [list ::source $filename] - } else { - uplevel 1 [list ::source -nopkg $filename] - } -} - # auto_load_index -- # Loads the contents of tclIndex files on the auto_path directory # list. This is usually invoked within auto_load to load the index # of available commands. Returns 1 if the index is loaded, and 0 if # the index is already loaded and up to date. @@ -435,10 +492,11 @@ catch {source [file join $dir tclIndex]} } elseif {[catch {set f [open [file join $dir tclIndex]]}]} { continue } else { set error [catch { + fconfigure $f -eofchar \032 set id [gets $f] if {$id eq "# Tcl autoload index file, version 2.0"} { eval [read $f] } elseif {$id eq "# Tcl autoload index file: each line identifies a Tcl"} { while {[gets $f line] >= 0} { @@ -446,11 +504,11 @@ || ([llength $line] != 2)} { continue } set name [lindex $line 0] set auto_index($name) \ - "::tcl::Pkg::source [file join $dir [lindex $line 1]]" + "source [file join $dir [lindex $line 1]]" } } else { error "[file join $dir tclIndex] isn't a proper Tcl index file" } } msg opts] @@ -614,15 +672,20 @@ } return "" } set path "[file dirname [info nameof]];.;" - if {[info exists env(WINDIR)]} { + if {[info exists env(SystemRoot)]} { + set windir $env(SystemRoot) + } elseif {[info exists env(WINDIR)]} { set windir $env(WINDIR) } if {[info exists windir]} { - append path "$windir/system32;$windir/system;$windir;" + if {$tcl_platform(os) eq "Windows NT"} { + append path "$windir/system32;" + } + append path "$windir/system;$windir;" } foreach var {PATH Path path} { if {[info exists env($var)]} { append path ";$env($var)" @@ -733,11 +796,11 @@ \"$dest\": file already exists" } } } } else { - if {[string first $nsrc $ndest] != -1} { + if {[string first $nsrc $ndest] >= 0} { set srclen [expr {[llength [file split $nsrc]] - 1}] set ndest [lindex [file split $ndest] $srclen] if {$ndest eq [file tail $nsrc]} { return -code error "error $action \"$src\" to\ \"$dest\": trying to rename a volume or move a directory\ DELETED library/install.tcl Index: library/install.tcl ================================================================== --- library/install.tcl +++ /dev/null @@ -1,244 +0,0 @@ -### -# Installer actions built into tclsh and invoked -# if the first command line argument is "install" -### -if {[llength $argv] < 2} { - exit 0 -} -namespace eval ::practcl {} -### -# Installer tools -### -proc ::practcl::_isdirectory name { - return [file isdirectory $name] -} -### -# Return true if the pkgindex file contains -# any statement other than "package ifneeded" -# and/or if any package ifneeded loads a DLL -### -proc ::practcl::_pkgindex_directory {path} { - set buffer {} - set pkgidxfile [file join $path pkgIndex.tcl] - if {![file exists $pkgidxfile]} { - # No pkgIndex file, read the source - foreach file [glob -nocomplain $path/*.tm] { - set file [file normalize $file] - set fname [file rootname [file tail $file]] - ### - # We used to be able to ... Assume the package is correct in the filename - # No hunt for a "package provides" - ### - set package [lindex [split $fname -] 0] - set version [lindex [split $fname -] 1] - ### - # Read the file, and override assumptions as needed - ### - set fin [open $file r] - set dat [read $fin] - close $fin - # Look for a teapot style Package statement - foreach line [split $dat \n] { - set line [string trim $line] - if { [string range $line 0 9] != "# Package " } continue - set package [lindex $line 2] - set version [lindex $line 3] - break - } - # Look for a package provide statement - foreach line [split $dat \n] { - set line [string trim $line] - if { [string range $line 0 14] != "package provide" } continue - set package [lindex $line 2] - set version [lindex $line 3] - break - } - append buffer "package ifneeded $package $version \[list source \[file join \$dir [file tail $file]\]\]" \n - } - foreach file [glob -nocomplain $path/*.tcl] { - if { [file tail $file] == "version_info.tcl" } continue - set fin [open $file r] - set dat [read $fin] - close $fin - if {![regexp "package provide" $dat]} continue - set fname [file rootname [file tail $file]] - # Look for a package provide statement - foreach line [split $dat \n] { - set line [string trim $line] - if { [string range $line 0 14] != "package provide" } continue - set package [lindex $line 2] - set version [lindex $line 3] - if {[string index $package 0] in "\$ \[ @"} continue - if {[string index $version 0] in "\$ \[ @"} continue - append buffer "package ifneeded $package $version \[list source \[file join \$dir [file tail $file]\]\]" \n - break - } - } - return $buffer - } - set fin [open $pkgidxfile r] - set dat [read $fin] - close $fin - set trace 0 - #if {[file tail $path] eq "tool"} { - # set trace 1 - #} - set thisline {} - foreach line [split $dat \n] { - append thisline $line \n - if {![info complete $thisline]} continue - set line [string trim $line] - if {[string length $line]==0} { - set thisline {} ; continue - } - if {[string index $line 0] eq "#"} { - set thisline {} ; continue - } - if {[regexp "if.*catch.*package.*Tcl.*return" $thisline]} { - if {$trace} {puts "[file dirname $pkgidxfile] Ignoring $thisline"} - set thisline {} ; continue - } - if {[regexp "if.*package.*vsatisfies.*package.*provide.*return" $thisline]} { - if {$trace} { puts "[file dirname $pkgidxfile] Ignoring $thisline" } - set thisline {} ; continue - } - if {![regexp "package.*ifneeded" $thisline]} { - # This package index contains arbitrary code - # source instead of trying to add it to the master - # package index - if {$trace} { puts "[file dirname $pkgidxfile] Arbitrary code $thisline" } - return {source [file join $dir pkgIndex.tcl]} - } - append buffer $thisline \n - set thisline {} - } - if {$trace} {puts [list [file dirname $pkgidxfile] $buffer]} - return $buffer -} - - -proc ::practcl::_pkgindex_path_subdir {path} { - set result {} - foreach subpath [glob -nocomplain [file join $path *]] { - if {[file isdirectory $subpath]} { - lappend result $subpath {*}[_pkgindex_path_subdir $subpath] - } - } - return $result -} -### -# Index all paths given as though they will end up in the same -# virtual file system -### -proc ::practcl::pkgindex_path args { - set stack {} - set buffer { -lappend ::PATHSTACK $dir - } - foreach base $args { - set base [file normalize $base] - set paths {} - foreach dir [glob -nocomplain [file join $base *]] { - if {[file tail $dir] eq "teapot"} continue - lappend paths $dir {*}[::practcl::_pkgindex_path_subdir $dir] - } - set i [string length $base] - # Build a list of all of the paths - if {[llength $paths]} { - foreach path $paths { - if {$path eq $base} continue - set path_indexed($path) 0 - } - } else { - puts [list WARNING: NO PATHS FOUND IN $base] - } - set path_indexed($base) 1 - set path_indexed([file join $base boot tcl]) 1 - foreach teapath [glob -nocomplain [file join $base teapot *]] { - set pkg [file tail $teapath] - append buffer [list set pkg $pkg] - append buffer { -set pkginstall [file join $::g(HOME) teapot $pkg] -if {![file exists $pkginstall]} { - installDir [file join $dir teapot $pkg] $pkginstall -} -} - } - foreach path $paths { - if {$path_indexed($path)} continue - set thisdir [file_relative $base $path] - set idxbuf [::practcl::_pkgindex_directory $path] - if {[string length $idxbuf]} { - incr path_indexed($path) - append buffer "set dir \[set PKGDIR \[file join \[lindex \$::PATHSTACK end\] $thisdir\]\]" \n - append buffer [string map {$dir $PKGDIR} [string trimright $idxbuf]] \n - } - } - } - append buffer { -set dir [lindex $::PATHSTACK end] -set ::PATHSTACK [lrange $::PATHSTACK 0 end-1] -} - return $buffer -} - -### -# topic: 64319f4600fb63c82b2258d908f9d066 -# description: Script to build the VFS file system -### -proc ::practcl::installDir {d1 d2} { - - puts [format {%*sCreating %s} [expr {4 * [info level]}] {} [file tail $d2]] - file delete -force -- $d2 - file mkdir $d2 - - foreach ftail [glob -directory $d1 -nocomplain -tails *] { - set f [file join $d1 $ftail] - if {[file isdirectory $f] && [string compare CVS $ftail]} { - installDir $f [file join $d2 $ftail] - } elseif {[file isfile $f]} { - file copy -force $f [file join $d2 $ftail] - if {$::tcl_platform(platform) eq {unix}} { - file attributes [file join $d2 $ftail] -permissions 0644 - } else { - file attributes [file join $d2 $ftail] -readonly 1 - } - } - } - - if {$::tcl_platform(platform) eq {unix}} { - file attributes $d2 -permissions 0755 - } else { - file attributes $d2 -readonly 1 - } -} - -proc ::practcl::copyDir {d1 d2 {toplevel 1}} { - #if {$toplevel} { - # puts [list ::practcl::copyDir $d1 -> $d2] - #} - #file delete -force -- $d2 - file mkdir $d2 - - foreach ftail [glob -directory $d1 -nocomplain -tails *] { - set f [file join $d1 $ftail] - if {[file isdirectory $f] && [string compare CVS $ftail]} { - copyDir $f [file join $d2 $ftail] 0 - } elseif {[file isfile $f]} { - file copy -force $f [file join $d2 $ftail] - } - } -} - -switch [lindex $argv 1] { - mkzip { - zipfs mkzip {*}[lrange $argv 2 end] - } - mkzip { - zipfs mkimg {*}[lrange $argv 2 end] - } - default { - ::practcl::[lindex $argv 1] {*}[lrange $argv 2 end] - } -} -exit 0 DELETED library/manifest.txt Index: library/manifest.txt ================================================================== --- library/manifest.txt +++ /dev/null @@ -1,18 +0,0 @@ -### -# Package manifest for all Tcl packages included in the /library file system -### -apply {{dir} { - set ::test [info script] - set isafe [interp issafe] - foreach {safe package version file} { - 0 http 2.9.0 {http http.tcl} - 1 msgcat 1.7.0 {msgcat msgcat.tcl} - 1 opt 0.4.7 {opt optparse.tcl} - 0 platform 1.0.14 {platform platform.tcl} - 0 platform::shell 1.1.4 {platform shell.tcl} - 1 tcltest 2.5.0 {tcltest tcltest.tcl} - } { - if {$isafe && !$safe} continue - package ifneeded $package $version [list source [file join $dir {*}$file]] - } -}} $dir Index: library/msgcat/msgcat.tcl ================================================================== --- library/msgcat/msgcat.tcl +++ library/msgcat/msgcat.tcl @@ -2,28 +2,26 @@ # # This file defines various procedures which implement a # message catalog facility for Tcl programs. It should be # loaded with the command "package require msgcat". # -# Copyright (c) 2010-2018 by Harald Oehlmann. +# Copyright (c) 2010-2015 by Harald Oehlmann. # Copyright (c) 1998-2000 by Ajuba Solutions. # Copyright (c) 1998 by Mark Harrison. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# We use oo::define::self, which is new in Tcl 8.7 -package require Tcl 8.7- +package require Tcl 8.5- # When the version number changes, be sure to update the pkgIndex.tcl file, # and the installation directory in the Makefiles. -package provide msgcat 1.7.0 +package provide msgcat 1.6.1 namespace eval msgcat { - namespace export mc mcn mcexists mcload mclocale mcmax\ - mcmset mcpreferences mcset\ + namespace export mc mcexists mcload mclocale mcmax mcmset mcpreferences mcset\ mcunknown mcflset mcflmset mcloadedlocales mcforgetpackage\ - mcpackagenamespaceget mcpackageconfig mcpackagelocale mcutil + mcpackageconfig mcpackagelocale # Records the list of locales to search variable Loclist {} # List of currently loaded locales @@ -41,16 +39,10 @@ # Records the mapping between source strings and translated strings. The # dict key is of the form " ", where locale and # namespace should be themselves dict values and the value is # the translated string. variable Msgs [dict create] -} - -# create ensemble namespace for mcutil command -namespace eval msgcat::mcutil { - namespace export getsystemlocale getpreferences - namespace ensemble create -prefix 0 # Map of language codes used in Windows registry to those of ISO-639 if {[info sharedlibextension] eq ".dll"} { variable WinRegToISO639 [dict create {*}{ 01 ar 0401 ar_SA 0801 ar_IQ 0c01 ar_EG 1001 ar_LY 1401 ar_DZ @@ -185,11 +177,11 @@ # msgcat::mc -- # # Find the translation for the given string based on the current # locale setting. Check the local namespace first, then look in each # parent namespace until the source is found. If additional args are -# specified, use the format command to work them into the translated +# specified, use the format command to work them into the traslated # string. # If no catalog item is found, mcunknown is called in the caller frame # and its result is returned. # # Arguments: @@ -198,41 +190,22 @@ # # Results: # Returns the translated string. Propagates errors thrown by the # format command. -proc msgcat::mc {args} { - tailcall mcn [PackageNamespaceGet] {*}$args -} - -# msgcat::mcn -- -# -# Find the translation for the given string based on the current -# locale setting. Check the passed namespace first, then look in each -# parent namespace until the source is found. If additional args are -# specified, use the format command to work them into the translated -# string. -# If no catalog item is found, mcunknown is called in the caller frame -# and its result is returned. -# -# Arguments: -# ns Package namespace of the translation -# src The string to translate. -# args Args to pass to the format command -# -# Results: -# Returns the translated string. Propagates errors thrown by the -# format command. - -proc msgcat::mcn {ns src args} { +proc msgcat::mc {src args} { + # this may be replaced by: + # return [mcget -namespace [uplevel 1 [list ::namespace current]] --\ + # $src {*}$args] # Check for the src in each namespace starting from the local and # ending in the global. variable Msgs variable Loclist + set ns [uplevel 1 [list ::namespace current]] set loclist [PackagePreferences $ns] set nscur $ns while {$nscur != ""} { foreach loc $loclist { @@ -244,11 +217,11 @@ set nscur [namespace parent $nscur] } # call package local or default unknown command set args [linsert $args 0 [lindex $loclist 0] $src] switch -exact -- [Invoke unknowncmd $args $ns result 1] { - 0 { tailcall mcunknown {*}$args } + 0 { return [uplevel 1 [linsert $args 0 [namespace origin mcunknown]]] } 1 { return [DefaultUnknown {*}$args] } default { return $result } } } @@ -270,43 +243,35 @@ variable Msgs variable Loclist variable PackageConfig + set ns [uplevel 1 [list ::namespace current]] + set loclist [PackagePreferences $ns] + while {[llength $args] != 1} { set args [lassign $args option] switch -glob -- $option { - -exactnamespace - -exactlocale { set $option 1 } - -namespace { - if {[llength $args] < 2} { - return -code error\ - "Argument missing for switch \"-namespace\"" - } - set args [lassign $args ns] - } + -exactnamespace { set exactnamespace 1 } + -exactlocale { set loclist [lrange $loclist 0 0] } -* { return -code error "unknown option \"$option\"" } default { return -code error "wrong # args: should be\ \"[lindex [info level 0] 0] ?-exactnamespace?\ - ?-exactlocale? ?-namespace ns? src\"" + ?-exactlocale? src\"" } } } set src [lindex $args 0] - if {![info exists ns]} { set ns [PackageNamespaceGet] } - - set loclist [PackagePreferences $ns] - if {[info exists -exactlocale]} { set loclist [lrange $loclist 0 0] } - while {$ns ne ""} { foreach loc $loclist { if {[dict exists $Msgs $ns $loc $src]} { return 1 } } - if {[info exists -exactnamespace]} {return 0} + if {[info exists exactnamespace]} {return 0} set ns [namespace parent $ns] } return 0 } @@ -336,31 +301,36 @@ set newLocale [string tolower [lindex $args 0]] if {$newLocale ne [file tail $newLocale]} { return -code error "invalid newLocale value \"$newLocale\":\ could be path to unsafe code." } - mcpreferences {*}[mcutil getpreferences $newLocale] + if {[lindex $Loclist 0] ne $newLocale} { + set Loclist [GetPreferences $newLocale] + + # locale not loaded jet + LoadAll $Loclist + # Invoke callback + Invoke changecmd $Loclist + } } return [lindex $Loclist 0] } -# msgcat::mcutil::getpreferences -- +# msgcat::GetPreferences -- # # Get list of locales from a locale. # The first element is always the lowercase locale. # Other elements have one component separated by "_" less. # Multiple "_" are seen as one separator: de__ch_spec de__ch de {} # -# This method is part of the ensemble mcutil -# # Arguments: # Locale. # # Results: # Locale list -proc msgcat::mcutil::getpreferences {locale} { +proc msgcat::GetPreferences {locale} { set locale [string tolower $locale] set loclist [list $locale] while {-1 !=[set pos [string last "_" $locale]]} { set locale [string range $locale 0 $pos-1] if { "_" ne [string index $locale end] } { @@ -377,55 +347,20 @@ # # Fetch the list of locales used to look up strings, ordered from # most preferred to least preferred. # # Arguments: -# New location list +# None. # # Results: # Returns an ordered list of the locales preferred by the user. -proc msgcat::mcpreferences {args} { +proc msgcat::mcpreferences {} { variable Loclist - - if {[llength $args] > 0} { - # args is the new loclist - if {![ListEqualString $args $Loclist]} { - set Loclist $args - - # locale not loaded jet - LoadAll $Loclist - # Invoke callback - Invoke changecmd $Loclist - } - } return $Loclist } -# msgcat::ListStringEqual -- -# -# Compare two strings for equal string contents -# -# Arguments: -# list1 first list -# list2 second list -# -# Results: -# 1 if lists of strings are identical, 0 otherwise - -proc msgcat::ListEqualString {list1 list2} { - if {[llength $list1] != [llength $list2]} { - return 0 - } - foreach item1 $list1 item2 $list2 { - if {$item1 ne $item2} { - return 0 - } - } - return 1 -} - # msgcat::mcloadedlocales -- # # Get or change the list of currently loaded default locales # # The following subcommands are available: @@ -505,95 +440,65 @@ # locale package locale (only set subcommand) # # Results: # Empty string, if not stated differently for the subcommand -proc msgcat::mcpackagelocale {subcommand args} { +proc msgcat::mcpackagelocale {subcommand {locale ""}} { # todo: implement using an ensemble variable Loclist variable LoadedLocales variable Msgs variable PackageConfig # Check option # check if required item is exactly provided - if { [llength $args] > 0 - && $subcommand in {"get" "isset" "unset" "loaded" "clear"} } { - return -code error "wrong # args: should be\ - \"[lrange [info level 0] 0 1]\"" + if {[llength [info level 0]] == 2} { + # locale not given + unset locale + } else { + # locale given + if {$subcommand in + {"get" "isset" "unset" "preferences" "loaded" "clear"} } { + return -code error "wrong # args: should be\ + \"[lrange [info level 0] 0 1]\"" + } + set locale [string tolower $locale] } - set ns [PackageNamespaceGet] + set ns [uplevel 1 {::namespace current}] switch -exact -- $subcommand { get { return [lindex [PackagePreferences $ns] 0] } + preferences { return [PackagePreferences $ns] } loaded { return [PackageLocales $ns] } - present { - if {[llength $args] != 1} { - return -code error "wrong # args: should be\ - \"[lrange [info level 0] 0 1] locale\"" - } - return [expr {[string tolower [lindex $args 0]] - in [PackageLocales $ns]} ] - } + present { return [expr {$locale in [PackageLocales $ns]} ]} isset { return [dict exists $PackageConfig loclist $ns] } - set - preferences { - # set a package locale or add a package locale - set fSet [expr {$subcommand eq "set"}] - - # Check parameter - if {$fSet && 1 < [llength $args] } { - return -code error "wrong # args: should be\ - \"[lrange [info level 0] 0 1] ?locale?\"" - } - - # > Return preferences if no parameter - if {!$fSet && 0 == [llength $args] } { - return [PackagePreferences $ns] - } + set { # set a package locale or add a package locale # Copy the default locale if no package locale set so far if {![dict exists $PackageConfig loclist $ns]} { dict set PackageConfig loclist $ns $Loclist dict set PackageConfig loadedlocales $ns $LoadedLocales } - # No argument for set: return current package locale - # The difference to no argument and subcommand "preferences" is, - # that "preferences" does not set the package locale property. - # This case is processed above, so no check for fSet here - if { 0 == [llength $args] } { - return [lindex [dict get $PackageConfig loclist $ns] 0] - } - - # Get new loclist - if {$fSet} { - set loclist [mcutil getpreferences [lindex $args 0]] - } else { - set loclist $args - } - - # Check if not changed to return imediately - if { [ListEqualString $loclist\ - [dict get $PackageConfig loclist $ns]] } { - if {$fSet} { - return [lindex $loclist 0] - } - return $loclist + # Check if changed + set loclist [dict get $PackageConfig loclist $ns] + if {! [info exists locale] || $locale eq [lindex $loclist 0] } { + return [lindex $loclist 0] } # Change loclist + set loclist [GetPreferences $locale] + set locale [lindex $loclist 0] dict set PackageConfig loclist $ns $loclist # load eventual missing locales set loadedLocales [dict get $PackageConfig loadedlocales $ns] + if {$locale in $loadedLocales} { return $locale } set loadLocales [ListComplement $loadedLocales $loclist] dict set PackageConfig loadedlocales $ns\ [concat $loadedLocales $loadLocales] Load $ns $loadLocales - if {$fSet} { - return [lindex $loclist 0] - } - return $loclist + return $locale } clear { # Remove all locales not contained in Loclist if {![dict exists $PackageConfig loclist $ns]} { return -code error "clear only when package locale set" } @@ -644,29 +549,20 @@ proc msgcat::mcforgetpackage {} { # todo: this may be implemented using an ensemble variable PackageConfig variable Msgs - set ns [PackageNamespaceGet] + set ns [uplevel 1 {::namespace current}] # Remove MC items dict unset Msgs $ns # Remove config items foreach key [dict keys $PackageConfig] { dict unset PackageConfig $key $ns } return } -# msgcat::mcgetmynamespace -- -# -# Return the package namespace of the caller -# This consideres to be called from a class or object. - -proc msgcat::mcpackagenamespaceget {} { - return [PackageNamespaceGet] -} - # msgcat::mcpackageconfig -- # # Get or modify the per caller namespace (e.g. packages) config options. # # Available subcommands are: @@ -718,11 +614,11 @@ # Depends on the subcommand and option and is described there proc msgcat::mcpackageconfig {subcommand option {value ""}} { variable PackageConfig # get namespace - set ns [PackageNamespaceGet] + set ns [uplevel 1 {::namespace current}] if {$option ni {"mcfolder" "loadcmd" "changecmd" "unknowncmd"}} { return -code error "bad option \"$option\": must be mcfolder, loadcmd,\ changecmd, or unknowncmd" } @@ -858,11 +754,12 @@ # # Results: # Returns the number of message catalogs that were loaded. proc msgcat::mcload {langdir} { - tailcall mcpackageconfig set mcfolder $langdir + return [uplevel 1 [list\ + [namespace origin mcpackageconfig] set mcfolder $langdir]] } # msgcat::LoadAll -- # # Load a list of locales for all packages not having a package locale @@ -1024,11 +921,11 @@ variable Msgs if {[llength [info level 0]] == 3} { ;# dest not specified set dest $src } - set ns [PackageNamespaceGet] + set ns [uplevel 1 [list ::namespace current]] set locale [string tolower $locale] dict set Msgs $ns $locale $src $dest return $dest @@ -1052,11 +949,11 @@ if {![info exists FileLocale]} { return -code error "must only be used inside a message catalog loaded\ with ::msgcat::mcload" } - tailcall mcset $FileLocale $src $dest + return [uplevel 1 [list [namespace origin mcset] $FileLocale $src $dest]] } # msgcat::mcmset -- # # Set the translation for multiple strings in a specified locale. @@ -1076,11 +973,11 @@ return -code error "bad translation list:\ should be \"[lindex [info level 0] 0] locale {src dest ...}\"" } set locale [string tolower $locale] - set ns [PackageNamespaceGet] + set ns [uplevel 1 [list ::namespace current]] foreach {src dest} $pairs { dict set Msgs $ns $locale $src $dest } @@ -1103,11 +1000,11 @@ if {![info exists FileLocale]} { return -code error "must only be used inside a message catalog loaded\ with ::msgcat::mcload" } - tailcall mcmset $FileLocale $pairs + return [uplevel 1 [list [namespace origin mcmset] $FileLocale $pairs]] } # msgcat::mcunknown -- # # This routine is called by msgcat::mc if a translation cannot @@ -1114,11 +1011,11 @@ # be found for a string and no unknowncmd is set for the current # package. This routine is intended to be replaced # by an application specific routine for error reporting # purposes. The default behavior is to return the source string. # If additional args are specified, the format command will be used -# to work them into the translated string. +# to work them into the traslated string. # # Arguments: # locale The current locale. # src The string to be translated. # args Args to pass to the format command @@ -1125,23 +1022,23 @@ # # Results: # Returns the translated value. proc msgcat::mcunknown {args} { - tailcall DefaultUnknown {*}$args + return [uplevel 1 [list [namespace origin DefaultUnknown] {*}$args]] } # msgcat::DefaultUnknown -- # # This routine is called by msgcat::mc if a translation cannot # be found for a string in the following circumstances: # - Default global handler, if mcunknown is not redefined. # - Per package handler, if the package sets unknowncmd to the empty # string. -# It returns the source string if the argument list is empty. +# It returna the source string if the argument list is empty. # If additional args are specified, the format command will be used -# to work them into the translated string. +# to work them into the traslated string. # # Arguments: # locale (unused) The current locale. # src The string to be translated. # args Args to pass to the format command @@ -1168,13 +1065,12 @@ # Results: # Returns the length of the longest translated string. proc msgcat::mcmax {args} { set max 0 - set ns [PackageNamespaceGet] foreach string $args { - set translated [uplevel 1 [list [namespace origin mcn] $ns $string]] + set translated [uplevel 1 [list [namespace origin mc] $string]] set len [string length $translated] if {$len>$max} { set max $len } } @@ -1181,11 +1077,11 @@ return $max } # Convert the locale values stored in environment variables to a form # suitable for passing to [mclocale] -proc msgcat::mcutil::ConvertLocale {value} { +proc msgcat::ConvertLocale {value} { # Assume $value is of form: $language[_$territory][.$codeset][@modifier] # Convert to form: $language[_$territory][_$modifier] # # Comment out expanded RE version -- bugs alleged # regexp -expanded { @@ -1208,80 +1104,53 @@ append ret _$modifier } return $ret } -# helper function to find package namespace of stack-frame -2 -# There are 4 possibilities: -# - called from a proc -# - called within a class definition script -# - called from an class defined oo object -# - called from a classless oo object -proc ::msgcat::PackageNamespaceGet {} { - uplevel 2 { - # Check self namespace to determine environment - switch -exact -- [namespace which self] { - {::oo::define::self} { - # We are within a class definition - return [namespace qualifiers [self]] - } - {::oo::Helpers::self} { - # We are within an object - set Class [info object class [self]] - # Check for classless defined object - if {$Class eq {::oo::object}} { - return [namespace qualifiers [self]] - } - # Class defined object - return [namespace qualifiers $Class] - } - default { - # Not in object environment - return [namespace current] - } - } - } -} - # Initialize the default locale -proc msgcat::mcutil::getsystemlocale {} { +proc msgcat::Init {} { global env # # set default locale, try to get from environment # foreach varName {LC_ALL LC_MESSAGES LANG} { if {[info exists env($varName)] && ("" ne $env($varName))} { - if {![catch { ConvertLocale $env($varName) } locale]} { - return $locale + if {![catch { + mclocale [ConvertLocale $env($varName)] + }]} { + return } } } # # On Darwin, fallback to current CFLocale identifier if available. # if {[info exists ::tcl::mac::locale] && $::tcl::mac::locale ne ""} { - if {![catch { ConvertLocale $::tcl::mac::locale } locale]} { - return $locale + if {![catch { + mclocale [ConvertLocale $::tcl::mac::locale] + }]} { + return } } # # The rest of this routine is special processing for Windows or # Cygwin. All other platforms, get out now. # if {([info sharedlibextension] ne ".dll") || [catch {package require registry}]} { - return C + mclocale C + return } # # On Windows or Cygwin, try to set locale depending on registry # settings, or fall back on locale of "C". # # On Vista and later: # HCU/Control Panel/Desktop : PreferredUILanguages is for language packs, - # HCU/Control Panel/International : localName is the default locale. + # HCU/Control Pannel/International : localName is the default locale. # # They contain the local string as RFC5646, composed of: # [a-z]{2,3} : language # -[a-z]{4} : script (optional, translated by table Latn->latin) # -[a-z]{2}|[0-9]{3} : territory (optional, numerical region codes not used) @@ -1299,42 +1168,43 @@ } set modifierDict [dict create latn latin cyrl cyrillic] if {[dict exists $modifierDict $script]} { append locale @ [dict get $modifierDict $script] } - if {![catch {ConvertLocale $locale} locale]} { - return $locale + if {![catch {mclocale [ConvertLocale $locale]}]} { + return } } } # then check value locale which contains a numerical language ID if {[catch { set locale [registry get $key "locale"] }]} { - return C + mclocale C + return } # # Keep trying to match against smaller and smaller suffixes - # of the registry value, since the latter hexdigits appear - # to determine general language and earlier hexdigits determine + # of the registry value, since the latter hexadigits appear + # to determine general language and earlier hexadigits determine # more precise information, such as territory. For example, # 0409 - English - United States # 0809 - English - United Kingdom # Add more translations to the WinRegToISO639 array above. # variable WinRegToISO639 set locale [string tolower $locale] while {[string length $locale]} { if {![catch { - ConvertLocale [dict get $WinRegToISO639 $locale] - } localeOut]} { - return $localeOut + mclocale [ConvertLocale [dict get $WinRegToISO639 $locale]] + }]} { + return } set locale [string range $locale 1 end] } # # No translation known. Fall back on "C" locale # - return C + mclocale C } -msgcat::mclocale [msgcat::mcutil getsystemlocale] +msgcat::Init Index: library/msgcat/pkgIndex.tcl ================================================================== --- library/msgcat/pkgIndex.tcl +++ library/msgcat/pkgIndex.tcl @@ -1,2 +1,2 @@ -if {![package vsatisfies [package provide Tcl] 8.7-]} {return} -package ifneeded msgcat 1.7.0 [list source [file join $dir msgcat.tcl]] +if {![package vsatisfies [package provide Tcl] 8.5-]} {return} +package ifneeded msgcat 1.6.1 [list source [file join $dir msgcat.tcl]] Index: library/msgs/ar.msg ================================================================== --- library/msgs/ar.msg +++ library/msgs/ar.msg @@ -1,54 +1,54 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset ar DAYS_OF_WEEK_ABBREV [list \ - "Ø­"\ - "Ù†"\ - "Ø«"\ - "ر"\ - "Ø®"\ - "ج"\ - "س"] + "\u062d"\ + "\u0646"\ + "\u062b"\ + "\u0631"\ + "\u062e"\ + "\u062c"\ + "\u0633"] ::msgcat::mcset ar DAYS_OF_WEEK_FULL [list \ - "الأحد"\ - "الاثنين"\ - "الثلاثاء"\ - "الأربعاء"\ - "الخميس"\ - "الجمعة"\ - "السبت"] + "\u0627\u0644\u0623\u062d\u062f"\ + "\u0627\u0644\u0627\u062b\u0646\u064a\u0646"\ + "\u0627\u0644\u062b\u0644\u0627\u062b\u0627\u0621"\ + "\u0627\u0644\u0623\u0631\u0628\u0639\u0627\u0621"\ + "\u0627\u0644\u062e\u0645\u064a\u0633"\ + "\u0627\u0644\u062c\u0645\u0639\u0629"\ + "\u0627\u0644\u0633\u0628\u062a"] ::msgcat::mcset ar MONTHS_ABBREV [list \ - "ينا"\ - "Ùبر"\ - "مار"\ - "أبر"\ - "ماي"\ - "يون"\ - "يول"\ - "أغس"\ - "سبت"\ - "أكت"\ - "نوÙ"\ - "ديس"\ + "\u064a\u0646\u0627"\ + "\u0641\u0628\u0631"\ + "\u0645\u0627\u0631"\ + "\u0623\u0628\u0631"\ + "\u0645\u0627\u064a"\ + "\u064a\u0648\u0646"\ + "\u064a\u0648\u0644"\ + "\u0623\u063a\u0633"\ + "\u0633\u0628\u062a"\ + "\u0623\u0643\u062a"\ + "\u0646\u0648\u0641"\ + "\u062f\u064a\u0633"\ ""] ::msgcat::mcset ar MONTHS_FULL [list \ - "يناير"\ - "Ùبراير"\ - "مارس"\ - "أبريل"\ - "مايو"\ - "يونيو"\ - "يوليو"\ - "أغسطس"\ - "سبتمبر"\ - "أكتوبر"\ - "نوÙمبر"\ - "ديسمبر"\ + "\u064a\u0646\u0627\u064a\u0631"\ + "\u0641\u0628\u0631\u0627\u064a\u0631"\ + "\u0645\u0627\u0631\u0633"\ + "\u0623\u0628\u0631\u064a\u0644"\ + "\u0645\u0627\u064a\u0648"\ + "\u064a\u0648\u0646\u064a\u0648"\ + "\u064a\u0648\u0644\u064a\u0648"\ + "\u0623\u063a\u0633\u0637\u0633"\ + "\u0633\u0628\u062a\u0645\u0628\u0631"\ + "\u0623\u0643\u062a\u0648\u0628\u0631"\ + "\u0646\u0648\u0641\u0645\u0628\u0631"\ + "\u062f\u064a\u0633\u0645\u0628\u0631"\ ""] - ::msgcat::mcset ar BCE "Ù‚.Ù…" - ::msgcat::mcset ar CE "Ù…" - ::msgcat::mcset ar AM "ص" - ::msgcat::mcset ar PM "Ù…" + ::msgcat::mcset ar BCE "\u0642.\u0645" + ::msgcat::mcset ar CE "\u0645" + ::msgcat::mcset ar AM "\u0635" + ::msgcat::mcset ar PM "\u0645" ::msgcat::mcset ar DATE_FORMAT "%d/%m/%Y" ::msgcat::mcset ar TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset ar DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z" } Index: library/msgs/ar_jo.msg ================================================================== --- library/msgs/ar_jo.msg +++ library/msgs/ar_jo.msg @@ -1,39 +1,39 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset ar_JO DAYS_OF_WEEK_ABBREV [list \ - "الأحد"\ - "الاثنين"\ - "الثلاثاء"\ - "الأربعاء"\ - "الخميس"\ - "الجمعة"\ - "السبت"] + "\u0627\u0644\u0623\u062d\u062f"\ + "\u0627\u0644\u0627\u062b\u0646\u064a\u0646"\ + "\u0627\u0644\u062b\u0644\u0627\u062b\u0627\u0621"\ + "\u0627\u0644\u0623\u0631\u0628\u0639\u0627\u0621"\ + "\u0627\u0644\u062e\u0645\u064a\u0633"\ + "\u0627\u0644\u062c\u0645\u0639\u0629"\ + "\u0627\u0644\u0633\u0628\u062a"] ::msgcat::mcset ar_JO MONTHS_ABBREV [list \ - "كانون الثاني"\ - "شباط"\ - "آذار"\ - "نيسان"\ - "نوار"\ - "حزيران"\ - "تموز"\ - "آب"\ - "أيلول"\ - "تشرين الأول"\ - "تشرين الثاني"\ - "كانون الأول"\ + "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ + "\u0634\u0628\u0627\u0637"\ + "\u0622\u0630\u0627\u0631"\ + "\u0646\u064a\u0633\u0627\u0646"\ + "\u0646\u0648\u0627\u0631"\ + "\u062d\u0632\u064a\u0631\u0627\u0646"\ + "\u062a\u0645\u0648\u0632"\ + "\u0622\u0628"\ + "\u0623\u064a\u0644\u0648\u0644"\ + "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\ + "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ + "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\ ""] ::msgcat::mcset ar_JO MONTHS_FULL [list \ - "كانون الثاني"\ - "شباط"\ - "آذار"\ - "نيسان"\ - "نوار"\ - "حزيران"\ - "تموز"\ - "آب"\ - "أيلول"\ - "تشرين الأول"\ - "تشرين الثاني"\ - "كانون الأول"\ + "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ + "\u0634\u0628\u0627\u0637"\ + "\u0622\u0630\u0627\u0631"\ + "\u0646\u064a\u0633\u0627\u0646"\ + "\u0646\u0648\u0627\u0631"\ + "\u062d\u0632\u064a\u0631\u0627\u0646"\ + "\u062a\u0645\u0648\u0632"\ + "\u0622\u0628"\ + "\u0623\u064a\u0644\u0648\u0644"\ + "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\ + "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ + "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\ ""] } Index: library/msgs/ar_lb.msg ================================================================== --- library/msgs/ar_lb.msg +++ library/msgs/ar_lb.msg @@ -1,39 +1,39 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset ar_LB DAYS_OF_WEEK_ABBREV [list \ - "الأحد"\ - "الاثنين"\ - "الثلاثاء"\ - "الأربعاء"\ - "الخميس"\ - "الجمعة"\ - "السبت"] + "\u0627\u0644\u0623\u062d\u062f"\ + "\u0627\u0644\u0627\u062b\u0646\u064a\u0646"\ + "\u0627\u0644\u062b\u0644\u0627\u062b\u0627\u0621"\ + "\u0627\u0644\u0623\u0631\u0628\u0639\u0627\u0621"\ + "\u0627\u0644\u062e\u0645\u064a\u0633"\ + "\u0627\u0644\u062c\u0645\u0639\u0629"\ + "\u0627\u0644\u0633\u0628\u062a"] ::msgcat::mcset ar_LB MONTHS_ABBREV [list \ - "كانون الثاني"\ - "شباط"\ - "آذار"\ - "نيسان"\ - "نوار"\ - "حزيران"\ - "تموز"\ - "آب"\ - "أيلول"\ - "تشرين الأول"\ - "تشرين الثاني"\ - "كانون الأول"\ + "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ + "\u0634\u0628\u0627\u0637"\ + "\u0622\u0630\u0627\u0631"\ + "\u0646\u064a\u0633\u0627\u0646"\ + "\u0646\u0648\u0627\u0631"\ + "\u062d\u0632\u064a\u0631\u0627\u0646"\ + "\u062a\u0645\u0648\u0632"\ + "\u0622\u0628"\ + "\u0623\u064a\u0644\u0648\u0644"\ + "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\ + "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ + "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\ ""] ::msgcat::mcset ar_LB MONTHS_FULL [list \ - "كانون الثاني"\ - "شباط"\ - "آذار"\ - "نيسان"\ - "نوار"\ - "حزيران"\ - "تموز"\ - "آب"\ - "أيلول"\ - "تشرين الأول"\ - "تشرين الثاني"\ - "كانون الأول"\ + "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ + "\u0634\u0628\u0627\u0637"\ + "\u0622\u0630\u0627\u0631"\ + "\u0646\u064a\u0633\u0627\u0646"\ + "\u0646\u0648\u0627\u0631"\ + "\u062d\u0632\u064a\u0631\u0627\u0646"\ + "\u062a\u0645\u0648\u0632"\ + "\u0622\u0628"\ + "\u0623\u064a\u0644\u0648\u0644"\ + "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\ + "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ + "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\ ""] } Index: library/msgs/ar_sy.msg ================================================================== --- library/msgs/ar_sy.msg +++ library/msgs/ar_sy.msg @@ -1,39 +1,39 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset ar_SY DAYS_OF_WEEK_ABBREV [list \ - "الأحد"\ - "الاثنين"\ - "الثلاثاء"\ - "الأربعاء"\ - "الخميس"\ - "الجمعة"\ - "السبت"] + "\u0627\u0644\u0623\u062d\u062f"\ + "\u0627\u0644\u0627\u062b\u0646\u064a\u0646"\ + "\u0627\u0644\u062b\u0644\u0627\u062b\u0627\u0621"\ + "\u0627\u0644\u0623\u0631\u0628\u0639\u0627\u0621"\ + "\u0627\u0644\u062e\u0645\u064a\u0633"\ + "\u0627\u0644\u062c\u0645\u0639\u0629"\ + "\u0627\u0644\u0633\u0628\u062a"] ::msgcat::mcset ar_SY MONTHS_ABBREV [list \ - "كانون الثاني"\ - "شباط"\ - "آذار"\ - "نيسان"\ - "نوار"\ - "حزيران"\ - "تموز"\ - "آب"\ - "أيلول"\ - "تشرين الأول"\ - "تشرين الثاني"\ - "كانون الأول"\ + "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ + "\u0634\u0628\u0627\u0637"\ + "\u0622\u0630\u0627\u0631"\ + "\u0646\u064a\u0633\u0627\u0646"\ + "\u0646\u0648\u0627\u0631"\ + "\u062d\u0632\u064a\u0631\u0627\u0646"\ + "\u062a\u0645\u0648\u0632"\ + "\u0622\u0628"\ + "\u0623\u064a\u0644\u0648\u0644"\ + "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\ + "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ + "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\ ""] ::msgcat::mcset ar_SY MONTHS_FULL [list \ - "كانون الثاني"\ - "شباط"\ - "آذار"\ - "نيسان"\ - "نواران"\ - "حزير"\ - "تموز"\ - "آب"\ - "أيلول"\ - "تشرين الأول"\ - "تشرين الثاني"\ - "كانون الأول"\ + "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ + "\u0634\u0628\u0627\u0637"\ + "\u0622\u0630\u0627\u0631"\ + "\u0646\u064a\u0633\u0627\u0646"\ + "\u0646\u0648\u0627\u0631\u0627\u0646"\ + "\u062d\u0632\u064a\u0631"\ + "\u062a\u0645\u0648\u0632"\ + "\u0622\u0628"\ + "\u0623\u064a\u0644\u0648\u0644"\ + "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\ + "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ + "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\ ""] } Index: library/msgs/be.msg ================================================================== --- library/msgs/be.msg +++ library/msgs/be.msg @@ -1,52 +1,52 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset be DAYS_OF_WEEK_ABBREV [list \ - "нд"\ - "пн"\ - "ат"\ - "ÑÑ€"\ - "чц"\ - "пт"\ - "Ñб"] + "\u043d\u0434"\ + "\u043f\u043d"\ + "\u0430\u0442"\ + "\u0441\u0440"\ + "\u0447\u0446"\ + "\u043f\u0442"\ + "\u0441\u0431"] ::msgcat::mcset be DAYS_OF_WEEK_FULL [list \ - "нÑдзелÑ"\ - "панÑдзелак"\ - "аўторак"\ - "Ñерада"\ - "чацвер"\ - "пÑтніца"\ - "Ñубота"] + "\u043d\u044f\u0434\u0437\u0435\u043b\u044f"\ + "\u043f\u0430\u043d\u044f\u0434\u0437\u0435\u043b\u0430\u043a"\ + "\u0430\u045e\u0442\u043e\u0440\u0430\u043a"\ + "\u0441\u0435\u0440\u0430\u0434\u0430"\ + "\u0447\u0430\u0446\u0432\u0435\u0440"\ + "\u043f\u044f\u0442\u043d\u0456\u0446\u0430"\ + "\u0441\u0443\u0431\u043e\u0442\u0430"] ::msgcat::mcset be MONTHS_ABBREV [list \ - "Ñтд"\ - "лют"\ - "Ñкв"\ - "крÑ"\ - "май"\ - "чрв"\ - "лпн"\ - "жнв"\ - "врÑ"\ - "кÑÑ‚"\ - "лÑÑ‚"\ - "Ñнж"\ + "\u0441\u0442\u0434"\ + "\u043b\u044e\u0442"\ + "\u0441\u043a\u0432"\ + "\u043a\u0440\u0441"\ + "\u043c\u0430\u0439"\ + "\u0447\u0440\u0432"\ + "\u043b\u043f\u043d"\ + "\u0436\u043d\u0432"\ + "\u0432\u0440\u0441"\ + "\u043a\u0441\u0442"\ + "\u043b\u0441\u0442"\ + "\u0441\u043d\u0436"\ ""] ::msgcat::mcset be MONTHS_FULL [list \ - "ÑтудзенÑ"\ - "лютага"\ - "Ñакавіка"\ - "краÑавіка"\ - "маÑ"\ - "чрвенÑ"\ - "ліпенÑ"\ - "жніўнÑ"\ - "вераÑнÑ"\ - "каÑтрычніка"\ - "лиÑтапада"\ - "ÑнежнÑ"\ + "\u0441\u0442\u0443\u0434\u0437\u0435\u043d\u044f"\ + "\u043b\u044e\u0442\u0430\u0433\u0430"\ + "\u0441\u0430\u043a\u0430\u0432\u0456\u043a\u0430"\ + "\u043a\u0440\u0430\u0441\u0430\u0432\u0456\u043a\u0430"\ + "\u043c\u0430\u044f"\ + "\u0447\u0440\u0432\u0435\u043d\u044f"\ + "\u043b\u0456\u043f\u0435\u043d\u044f"\ + "\u0436\u043d\u0456\u045e\u043d\u044f"\ + "\u0432\u0435\u0440\u0430\u0441\u043d\u044f"\ + "\u043a\u0430\u0441\u0442\u0440\u044b\u0447\u043d\u0456\u043a\u0430"\ + "\u043b\u0438\u0441\u0442\u0430\u043f\u0430\u0434\u0430"\ + "\u0441\u043d\u0435\u0436\u043d\u044f"\ ""] - ::msgcat::mcset be BCE "да н.е." - ::msgcat::mcset be CE "н.е." + ::msgcat::mcset be BCE "\u0434\u0430 \u043d.\u0435." + ::msgcat::mcset be CE "\u043d.\u0435." ::msgcat::mcset be DATE_FORMAT "%e.%m.%Y" ::msgcat::mcset be TIME_FORMAT "%k.%M.%S" ::msgcat::mcset be DATE_TIME_FORMAT "%e.%m.%Y %k.%M.%S %z" } Index: library/msgs/bg.msg ================================================================== --- library/msgs/bg.msg +++ library/msgs/bg.msg @@ -1,23 +1,23 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset bg DAYS_OF_WEEK_ABBREV [list \ - "Ðд"\ - "Пн"\ - "Ð’Ñ‚"\ - "Ср"\ - "Чт"\ - "Пт"\ - "Сб"] + "\u041d\u0434"\ + "\u041f\u043d"\ + "\u0412\u0442"\ + "\u0421\u0440"\ + "\u0427\u0442"\ + "\u041f\u0442"\ + "\u0421\u0431"] ::msgcat::mcset bg DAYS_OF_WEEK_FULL [list \ - "ÐеделÑ"\ - "Понеделник"\ - "Вторник"\ - "СрÑда"\ - "Четвъртък"\ - "Петък"\ - "Събота"] + "\u041d\u0435\u0434\u0435\u043b\u044f"\ + "\u041f\u043e\u043d\u0435\u0434\u0435\u043b\u043d\u0438\u043a"\ + "\u0412\u0442\u043e\u0440\u043d\u0438\u043a"\ + "\u0421\u0440\u044f\u0434\u0430"\ + "\u0427\u0435\u0442\u0432\u044a\u0440\u0442\u044a\u043a"\ + "\u041f\u0435\u0442\u044a\u043a"\ + "\u0421\u044a\u0431\u043e\u0442\u0430"] ::msgcat::mcset bg MONTHS_ABBREV [list \ "I"\ "II"\ "III"\ "IV"\ @@ -29,24 +29,24 @@ "X"\ "XI"\ "XII"\ ""] ::msgcat::mcset bg MONTHS_FULL [list \ - "Януари"\ - "Февруари"\ - "Март"\ - "Ðприл"\ - "Май"\ - "Юни"\ - "Юли"\ - "ÐвгуÑÑ‚"\ - "Септември"\ - "Октомври"\ - "Ðоември"\ - "Декември"\ + "\u042f\u043d\u0443\u0430\u0440\u0438"\ + "\u0424\u0435\u0432\u0440\u0443\u0430\u0440\u0438"\ + "\u041c\u0430\u0440\u0442"\ + "\u0410\u043f\u0440\u0438\u043b"\ + "\u041c\u0430\u0439"\ + "\u042e\u043d\u0438"\ + "\u042e\u043b\u0438"\ + "\u0410\u0432\u0433\u0443\u0441\u0442"\ + "\u0421\u0435\u043f\u0442\u0435\u043c\u0432\u0440\u0438"\ + "\u041e\u043a\u0442\u043e\u043c\u0432\u0440\u0438"\ + "\u041d\u043e\u0435\u043c\u0432\u0440\u0438"\ + "\u0414\u0435\u043a\u0435\u043c\u0432\u0440\u0438"\ ""] - ::msgcat::mcset bg BCE "пр.н.е." - ::msgcat::mcset bg CE "н.е." + ::msgcat::mcset bg BCE "\u043f\u0440.\u043d.\u0435." + ::msgcat::mcset bg CE "\u043d.\u0435." ::msgcat::mcset bg DATE_FORMAT "%Y-%m-%e" ::msgcat::mcset bg TIME_FORMAT "%k:%M:%S" ::msgcat::mcset bg DATE_TIME_FORMAT "%Y-%m-%e %k:%M:%S %z" } Index: library/msgs/bn.msg ================================================================== --- library/msgs/bn.msg +++ library/msgs/bn.msg @@ -1,49 +1,49 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset bn DAYS_OF_WEEK_ABBREV [list \ - "রবি"\ - "সোম"\ - "মঙগল"\ - "বà§à¦§"\ - "বৃহসà§à¦ªà¦¤à¦¿"\ - "শà§à¦•à§à¦°"\ - "শনি"] + "\u09b0\u09ac\u09bf"\ + "\u09b8\u09cb\u09ae"\ + "\u09ae\u0999\u0997\u09b2"\ + "\u09ac\u09c1\u09a7"\ + "\u09ac\u09c3\u09b9\u09b8\u09cd\u09aa\u09a4\u09bf"\ + "\u09b6\u09c1\u0995\u09cd\u09b0"\ + "\u09b6\u09a8\u09bf"] ::msgcat::mcset bn DAYS_OF_WEEK_FULL [list \ - "রবিবার"\ - "সোমবার"\ - "মঙগলবার"\ - "বà§à¦§à¦¬à¦¾à¦°"\ - "বৃহসà§à¦ªà¦¤à¦¿à¦¬à¦¾à¦°"\ - "শà§à¦•à§à¦°à¦¬à¦¾à¦°"\ - "শনিবার"] + "\u09b0\u09ac\u09bf\u09ac\u09be\u09b0"\ + "\u09b8\u09cb\u09ae\u09ac\u09be\u09b0"\ + "\u09ae\u0999\u0997\u09b2\u09ac\u09be\u09b0"\ + "\u09ac\u09c1\u09a7\u09ac\u09be\u09b0"\ + "\u09ac\u09c3\u09b9\u09b8\u09cd\u09aa\u09a4\u09bf\u09ac\u09be\u09b0"\ + "\u09b6\u09c1\u0995\u09cd\u09b0\u09ac\u09be\u09b0"\ + "\u09b6\u09a8\u09bf\u09ac\u09be\u09b0"] ::msgcat::mcset bn MONTHS_ABBREV [list \ - "জানà§à§Ÿà¦¾à¦°à§€"\ - "ফেবà§à¦°à§à§Ÿà¦¾à¦°à§€"\ - "মারà§à¦š"\ - "à¦à¦ªà§à¦°à¦¿à¦²"\ - "মে"\ - "জà§à¦¨"\ - "জà§à¦²à¦¾à¦‡"\ - "আগসà§à¦Ÿ"\ - "সেপà§à¦Ÿà§‡à¦®à§à¦¬à¦°"\ - "অকà§à¦Ÿà§‹à¦¬à¦°"\ - "নভেমà§à¦¬à¦°"\ - "ডিসেমà§à¦¬à¦°"\ + "\u099c\u09be\u09a8\u09c1\u09df\u09be\u09b0\u09c0"\ + "\u09ab\u09c7\u09ac\u09cd\u09b0\u09c1\u09df\u09be\u09b0\u09c0"\ + "\u09ae\u09be\u09b0\u09cd\u099a"\ + "\u098f\u09aa\u09cd\u09b0\u09bf\u09b2"\ + "\u09ae\u09c7"\ + "\u099c\u09c1\u09a8"\ + "\u099c\u09c1\u09b2\u09be\u0987"\ + "\u0986\u0997\u09b8\u09cd\u099f"\ + "\u09b8\u09c7\u09aa\u09cd\u099f\u09c7\u09ae\u09cd\u09ac\u09b0"\ + "\u0985\u0995\u09cd\u099f\u09cb\u09ac\u09b0"\ + "\u09a8\u09ad\u09c7\u09ae\u09cd\u09ac\u09b0"\ + "\u09a1\u09bf\u09b8\u09c7\u09ae\u09cd\u09ac\u09b0"\ ""] ::msgcat::mcset bn MONTHS_FULL [list \ - "জানà§à§Ÿà¦¾à¦°à§€"\ - "ফেবà§à¦°à§à§Ÿà¦¾à¦°à§€"\ - "মারà§à¦š"\ - "à¦à¦ªà§à¦°à¦¿à¦²"\ - "মে"\ - "জà§à¦¨"\ - "জà§à¦²à¦¾à¦‡"\ - "আগসà§à¦Ÿ"\ - "সেপà§à¦Ÿà§‡à¦®à§à¦¬à¦°"\ - "অকà§à¦Ÿà§‹à¦¬à¦°"\ - "নভেমà§à¦¬à¦°"\ - "ডিসেমà§à¦¬à¦°"\ + "\u099c\u09be\u09a8\u09c1\u09df\u09be\u09b0\u09c0"\ + "\u09ab\u09c7\u09ac\u09cd\u09b0\u09c1\u09df\u09be\u09b0\u09c0"\ + "\u09ae\u09be\u09b0\u09cd\u099a"\ + "\u098f\u09aa\u09cd\u09b0\u09bf\u09b2"\ + "\u09ae\u09c7"\ + "\u099c\u09c1\u09a8"\ + "\u099c\u09c1\u09b2\u09be\u0987"\ + "\u0986\u0997\u09b8\u09cd\u099f"\ + "\u09b8\u09c7\u09aa\u09cd\u099f\u09c7\u09ae\u09cd\u09ac\u09b0"\ + "\u0985\u0995\u09cd\u099f\u09cb\u09ac\u09b0"\ + "\u09a8\u09ad\u09c7\u09ae\u09cd\u09ac\u09b0"\ + "\u09a1\u09bf\u09b8\u09c7\u09ae\u09cd\u09ac\u09b0"\ ""] - ::msgcat::mcset bn AM "পূরà§à¦¬à¦¾à¦¹à§à¦£" - ::msgcat::mcset bn PM "অপরাহà§à¦£" + ::msgcat::mcset bn AM "\u09aa\u09c2\u09b0\u09cd\u09ac\u09be\u09b9\u09cd\u09a3" + ::msgcat::mcset bn PM "\u0985\u09aa\u09b0\u09be\u09b9\u09cd\u09a3" } Index: library/msgs/ca.msg ================================================================== --- library/msgs/ca.msg +++ library/msgs/ca.msg @@ -17,11 +17,11 @@ "divendres"\ "dissabte"] ::msgcat::mcset ca MONTHS_ABBREV [list \ "gen."\ "feb."\ - "març"\ + "mar\u00e7"\ "abr."\ "maig"\ "juny"\ "jul."\ "ag."\ @@ -31,11 +31,11 @@ "des."\ ""] ::msgcat::mcset ca MONTHS_FULL [list \ "gener"\ "febrer"\ - "març"\ + "mar\u00e7"\ "abril"\ "maig"\ "juny"\ "juliol"\ "agost"\ Index: library/msgs/cs.msg ================================================================== --- library/msgs/cs.msg +++ library/msgs/cs.msg @@ -1,22 +1,22 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset cs DAYS_OF_WEEK_ABBREV [list \ "Ne"\ "Po"\ - "Út"\ + "\u00dat"\ "St"\ - "ÄŒt"\ - "Pá"\ + "\u010ct"\ + "P\u00e1"\ "So"] ::msgcat::mcset cs DAYS_OF_WEEK_FULL [list \ - "NedÄ›le"\ - "PondÄ›lí"\ - "Úterý"\ - "StÅ™eda"\ - "ÄŒtvrtek"\ - "Pátek"\ + "Ned\u011ble"\ + "Pond\u011bl\u00ed"\ + "\u00dater\u00fd"\ + "St\u0159eda"\ + "\u010ctvrtek"\ + "P\u00e1tek"\ "Sobota"] ::msgcat::mcset cs MONTHS_ABBREV [list \ "I"\ "II"\ "III"\ @@ -30,25 +30,25 @@ "XI"\ "XII"\ ""] ::msgcat::mcset cs MONTHS_FULL [list \ "leden"\ - "únor"\ - "bÅ™ezen"\ + "\u00fanor"\ + "b\u0159ezen"\ "duben"\ - "kvÄ›ten"\ - "Äerven"\ - "Äervenec"\ + "kv\u011bten"\ + "\u010derven"\ + "\u010dervenec"\ "srpen"\ - "září"\ - "říjen"\ + "z\u00e1\u0159\u00ed"\ + "\u0159\u00edjen"\ "listopad"\ "prosinec"\ ""] - ::msgcat::mcset cs BCE "pÅ™.Kr." + ::msgcat::mcset cs BCE "p\u0159.Kr." ::msgcat::mcset cs CE "po Kr." ::msgcat::mcset cs AM "dop." ::msgcat::mcset cs PM "odp." ::msgcat::mcset cs DATE_FORMAT "%e.%m.%Y" ::msgcat::mcset cs TIME_FORMAT "%k:%M:%S" ::msgcat::mcset cs DATE_TIME_FORMAT "%e.%m.%Y %k:%M:%S %z" } Index: library/msgs/da.msg ================================================================== --- library/msgs/da.msg +++ library/msgs/da.msg @@ -1,23 +1,23 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset da DAYS_OF_WEEK_ABBREV [list \ - "sø"\ + "s\u00f8"\ "ma"\ "ti"\ "on"\ "to"\ "fr"\ - "lø"] + "l\u00f8"] ::msgcat::mcset da DAYS_OF_WEEK_FULL [list \ - "søndag"\ + "s\u00f8ndag"\ "mandag"\ "tirsdag"\ "onsdag"\ "torsdag"\ "fredag"\ - "lørdag"] + "l\u00f8rdag"] ::msgcat::mcset da MONTHS_ABBREV [list \ "jan"\ "feb"\ "mar"\ "apr"\ Index: library/msgs/de.msg ================================================================== --- library/msgs/de.msg +++ library/msgs/de.msg @@ -31,11 +31,11 @@ "Dez"\ ""] ::msgcat::mcset de MONTHS_FULL [list \ "Januar"\ "Februar"\ - "März"\ + "M\u00e4rz"\ "April"\ "Mai"\ "Juni"\ "Juli"\ "August"\ Index: library/msgs/de_at.msg ================================================================== --- library/msgs/de_at.msg +++ library/msgs/de_at.msg @@ -1,11 +1,11 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset de_AT MONTHS_ABBREV [list \ - "Jän"\ + "J\u00e4n"\ "Feb"\ - "Mär"\ + "M\u00e4r"\ "Apr"\ "Mai"\ "Jun"\ "Jul"\ "Aug"\ @@ -13,13 +13,13 @@ "Okt"\ "Nov"\ "Dez"\ ""] ::msgcat::mcset de_AT MONTHS_FULL [list \ - "Jänner"\ + "J\u00e4nner"\ "Februar"\ - "März"\ + "M\u00e4rz"\ "April"\ "Mai"\ "Juni"\ "Juli"\ "August"\ Index: library/msgs/de_be.msg ================================================================== --- library/msgs/de_be.msg +++ library/msgs/de_be.msg @@ -17,11 +17,11 @@ "Freitag"\ "Samstag"] ::msgcat::mcset de_BE MONTHS_ABBREV [list \ "Jan"\ "Feb"\ - "Mär"\ + "M\u00e4r"\ "Apr"\ "Mai"\ "Jun"\ "Jul"\ "Aug"\ @@ -31,11 +31,11 @@ "Dez"\ ""] ::msgcat::mcset de_BE MONTHS_FULL [list \ "Januar"\ "Februar"\ - "März"\ + "M\u00e4rz"\ "April"\ "Mai"\ "Juni"\ "Juli"\ "August"\ Index: library/msgs/el.msg ================================================================== --- library/msgs/el.msg +++ library/msgs/el.msg @@ -1,52 +1,52 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset el DAYS_OF_WEEK_ABBREV [list \ - "ΚυÏ"\ - "Δευ"\ - "ΤÏι"\ - "Τετ"\ - "Πεμ"\ - "ΠαÏ"\ - "Σαβ"] + "\u039a\u03c5\u03c1"\ + "\u0394\u03b5\u03c5"\ + "\u03a4\u03c1\u03b9"\ + "\u03a4\u03b5\u03c4"\ + "\u03a0\u03b5\u03bc"\ + "\u03a0\u03b1\u03c1"\ + "\u03a3\u03b1\u03b2"] ::msgcat::mcset el DAYS_OF_WEEK_FULL [list \ - "ΚυÏιακή"\ - "ΔευτέÏα"\ - "ΤÏίτη"\ - "ΤετάÏτη"\ - "Πέμπτη"\ - "ΠαÏασκευή"\ - "Σάββατο"] + "\u039a\u03c5\u03c1\u03b9\u03b1\u03ba\u03ae"\ + "\u0394\u03b5\u03c5\u03c4\u03ad\u03c1\u03b1"\ + "\u03a4\u03c1\u03af\u03c4\u03b7"\ + "\u03a4\u03b5\u03c4\u03ac\u03c1\u03c4\u03b7"\ + "\u03a0\u03ad\u03bc\u03c0\u03c4\u03b7"\ + "\u03a0\u03b1\u03c1\u03b1\u03c3\u03ba\u03b5\u03c5\u03ae"\ + "\u03a3\u03ac\u03b2\u03b2\u03b1\u03c4\u03bf"] ::msgcat::mcset el MONTHS_ABBREV [list \ - "Ιαν"\ - "Φεβ"\ - "ΜαÏ"\ - "ΑπÏ"\ - "Μαϊ"\ - "Ιουν"\ - "Ιουλ"\ - "Αυγ"\ - "Σεπ"\ - "Οκτ"\ - "Îοε"\ - "Δεκ"\ + "\u0399\u03b1\u03bd"\ + "\u03a6\u03b5\u03b2"\ + "\u039c\u03b1\u03c1"\ + "\u0391\u03c0\u03c1"\ + "\u039c\u03b1\u03ca"\ + "\u0399\u03bf\u03c5\u03bd"\ + "\u0399\u03bf\u03c5\u03bb"\ + "\u0391\u03c5\u03b3"\ + "\u03a3\u03b5\u03c0"\ + "\u039f\u03ba\u03c4"\ + "\u039d\u03bf\u03b5"\ + "\u0394\u03b5\u03ba"\ ""] ::msgcat::mcset el MONTHS_FULL [list \ - "ΙανουάÏιος"\ - "ΦεβÏουάÏιος"\ - "ΜάÏτιος"\ - "ΑπÏίλιος"\ - "Μάϊος"\ - "ΙοÏνιος"\ - "ΙοÏλιος"\ - "ΑÏγουστος"\ - "ΣεπτέμβÏιος"\ - "ΟκτώβÏιος"\ - "ÎοέμβÏιος"\ - "ΔεκέμβÏιος"\ + "\u0399\u03b1\u03bd\u03bf\u03c5\u03ac\u03c1\u03b9\u03bf\u03c2"\ + "\u03a6\u03b5\u03b2\u03c1\u03bf\u03c5\u03ac\u03c1\u03b9\u03bf\u03c2"\ + "\u039c\u03ac\u03c1\u03c4\u03b9\u03bf\u03c2"\ + "\u0391\u03c0\u03c1\u03af\u03bb\u03b9\u03bf\u03c2"\ + "\u039c\u03ac\u03ca\u03bf\u03c2"\ + "\u0399\u03bf\u03cd\u03bd\u03b9\u03bf\u03c2"\ + "\u0399\u03bf\u03cd\u03bb\u03b9\u03bf\u03c2"\ + "\u0391\u03cd\u03b3\u03bf\u03c5\u03c3\u03c4\u03bf\u03c2"\ + "\u03a3\u03b5\u03c0\u03c4\u03ad\u03bc\u03b2\u03c1\u03b9\u03bf\u03c2"\ + "\u039f\u03ba\u03c4\u03ce\u03b2\u03c1\u03b9\u03bf\u03c2"\ + "\u039d\u03bf\u03ad\u03bc\u03b2\u03c1\u03b9\u03bf\u03c2"\ + "\u0394\u03b5\u03ba\u03ad\u03bc\u03b2\u03c1\u03b9\u03bf\u03c2"\ ""] - ::msgcat::mcset el AM "πμ" - ::msgcat::mcset el PM "μμ" + ::msgcat::mcset el AM "\u03c0\u03bc" + ::msgcat::mcset el PM "\u03bc\u03bc" ::msgcat::mcset el DATE_FORMAT "%e/%m/%Y" ::msgcat::mcset el TIME_FORMAT_12 "%l:%M:%S %P" ::msgcat::mcset el DATE_TIME_FORMAT "%e/%m/%Y %l:%M:%S %P %z" } Index: library/msgs/eo.msg ================================================================== --- library/msgs/eo.msg +++ library/msgs/eo.msg @@ -3,19 +3,19 @@ ::msgcat::mcset eo DAYS_OF_WEEK_ABBREV [list \ "di"\ "lu"\ "ma"\ "me"\ - "ĵa"\ + "\u0135a"\ "ve"\ "sa"] ::msgcat::mcset eo DAYS_OF_WEEK_FULL [list \ - "dimanĉo"\ + "diman\u0109o"\ "lundo"\ "mardo"\ "merkredo"\ - "ĵaÅ­do"\ + "\u0135a\u016ddo"\ "vendredo"\ "sabato"] ::msgcat::mcset eo MONTHS_ABBREV [list \ "jan"\ "feb"\ @@ -22,11 +22,11 @@ "mar"\ "apr"\ "maj"\ "jun"\ "jul"\ - "aÅ­g"\ + "a\u016dg"\ "sep"\ "okt"\ "nov"\ "dec"\ ""] @@ -36,11 +36,11 @@ "marto"\ "aprilo"\ "majo"\ "junio"\ "julio"\ - "aÅ­gusto"\ + "a\u016dgusto"\ "septembro"\ "oktobro"\ "novembro"\ "decembro"\ ""] Index: library/msgs/es.msg ================================================================== --- library/msgs/es.msg +++ library/msgs/es.msg @@ -2,22 +2,22 @@ namespace eval ::tcl::clock { ::msgcat::mcset es DAYS_OF_WEEK_ABBREV [list \ "dom"\ "lun"\ "mar"\ - "mié"\ + "mi\u00e9"\ "jue"\ "vie"\ - "sáb"] + "s\u00e1b"] ::msgcat::mcset es DAYS_OF_WEEK_FULL [list \ "domingo"\ "lunes"\ "martes"\ - "miércoles"\ + "mi\u00e9rcoles"\ "jueves"\ "viernes"\ - "sábado"] + "s\u00e1bado"] ::msgcat::mcset es MONTHS_ABBREV [list \ "ene"\ "feb"\ "mar"\ "abr"\ Index: library/msgs/et.msg ================================================================== --- library/msgs/et.msg +++ library/msgs/et.msg @@ -7,21 +7,21 @@ "K"\ "N"\ "R"\ "L"] ::msgcat::mcset et DAYS_OF_WEEK_FULL [list \ - "pühapäev"\ - "esmaspäev"\ - "teisipäev"\ - "kolmapäev"\ - "neljapäev"\ + "p\u00fchap\u00e4ev"\ + "esmasp\u00e4ev"\ + "teisip\u00e4ev"\ + "kolmap\u00e4ev"\ + "neljap\u00e4ev"\ "reede"\ - "laupäev"] + "laup\u00e4ev"] ::msgcat::mcset et MONTHS_ABBREV [list \ "Jaan"\ "Veebr"\ - "Märts"\ + "M\u00e4rts"\ "Apr"\ "Mai"\ "Juuni"\ "Juuli"\ "Aug"\ @@ -31,11 +31,11 @@ "Dets"\ ""] ::msgcat::mcset et MONTHS_FULL [list \ "Jaanuar"\ "Veebruar"\ - "Märts"\ + "M\u00e4rts"\ "Aprill"\ "Mai"\ "Juuni"\ "Juuli"\ "August"\ Index: library/msgs/fa.msg ================================================================== --- library/msgs/fa.msg +++ library/msgs/fa.msg @@ -1,47 +1,47 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset fa DAYS_OF_WEEK_ABBREV [list \ - "ی∔"\ - "د∔"\ - "س∔"\ - "چ∔"\ - "پ∔"\ - "ج∔"\ - "ش∔"] + "\u06cc\u2214"\ + "\u062f\u2214"\ + "\u0633\u2214"\ + "\u0686\u2214"\ + "\u067e\u2214"\ + "\u062c\u2214"\ + "\u0634\u2214"] ::msgcat::mcset fa DAYS_OF_WEEK_FULL [list \ - "یی‌شنبه"\ - "دوشنبه"\ - "سه‌شنبه"\ - "چهارشنبه"\ - "پنج‌شنبه"\ - "جمعه"\ - "شنبه"] + "\u06cc\u06cc\u200c\u0634\u0646\u0628\u0647"\ + "\u062f\u0648\u0634\u0646\u0628\u0647"\ + "\u0633\u0647\u200c\u0634\u0646\u0628\u0647"\ + "\u0686\u0647\u0627\u0631\u0634\u0646\u0628\u0647"\ + "\u067e\u0646\u062c\u200c\u0634\u0646\u0628\u0647"\ + "\u062c\u0645\u0639\u0647"\ + "\u0634\u0646\u0628\u0647"] ::msgcat::mcset fa MONTHS_ABBREV [list \ - "ژان"\ - "Ùور"\ - "مار"\ - "آور"\ - "مـه"\ - "ژون"\ - "Ú˜ÙˆÛŒ"\ - "اوت"\ - "سپت"\ - "اكت"\ - "نوا"\ - "دسا"\ + "\u0698\u0627\u0646"\ + "\u0641\u0648\u0631"\ + "\u0645\u0627\u0631"\ + "\u0622\u0648\u0631"\ + "\u0645\u0640\u0647"\ + "\u0698\u0648\u0646"\ + "\u0698\u0648\u06cc"\ + "\u0627\u0648\u062a"\ + "\u0633\u067e\u062a"\ + "\u0627\u0643\u062a"\ + "\u0646\u0648\u0627"\ + "\u062f\u0633\u0627"\ ""] ::msgcat::mcset fa MONTHS_FULL [list \ - "ژانویه"\ - "Ùورویه"\ - "مارس"\ - "آوریل"\ - "مه"\ - "ژوئن"\ - "ژوئیه"\ - "اوت"\ - "سپتامبر"\ - "اكتبر"\ - "نوامبر"\ - "دسامبر"\ + "\u0698\u0627\u0646\u0648\u06cc\u0647"\ + "\u0641\u0648\u0631\u0648\u06cc\u0647"\ + "\u0645\u0627\u0631\u0633"\ + "\u0622\u0648\u0631\u06cc\u0644"\ + "\u0645\u0647"\ + "\u0698\u0648\u0626\u0646"\ + "\u0698\u0648\u0626\u06cc\u0647"\ + "\u0627\u0648\u062a"\ + "\u0633\u067e\u062a\u0627\u0645\u0628\u0631"\ + "\u0627\u0643\u062a\u0628\u0631"\ + "\u0646\u0648\u0627\u0645\u0628\u0631"\ + "\u062f\u0633\u0627\u0645\u0628\u0631"\ ""] } Index: library/msgs/fa_in.msg ================================================================== --- library/msgs/fa_in.msg +++ library/msgs/fa_in.msg @@ -1,52 +1,52 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset fa_IN DAYS_OF_WEEK_ABBREV [list \ - "ی∔"\ - "د∔"\ - "س∔"\ - "چ∔"\ - "پ∔"\ - "ج∔"\ - "ش∔"] + "\u06cc\u2214"\ + "\u062f\u2214"\ + "\u0633\u2214"\ + "\u0686\u2214"\ + "\u067e\u2214"\ + "\u062c\u2214"\ + "\u0634\u2214"] ::msgcat::mcset fa_IN DAYS_OF_WEEK_FULL [list \ - "یی‌شنبه"\ - "دوشنبه"\ - "سه‌شنبه"\ - "چهارشنبه"\ - "پنج‌شنبه"\ - "جمعه"\ - "شنبه"] + "\u06cc\u06cc\u200c\u0634\u0646\u0628\u0647"\ + "\u062f\u0648\u0634\u0646\u0628\u0647"\ + "\u0633\u0647\u200c\u0634\u0646\u0628\u0647"\ + "\u0686\u0647\u0627\u0631\u0634\u0646\u0628\u0647"\ + "\u067e\u0646\u062c\u200c\u0634\u0646\u0628\u0647"\ + "\u062c\u0645\u0639\u0647"\ + "\u0634\u0646\u0628\u0647"] ::msgcat::mcset fa_IN MONTHS_ABBREV [list \ - "ژان"\ - "Ùور"\ - "مار"\ - "آور"\ - "مـه"\ - "ژون"\ - "Ú˜ÙˆÛŒ"\ - "اوت"\ - "سپت"\ - "اكت"\ - "نوا"\ - "دسا"\ + "\u0698\u0627\u0646"\ + "\u0641\u0648\u0631"\ + "\u0645\u0627\u0631"\ + "\u0622\u0648\u0631"\ + "\u0645\u0640\u0647"\ + "\u0698\u0648\u0646"\ + "\u0698\u0648\u06cc"\ + "\u0627\u0648\u062a"\ + "\u0633\u067e\u062a"\ + "\u0627\u0643\u062a"\ + "\u0646\u0648\u0627"\ + "\u062f\u0633\u0627"\ ""] ::msgcat::mcset fa_IN MONTHS_FULL [list \ - "ژانویه"\ - "Ùورویه"\ - "مارس"\ - "آوریل"\ - "مه"\ - "ژوئن"\ - "ژوئیه"\ - "اوت"\ - "سپتامبر"\ - "اكتبر"\ - "نوامبر"\ - "دسامبر"\ + "\u0698\u0627\u0646\u0648\u06cc\u0647"\ + "\u0641\u0648\u0631\u0648\u06cc\u0647"\ + "\u0645\u0627\u0631\u0633"\ + "\u0622\u0648\u0631\u06cc\u0644"\ + "\u0645\u0647"\ + "\u0698\u0648\u0626\u0646"\ + "\u0698\u0648\u0626\u06cc\u0647"\ + "\u0627\u0648\u062a"\ + "\u0633\u067e\u062a\u0627\u0645\u0628\u0631"\ + "\u0627\u0643\u062a\u0628\u0631"\ + "\u0646\u0648\u0627\u0645\u0628\u0631"\ + "\u062f\u0633\u0627\u0645\u0628\u0631"\ ""] - ::msgcat::mcset fa_IN AM "صبح" - ::msgcat::mcset fa_IN PM "عصر" + ::msgcat::mcset fa_IN AM "\u0635\u0628\u062d" + ::msgcat::mcset fa_IN PM "\u0639\u0635\u0631" ::msgcat::mcset fa_IN DATE_FORMAT "%A %d %B %Y" ::msgcat::mcset fa_IN TIME_FORMAT_12 "%I:%M:%S %z" ::msgcat::mcset fa_IN DATE_TIME_FORMAT "%A %d %B %Y %I:%M:%S %z %z" } Index: library/msgs/fa_ir.msg ================================================================== --- library/msgs/fa_ir.msg +++ library/msgs/fa_ir.msg @@ -1,9 +1,9 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { - ::msgcat::mcset fa_IR AM "صبح" - ::msgcat::mcset fa_IR PM "عصر" - ::msgcat::mcset fa_IR DATE_FORMAT "%dâ„%mâ„%Y" + ::msgcat::mcset fa_IR AM "\u0635\u0628\u062d" + ::msgcat::mcset fa_IR PM "\u0639\u0635\u0631" + ::msgcat::mcset fa_IR DATE_FORMAT "%d\u2044%m\u2044%Y" ::msgcat::mcset fa_IR TIME_FORMAT "%S:%M:%H" ::msgcat::mcset fa_IR TIME_FORMAT_12 "%S:%M:%l %P" - ::msgcat::mcset fa_IR DATE_TIME_FORMAT "%dâ„%mâ„%Y %S:%M:%H %z" + ::msgcat::mcset fa_IR DATE_TIME_FORMAT "%d\u2044%m\u2044%Y %S:%M:%H %z" } Index: library/msgs/fi.msg ================================================================== --- library/msgs/fi.msg +++ library/msgs/fi.msg @@ -20,12 +20,12 @@ "tammi"\ "helmi"\ "maalis"\ "huhti"\ "touko"\ - "kesä"\ - "heinä"\ + "kes\u00e4"\ + "hein\u00e4"\ "elo"\ "syys"\ "loka"\ "marras"\ "joulu"\ @@ -34,12 +34,12 @@ "tammikuu"\ "helmikuu"\ "maaliskuu"\ "huhtikuu"\ "toukokuu"\ - "kesäkuu"\ - "heinäkuu"\ + "kes\u00e4kuu"\ + "hein\u00e4kuu"\ "elokuu"\ "syyskuu"\ "lokakuu"\ "marraskuu"\ "joulukuu"\ Index: library/msgs/fo.msg ================================================================== --- library/msgs/fo.msg +++ library/msgs/fo.msg @@ -1,22 +1,22 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset fo DAYS_OF_WEEK_ABBREV [list \ "sun"\ - "mán"\ - "týs"\ + "m\u00e1n"\ + "t\u00fds"\ "mik"\ - "hós"\ - "frí"\ + "h\u00f3s"\ + "fr\u00ed"\ "ley"] ::msgcat::mcset fo DAYS_OF_WEEK_FULL [list \ "sunnudagur"\ - "mánadagur"\ - "týsdagur"\ + "m\u00e1nadagur"\ + "t\u00fdsdagur"\ "mikudagur"\ - "hósdagur"\ - "fríggjadagur"\ + "h\u00f3sdagur"\ + "fr\u00edggjadagur"\ "leygardagur"] ::msgcat::mcset fo MONTHS_ABBREV [list \ "jan"\ "feb"\ "mar"\ @@ -32,11 +32,11 @@ ""] ::msgcat::mcset fo MONTHS_FULL [list \ "januar"\ "februar"\ "mars"\ - "apríl"\ + "apr\u00edl"\ "mai"\ "juni"\ "juli"\ "august"\ "september"\ Index: library/msgs/fr.msg ================================================================== --- library/msgs/fr.msg +++ library/msgs/fr.msg @@ -16,35 +16,35 @@ "jeudi"\ "vendredi"\ "samedi"] ::msgcat::mcset fr MONTHS_ABBREV [list \ "janv."\ - "févr."\ + "f\u00e9vr."\ "mars"\ "avr."\ "mai"\ "juin"\ "juil."\ - "août"\ + "ao\u00fbt"\ "sept."\ "oct."\ "nov."\ - "déc."\ + "d\u00e9c."\ ""] ::msgcat::mcset fr MONTHS_FULL [list \ "janvier"\ - "février"\ + "f\u00e9vrier"\ "mars"\ "avril"\ "mai"\ "juin"\ "juillet"\ - "août"\ + "ao\u00fbt"\ "septembre"\ "octobre"\ "novembre"\ - "décembre"\ + "d\u00e9cembre"\ ""] ::msgcat::mcset fr BCE "av. J.-C." ::msgcat::mcset fr CE "ap. J.-C." ::msgcat::mcset fr DATE_FORMAT "%e %B %Y" ::msgcat::mcset fr TIME_FORMAT "%H:%M:%S" Index: library/msgs/ga.msg ================================================================== --- library/msgs/ga.msg +++ library/msgs/ga.msg @@ -1,47 +1,47 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset ga DAYS_OF_WEEK_ABBREV [list \ "Domh"\ "Luan"\ - "Máirt"\ - "Céad"\ - "Déar"\ + "M\u00e1irt"\ + "C\u00e9ad"\ + "D\u00e9ar"\ "Aoine"\ "Sath"] ::msgcat::mcset ga DAYS_OF_WEEK_FULL [list \ - "Dé Domhnaigh"\ - "Dé Luain"\ - "Dé Máirt"\ - "Dé Céadaoin"\ - "Déardaoin"\ - "Dé hAoine"\ - "Dé Sathairn"] + "D\u00e9 Domhnaigh"\ + "D\u00e9 Luain"\ + "D\u00e9 M\u00e1irt"\ + "D\u00e9 C\u00e9adaoin"\ + "D\u00e9ardaoin"\ + "D\u00e9 hAoine"\ + "D\u00e9 Sathairn"] ::msgcat::mcset ga MONTHS_ABBREV [list \ "Ean"\ "Feabh"\ - "Márta"\ + "M\u00e1rta"\ "Aib"\ "Beal"\ "Meith"\ - "Iúil"\ - "Lún"\ - "MFómh"\ - "DFómh"\ + "I\u00fail"\ + "L\u00fan"\ + "MF\u00f3mh"\ + "DF\u00f3mh"\ "Samh"\ "Noll"\ ""] ::msgcat::mcset ga MONTHS_FULL [list \ - "Eanáir"\ + "Ean\u00e1ir"\ "Feabhra"\ - "Márta"\ - "Aibreán"\ - "Mí na Bealtaine"\ + "M\u00e1rta"\ + "Aibre\u00e1n"\ + "M\u00ed na Bealtaine"\ "Meith"\ - "Iúil"\ - "Lúnasa"\ - "Meán Fómhair"\ - "Deireadh Fómhair"\ - "Mí na Samhna"\ - "Mí na Nollag"\ + "I\u00fail"\ + "L\u00fanasa"\ + "Me\u00e1n F\u00f3mhair"\ + "Deireadh F\u00f3mhair"\ + "M\u00ed na Samhna"\ + "M\u00ed na Nollag"\ ""] } Index: library/msgs/gl.msg ================================================================== --- library/msgs/gl.msg +++ library/msgs/gl.msg @@ -2,29 +2,29 @@ namespace eval ::tcl::clock { ::msgcat::mcset gl DAYS_OF_WEEK_ABBREV [list \ "Dom"\ "Lun"\ "Mar"\ - "Mér"\ + "M\u00e9r"\ "Xov"\ "Ven"\ - "Sáb"] + "S\u00e1b"] ::msgcat::mcset gl DAYS_OF_WEEK_FULL [list \ "Domingo"\ "Luns"\ "Martes"\ - "Mércores"\ + "M\u00e9rcores"\ "Xoves"\ "Venres"\ - "Sábado"] + "S\u00e1bado"] ::msgcat::mcset gl MONTHS_ABBREV [list \ "Xan"\ "Feb"\ "Mar"\ "Abr"\ "Mai"\ - "Xuñ"\ + "Xu\u00f1"\ "Xul"\ "Ago"\ "Set"\ "Out"\ "Nov"\ @@ -34,14 +34,14 @@ "Xaneiro"\ "Febreiro"\ "Marzo"\ "Abril"\ "Maio"\ - "Xuño"\ + "Xu\u00f1o"\ "Xullo"\ "Agosto"\ "Setembro"\ "Outubro"\ "Novembro"\ "Decembro"\ ""] } Index: library/msgs/he.msg ================================================================== --- library/msgs/he.msg +++ library/msgs/he.msg @@ -1,52 +1,52 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset he DAYS_OF_WEEK_ABBREV [list \ - "×"\ - "ב"\ - "×’"\ - "ד"\ - "×”"\ - "ו"\ - "ש"] + "\u05d0"\ + "\u05d1"\ + "\u05d2"\ + "\u05d3"\ + "\u05d4"\ + "\u05d5"\ + "\u05e9"] ::msgcat::mcset he DAYS_OF_WEEK_FULL [list \ - "×™×•× ×¨×שון"\ - "×™×•× ×©× ×™"\ - "×™×•× ×©×œ×™×©×™"\ - "×™×•× ×¨×‘×™×¢×™"\ - "×™×•× ×—×ž×™×©×™"\ - "×™×•× ×©×™×©×™"\ - "שבת"] + "\u05d9\u05d5\u05dd \u05e8\u05d0\u05e9\u05d5\u05df"\ + "\u05d9\u05d5\u05dd \u05e9\u05e0\u05d9"\ + "\u05d9\u05d5\u05dd \u05e9\u05dc\u05d9\u05e9\u05d9"\ + "\u05d9\u05d5\u05dd \u05e8\u05d1\u05d9\u05e2\u05d9"\ + "\u05d9\u05d5\u05dd \u05d7\u05de\u05d9\u05e9\u05d9"\ + "\u05d9\u05d5\u05dd \u05e9\u05d9\u05e9\u05d9"\ + "\u05e9\u05d1\u05ea"] ::msgcat::mcset he MONTHS_ABBREV [list \ - "ינו"\ - "פבר"\ - "מרץ"\ - "×פר"\ - "מ××™"\ - "יונ"\ - "יול"\ - "×וג"\ - "ספט"\ - "×וק"\ - "נוב"\ - "דצמ"\ + "\u05d9\u05e0\u05d5"\ + "\u05e4\u05d1\u05e8"\ + "\u05de\u05e8\u05e5"\ + "\u05d0\u05e4\u05e8"\ + "\u05de\u05d0\u05d9"\ + "\u05d9\u05d5\u05e0"\ + "\u05d9\u05d5\u05dc"\ + "\u05d0\u05d5\u05d2"\ + "\u05e1\u05e4\u05d8"\ + "\u05d0\u05d5\u05e7"\ + "\u05e0\u05d5\u05d1"\ + "\u05d3\u05e6\u05de"\ ""] ::msgcat::mcset he MONTHS_FULL [list \ - "ינו×ר"\ - "פברו×ר"\ - "מרץ"\ - "×פריל"\ - "מ××™"\ - "יוני"\ - "יולי"\ - "×וגוסט"\ - "ספטמבר"\ - "×וקטובר"\ - "נובמבר"\ - "דצמבר"\ + "\u05d9\u05e0\u05d5\u05d0\u05e8"\ + "\u05e4\u05d1\u05e8\u05d5\u05d0\u05e8"\ + "\u05de\u05e8\u05e5"\ + "\u05d0\u05e4\u05e8\u05d9\u05dc"\ + "\u05de\u05d0\u05d9"\ + "\u05d9\u05d5\u05e0\u05d9"\ + "\u05d9\u05d5\u05dc\u05d9"\ + "\u05d0\u05d5\u05d2\u05d5\u05e1\u05d8"\ + "\u05e1\u05e4\u05d8\u05de\u05d1\u05e8"\ + "\u05d0\u05d5\u05e7\u05d8\u05d5\u05d1\u05e8"\ + "\u05e0\u05d5\u05d1\u05de\u05d1\u05e8"\ + "\u05d3\u05e6\u05de\u05d1\u05e8"\ ""] - ::msgcat::mcset he BCE "לסה"× " - ::msgcat::mcset he CE "לפסה"× " + ::msgcat::mcset he BCE "\u05dc\u05e1\u05d4\u0022\u05e0" + ::msgcat::mcset he CE "\u05dc\u05e4\u05e1\u05d4\u0022\u05e0" ::msgcat::mcset he DATE_FORMAT "%d/%m/%Y" ::msgcat::mcset he TIME_FORMAT "%H:%M:%S" ::msgcat::mcset he DATE_TIME_FORMAT "%d/%m/%Y %H:%M:%S %z" } Index: library/msgs/hi.msg ================================================================== --- library/msgs/hi.msg +++ library/msgs/hi.msg @@ -1,39 +1,39 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset hi DAYS_OF_WEEK_FULL [list \ - "रविवार"\ - "सोमवार"\ - "मंगलवार"\ - "बà¥à¤§à¤µà¤¾à¤°"\ - "गà¥à¤°à¥à¤µà¤¾à¤°"\ - "शà¥à¤•à¥à¤°à¤µà¤¾à¤°"\ - "शनिवार"] + "\u0930\u0935\u093f\u0935\u093e\u0930"\ + "\u0938\u094b\u092e\u0935\u093e\u0930"\ + "\u092e\u0902\u0917\u0932\u0935\u093e\u0930"\ + "\u092c\u0941\u0927\u0935\u093e\u0930"\ + "\u0917\u0941\u0930\u0941\u0935\u093e\u0930"\ + "\u0936\u0941\u0915\u094d\u0930\u0935\u093e\u0930"\ + "\u0936\u0928\u093f\u0935\u093e\u0930"] ::msgcat::mcset hi MONTHS_ABBREV [list \ - "जनवरी"\ - "फ़रवरी"\ - "मारà¥à¤š"\ - "अपà¥à¤°à¥‡à¤²"\ - "मई"\ - "जून"\ - "जà¥à¤²à¤¾à¤ˆ"\ - "अगसà¥à¤¤"\ - "सितमà¥à¤¬à¤°"\ - "अकà¥à¤Ÿà¥‚बर"\ - "नवमà¥à¤¬à¤°"\ - "दिसमà¥à¤¬à¤°"] + "\u091c\u0928\u0935\u0930\u0940"\ + "\u092b\u093c\u0930\u0935\u0930\u0940"\ + "\u092e\u093e\u0930\u094d\u091a"\ + "\u0905\u092a\u094d\u0930\u0947\u0932"\ + "\u092e\u0908"\ + "\u091c\u0942\u0928"\ + "\u091c\u0941\u0932\u093e\u0908"\ + "\u0905\u0917\u0938\u094d\u0924"\ + "\u0938\u093f\u0924\u092e\u094d\u092c\u0930"\ + "\u0905\u0915\u094d\u091f\u0942\u092c\u0930"\ + "\u0928\u0935\u092e\u094d\u092c\u0930"\ + "\u0926\u093f\u0938\u092e\u094d\u092c\u0930"] ::msgcat::mcset hi MONTHS_FULL [list \ - "जनवरी"\ - "फ़रवरी"\ - "मारà¥à¤š"\ - "अपà¥à¤°à¥‡à¤²"\ - "मई"\ - "जून"\ - "जà¥à¤²à¤¾à¤ˆ"\ - "अगसà¥à¤¤"\ - "सितमà¥à¤¬à¤°"\ - "अकà¥à¤Ÿà¥‚बर"\ - "नवमà¥à¤¬à¤°"\ - "दिसमà¥à¤¬à¤°"] - ::msgcat::mcset hi AM "ईसापूरà¥à¤µ" + "\u091c\u0928\u0935\u0930\u0940"\ + "\u092b\u093c\u0930\u0935\u0930\u0940"\ + "\u092e\u093e\u0930\u094d\u091a"\ + "\u0905\u092a\u094d\u0930\u0947\u0932"\ + "\u092e\u0908"\ + "\u091c\u0942\u0928"\ + "\u091c\u0941\u0932\u093e\u0908"\ + "\u0905\u0917\u0938\u094d\u0924"\ + "\u0938\u093f\u0924\u092e\u094d\u092c\u0930"\ + "\u0905\u0915\u094d\u091f\u0942\u092c\u0930"\ + "\u0928\u0935\u092e\u094d\u092c\u0930"\ + "\u0926\u093f\u0938\u092e\u094d\u092c\u0930"] + ::msgcat::mcset hi AM "\u0908\u0938\u093e\u092a\u0942\u0930\u094d\u0935" ::msgcat::mcset hi PM "." } Index: library/msgs/hr.msg ================================================================== --- library/msgs/hr.msg +++ library/msgs/hr.msg @@ -3,25 +3,25 @@ ::msgcat::mcset hr DAYS_OF_WEEK_ABBREV [list \ "ned"\ "pon"\ "uto"\ "sri"\ - "Äet"\ + "\u010det"\ "pet"\ "sub"] ::msgcat::mcset hr DAYS_OF_WEEK_FULL [list \ "nedjelja"\ "ponedjeljak"\ "utorak"\ "srijeda"\ - "Äetvrtak"\ + "\u010detvrtak"\ "petak"\ "subota"] ::msgcat::mcset hr MONTHS_ABBREV [list \ "sij"\ "vel"\ - "ožu"\ + "o\u017eu"\ "tra"\ "svi"\ "lip"\ "srp"\ "kol"\ @@ -29,13 +29,13 @@ "lis"\ "stu"\ "pro"\ ""] ::msgcat::mcset hr MONTHS_FULL [list \ - "sijeÄanj"\ - "veljaÄa"\ - "ožujak"\ + "sije\u010danj"\ + "velja\u010da"\ + "o\u017eujak"\ "travanj"\ "svibanj"\ "lipanj"\ "srpanj"\ "kolovoz"\ Index: library/msgs/hu.msg ================================================================== --- library/msgs/hu.msg +++ library/msgs/hu.msg @@ -7,42 +7,42 @@ "Sze"\ "Cs"\ "P"\ "Szo"] ::msgcat::mcset hu DAYS_OF_WEEK_FULL [list \ - "vasárnap"\ - "hétfÅ‘"\ + "vas\u00e1rnap"\ + "h\u00e9tf\u0151"\ "kedd"\ "szerda"\ - "csütörtök"\ - "péntek"\ + "cs\u00fct\u00f6rt\u00f6k"\ + "p\u00e9ntek"\ "szombat"] ::msgcat::mcset hu MONTHS_ABBREV [list \ "jan."\ "febr."\ - "márc."\ - "ápr."\ - "máj."\ - "jún."\ - "júl."\ + "m\u00e1rc."\ + "\u00e1pr."\ + "m\u00e1j."\ + "j\u00fan."\ + "j\u00fal."\ "aug."\ "szept."\ "okt."\ "nov."\ "dec."\ ""] ::msgcat::mcset hu MONTHS_FULL [list \ - "január"\ - "február"\ - "március"\ - "április"\ - "május"\ - "június"\ - "július"\ + "janu\u00e1r"\ + "febru\u00e1r"\ + "m\u00e1rcius"\ + "\u00e1prilis"\ + "m\u00e1jus"\ + "j\u00fanius"\ + "j\u00falius"\ "augusztus"\ "szeptember"\ - "október"\ + "okt\u00f3ber"\ "november"\ "december"\ ""] ::msgcat::mcset hu BCE "i.e." ::msgcat::mcset hu CE "i.u." Index: library/msgs/is.msg ================================================================== --- library/msgs/is.msg +++ library/msgs/is.msg @@ -1,49 +1,49 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset is DAYS_OF_WEEK_ABBREV [list \ "sun."\ - "mán."\ - "þri."\ - "mið."\ + "m\u00e1n."\ + "\u00feri."\ + "mi\u00f0."\ "fim."\ - "fös."\ + "f\u00f6s."\ "lau."] ::msgcat::mcset is DAYS_OF_WEEK_FULL [list \ "sunnudagur"\ - "mánudagur"\ - "þriðjudagur"\ - "miðvikudagur"\ + "m\u00e1nudagur"\ + "\u00feri\u00f0judagur"\ + "mi\u00f0vikudagur"\ "fimmtudagur"\ - "föstudagur"\ + "f\u00f6studagur"\ "laugardagur"] ::msgcat::mcset is MONTHS_ABBREV [list \ "jan."\ "feb."\ "mar."\ "apr."\ - "maí"\ - "jún."\ - "júl."\ - "ágú."\ + "ma\u00ed"\ + "j\u00fan."\ + "j\u00fal."\ + "\u00e1g\u00fa."\ "sep."\ "okt."\ - "nóv."\ + "n\u00f3v."\ "des."\ ""] ::msgcat::mcset is MONTHS_FULL [list \ - "janúar"\ - "febrúar"\ + "jan\u00faar"\ + "febr\u00faar"\ "mars"\ - "apríl"\ - "maí"\ - "júní"\ - "júlí"\ - "ágúst"\ + "apr\u00edl"\ + "ma\u00ed"\ + "j\u00fan\u00ed"\ + "j\u00fal\u00ed"\ + "\u00e1g\u00fast"\ "september"\ - "október"\ - "nóvember"\ + "okt\u00f3ber"\ + "n\u00f3vember"\ "desember"\ ""] ::msgcat::mcset is DATE_FORMAT "%e.%m.%Y" ::msgcat::mcset is TIME_FORMAT "%H:%M:%S" ::msgcat::mcset is DATE_TIME_FORMAT "%e.%m.%Y %H:%M:%S %z" Index: library/msgs/it.msg ================================================================== --- library/msgs/it.msg +++ library/msgs/it.msg @@ -8,15 +8,15 @@ "gio"\ "ven"\ "sab"] ::msgcat::mcset it DAYS_OF_WEEK_FULL [list \ "domenica"\ - "lunedì"\ - "martedì"\ - "mercoledì"\ - "giovedì"\ - "venerdì"\ + "luned\u00ec"\ + "marted\u00ec"\ + "mercoled\u00ec"\ + "gioved\u00ec"\ + "venerd\u00ec"\ "sabato"] ::msgcat::mcset it MONTHS_ABBREV [list \ "gen"\ "feb"\ "mar"\ Index: library/msgs/ja.msg ================================================================== --- library/msgs/ja.msg +++ library/msgs/ja.msg @@ -1,44 +1,44 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset ja DAYS_OF_WEEK_ABBREV [list \ - "æ—¥"\ - "月"\ - "ç«"\ - "æ°´"\ - "木"\ - "金"\ - "土"] + "\u65e5"\ + "\u6708"\ + "\u706b"\ + "\u6c34"\ + "\u6728"\ + "\u91d1"\ + "\u571f"] ::msgcat::mcset ja DAYS_OF_WEEK_FULL [list \ - "日曜日"\ - "月曜日"\ - "ç«æ›œæ—¥"\ - "水曜日"\ - "木曜日"\ - "金曜日"\ - "土曜日"] + "\u65e5\u66dc\u65e5"\ + "\u6708\u66dc\u65e5"\ + "\u706b\u66dc\u65e5"\ + "\u6c34\u66dc\u65e5"\ + "\u6728\u66dc\u65e5"\ + "\u91d1\u66dc\u65e5"\ + "\u571f\u66dc\u65e5"] ::msgcat::mcset ja MONTHS_FULL [list \ - "1月"\ - "2月"\ - "3月"\ - "4月"\ - "5月"\ - "6月"\ - "7月"\ - "8月"\ - "9月"\ - "10月"\ - "11月"\ - "12月"] - ::msgcat::mcset ja BCE "紀元å‰" - ::msgcat::mcset ja CE "西暦" - ::msgcat::mcset ja AM "åˆå‰" - ::msgcat::mcset ja PM "åˆå¾Œ" + "1\u6708"\ + "2\u6708"\ + "3\u6708"\ + "4\u6708"\ + "5\u6708"\ + "6\u6708"\ + "7\u6708"\ + "8\u6708"\ + "9\u6708"\ + "10\u6708"\ + "11\u6708"\ + "12\u6708"] + ::msgcat::mcset ja BCE "\u7d00\u5143\u524d" + ::msgcat::mcset ja CE "\u897f\u66a6" + ::msgcat::mcset ja AM "\u5348\u524d" + ::msgcat::mcset ja PM "\u5348\u5f8c" ::msgcat::mcset ja DATE_FORMAT "%Y/%m/%d" ::msgcat::mcset ja TIME_FORMAT "%k:%M:%S" ::msgcat::mcset ja TIME_FORMAT_12 "%P %I:%M:%S" ::msgcat::mcset ja DATE_TIME_FORMAT "%Y/%m/%d %k:%M:%S %z" - ::msgcat::mcset ja LOCALE_DATE_FORMAT "%EYå¹´%m月%dæ—¥" - ::msgcat::mcset ja LOCALE_TIME_FORMAT "%H時%M分%S秒" - ::msgcat::mcset ja LOCALE_DATE_TIME_FORMAT "%EYå¹´%m月%dæ—¥ (%a) %H時%M分%S秒 %z" - ::msgcat::mcset ja LOCALE_ERAS "{-9223372036854775808 西暦 0} {-3061011600 明治 1867} {-1812186000 大正 1911} {-1357635600 昭和 1925} {600220800 å¹³æˆ 1988} {1556668800 令和 2018}" + ::msgcat::mcset ja LOCALE_DATE_FORMAT "%EY\u5e74%m\u6708%d\u65e5" + ::msgcat::mcset ja LOCALE_TIME_FORMAT "%H\u6642%M\u5206%S\u79d2" + ::msgcat::mcset ja LOCALE_DATE_TIME_FORMAT "%EY\u5e74%m\u6708%d\u65e5 (%a) %H\u6642%M\u5206%S\u79d2 %z" + ::msgcat::mcset ja LOCALE_ERAS "{-9223372036854775808 \u897f\u66a6 0} {-3061011600 \u660e\u6cbb 1867} {-1812186000 \u5927\u6b63 1911} {-1357635600 \u662d\u548c 1925} {600220800 \u5e73\u6210 1988} {1556668800 \u4ee4\u548c 2018}" } Index: library/msgs/ko.msg ================================================================== --- library/msgs/ko.msg +++ library/msgs/ko.msg @@ -1,55 +1,55 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset ko DAYS_OF_WEEK_ABBREV [list \ - "ì¼"\ - "ì›”"\ - "í™”"\ - "수"\ - "목"\ - "금"\ - "토"] + "\uc77c"\ + "\uc6d4"\ + "\ud654"\ + "\uc218"\ + "\ubaa9"\ + "\uae08"\ + "\ud1a0"] ::msgcat::mcset ko DAYS_OF_WEEK_FULL [list \ - "ì¼ìš”ì¼"\ - "월요ì¼"\ - "화요ì¼"\ - "수요ì¼"\ - "목요ì¼"\ - "금요ì¼"\ - "토요ì¼"] + "\uc77c\uc694\uc77c"\ + "\uc6d4\uc694\uc77c"\ + "\ud654\uc694\uc77c"\ + "\uc218\uc694\uc77c"\ + "\ubaa9\uc694\uc77c"\ + "\uae08\uc694\uc77c"\ + "\ud1a0\uc694\uc77c"] ::msgcat::mcset ko MONTHS_ABBREV [list \ - "1ì›”"\ - "2ì›”"\ - "3ì›”"\ - "4ì›”"\ - "5ì›”"\ - "6ì›”"\ - "7ì›”"\ - "8ì›”"\ - "9ì›”"\ - "10ì›”"\ - "11ì›”"\ - "12ì›”"\ + "1\uc6d4"\ + "2\uc6d4"\ + "3\uc6d4"\ + "4\uc6d4"\ + "5\uc6d4"\ + "6\uc6d4"\ + "7\uc6d4"\ + "8\uc6d4"\ + "9\uc6d4"\ + "10\uc6d4"\ + "11\uc6d4"\ + "12\uc6d4"\ ""] ::msgcat::mcset ko MONTHS_FULL [list \ - "1ì›”"\ - "2ì›”"\ - "3ì›”"\ - "4ì›”"\ - "5ì›”"\ - "6ì›”"\ - "7ì›”"\ - "8ì›”"\ - "9ì›”"\ - "10ì›”"\ - "11ì›”"\ - "12ì›”"\ + "1\uc6d4"\ + "2\uc6d4"\ + "3\uc6d4"\ + "4\uc6d4"\ + "5\uc6d4"\ + "6\uc6d4"\ + "7\uc6d4"\ + "8\uc6d4"\ + "9\uc6d4"\ + "10\uc6d4"\ + "11\uc6d4"\ + "12\uc6d4"\ ""] - ::msgcat::mcset ko AM "오전" - ::msgcat::mcset ko PM "오후" + ::msgcat::mcset ko AM "\uc624\uc804" + ::msgcat::mcset ko PM "\uc624\ud6c4" ::msgcat::mcset ko DATE_FORMAT "%Y-%m-%d" ::msgcat::mcset ko TIME_FORMAT_12 "%P %l:%M:%S" ::msgcat::mcset ko DATE_TIME_FORMAT "%Y-%m-%d %P %l:%M:%S %z" - ::msgcat::mcset ko LOCALE_DATE_FORMAT "%Yë…„%B%Odì¼" - ::msgcat::mcset ko LOCALE_TIME_FORMAT "%Hì‹œ%M분%Sì´ˆ" - ::msgcat::mcset ko LOCALE_DATE_TIME_FORMAT "%A %Yë…„%B%Odì¼%Hì‹œ%M분%Sì´ˆ %z" + ::msgcat::mcset ko LOCALE_DATE_FORMAT "%Y\ub144%B%Od\uc77c" + ::msgcat::mcset ko LOCALE_TIME_FORMAT "%H\uc2dc%M\ubd84%S\ucd08" + ::msgcat::mcset ko LOCALE_DATE_TIME_FORMAT "%A %Y\ub144%B%Od\uc77c%H\uc2dc%M\ubd84%S\ucd08 %z" } Index: library/msgs/ko_kr.msg ================================================================== --- library/msgs/ko_kr.msg +++ library/msgs/ko_kr.msg @@ -1,8 +1,8 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { - ::msgcat::mcset ko_KR BCE "기ì›ì „" - ::msgcat::mcset ko_KR CE "서기" + ::msgcat::mcset ko_KR BCE "\uae30\uc6d0\uc804" + ::msgcat::mcset ko_KR CE "\uc11c\uae30" ::msgcat::mcset ko_KR DATE_FORMAT "%Y.%m.%d" ::msgcat::mcset ko_KR TIME_FORMAT_12 "%P %l:%M:%S" ::msgcat::mcset ko_KR DATE_TIME_FORMAT "%Y.%m.%d %P %l:%M:%S %z" } Index: library/msgs/kok.msg ================================================================== --- library/msgs/kok.msg +++ library/msgs/kok.msg @@ -1,39 +1,39 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset kok DAYS_OF_WEEK_FULL [list \ - "आदितà¥à¤¯à¤µà¤¾à¤°"\ - "सोमवार"\ - "मंगळार"\ - "बà¥à¤§à¤µà¤¾à¤°"\ - "गà¥à¤°à¥à¤µà¤¾à¤°"\ - "शà¥à¤•à¥à¤°à¤µà¤¾à¤°"\ - "शनिवार"] + "\u0906\u0926\u093f\u0924\u094d\u092f\u0935\u093e\u0930"\ + "\u0938\u094b\u092e\u0935\u093e\u0930"\ + "\u092e\u0902\u0917\u0933\u093e\u0930"\ + "\u092c\u0941\u0927\u0935\u093e\u0930"\ + "\u0917\u0941\u0930\u0941\u0935\u093e\u0930"\ + "\u0936\u0941\u0915\u094d\u0930\u0935\u093e\u0930"\ + "\u0936\u0928\u093f\u0935\u093e\u0930"] ::msgcat::mcset kok MONTHS_ABBREV [list \ - "जानेवारी"\ - "फेबृवारी"\ - "मारà¥à¤š"\ - "à¤à¤ªà¥à¤°à¤¿à¤²"\ - "मे"\ - "जून"\ - "जà¥à¤²à¥ˆ"\ - "ओगसà¥à¤Ÿ"\ - "सेपà¥à¤Ÿà¥‡à¤‚बर"\ - "ओकà¥à¤Ÿà¥‹à¤¬à¤°"\ - "नोवà¥à¤¹à¥‡à¤‚बर"\ - "डिसेंबर"] + "\u091c\u093e\u0928\u0947\u0935\u093e\u0930\u0940"\ + "\u092b\u0947\u092c\u0943\u0935\u093e\u0930\u0940"\ + "\u092e\u093e\u0930\u094d\u091a"\ + "\u090f\u092a\u094d\u0930\u093f\u0932"\ + "\u092e\u0947"\ + "\u091c\u0942\u0928"\ + "\u091c\u0941\u0932\u0948"\ + "\u0913\u0917\u0938\u094d\u091f"\ + "\u0938\u0947\u092a\u094d\u091f\u0947\u0902\u092c\u0930"\ + "\u0913\u0915\u094d\u091f\u094b\u092c\u0930"\ + "\u0928\u094b\u0935\u094d\u0939\u0947\u0902\u092c\u0930"\ + "\u0921\u093f\u0938\u0947\u0902\u092c\u0930"] ::msgcat::mcset kok MONTHS_FULL [list \ - "जानेवारी"\ - "फेबà¥à¤°à¥à¤µà¤¾à¤°à¥€"\ - "मारà¥à¤š"\ - "à¤à¤ªà¥à¤°à¤¿à¤²"\ - "मे"\ - "जून"\ - "जà¥à¤²à¥ˆ"\ - "ओगसà¥à¤Ÿ"\ - "सेपà¥à¤Ÿà¥‡à¤‚बर"\ - "ओकà¥à¤Ÿà¥‹à¤¬à¤°"\ - "नोवà¥à¤¹à¥‡à¤‚बर"\ - "डिसेंबर"] - ::msgcat::mcset kok AM "कà¥à¤°à¤¿à¤¸à¥à¤¤à¤ªà¥‚रà¥à¤µ" - ::msgcat::mcset kok PM "कà¥à¤°à¤¿à¤¸à¥à¤¤à¤¶à¤–ा" + "\u091c\u093e\u0928\u0947\u0935\u093e\u0930\u0940"\ + "\u092b\u0947\u092c\u094d\u0930\u0941\u0935\u093e\u0930\u0940"\ + "\u092e\u093e\u0930\u094d\u091a"\ + "\u090f\u092a\u094d\u0930\u093f\u0932"\ + "\u092e\u0947"\ + "\u091c\u0942\u0928"\ + "\u091c\u0941\u0932\u0948"\ + "\u0913\u0917\u0938\u094d\u091f"\ + "\u0938\u0947\u092a\u094d\u091f\u0947\u0902\u092c\u0930"\ + "\u0913\u0915\u094d\u091f\u094b\u092c\u0930"\ + "\u0928\u094b\u0935\u094d\u0939\u0947\u0902\u092c\u0930"\ + "\u0921\u093f\u0938\u0947\u0902\u092c\u0930"] + ::msgcat::mcset kok AM "\u0915\u094d\u0930\u093f\u0938\u094d\u0924\u092a\u0942\u0930\u094d\u0935" + ::msgcat::mcset kok PM "\u0915\u094d\u0930\u093f\u0938\u094d\u0924\u0936\u0916\u093e" } Index: library/msgs/lt.msg ================================================================== --- library/msgs/lt.msg +++ library/msgs/lt.msg @@ -5,19 +5,19 @@ "Pr"\ "An"\ "Tr"\ "Kt"\ "Pn"\ - "Å t"] + "\u0160t"] ::msgcat::mcset lt DAYS_OF_WEEK_FULL [list \ "Sekmadienis"\ "Pirmadienis"\ "Antradienis"\ - "TreÄiadienis"\ + "Tre\u010diadienis"\ "Ketvirtadienis"\ "Penktadienis"\ - "Å eÅ¡tadienis"] + "\u0160e\u0161tadienis"] ::msgcat::mcset lt MONTHS_ABBREV [list \ "Sau"\ "Vas"\ "Kov"\ "Bal"\ @@ -32,21 +32,21 @@ ""] ::msgcat::mcset lt MONTHS_FULL [list \ "Sausio"\ "Vasario"\ "Kovo"\ - "Balandžio"\ - "Gegužės"\ - "Birželio"\ + "Baland\u017eio"\ + "Gegu\u017e\u0117s"\ + "Bir\u017eelio"\ "Liepos"\ - "RugpjÅ«Äio"\ - "RugsÄ—jo"\ + "Rugpj\u016b\u010dio"\ + "Rugs\u0117jo"\ "Spalio"\ - "LapkriÄio"\ - "Gruodžio"\ + "Lapkri\u010dio"\ + "Gruod\u017eio"\ ""] ::msgcat::mcset lt BCE "pr.Kr." ::msgcat::mcset lt CE "po.Kr." ::msgcat::mcset lt DATE_FORMAT "%Y.%m.%e" ::msgcat::mcset lt TIME_FORMAT "%H.%M.%S" ::msgcat::mcset lt DATE_TIME_FORMAT "%Y.%m.%e %H.%M.%S %z" } Index: library/msgs/lv.msg ================================================================== --- library/msgs/lv.msg +++ library/msgs/lv.msg @@ -7,46 +7,46 @@ "T"\ "C"\ "Pk"\ "S"] ::msgcat::mcset lv DAYS_OF_WEEK_FULL [list \ - "svÄ“tdiena"\ + "sv\u0113tdiena"\ "pirmdiena"\ "otrdiena"\ - "treÅ¡diena"\ + "tre\u0161diena"\ "ceturdien"\ "piektdiena"\ "sestdiena"] ::msgcat::mcset lv MONTHS_ABBREV [list \ "Jan"\ "Feb"\ "Mar"\ "Apr"\ "Maijs"\ - "JÅ«n"\ - "JÅ«l"\ + "J\u016bn"\ + "J\u016bl"\ "Aug"\ "Sep"\ "Okt"\ "Nov"\ "Dec"\ ""] ::msgcat::mcset lv MONTHS_FULL [list \ - "janvÄris"\ - "februÄris"\ + "janv\u0101ris"\ + "febru\u0101ris"\ "marts"\ - "aprÄ«lis"\ + "apr\u012blis"\ "maijs"\ - "jÅ«nijs"\ - "jÅ«lijs"\ + "j\u016bnijs"\ + "j\u016blijs"\ "augusts"\ "septembris"\ "oktobris"\ "novembris"\ "decembris"\ ""] - ::msgcat::mcset lv BCE "pmÄ“" - ::msgcat::mcset lv CE "mÄ“" + ::msgcat::mcset lv BCE "pm\u0113" + ::msgcat::mcset lv CE "m\u0113" ::msgcat::mcset lv DATE_FORMAT "%Y.%e.%m" ::msgcat::mcset lv TIME_FORMAT "%H:%M:%S" ::msgcat::mcset lv DATE_TIME_FORMAT "%Y.%e.%m %H:%M:%S %z" } Index: library/msgs/mk.msg ================================================================== --- library/msgs/mk.msg +++ library/msgs/mk.msg @@ -1,52 +1,52 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset mk DAYS_OF_WEEK_ABBREV [list \ - "нед."\ - "пон."\ - "вт."\ - "Ñре."\ - "чет."\ - "пет."\ - "Ñаб."] + "\u043d\u0435\u0434."\ + "\u043f\u043e\u043d."\ + "\u0432\u0442."\ + "\u0441\u0440\u0435."\ + "\u0447\u0435\u0442."\ + "\u043f\u0435\u0442."\ + "\u0441\u0430\u0431."] ::msgcat::mcset mk DAYS_OF_WEEK_FULL [list \ - "недела"\ - "понеделник"\ - "вторник"\ - "Ñреда"\ - "четврток"\ - "петок"\ - "Ñабота"] + "\u043d\u0435\u0434\u0435\u043b\u0430"\ + "\u043f\u043e\u043d\u0435\u0434\u0435\u043b\u043d\u0438\u043a"\ + "\u0432\u0442\u043e\u0440\u043d\u0438\u043a"\ + "\u0441\u0440\u0435\u0434\u0430"\ + "\u0447\u0435\u0442\u0432\u0440\u0442\u043e\u043a"\ + "\u043f\u0435\u0442\u043e\u043a"\ + "\u0441\u0430\u0431\u043e\u0442\u0430"] ::msgcat::mcset mk MONTHS_ABBREV [list \ - "јан."\ - "фев."\ - "мар."\ - "апр."\ - "мај."\ - "јун."\ - "јул."\ - "авг."\ - "Ñепт."\ - "окт."\ - "ноем."\ - "декем."\ + "\u0458\u0430\u043d."\ + "\u0444\u0435\u0432."\ + "\u043c\u0430\u0440."\ + "\u0430\u043f\u0440."\ + "\u043c\u0430\u0458."\ + "\u0458\u0443\u043d."\ + "\u0458\u0443\u043b."\ + "\u0430\u0432\u0433."\ + "\u0441\u0435\u043f\u0442."\ + "\u043e\u043a\u0442."\ + "\u043d\u043e\u0435\u043c."\ + "\u0434\u0435\u043a\u0435\u043c."\ ""] ::msgcat::mcset mk MONTHS_FULL [list \ - "јануари"\ - "февруари"\ - "март"\ - "април"\ - "мај"\ - "јуни"\ - "јули"\ - "авгуÑÑ‚"\ - "Ñептември"\ - "октомври"\ - "ноември"\ - "декември"\ + "\u0458\u0430\u043d\u0443\u0430\u0440\u0438"\ + "\u0444\u0435\u0432\u0440\u0443\u0430\u0440\u0438"\ + "\u043c\u0430\u0440\u0442"\ + "\u0430\u043f\u0440\u0438\u043b"\ + "\u043c\u0430\u0458"\ + "\u0458\u0443\u043d\u0438"\ + "\u0458\u0443\u043b\u0438"\ + "\u0430\u0432\u0433\u0443\u0441\u0442"\ + "\u0441\u0435\u043f\u0442\u0435\u043c\u0432\u0440\u0438"\ + "\u043e\u043a\u0442\u043e\u043c\u0432\u0440\u0438"\ + "\u043d\u043e\u0435\u043c\u0432\u0440\u0438"\ + "\u0434\u0435\u043a\u0435\u043c\u0432\u0440\u0438"\ ""] - ::msgcat::mcset mk BCE "пр.н.е." - ::msgcat::mcset mk CE "ае." + ::msgcat::mcset mk BCE "\u043f\u0440.\u043d.\u0435." + ::msgcat::mcset mk CE "\u0430\u0435." ::msgcat::mcset mk DATE_FORMAT "%e.%m.%Y" ::msgcat::mcset mk TIME_FORMAT "%H:%M:%S %z" ::msgcat::mcset mk DATE_TIME_FORMAT "%e.%m.%Y %H:%M:%S %z %z" } Index: library/msgs/mr.msg ================================================================== --- library/msgs/mr.msg +++ library/msgs/mr.msg @@ -1,39 +1,39 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset mr DAYS_OF_WEEK_FULL [list \ - "रविवार"\ - "सोमवार"\ - "मंगळवार"\ - "मंगळवार"\ - "गà¥à¤°à¥à¤µà¤¾à¤°"\ - "शà¥à¤•à¥à¤°à¤µà¤¾à¤°"\ - "शनिवार"] + "\u0930\u0935\u093f\u0935\u093e\u0930"\ + "\u0938\u094b\u092e\u0935\u093e\u0930"\ + "\u092e\u0902\u0917\u0933\u0935\u093e\u0930"\ + "\u092e\u0902\u0917\u0933\u0935\u093e\u0930"\ + "\u0917\u0941\u0930\u0941\u0935\u093e\u0930"\ + "\u0936\u0941\u0915\u094d\u0930\u0935\u093e\u0930"\ + "\u0936\u0928\u093f\u0935\u093e\u0930"] ::msgcat::mcset mr MONTHS_ABBREV [list \ - "जानेवारी"\ - "फेबृवारी"\ - "मारà¥à¤š"\ - "à¤à¤ªà¥à¤°à¤¿à¤²"\ - "मे"\ - "जून"\ - "जà¥à¤²à¥ˆ"\ - "ओगसà¥à¤Ÿ"\ - "सेपà¥à¤Ÿà¥‡à¤‚बर"\ - "ओकà¥à¤Ÿà¥‹à¤¬à¤°"\ - "नोवà¥à¤¹à¥‡à¤‚बर"\ - "डिसेंबर"] + "\u091c\u093e\u0928\u0947\u0935\u093e\u0930\u0940"\ + "\u092b\u0947\u092c\u0943\u0935\u093e\u0930\u0940"\ + "\u092e\u093e\u0930\u094d\u091a"\ + "\u090f\u092a\u094d\u0930\u093f\u0932"\ + "\u092e\u0947"\ + "\u091c\u0942\u0928"\ + "\u091c\u0941\u0932\u0948"\ + "\u0913\u0917\u0938\u094d\u091f"\ + "\u0938\u0947\u092a\u094d\u091f\u0947\u0902\u092c\u0930"\ + "\u0913\u0915\u094d\u091f\u094b\u092c\u0930"\ + "\u0928\u094b\u0935\u094d\u0939\u0947\u0902\u092c\u0930"\ + "\u0921\u093f\u0938\u0947\u0902\u092c\u0930"] ::msgcat::mcset mr MONTHS_FULL [list \ - "जानेवारी"\ - "फेबृवारी"\ - "मारà¥à¤š"\ - "à¤à¤ªà¥à¤°à¤¿à¤²"\ - "मे"\ - "जून"\ - "जà¥à¤²à¥ˆ"\ - "ओगसà¥à¤Ÿ"\ - "सेपà¥à¤Ÿà¥‡à¤‚बर"\ - "ओकà¥à¤Ÿà¥‹à¤¬à¤°"\ - "नोवà¥à¤¹à¥‡à¤‚बर"\ - "डिसेंबर"] + "\u091c\u093e\u0928\u0947\u0935\u093e\u0930\u0940"\ + "\u092b\u0947\u092c\u0943\u0935\u093e\u0930\u0940"\ + "\u092e\u093e\u0930\u094d\u091a"\ + "\u090f\u092a\u094d\u0930\u093f\u0932"\ + "\u092e\u0947"\ + "\u091c\u0942\u0928"\ + "\u091c\u0941\u0932\u0948"\ + "\u0913\u0917\u0938\u094d\u091f"\ + "\u0938\u0947\u092a\u094d\u091f\u0947\u0902\u092c\u0930"\ + "\u0913\u0915\u094d\u091f\u094b\u092c\u0930"\ + "\u0928\u094b\u0935\u094d\u0939\u0947\u0902\u092c\u0930"\ + "\u0921\u093f\u0938\u0947\u0902\u092c\u0930"] ::msgcat::mcset mr AM "BC" ::msgcat::mcset mr PM "AD" } Index: library/msgs/mt.msg ================================================================== --- library/msgs/mt.msg +++ library/msgs/mt.msg @@ -1,21 +1,21 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset mt DAYS_OF_WEEK_ABBREV [list \ - "Ħad"\ + "\u0126ad"\ "Tne"\ "Tli"\ "Erb"\ - "Ħam"\ - "Ä im"] + "\u0126am"\ + "\u0120im"] ::msgcat::mcset mt MONTHS_ABBREV [list \ "Jan"\ "Fra"\ "Mar"\ "Apr"\ "Mej"\ - "Ä un"\ + "\u0120un"\ "Lul"\ "Awi"\ "Set"\ "Ott"\ "Nov"] Index: library/msgs/nb.msg ================================================================== --- library/msgs/nb.msg +++ library/msgs/nb.msg @@ -1,23 +1,23 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset nb DAYS_OF_WEEK_ABBREV [list \ - "sø"\ + "s\u00f8"\ "ma"\ "ti"\ "on"\ "to"\ "fr"\ - "lø"] + "l\u00f8"] ::msgcat::mcset nb DAYS_OF_WEEK_FULL [list \ - "søndag"\ + "s\u00f8ndag"\ "mandag"\ "tirsdag"\ "onsdag"\ "torsdag"\ "fredag"\ - "lørdag"] + "l\u00f8rdag"] ::msgcat::mcset nb MONTHS_ABBREV [list \ "jan"\ "feb"\ "mar"\ "apr"\ Index: library/msgs/nn.msg ================================================================== --- library/msgs/nn.msg +++ library/msgs/nn.msg @@ -1,18 +1,18 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset nn DAYS_OF_WEEK_ABBREV [list \ "su"\ - "mÃ¥"\ + "m\u00e5"\ "ty"\ "on"\ "to"\ "fr"\ "lau"] ::msgcat::mcset nn DAYS_OF_WEEK_FULL [list \ "sundag"\ - "mÃ¥ndag"\ + "m\u00e5ndag"\ "tysdag"\ "onsdag"\ "torsdag"\ "fredag"\ "laurdag"] Index: library/msgs/pl.msg ================================================================== --- library/msgs/pl.msg +++ library/msgs/pl.msg @@ -2,21 +2,21 @@ namespace eval ::tcl::clock { ::msgcat::mcset pl DAYS_OF_WEEK_ABBREV [list \ "N"\ "Pn"\ "Wt"\ - "Åšr"\ + "\u015ar"\ "Cz"\ "Pt"\ "So"] ::msgcat::mcset pl DAYS_OF_WEEK_FULL [list \ "niedziela"\ - "poniedziaÅ‚ek"\ + "poniedzia\u0142ek"\ "wtorek"\ - "Å›roda"\ + "\u015broda"\ "czwartek"\ - "piÄ…tek"\ + "pi\u0105tek"\ "sobota"] ::msgcat::mcset pl MONTHS_ABBREV [list \ "sty"\ "lut"\ "mar"\ @@ -24,29 +24,29 @@ "maj"\ "cze"\ "lip"\ "sie"\ "wrz"\ - "paź"\ + "pa\u017a"\ "lis"\ "gru"\ ""] ::msgcat::mcset pl MONTHS_FULL [list \ - "styczeÅ„"\ + "stycze\u0144"\ "luty"\ "marzec"\ - "kwiecieÅ„"\ + "kwiecie\u0144"\ "maj"\ "czerwiec"\ "lipiec"\ - "sierpieÅ„"\ - "wrzesieÅ„"\ - "październik"\ + "sierpie\u0144"\ + "wrzesie\u0144"\ + "pa\u017adziernik"\ "listopad"\ - "grudzieÅ„"\ + "grudzie\u0144"\ ""] ::msgcat::mcset pl BCE "p.n.e." ::msgcat::mcset pl CE "n.e." ::msgcat::mcset pl DATE_FORMAT "%Y-%m-%d" ::msgcat::mcset pl TIME_FORMAT "%H:%M:%S" ::msgcat::mcset pl DATE_TIME_FORMAT "%Y-%m-%d %H:%M:%S %z" } Index: library/msgs/pt.msg ================================================================== --- library/msgs/pt.msg +++ library/msgs/pt.msg @@ -5,19 +5,19 @@ "Seg"\ "Ter"\ "Qua"\ "Qui"\ "Sex"\ - "Sáb"] + "S\u00e1b"] ::msgcat::mcset pt DAYS_OF_WEEK_FULL [list \ "Domingo"\ "Segunda-feira"\ - "Terça-feira"\ + "Ter\u00e7a-feira"\ "Quarta-feira"\ "Quinta-feira"\ "Sexta-feira"\ - "Sábado"] + "S\u00e1bado"] ::msgcat::mcset pt MONTHS_ABBREV [list \ "Jan"\ "Fev"\ "Mar"\ "Abr"\ @@ -31,11 +31,11 @@ "Dez"\ ""] ::msgcat::mcset pt MONTHS_FULL [list \ "Janeiro"\ "Fevereiro"\ - "Março"\ + "Mar\u00e7o"\ "Abril"\ "Maio"\ "Junho"\ "Julho"\ "Agosto"\ Index: library/msgs/ro.msg ================================================================== --- library/msgs/ro.msg +++ library/msgs/ro.msg @@ -7,17 +7,17 @@ "Mi"\ "J"\ "V"\ "S"] ::msgcat::mcset ro DAYS_OF_WEEK_FULL [list \ - "duminică"\ + "duminic\u0103"\ "luni"\ - "marÅ£i"\ + "mar\u0163i"\ "miercuri"\ "joi"\ "vineri"\ - "sîmbătă"] + "s\u00eemb\u0103t\u0103"] ::msgcat::mcset ro MONTHS_ABBREV [list \ "Ian"\ "Feb"\ "Mar"\ "Apr"\ @@ -43,10 +43,10 @@ "octombrie"\ "noiembrie"\ "decembrie"\ ""] ::msgcat::mcset ro BCE "d.C." - ::msgcat::mcset ro CE "î.d.C." + ::msgcat::mcset ro CE "\u00ee.d.C." ::msgcat::mcset ro DATE_FORMAT "%d.%m.%Y" ::msgcat::mcset ro TIME_FORMAT "%H:%M:%S" ::msgcat::mcset ro DATE_TIME_FORMAT "%d.%m.%Y %H:%M:%S %z" } Index: library/msgs/ru.msg ================================================================== --- library/msgs/ru.msg +++ library/msgs/ru.msg @@ -1,52 +1,52 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset ru DAYS_OF_WEEK_ABBREV [list \ - "Ð’Ñ"\ - "Пн"\ - "Ð’Ñ‚"\ - "Ср"\ - "Чт"\ - "Пт"\ - "Сб"] + "\u0412\u0441"\ + "\u041f\u043d"\ + "\u0412\u0442"\ + "\u0421\u0440"\ + "\u0427\u0442"\ + "\u041f\u0442"\ + "\u0421\u0431"] ::msgcat::mcset ru DAYS_OF_WEEK_FULL [list \ - "воÑкреÑенье"\ - "понедельник"\ - "вторник"\ - "Ñреда"\ - "четверг"\ - "пÑтница"\ - "Ñуббота"] + "\u0432\u043e\u0441\u043a\u0440\u0435\u0441\u0435\u043d\u044c\u0435"\ + "\u043f\u043e\u043d\u0435\u0434\u0435\u043b\u044c\u043d\u0438\u043a"\ + "\u0432\u0442\u043e\u0440\u043d\u0438\u043a"\ + "\u0441\u0440\u0435\u0434\u0430"\ + "\u0447\u0435\u0442\u0432\u0435\u0440\u0433"\ + "\u043f\u044f\u0442\u043d\u0438\u0446\u0430"\ + "\u0441\u0443\u0431\u0431\u043e\u0442\u0430"] ::msgcat::mcset ru MONTHS_ABBREV [list \ - "Ñнв"\ - "фев"\ - "мар"\ - "апр"\ - "май"\ - "июн"\ - "июл"\ - "авг"\ - "Ñен"\ - "окт"\ - "ноÑ"\ - "дек"\ + "\u044f\u043d\u0432"\ + "\u0444\u0435\u0432"\ + "\u043c\u0430\u0440"\ + "\u0430\u043f\u0440"\ + "\u043c\u0430\u0439"\ + "\u0438\u044e\u043d"\ + "\u0438\u044e\u043b"\ + "\u0430\u0432\u0433"\ + "\u0441\u0435\u043d"\ + "\u043e\u043a\u0442"\ + "\u043d\u043e\u044f"\ + "\u0434\u0435\u043a"\ ""] ::msgcat::mcset ru MONTHS_FULL [list \ - "Январь"\ - "Февраль"\ - "Март"\ - "Ðпрель"\ - "Май"\ - "Июнь"\ - "Июль"\ - "ÐвгуÑÑ‚"\ - "СентÑбрь"\ - "ОктÑбрь"\ - "ÐоÑбрь"\ - "Декабрь"\ + "\u042f\u043d\u0432\u0430\u0440\u044c"\ + "\u0424\u0435\u0432\u0440\u0430\u043b\u044c"\ + "\u041c\u0430\u0440\u0442"\ + "\u0410\u043f\u0440\u0435\u043b\u044c"\ + "\u041c\u0430\u0439"\ + "\u0418\u044e\u043d\u044c"\ + "\u0418\u044e\u043b\u044c"\ + "\u0410\u0432\u0433\u0443\u0441\u0442"\ + "\u0421\u0435\u043d\u0442\u044f\u0431\u0440\u044c"\ + "\u041e\u043a\u0442\u044f\u0431\u0440\u044c"\ + "\u041d\u043e\u044f\u0431\u0440\u044c"\ + "\u0414\u0435\u043a\u0430\u0431\u0440\u044c"\ ""] - ::msgcat::mcset ru BCE "до н.Ñ." - ::msgcat::mcset ru CE "н.Ñ." + ::msgcat::mcset ru BCE "\u0434\u043e \u043d.\u044d." + ::msgcat::mcset ru CE "\u043d.\u044d." ::msgcat::mcset ru DATE_FORMAT "%d.%m.%Y" ::msgcat::mcset ru TIME_FORMAT "%k:%M:%S" ::msgcat::mcset ru DATE_TIME_FORMAT "%d.%m.%Y %k:%M:%S %z" } Index: library/msgs/sh.msg ================================================================== --- library/msgs/sh.msg +++ library/msgs/sh.msg @@ -3,19 +3,19 @@ ::msgcat::mcset sh DAYS_OF_WEEK_ABBREV [list \ "Ned"\ "Pon"\ "Uto"\ "Sre"\ - "ÄŒet"\ + "\u010cet"\ "Pet"\ "Sub"] ::msgcat::mcset sh DAYS_OF_WEEK_FULL [list \ "Nedelja"\ "Ponedeljak"\ "Utorak"\ "Sreda"\ - "ÄŒetvrtak"\ + "\u010cetvrtak"\ "Petak"\ "Subota"] ::msgcat::mcset sh MONTHS_ABBREV [list \ "Jan"\ "Feb"\ Index: library/msgs/sk.msg ================================================================== --- library/msgs/sk.msg +++ library/msgs/sk.msg @@ -3,46 +3,46 @@ ::msgcat::mcset sk DAYS_OF_WEEK_ABBREV [list \ "Ne"\ "Po"\ "Ut"\ "St"\ - "Å t"\ + "\u0160t"\ "Pa"\ "So"] ::msgcat::mcset sk DAYS_OF_WEEK_FULL [list \ - "Nedeľe"\ + "Nede\u013ee"\ "Pondelok"\ "Utorok"\ "Streda"\ - "Å tvrtok"\ + "\u0160tvrtok"\ "Piatok"\ "Sobota"] ::msgcat::mcset sk MONTHS_ABBREV [list \ "jan"\ "feb"\ "mar"\ "apr"\ - "máj"\ - "jún"\ - "júl"\ + "m\u00e1j"\ + "j\u00fan"\ + "j\u00fal"\ "aug"\ "sep"\ "okt"\ "nov"\ "dec"\ ""] ::msgcat::mcset sk MONTHS_FULL [list \ - "január"\ - "február"\ + "janu\u00e1r"\ + "febru\u00e1r"\ "marec"\ - "apríl"\ - "máj"\ - "jún"\ - "júl"\ + "apr\u00edl"\ + "m\u00e1j"\ + "j\u00fan"\ + "j\u00fal"\ "august"\ "september"\ - "október"\ + "okt\u00f3ber"\ "november"\ "december"\ ""] ::msgcat::mcset sk BCE "pred n.l." ::msgcat::mcset sk CE "n.l." Index: library/msgs/sl.msg ================================================================== --- library/msgs/sl.msg +++ library/msgs/sl.msg @@ -3,19 +3,19 @@ ::msgcat::mcset sl DAYS_OF_WEEK_ABBREV [list \ "Ned"\ "Pon"\ "Tor"\ "Sre"\ - "ÄŒet"\ + "\u010cet"\ "Pet"\ "Sob"] ::msgcat::mcset sl DAYS_OF_WEEK_FULL [list \ "Nedelja"\ "Ponedeljek"\ "Torek"\ "Sreda"\ - "ÄŒetrtek"\ + "\u010cetrtek"\ "Petek"\ "Sobota"] ::msgcat::mcset sl MONTHS_ABBREV [list \ "jan"\ "feb"\ @@ -42,11 +42,11 @@ "september"\ "oktober"\ "november"\ "december"\ ""] - ::msgcat::mcset sl BCE "pr.n.Å¡." + ::msgcat::mcset sl BCE "pr.n.\u0161." ::msgcat::mcset sl CE "po Kr." ::msgcat::mcset sl DATE_FORMAT "%Y.%m.%e" ::msgcat::mcset sl TIME_FORMAT "%k:%M:%S" ::msgcat::mcset sl DATE_TIME_FORMAT "%Y.%m.%e %k:%M:%S %z" } Index: library/msgs/sq.msg ================================================================== --- library/msgs/sq.msg +++ library/msgs/sq.msg @@ -1,23 +1,23 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset sq DAYS_OF_WEEK_ABBREV [list \ "Die"\ - "Hën"\ + "H\u00ebn"\ "Mar"\ - "Mër"\ + "M\u00ebr"\ "Enj"\ "Pre"\ "Sht"] ::msgcat::mcset sq DAYS_OF_WEEK_FULL [list \ "e diel"\ - "e hënë"\ - "e martë"\ - "e mërkurë"\ + "e h\u00ebn\u00eb"\ + "e mart\u00eb"\ + "e m\u00ebrkur\u00eb"\ "e enjte"\ "e premte"\ - "e shtunë"] + "e shtun\u00eb"] ::msgcat::mcset sq MONTHS_ABBREV [list \ "Jan"\ "Shk"\ "Mar"\ "Pri"\ @@ -25,11 +25,11 @@ "Qer"\ "Kor"\ "Gsh"\ "Sht"\ "Tet"\ - "Nën"\ + "N\u00ebn"\ "Dhj"\ ""] ::msgcat::mcset sq MONTHS_FULL [list \ "janar"\ "shkurt"\ @@ -39,11 +39,11 @@ "qershor"\ "korrik"\ "gusht"\ "shtator"\ "tetor"\ - "nëntor"\ + "n\u00ebntor"\ "dhjetor"\ ""] ::msgcat::mcset sq BCE "p.e.r." ::msgcat::mcset sq CE "n.e.r." ::msgcat::mcset sq AM "PD" Index: library/msgs/sr.msg ================================================================== --- library/msgs/sr.msg +++ library/msgs/sr.msg @@ -1,52 +1,52 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset sr DAYS_OF_WEEK_ABBREV [list \ - "Ðед"\ - "Пон"\ - "Уто"\ - "Сре"\ - "Чет"\ - "Пет"\ - "Суб"] + "\u041d\u0435\u0434"\ + "\u041f\u043e\u043d"\ + "\u0423\u0442\u043e"\ + "\u0421\u0440\u0435"\ + "\u0427\u0435\u0442"\ + "\u041f\u0435\u0442"\ + "\u0421\u0443\u0431"] ::msgcat::mcset sr DAYS_OF_WEEK_FULL [list \ - "Ðедеља"\ - "Понедељак"\ - "Уторак"\ - "Среда"\ - "Четвртак"\ - "Петак"\ - "Субота"] + "\u041d\u0435\u0434\u0435\u0459\u0430"\ + "\u041f\u043e\u043d\u0435\u0434\u0435\u0459\u0430\u043a"\ + "\u0423\u0442\u043e\u0440\u0430\u043a"\ + "\u0421\u0440\u0435\u0434\u0430"\ + "\u0427\u0435\u0442\u0432\u0440\u0442\u0430\u043a"\ + "\u041f\u0435\u0442\u0430\u043a"\ + "\u0421\u0443\u0431\u043e\u0442\u0430"] ::msgcat::mcset sr MONTHS_ABBREV [list \ - "Јан"\ - "Феб"\ - "Мар"\ - "Ðпр"\ - "Мај"\ - "Јун"\ - "Јул"\ - "Ðвг"\ - "Сеп"\ - "Окт"\ - "Ðов"\ - "Дец"\ + "\u0408\u0430\u043d"\ + "\u0424\u0435\u0431"\ + "\u041c\u0430\u0440"\ + "\u0410\u043f\u0440"\ + "\u041c\u0430\u0458"\ + "\u0408\u0443\u043d"\ + "\u0408\u0443\u043b"\ + "\u0410\u0432\u0433"\ + "\u0421\u0435\u043f"\ + "\u041e\u043a\u0442"\ + "\u041d\u043e\u0432"\ + "\u0414\u0435\u0446"\ ""] ::msgcat::mcset sr MONTHS_FULL [list \ - "Јануар"\ - "Фебруар"\ - "Март"\ - "Ðприл"\ - "Мај"\ - "Јуни"\ - "Јули"\ - "ÐвгуÑÑ‚"\ - "Септембар"\ - "Октобар"\ - "Ðовембар"\ - "Децембар"\ + "\u0408\u0430\u043d\u0443\u0430\u0440"\ + "\u0424\u0435\u0431\u0440\u0443\u0430\u0440"\ + "\u041c\u0430\u0440\u0442"\ + "\u0410\u043f\u0440\u0438\u043b"\ + "\u041c\u0430\u0458"\ + "\u0408\u0443\u043d\u0438"\ + "\u0408\u0443\u043b\u0438"\ + "\u0410\u0432\u0433\u0443\u0441\u0442"\ + "\u0421\u0435\u043f\u0442\u0435\u043c\u0431\u0430\u0440"\ + "\u041e\u043a\u0442\u043e\u0431\u0430\u0440"\ + "\u041d\u043e\u0432\u0435\u043c\u0431\u0430\u0440"\ + "\u0414\u0435\u0446\u0435\u043c\u0431\u0430\u0440"\ ""] - ::msgcat::mcset sr BCE "п. н. е." - ::msgcat::mcset sr CE "н. е" + ::msgcat::mcset sr BCE "\u043f. \u043d. \u0435." + ::msgcat::mcset sr CE "\u043d. \u0435" ::msgcat::mcset sr DATE_FORMAT "%Y.%m.%e" ::msgcat::mcset sr TIME_FORMAT "%k.%M.%S" ::msgcat::mcset sr DATE_TIME_FORMAT "%Y.%m.%e %k.%M.%S %z" } Index: library/msgs/sv.msg ================================================================== --- library/msgs/sv.msg +++ library/msgs/sv.msg @@ -1,23 +1,23 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset sv DAYS_OF_WEEK_ABBREV [list \ - "sö"\ - "mÃ¥"\ + "s\u00f6"\ + "m\u00e5"\ "ti"\ "on"\ "to"\ "fr"\ - "lö"] + "l\u00f6"] ::msgcat::mcset sv DAYS_OF_WEEK_FULL [list \ - "söndag"\ - "mÃ¥ndag"\ + "s\u00f6ndag"\ + "m\u00e5ndag"\ "tisdag"\ "onsdag"\ "torsdag"\ "fredag"\ - "lördag"] + "l\u00f6rdag"] ::msgcat::mcset sv MONTHS_ABBREV [list \ "jan"\ "feb"\ "mar"\ "apr"\ Index: library/msgs/ta.msg ================================================================== --- library/msgs/ta.msg +++ library/msgs/ta.msg @@ -1,39 +1,39 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset ta DAYS_OF_WEEK_FULL [list \ - "ஞாயிறà¯"\ - "திஙà¯à®•à®³à¯"\ - "செவà¯à®µà®¾à®¯à¯"\ - "பà¯à®¤à®©à¯"\ - "வியாழனà¯"\ - "வெளà¯à®³à®¿"\ - "சனி"] + "\u0b9e\u0bbe\u0baf\u0bbf\u0bb1\u0bc1"\ + "\u0ba4\u0bbf\u0b99\u0bcd\u0b95\u0bb3\u0bcd"\ + "\u0b9a\u0bc6\u0bb5\u0bcd\u0bb5\u0bbe\u0baf\u0bcd"\ + "\u0baa\u0bc1\u0ba4\u0ba9\u0bcd"\ + "\u0bb5\u0bbf\u0baf\u0bbe\u0bb4\u0ba9\u0bcd"\ + "\u0bb5\u0bc6\u0bb3\u0bcd\u0bb3\u0bbf"\ + "\u0b9a\u0ba9\u0bbf"] ::msgcat::mcset ta MONTHS_ABBREV [list \ - "ஜனவரி"\ - "பெபà¯à®°à®µà®°à®¿"\ - "மாரà¯à®šà¯"\ - "à®à®ªà¯à®°à®²à¯"\ - "மே"\ - "ஜூனà¯"\ - "ஜூலை"\ - "ஆகஸà¯à®Ÿà¯"\ - "செபà¯à®Ÿà®®à¯à®ªà®°à¯"\ - "அகà¯à®Ÿà¯‹à®ªà®°à¯"\ - "நவமà¯à®ªà®°à¯"\ - "டிசமà¯à®ªà®°à¯r"] + "\u0b9c\u0ba9\u0bb5\u0bb0\u0bbf"\ + "\u0baa\u0bc6\u0baa\u0bcd\u0bb0\u0bb5\u0bb0\u0bbf"\ + "\u0bae\u0bbe\u0bb0\u0bcd\u0b9a\u0bcd"\ + "\u0b8f\u0baa\u0bcd\u0bb0\u0bb2\u0bcd"\ + "\u0bae\u0bc7"\ + "\u0b9c\u0bc2\u0ba9\u0bcd"\ + "\u0b9c\u0bc2\u0bb2\u0bc8"\ + "\u0b86\u0b95\u0bb8\u0bcd\u0b9f\u0bcd"\ + "\u0b9a\u0bc6\u0baa\u0bcd\u0b9f\u0bae\u0bcd\u0baa\u0bb0\u0bcd"\ + "\u0b85\u0b95\u0bcd\u0b9f\u0bcb\u0baa\u0bb0\u0bcd"\ + "\u0ba8\u0bb5\u0bae\u0bcd\u0baa\u0bb0\u0bcd"\ + "\u0b9f\u0bbf\u0b9a\u0bae\u0bcd\u0baa\u0bb0\u0bcdr"] ::msgcat::mcset ta MONTHS_FULL [list \ - "ஜனவரி"\ - "பெபà¯à®°à®µà®°à®¿"\ - "மாரà¯à®šà¯"\ - "à®à®ªà¯à®°à®²à¯"\ - "மே"\ - "ஜூனà¯"\ - "ஜூலை"\ - "ஆகஸà¯à®Ÿà¯"\ - "செபà¯à®Ÿà®®à¯à®ªà®°à¯"\ - "அகà¯à®Ÿà¯‹à®ªà®°à¯"\ - "நவமà¯à®ªà®°à¯"\ - "டிசமà¯à®ªà®°à¯r"] - ::msgcat::mcset ta AM "கிமà¯" - ::msgcat::mcset ta PM "கிபி" + "\u0b9c\u0ba9\u0bb5\u0bb0\u0bbf"\ + "\u0baa\u0bc6\u0baa\u0bcd\u0bb0\u0bb5\u0bb0\u0bbf"\ + "\u0bae\u0bbe\u0bb0\u0bcd\u0b9a\u0bcd"\ + "\u0b8f\u0baa\u0bcd\u0bb0\u0bb2\u0bcd"\ + "\u0bae\u0bc7"\ + "\u0b9c\u0bc2\u0ba9\u0bcd"\ + "\u0b9c\u0bc2\u0bb2\u0bc8"\ + "\u0b86\u0b95\u0bb8\u0bcd\u0b9f\u0bcd"\ + "\u0b9a\u0bc6\u0baa\u0bcd\u0b9f\u0bae\u0bcd\u0baa\u0bb0\u0bcd"\ + "\u0b85\u0b95\u0bcd\u0b9f\u0bcb\u0baa\u0bb0\u0bcd"\ + "\u0ba8\u0bb5\u0bae\u0bcd\u0baa\u0bb0\u0bcd"\ + "\u0b9f\u0bbf\u0b9a\u0bae\u0bcd\u0baa\u0bb0\u0bcdr"] + ::msgcat::mcset ta AM "\u0b95\u0bbf\u0bae\u0bc1" + ::msgcat::mcset ta PM "\u0b95\u0bbf\u0baa\u0bbf" } Index: library/msgs/te.msg ================================================================== --- library/msgs/te.msg +++ library/msgs/te.msg @@ -1,47 +1,47 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset te DAYS_OF_WEEK_ABBREV [list \ - "ఆది"\ - "సోమ"\ - "మంగళ"\ - "à°¬à±à°§"\ - "à°—à±à°°à±"\ - "à°¶à±à°•à±à°°"\ - "శని"] + "\u0c06\u0c26\u0c3f"\ + "\u0c38\u0c4b\u0c2e"\ + "\u0c2e\u0c02\u0c17\u0c33"\ + "\u0c2c\u0c41\u0c27"\ + "\u0c17\u0c41\u0c30\u0c41"\ + "\u0c36\u0c41\u0c15\u0c4d\u0c30"\ + "\u0c36\u0c28\u0c3f"] ::msgcat::mcset te DAYS_OF_WEEK_FULL [list \ - "ఆదివారం"\ - "సోమవారం"\ - "మంగళవారం"\ - "à°¬à±à°§à°µà°¾à°°à°‚"\ - "à°—à±à°°à±à°µà°¾à°°à°‚"\ - "à°¶à±à°•à±à°°à°µà°¾à°°à°‚"\ - "శనివారం"] + "\u0c06\u0c26\u0c3f\u0c35\u0c3e\u0c30\u0c02"\ + "\u0c38\u0c4b\u0c2e\u0c35\u0c3e\u0c30\u0c02"\ + "\u0c2e\u0c02\u0c17\u0c33\u0c35\u0c3e\u0c30\u0c02"\ + "\u0c2c\u0c41\u0c27\u0c35\u0c3e\u0c30\u0c02"\ + "\u0c17\u0c41\u0c30\u0c41\u0c35\u0c3e\u0c30\u0c02"\ + "\u0c36\u0c41\u0c15\u0c4d\u0c30\u0c35\u0c3e\u0c30\u0c02"\ + "\u0c36\u0c28\u0c3f\u0c35\u0c3e\u0c30\u0c02"] ::msgcat::mcset te MONTHS_ABBREV [list \ - "జనవరి"\ - "à°«à°¿à°¬à±à°°à°µà°°à°¿"\ - "మారà±à°šà°¿"\ - "à°à°ªà±à°°à°¿à°²à±"\ - "మే"\ - "జూనà±"\ - "జూలై"\ - "ఆగసà±à°Ÿà±"\ - "సెపà±à°Ÿà±†à°‚బరà±"\ - "à°…à°•à±à°Ÿà±‹à°¬à°°à±"\ - "నవంబరà±"\ - "డిసెంబరà±"\ + "\u0c1c\u0c28\u0c35\u0c30\u0c3f"\ + "\u0c2b\u0c3f\u0c2c\u0c4d\u0c30\u0c35\u0c30\u0c3f"\ + "\u0c2e\u0c3e\u0c30\u0c4d\u0c1a\u0c3f"\ + "\u0c0f\u0c2a\u0c4d\u0c30\u0c3f\u0c32\u0c4d"\ + "\u0c2e\u0c47"\ + "\u0c1c\u0c42\u0c28\u0c4d"\ + "\u0c1c\u0c42\u0c32\u0c48"\ + "\u0c06\u0c17\u0c38\u0c4d\u0c1f\u0c41"\ + "\u0c38\u0c46\u0c2a\u0c4d\u0c1f\u0c46\u0c02\u0c2c\u0c30\u0c4d"\ + "\u0c05\u0c15\u0c4d\u0c1f\u0c4b\u0c2c\u0c30\u0c4d"\ + "\u0c28\u0c35\u0c02\u0c2c\u0c30\u0c4d"\ + "\u0c21\u0c3f\u0c38\u0c46\u0c02\u0c2c\u0c30\u0c4d"\ ""] ::msgcat::mcset te MONTHS_FULL [list \ - "జనవరి"\ - "à°«à°¿à°¬à±à°°à°µà°°à°¿"\ - "మారà±à°šà°¿"\ - "à°à°ªà±à°°à°¿à°²à±"\ - "మే"\ - "జూనà±"\ - "జూలై"\ - "ఆగసà±à°Ÿà±"\ - "సెపà±à°Ÿà±†à°‚బరà±"\ - "à°…à°•à±à°Ÿà±‹à°¬à°°à±"\ - "నవంబరà±"\ - "డిసెంబరà±"\ + "\u0c1c\u0c28\u0c35\u0c30\u0c3f"\ + "\u0c2b\u0c3f\u0c2c\u0c4d\u0c30\u0c35\u0c30\u0c3f"\ + "\u0c2e\u0c3e\u0c30\u0c4d\u0c1a\u0c3f"\ + "\u0c0f\u0c2a\u0c4d\u0c30\u0c3f\u0c32\u0c4d"\ + "\u0c2e\u0c47"\ + "\u0c1c\u0c42\u0c28\u0c4d"\ + "\u0c1c\u0c42\u0c32\u0c48"\ + "\u0c06\u0c17\u0c38\u0c4d\u0c1f\u0c41"\ + "\u0c38\u0c46\u0c2a\u0c4d\u0c1f\u0c46\u0c02\u0c2c\u0c30\u0c4d"\ + "\u0c05\u0c15\u0c4d\u0c1f\u0c4b\u0c2c\u0c30\u0c4d"\ + "\u0c28\u0c35\u0c02\u0c2c\u0c30\u0c4d"\ + "\u0c21\u0c3f\u0c38\u0c46\u0c02\u0c2c\u0c30\u0c4d"\ ""] } Index: library/msgs/te_in.msg ================================================================== --- library/msgs/te_in.msg +++ library/msgs/te_in.msg @@ -1,8 +1,8 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { - ::msgcat::mcset te_IN AM "పూరà±à°µà°¾à°¹à±à°¨" - ::msgcat::mcset te_IN PM "అపరాహà±à°¨" + ::msgcat::mcset te_IN AM "\u0c2a\u0c42\u0c30\u0c4d\u0c35\u0c3e\u0c39\u0c4d\u0c28" + ::msgcat::mcset te_IN PM "\u0c05\u0c2a\u0c30\u0c3e\u0c39\u0c4d\u0c28" ::msgcat::mcset te_IN DATE_FORMAT "%d/%m/%Y" ::msgcat::mcset te_IN TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset te_IN DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z" } Index: library/msgs/th.msg ================================================================== --- library/msgs/th.msg +++ library/msgs/th.msg @@ -1,54 +1,54 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset th DAYS_OF_WEEK_ABBREV [list \ - "อา."\ - "จ."\ - "อ."\ - "พ."\ - "พฤ."\ - "ศ."\ - "ส."] + "\u0e2d\u0e32."\ + "\u0e08."\ + "\u0e2d."\ + "\u0e1e."\ + "\u0e1e\u0e24."\ + "\u0e28."\ + "\u0e2a."] ::msgcat::mcset th DAYS_OF_WEEK_FULL [list \ - "วันอาทิตย์"\ - "วันจันทร์"\ - "วันอังคาร"\ - "วันพุธ"\ - "วันพฤหัสบดี"\ - "วันศุà¸à¸£à¹Œ"\ - "วันเสาร์"] + "\u0e27\u0e31\u0e19\u0e2d\u0e32\u0e17\u0e34\u0e15\u0e22\u0e4c"\ + "\u0e27\u0e31\u0e19\u0e08\u0e31\u0e19\u0e17\u0e23\u0e4c"\ + "\u0e27\u0e31\u0e19\u0e2d\u0e31\u0e07\u0e04\u0e32\u0e23"\ + "\u0e27\u0e31\u0e19\u0e1e\u0e38\u0e18"\ + "\u0e27\u0e31\u0e19\u0e1e\u0e24\u0e2b\u0e31\u0e2a\u0e1a\u0e14\u0e35"\ + "\u0e27\u0e31\u0e19\u0e28\u0e38\u0e01\u0e23\u0e4c"\ + "\u0e27\u0e31\u0e19\u0e40\u0e2a\u0e32\u0e23\u0e4c"] ::msgcat::mcset th MONTHS_ABBREV [list \ - "ม.ค."\ - "à¸.พ."\ - "มี.ค."\ - "เม.ย."\ - "พ.ค."\ - "มิ.ย."\ - "à¸.ค."\ - "ส.ค."\ - "à¸.ย."\ - "ต.ค."\ - "พ.ย."\ - "ธ.ค."\ + "\u0e21.\u0e04."\ + "\u0e01.\u0e1e."\ + "\u0e21\u0e35.\u0e04."\ + "\u0e40\u0e21.\u0e22."\ + "\u0e1e.\u0e04."\ + "\u0e21\u0e34.\u0e22."\ + "\u0e01.\u0e04."\ + "\u0e2a.\u0e04."\ + "\u0e01.\u0e22."\ + "\u0e15.\u0e04."\ + "\u0e1e.\u0e22."\ + "\u0e18.\u0e04."\ ""] ::msgcat::mcset th MONTHS_FULL [list \ - "มà¸à¸£à¸²à¸„ม"\ - "à¸à¸¸à¸¡à¸ à¸²à¸žà¸±à¸™à¸˜à¹Œ"\ - "มีนาคม"\ - "เมษายน"\ - "พฤษภาคม"\ - "มิถุนายน"\ - "à¸à¸£à¸à¸Žà¸²à¸„ม"\ - "สิงหาคม"\ - "à¸à¸±à¸™à¸¢à¸²à¸¢à¸™"\ - "ตุลาคม"\ - "พฤศจิà¸à¸²à¸¢à¸™"\ - "ธันวาคม"\ + "\u0e21\u0e01\u0e23\u0e32\u0e04\u0e21"\ + "\u0e01\u0e38\u0e21\u0e20\u0e32\u0e1e\u0e31\u0e19\u0e18\u0e4c"\ + "\u0e21\u0e35\u0e19\u0e32\u0e04\u0e21"\ + "\u0e40\u0e21\u0e29\u0e32\u0e22\u0e19"\ + "\u0e1e\u0e24\u0e29\u0e20\u0e32\u0e04\u0e21"\ + "\u0e21\u0e34\u0e16\u0e38\u0e19\u0e32\u0e22\u0e19"\ + "\u0e01\u0e23\u0e01\u0e0e\u0e32\u0e04\u0e21"\ + "\u0e2a\u0e34\u0e07\u0e2b\u0e32\u0e04\u0e21"\ + "\u0e01\u0e31\u0e19\u0e22\u0e32\u0e22\u0e19"\ + "\u0e15\u0e38\u0e25\u0e32\u0e04\u0e21"\ + "\u0e1e\u0e24\u0e28\u0e08\u0e34\u0e01\u0e32\u0e22\u0e19"\ + "\u0e18\u0e31\u0e19\u0e27\u0e32\u0e04\u0e21"\ ""] - ::msgcat::mcset th BCE "ลที่" - ::msgcat::mcset th CE "ค.ศ." - ::msgcat::mcset th AM "à¸à¹ˆà¸­à¸™à¹€à¸—ี่ยง" - ::msgcat::mcset th PM "หลังเที่ยง" + ::msgcat::mcset th BCE "\u0e25\u0e17\u0e35\u0e48" + ::msgcat::mcset th CE "\u0e04.\u0e28." + ::msgcat::mcset th AM "\u0e01\u0e48\u0e2d\u0e19\u0e40\u0e17\u0e35\u0e48\u0e22\u0e07" + ::msgcat::mcset th PM "\u0e2b\u0e25\u0e31\u0e07\u0e40\u0e17\u0e35\u0e48\u0e22\u0e07" ::msgcat::mcset th DATE_FORMAT "%e/%m/%Y" ::msgcat::mcset th TIME_FORMAT "%k:%M:%S" ::msgcat::mcset th DATE_TIME_FORMAT "%e/%m/%Y %k:%M:%S %z" } Index: library/msgs/tr.msg ================================================================== --- library/msgs/tr.msg +++ library/msgs/tr.msg @@ -2,49 +2,49 @@ namespace eval ::tcl::clock { ::msgcat::mcset tr DAYS_OF_WEEK_ABBREV [list \ "Paz"\ "Pzt"\ "Sal"\ - "Çar"\ + "\u00c7ar"\ "Per"\ "Cum"\ "Cmt"] ::msgcat::mcset tr DAYS_OF_WEEK_FULL [list \ "Pazar"\ "Pazartesi"\ - "Salı"\ - "ÇarÅŸamba"\ - "PerÅŸembe"\ + "Sal\u0131"\ + "\u00c7ar\u015famba"\ + "Per\u015fembe"\ "Cuma"\ "Cumartesi"] ::msgcat::mcset tr MONTHS_ABBREV [list \ "Oca"\ - "Åžub"\ + "\u015eub"\ "Mar"\ "Nis"\ "May"\ "Haz"\ "Tem"\ - "AÄŸu"\ + "A\u011fu"\ "Eyl"\ "Eki"\ "Kas"\ "Ara"\ ""] ::msgcat::mcset tr MONTHS_FULL [list \ "Ocak"\ - "Åžubat"\ + "\u015eubat"\ "Mart"\ "Nisan"\ - "Mayıs"\ + "May\u0131s"\ "Haziran"\ "Temmuz"\ - "AÄŸustos"\ - "Eylül"\ + "A\u011fustos"\ + "Eyl\u00fcl"\ "Ekim"\ - "Kasım"\ - "Aralık"\ + "Kas\u0131m"\ + "Aral\u0131k"\ ""] ::msgcat::mcset tr DATE_FORMAT "%d.%m.%Y" ::msgcat::mcset tr TIME_FORMAT "%H:%M:%S" ::msgcat::mcset tr DATE_TIME_FORMAT "%d.%m.%Y %H:%M:%S %z" } Index: library/msgs/uk.msg ================================================================== --- library/msgs/uk.msg +++ library/msgs/uk.msg @@ -1,52 +1,52 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset uk DAYS_OF_WEEK_ABBREV [list \ - "нд"\ - "пн"\ - "вт"\ - "ÑÑ€"\ - "чт"\ - "пт"\ - "Ñб"] + "\u043d\u0434"\ + "\u043f\u043d"\ + "\u0432\u0442"\ + "\u0441\u0440"\ + "\u0447\u0442"\ + "\u043f\u0442"\ + "\u0441\u0431"] ::msgcat::mcset uk DAYS_OF_WEEK_FULL [list \ - "неділÑ"\ - "понеділок"\ - "вівторок"\ - "Ñереда"\ - "четвер"\ - "п'ÑтницÑ"\ - "Ñубота"] + "\u043d\u0435\u0434\u0456\u043b\u044f"\ + "\u043f\u043e\u043d\u0435\u0434\u0456\u043b\u043e\u043a"\ + "\u0432\u0456\u0432\u0442\u043e\u0440\u043e\u043a"\ + "\u0441\u0435\u0440\u0435\u0434\u0430"\ + "\u0447\u0435\u0442\u0432\u0435\u0440"\ + "\u043f'\u044f\u0442\u043d\u0438\u0446\u044f"\ + "\u0441\u0443\u0431\u043e\u0442\u0430"] ::msgcat::mcset uk MONTHS_ABBREV [list \ - "Ñіч"\ - "лют"\ - "бер"\ - "квіт"\ - "трав"\ - "черв"\ - "лип"\ - "Ñерп"\ - "вер"\ - "жовт"\ - "лиÑÑ‚"\ - "груд"\ + "\u0441\u0456\u0447"\ + "\u043b\u044e\u0442"\ + "\u0431\u0435\u0440"\ + "\u043a\u0432\u0456\u0442"\ + "\u0442\u0440\u0430\u0432"\ + "\u0447\u0435\u0440\u0432"\ + "\u043b\u0438\u043f"\ + "\u0441\u0435\u0440\u043f"\ + "\u0432\u0435\u0440"\ + "\u0436\u043e\u0432\u0442"\ + "\u043b\u0438\u0441\u0442"\ + "\u0433\u0440\u0443\u0434"\ ""] ::msgcat::mcset uk MONTHS_FULL [list \ - "ÑічнÑ"\ - "лютого"\ - "березнÑ"\ - "квітнÑ"\ - "травнÑ"\ - "червнÑ"\ - "липнÑ"\ - "ÑерпнÑ"\ - "вереÑнÑ"\ - "жовтнÑ"\ - "лиÑтопада"\ - "груднÑ"\ + "\u0441\u0456\u0447\u043d\u044f"\ + "\u043b\u044e\u0442\u043e\u0433\u043e"\ + "\u0431\u0435\u0440\u0435\u0437\u043d\u044f"\ + "\u043a\u0432\u0456\u0442\u043d\u044f"\ + "\u0442\u0440\u0430\u0432\u043d\u044f"\ + "\u0447\u0435\u0440\u0432\u043d\u044f"\ + "\u043b\u0438\u043f\u043d\u044f"\ + "\u0441\u0435\u0440\u043f\u043d\u044f"\ + "\u0432\u0435\u0440\u0435\u0441\u043d\u044f"\ + "\u0436\u043e\u0432\u0442\u043d\u044f"\ + "\u043b\u0438\u0441\u0442\u043e\u043f\u0430\u0434\u0430"\ + "\u0433\u0440\u0443\u0434\u043d\u044f"\ ""] - ::msgcat::mcset uk BCE "до н.е." - ::msgcat::mcset uk CE "піÑÐ»Ñ Ð½.е." + ::msgcat::mcset uk BCE "\u0434\u043e \u043d.\u0435." + ::msgcat::mcset uk CE "\u043f\u0456\u0441\u043b\u044f \u043d.\u0435." ::msgcat::mcset uk DATE_FORMAT "%e/%m/%Y" ::msgcat::mcset uk TIME_FORMAT "%k:%M:%S" ::msgcat::mcset uk DATE_TIME_FORMAT "%e/%m/%Y %k:%M:%S %z" } Index: library/msgs/vi.msg ================================================================== --- library/msgs/vi.msg +++ library/msgs/vi.msg @@ -7,17 +7,17 @@ "Th 5"\ "Th 6"\ "Th 7"\ "CN"] ::msgcat::mcset vi DAYS_OF_WEEK_FULL [list \ - "ThÆ°Ì hai"\ - "ThÆ°Ì ba"\ - "ThÆ°Ì tÆ°"\ - "ThÆ°Ì năm"\ - "ThÆ°Ì sáu"\ - "ThÆ°Ì bảy"\ - "Chủ nhật"] + "Th\u01b0\u0301 hai"\ + "Th\u01b0\u0301 ba"\ + "Th\u01b0\u0301 t\u01b0"\ + "Th\u01b0\u0301 n\u0103m"\ + "Th\u01b0\u0301 s\u00e1u"\ + "Th\u01b0\u0301 ba\u0309y"\ + "Chu\u0309 nh\u00e2\u0323t"] ::msgcat::mcset vi MONTHS_ABBREV [list \ "Thg 1"\ "Thg 2"\ "Thg 3"\ "Thg 4"\ @@ -29,22 +29,22 @@ "Thg 10"\ "Thg 11"\ "Thg 12"\ ""] ::msgcat::mcset vi MONTHS_FULL [list \ - "Tháng một"\ - "Tháng hai"\ - "Tháng ba"\ - "Tháng tÆ°"\ - "Tháng năm"\ - "Tháng sáu"\ - "Tháng bảy"\ - "Tháng tám"\ - "Tháng chín"\ - "Tháng mÆ°Æ¡Ì€i"\ - "Tháng mÆ°Æ¡Ì€i một"\ - "Tháng mÆ°Æ¡Ì€i hai"\ + "Th\u00e1ng m\u00f4\u0323t"\ + "Th\u00e1ng hai"\ + "Th\u00e1ng ba"\ + "Th\u00e1ng t\u01b0"\ + "Th\u00e1ng n\u0103m"\ + "Th\u00e1ng s\u00e1u"\ + "Th\u00e1ng ba\u0309y"\ + "Th\u00e1ng t\u00e1m"\ + "Th\u00e1ng ch\u00edn"\ + "Th\u00e1ng m\u01b0\u01a1\u0300i"\ + "Th\u00e1ng m\u01b0\u01a1\u0300i m\u00f4\u0323t"\ + "Th\u00e1ng m\u01b0\u01a1\u0300i hai"\ ""] ::msgcat::mcset vi DATE_FORMAT "%d %b %Y" ::msgcat::mcset vi TIME_FORMAT "%H:%M:%S" ::msgcat::mcset vi DATE_TIME_FORMAT "%d %b %Y %H:%M:%S %z" } Index: library/msgs/zh.msg ================================================================== --- library/msgs/zh.msg +++ library/msgs/zh.msg @@ -1,55 +1,55 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset zh DAYS_OF_WEEK_ABBREV [list \ - "星期日"\ - "星期一"\ - "星期二"\ - "星期三"\ - "星期四"\ - "星期五"\ - "星期六"] + "\u661f\u671f\u65e5"\ + "\u661f\u671f\u4e00"\ + "\u661f\u671f\u4e8c"\ + "\u661f\u671f\u4e09"\ + "\u661f\u671f\u56db"\ + "\u661f\u671f\u4e94"\ + "\u661f\u671f\u516d"] ::msgcat::mcset zh DAYS_OF_WEEK_FULL [list \ - "星期日"\ - "星期一"\ - "星期二"\ - "星期三"\ - "星期四"\ - "星期五"\ - "星期六"] + "\u661f\u671f\u65e5"\ + "\u661f\u671f\u4e00"\ + "\u661f\u671f\u4e8c"\ + "\u661f\u671f\u4e09"\ + "\u661f\u671f\u56db"\ + "\u661f\u671f\u4e94"\ + "\u661f\u671f\u516d"] ::msgcat::mcset zh MONTHS_ABBREV [list \ - "一月"\ - "二月"\ - "三月"\ - "四月"\ - "五月"\ - "六月"\ - "七月"\ - "八月"\ - "ä¹æœˆ"\ - "å月"\ - "å一月"\ - "å二月"\ + "\u4e00\u6708"\ + "\u4e8c\u6708"\ + "\u4e09\u6708"\ + "\u56db\u6708"\ + "\u4e94\u6708"\ + "\u516d\u6708"\ + "\u4e03\u6708"\ + "\u516b\u6708"\ + "\u4e5d\u6708"\ + "\u5341\u6708"\ + "\u5341\u4e00\u6708"\ + "\u5341\u4e8c\u6708"\ ""] ::msgcat::mcset zh MONTHS_FULL [list \ - "一月"\ - "二月"\ - "三月"\ - "四月"\ - "五月"\ - "六月"\ - "七月"\ - "八月"\ - "ä¹æœˆ"\ - "å月"\ - "å一月"\ - "å二月"\ + "\u4e00\u6708"\ + "\u4e8c\u6708"\ + "\u4e09\u6708"\ + "\u56db\u6708"\ + "\u4e94\u6708"\ + "\u516d\u6708"\ + "\u4e03\u6708"\ + "\u516b\u6708"\ + "\u4e5d\u6708"\ + "\u5341\u6708"\ + "\u5341\u4e00\u6708"\ + "\u5341\u4e8c\u6708"\ ""] - ::msgcat::mcset zh BCE "公元å‰" - ::msgcat::mcset zh CE "公元" - ::msgcat::mcset zh AM "上åˆ" - ::msgcat::mcset zh PM "下åˆ" - ::msgcat::mcset zh LOCALE_NUMERALS "〇 一 二 三 å›› 五 å…­ 七 å…« ä¹ å å一 å二 å三 åå›› å五 åå…­ å七 åå…« åä¹ äºŒå 廿一 廿二 廿三 廿四 廿五 廿六 廿七 廿八 å»¿ä¹ ä¸‰å å…一 å…二 å…三 å…å›› å…五 å…å…­ å…七 å…å…« å…ä¹ å››å å››å一 å››å二 å››å三 å››åå›› å››å五 å››åå…­ å››å七 å››åå…« å››åä¹ äº”å 五å一 五å二 五å三 五åå›› 五å五 五åå…­ 五å七 五åå…« 五åä¹ å…­å å…­å一 å…­å二 å…­å三 å…­åå›› å…­å五 å…­åå…­ å…­å七 å…­åå…« å…­åä¹ ä¸ƒå 七å一 七å二 七å三 七åå›› 七å五 七åå…­ 七å七 七åå…« 七åä¹ å…«å å…«å一 å…«å二 å…«å三 å…«åå›› å…«å五 å…«åå…­ å…«å七 å…«åå…« å…«åä¹ ä¹å ä¹å一 ä¹å二 ä¹å三 ä¹åå›› ä¹å五 ä¹åå…­ ä¹å七 ä¹åå…« ä¹åä¹" - ::msgcat::mcset zh LOCALE_DATE_FORMAT "公元%Yå¹´%B%Odæ—¥" - ::msgcat::mcset zh LOCALE_TIME_FORMAT "%OHæ—¶%OM分%OS秒" - ::msgcat::mcset zh LOCALE_DATE_TIME_FORMAT "%A %Yå¹´%B%Odæ—¥%OHæ—¶%OM分%OS秒 %z" + ::msgcat::mcset zh BCE "\u516c\u5143\u524d" + ::msgcat::mcset zh CE "\u516c\u5143" + ::msgcat::mcset zh AM "\u4e0a\u5348" + ::msgcat::mcset zh PM "\u4e0b\u5348" + ::msgcat::mcset zh LOCALE_NUMERALS "\u3007 \u4e00 \u4e8c \u4e09 \u56db \u4e94 \u516d \u4e03 \u516b \u4e5d \u5341 \u5341\u4e00 \u5341\u4e8c \u5341\u4e09 \u5341\u56db \u5341\u4e94 \u5341\u516d \u5341\u4e03 \u5341\u516b \u5341\u4e5d \u4e8c\u5341 \u5eff\u4e00 \u5eff\u4e8c \u5eff\u4e09 \u5eff\u56db \u5eff\u4e94 \u5eff\u516d \u5eff\u4e03 \u5eff\u516b \u5eff\u4e5d \u4e09\u5341 \u5345\u4e00 \u5345\u4e8c \u5345\u4e09 \u5345\u56db \u5345\u4e94 \u5345\u516d \u5345\u4e03 \u5345\u516b \u5345\u4e5d \u56db\u5341 \u56db\u5341\u4e00 \u56db\u5341\u4e8c \u56db\u5341\u4e09 \u56db\u5341\u56db \u56db\u5341\u4e94 \u56db\u5341\u516d \u56db\u5341\u4e03 \u56db\u5341\u516b \u56db\u5341\u4e5d \u4e94\u5341 \u4e94\u5341\u4e00 \u4e94\u5341\u4e8c \u4e94\u5341\u4e09 \u4e94\u5341\u56db \u4e94\u5341\u4e94 \u4e94\u5341\u516d \u4e94\u5341\u4e03 \u4e94\u5341\u516b \u4e94\u5341\u4e5d \u516d\u5341 \u516d\u5341\u4e00 \u516d\u5341\u4e8c \u516d\u5341\u4e09 \u516d\u5341\u56db \u516d\u5341\u4e94 \u516d\u5341\u516d \u516d\u5341\u4e03 \u516d\u5341\u516b \u516d\u5341\u4e5d \u4e03\u5341 \u4e03\u5341\u4e00 \u4e03\u5341\u4e8c \u4e03\u5341\u4e09 \u4e03\u5341\u56db \u4e03\u5341\u4e94 \u4e03\u5341\u516d \u4e03\u5341\u4e03 \u4e03\u5341\u516b \u4e03\u5341\u4e5d \u516b\u5341 \u516b\u5341\u4e00 \u516b\u5341\u4e8c \u516b\u5341\u4e09 \u516b\u5341\u56db \u516b\u5341\u4e94 \u516b\u5341\u516d \u516b\u5341\u4e03 \u516b\u5341\u516b \u516b\u5341\u4e5d \u4e5d\u5341 \u4e5d\u5341\u4e00 \u4e5d\u5341\u4e8c \u4e5d\u5341\u4e09 \u4e5d\u5341\u56db \u4e5d\u5341\u4e94 \u4e5d\u5341\u516d \u4e5d\u5341\u4e03 \u4e5d\u5341\u516b \u4e5d\u5341\u4e5d" + ::msgcat::mcset zh LOCALE_DATE_FORMAT "\u516c\u5143%Y\u5e74%B%Od\u65e5" + ::msgcat::mcset zh LOCALE_TIME_FORMAT "%OH\u65f6%OM\u5206%OS\u79d2" + ::msgcat::mcset zh LOCALE_DATE_TIME_FORMAT "%A %Y\u5e74%B%Od\u65e5%OH\u65f6%OM\u5206%OS\u79d2 %z" } Index: library/msgs/zh_cn.msg ================================================================== --- library/msgs/zh_cn.msg +++ library/msgs/zh_cn.msg @@ -1,7 +1,7 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset zh_CN DATE_FORMAT "%Y-%m-%e" ::msgcat::mcset zh_CN TIME_FORMAT "%k:%M:%S" - ::msgcat::mcset zh_CN TIME_FORMAT_12 "%P%Iæ—¶%M分%S秒" + ::msgcat::mcset zh_CN TIME_FORMAT_12 "%P%I\u65f6%M\u5206%S\u79d2" ::msgcat::mcset zh_CN DATE_TIME_FORMAT "%Y-%m-%e %k:%M:%S %z" } Index: library/msgs/zh_hk.msg ================================================================== --- library/msgs/zh_hk.msg +++ library/msgs/zh_hk.msg @@ -1,28 +1,28 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset zh_HK DAYS_OF_WEEK_ABBREV [list \ - "æ—¥"\ - "一"\ - "二"\ - "三"\ - "å››"\ - "五"\ - "å…­"] + "\u65e5"\ + "\u4e00"\ + "\u4e8c"\ + "\u4e09"\ + "\u56db"\ + "\u4e94"\ + "\u516d"] ::msgcat::mcset zh_HK MONTHS_ABBREV [list \ - "1月"\ - "2月"\ - "3月"\ - "4月"\ - "5月"\ - "6月"\ - "7月"\ - "8月"\ - "9月"\ - "10月"\ - "11月"\ - "12月"\ + "1\u6708"\ + "2\u6708"\ + "3\u6708"\ + "4\u6708"\ + "5\u6708"\ + "6\u6708"\ + "7\u6708"\ + "8\u6708"\ + "9\u6708"\ + "10\u6708"\ + "11\u6708"\ + "12\u6708"\ ""] - ::msgcat::mcset zh_HK DATE_FORMAT "%Yå¹´%m月%eæ—¥" + ::msgcat::mcset zh_HK DATE_FORMAT "%Y\u5e74%m\u6708%e\u65e5" ::msgcat::mcset zh_HK TIME_FORMAT_12 "%P%I:%M:%S" - ::msgcat::mcset zh_HK DATE_TIME_FORMAT "%Yå¹´%m月%eæ—¥ %P%I:%M:%S %z" + ::msgcat::mcset zh_HK DATE_TIME_FORMAT "%Y\u5e74%m\u6708%e\u65e5 %P%I:%M:%S %z" } Index: library/msgs/zh_sg.msg ================================================================== --- library/msgs/zh_sg.msg +++ library/msgs/zh_sg.msg @@ -1,8 +1,8 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { - ::msgcat::mcset zh_SG AM "上åˆ" - ::msgcat::mcset zh_SG PM "中åˆ" + ::msgcat::mcset zh_SG AM "\u4e0a\u5348" + ::msgcat::mcset zh_SG PM "\u4e2d\u5348" ::msgcat::mcset zh_SG DATE_FORMAT "%d %B %Y" ::msgcat::mcset zh_SG TIME_FORMAT_12 "%P %I:%M:%S" ::msgcat::mcset zh_SG DATE_TIME_FORMAT "%d %B %Y %P %I:%M:%S %z" } Index: library/msgs/zh_tw.msg ================================================================== --- library/msgs/zh_tw.msg +++ library/msgs/zh_tw.msg @@ -1,8 +1,8 @@ # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { - ::msgcat::mcset zh_TW BCE "民國å‰" - ::msgcat::mcset zh_TW CE "民國" + ::msgcat::mcset zh_TW BCE "\u6c11\u570b\u524d" + ::msgcat::mcset zh_TW CE "\u6c11\u570b" ::msgcat::mcset zh_TW DATE_FORMAT "%Y/%m/%e" ::msgcat::mcset zh_TW TIME_FORMAT_12 "%P %I:%M:%S" ::msgcat::mcset zh_TW DATE_TIME_FORMAT "%Y/%m/%e %P %I:%M:%S %z" } Index: library/opt/optparse.tcl ================================================================== --- library/opt/optparse.tcl +++ library/opt/optparse.tcl @@ -9,11 +9,11 @@ # may directly incorporate this code into your application. package require Tcl 8.5- # When this version number changes, update the pkgIndex.tcl file # and the install directory in the Makefiles. -package provide opt 0.4.7 +package provide opt 0.4.8 namespace eval ::tcl { # Exported APIs namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \ @@ -42,12 +42,12 @@ {arg1 3 "some number"} {-aflag} {-intflag 7} {-weirdflag "help string"} {-noStatics "Not ok to load static packages"} - {-nestedloading1 true "OK to load into nested slaves"} - {-nestedloading2 -boolean true "OK to load into nested slaves"} + {-nestedloading1 true "OK to load into nested children"} + {-nestedloading2 -boolean true "OK to load into nested children"} {-libsOK -choice {Tk SybTcl} "List of packages that can be loaded"} {-precision -int 12 "Number of digits of precision"} {-intval 7 "An integer"} {-scale -float 1.0 "Scale factor"} Index: library/opt/pkgIndex.tcl ================================================================== --- library/opt/pkgIndex.tcl +++ library/opt/pkgIndex.tcl @@ -7,6 +7,6 @@ # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.5-]} {return} -package ifneeded opt 0.4.7 [list source [file join $dir optparse.tcl]] +package ifneeded opt 0.4.8 [list source [file join $dir optparse.tcl]] Index: library/package.tcl ================================================================== --- library/package.tcl +++ library/package.tcl @@ -235,11 +235,11 @@ $c eval [list set ::tcl::dir $dir] $c eval [list set ::tcl::file $file] $c eval [list set ::tcl::direct $direct] - # Download needed procedures into the slave because we've just deleted + # Download needed procedures into the child because we've just deleted # the unknown procedure. This doesn't handle procedures with default # arguments. foreach p {::tcl::Pkg::CompareExtension} { $c eval [list namespace eval [namespace qualifiers $p] {}] @@ -477,29 +477,28 @@ set use_path [lrange $use_path 0 end-1] continue } set tclSeenPath($dir) 1 - # we can't use glob in safe interps, so enclose the following in a - # catch statement, where we get the pkgIndex files out of the - # subdirectories + # Get the pkgIndex.tcl files in subdirectories of auto_path directories. + # - Safe Base interpreters have a restricted "glob" command that + # works in this case. + # - The "catch" was essential when there was no safe glob and every + # call in a safe interp failed; it is retained only for corner + # cases in which the eventual call to glob returns an error. catch { foreach file [glob -directory $dir -join -nocomplain \ * pkgIndex.tcl] { set dir [file dirname $file] if {![info exists procdDirs($dir)]} { try { - ::tcl::Pkg::source $file + source $file } trap {POSIX EACCES} {} { # $file was not readable; silently ignore continue } on error msg { - if {[regexp {version conflict for package} $msg]} { - # In case of version conflict, silently ignore - continue - } - tclLog "error reading package index file $file: $msg" + tclLog "error reading package index file $file: $msg" } on ok {} { set procdDirs($dir) 1 } } } @@ -508,19 +507,15 @@ if {![info exists procdDirs($dir)]} { set file [file join $dir pkgIndex.tcl] # safe interps usually don't have "file exists", if {([interp issafe] || [file exists $file])} { try { - ::tcl::Pkg::source $file + source $file } trap {POSIX EACCES} {} { # $file was not readable; silently ignore continue } on error msg { - if {[regexp {version conflict for package} $msg]} { - # In case of version conflict, silently ignore - continue - } tclLog "error reading package index file $file: $msg" } on ok {} { set procdDirs($dir) 1 } } @@ -591,24 +586,21 @@ continue } set tclSeenPath($dir) 1 # get the pkgIndex files out of the subdirectories + # Safe interpreters do not use tcl::MacOSXPkgUnknown - see init.tcl. foreach file [glob -directory $dir -join -nocomplain \ * Resources Scripts pkgIndex.tcl] { set dir [file dirname $file] if {![info exists procdDirs($dir)]} { try { - ::tcl::Pkg::source $file + source $file } trap {POSIX EACCES} {} { # $file was not readable; silently ignore continue } on error msg { - if {[regexp {version conflict for package} $msg]} { - # In case of version conflict, silently ignore - continue - } tclLog "error reading package index file $file: $msg" } on ok {} { set procdDirs($dir) 1 } } Index: library/reg/pkgIndex.tcl ================================================================== --- library/reg/pkgIndex.tcl +++ library/reg/pkgIndex.tcl @@ -1,9 +1,9 @@ -if {([info commands ::tcl::pkgconfig] eq "") - || ([info sharedlibextension] ne ".dll")} return +if {![package vsatisfies [package provide Tcl] 8.5]} return +if {[info sharedlibextension] != ".dll"} return if {[::tcl::pkgconfig get debug]} { - package ifneeded registry 1.3.3 \ - [list load [file join $dir tclreg13g.dll] registry] + package ifneeded registry 1.3.5 \ + [list load [file join $dir tclreg13g.dll] Registry] } else { - package ifneeded registry 1.3.3 \ - [list load [file join $dir tclreg13.dll] registry] + package ifneeded registry 1.3.5 \ + [list load [file join $dir tclreg13.dll] Registry] } Index: library/safe.tcl ================================================================== --- library/safe.tcl +++ library/safe.tcl @@ -1,11 +1,11 @@ # safe.tcl -- # # This file provide a safe loading/sourcing mechanism for safe interpreters. -# It implements a virtual path mecanism to hide the real pathnames from the -# slave. It runs in a master interpreter and sets up data structure and -# aliases that will be invoked when used from a slave interpreter. +# It implements a virtual path mechanism to hide the real pathnames from the +# child. It runs in a parent interpreter and sets up data structure and +# aliases that will be invoked when used from a child interpreter. # # See the safe.n man page for details. # # Copyright (c) 1996-1997 Sun Microsystems, Inc. # @@ -18,11 +18,11 @@ # Private procs starts with uppercase. # Public procs are exported and starts with lowercase # # Needed utilities package -package require opt 0.4.1 +package require opt 0.4.8 # Create the safe namespace namespace eval ::safe { # Exported API: namespace export interpCreate interpInit interpConfigure interpDelete \ @@ -77,29 +77,31 @@ #### # Interface/entry point function and front end for "Create" proc ::safe::interpCreate {args} { set Args [::tcl::OptKeyParse ::safe::interpCreate $args] + RejectExcessColons $slave InterpCreate $slave $accessPath \ [InterpStatics] [InterpNested] $deleteHook } proc ::safe::interpInit {args} { set Args [::tcl::OptKeyParse ::safe::interpIC $args] if {![::interp exists $slave]} { return -code error "\"$slave\" is not an interpreter" } + RejectExcessColons $slave InterpInit $slave $accessPath \ [InterpStatics] [InterpNested] $deleteHook } -# Check that the given slave is "one of us" -proc ::safe::CheckInterp {slave} { - namespace upvar ::safe S$slave state - if {![info exists state] || ![::interp exists $slave]} { +# Check that the given child is "one of us" +proc ::safe::CheckInterp {child} { + namespace upvar ::safe [VarName $child] state + if {![info exists state] || ![::interp exists $child]} { return -code error \ - "\"$slave\" is not an interpreter managed by ::safe::" + "\"$child\" is not an interpreter managed by ::safe::" } } # Interface/entry point function and front end for "Configure". This code # is awfully pedestrian because it would need more coupling and support @@ -111,21 +113,21 @@ # This is even more complicated by the boolean flags with no values that # we had the bad idea to support for the sake of user simplicity in # create/init but which makes life hard in configure... # So this will be hopefully written and some integrated with opt1.0 -# (hopefully for tcl9.0 ?) +# (hopefully for tcl8.1 ?) proc ::safe::interpConfigure {args} { switch [llength $args] { 1 { # If we have exactly 1 argument the semantic is to return all # the current configuration. We still call OptKeyParse though - # we know that "slave" is our given argument because it also + # we know that "child" is our given argument because it also # checks for the "-help" option. set Args [::tcl::OptKeyParse ::safe::interpIC $args] CheckInterp $slave - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $slave] state return [join [list \ [list -accessPath $state(access_path)] \ [list -statics $state(staticsok)] \ [list -nested $state(nestedok)] \ @@ -144,11 +146,11 @@ return -code error [::tcl::OptAmbigous $desc $arg] } elseif {$hits == 0} { return -code error [::tcl::OptFlagUsage $desc $arg] } CheckInterp $slave - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $slave] state set item [::tcl::OptCurDesc $desc] set name [::tcl::OptName $item] switch -exact -- $name { -accessPath { @@ -185,19 +187,19 @@ default { # Otherwise we want to parse the arguments like init and # create did set Args [::tcl::OptKeyParse ::safe::interpIC $args] CheckInterp $slave - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $slave] state # Get the current (and not the default) values of whatever has # not been given: if {![::tcl::OptProcArgGiven -accessPath]} { - set doreset 1 + set doreset 0 set accessPath $state(access_path) } else { - set doreset 0 + set doreset 1 } if { ![::tcl::OptProcArgGiven -statics] && ![::tcl::OptProcArgGiven -noStatics] } then { @@ -216,18 +218,37 @@ if {![::tcl::OptProcArgGiven -deleteHook]} { set deleteHook $state(cleanupHook) } # we can now reconfigure : InterpSetConfig $slave $accessPath $statics $nested $deleteHook - # auto_reset the slave (to completly synch the new access_path) + # auto_reset the child (to completly synch the new access_path) if {$doreset} { if {[catch {::interp eval $slave {auto_reset}} msg]} { Log $slave "auto_reset failed: $msg" } else { Log $slave "successful auto_reset" NOTICE } + + # Sync the paths used to search for Tcl modules. + ::interp eval $slave {tcl::tm::path remove {*}[tcl::tm::list]} + if {[llength $state(tm_path_slave)] > 0} { + ::interp eval $slave [list \ + ::tcl::tm::add {*}[lreverse $state(tm_path_slave)]] + } + + # Remove stale "package ifneeded" data for non-loaded packages. + # - Not for loaded packages, because "package forget" erases + # data from "package provide" as well as "package ifneeded". + # - This is OK because the script cannot reload any version of + # the package unless it first does "package forget". + foreach pkg [::interp eval $slave {package names}] { + if {[::interp eval $slave [list package provide $pkg]] eq ""} { + ::interp eval $slave [list package forget $pkg] + } + } } + return } } } #### @@ -237,96 +258,98 @@ #### # # safe::InterpCreate : doing the real job # -# This procedure creates a safe slave and initializes it with the safe +# This procedure creates a safe interpreter and initializes it with the safe # base aliases. -# NB: slave name must be simple alphanumeric string, no spaces, no (), no +# NB: child name must be simple alphanumeric string, no spaces, no (), no # {},... {because the state array is stored as part of the name} # -# Returns the slave name. +# Returns the child name. # # Optional Arguments : -# + slave name : if empty, generated name will be used +# + child name : if empty, generated name will be used # + access_path: path list controlling where load/source can occur, -# if empty: the master auto_path will be used. +# if empty: the parent auto_path will be used. # + staticsok : flag, if 0 :no static package can be loaded (load {} Xxx) # if 1 :static packages are ok. # + nestedok: flag, if 0 :no loading to sub-sub interps (load xx xx sub) # if 1 : multiple levels are ok. # use the full name and no indent so auto_mkIndex can find us proc ::safe::InterpCreate { - slave + child access_path staticsok nestedok deletehook } { - # Create the slave. - if {$slave ne ""} { - ::interp create -safe $slave + # Create the child. + # If evaluated in ::safe, the interpreter command for foo is ::foo; + # but for foo::bar is safe::foo::bar. So evaluate in :: instead. + if {$child ne ""} { + namespace eval :: [list ::interp create -safe $child] } else { - # empty argument: generate slave name - set slave [::interp create -safe] + # empty argument: generate child name + set child [::interp create -safe] } - Log $slave "Created" NOTICE + Log $child "Created" NOTICE - # Initialize it. (returns slave name) - InterpInit $slave $access_path $staticsok $nestedok $deletehook + # Initialize it. (returns child name) + InterpInit $child $access_path $staticsok $nestedok $deletehook } # # InterpSetConfig (was setAccessPath) : -# Sets up slave virtual auto_path and corresponding structure within -# the master. Also sets the tcl_library in the slave to be the first +# Sets up child virtual auto_path and corresponding structure within +# the parent. Also sets the tcl_library in the child to be the first # directory in the path. -# NB: If you change the path after the slave has been initialized you -# probably need to call "auto_reset" in the slave in order that it gets +# NB: If you change the path after the child has been initialized you +# probably need to call "auto_reset" in the child in order that it gets # the right auto_index() array values. -proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { +proc ::safe::InterpSetConfig {child access_path staticsok nestedok deletehook} { global auto_path # determine and store the access path if empty if {$access_path eq ""} { set access_path $auto_path # Make sure that tcl_library is in auto_path and at the first # position (needed by setAccessPath) set where [lsearch -exact $access_path [info library]] - if {$where == -1} { + if {$where < 0} { # not found, add it. set access_path [linsert $access_path 0 [info library]] - Log $slave "tcl_library was not in auto_path,\ + Log $child "tcl_library was not in auto_path,\ added it to slave's access_path" NOTICE } elseif {$where != 0} { # not first, move it first set access_path [linsert \ [lreplace $access_path $where $where] \ 0 [info library]] - Log $slave "tcl_libray was not in first in auto_path,\ + Log $child "tcl_libray was not in first in auto_path,\ moved it to front of slave's access_path" NOTICE } # Add 1st level sub dirs (will searched by auto loading from tcl - # code in the slave using glob and thus fail, so we add them here + # code in the child using glob and thus fail, so we add them here # so by default it works the same). set access_path [AddSubDirs $access_path] } - Log $slave "Setting accessPath=($access_path) staticsok=$staticsok\ + Log $child "Setting accessPath=($access_path) staticsok=$staticsok\ nestedok=$nestedok deletehook=($deletehook)" NOTICE - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $child] state # clear old autopath if it existed # build new one # Extend the access list with the paths used to look for Tcl Modules. # We save the virtual form separately as well, as syncing it with the - # slave has to be defered until the necessary commands are present for + # child has to be deferred until the necessary commands are present for # setup. set norm_access_path {} set slave_access_path {} set map_access_path {} @@ -342,28 +365,40 @@ lappend norm_access_path [file normalize $dir] incr i } set morepaths [::tcl::tm::list] + set firstpass 1 while {[llength $morepaths]} { set addpaths $morepaths set morepaths {} foreach dir $addpaths { # Prevent the addition of dirs on the tm list to the # result if they are already known. if {[dict exists $remap_access_path $dir]} { + if {$firstpass} { + # $dir is in [::tcl::tm::list] and belongs in the slave_tm_path. + # Later passes handle subdirectories, which belong in the + # access path but not in the module path. + lappend slave_tm_path [dict get $remap_access_path $dir] + } continue } set token [PathToken $i] lappend access_path $dir lappend slave_access_path $token lappend map_access_path $token $dir lappend remap_access_path $dir $token lappend norm_access_path [file normalize $dir] - lappend slave_tm_path $token + if {$firstpass} { + # $dir is in [::tcl::tm::list] and belongs in the slave_tm_path. + # Later passes handle subdirectories, which belong in the + # access path but not in the module path. + lappend slave_tm_path $token + } incr i # [Bug 2854929] # Recursively find deeper paths which may contain # modules. Required to handle modules with names like @@ -370,10 +405,11 @@ # 'platform::shell', which translate into # 'platform/shell-X.tm', i.e arbitrarily deep # subdirectories. lappend morepaths {*}[glob -nocomplain -directory $dir -type d *] } + set firstpass 0 } set state(access_path) $access_path set state(access_path,map) $map_access_path set state(access_path,remap) $remap_access_path @@ -382,36 +418,39 @@ set state(tm_path_slave) $slave_tm_path set state(staticsok) $staticsok set state(nestedok) $nestedok set state(cleanupHook) $deletehook - SyncAccessPath $slave + SyncAccessPath $child + return } # # # FindInAccessPath: # Search for a real directory and returns its virtual Id (including the # "$") -proc ::safe::interpFindInAccessPath {slave path} { - namespace upvar ::safe S$slave state +proc ::safe::interpFindInAccessPath {child path} { + CheckInterp $child + namespace upvar ::safe [VarName $child] state if {![dict exists $state(access_path,remap) $path]} { - return -code error "$path not found in access path $access_path" + return -code error "$path not found in access path" } return [dict get $state(access_path,remap) $path] } # # addToAccessPath: # add (if needed) a real directory to access path and return its # virtual token (including the "$"). -proc ::safe::interpAddToAccessPath {slave path} { +proc ::safe::interpAddToAccessPath {child path} { # first check if the directory is already in there # (inlined interpFindInAccessPath). - namespace upvar ::safe S$slave state + CheckInterp $child + namespace upvar ::safe [VarName $child] state if {[dict exists $state(access_path,remap) $path]} { return [dict get $state(access_path,remap) $path] } @@ -422,98 +461,100 @@ lappend state(access_path,slave) $token lappend state(access_path,map) $token $path lappend state(access_path,remap) $path $token lappend state(access_path,norm) [file normalize $path] - SyncAccessPath $slave + SyncAccessPath $child return $token } # This procedure applies the initializations to an already existing # interpreter. It is useful when you want to install the safe base aliases # into a preexisting safe interpreter. proc ::safe::InterpInit { - slave + child access_path staticsok nestedok deletehook } { # Configure will generate an access_path when access_path is empty. - InterpSetConfig $slave $access_path $staticsok $nestedok $deletehook + InterpSetConfig $child $access_path $staticsok $nestedok $deletehook # NB we need to add [namespace current], aliases are always absolute # paths. - # These aliases let the slave load files to define new commands - # This alias lets the slave use the encoding names, convertfrom, + # These aliases let the child load files to define new commands + # This alias lets the child use the encoding names, convertfrom, # convertto, and system, but not "encoding system " to set the # system encoding. # Handling Tcl Modules, we need a restricted form of Glob. # This alias interposes on the 'exit' command and cleanly terminates - # the slave. + # the child. foreach {command alias} { source AliasSource load AliasLoad + encoding AliasEncoding exit interpDelete glob AliasGlob } { - ::interp alias $slave $command {} [namespace current]::$alias $slave + ::interp alias $child $command {} [namespace current]::$alias $child } - # UGLY POINT! These commands are safe (they're ensembles with unsafe - # subcommands), but is assumed to not be by existing policies so it is - # hidden by default. Hack it... - foreach command {encoding file} { - ::interp alias $slave $command {} interp invokehidden $slave $command - } - - # This alias lets the slave have access to a subset of the 'file' + # This alias lets the child have access to a subset of the 'file' # command functionality. + ::interp expose $child file foreach subcommand {dirname extension rootname tail} { - ::interp alias $slave ::tcl::file::$subcommand {} \ - ::safe::AliasFileSubcommand $slave $subcommand - } - - # Subcommand of 'encoding' that has special handling; [encoding system] is - # OK provided it has no other arguments passed to it. - ::interp alias $slave ::tcl::encoding::system {} \ - ::safe::AliasEncodingSystem $slave + ::interp alias $child ::tcl::file::$subcommand {} \ + ::safe::AliasFileSubcommand $child $subcommand + } + foreach subcommand { + atime attributes copy delete executable exists isdirectory isfile + link lstat mtime mkdir nativename normalize owned readable readlink + rename size stat tempfile type volumes writable + } { + ::interp alias $child ::tcl::file::$subcommand {} \ + ::safe::BadSubcommand $child file $subcommand + } # Subcommands of info - ::interp alias $slave ::tcl::info::nameofexecutable {} \ - ::safe::AliasExeName $slave + foreach {subcommand alias} { + nameofexecutable AliasExeName + } { + ::interp alias $child ::tcl::info::$subcommand \ + {} [namespace current]::$alias $child + } - # The allowed slave variables already have been set by Tcl_MakeSafe(3) + # The allowed child variables already have been set by Tcl_MakeSafe(3) - # Source init.tcl and tm.tcl into the slave, to get auto_load and + # Source init.tcl and tm.tcl into the child, to get auto_load and # other procedures defined: - if {[catch {::interp eval $slave { + if {[catch {::interp eval $child { source [file join $tcl_library init.tcl] }} msg opt]} { - Log $slave "can't source init.tcl ($msg)" - return -options $opt "can't source init.tcl into slave $slave ($msg)" + Log $child "can't source init.tcl ($msg)" + return -options $opt "can't source init.tcl into slave $child ($msg)" } - if {[catch {::interp eval $slave { + if {[catch {::interp eval $child { source [file join $tcl_library tm.tcl] }} msg opt]} { - Log $slave "can't source tm.tcl ($msg)" - return -options $opt "can't source tm.tcl into slave $slave ($msg)" + Log $child "can't source tm.tcl ($msg)" + return -options $opt "can't source tm.tcl into slave $child ($msg)" } # Sync the paths used to search for Tcl modules. This can be done only # now, after tm.tcl was loaded. - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $child] state if {[llength $state(tm_path_slave)] > 0} { - ::interp eval $slave [list \ + ::interp eval $child [list \ ::tcl::tm::add {*}[lreverse $state(tm_path_slave)]] } - return $slave + return $child } # Add (only if needed, avoid duplicates) 1 level of sub directories to an # existing path list. Also removes non directories from the returned # list. @@ -535,19 +576,34 @@ } } return $res } -# This procedure deletes a safe slave managed by Safe Tcl and cleans up -# associated state: - -proc ::safe::interpDelete {slave} { - Log $slave "About to delete" NOTICE - - namespace upvar ::safe S$slave state - - # If the slave has a cleanup hook registered, call it. Check the +# This procedure deletes a safe interpreter managed by Safe Tcl and cleans up +# associated state. +# - The command will also delete non-Safe-Base interpreters. +# - This is regrettable, but to avoid breaking existing code this should be +# amended at the next major revision by uncommenting "CheckInterp". + +proc ::safe::interpDelete {child} { + Log $child "About to delete" NOTICE + + # CheckInterp $child + namespace upvar ::safe [VarName $child] state + + # When an interpreter is deleted with [interp delete], any sub-interpreters + # are deleted automatically, but this leaves behind their data in the Safe + # Base. To clean up properly, we call safe::interpDelete recursively on each + # Safe Base sub-interpreter, so each one is deleted cleanly and not by + # the automatic mechanism built into [interp delete]. + foreach sub [interp children $child] { + if {[info exists ::safe::[VarName [list $child $sub]]]} { + ::safe::interpDelete [list $child $sub] + } + } + + # If the child has a cleanup hook registered, call it. Check the # existance because we might be called to delete an interp which has # not been registered with us at all if {[info exists state(cleanupHook)]} { set hook $state(cleanupHook) @@ -554,29 +610,29 @@ if {[llength $hook]} { # remove the hook now, otherwise if the hook calls us somehow, # we'll loop unset state(cleanupHook) try { - {*}$hook $slave + {*}$hook $child } on error err { - Log $slave "Delete hook error ($err)" + Log $child "Delete hook error ($err)" } } } - # Discard the global array of state associated with the slave, and + # Discard the global array of state associated with the child, and # delete the interpreter. if {[info exists state]} { unset state } # if we have been called twice, the interp might have been deleted # already - if {[::interp exists $slave]} { - ::interp delete $slave - Log $slave "Deleted" NOTICE + if {[::interp exists $child]} { + ::interp delete $child + Log $child "Deleted" NOTICE } return } @@ -598,38 +654,38 @@ # of all users. proc ::safe::Log {args} {} } else { # Activate logging, define proper command. - proc ::safe::Log {slave msg {type ERROR}} { + proc ::safe::Log {child msg {type ERROR}} { variable Log - {*}$Log "$type for slave $slave : $msg" + {*}$Log "$type for slave $child : $msg" return } } } # ------------------- END OF PUBLIC METHODS ------------ # -# Sets the slave auto_path to the master recorded value. Also sets +# Sets the child auto_path to the parent recorded value. Also sets # tcl_library to the first token of the virtual path. # -proc ::safe::SyncAccessPath {slave} { - namespace upvar ::safe S$slave state +proc ::safe::SyncAccessPath {child} { + namespace upvar ::safe [VarName $child] state set slave_access_path $state(access_path,slave) - ::interp eval $slave [list set auto_path $slave_access_path] + ::interp eval $child [list set auto_path $slave_access_path] - Log $slave "auto_path in $slave has been set to $slave_access_path"\ + Log $child "auto_path in $child has been set to $slave_access_path"\ NOTICE # This code assumes that info library is the first element in the # list of auto_path's. See -> InterpSetConfig for the code which # ensures this condition. - ::interp eval $slave [list \ + ::interp eval $child [list \ set tcl_library [lindex $slave_access_path 0]] } # Returns the virtual token for directory number N. proc ::safe::PathToken {n} { @@ -639,12 +695,12 @@ } # # translate virtual path into real path # -proc ::safe::TranslatePath {slave path} { - namespace upvar ::safe S$slave state +proc ::safe::TranslatePath {child path} { + namespace upvar ::safe [VarName $child] state # somehow strip the namespaces 'functionality' out (the danger is that # we would strip valid macintosh "../" queries... : if {[string match "*::*" $path] || [string match "*..*" $path]} { return -code error "invalid characters in path $path" @@ -655,11 +711,11 @@ return [string map $state(access_path,map) $path] } # file name control (limit access to files/resources that should be a # valid tcl source file) -proc ::safe::CheckFileName {slave file} { +proc ::safe::CheckFileName {child file} { # This used to limit what can be sourced to ".tcl" and forbid files # with more than 1 dot and longer than 14 chars, but I changed that # for 8.4 as a safe interp has enough internal protection already to # allow sourcing anything. - hobbs @@ -676,21 +732,21 @@ # AliasFileSubcommand handles selected subcommands of [file] in safe # interpreters that are *almost* safe. In particular, it just acts to # prevent discovery of what home directories exist. -proc ::safe::AliasFileSubcommand {slave subcommand name} { +proc ::safe::AliasFileSubcommand {child subcommand name} { if {[string match ~* $name]} { set name ./$name } - tailcall ::interp invokehidden $slave tcl:file:$subcommand $name + tailcall ::interp invokehidden $child tcl:file:$subcommand $name } # AliasGlob is the target of the "glob" alias in safe interpreters. -proc ::safe::AliasGlob {slave args} { - Log $slave "GLOB ! $args" NOTICE +proc ::safe::AliasGlob {child args} { + Log $child "GLOB ! $args" NOTICE set cmd {} set at 0 array set got { -directory 0 -nocomplain 0 @@ -708,14 +764,18 @@ set dir {} set virtualdir {} while {$at < [llength $args]} { switch -glob -- [set opt [lindex $args $at]] { - -nocomplain - -- - -join - -tails { + -nocomplain - -- - -tails { lappend cmd $opt set got($opt) 1 incr at + } + -join { + set got($opt) 1 + incr at } -types - -type { lappend cmd -types [lindex $args [incr at]] incr at } @@ -726,19 +786,12 @@ } set got($opt) 1 set virtualdir [lindex $args [incr at]] incr at } - pkgIndex.tcl { - # Oops, this is globbing a subdirectory in regular package - # search. That is not wanted. Abort, handler does catch - # already (because glob was not defined before). See - # package.tcl, lines 484ff in tclPkgUnknown. - return -code error "unknown command glob" - } -* { - Log $slave "Safe base rejecting glob option '$opt'" + Log $child "Safe base rejecting glob option '$opt'" return -code error "Safe base rejecting glob option '$opt'" } default { break } @@ -745,191 +798,237 @@ } if {$got(--)} break } # Get the real path from the virtual one and check that the path is in the - # access path of that slave. Done after basic argument processing so that + # access path of that child. Done after basic argument processing so that # we know if -nocomplain is set. if {$got(-directory)} { try { - set dir [TranslatePath $slave $virtualdir] - DirInAccessPath $slave $dir + set dir [TranslatePath $child $virtualdir] + DirInAccessPath $child $dir } on error msg { - Log $slave $msg + Log $child $msg if {$got(-nocomplain)} return return -code error "permission denied" } - lappend cmd -directory $dir + if {$got(--)} { + set cmd [linsert $cmd end-1 -directory $dir] + } else { + lappend cmd -directory $dir + } + } else { + # The code after this "if ... else" block would conspire to return with + # no results in this case, if it were allowed to proceed. Instead, + # return now and reduce the number of cases to be considered later. + Log $child {option -directory must be supplied} + if {$got(-nocomplain)} return + return -code error "permission denied" } - # Apply the -join semantics ourselves + # Apply the -join semantics ourselves. if {$got(-join)} { set args [lreplace $args $at end [join [lrange $args $at end] "/"]] } - # Process remaining pattern arguments + # Process the pattern arguments. If we've done a join there is only one + # pattern argument. + set firstPattern [llength $cmd] foreach opt [lrange $args $at end] { if {![regexp $dirPartRE $opt -> thedir thefile]} { set thedir . - } elseif {[string match ~* $thedir]} { - set thedir ./$thedir + # The *.tm search comes here. } - if {$thedir eq "*" && - ($thefile eq "pkgIndex.tcl" || $thefile eq "*.tm")} { + # "Special" treatment for (joined) argument {*/pkgIndex.tcl}. + # Do the expansion of "*" here, and filter out any directories that are + # not in the access path. The outcome is to lappend to cmd a path of + # the form $virtualdir/subdir/pkgIndex.tcl for each subdirectory subdir, + # after removing any subdir that are not in the access path. + if {($thedir eq "*") && ($thefile eq "pkgIndex.tcl")} { set mapped 0 - foreach d [glob -directory [TranslatePath $slave $virtualdir] \ + foreach d [glob -directory [TranslatePath $child $virtualdir] \ -types d -tails *] { catch { - DirInAccessPath $slave \ - [TranslatePath $slave [file join $virtualdir $d]] + DirInAccessPath $child \ + [TranslatePath $child [file join $virtualdir $d]] lappend cmd [file join $d $thefile] set mapped 1 } } if {$mapped} continue + # Don't [continue] if */pkgIndex.tcl has no matches in the access + # path. The pattern will now receive the same treatment as a + # "non-special" pattern (and will fail because it includes a "*" in + # the directory name). } + # Any directory pattern that is not an exact (i.e. non-glob) match to a + # directory in the access path will be rejected here. + # - Rejections include any directory pattern that has glob matching + # patterns "*", "?", backslashes, braces or square brackets, (UNLESS + # it corresponds to a genuine directory name AND that directory is in + # the access path). + # - The only "special matching characters" that remain in patterns for + # processing by glob are in the filename tail. + # - [file join $anything ~${foo}] is ~${foo}, which is not an exact + # match to any directory in the access path. Hence directory patterns + # that begin with "~" are rejected here. Tests safe-16.[5-8] check + # that "file join" remains as required and does not expand ~${foo}. + # - Bug [3529949] relates to unwanted expansion of ~${foo} and this is + # how the present code avoids the bug. All tests safe-16.* relate. try { - DirInAccessPath $slave [TranslatePath $slave \ + DirInAccessPath $child [TranslatePath $child \ [file join $virtualdir $thedir]] } on error msg { - Log $slave $msg + Log $child $msg if {$got(-nocomplain)} continue return -code error "permission denied" } lappend cmd $opt } - Log $slave "GLOB = $cmd" NOTICE + Log $child "GLOB = $cmd" NOTICE if {$got(-nocomplain) && [llength $cmd] eq $firstPattern} { return } try { - set entries [::interp invokehidden $slave glob {*}$cmd] + # >>>>>>>>>> HERE'S THE CALL TO SAFE INTERP GLOB <<<<<<<<<< + # - Pattern arguments added to cmd have NOT been translated from tokens. + # Only the virtualdir is translated (to dir). + # - In the pkgIndex.tcl case, there is no "*" in the pattern arguments, + # which are a list of names each with tail pkgIndex.tcl. The purpose + # of the call to glob is to remove the names for which the file does + # not exist. + set entries [::interp invokehidden $child glob {*}$cmd] } on error msg { - Log $slave $msg + # This is the only place that a call with -nocomplain and no invalid + # "dash-options" can return an error. + Log $child $msg return -code error "script error" } - Log $slave "GLOB < $entries" NOTICE + Log $child "GLOB < $entries" NOTICE - # Translate path back to what the slave should see. + # Translate path back to what the child should see. set res {} set l [string length $dir] foreach p $entries { if {[string equal -length $l $dir $p]} { set p [string replace $p 0 [expr {$l-1}] $virtualdir] } lappend res $p } - Log $slave "GLOB > $res" NOTICE + Log $child "GLOB > $res" NOTICE return $res } # AliasSource is the target of the "source" alias in safe interpreters. -proc ::safe::AliasSource {slave args} { +proc ::safe::AliasSource {child args} { set argc [llength $args] # Extended for handling of Tcl Modules to allow not only "source # filename", but "source -encoding E filename" as well. if {[lindex $args 0] eq "-encoding"} { incr argc -2 set encoding [lindex $args 1] set at 2 if {$encoding eq "identity"} { - Log $slave "attempt to use the identity encoding" + Log $child "attempt to use the identity encoding" return -code error "permission denied" } } else { set at 0 set encoding {} } if {$argc != 1} { set msg "wrong # args: should be \"source ?-encoding E? fileName\"" - Log $slave "$msg ($args)" + Log $child "$msg ($args)" return -code error $msg } set file [lindex $args $at] # get the real path from the virtual one. if {[catch { - set realfile [TranslatePath $slave $file] - } msg]} { - Log $slave $msg - return -code error "permission denied" - } - - # check that the path is in the access path of that slave - if {[catch { - FileInAccessPath $slave $realfile - } msg]} { - Log $slave $msg - return -code error "permission denied" - } - - # do the checks on the filename : - if {[catch { - CheckFileName $slave $realfile - } msg]} { - Log $slave "$realfile:$msg" - return -code error $msg - } - - # Passed all the tests, lets source it. Note that we do this all manually - # because we want to control [info script] in the slave so information - # doesn't leak so much. [Bug 2913625] - set old [::interp eval $slave {info script}] + set realfile [TranslatePath $child $file] + } msg]} { + Log $child $msg + return -code error "permission denied" + } + + # check that the path is in the access path of that child + if {[catch { + FileInAccessPath $child $realfile + } msg]} { + Log $child $msg + return -code error "permission denied" + } + + # Check that the filename exists and is readable. If it is not, deliver + # this -errorcode so that caller in tclPkgUnknown does not write a message + # to tclLog. Has no effect on other callers of ::source, which are in + # "package ifneeded" scripts. + if {[catch { + CheckFileName $child $realfile + } msg]} { + Log $child "$realfile:$msg" + return -code error -errorcode {POSIX EACCES} $msg + } + + # Passed all the tests, lets source it. Note that we do this all manually + # because we want to control [info script] in the child so information + # doesn't leak so much. [Bug 2913625] + set old [::interp eval $child {info script}] set replacementMsg "script error" set code [catch { set f [open $realfile] fconfigure $f -eofchar \032 if {$encoding ne ""} { fconfigure $f -encoding $encoding } set contents [read $f] close $f - ::interp eval $slave [list info script $file] + ::interp eval $child [list info script $file] } msg opt] if {$code == 0} { - set code [catch {::interp eval $slave $contents} msg opt] + set code [catch {::interp eval $child $contents} msg opt] set replacementMsg $msg } - catch {interp eval $slave [list info script $old]} + catch {interp eval $child [list info script $old]} # Note that all non-errors are fine result codes from [source], so we must # take a little care to do it properly. [Bug 2923613] if {$code == 1} { - Log $slave $msg + Log $child $msg return -code error $replacementMsg } return -code $code -options $opt $msg } # AliasLoad is the target of the "load" alias in safe interpreters. -proc ::safe::AliasLoad {slave file args} { +proc ::safe::AliasLoad {child file args} { set argc [llength $args] if {$argc > 2} { set msg "load error: too many arguments" - Log $slave "$msg ($argc) {$file $args}" + Log $child "$msg ($argc) {$file $args}" return -code error $msg } # package name (can be empty if file is not). set package [lindex $args 0] - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $child] state # Determine where to load. load use a relative interp path and {} # means self, so we can directly and safely use passed arg. set target [lindex $args 1] if {$target ne ""} { # we will try to load into a sub sub interp; check that we want to # authorize that. if {!$state(nestedok)} { - Log $slave "loading to a sub interp (nestedok)\ + Log $child "loading to a sub interp (nestedok)\ disabled (trying to load $package to $target)" return -code error "permission denied (nested load)" } } @@ -936,53 +1035,60 @@ # Determine what kind of load is requested if {$file eq ""} { # static package loading if {$package eq ""} { set msg "load error: empty filename and no package name" - Log $slave $msg + Log $child $msg return -code error $msg } if {!$state(staticsok)} { - Log $slave "static packages loading disabled\ + Log $child "static packages loading disabled\ (trying to load $package to $target)" return -code error "permission denied (static package)" } } else { # file loading # get the real path from the virtual one. try { - set file [TranslatePath $slave $file] + set file [TranslatePath $child $file] } on error msg { - Log $slave $msg + Log $child $msg return -code error "permission denied" } # check the translated path try { - FileInAccessPath $slave $file + FileInAccessPath $child $file } on error msg { - Log $slave $msg + Log $child $msg return -code error "permission denied (path)" } } try { - return [::interp invokehidden $slave load $file $package $target] + return [::interp invokehidden $child load $file $package $target] } on error msg { - Log $slave $msg + # Some packages return no error message. + set msg0 "load of binary library for package $package failed" + if {$msg eq {}} { + set msg $msg0 + } else { + set msg "$msg0: $msg" + } + Log $child $msg return -code error $msg } } # FileInAccessPath raises an error if the file is not found in the list of -# directories contained in the (master side recorded) slave's access path. +# directories contained in the (parent side recorded) child's access path. # the security here relies on "file dirname" answering the proper # result... needs checking ? -proc ::safe::FileInAccessPath {slave file} { - namespace upvar ::safe S$slave state +proc ::safe::FileInAccessPath {child file} { + namespace upvar ::safe [VarName $child] state set access_path $state(access_path) if {[file isdirectory $file]} { return -code error "\"$file\": is a directory" } @@ -990,18 +1096,18 @@ # Normalize paths for comparison since lsearch knows nothing of # potential pathname anomalies. set norm_parent [file normalize $parent] - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $child] state if {$norm_parent ni $state(access_path,norm)} { return -code error "\"$file\": not in access_path" } } -proc ::safe::DirInAccessPath {slave dir} { - namespace upvar ::safe S$slave state +proc ::safe::DirInAccessPath {child dir} { + namespace upvar ::safe [VarName $child] state set access_path $state(access_path) if {[file isfile $dir]} { return -code error "\"$dir\": is a file" } @@ -1008,47 +1114,102 @@ # Normalize paths for comparison since lsearch knows nothing of # potential pathname anomalies. set norm_dir [file normalize $dir] - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $child] state if {$norm_dir ni $state(access_path,norm)} { return -code error "\"$dir\": not in access_path" } } # This procedure is used to report an attempt to use an unsafe member of an # ensemble command. -proc ::safe::BadSubcommand {slave command subcommand args} { +proc ::safe::BadSubcommand {child command subcommand args} { set msg "not allowed to invoke subcommand $subcommand of $command" - Log $slave $msg + Log $child $msg return -code error -errorcode {TCL SAFE SUBCOMMAND} $msg } -# AliasEncodingSystem is the target of the "encoding system" alias in safe -# interpreters. -proc ::safe::AliasEncodingSystem {slave args} { +# AliasEncoding is the target of the "encoding" alias in safe interpreters. + +proc ::safe::AliasEncoding {child option args} { + # Note that [encoding dirs] is not supported in safe children at all + set subcommands {convertfrom convertto names system} try { - # Must not pass extra arguments; safe slaves may not set the system - # encoding but they may read it. - if {[llength $args]} { + set option [tcl::prefix match -error [list -level 1 -errorcode \ + [list TCL LOOKUP INDEX option $option]] $subcommands $option] + # Special case: [encoding system] ok, but [encoding system foo] not + if {$option eq "system" && [llength $args]} { return -code error -errorcode {TCL WRONGARGS} \ "wrong # args: should be \"encoding system\"" } } on error {msg options} { - Log $slave $msg + Log $child $msg return -options $options $msg } - tailcall ::interp invokehidden $slave tcl:encoding:system + tailcall ::interp invokehidden $child encoding $option {*}$args } # Various minor hiding of platform features. [Bug 2913625] -proc ::safe::AliasExeName {slave} { +proc ::safe::AliasExeName {child} { return "" } + +# ------------------------------------------------------------------------------ +# Using Interpreter Names with Namespace Qualifiers +# ------------------------------------------------------------------------------ +# (1) We wish to preserve compatibility with existing code, in which Safe Base +# interpreter names have no namespace qualifiers. +# (2) safe::interpCreate and the rest of the Safe Base previously could not +# accept namespace qualifiers in an interpreter name. +# (3) The interp command will accept namespace qualifiers in an interpreter +# name, but accepts distinct interpreters that will have the same command +# name (e.g. foo, ::foo, and :::foo) (bug 66c2e8c974). +# (4) To satisfy these constraints, Safe Base interpreter names will be fully +# qualified namespace names with no excess colons and with the leading "::" +# omitted. +# (5) Trailing "::" implies a namespace tail {}, which interp reads as {{}}. +# Reject such names. +# (6) We could: +# (a) EITHER reject usable but non-compliant names (e.g. excess colons) in +# interpCreate, interpInit; +# (b) OR accept such names and then translate to a compliant name in every +# command. +# The problem with (b) is that the user will expect to use the name with the +# interp command and will find that it is not recognised. +# E.g "interpCreate ::foo" creates interpreter "foo", and the user's name +# "::foo" works with all the Safe Base commands, but "interp eval ::foo" +# fails. +# So we choose (a). +# (7) The command +# namespace upvar ::safe S$child state +# becomes +# namespace upvar ::safe [VarName $child] state +# ------------------------------------------------------------------------------ + +proc ::safe::RejectExcessColons {child} { + set stripped [regsub -all -- {:::*} $child ::] + if {[string range $stripped end-1 end] eq {::}} { + return -code error {interpreter name must not end in "::"} + } + if {$stripped ne $child} { + set msg {interpreter name has excess colons in namespace separators} + return -code error $msg + } + if {[string range $stripped 0 1] eq {::}} { + return -code error {interpreter name must not begin "::"} + } + return +} + +proc ::safe::VarName {child} { + # return S$child + return S[string map {:: @N @ @A} $child] +} proc ::safe::Setup {} { #### # # Setup the arguments parsing @@ -1104,25 +1265,25 @@ # internal variables # Log command, set via 'setLogCmd'. Logging is disabled when empty. variable Log {} - # The package maintains a state array per slave interp under its + # The package maintains a state array per child interp under its # control. The name of this array is S. This array is # brought into scope where needed, using 'namespace upvar'. The S - # prefix is used to avoid that a slave interp called "Log" smashes + # prefix is used to avoid that a child interp called "Log" smashes # the "Log" variable. # # The array's elements are: # - # access_path : List of paths accessible to the slave. + # access_path : List of paths accessible to the child. # access_path,norm : Ditto, in normalized form. - # access_path,slave : Ditto, as the path tokens as seen by the slave. + # access_path,slave : Ditto, as the path tokens as seen by the child. # access_path,map : dict ( token -> path ) # access_path,remap : dict ( path -> token ) - # tm_path_slave : List of TM root directories, as tokens seen by the slave. + # tm_path_slave : List of TM root directories, as tokens seen by the child. # staticsok : Value of option -statics # nestedok : Value of option -nested # cleanupHook : Value of option -deleteHook } ::safe::Setup Index: library/tclIndex ================================================================== --- library/tclIndex +++ library/tclIndex @@ -5,71 +5,74 @@ # more commands. Typically each line is a command that # sets an element in the auto_index array, where the # element name is the name of a command and the value is # a script that loads the command. -set auto_index(auto_reset) [list ::tcl::Pkg::source [file join $dir auto.tcl]] -set auto_index(tcl_findLibrary) [list ::tcl::Pkg::source [file join $dir auto.tcl]] -set auto_index(auto_mkindex) [list ::tcl::Pkg::source [file join $dir auto.tcl]] -set auto_index(auto_mkindex_old) [list ::tcl::Pkg::source [file join $dir auto.tcl]] -set auto_index(::auto_mkindex_parser::init) [list ::tcl::Pkg::source [file join $dir auto.tcl]] -set auto_index(::auto_mkindex_parser::cleanup) [list ::tcl::Pkg::source [file join $dir auto.tcl]] -set auto_index(::auto_mkindex_parser::mkindex) [list ::tcl::Pkg::source [file join $dir auto.tcl]] -set auto_index(::auto_mkindex_parser::hook) [list ::tcl::Pkg::source [file join $dir auto.tcl]] -set auto_index(::auto_mkindex_parser::slavehook) [list ::tcl::Pkg::source [file join $dir auto.tcl]] -set auto_index(::auto_mkindex_parser::command) [list ::tcl::Pkg::source [file join $dir auto.tcl]] -set auto_index(::auto_mkindex_parser::commandInit) [list ::tcl::Pkg::source [file join $dir auto.tcl]] -set auto_index(::auto_mkindex_parser::fullname) [list ::tcl::Pkg::source [file join $dir auto.tcl]] -set auto_index(history) [list ::tcl::Pkg::source [file join $dir history.tcl]] -set auto_index(::tcl::HistAdd) [list ::tcl::Pkg::source [file join $dir history.tcl]] -set auto_index(::tcl::HistKeep) [list ::tcl::Pkg::source [file join $dir history.tcl]] -set auto_index(::tcl::HistClear) [list ::tcl::Pkg::source [file join $dir history.tcl]] -set auto_index(::tcl::HistInfo) [list ::tcl::Pkg::source [file join $dir history.tcl]] -set auto_index(::tcl::HistRedo) [list ::tcl::Pkg::source [file join $dir history.tcl]] -set auto_index(::tcl::HistIndex) [list ::tcl::Pkg::source [file join $dir history.tcl]] -set auto_index(::tcl::HistEvent) [list ::tcl::Pkg::source [file join $dir history.tcl]] -set auto_index(::tcl::HistChange) [list ::tcl::Pkg::source [file join $dir history.tcl]] -set auto_index(pkg_mkIndex) [list ::tcl::Pkg::source [file join $dir package.tcl]] -set auto_index(tclPkgSetup) [list ::tcl::Pkg::source [file join $dir package.tcl]] -set auto_index(tclPkgUnknown) [list ::tcl::Pkg::source [file join $dir package.tcl]] -set auto_index(::tcl::MacOSXPkgUnknown) [list ::tcl::Pkg::source [file join $dir package.tcl]] -set auto_index(::pkg::create) [list ::tcl::Pkg::source [file join $dir package.tcl]] -set auto_index(parray) [list ::tcl::Pkg::source [file join $dir parray.tcl]] -set auto_index(::safe::InterpStatics) [list ::tcl::Pkg::source [file join $dir safe.tcl]] -set auto_index(::safe::InterpNested) [list ::tcl::Pkg::source [file join $dir safe.tcl]] -set auto_index(::safe::interpCreate) [list ::tcl::Pkg::source [file join $dir safe.tcl]] -set auto_index(::safe::interpInit) [list ::tcl::Pkg::source [file join $dir safe.tcl]] -set auto_index(::safe::CheckInterp) [list ::tcl::Pkg::source [file join $dir safe.tcl]] -set auto_index(::safe::interpConfigure) [list ::tcl::Pkg::source [file join $dir safe.tcl]] -set auto_index(::safe::InterpCreate) [list ::tcl::Pkg::source [file join $dir safe.tcl]] -set auto_index(::safe::InterpSetConfig) [list ::tcl::Pkg::source [file join $dir safe.tcl]] -set auto_index(::safe::interpFindInAccessPath) [list ::tcl::Pkg::source [file join $dir safe.tcl]] -set auto_index(::safe::interpAddToAccessPath) [list ::tcl::Pkg::source [file join $dir safe.tcl]] -set auto_index(::safe::InterpInit) [list ::tcl::Pkg::source [file join $dir safe.tcl]] -set auto_index(::safe::AddSubDirs) [list ::tcl::Pkg::source [file join $dir safe.tcl]] -set auto_index(::safe::interpDelete) [list ::tcl::Pkg::source [file join $dir safe.tcl]] -set auto_index(::safe::setLogCmd) [list ::tcl::Pkg::source [file join $dir safe.tcl]] -set auto_index(::safe::SyncAccessPath) [list ::tcl::Pkg::source [file join $dir safe.tcl]] -set auto_index(::safe::PathToken) [list ::tcl::Pkg::source [file join $dir safe.tcl]] -set auto_index(::safe::TranslatePath) [list ::tcl::Pkg::source [file join $dir safe.tcl]] -set auto_index(::safe::Log) [list ::tcl::Pkg::source [file join $dir safe.tcl]] -set auto_index(::safe::CheckFileName) [list ::tcl::Pkg::source [file join $dir safe.tcl]] -set auto_index(::safe::AliasGlob) [list ::tcl::Pkg::source [file join $dir safe.tcl]] -set auto_index(::safe::AliasSource) [list ::tcl::Pkg::source [file join $dir safe.tcl]] -set auto_index(::safe::AliasLoad) [list ::tcl::Pkg::source [file join $dir safe.tcl]] -set auto_index(::safe::FileInAccessPath) [list ::tcl::Pkg::source [file join $dir safe.tcl]] -set auto_index(::safe::DirInAccessPath) [list ::tcl::Pkg::source [file join $dir safe.tcl]] -set auto_index(::safe::Subset) [list ::tcl::Pkg::source [file join $dir safe.tcl]] -set auto_index(::safe::AliasSubset) [list ::tcl::Pkg::source [file join $dir safe.tcl]] -set auto_index(::safe::AliasEncoding) [list ::tcl::Pkg::source [file join $dir safe.tcl]] -set auto_index(tcl_wordBreakAfter) [list ::tcl::Pkg::source [file join $dir word.tcl]] -set auto_index(tcl_wordBreakBefore) [list ::tcl::Pkg::source [file join $dir word.tcl]] -set auto_index(tcl_endOfWord) [list ::tcl::Pkg::source [file join $dir word.tcl]] -set auto_index(tcl_startOfNextWord) [list ::tcl::Pkg::source [file join $dir word.tcl]] -set auto_index(tcl_startOfPreviousWord) [list ::tcl::Pkg::source [file join $dir word.tcl]] -set auto_index(::tcl::tm::add) [list ::tcl::Pkg::source [file join $dir tm.tcl]] -set auto_index(::tcl::tm::remove) [list ::tcl::Pkg::source [file join $dir tm.tcl]] -set auto_index(::tcl::tm::list) [list ::tcl::Pkg::source [file join $dir tm.tcl]] -set auto_index(::tcl::tm::Defaults) [list ::tcl::Pkg::source [file join $dir tm.tcl]] -set auto_index(::tcl::tm::UnknownHandler) [list ::tcl::Pkg::source [file join $dir tm.tcl]] -set auto_index(::tcl::tm::roots) [list ::tcl::Pkg::source [file join $dir tm.tcl]] -set auto_index(::tcl::tm::path) [list ::tcl::Pkg::source [file join $dir tm.tcl]] +set auto_index(auto_reset) [list source [file join $dir auto.tcl]] +set auto_index(tcl_findLibrary) [list source [file join $dir auto.tcl]] +set auto_index(auto_mkindex) [list source [file join $dir auto.tcl]] +set auto_index(auto_mkindex_old) [list source [file join $dir auto.tcl]] +set auto_index(::auto_mkindex_parser::init) [list source [file join $dir auto.tcl]] +set auto_index(::auto_mkindex_parser::cleanup) [list source [file join $dir auto.tcl]] +set auto_index(::auto_mkindex_parser::mkindex) [list source [file join $dir auto.tcl]] +set auto_index(::auto_mkindex_parser::hook) [list source [file join $dir auto.tcl]] +set auto_index(::auto_mkindex_parser::slavehook) [list source [file join $dir auto.tcl]] +set auto_index(::auto_mkindex_parser::command) [list source [file join $dir auto.tcl]] +set auto_index(::auto_mkindex_parser::commandInit) [list source [file join $dir auto.tcl]] +set auto_index(::auto_mkindex_parser::fullname) [list source [file join $dir auto.tcl]] +set auto_index(history) [list source [file join $dir history.tcl]] +set auto_index(::tcl::HistAdd) [list source [file join $dir history.tcl]] +set auto_index(::tcl::HistKeep) [list source [file join $dir history.tcl]] +set auto_index(::tcl::HistClear) [list source [file join $dir history.tcl]] +set auto_index(::tcl::HistInfo) [list source [file join $dir history.tcl]] +set auto_index(::tcl::HistRedo) [list source [file join $dir history.tcl]] +set auto_index(::tcl::HistIndex) [list source [file join $dir history.tcl]] +set auto_index(::tcl::HistEvent) [list source [file join $dir history.tcl]] +set auto_index(::tcl::HistChange) [list source [file join $dir history.tcl]] +set auto_index(pkg_mkIndex) [list source [file join $dir package.tcl]] +set auto_index(tclPkgSetup) [list source [file join $dir package.tcl]] +set auto_index(tclPkgUnknown) [list source [file join $dir package.tcl]] +set auto_index(::tcl::MacOSXPkgUnknown) [list source [file join $dir package.tcl]] +set auto_index(::pkg::create) [list source [file join $dir package.tcl]] +set auto_index(parray) [list source [file join $dir parray.tcl]] +set auto_index(::safe::InterpStatics) [list source [file join $dir safe.tcl]] +set auto_index(::safe::InterpNested) [list source [file join $dir safe.tcl]] +set auto_index(::safe::interpCreate) [list source [file join $dir safe.tcl]] +set auto_index(::safe::interpInit) [list source [file join $dir safe.tcl]] +set auto_index(::safe::CheckInterp) [list source [file join $dir safe.tcl]] +set auto_index(::safe::interpConfigure) [list source [file join $dir safe.tcl]] +set auto_index(::safe::InterpCreate) [list source [file join $dir safe.tcl]] +set auto_index(::safe::InterpSetConfig) [list source [file join $dir safe.tcl]] +set auto_index(::safe::interpFindInAccessPath) [list source [file join $dir safe.tcl]] +set auto_index(::safe::interpAddToAccessPath) [list source [file join $dir safe.tcl]] +set auto_index(::safe::InterpInit) [list source [file join $dir safe.tcl]] +set auto_index(::safe::AddSubDirs) [list source [file join $dir safe.tcl]] +set auto_index(::safe::interpDelete) [list source [file join $dir safe.tcl]] +set auto_index(::safe::setLogCmd) [list source [file join $dir safe.tcl]] +set auto_index(::safe::SyncAccessPath) [list source [file join $dir safe.tcl]] +set auto_index(::safe::PathToken) [list source [file join $dir safe.tcl]] +set auto_index(::safe::TranslatePath) [list source [file join $dir safe.tcl]] +set auto_index(::safe::Log) [list source [file join $dir safe.tcl]] +set auto_index(::safe::CheckFileName) [list source [file join $dir safe.tcl]] +set auto_index(::safe::AliasGlob) [list source [file join $dir safe.tcl]] +set auto_index(::safe::AliasSource) [list source [file join $dir safe.tcl]] +set auto_index(::safe::AliasLoad) [list source [file join $dir safe.tcl]] +set auto_index(::safe::FileInAccessPath) [list source [file join $dir safe.tcl]] +set auto_index(::safe::DirInAccessPath) [list source [file join $dir safe.tcl]] +set auto_index(::safe::Subset) [list source [file join $dir safe.tcl]] +set auto_index(::safe::AliasSubset) [list source [file join $dir safe.tcl]] +set auto_index(::safe::AliasEncoding) [list source [file join $dir safe.tcl]] +set auto_index(tcl_wordBreakAfter) [list source [file join $dir word.tcl]] +set auto_index(tcl_wordBreakBefore) [list source [file join $dir word.tcl]] +set auto_index(tcl_endOfWord) [list source [file join $dir word.tcl]] +set auto_index(tcl_startOfNextWord) [list source [file join $dir word.tcl]] +set auto_index(tcl_startOfPreviousWord) [list source [file join $dir word.tcl]] +set auto_index(::tcl::tm::add) [list source [file join $dir tm.tcl]] +set auto_index(::tcl::tm::remove) [list source [file join $dir tm.tcl]] +set auto_index(::tcl::tm::list) [list source [file join $dir tm.tcl]] +set auto_index(::tcl::tm::Defaults) [list source [file join $dir tm.tcl]] +set auto_index(::tcl::tm::UnknownHandler) [list source [file join $dir tm.tcl]] +set auto_index(::tcl::tm::roots) [list source [file join $dir tm.tcl]] +set auto_index(::tcl::tm::path) [list source [file join $dir tm.tcl]] +if {[namespace exists ::tcl::unsupported]} { + set auto_index(timerate) {namespace import ::tcl::unsupported::timerate} +} Index: library/tcltest/pkgIndex.tcl ================================================================== --- library/tcltest/pkgIndex.tcl +++ library/tcltest/pkgIndex.tcl @@ -7,6 +7,6 @@ # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.5-]} {return} -package ifneeded tcltest 2.5.0 [list source [file join $dir tcltest.tcl]] +package ifneeded tcltest 2.5.3 [list source [file join $dir tcltest.tcl]] Index: library/tcltest/tcltest.tcl ================================================================== --- library/tcltest/tcltest.tcl +++ library/tcltest/tcltest.tcl @@ -20,11 +20,11 @@ namespace eval tcltest { # When the version number changes, be sure to update the pkgIndex.tcl file, # and the install directory in the Makefiles. When the minor version # changes (new feature) be sure to update the man page as well. - variable Version 2.5.0 + variable Version 2.5.3 # Compatibility support for dumb variables defined in tcltest 1 # Do not use these. Call [package provide Tcl] and [info patchlevel] # yourself. You don't need tcltest to wrap it for you. variable version [package provide Tcl] @@ -638,11 +638,11 @@ return $valid } proc IsVerbose {level} { variable Option - return [expr {[lsearch -exact $Option(-verbose) $level] != -1}] + return [expr {[lsearch -exact $Option(-verbose) $level] >= 0}] } # Default verbosity is to show bodies of failed tests Option -verbose {body error} { Takes any combination of the values 'p', 's', 'b', 't', 'e' and 'l'. @@ -809,18 +809,18 @@ Send errors from test runs to the specified file. } AcceptOutFile errorFile trace add variable Option(-errfile) write \ [namespace code {errorChannel $Option(-errfile) ;#}] - proc loadIntoSlaveInterpreter {slave args} { + proc loadIntoChildInterpreter {child args} { variable Version - interp eval $slave [package ifneeded tcltest $Version] - interp eval $slave "tcltest::configure {*}{$args}" - interp alias $slave ::tcltest::ReportToMaster \ - {} ::tcltest::ReportedFromSlave + interp eval $child [package ifneeded tcltest $Version] + interp eval $child "tcltest::configure {*}{$args}" + interp alias $child ::tcltest::ReportToParent \ + {} ::tcltest::ReportedFromChild } - proc ReportedFromSlave {total passed skipped failed because newfiles} { + proc ReportedFromChild {total passed skipped failed because newfiles} { variable numTests variable skippedBecause variable createdNewFiles incr numTests(Total) $total incr numTests(Passed) $passed @@ -968,11 +968,11 @@ DebugPuts 3 "entering testConstraint $constraint $value" if {[llength [info level 0]] == 2} { return $testConstraints($constraint) } # Check for boolean values - if {[catch {expr {$value && $value}} msg]} { + if {[catch {expr {$value && 1}} msg]} { return -code error $msg } if {[limitConstraints] && ($constraint ni $Option(-constraints))} { set value 0 } @@ -1980,20 +1980,28 @@ if {[file exists [file join [workingDirectory] core]]} { set coreModTime [file mtime [file join [workingDirectory] core]] } } - # First, run the setup script + # First, run the setup script (or a hook if it presents): + if {[set cmd [namespace which -command [namespace current]::SetupTest]] ne ""} { + set setup [list $cmd $setup] + } + set processTest 1 set code [catch {uplevel 1 $setup} setupMsg] if {$code == 1} { set errorInfo(setup) $::errorInfo set errorCodeRes(setup) $::errorCode + if {$errorCodeRes(setup) eq "BYPASS-SKIPPED-TEST"} { + _noticeSkipped $name $setupMsg + set processTest [set code 0] + } } set setupFailure [expr {$code != 0}] # Only run the test body if the setup was successful - if {!$setupFailure} { + if {$processTest && !$setupFailure} { # Register startup time if {[IsVerbose msec] || [IsVerbose usec]} { set timeStart [clock microseconds] } @@ -2012,29 +2020,33 @@ } lassign $testResult actualAnswer returnCode if {$returnCode == 1} { set errorInfo(body) $::errorInfo set errorCodeRes(body) $::errorCode + if {$errorCodeRes(body) eq "BYPASS-SKIPPED-TEST"} { + _noticeSkipped $name $actualAnswer + set processTest [set returnCode 0] + } } } # check if the return code matched the expected return code set codeFailure 0 - if {!$setupFailure && ($returnCode ni $returnCodes)} { + if {$processTest && !$setupFailure && ($returnCode ni $returnCodes)} { set codeFailure 1 } set errorCodeFailure 0 - if {!$setupFailure && !$codeFailure && $returnCode == 1 && \ + if {$processTest && !$setupFailure && !$codeFailure && $returnCode == 1 && \ ![string match $errorCode $errorCodeRes(body)]} { set errorCodeFailure 1 } # If expected output/error strings exist, we have to compare # them. If the comparison fails, then so did the test. set outputFailure 0 variable outData - if {[info exists output] && !$codeFailure} { + if {$processTest && [info exists output] && !$codeFailure} { if {[set outputCompare [catch { CompareStrings $outData $output $match } outputMatch]] == 0} { set outputFailure [expr {!$outputMatch}] } else { @@ -2042,11 +2054,11 @@ } } set errorFailure 0 variable errData - if {[info exists errorOutput] && !$codeFailure} { + if {$processTest && [info exists errorOutput] && !$codeFailure} { if {[set errorCompare [catch { CompareStrings $errData $errorOutput $match } errorMatch]] == 0} { set errorFailure [expr {!$errorMatch}] } else { @@ -2054,21 +2066,26 @@ } } # check if the answer matched the expected answer # Only check if we ran the body of the test (no setup failure) - if {$setupFailure || $codeFailure} { + if {!$processTest} { + set scriptFailure 0 + } elseif {$setupFailure || $codeFailure} { set scriptFailure 0 } elseif {[set scriptCompare [catch { CompareStrings $actualAnswer $result $match } scriptMatch]] == 0} { set scriptFailure [expr {!$scriptMatch}] } else { set scriptFailure 1 } - # Always run the cleanup script + # Always run the cleanup script (or a hook if it presents): + if {[set cmd [namespace which -command [namespace current]::CleanupTest]] ne ""} { + set cleanup [list $cmd $cleanup] + } set code [catch {uplevel 1 $cleanup} cleanupMsg] if {$code == 1} { set errorInfo(cleanup) $::errorInfo set errorCodeRes(cleanup) $::errorCode } @@ -2114,10 +2131,16 @@ } if {[IsVerbose msec]} { puts [outputChannel] "++++ $name took [expr {round($t/1000.)}] ms" } } + + # if skipped, it is safe to return here + if {!$processTest} { + incr testLevel -1 + return + } # if we didn't experience any failures, then we passed variable numTests if {!($setupFailure || $cleanupFailure || $coreFailure || $outputFailure || $errorFailure || $codeFailure @@ -2175,11 +2198,11 @@ if {[info exists errorInfo(setup)]} { puts [outputChannel] "---- errorInfo(setup): $errorInfo(setup)" puts [outputChannel] "---- errorCode(setup): $errorCodeRes(setup)" } } - if {$scriptFailure} { + if {$processTest && $scriptFailure} { if {$scriptCompare} { puts [outputChannel] "---- Error testing result: $scriptMatch" } else { puts [outputChannel] "---- Result was:\n$actualAnswer" puts [outputChannel] "---- Result should have been\ @@ -2241,10 +2264,36 @@ puts [outputChannel] "==== $name FAILED\n" incr testLevel -1 return } + +# Skip -- +# +# Skips a running test and add a reason to skipped "constraints". Can be used +# to conditional intended abort of the test. +# +# Side Effects: Maintains tally of total tests seen and tests skipped. +# +proc tcltest::Skip {reason} { + return -code error -errorcode BYPASS-SKIPPED-TEST $reason +} + +proc tcltest::_noticeSkipped {name reason} { + variable testLevel + variable numTests + + if {[IsVerbose skip]} { + puts [outputChannel] "++++ $name SKIPPED: $reason" + } + + if {$testLevel == 1} { + incr numTests(Skipped) + AddToSkippedBecause $reason + } +} + # Skipped -- # # Given a test name and it constraints, returns a boolean indicating # whether the current configuration says the test should be skipped. @@ -2322,18 +2371,11 @@ } } } if {!$doTest} { - if {[IsVerbose skip]} { - puts [outputChannel] "++++ $name SKIPPED: $constraints" - } - - if {$testLevel == 1} { - incr numTests(Skipped) - AddToSkippedBecause $constraints - } + _noticeSkipped $name $constraints return 1 } } return 0 } @@ -2352,10 +2394,14 @@ if {[llength [info commands memory]] == 1} { memory tag $name } + # run the test script (or a hook if it presents): + if {[set cmd [namespace which -command [namespace current]::EvalTest]] ne ""} { + set script [list $cmd $script] + } set code [catch {uplevel 1 $script} actualAnswer] return [list $actualAnswer $code] } @@ -2414,12 +2460,12 @@ FillFilesExisted set testFileName [file tail [info script]] # Hook to handle reporting to a parent interpreter - if {[llength [info commands [namespace current]::ReportToMaster]]} { - ReportToMaster $numTests(Total) $numTests(Passed) $numTests(Skipped) \ + if {[llength [info commands [namespace current]::ReportToParent]]} { + ReportToParent $numTests(Total) $numTests(Passed) $numTests(Skipped) \ $numTests(Failed) [array get skippedBecause] \ [array get createdNewFiles] set testSingleFile false } @@ -2750,11 +2796,10 @@ variable testSingleFile variable numTestFiles variable numTests variable failFiles variable DefaultValue - set failFilesAccum {} FillFilesExisted if {[llength [info level 0]] == 1} { set shell [interpreter] } @@ -2806,12 +2851,22 @@ set tail [file tail $file] puts [outputChannel] $tail flush [outputChannel] if {[singleProcess]} { - incr numTestFiles - uplevel 1 [list ::source $file] + if {[catch { + incr numTestFiles + uplevel 1 [list ::source $file] + } msg]} { + puts [outputChannel] "Test file error: $msg" + # append the name of the test to a list to be reported + # later + lappend testFileFailures $file + } + if {$numTests(Failed) > 0} { + set failFilesSet 1 + } } else { # Pass along our configuration to the child processes. # EXCEPT for the -outfile, because the parent process # needs to read and process output of children. set childargv [list] @@ -2840,11 +2895,11 @@ foreach index {Total Passed Skipped Failed} { incr numTests($index) [set $index] } if {$Failed > 0} { lappend failFiles $testFile - lappend failFilesAccum $testFile + set failFilesSet 1 } } elseif {[regexp [join { {^Number of tests skipped } {for each constraint:} {|^\t(\d+)\t(.+)$} @@ -2887,11 +2942,11 @@ set endTime [eval $timeCmd] puts [outputChannel] "\n$dir test ended at $endTime" puts [outputChannel] "" puts [outputChannel] [string repeat ~ 44] } - return [expr {[info exists testFileFailures] || [llength $failFilesAccum]}] + return [expr {[info exists testFileFailures] || [info exists failFilesSet]}] } ##################################################################### # Test utility procs - not used in tcltest, but may be useful for @@ -3059,22 +3114,28 @@ set directory [temporaryDirectory] } set fullName [file join $directory $name] DebugPuts 3 "[lindex [info level 0] 0]: removing $fullName" set idx [lsearch -exact $filesMade $fullName] - set filesMade [lreplace $filesMade $idx $idx] - if {$idx == -1} { + if {$idx < 0} { DebugDo 1 { Warn "removeFile removing \"$fullName\":\n not created by makeFile" } + } else { + set filesMade [lreplace $filesMade $idx $idx] } if {![file isfile $fullName]} { DebugDo 1 { Warn "removeFile removing \"$fullName\":\n not a file" } } - return [file delete -- $fullName] + if {[catch {file delete -- $fullName} msg ]} { + DebugDo 1 { + Warn "removeFile removing \"$fullName\":\n failed: $msg" + } + } + return } # tcltest::makeDirectory -- # # Create a new dir with the name . @@ -3130,11 +3191,11 @@ } set fullName [file join $directory $name] DebugPuts 3 "[lindex [info level 0] 0]: deleting $fullName" set idx [lsearch -exact $filesMade $fullName] set filesMade [lreplace $filesMade $idx $idx] - if {$idx == -1} { + if {$idx < 0} { DebugDo 1 { Warn "removeDirectory removing \"$fullName\":\n not created\ by makeDirectory" } } @@ -3179,12 +3240,12 @@ # This allows the tester to # 1. Create denormalized or improperly formed strings to pass to C # procedures that are supposed to accept strings with embedded NULL # bytes. # 2. Confirm that a string result has a certain pattern of bytes, for -# instance to confirm that "\xe0\0" in a Tcl script is stored -# internally in UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80". +# instance to confirm that "\xE0\0" in a Tcl script is stored +# internally in UTF-8 as the sequence of bytes "\xC3\xA0\xC0\x80". # # Generally, it's a bad idea to examine the bytes in a Tcl string or to # construct improperly formed strings in this manner, because it involves # exposing that Tcl uses UTF-8 internally. # Index: library/tm.tcl ================================================================== --- library/tm.tcl +++ library/tm.tcl @@ -210,15 +210,16 @@ if {![interp issafe] && ![file exists $currentsearchpath]} { continue } set strip [llength [file split $path]] - # We can't use glob in safe interps, so enclose the following in a - # catch statement, where we get the module files out of the - # subdirectories. In other words, Tcl Modules are not-functional - # in such an interpreter. This is the same as for the command - # "tclPkgUnknown", i.e. the search for regular packages. + # Get the module files out of the subdirectories. + # - Safe Base interpreters have a restricted "glob" command that + # works in this case. + # - The "catch" was essential when there was no safe glob and every + # call in a safe interp failed; it is retained only for corner + # cases in which the eventual call to glob returns an error. catch { # We always look for _all_ possible modules in the current # path, to get the max result out of the glob. @@ -236,16 +237,20 @@ # Ignore everything where the version part is not # acceptable to "package vcompare". continue } - if {[package ifneeded $pkgname $pkgversion] ne {}} { + if {([package ifneeded $pkgname $pkgversion] ne {}) + && (![interp issafe]) + } { # There's already a provide script registered for # this version of this package. Since all units of # code claiming to be the same version of the same # package ought to be identical, just stick with # the one we already have. + # This does not apply to Safe Base interpreters because + # the token-to-directory mapping may have changed. continue } # We have found a candidate, generate a "provide script" # for it, and remember it. Note that we are using ::list @@ -309,11 +314,11 @@ # May add paths to the list of defaults. proc ::tcl::tm::Defaults {} { global env tcl_platform - lassign [split [info tclversion] .] major minor + regexp {^(\d+)\.(\d+)} [package provide Tcl] - major minor set exe [file normalize [info nameofexecutable]] # Note that we're using [::list], not [list] because [list] means # something other than [::list] in this namespace. roots [::list \ @@ -352,11 +357,11 @@ # # Sideeffects # Calls 'path add' to paths to the list of module search paths. proc ::tcl::tm::roots {paths} { - regexp {^(\d+)\.(\d+)} [package present Tcl] - major minor + regexp {^(\d+)\.(\d+)} [package provide Tcl] - major minor foreach pa $paths { set p [file join $pa tcl$major] for {set n $minor} {$n >= 0} {incr n -1} { set px [file join $p ${major}.${n}] if {![interp issafe]} {set px [file normalize $px]} Index: library/tzdata/Africa/Algiers ================================================================== --- library/tzdata/Africa/Algiers +++ library/tzdata/Africa/Algiers @@ -1,10 +1,10 @@ # created by tools/tclZIC.tcl - do not edit set TZData(:Africa/Algiers) { {-9223372036854775808 732 0 LMT} - {-2486679072 561 0 PMT} + {-2486592732 561 0 PMT} {-1855958961 0 0 WET} {-1689814800 3600 1 WEST} {-1680397200 0 0 WET} {-1665363600 3600 1 WEST} {-1648342800 0 0 WET} Index: library/tzdata/Africa/Casablanca ================================================================== --- library/tzdata/Africa/Casablanca +++ library/tzdata/Africa/Casablanca @@ -58,43 +58,145 @@ {1529200800 3600 1 +00} {1540695600 3600 0 +01} {1557021600 0 1 +01} {1560045600 3600 0 +01} {1587261600 0 1 +01} - {1590285600 3600 0 +01} + {1590890400 3600 0 +01} {1618106400 0 1 +01} {1621130400 3600 0 +01} {1648346400 0 1 +01} {1651975200 3600 0 +01} {1679191200 0 1 +01} - {1682215200 3600 0 +01} + {1682820000 3600 0 +01} {1710036000 0 1 +01} {1713060000 3600 0 +01} {1740276000 0 1 +01} {1743904800 3600 0 +01} {1771120800 0 1 +01} {1774144800 3600 0 +01} {1801965600 0 1 +01} {1804989600 3600 0 +01} {1832205600 0 1 +01} - {1835229600 3600 0 +01} + {1835834400 3600 0 +01} {1863050400 0 1 +01} {1866074400 3600 0 +01} {1893290400 0 1 +01} {1896919200 3600 0 +01} {1924135200 0 1 +01} - {1927159200 3600 0 +01} + {1927764000 3600 0 +01} {1954980000 0 1 +01} {1958004000 3600 0 +01} {1985220000 0 1 +01} {1988848800 3600 0 +01} {2016064800 0 1 +01} {2019088800 3600 0 +01} {2046304800 0 1 +01} {2049933600 3600 0 +01} {2077149600 0 1 +01} - {2080173600 3600 0 +01} + {2080778400 3600 0 +01} {2107994400 0 1 +01} {2111018400 3600 0 +01} {2138234400 0 1 +01} {2141863200 3600 0 +01} + {2169079200 0 1 +01} + {2172708000 3600 0 +01} + {2199924000 0 1 +01} + {2202948000 3600 0 +01} + {2230164000 0 1 +01} + {2233792800 3600 0 +01} + {2261008800 0 1 +01} + {2264032800 3600 0 +01} + {2291248800 0 1 +01} + {2294877600 3600 0 +01} + {2322093600 0 1 +01} + {2325722400 3600 0 +01} + {2352938400 0 1 +01} + {2355962400 3600 0 +01} + {2383178400 0 1 +01} + {2386807200 3600 0 +01} + {2414023200 0 1 +01} + {2417652000 3600 0 +01} + {2444868000 0 1 +01} + {2447892000 3600 0 +01} + {2475108000 0 1 +01} + {2478736800 3600 0 +01} + {2505952800 0 1 +01} + {2508976800 3600 0 +01} + {2536192800 0 1 +01} + {2539821600 3600 0 +01} + {2567037600 0 1 +01} + {2570666400 3600 0 +01} + {2597882400 0 1 +01} + {2600906400 3600 0 +01} + {2628122400 0 1 +01} + {2631751200 3600 0 +01} + {2658967200 0 1 +01} + {2662596000 3600 0 +01} + {2689812000 0 1 +01} + {2692836000 3600 0 +01} + {2720052000 0 1 +01} + {2723680800 3600 0 +01} + {2750896800 0 1 +01} + {2753920800 3600 0 +01} + {2781136800 0 1 +01} + {2784765600 3600 0 +01} + {2811981600 0 1 +01} + {2815610400 3600 0 +01} + {2842826400 0 1 +01} + {2845850400 3600 0 +01} + {2873066400 0 1 +01} + {2876695200 3600 0 +01} + {2903911200 0 1 +01} + {2907540000 3600 0 +01} + {2934756000 0 1 +01} + {2937780000 3600 0 +01} + {2964996000 0 1 +01} + {2968624800 3600 0 +01} + {2995840800 0 1 +01} + {2998864800 3600 0 +01} + {3026080800 0 1 +01} + {3029709600 3600 0 +01} + {3056925600 0 1 +01} + {3060554400 3600 0 +01} + {3087770400 0 1 +01} + {3090794400 3600 0 +01} + {3118010400 0 1 +01} + {3121639200 3600 0 +01} + {3148855200 0 1 +01} + {3152484000 3600 0 +01} + {3179700000 0 1 +01} + {3182724000 3600 0 +01} + {3209940000 0 1 +01} + {3213568800 3600 0 +01} + {3240784800 0 1 +01} + {3243808800 3600 0 +01} + {3271024800 0 1 +01} + {3274653600 3600 0 +01} + {3301869600 0 1 +01} + {3305498400 3600 0 +01} + {3332714400 0 1 +01} + {3335738400 3600 0 +01} + {3362954400 0 1 +01} + {3366583200 3600 0 +01} + {3393799200 0 1 +01} + {3397428000 3600 0 +01} + {3424644000 0 1 +01} + {3427668000 3600 0 +01} + {3454884000 0 1 +01} + {3458512800 3600 0 +01} + {3485728800 0 1 +01} + {3488752800 3600 0 +01} + {3515968800 0 1 +01} + {3519597600 3600 0 +01} + {3546813600 0 1 +01} + {3550442400 3600 0 +01} + {3577658400 0 1 +01} + {3580682400 3600 0 +01} + {3607898400 0 1 +01} + {3611527200 3600 0 +01} + {3638743200 0 1 +01} + {3642372000 3600 0 +01} + {3669588000 0 1 +01} + {3672612000 3600 0 +01} + {3699828000 0 1 +01} + {3703456800 3600 0 +01} } Index: library/tzdata/Africa/El_Aaiun ================================================================== --- library/tzdata/Africa/El_Aaiun +++ library/tzdata/Africa/El_Aaiun @@ -47,43 +47,145 @@ {1529200800 3600 1 +00} {1540695600 3600 0 +01} {1557021600 0 1 +01} {1560045600 3600 0 +01} {1587261600 0 1 +01} - {1590285600 3600 0 +01} + {1590890400 3600 0 +01} {1618106400 0 1 +01} {1621130400 3600 0 +01} {1648346400 0 1 +01} {1651975200 3600 0 +01} {1679191200 0 1 +01} - {1682215200 3600 0 +01} + {1682820000 3600 0 +01} {1710036000 0 1 +01} {1713060000 3600 0 +01} {1740276000 0 1 +01} {1743904800 3600 0 +01} {1771120800 0 1 +01} {1774144800 3600 0 +01} {1801965600 0 1 +01} {1804989600 3600 0 +01} {1832205600 0 1 +01} - {1835229600 3600 0 +01} + {1835834400 3600 0 +01} {1863050400 0 1 +01} {1866074400 3600 0 +01} {1893290400 0 1 +01} {1896919200 3600 0 +01} {1924135200 0 1 +01} - {1927159200 3600 0 +01} + {1927764000 3600 0 +01} {1954980000 0 1 +01} {1958004000 3600 0 +01} {1985220000 0 1 +01} {1988848800 3600 0 +01} {2016064800 0 1 +01} {2019088800 3600 0 +01} {2046304800 0 1 +01} {2049933600 3600 0 +01} {2077149600 0 1 +01} - {2080173600 3600 0 +01} + {2080778400 3600 0 +01} {2107994400 0 1 +01} {2111018400 3600 0 +01} {2138234400 0 1 +01} {2141863200 3600 0 +01} + {2169079200 0 1 +01} + {2172708000 3600 0 +01} + {2199924000 0 1 +01} + {2202948000 3600 0 +01} + {2230164000 0 1 +01} + {2233792800 3600 0 +01} + {2261008800 0 1 +01} + {2264032800 3600 0 +01} + {2291248800 0 1 +01} + {2294877600 3600 0 +01} + {2322093600 0 1 +01} + {2325722400 3600 0 +01} + {2352938400 0 1 +01} + {2355962400 3600 0 +01} + {2383178400 0 1 +01} + {2386807200 3600 0 +01} + {2414023200 0 1 +01} + {2417652000 3600 0 +01} + {2444868000 0 1 +01} + {2447892000 3600 0 +01} + {2475108000 0 1 +01} + {2478736800 3600 0 +01} + {2505952800 0 1 +01} + {2508976800 3600 0 +01} + {2536192800 0 1 +01} + {2539821600 3600 0 +01} + {2567037600 0 1 +01} + {2570666400 3600 0 +01} + {2597882400 0 1 +01} + {2600906400 3600 0 +01} + {2628122400 0 1 +01} + {2631751200 3600 0 +01} + {2658967200 0 1 +01} + {2662596000 3600 0 +01} + {2689812000 0 1 +01} + {2692836000 3600 0 +01} + {2720052000 0 1 +01} + {2723680800 3600 0 +01} + {2750896800 0 1 +01} + {2753920800 3600 0 +01} + {2781136800 0 1 +01} + {2784765600 3600 0 +01} + {2811981600 0 1 +01} + {2815610400 3600 0 +01} + {2842826400 0 1 +01} + {2845850400 3600 0 +01} + {2873066400 0 1 +01} + {2876695200 3600 0 +01} + {2903911200 0 1 +01} + {2907540000 3600 0 +01} + {2934756000 0 1 +01} + {2937780000 3600 0 +01} + {2964996000 0 1 +01} + {2968624800 3600 0 +01} + {2995840800 0 1 +01} + {2998864800 3600 0 +01} + {3026080800 0 1 +01} + {3029709600 3600 0 +01} + {3056925600 0 1 +01} + {3060554400 3600 0 +01} + {3087770400 0 1 +01} + {3090794400 3600 0 +01} + {3118010400 0 1 +01} + {3121639200 3600 0 +01} + {3148855200 0 1 +01} + {3152484000 3600 0 +01} + {3179700000 0 1 +01} + {3182724000 3600 0 +01} + {3209940000 0 1 +01} + {3213568800 3600 0 +01} + {3240784800 0 1 +01} + {3243808800 3600 0 +01} + {3271024800 0 1 +01} + {3274653600 3600 0 +01} + {3301869600 0 1 +01} + {3305498400 3600 0 +01} + {3332714400 0 1 +01} + {3335738400 3600 0 +01} + {3362954400 0 1 +01} + {3366583200 3600 0 +01} + {3393799200 0 1 +01} + {3397428000 3600 0 +01} + {3424644000 0 1 +01} + {3427668000 3600 0 +01} + {3454884000 0 1 +01} + {3458512800 3600 0 +01} + {3485728800 0 1 +01} + {3488752800 3600 0 +01} + {3515968800 0 1 +01} + {3519597600 3600 0 +01} + {3546813600 0 1 +01} + {3550442400 3600 0 +01} + {3577658400 0 1 +01} + {3580682400 3600 0 +01} + {3607898400 0 1 +01} + {3611527200 3600 0 +01} + {3638743200 0 1 +01} + {3642372000 3600 0 +01} + {3669588000 0 1 +01} + {3672612000 3600 0 +01} + {3699828000 0 1 +01} + {3703456800 3600 0 +01} } Index: library/tzdata/America/Campo_Grande ================================================================== --- library/tzdata/America/Campo_Grande +++ library/tzdata/America/Campo_Grande @@ -91,167 +91,6 @@ {1487473200 -14400 0 -04} {1508040000 -10800 1 -04} {1518922800 -14400 0 -04} {1541304000 -10800 1 -04} {1550372400 -14400 0 -04} - {1572753600 -10800 1 -04} - {1581822000 -14400 0 -04} - {1604203200 -10800 1 -04} - {1613876400 -14400 0 -04} - {1636257600 -10800 1 -04} - {1645326000 -14400 0 -04} - {1667707200 -10800 1 -04} - {1677380400 -14400 0 -04} - {1699156800 -10800 1 -04} - {1708225200 -14400 0 -04} - {1730606400 -10800 1 -04} - {1739674800 -14400 0 -04} - {1762056000 -10800 1 -04} - {1771729200 -14400 0 -04} - {1793505600 -10800 1 -04} - {1803178800 -14400 0 -04} - {1825560000 -10800 1 -04} - {1834628400 -14400 0 -04} - {1857009600 -10800 1 -04} - {1866078000 -14400 0 -04} - {1888459200 -10800 1 -04} - {1897527600 -14400 0 -04} - {1919908800 -10800 1 -04} - {1928977200 -14400 0 -04} - {1951358400 -10800 1 -04} - {1960426800 -14400 0 -04} - {1983412800 -10800 1 -04} - {1992481200 -14400 0 -04} - {2014862400 -10800 1 -04} - {2024535600 -14400 0 -04} - {2046312000 -10800 1 -04} - {2055380400 -14400 0 -04} - {2077761600 -10800 1 -04} - {2086830000 -14400 0 -04} - {2109211200 -10800 1 -04} - {2118884400 -14400 0 -04} - {2140660800 -10800 1 -04} - {2150334000 -14400 0 -04} - {2172715200 -10800 1 -04} - {2181783600 -14400 0 -04} - {2204164800 -10800 1 -04} - {2213233200 -14400 0 -04} - {2235614400 -10800 1 -04} - {2244682800 -14400 0 -04} - {2267064000 -10800 1 -04} - {2276132400 -14400 0 -04} - {2298513600 -10800 1 -04} - {2307582000 -14400 0 -04} - {2329963200 -10800 1 -04} - {2339636400 -14400 0 -04} - {2362017600 -10800 1 -04} - {2371086000 -14400 0 -04} - {2393467200 -10800 1 -04} - {2402535600 -14400 0 -04} - {2424916800 -10800 1 -04} - {2433985200 -14400 0 -04} - {2456366400 -10800 1 -04} - {2465434800 -14400 0 -04} - {2487816000 -10800 1 -04} - {2497489200 -14400 0 -04} - {2519870400 -10800 1 -04} - {2528938800 -14400 0 -04} - {2551320000 -10800 1 -04} - {2560388400 -14400 0 -04} - {2582769600 -10800 1 -04} - {2591838000 -14400 0 -04} - {2614219200 -10800 1 -04} - {2623287600 -14400 0 -04} - {2645668800 -10800 1 -04} - {2654737200 -14400 0 -04} - {2677118400 -10800 1 -04} - {2686791600 -14400 0 -04} - {2709172800 -10800 1 -04} - {2718241200 -14400 0 -04} - {2740622400 -10800 1 -04} - {2749690800 -14400 0 -04} - {2772072000 -10800 1 -04} - {2781140400 -14400 0 -04} - {2803521600 -10800 1 -04} - {2812590000 -14400 0 -04} - {2834971200 -10800 1 -04} - {2844039600 -14400 0 -04} - {2867025600 -10800 1 -04} - {2876094000 -14400 0 -04} - {2898475200 -10800 1 -04} - {2907543600 -14400 0 -04} - {2929924800 -10800 1 -04} - {2938993200 -14400 0 -04} - {2961374400 -10800 1 -04} - {2970442800 -14400 0 -04} - {2992824000 -10800 1 -04} - {3001892400 -14400 0 -04} - {3024273600 -10800 1 -04} - {3033946800 -14400 0 -04} - {3056328000 -10800 1 -04} - {3065396400 -14400 0 -04} - {3087777600 -10800 1 -04} - {3096846000 -14400 0 -04} - {3119227200 -10800 1 -04} - {3128295600 -14400 0 -04} - {3150676800 -10800 1 -04} - {3159745200 -14400 0 -04} - {3182126400 -10800 1 -04} - {3191194800 -14400 0 -04} - {3213576000 -10800 1 -04} - {3223249200 -14400 0 -04} - {3245630400 -10800 1 -04} - {3254698800 -14400 0 -04} - {3277080000 -10800 1 -04} - {3286148400 -14400 0 -04} - {3308529600 -10800 1 -04} - {3317598000 -14400 0 -04} - {3339979200 -10800 1 -04} - {3349047600 -14400 0 -04} - {3371428800 -10800 1 -04} - {3381102000 -14400 0 -04} - {3403483200 -10800 1 -04} - {3412551600 -14400 0 -04} - {3434932800 -10800 1 -04} - {3444001200 -14400 0 -04} - {3466382400 -10800 1 -04} - {3475450800 -14400 0 -04} - {3497832000 -10800 1 -04} - {3506900400 -14400 0 -04} - {3529281600 -10800 1 -04} - {3538350000 -14400 0 -04} - {3560731200 -10800 1 -04} - {3570404400 -14400 0 -04} - {3592785600 -10800 1 -04} - {3601854000 -14400 0 -04} - {3624235200 -10800 1 -04} - {3633303600 -14400 0 -04} - {3655684800 -10800 1 -04} - {3664753200 -14400 0 -04} - {3687134400 -10800 1 -04} - {3696202800 -14400 0 -04} - {3718584000 -10800 1 -04} - {3727652400 -14400 0 -04} - {3750638400 -10800 1 -04} - {3759706800 -14400 0 -04} - {3782088000 -10800 1 -04} - {3791156400 -14400 0 -04} - {3813537600 -10800 1 -04} - {3822606000 -14400 0 -04} - {3844987200 -10800 1 -04} - {3854055600 -14400 0 -04} - {3876436800 -10800 1 -04} - {3885505200 -14400 0 -04} - {3907886400 -10800 1 -04} - {3917559600 -14400 0 -04} - {3939940800 -10800 1 -04} - {3949009200 -14400 0 -04} - {3971390400 -10800 1 -04} - {3980458800 -14400 0 -04} - {4002840000 -10800 1 -04} - {4011908400 -14400 0 -04} - {4034289600 -10800 1 -04} - {4043358000 -14400 0 -04} - {4065739200 -10800 1 -04} - {4074807600 -14400 0 -04} - {4097188800 -10800 1 -04} } Index: library/tzdata/America/Cuiaba ================================================================== --- library/tzdata/America/Cuiaba +++ library/tzdata/America/Cuiaba @@ -91,167 +91,6 @@ {1487473200 -14400 0 -04} {1508040000 -10800 1 -04} {1518922800 -14400 0 -04} {1541304000 -10800 1 -04} {1550372400 -14400 0 -04} - {1572753600 -10800 1 -04} - {1581822000 -14400 0 -04} - {1604203200 -10800 1 -04} - {1613876400 -14400 0 -04} - {1636257600 -10800 1 -04} - {1645326000 -14400 0 -04} - {1667707200 -10800 1 -04} - {1677380400 -14400 0 -04} - {1699156800 -10800 1 -04} - {1708225200 -14400 0 -04} - {1730606400 -10800 1 -04} - {1739674800 -14400 0 -04} - {1762056000 -10800 1 -04} - {1771729200 -14400 0 -04} - {1793505600 -10800 1 -04} - {1803178800 -14400 0 -04} - {1825560000 -10800 1 -04} - {1834628400 -14400 0 -04} - {1857009600 -10800 1 -04} - {1866078000 -14400 0 -04} - {1888459200 -10800 1 -04} - {1897527600 -14400 0 -04} - {1919908800 -10800 1 -04} - {1928977200 -14400 0 -04} - {1951358400 -10800 1 -04} - {1960426800 -14400 0 -04} - {1983412800 -10800 1 -04} - {1992481200 -14400 0 -04} - {2014862400 -10800 1 -04} - {2024535600 -14400 0 -04} - {2046312000 -10800 1 -04} - {2055380400 -14400 0 -04} - {2077761600 -10800 1 -04} - {2086830000 -14400 0 -04} - {2109211200 -10800 1 -04} - {2118884400 -14400 0 -04} - {2140660800 -10800 1 -04} - {2150334000 -14400 0 -04} - {2172715200 -10800 1 -04} - {2181783600 -14400 0 -04} - {2204164800 -10800 1 -04} - {2213233200 -14400 0 -04} - {2235614400 -10800 1 -04} - {2244682800 -14400 0 -04} - {2267064000 -10800 1 -04} - {2276132400 -14400 0 -04} - {2298513600 -10800 1 -04} - {2307582000 -14400 0 -04} - {2329963200 -10800 1 -04} - {2339636400 -14400 0 -04} - {2362017600 -10800 1 -04} - {2371086000 -14400 0 -04} - {2393467200 -10800 1 -04} - {2402535600 -14400 0 -04} - {2424916800 -10800 1 -04} - {2433985200 -14400 0 -04} - {2456366400 -10800 1 -04} - {2465434800 -14400 0 -04} - {2487816000 -10800 1 -04} - {2497489200 -14400 0 -04} - {2519870400 -10800 1 -04} - {2528938800 -14400 0 -04} - {2551320000 -10800 1 -04} - {2560388400 -14400 0 -04} - {2582769600 -10800 1 -04} - {2591838000 -14400 0 -04} - {2614219200 -10800 1 -04} - {2623287600 -14400 0 -04} - {2645668800 -10800 1 -04} - {2654737200 -14400 0 -04} - {2677118400 -10800 1 -04} - {2686791600 -14400 0 -04} - {2709172800 -10800 1 -04} - {2718241200 -14400 0 -04} - {2740622400 -10800 1 -04} - {2749690800 -14400 0 -04} - {2772072000 -10800 1 -04} - {2781140400 -14400 0 -04} - {2803521600 -10800 1 -04} - {2812590000 -14400 0 -04} - {2834971200 -10800 1 -04} - {2844039600 -14400 0 -04} - {2867025600 -10800 1 -04} - {2876094000 -14400 0 -04} - {2898475200 -10800 1 -04} - {2907543600 -14400 0 -04} - {2929924800 -10800 1 -04} - {2938993200 -14400 0 -04} - {2961374400 -10800 1 -04} - {2970442800 -14400 0 -04} - {2992824000 -10800 1 -04} - {3001892400 -14400 0 -04} - {3024273600 -10800 1 -04} - {3033946800 -14400 0 -04} - {3056328000 -10800 1 -04} - {3065396400 -14400 0 -04} - {3087777600 -10800 1 -04} - {3096846000 -14400 0 -04} - {3119227200 -10800 1 -04} - {3128295600 -14400 0 -04} - {3150676800 -10800 1 -04} - {3159745200 -14400 0 -04} - {3182126400 -10800 1 -04} - {3191194800 -14400 0 -04} - {3213576000 -10800 1 -04} - {3223249200 -14400 0 -04} - {3245630400 -10800 1 -04} - {3254698800 -14400 0 -04} - {3277080000 -10800 1 -04} - {3286148400 -14400 0 -04} - {3308529600 -10800 1 -04} - {3317598000 -14400 0 -04} - {3339979200 -10800 1 -04} - {3349047600 -14400 0 -04} - {3371428800 -10800 1 -04} - {3381102000 -14400 0 -04} - {3403483200 -10800 1 -04} - {3412551600 -14400 0 -04} - {3434932800 -10800 1 -04} - {3444001200 -14400 0 -04} - {3466382400 -10800 1 -04} - {3475450800 -14400 0 -04} - {3497832000 -10800 1 -04} - {3506900400 -14400 0 -04} - {3529281600 -10800 1 -04} - {3538350000 -14400 0 -04} - {3560731200 -10800 1 -04} - {3570404400 -14400 0 -04} - {3592785600 -10800 1 -04} - {3601854000 -14400 0 -04} - {3624235200 -10800 1 -04} - {3633303600 -14400 0 -04} - {3655684800 -10800 1 -04} - {3664753200 -14400 0 -04} - {3687134400 -10800 1 -04} - {3696202800 -14400 0 -04} - {3718584000 -10800 1 -04} - {3727652400 -14400 0 -04} - {3750638400 -10800 1 -04} - {3759706800 -14400 0 -04} - {3782088000 -10800 1 -04} - {3791156400 -14400 0 -04} - {3813537600 -10800 1 -04} - {3822606000 -14400 0 -04} - {3844987200 -10800 1 -04} - {3854055600 -14400 0 -04} - {3876436800 -10800 1 -04} - {3885505200 -14400 0 -04} - {3907886400 -10800 1 -04} - {3917559600 -14400 0 -04} - {3939940800 -10800 1 -04} - {3949009200 -14400 0 -04} - {3971390400 -10800 1 -04} - {3980458800 -14400 0 -04} - {4002840000 -10800 1 -04} - {4011908400 -14400 0 -04} - {4034289600 -10800 1 -04} - {4043358000 -14400 0 -04} - {4065739200 -10800 1 -04} - {4074807600 -14400 0 -04} - {4097188800 -10800 1 -04} } Index: library/tzdata/America/Dawson ================================================================== --- library/tzdata/America/Dawson +++ library/tzdata/America/Dawson @@ -92,165 +92,7 @@ {1520762400 -25200 1 PDT} {1541322000 -28800 0 PST} {1552212000 -25200 1 PDT} {1572771600 -28800 0 PST} {1583661600 -25200 1 PDT} - {1604221200 -28800 0 PST} - {1615716000 -25200 1 PDT} - {1636275600 -28800 0 PST} - {1647165600 -25200 1 PDT} - {1667725200 -28800 0 PST} - {1678615200 -25200 1 PDT} - {1699174800 -28800 0 PST} - {1710064800 -25200 1 PDT} - {1730624400 -28800 0 PST} - {1741514400 -25200 1 PDT} - {1762074000 -28800 0 PST} - {1772964000 -25200 1 PDT} - {1793523600 -28800 0 PST} - {1805018400 -25200 1 PDT} - {1825578000 -28800 0 PST} - {1836468000 -25200 1 PDT} - {1857027600 -28800 0 PST} - {1867917600 -25200 1 PDT} - {1888477200 -28800 0 PST} - {1899367200 -25200 1 PDT} - {1919926800 -28800 0 PST} - {1930816800 -25200 1 PDT} - {1951376400 -28800 0 PST} - {1962871200 -25200 1 PDT} - {1983430800 -28800 0 PST} - {1994320800 -25200 1 PDT} - {2014880400 -28800 0 PST} - {2025770400 -25200 1 PDT} - {2046330000 -28800 0 PST} - {2057220000 -25200 1 PDT} - {2077779600 -28800 0 PST} - {2088669600 -25200 1 PDT} - {2109229200 -28800 0 PST} - {2120119200 -25200 1 PDT} - {2140678800 -28800 0 PST} - {2152173600 -25200 1 PDT} - {2172733200 -28800 0 PST} - {2183623200 -25200 1 PDT} - {2204182800 -28800 0 PST} - {2215072800 -25200 1 PDT} - {2235632400 -28800 0 PST} - {2246522400 -25200 1 PDT} - {2267082000 -28800 0 PST} - {2277972000 -25200 1 PDT} - {2298531600 -28800 0 PST} - {2309421600 -25200 1 PDT} - {2329981200 -28800 0 PST} - {2341476000 -25200 1 PDT} - {2362035600 -28800 0 PST} - {2372925600 -25200 1 PDT} - {2393485200 -28800 0 PST} - {2404375200 -25200 1 PDT} - {2424934800 -28800 0 PST} - {2435824800 -25200 1 PDT} - {2456384400 -28800 0 PST} - {2467274400 -25200 1 PDT} - {2487834000 -28800 0 PST} - {2499328800 -25200 1 PDT} - {2519888400 -28800 0 PST} - {2530778400 -25200 1 PDT} - {2551338000 -28800 0 PST} - {2562228000 -25200 1 PDT} - {2582787600 -28800 0 PST} - {2593677600 -25200 1 PDT} - {2614237200 -28800 0 PST} - {2625127200 -25200 1 PDT} - {2645686800 -28800 0 PST} - {2656576800 -25200 1 PDT} - {2677136400 -28800 0 PST} - {2688631200 -25200 1 PDT} - {2709190800 -28800 0 PST} - {2720080800 -25200 1 PDT} - {2740640400 -28800 0 PST} - {2751530400 -25200 1 PDT} - {2772090000 -28800 0 PST} - {2782980000 -25200 1 PDT} - {2803539600 -28800 0 PST} - {2814429600 -25200 1 PDT} - {2834989200 -28800 0 PST} - {2846484000 -25200 1 PDT} - {2867043600 -28800 0 PST} - {2877933600 -25200 1 PDT} - {2898493200 -28800 0 PST} - {2909383200 -25200 1 PDT} - {2929942800 -28800 0 PST} - {2940832800 -25200 1 PDT} - {2961392400 -28800 0 PST} - {2972282400 -25200 1 PDT} - {2992842000 -28800 0 PST} - {3003732000 -25200 1 PDT} - {3024291600 -28800 0 PST} - {3035786400 -25200 1 PDT} - {3056346000 -28800 0 PST} - {3067236000 -25200 1 PDT} - {3087795600 -28800 0 PST} - {3098685600 -25200 1 PDT} - {3119245200 -28800 0 PST} - {3130135200 -25200 1 PDT} - {3150694800 -28800 0 PST} - {3161584800 -25200 1 PDT} - {3182144400 -28800 0 PST} - {3193034400 -25200 1 PDT} - {3213594000 -28800 0 PST} - {3225088800 -25200 1 PDT} - {3245648400 -28800 0 PST} - {3256538400 -25200 1 PDT} - {3277098000 -28800 0 PST} - {3287988000 -25200 1 PDT} - {3308547600 -28800 0 PST} - {3319437600 -25200 1 PDT} - {3339997200 -28800 0 PST} - {3350887200 -25200 1 PDT} - {3371446800 -28800 0 PST} - {3382941600 -25200 1 PDT} - {3403501200 -28800 0 PST} - {3414391200 -25200 1 PDT} - {3434950800 -28800 0 PST} - {3445840800 -25200 1 PDT} - {3466400400 -28800 0 PST} - {3477290400 -25200 1 PDT} - {3497850000 -28800 0 PST} - {3508740000 -25200 1 PDT} - {3529299600 -28800 0 PST} - {3540189600 -25200 1 PDT} - {3560749200 -28800 0 PST} - {3572244000 -25200 1 PDT} - {3592803600 -28800 0 PST} - {3603693600 -25200 1 PDT} - {3624253200 -28800 0 PST} - {3635143200 -25200 1 PDT} - {3655702800 -28800 0 PST} - {3666592800 -25200 1 PDT} - {3687152400 -28800 0 PST} - {3698042400 -25200 1 PDT} - {3718602000 -28800 0 PST} - {3730096800 -25200 1 PDT} - {3750656400 -28800 0 PST} - {3761546400 -25200 1 PDT} - {3782106000 -28800 0 PST} - {3792996000 -25200 1 PDT} - {3813555600 -28800 0 PST} - {3824445600 -25200 1 PDT} - {3845005200 -28800 0 PST} - {3855895200 -25200 1 PDT} - {3876454800 -28800 0 PST} - {3887344800 -25200 1 PDT} - {3907904400 -28800 0 PST} - {3919399200 -25200 1 PDT} - {3939958800 -28800 0 PST} - {3950848800 -25200 1 PDT} - {3971408400 -28800 0 PST} - {3982298400 -25200 1 PDT} - {4002858000 -28800 0 PST} - {4013748000 -25200 1 PDT} - {4034307600 -28800 0 PST} - {4045197600 -25200 1 PDT} - {4065757200 -28800 0 PST} - {4076647200 -25200 1 PDT} - {4097206800 -28800 0 PST} + {1604217600 -25200 0 MST} } Index: library/tzdata/America/Detroit ================================================================== --- library/tzdata/America/Detroit +++ library/tzdata/America/Detroit @@ -9,10 +9,15 @@ {-769395600 -14400 1 EPT} {-765396000 -18000 0 EST} {-757364400 -18000 0 EST} {-684349200 -14400 1 EDT} {-671047200 -18000 0 EST} + {-80506740 -14400 0 EDT} + {-68666400 -18000 0 EST} + {-52938000 -14400 1 EDT} + {-37216800 -18000 0 EST} + {-31518000 -18000 0 EST} {94712400 -18000 0 EST} {104914800 -14400 1 EDT} {120636000 -18000 0 EST} {126687600 -14400 1 EDT} {152085600 -18000 0 EST} Index: library/tzdata/America/Edmonton ================================================================== --- library/tzdata/America/Edmonton +++ library/tzdata/America/Edmonton @@ -18,14 +18,10 @@ {-880210800 -21600 1 MWT} {-769395600 -21600 1 MPT} {-765388800 -25200 0 MST} {-715791600 -21600 1 MDT} {-702489600 -25200 0 MST} - {-84380400 -21600 1 MDT} - {-68659200 -25200 0 MST} - {-21481200 -21600 1 MDT} - {-5760000 -25200 0 MST} {73472400 -21600 1 MDT} {89193600 -25200 0 MST} {104922000 -21600 1 MDT} {120643200 -25200 0 MST} {136371600 -21600 1 MDT} Index: library/tzdata/America/Godthab ================================================================== --- library/tzdata/America/Godthab +++ library/tzdata/America/Godthab @@ -1,246 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/Godthab) { - {-9223372036854775808 -12416 0 LMT} - {-1686083584 -10800 0 -03} - {323845200 -7200 0 -02} - {338950800 -10800 0 -03} - {354675600 -7200 1 -02} - {370400400 -10800 0 -03} - {386125200 -7200 1 -02} - {401850000 -10800 0 -03} - {417574800 -7200 1 -02} - {433299600 -10800 0 -03} - {449024400 -7200 1 -02} - {465354000 -10800 0 -03} - {481078800 -7200 1 -02} - {496803600 -10800 0 -03} - {512528400 -7200 1 -02} - {528253200 -10800 0 -03} - {543978000 -7200 1 -02} - {559702800 -10800 0 -03} - {575427600 -7200 1 -02} - {591152400 -10800 0 -03} - {606877200 -7200 1 -02} - {622602000 -10800 0 -03} - {638326800 -7200 1 -02} - {654656400 -10800 0 -03} - {670381200 -7200 1 -02} - {686106000 -10800 0 -03} - {701830800 -7200 1 -02} - {717555600 -10800 0 -03} - {733280400 -7200 1 -02} - {749005200 -10800 0 -03} - {764730000 -7200 1 -02} - {780454800 -10800 0 -03} - {796179600 -7200 1 -02} - {811904400 -10800 0 -03} - {828234000 -7200 1 -02} - {846378000 -10800 0 -03} - {859683600 -7200 1 -02} - {877827600 -10800 0 -03} - {891133200 -7200 1 -02} - {909277200 -10800 0 -03} - {922582800 -7200 1 -02} - {941331600 -10800 0 -03} - {954032400 -7200 1 -02} - {972781200 -10800 0 -03} - {985482000 -7200 1 -02} - {1004230800 -10800 0 -03} - {1017536400 -7200 1 -02} - {1035680400 -10800 0 -03} - {1048986000 -7200 1 -02} - {1067130000 -10800 0 -03} - {1080435600 -7200 1 -02} - {1099184400 -10800 0 -03} - {1111885200 -7200 1 -02} - {1130634000 -10800 0 -03} - {1143334800 -7200 1 -02} - {1162083600 -10800 0 -03} - {1174784400 -7200 1 -02} - {1193533200 -10800 0 -03} - {1206838800 -7200 1 -02} - {1224982800 -10800 0 -03} - {1238288400 -7200 1 -02} - {1256432400 -10800 0 -03} - {1269738000 -7200 1 -02} - {1288486800 -10800 0 -03} - {1301187600 -7200 1 -02} - {1319936400 -10800 0 -03} - {1332637200 -7200 1 -02} - {1351386000 -10800 0 -03} - {1364691600 -7200 1 -02} - {1382835600 -10800 0 -03} - {1396141200 -7200 1 -02} - {1414285200 -10800 0 -03} - {1427590800 -7200 1 -02} - {1445734800 -10800 0 -03} - {1459040400 -7200 1 -02} - {1477789200 -10800 0 -03} - {1490490000 -7200 1 -02} - {1509238800 -10800 0 -03} - {1521939600 -7200 1 -02} - {1540688400 -10800 0 -03} - {1553994000 -7200 1 -02} - {1572138000 -10800 0 -03} - {1585443600 -7200 1 -02} - {1603587600 -10800 0 -03} - {1616893200 -7200 1 -02} - {1635642000 -10800 0 -03} - {1648342800 -7200 1 -02} - {1667091600 -10800 0 -03} - {1679792400 -7200 1 -02} - {1698541200 -10800 0 -03} - {1711846800 -7200 1 -02} - {1729990800 -10800 0 -03} - {1743296400 -7200 1 -02} - {1761440400 -10800 0 -03} - {1774746000 -7200 1 -02} - {1792890000 -10800 0 -03} - {1806195600 -7200 1 -02} - {1824944400 -10800 0 -03} - {1837645200 -7200 1 -02} - {1856394000 -10800 0 -03} - {1869094800 -7200 1 -02} - {1887843600 -10800 0 -03} - {1901149200 -7200 1 -02} - {1919293200 -10800 0 -03} - {1932598800 -7200 1 -02} - {1950742800 -10800 0 -03} - {1964048400 -7200 1 -02} - {1982797200 -10800 0 -03} - {1995498000 -7200 1 -02} - {2014246800 -10800 0 -03} - {2026947600 -7200 1 -02} - {2045696400 -10800 0 -03} - {2058397200 -7200 1 -02} - {2077146000 -10800 0 -03} - {2090451600 -7200 1 -02} - {2108595600 -10800 0 -03} - {2121901200 -7200 1 -02} - {2140045200 -10800 0 -03} - {2153350800 -7200 1 -02} - {2172099600 -10800 0 -03} - {2184800400 -7200 1 -02} - {2203549200 -10800 0 -03} - {2216250000 -7200 1 -02} - {2234998800 -10800 0 -03} - {2248304400 -7200 1 -02} - {2266448400 -10800 0 -03} - {2279754000 -7200 1 -02} - {2297898000 -10800 0 -03} - {2311203600 -7200 1 -02} - {2329347600 -10800 0 -03} - {2342653200 -7200 1 -02} - {2361402000 -10800 0 -03} - {2374102800 -7200 1 -02} - {2392851600 -10800 0 -03} - {2405552400 -7200 1 -02} - {2424301200 -10800 0 -03} - {2437606800 -7200 1 -02} - {2455750800 -10800 0 -03} - {2469056400 -7200 1 -02} - {2487200400 -10800 0 -03} - {2500506000 -7200 1 -02} - {2519254800 -10800 0 -03} - {2531955600 -7200 1 -02} - {2550704400 -10800 0 -03} - {2563405200 -7200 1 -02} - {2582154000 -10800 0 -03} - {2595459600 -7200 1 -02} - {2613603600 -10800 0 -03} - {2626909200 -7200 1 -02} - {2645053200 -10800 0 -03} - {2658358800 -7200 1 -02} - {2676502800 -10800 0 -03} - {2689808400 -7200 1 -02} - {2708557200 -10800 0 -03} - {2721258000 -7200 1 -02} - {2740006800 -10800 0 -03} - {2752707600 -7200 1 -02} - {2771456400 -10800 0 -03} - {2784762000 -7200 1 -02} - {2802906000 -10800 0 -03} - {2816211600 -7200 1 -02} - {2834355600 -10800 0 -03} - {2847661200 -7200 1 -02} - {2866410000 -10800 0 -03} - {2879110800 -7200 1 -02} - {2897859600 -10800 0 -03} - {2910560400 -7200 1 -02} - {2929309200 -10800 0 -03} - {2942010000 -7200 1 -02} - {2960758800 -10800 0 -03} - {2974064400 -7200 1 -02} - {2992208400 -10800 0 -03} - {3005514000 -7200 1 -02} - {3023658000 -10800 0 -03} - {3036963600 -7200 1 -02} - {3055712400 -10800 0 -03} - {3068413200 -7200 1 -02} - {3087162000 -10800 0 -03} - {3099862800 -7200 1 -02} - {3118611600 -10800 0 -03} - {3131917200 -7200 1 -02} - {3150061200 -10800 0 -03} - {3163366800 -7200 1 -02} - {3181510800 -10800 0 -03} - {3194816400 -7200 1 -02} - {3212960400 -10800 0 -03} - {3226266000 -7200 1 -02} - {3245014800 -10800 0 -03} - {3257715600 -7200 1 -02} - {3276464400 -10800 0 -03} - {3289165200 -7200 1 -02} - {3307914000 -10800 0 -03} - {3321219600 -7200 1 -02} - {3339363600 -10800 0 -03} - {3352669200 -7200 1 -02} - {3370813200 -10800 0 -03} - {3384118800 -7200 1 -02} - {3402867600 -10800 0 -03} - {3415568400 -7200 1 -02} - {3434317200 -10800 0 -03} - {3447018000 -7200 1 -02} - {3465766800 -10800 0 -03} - {3479072400 -7200 1 -02} - {3497216400 -10800 0 -03} - {3510522000 -7200 1 -02} - {3528666000 -10800 0 -03} - {3541971600 -7200 1 -02} - {3560115600 -10800 0 -03} - {3573421200 -7200 1 -02} - {3592170000 -10800 0 -03} - {3604870800 -7200 1 -02} - {3623619600 -10800 0 -03} - {3636320400 -7200 1 -02} - {3655069200 -10800 0 -03} - {3668374800 -7200 1 -02} - {3686518800 -10800 0 -03} - {3699824400 -7200 1 -02} - {3717968400 -10800 0 -03} - {3731274000 -7200 1 -02} - {3750022800 -10800 0 -03} - {3762723600 -7200 1 -02} - {3781472400 -10800 0 -03} - {3794173200 -7200 1 -02} - {3812922000 -10800 0 -03} - {3825622800 -7200 1 -02} - {3844371600 -10800 0 -03} - {3857677200 -7200 1 -02} - {3875821200 -10800 0 -03} - {3889126800 -7200 1 -02} - {3907270800 -10800 0 -03} - {3920576400 -7200 1 -02} - {3939325200 -10800 0 -03} - {3952026000 -7200 1 -02} - {3970774800 -10800 0 -03} - {3983475600 -7200 1 -02} - {4002224400 -10800 0 -03} - {4015530000 -7200 1 -02} - {4033674000 -10800 0 -03} - {4046979600 -7200 1 -02} - {4065123600 -10800 0 -03} - {4078429200 -7200 1 -02} - {4096573200 -10800 0 -03} -} +if {![info exists TZData(America/Nuuk)]} { + LoadTimeZoneFile America/Nuuk +} +set TZData(:America/Godthab) $TZData(:America/Nuuk) Index: library/tzdata/America/Indiana/Tell_City ================================================================== --- library/tzdata/America/Indiana/Tell_City +++ library/tzdata/America/Indiana/Tell_City @@ -9,16 +9,10 @@ {-1583686800 -21600 0 CST} {-880214400 -18000 1 CWT} {-769395600 -18000 1 CPT} {-765392400 -21600 0 CST} {-757360800 -21600 0 CST} - {-747244800 -18000 1 CDT} - {-733942800 -21600 0 CST} - {-526492800 -18000 1 CDT} - {-513190800 -21600 0 CST} - {-495043200 -18000 1 CDT} - {-481741200 -21600 0 CST} {-462996000 -18000 1 CDT} {-450291600 -21600 0 CST} {-431539200 -18000 1 CDT} {-418237200 -21600 0 CST} {-400089600 -18000 1 CDT} @@ -26,20 +20,22 @@ {-368640000 -18000 1 CDT} {-355338000 -21600 0 CST} {-337190400 -18000 1 CDT} {-323888400 -21600 0 CST} {-305740800 -18000 1 CDT} - {-289414800 -21600 0 CST} + {-292438800 -21600 0 CST} {-273686400 -18000 1 CDT} - {-260989200 -21600 0 CST} + {-257965200 -21600 0 CST} {-242236800 -18000 1 CDT} {-226515600 -21600 0 CST} {-210787200 -18000 1 CDT} {-195066000 -21600 0 CST} {-179337600 -18000 0 EST} - {-31518000 -18000 0 EST} - {-21488400 -14400 1 EDT} + {-68662800 -21600 0 CST} + {-52934400 -18000 1 CDT} + {-37213200 -21600 0 CST} + {-21484800 -14400 0 EDT} {-5767200 -18000 0 EST} {9961200 -14400 1 EDT} {25682400 -18000 0 EST} {31554000 -18000 0 EST} {1143961200 -21600 0 CST} Index: library/tzdata/America/Kentucky/Louisville ================================================================== --- library/tzdata/America/Kentucky/Louisville +++ library/tzdata/America/Kentucky/Louisville @@ -15,16 +15,13 @@ {-883591200 -21600 0 CST} {-880214400 -18000 1 CWT} {-769395600 -18000 1 CPT} {-765392400 -21600 0 CST} {-757360800 -21600 0 CST} - {-747244800 -18000 1 CDT} + {-747251940 -18000 1 CDT} {-744224400 -21600 0 CST} - {-715795200 -18000 1 CDT} - {-684349200 -18000 1 CDT} - {-652899600 -18000 1 CDT} - {-620845200 -18000 1 CDT} + {-620841600 -18000 1 CDT} {-608144400 -21600 0 CST} {-589392000 -18000 1 CDT} {-576090000 -21600 0 CST} {-557942400 -18000 1 CDT} {-544640400 -21600 0 CST} @@ -43,11 +40,11 @@ {-337190400 -18000 1 CDT} {-321469200 -21600 0 CST} {-305740800 -18000 1 CDT} {-289414800 -21600 0 CST} {-273686400 -18000 1 CDT} - {-266432400 -18000 0 EST} + {-266428800 -18000 0 EST} {-63140400 -18000 0 EST} {-52938000 -14400 1 EDT} {-37216800 -18000 0 EST} {-21488400 -14400 1 EDT} {-5767200 -18000 0 EST} ADDED library/tzdata/America/Nuuk Index: library/tzdata/America/Nuuk ================================================================== --- /dev/null +++ library/tzdata/America/Nuuk @@ -0,0 +1,246 @@ +# created by tools/tclZIC.tcl - do not edit + +set TZData(:America/Nuuk) { + {-9223372036854775808 -12416 0 LMT} + {-1686083584 -10800 0 -03} + {323845200 -7200 0 -02} + {338950800 -10800 0 -03} + {354675600 -7200 1 -02} + {370400400 -10800 0 -03} + {386125200 -7200 1 -02} + {401850000 -10800 0 -03} + {417574800 -7200 1 -02} + {433299600 -10800 0 -03} + {449024400 -7200 1 -02} + {465354000 -10800 0 -03} + {481078800 -7200 1 -02} + {496803600 -10800 0 -03} + {512528400 -7200 1 -02} + {528253200 -10800 0 -03} + {543978000 -7200 1 -02} + {559702800 -10800 0 -03} + {575427600 -7200 1 -02} + {591152400 -10800 0 -03} + {606877200 -7200 1 -02} + {622602000 -10800 0 -03} + {638326800 -7200 1 -02} + {654656400 -10800 0 -03} + {670381200 -7200 1 -02} + {686106000 -10800 0 -03} + {701830800 -7200 1 -02} + {717555600 -10800 0 -03} + {733280400 -7200 1 -02} + {749005200 -10800 0 -03} + {764730000 -7200 1 -02} + {780454800 -10800 0 -03} + {796179600 -7200 1 -02} + {811904400 -10800 0 -03} + {828234000 -7200 1 -02} + {846378000 -10800 0 -03} + {859683600 -7200 1 -02} + {877827600 -10800 0 -03} + {891133200 -7200 1 -02} + {909277200 -10800 0 -03} + {922582800 -7200 1 -02} + {941331600 -10800 0 -03} + {954032400 -7200 1 -02} + {972781200 -10800 0 -03} + {985482000 -7200 1 -02} + {1004230800 -10800 0 -03} + {1017536400 -7200 1 -02} + {1035680400 -10800 0 -03} + {1048986000 -7200 1 -02} + {1067130000 -10800 0 -03} + {1080435600 -7200 1 -02} + {1099184400 -10800 0 -03} + {1111885200 -7200 1 -02} + {1130634000 -10800 0 -03} + {1143334800 -7200 1 -02} + {1162083600 -10800 0 -03} + {1174784400 -7200 1 -02} + {1193533200 -10800 0 -03} + {1206838800 -7200 1 -02} + {1224982800 -10800 0 -03} + {1238288400 -7200 1 -02} + {1256432400 -10800 0 -03} + {1269738000 -7200 1 -02} + {1288486800 -10800 0 -03} + {1301187600 -7200 1 -02} + {1319936400 -10800 0 -03} + {1332637200 -7200 1 -02} + {1351386000 -10800 0 -03} + {1364691600 -7200 1 -02} + {1382835600 -10800 0 -03} + {1396141200 -7200 1 -02} + {1414285200 -10800 0 -03} + {1427590800 -7200 1 -02} + {1445734800 -10800 0 -03} + {1459040400 -7200 1 -02} + {1477789200 -10800 0 -03} + {1490490000 -7200 1 -02} + {1509238800 -10800 0 -03} + {1521939600 -7200 1 -02} + {1540688400 -10800 0 -03} + {1553994000 -7200 1 -02} + {1572138000 -10800 0 -03} + {1585443600 -7200 1 -02} + {1603587600 -10800 0 -03} + {1616893200 -7200 1 -02} + {1635642000 -10800 0 -03} + {1648342800 -7200 1 -02} + {1667091600 -10800 0 -03} + {1679792400 -7200 1 -02} + {1698541200 -10800 0 -03} + {1711846800 -7200 1 -02} + {1729990800 -10800 0 -03} + {1743296400 -7200 1 -02} + {1761440400 -10800 0 -03} + {1774746000 -7200 1 -02} + {1792890000 -10800 0 -03} + {1806195600 -7200 1 -02} + {1824944400 -10800 0 -03} + {1837645200 -7200 1 -02} + {1856394000 -10800 0 -03} + {1869094800 -7200 1 -02} + {1887843600 -10800 0 -03} + {1901149200 -7200 1 -02} + {1919293200 -10800 0 -03} + {1932598800 -7200 1 -02} + {1950742800 -10800 0 -03} + {1964048400 -7200 1 -02} + {1982797200 -10800 0 -03} + {1995498000 -7200 1 -02} + {2014246800 -10800 0 -03} + {2026947600 -7200 1 -02} + {2045696400 -10800 0 -03} + {2058397200 -7200 1 -02} + {2077146000 -10800 0 -03} + {2090451600 -7200 1 -02} + {2108595600 -10800 0 -03} + {2121901200 -7200 1 -02} + {2140045200 -10800 0 -03} + {2153350800 -7200 1 -02} + {2172099600 -10800 0 -03} + {2184800400 -7200 1 -02} + {2203549200 -10800 0 -03} + {2216250000 -7200 1 -02} + {2234998800 -10800 0 -03} + {2248304400 -7200 1 -02} + {2266448400 -10800 0 -03} + {2279754000 -7200 1 -02} + {2297898000 -10800 0 -03} + {2311203600 -7200 1 -02} + {2329347600 -10800 0 -03} + {2342653200 -7200 1 -02} + {2361402000 -10800 0 -03} + {2374102800 -7200 1 -02} + {2392851600 -10800 0 -03} + {2405552400 -7200 1 -02} + {2424301200 -10800 0 -03} + {2437606800 -7200 1 -02} + {2455750800 -10800 0 -03} + {2469056400 -7200 1 -02} + {2487200400 -10800 0 -03} + {2500506000 -7200 1 -02} + {2519254800 -10800 0 -03} + {2531955600 -7200 1 -02} + {2550704400 -10800 0 -03} + {2563405200 -7200 1 -02} + {2582154000 -10800 0 -03} + {2595459600 -7200 1 -02} + {2613603600 -10800 0 -03} + {2626909200 -7200 1 -02} + {2645053200 -10800 0 -03} + {2658358800 -7200 1 -02} + {2676502800 -10800 0 -03} + {2689808400 -7200 1 -02} + {2708557200 -10800 0 -03} + {2721258000 -7200 1 -02} + {2740006800 -10800 0 -03} + {2752707600 -7200 1 -02} + {2771456400 -10800 0 -03} + {2784762000 -7200 1 -02} + {2802906000 -10800 0 -03} + {2816211600 -7200 1 -02} + {2834355600 -10800 0 -03} + {2847661200 -7200 1 -02} + {2866410000 -10800 0 -03} + {2879110800 -7200 1 -02} + {2897859600 -10800 0 -03} + {2910560400 -7200 1 -02} + {2929309200 -10800 0 -03} + {2942010000 -7200 1 -02} + {2960758800 -10800 0 -03} + {2974064400 -7200 1 -02} + {2992208400 -10800 0 -03} + {3005514000 -7200 1 -02} + {3023658000 -10800 0 -03} + {3036963600 -7200 1 -02} + {3055712400 -10800 0 -03} + {3068413200 -7200 1 -02} + {3087162000 -10800 0 -03} + {3099862800 -7200 1 -02} + {3118611600 -10800 0 -03} + {3131917200 -7200 1 -02} + {3150061200 -10800 0 -03} + {3163366800 -7200 1 -02} + {3181510800 -10800 0 -03} + {3194816400 -7200 1 -02} + {3212960400 -10800 0 -03} + {3226266000 -7200 1 -02} + {3245014800 -10800 0 -03} + {3257715600 -7200 1 -02} + {3276464400 -10800 0 -03} + {3289165200 -7200 1 -02} + {3307914000 -10800 0 -03} + {3321219600 -7200 1 -02} + {3339363600 -10800 0 -03} + {3352669200 -7200 1 -02} + {3370813200 -10800 0 -03} + {3384118800 -7200 1 -02} + {3402867600 -10800 0 -03} + {3415568400 -7200 1 -02} + {3434317200 -10800 0 -03} + {3447018000 -7200 1 -02} + {3465766800 -10800 0 -03} + {3479072400 -7200 1 -02} + {3497216400 -10800 0 -03} + {3510522000 -7200 1 -02} + {3528666000 -10800 0 -03} + {3541971600 -7200 1 -02} + {3560115600 -10800 0 -03} + {3573421200 -7200 1 -02} + {3592170000 -10800 0 -03} + {3604870800 -7200 1 -02} + {3623619600 -10800 0 -03} + {3636320400 -7200 1 -02} + {3655069200 -10800 0 -03} + {3668374800 -7200 1 -02} + {3686518800 -10800 0 -03} + {3699824400 -7200 1 -02} + {3717968400 -10800 0 -03} + {3731274000 -7200 1 -02} + {3750022800 -10800 0 -03} + {3762723600 -7200 1 -02} + {3781472400 -10800 0 -03} + {3794173200 -7200 1 -02} + {3812922000 -10800 0 -03} + {3825622800 -7200 1 -02} + {3844371600 -10800 0 -03} + {3857677200 -7200 1 -02} + {3875821200 -10800 0 -03} + {3889126800 -7200 1 -02} + {3907270800 -10800 0 -03} + {3920576400 -7200 1 -02} + {3939325200 -10800 0 -03} + {3952026000 -7200 1 -02} + {3970774800 -10800 0 -03} + {3983475600 -7200 1 -02} + {4002224400 -10800 0 -03} + {4015530000 -7200 1 -02} + {4033674000 -10800 0 -03} + {4046979600 -7200 1 -02} + {4065123600 -10800 0 -03} + {4078429200 -7200 1 -02} + {4096573200 -10800 0 -03} +} Index: library/tzdata/America/Sao_Paulo ================================================================== --- library/tzdata/America/Sao_Paulo +++ library/tzdata/America/Sao_Paulo @@ -92,167 +92,6 @@ {1487469600 -10800 0 -03} {1508036400 -7200 1 -03} {1518919200 -10800 0 -03} {1541300400 -7200 1 -03} {1550368800 -10800 0 -03} - {1572750000 -7200 1 -03} - {1581818400 -10800 0 -03} - {1604199600 -7200 1 -03} - {1613872800 -10800 0 -03} - {1636254000 -7200 1 -03} - {1645322400 -10800 0 -03} - {1667703600 -7200 1 -03} - {1677376800 -10800 0 -03} - {1699153200 -7200 1 -03} - {1708221600 -10800 0 -03} - {1730602800 -7200 1 -03} - {1739671200 -10800 0 -03} - {1762052400 -7200 1 -03} - {1771725600 -10800 0 -03} - {1793502000 -7200 1 -03} - {1803175200 -10800 0 -03} - {1825556400 -7200 1 -03} - {1834624800 -10800 0 -03} - {1857006000 -7200 1 -03} - {1866074400 -10800 0 -03} - {1888455600 -7200 1 -03} - {1897524000 -10800 0 -03} - {1919905200 -7200 1 -03} - {1928973600 -10800 0 -03} - {1951354800 -7200 1 -03} - {1960423200 -10800 0 -03} - {1983409200 -7200 1 -03} - {1992477600 -10800 0 -03} - {2014858800 -7200 1 -03} - {2024532000 -10800 0 -03} - {2046308400 -7200 1 -03} - {2055376800 -10800 0 -03} - {2077758000 -7200 1 -03} - {2086826400 -10800 0 -03} - {2109207600 -7200 1 -03} - {2118880800 -10800 0 -03} - {2140657200 -7200 1 -03} - {2150330400 -10800 0 -03} - {2172711600 -7200 1 -03} - {2181780000 -10800 0 -03} - {2204161200 -7200 1 -03} - {2213229600 -10800 0 -03} - {2235610800 -7200 1 -03} - {2244679200 -10800 0 -03} - {2267060400 -7200 1 -03} - {2276128800 -10800 0 -03} - {2298510000 -7200 1 -03} - {2307578400 -10800 0 -03} - {2329959600 -7200 1 -03} - {2339632800 -10800 0 -03} - {2362014000 -7200 1 -03} - {2371082400 -10800 0 -03} - {2393463600 -7200 1 -03} - {2402532000 -10800 0 -03} - {2424913200 -7200 1 -03} - {2433981600 -10800 0 -03} - {2456362800 -7200 1 -03} - {2465431200 -10800 0 -03} - {2487812400 -7200 1 -03} - {2497485600 -10800 0 -03} - {2519866800 -7200 1 -03} - {2528935200 -10800 0 -03} - {2551316400 -7200 1 -03} - {2560384800 -10800 0 -03} - {2582766000 -7200 1 -03} - {2591834400 -10800 0 -03} - {2614215600 -7200 1 -03} - {2623284000 -10800 0 -03} - {2645665200 -7200 1 -03} - {2654733600 -10800 0 -03} - {2677114800 -7200 1 -03} - {2686788000 -10800 0 -03} - {2709169200 -7200 1 -03} - {2718237600 -10800 0 -03} - {2740618800 -7200 1 -03} - {2749687200 -10800 0 -03} - {2772068400 -7200 1 -03} - {2781136800 -10800 0 -03} - {2803518000 -7200 1 -03} - {2812586400 -10800 0 -03} - {2834967600 -7200 1 -03} - {2844036000 -10800 0 -03} - {2867022000 -7200 1 -03} - {2876090400 -10800 0 -03} - {2898471600 -7200 1 -03} - {2907540000 -10800 0 -03} - {2929921200 -7200 1 -03} - {2938989600 -10800 0 -03} - {2961370800 -7200 1 -03} - {2970439200 -10800 0 -03} - {2992820400 -7200 1 -03} - {3001888800 -10800 0 -03} - {3024270000 -7200 1 -03} - {3033943200 -10800 0 -03} - {3056324400 -7200 1 -03} - {3065392800 -10800 0 -03} - {3087774000 -7200 1 -03} - {3096842400 -10800 0 -03} - {3119223600 -7200 1 -03} - {3128292000 -10800 0 -03} - {3150673200 -7200 1 -03} - {3159741600 -10800 0 -03} - {3182122800 -7200 1 -03} - {3191191200 -10800 0 -03} - {3213572400 -7200 1 -03} - {3223245600 -10800 0 -03} - {3245626800 -7200 1 -03} - {3254695200 -10800 0 -03} - {3277076400 -7200 1 -03} - {3286144800 -10800 0 -03} - {3308526000 -7200 1 -03} - {3317594400 -10800 0 -03} - {3339975600 -7200 1 -03} - {3349044000 -10800 0 -03} - {3371425200 -7200 1 -03} - {3381098400 -10800 0 -03} - {3403479600 -7200 1 -03} - {3412548000 -10800 0 -03} - {3434929200 -7200 1 -03} - {3443997600 -10800 0 -03} - {3466378800 -7200 1 -03} - {3475447200 -10800 0 -03} - {3497828400 -7200 1 -03} - {3506896800 -10800 0 -03} - {3529278000 -7200 1 -03} - {3538346400 -10800 0 -03} - {3560727600 -7200 1 -03} - {3570400800 -10800 0 -03} - {3592782000 -7200 1 -03} - {3601850400 -10800 0 -03} - {3624231600 -7200 1 -03} - {3633300000 -10800 0 -03} - {3655681200 -7200 1 -03} - {3664749600 -10800 0 -03} - {3687130800 -7200 1 -03} - {3696199200 -10800 0 -03} - {3718580400 -7200 1 -03} - {3727648800 -10800 0 -03} - {3750634800 -7200 1 -03} - {3759703200 -10800 0 -03} - {3782084400 -7200 1 -03} - {3791152800 -10800 0 -03} - {3813534000 -7200 1 -03} - {3822602400 -10800 0 -03} - {3844983600 -7200 1 -03} - {3854052000 -10800 0 -03} - {3876433200 -7200 1 -03} - {3885501600 -10800 0 -03} - {3907882800 -7200 1 -03} - {3917556000 -10800 0 -03} - {3939937200 -7200 1 -03} - {3949005600 -10800 0 -03} - {3971386800 -7200 1 -03} - {3980455200 -10800 0 -03} - {4002836400 -7200 1 -03} - {4011904800 -10800 0 -03} - {4034286000 -7200 1 -03} - {4043354400 -10800 0 -03} - {4065735600 -7200 1 -03} - {4074804000 -10800 0 -03} - {4097185200 -7200 1 -03} } Index: library/tzdata/America/Vancouver ================================================================== --- library/tzdata/America/Vancouver +++ library/tzdata/America/Vancouver @@ -7,11 +7,11 @@ {-1615129200 -28800 0 PST} {-880207200 -25200 1 PWT} {-769395600 -25200 1 PPT} {-765385200 -28800 0 PST} {-747237600 -25200 1 PDT} - {-732726000 -28800 0 PST} + {-733935600 -28800 0 PST} {-715788000 -25200 1 PDT} {-702486000 -28800 0 PST} {-684338400 -25200 1 PDT} {-671036400 -28800 0 PST} {-652888800 -25200 1 PDT} Index: library/tzdata/America/Whitehorse ================================================================== --- library/tzdata/America/Whitehorse +++ library/tzdata/America/Whitehorse @@ -92,165 +92,7 @@ {1520762400 -25200 1 PDT} {1541322000 -28800 0 PST} {1552212000 -25200 1 PDT} {1572771600 -28800 0 PST} {1583661600 -25200 1 PDT} - {1604221200 -28800 0 PST} - {1615716000 -25200 1 PDT} - {1636275600 -28800 0 PST} - {1647165600 -25200 1 PDT} - {1667725200 -28800 0 PST} - {1678615200 -25200 1 PDT} - {1699174800 -28800 0 PST} - {1710064800 -25200 1 PDT} - {1730624400 -28800 0 PST} - {1741514400 -25200 1 PDT} - {1762074000 -28800 0 PST} - {1772964000 -25200 1 PDT} - {1793523600 -28800 0 PST} - {1805018400 -25200 1 PDT} - {1825578000 -28800 0 PST} - {1836468000 -25200 1 PDT} - {1857027600 -28800 0 PST} - {1867917600 -25200 1 PDT} - {1888477200 -28800 0 PST} - {1899367200 -25200 1 PDT} - {1919926800 -28800 0 PST} - {1930816800 -25200 1 PDT} - {1951376400 -28800 0 PST} - {1962871200 -25200 1 PDT} - {1983430800 -28800 0 PST} - {1994320800 -25200 1 PDT} - {2014880400 -28800 0 PST} - {2025770400 -25200 1 PDT} - {2046330000 -28800 0 PST} - {2057220000 -25200 1 PDT} - {2077779600 -28800 0 PST} - {2088669600 -25200 1 PDT} - {2109229200 -28800 0 PST} - {2120119200 -25200 1 PDT} - {2140678800 -28800 0 PST} - {2152173600 -25200 1 PDT} - {2172733200 -28800 0 PST} - {2183623200 -25200 1 PDT} - {2204182800 -28800 0 PST} - {2215072800 -25200 1 PDT} - {2235632400 -28800 0 PST} - {2246522400 -25200 1 PDT} - {2267082000 -28800 0 PST} - {2277972000 -25200 1 PDT} - {2298531600 -28800 0 PST} - {2309421600 -25200 1 PDT} - {2329981200 -28800 0 PST} - {2341476000 -25200 1 PDT} - {2362035600 -28800 0 PST} - {2372925600 -25200 1 PDT} - {2393485200 -28800 0 PST} - {2404375200 -25200 1 PDT} - {2424934800 -28800 0 PST} - {2435824800 -25200 1 PDT} - {2456384400 -28800 0 PST} - {2467274400 -25200 1 PDT} - {2487834000 -28800 0 PST} - {2499328800 -25200 1 PDT} - {2519888400 -28800 0 PST} - {2530778400 -25200 1 PDT} - {2551338000 -28800 0 PST} - {2562228000 -25200 1 PDT} - {2582787600 -28800 0 PST} - {2593677600 -25200 1 PDT} - {2614237200 -28800 0 PST} - {2625127200 -25200 1 PDT} - {2645686800 -28800 0 PST} - {2656576800 -25200 1 PDT} - {2677136400 -28800 0 PST} - {2688631200 -25200 1 PDT} - {2709190800 -28800 0 PST} - {2720080800 -25200 1 PDT} - {2740640400 -28800 0 PST} - {2751530400 -25200 1 PDT} - {2772090000 -28800 0 PST} - {2782980000 -25200 1 PDT} - {2803539600 -28800 0 PST} - {2814429600 -25200 1 PDT} - {2834989200 -28800 0 PST} - {2846484000 -25200 1 PDT} - {2867043600 -28800 0 PST} - {2877933600 -25200 1 PDT} - {2898493200 -28800 0 PST} - {2909383200 -25200 1 PDT} - {2929942800 -28800 0 PST} - {2940832800 -25200 1 PDT} - {2961392400 -28800 0 PST} - {2972282400 -25200 1 PDT} - {2992842000 -28800 0 PST} - {3003732000 -25200 1 PDT} - {3024291600 -28800 0 PST} - {3035786400 -25200 1 PDT} - {3056346000 -28800 0 PST} - {3067236000 -25200 1 PDT} - {3087795600 -28800 0 PST} - {3098685600 -25200 1 PDT} - {3119245200 -28800 0 PST} - {3130135200 -25200 1 PDT} - {3150694800 -28800 0 PST} - {3161584800 -25200 1 PDT} - {3182144400 -28800 0 PST} - {3193034400 -25200 1 PDT} - {3213594000 -28800 0 PST} - {3225088800 -25200 1 PDT} - {3245648400 -28800 0 PST} - {3256538400 -25200 1 PDT} - {3277098000 -28800 0 PST} - {3287988000 -25200 1 PDT} - {3308547600 -28800 0 PST} - {3319437600 -25200 1 PDT} - {3339997200 -28800 0 PST} - {3350887200 -25200 1 PDT} - {3371446800 -28800 0 PST} - {3382941600 -25200 1 PDT} - {3403501200 -28800 0 PST} - {3414391200 -25200 1 PDT} - {3434950800 -28800 0 PST} - {3445840800 -25200 1 PDT} - {3466400400 -28800 0 PST} - {3477290400 -25200 1 PDT} - {3497850000 -28800 0 PST} - {3508740000 -25200 1 PDT} - {3529299600 -28800 0 PST} - {3540189600 -25200 1 PDT} - {3560749200 -28800 0 PST} - {3572244000 -25200 1 PDT} - {3592803600 -28800 0 PST} - {3603693600 -25200 1 PDT} - {3624253200 -28800 0 PST} - {3635143200 -25200 1 PDT} - {3655702800 -28800 0 PST} - {3666592800 -25200 1 PDT} - {3687152400 -28800 0 PST} - {3698042400 -25200 1 PDT} - {3718602000 -28800 0 PST} - {3730096800 -25200 1 PDT} - {3750656400 -28800 0 PST} - {3761546400 -25200 1 PDT} - {3782106000 -28800 0 PST} - {3792996000 -25200 1 PDT} - {3813555600 -28800 0 PST} - {3824445600 -25200 1 PDT} - {3845005200 -28800 0 PST} - {3855895200 -25200 1 PDT} - {3876454800 -28800 0 PST} - {3887344800 -25200 1 PDT} - {3907904400 -28800 0 PST} - {3919399200 -25200 1 PDT} - {3939958800 -28800 0 PST} - {3950848800 -25200 1 PDT} - {3971408400 -28800 0 PST} - {3982298400 -25200 1 PDT} - {4002858000 -28800 0 PST} - {4013748000 -25200 1 PDT} - {4034307600 -28800 0 PST} - {4045197600 -25200 1 PDT} - {4065757200 -28800 0 PST} - {4076647200 -25200 1 PDT} - {4097206800 -28800 0 PST} + {1604217600 -25200 0 MST} } Index: library/tzdata/Antarctica/Casey ================================================================== --- library/tzdata/Antarctica/Casey +++ library/tzdata/Antarctica/Casey @@ -7,6 +7,11 @@ {1267714800 28800 0 +08} {1319738400 39600 0 +11} {1329843600 28800 0 +08} {1477065600 39600 0 +11} {1520701200 28800 0 +08} + {1538856000 39600 0 +11} + {1552752000 28800 0 +08} + {1570129200 39600 0 +11} + {1583596800 28800 0 +08} + {1601740860 39600 0 +11} } Index: library/tzdata/Antarctica/Macquarie ================================================================== --- library/tzdata/Antarctica/Macquarie +++ library/tzdata/Antarctica/Macquarie @@ -91,7 +91,186 @@ {1191686400 39600 1 AEDT} {1207411200 36000 0 AEST} {1223136000 39600 1 AEDT} {1238860800 36000 0 AEST} {1254585600 39600 1 AEDT} - {1270310400 39600 0 +11} + {1262264400 39600 1 AEDT} + {1293800400 39600 0 AEST} + {1301760000 36000 0 AEST} + {1317484800 39600 1 AEDT} + {1333209600 36000 0 AEST} + {1349539200 39600 1 AEDT} + {1365264000 36000 0 AEST} + {1380988800 39600 1 AEDT} + {1396713600 36000 0 AEST} + {1412438400 39600 1 AEDT} + {1428163200 36000 0 AEST} + {1443888000 39600 1 AEDT} + {1459612800 36000 0 AEST} + {1475337600 39600 1 AEDT} + {1491062400 36000 0 AEST} + {1506787200 39600 1 AEDT} + {1522512000 36000 0 AEST} + {1538841600 39600 1 AEDT} + {1554566400 36000 0 AEST} + {1570291200 39600 1 AEDT} + {1586016000 36000 0 AEST} + {1601740800 39600 1 AEDT} + {1617465600 36000 0 AEST} + {1633190400 39600 1 AEDT} + {1648915200 36000 0 AEST} + {1664640000 39600 1 AEDT} + {1680364800 36000 0 AEST} + {1696089600 39600 1 AEDT} + {1712419200 36000 0 AEST} + {1728144000 39600 1 AEDT} + {1743868800 36000 0 AEST} + {1759593600 39600 1 AEDT} + {1775318400 36000 0 AEST} + {1791043200 39600 1 AEDT} + {1806768000 36000 0 AEST} + {1822492800 39600 1 AEDT} + {1838217600 36000 0 AEST} + {1853942400 39600 1 AEDT} + {1869667200 36000 0 AEST} + {1885996800 39600 1 AEDT} + {1901721600 36000 0 AEST} + {1917446400 39600 1 AEDT} + {1933171200 36000 0 AEST} + {1948896000 39600 1 AEDT} + {1964620800 36000 0 AEST} + {1980345600 39600 1 AEDT} + {1996070400 36000 0 AEST} + {2011795200 39600 1 AEDT} + {2027520000 36000 0 AEST} + {2043244800 39600 1 AEDT} + {2058969600 36000 0 AEST} + {2075299200 39600 1 AEDT} + {2091024000 36000 0 AEST} + {2106748800 39600 1 AEDT} + {2122473600 36000 0 AEST} + {2138198400 39600 1 AEDT} + {2153923200 36000 0 AEST} + {2169648000 39600 1 AEDT} + {2185372800 36000 0 AEST} + {2201097600 39600 1 AEDT} + {2216822400 36000 0 AEST} + {2233152000 39600 1 AEDT} + {2248876800 36000 0 AEST} + {2264601600 39600 1 AEDT} + {2280326400 36000 0 AEST} + {2296051200 39600 1 AEDT} + {2311776000 36000 0 AEST} + {2327500800 39600 1 AEDT} + {2343225600 36000 0 AEST} + {2358950400 39600 1 AEDT} + {2374675200 36000 0 AEST} + {2390400000 39600 1 AEDT} + {2406124800 36000 0 AEST} + {2422454400 39600 1 AEDT} + {2438179200 36000 0 AEST} + {2453904000 39600 1 AEDT} + {2469628800 36000 0 AEST} + {2485353600 39600 1 AEDT} + {2501078400 36000 0 AEST} + {2516803200 39600 1 AEDT} + {2532528000 36000 0 AEST} + {2548252800 39600 1 AEDT} + {2563977600 36000 0 AEST} + {2579702400 39600 1 AEDT} + {2596032000 36000 0 AEST} + {2611756800 39600 1 AEDT} + {2627481600 36000 0 AEST} + {2643206400 39600 1 AEDT} + {2658931200 36000 0 AEST} + {2674656000 39600 1 AEDT} + {2690380800 36000 0 AEST} + {2706105600 39600 1 AEDT} + {2721830400 36000 0 AEST} + {2737555200 39600 1 AEDT} + {2753280000 36000 0 AEST} + {2769609600 39600 1 AEDT} + {2785334400 36000 0 AEST} + {2801059200 39600 1 AEDT} + {2816784000 36000 0 AEST} + {2832508800 39600 1 AEDT} + {2848233600 36000 0 AEST} + {2863958400 39600 1 AEDT} + {2879683200 36000 0 AEST} + {2895408000 39600 1 AEDT} + {2911132800 36000 0 AEST} + {2926857600 39600 1 AEDT} + {2942582400 36000 0 AEST} + {2958912000 39600 1 AEDT} + {2974636800 36000 0 AEST} + {2990361600 39600 1 AEDT} + {3006086400 36000 0 AEST} + {3021811200 39600 1 AEDT} + {3037536000 36000 0 AEST} + {3053260800 39600 1 AEDT} + {3068985600 36000 0 AEST} + {3084710400 39600 1 AEDT} + {3100435200 36000 0 AEST} + {3116764800 39600 1 AEDT} + {3132489600 36000 0 AEST} + {3148214400 39600 1 AEDT} + {3163939200 36000 0 AEST} + {3179664000 39600 1 AEDT} + {3195388800 36000 0 AEST} + {3211113600 39600 1 AEDT} + {3226838400 36000 0 AEST} + {3242563200 39600 1 AEDT} + {3258288000 36000 0 AEST} + {3274012800 39600 1 AEDT} + {3289737600 36000 0 AEST} + {3306067200 39600 1 AEDT} + {3321792000 36000 0 AEST} + {3337516800 39600 1 AEDT} + {3353241600 36000 0 AEST} + {3368966400 39600 1 AEDT} + {3384691200 36000 0 AEST} + {3400416000 39600 1 AEDT} + {3416140800 36000 0 AEST} + {3431865600 39600 1 AEDT} + {3447590400 36000 0 AEST} + {3463315200 39600 1 AEDT} + {3479644800 36000 0 AEST} + {3495369600 39600 1 AEDT} + {3511094400 36000 0 AEST} + {3526819200 39600 1 AEDT} + {3542544000 36000 0 AEST} + {3558268800 39600 1 AEDT} + {3573993600 36000 0 AEST} + {3589718400 39600 1 AEDT} + {3605443200 36000 0 AEST} + {3621168000 39600 1 AEDT} + {3636892800 36000 0 AEST} + {3653222400 39600 1 AEDT} + {3668947200 36000 0 AEST} + {3684672000 39600 1 AEDT} + {3700396800 36000 0 AEST} + {3716121600 39600 1 AEDT} + {3731846400 36000 0 AEST} + {3747571200 39600 1 AEDT} + {3763296000 36000 0 AEST} + {3779020800 39600 1 AEDT} + {3794745600 36000 0 AEST} + {3810470400 39600 1 AEDT} + {3826195200 36000 0 AEST} + {3842524800 39600 1 AEDT} + {3858249600 36000 0 AEST} + {3873974400 39600 1 AEDT} + {3889699200 36000 0 AEST} + {3905424000 39600 1 AEDT} + {3921148800 36000 0 AEST} + {3936873600 39600 1 AEDT} + {3952598400 36000 0 AEST} + {3968323200 39600 1 AEDT} + {3984048000 36000 0 AEST} + {4000377600 39600 1 AEDT} + {4016102400 36000 0 AEST} + {4031827200 39600 1 AEDT} + {4047552000 36000 0 AEST} + {4063276800 39600 1 AEDT} + {4079001600 36000 0 AEST} + {4094726400 39600 1 AEDT} } Index: library/tzdata/Asia/Gaza ================================================================== --- library/tzdata/Asia/Gaza +++ library/tzdata/Asia/Gaza @@ -108,175 +108,175 @@ {1364508000 10800 1 EEST} {1380229200 7200 0 EET} {1395957600 10800 1 EEST} {1414098000 7200 0 EET} {1427493600 10800 1 EEST} - {1445547600 7200 0 EET} + {1445551200 7200 0 EET} {1458946800 10800 1 EEST} {1477692000 7200 0 EET} {1490396400 10800 1 EEST} {1509141600 7200 0 EET} {1521846000 10800 1 EEST} {1540591200 7200 0 EET} - {1553900400 10800 1 EEST} - {1572040800 7200 0 EET} - {1585350000 10800 1 EEST} - {1604095200 7200 0 EET} - {1616799600 10800 1 EEST} + {1553810400 10800 1 EEST} + {1572037200 7200 0 EET} + {1585346400 10800 1 EEST} + {1603490400 7200 0 EET} + {1616796000 10800 1 EEST} {1635544800 7200 0 EET} - {1648249200 10800 1 EEST} + {1648245600 10800 1 EEST} {1666994400 7200 0 EET} - {1679698800 10800 1 EEST} + {1679695200 10800 1 EEST} {1698444000 7200 0 EET} - {1711753200 10800 1 EEST} + {1711749600 10800 1 EEST} {1729893600 7200 0 EET} - {1743202800 10800 1 EEST} + {1743199200 10800 1 EEST} {1761343200 7200 0 EET} - {1774652400 10800 1 EEST} - {1793397600 7200 0 EET} - {1806102000 10800 1 EEST} + {1774648800 10800 1 EEST} + {1792792800 7200 0 EET} + {1806098400 10800 1 EEST} {1824847200 7200 0 EET} - {1837551600 10800 1 EEST} + {1837548000 10800 1 EEST} {1856296800 7200 0 EET} - {1869001200 10800 1 EEST} + {1868997600 10800 1 EEST} {1887746400 7200 0 EET} - {1901055600 10800 1 EEST} + {1901052000 10800 1 EEST} {1919196000 7200 0 EET} - {1932505200 10800 1 EEST} + {1932501600 10800 1 EEST} {1950645600 7200 0 EET} - {1963954800 10800 1 EEST} + {1963951200 10800 1 EEST} {1982700000 7200 0 EET} - {1995404400 10800 1 EEST} + {1995400800 10800 1 EEST} {2014149600 7200 0 EET} - {2026854000 10800 1 EEST} + {2026850400 10800 1 EEST} {2045599200 7200 0 EET} - {2058303600 10800 1 EEST} + {2058300000 10800 1 EEST} {2077048800 7200 0 EET} - {2090358000 10800 1 EEST} + {2090354400 10800 1 EEST} {2108498400 7200 0 EET} - {2121807600 10800 1 EEST} - {2140552800 7200 0 EET} - {2153257200 10800 1 EEST} + {2121804000 10800 1 EEST} + {2139948000 7200 0 EET} + {2153253600 10800 1 EEST} {2172002400 7200 0 EET} - {2184706800 10800 1 EEST} + {2184703200 10800 1 EEST} {2203452000 7200 0 EET} - {2216156400 10800 1 EEST} + {2216152800 10800 1 EEST} {2234901600 7200 0 EET} - {2248210800 10800 1 EEST} + {2248207200 10800 1 EEST} {2266351200 7200 0 EET} - {2279660400 10800 1 EEST} + {2279656800 10800 1 EEST} {2297800800 7200 0 EET} - {2311110000 10800 1 EEST} - {2329855200 7200 0 EET} - {2342559600 10800 1 EEST} + {2311106400 10800 1 EEST} + {2329250400 7200 0 EET} + {2342556000 10800 1 EEST} {2361304800 7200 0 EET} - {2374009200 10800 1 EEST} + {2374005600 10800 1 EEST} {2392754400 7200 0 EET} - {2405458800 10800 1 EEST} + {2405455200 10800 1 EEST} {2424204000 7200 0 EET} - {2437513200 10800 1 EEST} + {2437509600 10800 1 EEST} {2455653600 7200 0 EET} - {2468962800 10800 1 EEST} - {2487708000 7200 0 EET} - {2500412400 10800 1 EEST} + {2468959200 10800 1 EEST} + {2487103200 7200 0 EET} + {2500408800 10800 1 EEST} {2519157600 7200 0 EET} - {2531862000 10800 1 EEST} + {2531858400 10800 1 EEST} {2550607200 7200 0 EET} - {2563311600 10800 1 EEST} + {2563308000 10800 1 EEST} {2582056800 7200 0 EET} - {2595366000 10800 1 EEST} + {2595362400 10800 1 EEST} {2613506400 7200 0 EET} - {2626815600 10800 1 EEST} + {2626812000 10800 1 EEST} {2644956000 7200 0 EET} - {2658265200 10800 1 EEST} - {2677010400 7200 0 EET} - {2689714800 10800 1 EEST} + {2658261600 10800 1 EEST} + {2676405600 7200 0 EET} + {2689711200 10800 1 EEST} {2708460000 7200 0 EET} - {2721164400 10800 1 EEST} + {2721160800 10800 1 EEST} {2739909600 7200 0 EET} - {2752614000 10800 1 EEST} + {2752610400 10800 1 EEST} {2771359200 7200 0 EET} - {2784668400 10800 1 EEST} + {2784664800 10800 1 EEST} {2802808800 7200 0 EET} - {2816118000 10800 1 EEST} + {2816114400 10800 1 EEST} {2834258400 7200 0 EET} - {2847567600 10800 1 EEST} + {2847564000 10800 1 EEST} {2866312800 7200 0 EET} - {2879017200 10800 1 EEST} + {2879013600 10800 1 EEST} {2897762400 7200 0 EET} - {2910466800 10800 1 EEST} + {2910463200 10800 1 EEST} {2929212000 7200 0 EET} - {2941916400 10800 1 EEST} + {2941912800 10800 1 EEST} {2960661600 7200 0 EET} - {2973970800 10800 1 EEST} + {2973967200 10800 1 EEST} {2992111200 7200 0 EET} - {3005420400 10800 1 EEST} - {3024165600 7200 0 EET} - {3036870000 10800 1 EEST} + {3005416800 10800 1 EEST} + {3023560800 7200 0 EET} + {3036866400 10800 1 EEST} {3055615200 7200 0 EET} - {3068319600 10800 1 EEST} + {3068316000 10800 1 EEST} {3087064800 7200 0 EET} - {3099769200 10800 1 EEST} + {3099765600 10800 1 EEST} {3118514400 7200 0 EET} - {3131823600 10800 1 EEST} + {3131820000 10800 1 EEST} {3149964000 7200 0 EET} - {3163273200 10800 1 EEST} + {3163269600 10800 1 EEST} {3181413600 7200 0 EET} - {3194722800 10800 1 EEST} - {3213468000 7200 0 EET} - {3226172400 10800 1 EEST} + {3194719200 10800 1 EEST} + {3212863200 7200 0 EET} + {3226168800 10800 1 EEST} {3244917600 7200 0 EET} - {3257622000 10800 1 EEST} + {3257618400 10800 1 EEST} {3276367200 7200 0 EET} - {3289071600 10800 1 EEST} + {3289068000 10800 1 EEST} {3307816800 7200 0 EET} - {3321126000 10800 1 EEST} + {3321122400 10800 1 EEST} {3339266400 7200 0 EET} - {3352575600 10800 1 EEST} - {3371320800 7200 0 EET} - {3384025200 10800 1 EEST} + {3352572000 10800 1 EEST} + {3370716000 7200 0 EET} + {3384021600 10800 1 EEST} {3402770400 7200 0 EET} - {3415474800 10800 1 EEST} + {3415471200 10800 1 EEST} {3434220000 7200 0 EET} - {3446924400 10800 1 EEST} + {3446920800 10800 1 EEST} {3465669600 7200 0 EET} - {3478978800 10800 1 EEST} + {3478975200 10800 1 EEST} {3497119200 7200 0 EET} - {3510428400 10800 1 EEST} + {3510424800 10800 1 EEST} {3528568800 7200 0 EET} - {3541878000 10800 1 EEST} - {3560623200 7200 0 EET} - {3573327600 10800 1 EEST} + {3541874400 10800 1 EEST} + {3560018400 7200 0 EET} + {3573324000 10800 1 EEST} {3592072800 7200 0 EET} - {3604777200 10800 1 EEST} + {3604773600 10800 1 EEST} {3623522400 7200 0 EET} - {3636226800 10800 1 EEST} + {3636223200 10800 1 EEST} {3654972000 7200 0 EET} - {3668281200 10800 1 EEST} + {3668277600 10800 1 EEST} {3686421600 7200 0 EET} - {3699730800 10800 1 EEST} + {3699727200 10800 1 EEST} {3717871200 7200 0 EET} - {3731180400 10800 1 EEST} + {3731176800 10800 1 EEST} {3749925600 7200 0 EET} - {3762630000 10800 1 EEST} + {3762626400 10800 1 EEST} {3781375200 7200 0 EET} - {3794079600 10800 1 EEST} + {3794076000 10800 1 EEST} {3812824800 7200 0 EET} - {3825529200 10800 1 EEST} + {3825525600 10800 1 EEST} {3844274400 7200 0 EET} - {3857583600 10800 1 EEST} + {3857580000 10800 1 EEST} {3875724000 7200 0 EET} - {3889033200 10800 1 EEST} - {3907778400 7200 0 EET} - {3920482800 10800 1 EEST} + {3889029600 10800 1 EEST} + {3907173600 7200 0 EET} + {3920479200 10800 1 EEST} {3939228000 7200 0 EET} - {3951932400 10800 1 EEST} + {3951928800 10800 1 EEST} {3970677600 7200 0 EET} - {3983382000 10800 1 EEST} + {3983378400 10800 1 EEST} {4002127200 7200 0 EET} - {4015436400 10800 1 EEST} + {4015432800 10800 1 EEST} {4033576800 7200 0 EET} - {4046886000 10800 1 EEST} + {4046882400 10800 1 EEST} {4065026400 7200 0 EET} - {4078335600 10800 1 EEST} - {4097080800 7200 0 EET} + {4078332000 10800 1 EEST} + {4096476000 7200 0 EET} } Index: library/tzdata/Asia/Hebron ================================================================== --- library/tzdata/Asia/Hebron +++ library/tzdata/Asia/Hebron @@ -107,175 +107,175 @@ {1364508000 10800 1 EEST} {1380229200 7200 0 EET} {1395957600 10800 1 EEST} {1414098000 7200 0 EET} {1427493600 10800 1 EEST} - {1445547600 7200 0 EET} + {1445551200 7200 0 EET} {1458946800 10800 1 EEST} {1477692000 7200 0 EET} {1490396400 10800 1 EEST} {1509141600 7200 0 EET} {1521846000 10800 1 EEST} {1540591200 7200 0 EET} - {1553900400 10800 1 EEST} - {1572040800 7200 0 EET} - {1585350000 10800 1 EEST} - {1604095200 7200 0 EET} - {1616799600 10800 1 EEST} + {1553810400 10800 1 EEST} + {1572037200 7200 0 EET} + {1585346400 10800 1 EEST} + {1603490400 7200 0 EET} + {1616796000 10800 1 EEST} {1635544800 7200 0 EET} - {1648249200 10800 1 EEST} + {1648245600 10800 1 EEST} {1666994400 7200 0 EET} - {1679698800 10800 1 EEST} + {1679695200 10800 1 EEST} {1698444000 7200 0 EET} - {1711753200 10800 1 EEST} + {1711749600 10800 1 EEST} {1729893600 7200 0 EET} - {1743202800 10800 1 EEST} + {1743199200 10800 1 EEST} {1761343200 7200 0 EET} - {1774652400 10800 1 EEST} - {1793397600 7200 0 EET} - {1806102000 10800 1 EEST} + {1774648800 10800 1 EEST} + {1792792800 7200 0 EET} + {1806098400 10800 1 EEST} {1824847200 7200 0 EET} - {1837551600 10800 1 EEST} + {1837548000 10800 1 EEST} {1856296800 7200 0 EET} - {1869001200 10800 1 EEST} + {1868997600 10800 1 EEST} {1887746400 7200 0 EET} - {1901055600 10800 1 EEST} + {1901052000 10800 1 EEST} {1919196000 7200 0 EET} - {1932505200 10800 1 EEST} + {1932501600 10800 1 EEST} {1950645600 7200 0 EET} - {1963954800 10800 1 EEST} + {1963951200 10800 1 EEST} {1982700000 7200 0 EET} - {1995404400 10800 1 EEST} + {1995400800 10800 1 EEST} {2014149600 7200 0 EET} - {2026854000 10800 1 EEST} + {2026850400 10800 1 EEST} {2045599200 7200 0 EET} - {2058303600 10800 1 EEST} + {2058300000 10800 1 EEST} {2077048800 7200 0 EET} - {2090358000 10800 1 EEST} + {2090354400 10800 1 EEST} {2108498400 7200 0 EET} - {2121807600 10800 1 EEST} - {2140552800 7200 0 EET} - {2153257200 10800 1 EEST} + {2121804000 10800 1 EEST} + {2139948000 7200 0 EET} + {2153253600 10800 1 EEST} {2172002400 7200 0 EET} - {2184706800 10800 1 EEST} + {2184703200 10800 1 EEST} {2203452000 7200 0 EET} - {2216156400 10800 1 EEST} + {2216152800 10800 1 EEST} {2234901600 7200 0 EET} - {2248210800 10800 1 EEST} + {2248207200 10800 1 EEST} {2266351200 7200 0 EET} - {2279660400 10800 1 EEST} + {2279656800 10800 1 EEST} {2297800800 7200 0 EET} - {2311110000 10800 1 EEST} - {2329855200 7200 0 EET} - {2342559600 10800 1 EEST} + {2311106400 10800 1 EEST} + {2329250400 7200 0 EET} + {2342556000 10800 1 EEST} {2361304800 7200 0 EET} - {2374009200 10800 1 EEST} + {2374005600 10800 1 EEST} {2392754400 7200 0 EET} - {2405458800 10800 1 EEST} + {2405455200 10800 1 EEST} {2424204000 7200 0 EET} - {2437513200 10800 1 EEST} + {2437509600 10800 1 EEST} {2455653600 7200 0 EET} - {2468962800 10800 1 EEST} - {2487708000 7200 0 EET} - {2500412400 10800 1 EEST} + {2468959200 10800 1 EEST} + {2487103200 7200 0 EET} + {2500408800 10800 1 EEST} {2519157600 7200 0 EET} - {2531862000 10800 1 EEST} + {2531858400 10800 1 EEST} {2550607200 7200 0 EET} - {2563311600 10800 1 EEST} + {2563308000 10800 1 EEST} {2582056800 7200 0 EET} - {2595366000 10800 1 EEST} + {2595362400 10800 1 EEST} {2613506400 7200 0 EET} - {2626815600 10800 1 EEST} + {2626812000 10800 1 EEST} {2644956000 7200 0 EET} - {2658265200 10800 1 EEST} - {2677010400 7200 0 EET} - {2689714800 10800 1 EEST} + {2658261600 10800 1 EEST} + {2676405600 7200 0 EET} + {2689711200 10800 1 EEST} {2708460000 7200 0 EET} - {2721164400 10800 1 EEST} + {2721160800 10800 1 EEST} {2739909600 7200 0 EET} - {2752614000 10800 1 EEST} + {2752610400 10800 1 EEST} {2771359200 7200 0 EET} - {2784668400 10800 1 EEST} + {2784664800 10800 1 EEST} {2802808800 7200 0 EET} - {2816118000 10800 1 EEST} + {2816114400 10800 1 EEST} {2834258400 7200 0 EET} - {2847567600 10800 1 EEST} + {2847564000 10800 1 EEST} {2866312800 7200 0 EET} - {2879017200 10800 1 EEST} + {2879013600 10800 1 EEST} {2897762400 7200 0 EET} - {2910466800 10800 1 EEST} + {2910463200 10800 1 EEST} {2929212000 7200 0 EET} - {2941916400 10800 1 EEST} + {2941912800 10800 1 EEST} {2960661600 7200 0 EET} - {2973970800 10800 1 EEST} + {2973967200 10800 1 EEST} {2992111200 7200 0 EET} - {3005420400 10800 1 EEST} - {3024165600 7200 0 EET} - {3036870000 10800 1 EEST} + {3005416800 10800 1 EEST} + {3023560800 7200 0 EET} + {3036866400 10800 1 EEST} {3055615200 7200 0 EET} - {3068319600 10800 1 EEST} + {3068316000 10800 1 EEST} {3087064800 7200 0 EET} - {3099769200 10800 1 EEST} + {3099765600 10800 1 EEST} {3118514400 7200 0 EET} - {3131823600 10800 1 EEST} + {3131820000 10800 1 EEST} {3149964000 7200 0 EET} - {3163273200 10800 1 EEST} + {3163269600 10800 1 EEST} {3181413600 7200 0 EET} - {3194722800 10800 1 EEST} - {3213468000 7200 0 EET} - {3226172400 10800 1 EEST} + {3194719200 10800 1 EEST} + {3212863200 7200 0 EET} + {3226168800 10800 1 EEST} {3244917600 7200 0 EET} - {3257622000 10800 1 EEST} + {3257618400 10800 1 EEST} {3276367200 7200 0 EET} - {3289071600 10800 1 EEST} + {3289068000 10800 1 EEST} {3307816800 7200 0 EET} - {3321126000 10800 1 EEST} + {3321122400 10800 1 EEST} {3339266400 7200 0 EET} - {3352575600 10800 1 EEST} - {3371320800 7200 0 EET} - {3384025200 10800 1 EEST} + {3352572000 10800 1 EEST} + {3370716000 7200 0 EET} + {3384021600 10800 1 EEST} {3402770400 7200 0 EET} - {3415474800 10800 1 EEST} + {3415471200 10800 1 EEST} {3434220000 7200 0 EET} - {3446924400 10800 1 EEST} + {3446920800 10800 1 EEST} {3465669600 7200 0 EET} - {3478978800 10800 1 EEST} + {3478975200 10800 1 EEST} {3497119200 7200 0 EET} - {3510428400 10800 1 EEST} + {3510424800 10800 1 EEST} {3528568800 7200 0 EET} - {3541878000 10800 1 EEST} - {3560623200 7200 0 EET} - {3573327600 10800 1 EEST} + {3541874400 10800 1 EEST} + {3560018400 7200 0 EET} + {3573324000 10800 1 EEST} {3592072800 7200 0 EET} - {3604777200 10800 1 EEST} + {3604773600 10800 1 EEST} {3623522400 7200 0 EET} - {3636226800 10800 1 EEST} + {3636223200 10800 1 EEST} {3654972000 7200 0 EET} - {3668281200 10800 1 EEST} + {3668277600 10800 1 EEST} {3686421600 7200 0 EET} - {3699730800 10800 1 EEST} + {3699727200 10800 1 EEST} {3717871200 7200 0 EET} - {3731180400 10800 1 EEST} + {3731176800 10800 1 EEST} {3749925600 7200 0 EET} - {3762630000 10800 1 EEST} + {3762626400 10800 1 EEST} {3781375200 7200 0 EET} - {3794079600 10800 1 EEST} + {3794076000 10800 1 EEST} {3812824800 7200 0 EET} - {3825529200 10800 1 EEST} + {3825525600 10800 1 EEST} {3844274400 7200 0 EET} - {3857583600 10800 1 EEST} + {3857580000 10800 1 EEST} {3875724000 7200 0 EET} - {3889033200 10800 1 EEST} - {3907778400 7200 0 EET} - {3920482800 10800 1 EEST} + {3889029600 10800 1 EEST} + {3907173600 7200 0 EET} + {3920479200 10800 1 EEST} {3939228000 7200 0 EET} - {3951932400 10800 1 EEST} + {3951928800 10800 1 EEST} {3970677600 7200 0 EET} - {3983382000 10800 1 EEST} + {3983378400 10800 1 EEST} {4002127200 7200 0 EET} - {4015436400 10800 1 EEST} + {4015432800 10800 1 EEST} {4033576800 7200 0 EET} - {4046886000 10800 1 EEST} + {4046882400 10800 1 EEST} {4065026400 7200 0 EET} - {4078335600 10800 1 EEST} - {4097080800 7200 0 EET} + {4078332000 10800 1 EEST} + {4096476000 7200 0 EET} } Index: library/tzdata/Asia/Hong_Kong ================================================================== --- library/tzdata/Asia/Hong_Kong +++ library/tzdata/Asia/Hong_Kong @@ -1,28 +1,28 @@ # created by tools/tclZIC.tcl - do not edit set TZData(:Asia/Hong_Kong) { {-9223372036854775808 27402 0 LMT} {-2056690800 28800 0 HKT} - {-900909000 32400 1 HKST} - {-891579600 30600 0 HKT} + {-900910800 32400 1 HKST} + {-891579600 30600 1 HKWT} {-884248200 32400 0 JST} - {-766659600 28800 0 HKT} - {-747981000 32400 1 HKST} - {-728544600 28800 0 HKT} + {-761209200 28800 0 HKT} + {-747907200 32400 1 HKST} + {-728541000 28800 0 HKT} {-717049800 32400 1 HKST} - {-694503000 28800 0 HKT} + {-697091400 28800 0 HKT} {-683785800 32400 1 HKST} - {-668064600 28800 0 HKT} + {-668061000 28800 0 HKT} {-654755400 32400 1 HKST} - {-636615000 28800 0 HKT} + {-636611400 28800 0 HKT} {-623305800 32400 1 HKST} - {-605165400 28800 0 HKT} + {-605161800 28800 0 HKT} {-591856200 32400 1 HKST} - {-573715800 28800 0 HKT} + {-573712200 28800 0 HKT} {-559801800 32400 1 HKST} - {-541661400 28800 0 HKT} + {-541657800 28800 0 HKT} {-528352200 32400 1 HKST} {-510211800 28800 0 HKT} {-498112200 32400 1 HKST} {-478762200 28800 0 HKT} {-466662600 32400 1 HKST} Index: library/tzdata/Asia/Seoul ================================================================== --- library/tzdata/Asia/Seoul +++ library/tzdata/Asia/Seoul @@ -3,10 +3,18 @@ set TZData(:Asia/Seoul) { {-9223372036854775808 30472 0 LMT} {-1948782472 30600 0 KST} {-1830414600 32400 0 JST} {-767350800 32400 0 KST} + {-681210000 36000 1 KDT} + {-672228000 32400 0 KST} + {-654771600 36000 1 KDT} + {-640864800 32400 0 KST} + {-623408400 36000 1 KDT} + {-609415200 32400 0 KST} + {-588848400 36000 1 KDT} + {-577965600 32400 0 KST} {-498128400 30600 0 KST} {-462702600 34200 1 KDT} {-451733400 30600 0 KST} {-429784200 34200 1 KDT} {-418296600 30600 0 KST} Index: library/tzdata/Asia/Shanghai ================================================================== --- library/tzdata/Asia/Shanghai +++ library/tzdata/Asia/Shanghai @@ -1,10 +1,12 @@ # created by tools/tclZIC.tcl - do not edit set TZData(:Asia/Shanghai) { {-9223372036854775808 29143 0 LMT} {-2177481943 28800 0 CST} + {-1600675200 32400 1 CDT} + {-1585904400 28800 0 CST} {-933667200 32400 1 CDT} {-922093200 28800 0 CST} {-908870400 32400 1 CDT} {-888829200 28800 0 CST} {-881049600 32400 1 CDT} Index: library/tzdata/Europe/Brussels ================================================================== --- library/tzdata/Europe/Brussels +++ library/tzdata/Europe/Brussels @@ -1,11 +1,11 @@ # created by tools/tclZIC.tcl - do not edit set TZData(:Europe/Brussels) { {-9223372036854775808 1050 0 LMT} {-2840141850 1050 0 BMT} - {-2450953050 0 0 WET} + {-2450995200 0 0 WET} {-1740355200 3600 0 CET} {-1693702800 7200 0 CEST} {-1680483600 3600 0 CET} {-1663455600 7200 1 CEST} {-1650150000 3600 0 CET} Index: library/tzdata/Europe/Budapest ================================================================== --- library/tzdata/Europe/Budapest +++ library/tzdata/Europe/Budapest @@ -1,54 +1,55 @@ # created by tools/tclZIC.tcl - do not edit set TZData(:Europe/Budapest) { {-9223372036854775808 4580 0 LMT} - {-2500938980 3600 0 CET} + {-2498260580 3600 0 CET} {-1693706400 7200 1 CEST} {-1680483600 3600 0 CET} {-1663455600 7200 1 CEST} {-1650150000 3600 0 CET} {-1640998800 3600 0 CET} - {-1633212000 7200 1 CEST} + {-1632006000 7200 1 CEST} {-1618700400 3600 0 CET} - {-1600466400 7200 1 CEST} - {-1581202800 3600 0 CET} - {-906771600 3600 0 CET} + {-1600470000 7200 1 CEST} + {-1587250800 3600 0 CET} + {-1569711600 7200 1 CEST} + {-1555196400 3600 0 CET} + {-906775200 3600 0 CET} {-857257200 3600 0 CET} {-844556400 7200 1 CEST} {-828226800 3600 0 CET} {-812502000 7200 1 CEST} {-796777200 3600 0 CET} {-788922000 3600 0 CET} {-778471200 7200 1 CEST} - {-762660000 3600 0 CET} + {-762656400 3600 0 CET} {-749689200 7200 1 CEST} - {-733359600 3600 0 CET} + {-733276800 3600 0 CET} {-717634800 7200 1 CEST} {-701910000 3600 0 CET} {-686185200 7200 1 CEST} {-670460400 3600 0 CET} {-654130800 7200 1 CEST} {-639010800 3600 0 CET} - {-621990000 7200 1 CEST} - {-605660400 3600 0 CET} {-492656400 7200 1 CEST} {-481168800 3600 0 CET} - {-461120400 7200 1 CEST} - {-449632800 3600 0 CET} - {-428547600 7200 1 CEST} - {-418269600 3600 0 CET} - {-397094400 7200 1 CEST} + {-461199600 7200 1 CEST} + {-449708400 3600 0 CET} + {-428540400 7200 1 CEST} + {-418258800 3600 0 CET} + {-397090800 7200 1 CEST} {-386809200 3600 0 CET} - {323827200 7200 1 CEST} - {338950800 3600 0 CET} - {354675600 7200 1 CEST} - {370400400 3600 0 CET} - {386125200 7200 1 CEST} - {401850000 3600 0 CET} - {417574800 7200 1 CEST} - {433299600 3600 0 CET} + {323823600 7200 1 CEST} + {338943600 3600 0 CET} + {354668400 7200 1 CEST} + {370393200 3600 0 CET} + {386118000 7200 1 CEST} + {401842800 3600 0 CET} + {417567600 7200 1 CEST} + {433292400 3600 0 CET} + {441759600 3600 0 CET} {449024400 7200 1 CEST} {465354000 3600 0 CET} {481078800 7200 1 CEST} {496803600 3600 0 CET} {512528400 7200 1 CEST} Index: library/tzdata/Europe/Istanbul ================================================================== --- library/tzdata/Europe/Istanbul +++ library/tzdata/Europe/Istanbul @@ -14,65 +14,50 @@ {-1490583600 7200 0 EET} {-1440208800 10800 1 EEST} {-1428030000 7200 0 EET} {-1409709600 10800 1 EEST} {-1396494000 7200 0 EET} - {-931140000 10800 1 EEST} - {-922762800 7200 0 EET} + {-931053600 10800 1 EEST} + {-922676400 7200 0 EET} {-917834400 10800 1 EEST} {-892436400 7200 0 EET} {-875844000 10800 1 EEST} - {-857358000 7200 0 EET} - {-781063200 10800 1 EEST} {-764737200 7200 0 EET} {-744343200 10800 1 EEST} {-733806000 7200 0 EET} {-716436000 10800 1 EEST} {-701924400 7200 0 EET} {-684986400 10800 1 EEST} {-670474800 7200 0 EET} {-654141600 10800 1 EEST} {-639025200 7200 0 EET} - {-621828000 10800 1 EEST} + {-622087200 10800 1 EEST} {-606970800 7200 0 EET} {-590032800 10800 1 EEST} - {-575434800 7200 0 EET} + {-575521200 7200 0 EET} {-235620000 10800 1 EEST} - {-228279600 7200 0 EET} + {-194842800 7200 0 EET} {-177732000 10800 1 EEST} {-165726000 7200 0 EET} - {10533600 10800 1 EEST} - {23835600 7200 0 EET} - {41983200 10800 1 EEST} - {55285200 7200 0 EET} - {74037600 10800 1 EEST} - {87339600 7200 0 EET} {107910000 10800 1 EEST} - {121219200 7200 0 EET} + {121215600 7200 0 EET} {133920000 10800 1 EEST} - {152676000 7200 0 EET} - {165362400 10800 1 EEST} - {183502800 7200 0 EET} - {202428000 10800 1 EEST} - {215557200 7200 0 EET} - {228866400 10800 1 EEST} - {245797200 7200 0 EET} - {260316000 10800 1 EEST} - {277246800 14400 0 +04} - {291769200 14400 1 +04} - {308779200 10800 0 +03} - {323827200 14400 1 +04} - {340228800 10800 0 +03} - {354672000 14400 1 +04} - {371678400 10800 0 +03} - {386121600 14400 1 +04} - {403128000 10800 0 +03} - {428446800 14400 1 +04} - {433886400 10800 0 +03} - {482792400 7200 0 EET} - {482796000 10800 1 EEST} - {496702800 7200 0 EET} + {152665200 7200 0 EET} + {164678400 10800 1 EEST} + {184114800 7200 0 EET} + {196214400 10800 1 EEST} + {215564400 7200 0 EET} + {228873600 10800 1 EEST} + {245804400 7200 0 EET} + {260323200 10800 1 EEST} + {267919200 10800 0 +03} + {277254000 10800 0 +03} + {428454000 14400 1 +04} + {433893600 10800 0 +03} + {468111600 7200 0 EET} + {482799600 10800 1 EEST} + {496710000 7200 0 EET} {512521200 10800 1 EEST} {528246000 7200 0 EET} {543970800 10800 1 EEST} {559695600 7200 0 EET} {575420400 10800 1 EEST} Index: library/tzdata/Europe/Kaliningrad ================================================================== --- library/tzdata/Europe/Kaliningrad +++ library/tzdata/Europe/Kaliningrad @@ -13,14 +13,15 @@ {-857257200 3600 0 CET} {-844556400 7200 1 CEST} {-828226800 3600 0 CET} {-812502000 7200 1 CEST} {-796777200 3600 0 CET} - {-788922000 7200 0 CET} - {-778730400 10800 1 CEST} - {-762663600 7200 0 CET} - {-757389600 10800 0 MSD} + {-781052400 7200 1 CEST} + {-780368400 7200 0 EET} + {-778730400 10800 1 EEST} + {-762663600 7200 0 EET} + {-749095200 10800 0 MSD} {354920400 14400 1 MSD} {370728000 10800 0 MSK} {386456400 14400 1 MSD} {402264000 10800 0 MSK} {417992400 14400 1 MSD} Index: library/tzdata/Europe/Monaco ================================================================== --- library/tzdata/Europe/Monaco +++ library/tzdata/Europe/Monaco @@ -1,11 +1,11 @@ # created by tools/tclZIC.tcl - do not edit set TZData(:Europe/Monaco) { {-9223372036854775808 1772 0 LMT} - {-2486680172 561 0 PMT} - {-1855958961 0 0 WET} + {-2448318572 561 0 PMT} + {-1854403761 0 0 WET} {-1689814800 3600 1 WEST} {-1680397200 0 0 WET} {-1665363600 3600 1 WEST} {-1648342800 0 0 WET} {-1635123600 3600 1 WEST} Index: library/tzdata/Europe/Paris ================================================================== --- library/tzdata/Europe/Paris +++ library/tzdata/Europe/Paris @@ -1,11 +1,11 @@ # created by tools/tclZIC.tcl - do not edit set TZData(:Europe/Paris) { {-9223372036854775808 561 0 LMT} - {-2486678901 561 0 PMT} - {-1855958901 0 0 WET} + {-2486592561 561 0 PMT} + {-1855958961 0 0 WET} {-1689814800 3600 1 WEST} {-1680397200 0 0 WET} {-1665363600 3600 1 WEST} {-1648342800 0 0 WET} {-1635123600 3600 1 WEST} Index: library/tzdata/Europe/Rome ================================================================== --- library/tzdata/Europe/Rome +++ library/tzdata/Europe/Rome @@ -1,10 +1,10 @@ # created by tools/tclZIC.tcl - do not edit set TZData(:Europe/Rome) { {-9223372036854775808 2996 0 LMT} - {-3259097396 2996 0 RMT} + {-3252098996 2996 0 RMT} {-2403565200 3600 0 CET} {-1690765200 7200 1 CEST} {-1680487200 3600 0 CET} {-1664758800 7200 1 CEST} {-1648951200 3600 0 CET} Index: library/tzdata/Europe/Vienna ================================================================== --- library/tzdata/Europe/Vienna +++ library/tzdata/Europe/Vienna @@ -20,11 +20,11 @@ {-796777200 3600 0 CET} {-781052400 7200 1 CEST} {-780188400 3600 0 CET} {-757386000 3600 0 CET} {-748479600 7200 1 CEST} - {-733359600 3600 0 CET} + {-733273200 3600 0 CET} {-717634800 7200 1 CEST} {-701910000 3600 0 CET} {-684975600 7200 1 CEST} {-670460400 3600 0 CET} {323823600 7200 1 CEST} Index: library/tzdata/Pacific/Fiji ================================================================== --- library/tzdata/Pacific/Fiji +++ library/tzdata/Pacific/Fiji @@ -25,167 +25,167 @@ {1484402400 43200 0 +12} {1509804000 46800 1 +12} {1515852000 43200 0 +12} {1541253600 46800 1 +12} {1547301600 43200 0 +12} - {1572703200 46800 1 +12} - {1579356000 43200 0 +12} - {1604152800 46800 1 +12} + {1573308000 46800 1 +12} + {1578751200 43200 0 +12} + {1608386400 46800 1 +12} {1610805600 43200 0 +12} - {1636207200 46800 1 +12} + {1636812000 46800 1 +12} {1642255200 43200 0 +12} - {1667656800 46800 1 +12} + {1668261600 46800 1 +12} {1673704800 43200 0 +12} - {1699106400 46800 1 +12} + {1699711200 46800 1 +12} {1705154400 43200 0 +12} - {1730556000 46800 1 +12} - {1737208800 43200 0 +12} - {1762005600 46800 1 +12} + {1731160800 46800 1 +12} + {1736604000 43200 0 +12} + {1762610400 46800 1 +12} {1768658400 43200 0 +12} - {1793455200 46800 1 +12} + {1794060000 46800 1 +12} {1800108000 43200 0 +12} - {1825509600 46800 1 +12} + {1826114400 46800 1 +12} {1831557600 43200 0 +12} - {1856959200 46800 1 +12} + {1857564000 46800 1 +12} {1863007200 43200 0 +12} - {1888408800 46800 1 +12} + {1889013600 46800 1 +12} {1894456800 43200 0 +12} - {1919858400 46800 1 +12} - {1926511200 43200 0 +12} - {1951308000 46800 1 +12} + {1920463200 46800 1 +12} + {1925906400 43200 0 +12} + {1951912800 46800 1 +12} {1957960800 43200 0 +12} - {1983362400 46800 1 +12} + {1983967200 46800 1 +12} {1989410400 43200 0 +12} - {2014812000 46800 1 +12} + {2015416800 46800 1 +12} {2020860000 43200 0 +12} - {2046261600 46800 1 +12} + {2046866400 46800 1 +12} {2052309600 43200 0 +12} - {2077711200 46800 1 +12} + {2078316000 46800 1 +12} {2083759200 43200 0 +12} - {2109160800 46800 1 +12} + {2109765600 46800 1 +12} {2115813600 43200 0 +12} - {2140610400 46800 1 +12} + {2141215200 46800 1 +12} {2147263200 43200 0 +12} - {2172664800 46800 1 +12} + {2173269600 46800 1 +12} {2178712800 43200 0 +12} - {2204114400 46800 1 +12} + {2204719200 46800 1 +12} {2210162400 43200 0 +12} - {2235564000 46800 1 +12} + {2236168800 46800 1 +12} {2241612000 43200 0 +12} - {2267013600 46800 1 +12} - {2273666400 43200 0 +12} - {2298463200 46800 1 +12} + {2267618400 46800 1 +12} + {2273061600 43200 0 +12} + {2299068000 46800 1 +12} {2305116000 43200 0 +12} - {2329912800 46800 1 +12} + {2330517600 46800 1 +12} {2336565600 43200 0 +12} - {2361967200 46800 1 +12} + {2362572000 46800 1 +12} {2368015200 43200 0 +12} - {2393416800 46800 1 +12} + {2394021600 46800 1 +12} {2399464800 43200 0 +12} - {2424866400 46800 1 +12} + {2425471200 46800 1 +12} {2430914400 43200 0 +12} - {2456316000 46800 1 +12} - {2462968800 43200 0 +12} - {2487765600 46800 1 +12} + {2456920800 46800 1 +12} + {2462364000 43200 0 +12} + {2488370400 46800 1 +12} {2494418400 43200 0 +12} - {2519820000 46800 1 +12} + {2520424800 46800 1 +12} {2525868000 43200 0 +12} - {2551269600 46800 1 +12} + {2551874400 46800 1 +12} {2557317600 43200 0 +12} - {2582719200 46800 1 +12} + {2583324000 46800 1 +12} {2588767200 43200 0 +12} - {2614168800 46800 1 +12} - {2620821600 43200 0 +12} - {2645618400 46800 1 +12} + {2614773600 46800 1 +12} + {2620216800 43200 0 +12} + {2646223200 46800 1 +12} {2652271200 43200 0 +12} - {2677068000 46800 1 +12} + {2677672800 46800 1 +12} {2683720800 43200 0 +12} - {2709122400 46800 1 +12} + {2709727200 46800 1 +12} {2715170400 43200 0 +12} - {2740572000 46800 1 +12} + {2741176800 46800 1 +12} {2746620000 43200 0 +12} - {2772021600 46800 1 +12} + {2772626400 46800 1 +12} {2778069600 43200 0 +12} - {2803471200 46800 1 +12} - {2810124000 43200 0 +12} - {2834920800 46800 1 +12} + {2804076000 46800 1 +12} + {2809519200 43200 0 +12} + {2835525600 46800 1 +12} {2841573600 43200 0 +12} - {2866975200 46800 1 +12} + {2867580000 46800 1 +12} {2873023200 43200 0 +12} - {2898424800 46800 1 +12} + {2899029600 46800 1 +12} {2904472800 43200 0 +12} - {2929874400 46800 1 +12} + {2930479200 46800 1 +12} {2935922400 43200 0 +12} - {2961324000 46800 1 +12} + {2961928800 46800 1 +12} {2967372000 43200 0 +12} - {2992773600 46800 1 +12} + {2993378400 46800 1 +12} {2999426400 43200 0 +12} - {3024223200 46800 1 +12} + {3024828000 46800 1 +12} {3030876000 43200 0 +12} - {3056277600 46800 1 +12} + {3056882400 46800 1 +12} {3062325600 43200 0 +12} - {3087727200 46800 1 +12} + {3088332000 46800 1 +12} {3093775200 43200 0 +12} - {3119176800 46800 1 +12} + {3119781600 46800 1 +12} {3125224800 43200 0 +12} - {3150626400 46800 1 +12} - {3157279200 43200 0 +12} - {3182076000 46800 1 +12} + {3151231200 46800 1 +12} + {3156674400 43200 0 +12} + {3182680800 46800 1 +12} {3188728800 43200 0 +12} - {3213525600 46800 1 +12} + {3214130400 46800 1 +12} {3220178400 43200 0 +12} - {3245580000 46800 1 +12} + {3246184800 46800 1 +12} {3251628000 43200 0 +12} - {3277029600 46800 1 +12} + {3277634400 46800 1 +12} {3283077600 43200 0 +12} - {3308479200 46800 1 +12} + {3309084000 46800 1 +12} {3314527200 43200 0 +12} - {3339928800 46800 1 +12} - {3346581600 43200 0 +12} - {3371378400 46800 1 +12} + {3340533600 46800 1 +12} + {3345976800 43200 0 +12} + {3371983200 46800 1 +12} {3378031200 43200 0 +12} - {3403432800 46800 1 +12} + {3404037600 46800 1 +12} {3409480800 43200 0 +12} - {3434882400 46800 1 +12} + {3435487200 46800 1 +12} {3440930400 43200 0 +12} - {3466332000 46800 1 +12} + {3466936800 46800 1 +12} {3472380000 43200 0 +12} - {3497781600 46800 1 +12} - {3504434400 43200 0 +12} - {3529231200 46800 1 +12} + {3498386400 46800 1 +12} + {3503829600 43200 0 +12} + {3529836000 46800 1 +12} {3535884000 43200 0 +12} - {3560680800 46800 1 +12} + {3561285600 46800 1 +12} {3567333600 43200 0 +12} - {3592735200 46800 1 +12} + {3593340000 46800 1 +12} {3598783200 43200 0 +12} - {3624184800 46800 1 +12} + {3624789600 46800 1 +12} {3630232800 43200 0 +12} - {3655634400 46800 1 +12} + {3656239200 46800 1 +12} {3661682400 43200 0 +12} - {3687084000 46800 1 +12} - {3693736800 43200 0 +12} - {3718533600 46800 1 +12} + {3687688800 46800 1 +12} + {3693132000 43200 0 +12} + {3719138400 46800 1 +12} {3725186400 43200 0 +12} - {3750588000 46800 1 +12} + {3751192800 46800 1 +12} {3756636000 43200 0 +12} - {3782037600 46800 1 +12} + {3782642400 46800 1 +12} {3788085600 43200 0 +12} - {3813487200 46800 1 +12} + {3814092000 46800 1 +12} {3819535200 43200 0 +12} - {3844936800 46800 1 +12} + {3845541600 46800 1 +12} {3850984800 43200 0 +12} - {3876386400 46800 1 +12} + {3876991200 46800 1 +12} {3883039200 43200 0 +12} - {3907836000 46800 1 +12} + {3908440800 46800 1 +12} {3914488800 43200 0 +12} - {3939890400 46800 1 +12} + {3940495200 46800 1 +12} {3945938400 43200 0 +12} - {3971340000 46800 1 +12} + {3971944800 46800 1 +12} {3977388000 43200 0 +12} - {4002789600 46800 1 +12} + {4003394400 46800 1 +12} {4008837600 43200 0 +12} - {4034239200 46800 1 +12} - {4040892000 43200 0 +12} - {4065688800 46800 1 +12} + {4034844000 46800 1 +12} + {4040287200 43200 0 +12} + {4066293600 46800 1 +12} {4072341600 43200 0 +12} - {4097138400 46800 1 +12} + {4097743200 46800 1 +12} } Index: library/tzdata/Pacific/Norfolk ================================================================== --- library/tzdata/Pacific/Norfolk +++ library/tzdata/Pacific/Norfolk @@ -3,8 +3,170 @@ set TZData(:Pacific/Norfolk) { {-9223372036854775808 40312 0 LMT} {-2177493112 40320 0 +1112} {-599656320 41400 0 +1130} {152029800 45000 1 +1230} - {162912600 41400 0 +1130} + {162916200 41400 0 +1130} {1443882600 39600 0 +11} + {1561899600 39600 0 +12} + {1570287600 43200 1 +12} + {1586012400 39600 0 +12} + {1601737200 43200 1 +12} + {1617462000 39600 0 +12} + {1633186800 43200 1 +12} + {1648911600 39600 0 +12} + {1664636400 43200 1 +12} + {1680361200 39600 0 +12} + {1696086000 43200 1 +12} + {1712415600 39600 0 +12} + {1728140400 43200 1 +12} + {1743865200 39600 0 +12} + {1759590000 43200 1 +12} + {1775314800 39600 0 +12} + {1791039600 43200 1 +12} + {1806764400 39600 0 +12} + {1822489200 43200 1 +12} + {1838214000 39600 0 +12} + {1853938800 43200 1 +12} + {1869663600 39600 0 +12} + {1885993200 43200 1 +12} + {1901718000 39600 0 +12} + {1917442800 43200 1 +12} + {1933167600 39600 0 +12} + {1948892400 43200 1 +12} + {1964617200 39600 0 +12} + {1980342000 43200 1 +12} + {1996066800 39600 0 +12} + {2011791600 43200 1 +12} + {2027516400 39600 0 +12} + {2043241200 43200 1 +12} + {2058966000 39600 0 +12} + {2075295600 43200 1 +12} + {2091020400 39600 0 +12} + {2106745200 43200 1 +12} + {2122470000 39600 0 +12} + {2138194800 43200 1 +12} + {2153919600 39600 0 +12} + {2169644400 43200 1 +12} + {2185369200 39600 0 +12} + {2201094000 43200 1 +12} + {2216818800 39600 0 +12} + {2233148400 43200 1 +12} + {2248873200 39600 0 +12} + {2264598000 43200 1 +12} + {2280322800 39600 0 +12} + {2296047600 43200 1 +12} + {2311772400 39600 0 +12} + {2327497200 43200 1 +12} + {2343222000 39600 0 +12} + {2358946800 43200 1 +12} + {2374671600 39600 0 +12} + {2390396400 43200 1 +12} + {2406121200 39600 0 +12} + {2422450800 43200 1 +12} + {2438175600 39600 0 +12} + {2453900400 43200 1 +12} + {2469625200 39600 0 +12} + {2485350000 43200 1 +12} + {2501074800 39600 0 +12} + {2516799600 43200 1 +12} + {2532524400 39600 0 +12} + {2548249200 43200 1 +12} + {2563974000 39600 0 +12} + {2579698800 43200 1 +12} + {2596028400 39600 0 +12} + {2611753200 43200 1 +12} + {2627478000 39600 0 +12} + {2643202800 43200 1 +12} + {2658927600 39600 0 +12} + {2674652400 43200 1 +12} + {2690377200 39600 0 +12} + {2706102000 43200 1 +12} + {2721826800 39600 0 +12} + {2737551600 43200 1 +12} + {2753276400 39600 0 +12} + {2769606000 43200 1 +12} + {2785330800 39600 0 +12} + {2801055600 43200 1 +12} + {2816780400 39600 0 +12} + {2832505200 43200 1 +12} + {2848230000 39600 0 +12} + {2863954800 43200 1 +12} + {2879679600 39600 0 +12} + {2895404400 43200 1 +12} + {2911129200 39600 0 +12} + {2926854000 43200 1 +12} + {2942578800 39600 0 +12} + {2958908400 43200 1 +12} + {2974633200 39600 0 +12} + {2990358000 43200 1 +12} + {3006082800 39600 0 +12} + {3021807600 43200 1 +12} + {3037532400 39600 0 +12} + {3053257200 43200 1 +12} + {3068982000 39600 0 +12} + {3084706800 43200 1 +12} + {3100431600 39600 0 +12} + {3116761200 43200 1 +12} + {3132486000 39600 0 +12} + {3148210800 43200 1 +12} + {3163935600 39600 0 +12} + {3179660400 43200 1 +12} + {3195385200 39600 0 +12} + {3211110000 43200 1 +12} + {3226834800 39600 0 +12} + {3242559600 43200 1 +12} + {3258284400 39600 0 +12} + {3274009200 43200 1 +12} + {3289734000 39600 0 +12} + {3306063600 43200 1 +12} + {3321788400 39600 0 +12} + {3337513200 43200 1 +12} + {3353238000 39600 0 +12} + {3368962800 43200 1 +12} + {3384687600 39600 0 +12} + {3400412400 43200 1 +12} + {3416137200 39600 0 +12} + {3431862000 43200 1 +12} + {3447586800 39600 0 +12} + {3463311600 43200 1 +12} + {3479641200 39600 0 +12} + {3495366000 43200 1 +12} + {3511090800 39600 0 +12} + {3526815600 43200 1 +12} + {3542540400 39600 0 +12} + {3558265200 43200 1 +12} + {3573990000 39600 0 +12} + {3589714800 43200 1 +12} + {3605439600 39600 0 +12} + {3621164400 43200 1 +12} + {3636889200 39600 0 +12} + {3653218800 43200 1 +12} + {3668943600 39600 0 +12} + {3684668400 43200 1 +12} + {3700393200 39600 0 +12} + {3716118000 43200 1 +12} + {3731842800 39600 0 +12} + {3747567600 43200 1 +12} + {3763292400 39600 0 +12} + {3779017200 43200 1 +12} + {3794742000 39600 0 +12} + {3810466800 43200 1 +12} + {3826191600 39600 0 +12} + {3842521200 43200 1 +12} + {3858246000 39600 0 +12} + {3873970800 43200 1 +12} + {3889695600 39600 0 +12} + {3905420400 43200 1 +12} + {3921145200 39600 0 +12} + {3936870000 43200 1 +12} + {3952594800 39600 0 +12} + {3968319600 43200 1 +12} + {3984044400 39600 0 +12} + {4000374000 43200 1 +12} + {4016098800 39600 0 +12} + {4031823600 43200 1 +12} + {4047548400 39600 0 +12} + {4063273200 43200 1 +12} + {4078998000 39600 0 +12} + {4094722800 43200 1 +12} } ADDED library/tzdata/SystemV/AST4 Index: library/tzdata/SystemV/AST4 ================================================================== --- /dev/null +++ library/tzdata/SystemV/AST4 @@ -0,0 +1,5 @@ +# created by ../tools/tclZIC.tcl - do not edit +if {![info exists TZData(America/Puerto_Rico)]} { + LoadTimeZoneFile America/Puerto_Rico +} +set TZData(:SystemV/AST4) $TZData(:America/Puerto_Rico) ADDED library/tzdata/SystemV/AST4ADT Index: library/tzdata/SystemV/AST4ADT ================================================================== --- /dev/null +++ library/tzdata/SystemV/AST4ADT @@ -0,0 +1,5 @@ +# created by ../tools/tclZIC.tcl - do not edit +if {![info exists TZData(America/Halifax)]} { + LoadTimeZoneFile America/Halifax +} +set TZData(:SystemV/AST4ADT) $TZData(:America/Halifax) ADDED library/tzdata/SystemV/CST6 Index: library/tzdata/SystemV/CST6 ================================================================== --- /dev/null +++ library/tzdata/SystemV/CST6 @@ -0,0 +1,5 @@ +# created by ../tools/tclZIC.tcl - do not edit +if {![info exists TZData(America/Regina)]} { + LoadTimeZoneFile America/Regina +} +set TZData(:SystemV/CST6) $TZData(:America/Regina) ADDED library/tzdata/SystemV/CST6CDT Index: library/tzdata/SystemV/CST6CDT ================================================================== --- /dev/null +++ library/tzdata/SystemV/CST6CDT @@ -0,0 +1,5 @@ +# created by ../tools/tclZIC.tcl - do not edit +if {![info exists TZData(America/Chicago)]} { + LoadTimeZoneFile America/Chicago +} +set TZData(:SystemV/CST6CDT) $TZData(:America/Chicago) ADDED library/tzdata/SystemV/EST5 Index: library/tzdata/SystemV/EST5 ================================================================== --- /dev/null +++ library/tzdata/SystemV/EST5 @@ -0,0 +1,5 @@ +# created by ../tools/tclZIC.tcl - do not edit +if {![info exists TZData(America/Indianapolis)]} { + LoadTimeZoneFile America/Indianapolis +} +set TZData(:SystemV/EST5) $TZData(:America/Indianapolis) ADDED library/tzdata/SystemV/EST5EDT Index: library/tzdata/SystemV/EST5EDT ================================================================== --- /dev/null +++ library/tzdata/SystemV/EST5EDT @@ -0,0 +1,5 @@ +# created by ../tools/tclZIC.tcl - do not edit +if {![info exists TZData(America/New_York)]} { + LoadTimeZoneFile America/New_York +} +set TZData(:SystemV/EST5EDT) $TZData(:America/New_York) ADDED library/tzdata/SystemV/HST10 Index: library/tzdata/SystemV/HST10 ================================================================== --- /dev/null +++ library/tzdata/SystemV/HST10 @@ -0,0 +1,5 @@ +# created by ../tools/tclZIC.tcl - do not edit +if {![info exists TZData(Pacific/Honolulu)]} { + LoadTimeZoneFile Pacific/Honolulu +} +set TZData(:SystemV/HST10) $TZData(:Pacific/Honolulu) ADDED library/tzdata/SystemV/MST7 Index: library/tzdata/SystemV/MST7 ================================================================== --- /dev/null +++ library/tzdata/SystemV/MST7 @@ -0,0 +1,5 @@ +# created by ../tools/tclZIC.tcl - do not edit +if {![info exists TZData(America/Phoenix)]} { + LoadTimeZoneFile America/Phoenix +} +set TZData(:SystemV/MST7) $TZData(:America/Phoenix) ADDED library/tzdata/SystemV/MST7MDT Index: library/tzdata/SystemV/MST7MDT ================================================================== --- /dev/null +++ library/tzdata/SystemV/MST7MDT @@ -0,0 +1,5 @@ +# created by ../tools/tclZIC.tcl - do not edit +if {![info exists TZData(America/Denver)]} { + LoadTimeZoneFile America/Denver +} +set TZData(:SystemV/MST7MDT) $TZData(:America/Denver) ADDED library/tzdata/SystemV/PST8 Index: library/tzdata/SystemV/PST8 ================================================================== --- /dev/null +++ library/tzdata/SystemV/PST8 @@ -0,0 +1,5 @@ +# created by ../tools/tclZIC.tcl - do not edit +if {![info exists TZData(Pacific/Pitcairn)]} { + LoadTimeZoneFile Pacific/Pitcairn +} +set TZData(:SystemV/PST8) $TZData(:Pacific/Pitcairn) ADDED library/tzdata/SystemV/PST8PDT Index: library/tzdata/SystemV/PST8PDT ================================================================== --- /dev/null +++ library/tzdata/SystemV/PST8PDT @@ -0,0 +1,5 @@ +# created by ../tools/tclZIC.tcl - do not edit +if {![info exists TZData(America/Los_Angeles)]} { + LoadTimeZoneFile America/Los_Angeles +} +set TZData(:SystemV/PST8PDT) $TZData(:America/Los_Angeles) ADDED library/tzdata/SystemV/YST9 Index: library/tzdata/SystemV/YST9 ================================================================== --- /dev/null +++ library/tzdata/SystemV/YST9 @@ -0,0 +1,5 @@ +# created by ../tools/tclZIC.tcl - do not edit +if {![info exists TZData(Pacific/Gambier)]} { + LoadTimeZoneFile Pacific/Gambier +} +set TZData(:SystemV/YST9) $TZData(:Pacific/Gambier) ADDED library/tzdata/SystemV/YST9YDT Index: library/tzdata/SystemV/YST9YDT ================================================================== --- /dev/null +++ library/tzdata/SystemV/YST9YDT @@ -0,0 +1,5 @@ +# created by ../tools/tclZIC.tcl - do not edit +if {![info exists TZData(America/Anchorage)]} { + LoadTimeZoneFile America/Anchorage +} +set TZData(:SystemV/YST9YDT) $TZData(:America/Anchorage) Index: library/word.tcl ================================================================== --- library/word.tcl +++ library/word.tcl @@ -9,18 +9,28 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # The following variables are used to determine which characters are -# interpreted as word characters. See bug [f1253530cdd8]. Will -# probably be removed in Tcl 9. - -if {![info exists ::tcl_wordchars]} { - set ::tcl_wordchars {\w} -} -if {![info exists ::tcl_nonwordchars]} { - set ::tcl_nonwordchars {\W} +# interpreted as white space. + +if {$::tcl_platform(platform) eq "windows"} { + # Windows style - any but a unicode space char + if {![info exists ::tcl_wordchars]} { + set ::tcl_wordchars {\S} + } + if {![info exists ::tcl_nonwordchars]} { + set ::tcl_nonwordchars {\s} + } +} else { + # Motif style - any unicode word char (number, letter, or underscore) + if {![info exists ::tcl_wordchars]} { + set ::tcl_wordchars {\w} + } + if {![info exists ::tcl_nonwordchars]} { + set ::tcl_nonwordchars {\W} + } } # Arrange for caches of the real matcher REs to be kept, which enables the REs # themselves to be cached for greater performance (and somewhat greater # clarity too). @@ -134,9 +144,11 @@ # start - Index into string specifying starting point. proc tcl_startOfPreviousWord {str start} { variable ::tcl::WordBreakRE set word {-1 -1} - regexp -indices -- $WordBreakRE(previous) [string range $str 0 $start-1] \ - result word + if {$start > 0} { + regexp -indices -- $WordBreakRE(previous) [string range $str 0 $start-1] \ + result word + } return [lindex $word 0] } Index: libtommath/README.md ================================================================== --- libtommath/README.md +++ libtommath/README.md @@ -1,25 +1,44 @@ # libtommath This is the git repository for [LibTomMath](http://www.libtom.net/LibTomMath/), a free open source portable number theoretic multiple-precision integer (MPI) library written entirely in C. ## Build Status + +### Travis CI master: [![Build Status](https://api.travis-ci.org/libtom/libtommath.png?branch=master)](https://travis-ci.org/libtom/libtommath) develop: [![Build Status](https://api.travis-ci.org/libtom/libtommath.png?branch=develop)](https://travis-ci.org/libtom/libtommath) +### AppVeyor + +master: [![Build status](https://ci.appveyor.com/api/projects/status/b80lpolw3i8m6hsh/branch/master?svg=true)](https://ci.appveyor.com/project/libtom/libtommath/branch/master) + +develop: [![Build status](https://ci.appveyor.com/api/projects/status/b80lpolw3i8m6hsh/branch/develop?svg=true)](https://ci.appveyor.com/project/libtom/libtommath/branch/develop) + +### ABI Laboratory + API/ABI changes: [check here](https://abi-laboratory.pro/tracker/timeline/libtommath/) ## Summary The `develop` branch contains the in-development version. Stable releases are tagged. -Documentation is built from the LaTeX file `bn.tex`. There is also limited documentation in `tommath.h`. There is also a document, `tommath.pdf`, which describes the goals of the project and many of the algorithms used. +Documentation is built from the LaTeX file `bn.tex`. There is also limited documentation in `tommath.h`. +There is also a document, `tommath.pdf`, which describes the goals of the project and many of the algorithms used. -The project can be build by using `make`. Along with the usual `make`, `make clean` and `make install`, there are several other build targets, see the makefile for details. There are also makefiles for certain specific platforms. +The project can be build by using `make`. Along with the usual `make`, `make clean` and `make install`, +there are several other build targets, see the makefile for details. +There are also makefiles for certain specific platforms. ## Testing Tests are located in `demo/` and can be built in two flavors. -* `make test` creates a test binary that is intended to be run against `mtest`. `mtest` can be built with `make mtest` and test execution is done like `./mtest/mtest | ./test`. `mtest` is creating test vectors using an alternative MPI library and `test` is consuming these vectors to verify correct behavior of ltm -* `make test_standalone` creates a stand-alone test binary that executes several test routines. +* `make test` creates a stand-alone test binary that executes several test routines. +* `make mtest_opponent` creates a test binary that is intended to be run against `mtest`. + `mtest` can be built with `make mtest` and test execution is done like `./mtest/mtest | ./mtest_opponent`. + `mtest` is creating test vectors using an alternative MPI library and `test` is consuming these vectors to verify correct behavior of ltm + +## Building and Installing + +Building is straightforward for GNU Linux only, the section "Building LibTomMath" in the documentation in `doc/bn.pdf` has the details. ADDED libtommath/appveyor.yml Index: libtommath/appveyor.yml ================================================================== --- /dev/null +++ libtommath/appveyor.yml @@ -0,0 +1,20 @@ +version: 1.2.0-{build} +branches: + only: + - master + - develop + - /^release/ + - /^travis/ +image: +- Visual Studio 2019 +- Visual Studio 2017 +- Visual Studio 2015 +build_script: +- cmd: >- + if "Visual Studio 2019"=="%APPVEYOR_BUILD_WORKER_IMAGE%" call "C:\Program Files (x86)\Microsoft Visual Studio\2019\Community\VC\Auxiliary\Build\vcvars64.bat" + if "Visual Studio 2017"=="%APPVEYOR_BUILD_WORKER_IMAGE%" call "C:\Program Files (x86)\Microsoft Visual Studio\2017\Community\VC\Auxiliary\Build\vcvars64.bat" + if "Visual Studio 2015"=="%APPVEYOR_BUILD_WORKER_IMAGE%" call "C:\Program Files\Microsoft SDKs\Windows\v7.1\Bin\SetEnv.cmd" /x64 + if "Visual Studio 2015"=="%APPVEYOR_BUILD_WORKER_IMAGE%" call "C:\Program Files (x86)\Microsoft Visual Studio 14.0\VC\vcvarsall.bat" x86_amd64 + nmake -f makefile.msvc all +test_script: +- cmd: test.exe Index: libtommath/astylerc ================================================================== --- libtommath/astylerc +++ libtommath/astylerc @@ -1,10 +1,13 @@ # Artistic Style, see http://astyle.sourceforge.net/ # full documentation, see: http://astyle.sourceforge.net/astyle.html # # usage: # astyle --options=astylerc *.[ch] + +# Do not create backup, annonying in the times of git +suffix=none ## Bracket Style Options style=kr ## Tab Options ADDED libtommath/bn_cutoffs.c Index: libtommath/bn_cutoffs.c ================================================================== --- /dev/null +++ libtommath/bn_cutoffs.c @@ -0,0 +1,14 @@ +#include "tommath_private.h" +#ifdef BN_CUTOFFS_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +#ifndef MP_FIXED_CUTOFFS +#include "tommath_cutoffs.h" +int KARATSUBA_MUL_CUTOFF = MP_DEFAULT_KARATSUBA_MUL_CUTOFF, + KARATSUBA_SQR_CUTOFF = MP_DEFAULT_KARATSUBA_SQR_CUTOFF, + TOOM_MUL_CUTOFF = MP_DEFAULT_TOOM_MUL_CUTOFF, + TOOM_SQR_CUTOFF = MP_DEFAULT_TOOM_SQR_CUTOFF; +#endif + +#endif ADDED libtommath/bn_deprecated.c Index: libtommath/bn_deprecated.c ================================================================== --- /dev/null +++ libtommath/bn_deprecated.c @@ -0,0 +1,321 @@ +#include "tommath_private.h" +#ifdef BN_DEPRECATED_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +#ifdef BN_MP_GET_BIT_C +int mp_get_bit(const mp_int *a, int b) +{ + if (b < 0) { + return MP_VAL; + } + return (s_mp_get_bit(a, (unsigned int)b) == MP_YES) ? MP_YES : MP_NO; +} +#endif +#ifdef BN_MP_JACOBI_C +mp_err mp_jacobi(const mp_int *a, const mp_int *n, int *c) +{ + if (a->sign == MP_NEG) { + return MP_VAL; + } + if (mp_cmp_d(n, 0uL) != MP_GT) { + return MP_VAL; + } + return mp_kronecker(a, n, c); +} +#endif +#ifdef BN_MP_PRIME_RANDOM_EX_C +mp_err mp_prime_random_ex(mp_int *a, int t, int size, int flags, private_mp_prime_callback cb, void *dat) +{ + return s_mp_prime_random_ex(a, t, size, flags, cb, dat); +} +#endif +#ifdef BN_MP_RAND_DIGIT_C +mp_err mp_rand_digit(mp_digit *r) +{ + mp_err err = s_mp_rand_source(r, sizeof(mp_digit)); + *r &= MP_MASK; + return err; +} +#endif +#ifdef BN_FAST_MP_INVMOD_C +mp_err fast_mp_invmod(const mp_int *a, const mp_int *b, mp_int *c) +{ + return s_mp_invmod_fast(a, b, c); +} +#endif +#ifdef BN_FAST_MP_MONTGOMERY_REDUCE_C +mp_err fast_mp_montgomery_reduce(mp_int *x, const mp_int *n, mp_digit rho) +{ + return s_mp_montgomery_reduce_fast(x, n, rho); +} +#endif +#ifdef BN_FAST_S_MP_MUL_DIGS_C +mp_err fast_s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs) +{ + return s_mp_mul_digs_fast(a, b, c, digs); +} +#endif +#ifdef BN_FAST_S_MP_MUL_HIGH_DIGS_C +mp_err fast_s_mp_mul_high_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs) +{ + return s_mp_mul_high_digs_fast(a, b, c, digs); +} +#endif +#ifdef BN_FAST_S_MP_SQR_C +mp_err fast_s_mp_sqr(const mp_int *a, mp_int *b) +{ + return s_mp_sqr_fast(a, b); +} +#endif +#ifdef BN_MP_BALANCE_MUL_C +mp_err mp_balance_mul(const mp_int *a, const mp_int *b, mp_int *c) +{ + return s_mp_balance_mul(a, b, c); +} +#endif +#ifdef BN_MP_EXPTMOD_FAST_C +mp_err mp_exptmod_fast(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y, int redmode) +{ + return s_mp_exptmod_fast(G, X, P, Y, redmode); +} +#endif +#ifdef BN_MP_INVMOD_SLOW_C +mp_err mp_invmod_slow(const mp_int *a, const mp_int *b, mp_int *c) +{ + return s_mp_invmod_slow(a, b, c); +} +#endif +#ifdef BN_MP_KARATSUBA_MUL_C +mp_err mp_karatsuba_mul(const mp_int *a, const mp_int *b, mp_int *c) +{ + return s_mp_karatsuba_mul(a, b, c); +} +#endif +#ifdef BN_MP_KARATSUBA_SQR_C +mp_err mp_karatsuba_sqr(const mp_int *a, mp_int *b) +{ + return s_mp_karatsuba_sqr(a, b); +} +#endif +#ifdef BN_MP_TOOM_MUL_C +mp_err mp_toom_mul(const mp_int *a, const mp_int *b, mp_int *c) +{ + return s_mp_toom_mul(a, b, c); +} +#endif +#ifdef BN_MP_TOOM_SQR_C +mp_err mp_toom_sqr(const mp_int *a, mp_int *b) +{ + return s_mp_toom_sqr(a, b); +} +#endif +#ifdef S_MP_REVERSE_C +void bn_reverse(unsigned char *s, int len) +{ + if (len > 0) { + s_mp_reverse(s, (size_t)len); + } +} +#endif +#ifdef BN_MP_TC_AND_C +mp_err mp_tc_and(const mp_int *a, const mp_int *b, mp_int *c) +{ + return mp_and(a, b, c); +} +#endif +#ifdef BN_MP_TC_OR_C +mp_err mp_tc_or(const mp_int *a, const mp_int *b, mp_int *c) +{ + return mp_or(a, b, c); +} +#endif +#ifdef BN_MP_TC_XOR_C +mp_err mp_tc_xor(const mp_int *a, const mp_int *b, mp_int *c) +{ + return mp_xor(a, b, c); +} +#endif +#ifdef BN_MP_TC_DIV_2D_C +mp_err mp_tc_div_2d(const mp_int *a, int b, mp_int *c) +{ + return mp_signed_rsh(a, b, c); +} +#endif +#ifdef BN_MP_INIT_SET_INT_C +mp_err mp_init_set_int(mp_int *a, unsigned long b) +{ + return mp_init_u32(a, (uint32_t)b); +} +#endif +#ifdef BN_MP_SET_INT_C +mp_err mp_set_int(mp_int *a, unsigned long b) +{ + mp_set_u32(a, (uint32_t)b); + return MP_OKAY; +} +#endif +#ifdef BN_MP_SET_LONG_C +mp_err mp_set_long(mp_int *a, unsigned long b) +{ + mp_set_u64(a, b); + return MP_OKAY; +} +#endif +#ifdef BN_MP_SET_LONG_LONG_C +mp_err mp_set_long_long(mp_int *a, unsigned long long b) +{ + mp_set_u64(a, b); + return MP_OKAY; +} +#endif +#ifdef BN_MP_GET_INT_C +unsigned long mp_get_int(const mp_int *a) +{ + return (unsigned long)mp_get_mag_u32(a); +} +#endif +#ifdef BN_MP_GET_LONG_C +unsigned long mp_get_long(const mp_int *a) +{ + return (unsigned long)mp_get_mag_ul(a); +} +#endif +#ifdef BN_MP_GET_LONG_LONG_C +unsigned long long mp_get_long_long(const mp_int *a) +{ + return mp_get_mag_ull(a); +} +#endif +#ifdef BN_MP_PRIME_IS_DIVISIBLE_C +mp_err mp_prime_is_divisible(const mp_int *a, mp_bool *result) +{ + return s_mp_prime_is_divisible(a, result); +} +#endif +#ifdef BN_MP_EXPT_D_EX_C +mp_err mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast) +{ + (void)fast; + if (b > MP_MIN(MP_DIGIT_MAX, UINT32_MAX)) { + return MP_VAL; + } + return mp_expt_u32(a, (uint32_t)b, c); +} +#endif +#ifdef BN_MP_EXPT_D_C +mp_err mp_expt_d(const mp_int *a, mp_digit b, mp_int *c) +{ + if (b > MP_MIN(MP_DIGIT_MAX, UINT32_MAX)) { + return MP_VAL; + } + return mp_expt_u32(a, (uint32_t)b, c); +} +#endif +#ifdef BN_MP_N_ROOT_EX_C +mp_err mp_n_root_ex(const mp_int *a, mp_digit b, mp_int *c, int fast) +{ + (void)fast; + if (b > MP_MIN(MP_DIGIT_MAX, UINT32_MAX)) { + return MP_VAL; + } + return mp_root_u32(a, (unsigned int)b, c); +} +#endif +#ifdef BN_MP_N_ROOT_C +mp_err mp_n_root(const mp_int *a, mp_digit b, mp_int *c) +{ + if (b > MP_MIN(MP_DIGIT_MAX, UINT32_MAX)) { + return MP_VAL; + } + return mp_root_u32(a, (unsigned int)b, c); +} +#endif +#ifdef BN_MP_UNSIGNED_BIN_SIZE_C +int mp_unsigned_bin_size(const mp_int *a) +{ + return (int)mp_ubin_size(a); +} +#endif +#ifdef BN_MP_READ_UNSIGNED_BIN_C +mp_err mp_read_unsigned_bin(mp_int *a, const unsigned char *b, int c) +{ + return mp_from_ubin(a, b, (size_t) c); +} +#endif +#ifdef BN_MP_TO_UNSIGNED_BIN_C +mp_err mp_to_unsigned_bin(const mp_int *a, unsigned char *b) +{ + return mp_to_ubin(a, b, SIZE_MAX, NULL); +} +#endif +#ifdef BN_MP_TO_UNSIGNED_BIN_N_C +mp_err mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen) +{ + size_t n = mp_ubin_size(a); + if (*outlen < (unsigned long)n) { + return MP_VAL; + } + *outlen = (unsigned long)n; + return mp_to_ubin(a, b, n, NULL); +} +#endif +#ifdef BN_MP_SIGNED_BIN_SIZE_C +int mp_signed_bin_size(const mp_int *a) +{ + return (int)mp_sbin_size(a); +} +#endif +#ifdef BN_MP_READ_SIGNED_BIN_C +mp_err mp_read_signed_bin(mp_int *a, const unsigned char *b, int c) +{ + return mp_from_sbin(a, b, (size_t) c); +} +#endif +#ifdef BN_MP_TO_SIGNED_BIN_C +mp_err mp_to_signed_bin(const mp_int *a, unsigned char *b) +{ + return mp_to_sbin(a, b, SIZE_MAX, NULL); +} +#endif +#ifdef BN_MP_TO_SIGNED_BIN_N_C +mp_err mp_to_signed_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen) +{ + size_t n = mp_sbin_size(a); + if (*outlen < (unsigned long)n) { + return MP_VAL; + } + *outlen = (unsigned long)n; + return mp_to_sbin(a, b, n, NULL); +} +#endif +#ifdef BN_MP_TORADIX_N_C +mp_err mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen) +{ + if (maxlen < 0) { + return MP_VAL; + } + return mp_to_radix(a, str, (size_t)maxlen, NULL, radix); +} +#endif +#ifdef BN_MP_TORADIX_C +mp_err mp_toradix(const mp_int *a, char *str, int radix) +{ + return mp_to_radix(a, str, SIZE_MAX, NULL, radix); +} +#endif +#ifdef BN_MP_IMPORT_C +mp_err mp_import(mp_int *rop, size_t count, int order, size_t size, int endian, size_t nails, + const void *op) +{ + return mp_unpack(rop, count, order, size, endian, nails, op); +} +#endif +#ifdef BN_MP_EXPORT_C +mp_err mp_export(void *rop, size_t *countp, int order, size_t size, + int endian, size_t nails, const mp_int *op) +{ + return mp_pack(rop, SIZE_MAX, countp, order, size, endian, nails, op); +} +#endif +#endif DELETED libtommath/bn_error.c Index: libtommath/bn_error.c ================================================================== --- libtommath/bn_error.c +++ /dev/null @@ -1,44 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_ERROR_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -static const struct { - int code; - const char *msg; -} msgs[] = { - { MP_OKAY, "Successful" }, - { MP_MEM, "Out of heap" }, - { MP_VAL, "Value out of range" } -}; - -/* return a char * string for a given code */ -const char *mp_error_to_string(int code) -{ - size_t x; - - /* scan the lookup table for the given message */ - for (x = 0; x < (sizeof(msgs) / sizeof(msgs[0])); x++) { - if (msgs[x].code == code) { - return msgs[x].msg; - } - } - - /* generic reply for invalid code */ - return "Invalid error code"; -} - -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ DELETED libtommath/bn_fast_mp_invmod.c Index: libtommath/bn_fast_mp_invmod.c ================================================================== --- libtommath/bn_fast_mp_invmod.c +++ /dev/null @@ -1,160 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_FAST_MP_INVMOD_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* computes the modular inverse via binary extended euclidean algorithm, - * that is c = 1/a mod b - * - * Based on slow invmod except this is optimized for the case where b is - * odd as per HAC Note 14.64 on pp. 610 - */ -int fast_mp_invmod(const mp_int *a, const mp_int *b, mp_int *c) -{ - mp_int x, y, u, v, B, D; - int res, neg; - - /* 2. [modified] b must be odd */ - if (mp_iseven(b) == MP_YES) { - return MP_VAL; - } - - /* init all our temps */ - if ((res = mp_init_multi(&x, &y, &u, &v, &B, &D, NULL)) != MP_OKAY) { - return res; - } - - /* x == modulus, y == value to invert */ - if ((res = mp_copy(b, &x)) != MP_OKAY) { - goto LBL_ERR; - } - - /* we need y = |a| */ - if ((res = mp_mod(a, b, &y)) != MP_OKAY) { - goto LBL_ERR; - } - - /* if one of x,y is zero return an error! */ - if ((mp_iszero(&x) == MP_YES) || (mp_iszero(&y) == MP_YES)) { - res = MP_VAL; - goto LBL_ERR; - } - - /* 3. u=x, v=y, A=1, B=0, C=0,D=1 */ - if ((res = mp_copy(&x, &u)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_copy(&y, &v)) != MP_OKAY) { - goto LBL_ERR; - } - mp_set(&D, 1uL); - -top: - /* 4. while u is even do */ - while (mp_iseven(&u) == MP_YES) { - /* 4.1 u = u/2 */ - if ((res = mp_div_2(&u, &u)) != MP_OKAY) { - goto LBL_ERR; - } - /* 4.2 if B is odd then */ - if (mp_isodd(&B) == MP_YES) { - if ((res = mp_sub(&B, &x, &B)) != MP_OKAY) { - goto LBL_ERR; - } - } - /* B = B/2 */ - if ((res = mp_div_2(&B, &B)) != MP_OKAY) { - goto LBL_ERR; - } - } - - /* 5. while v is even do */ - while (mp_iseven(&v) == MP_YES) { - /* 5.1 v = v/2 */ - if ((res = mp_div_2(&v, &v)) != MP_OKAY) { - goto LBL_ERR; - } - /* 5.2 if D is odd then */ - if (mp_isodd(&D) == MP_YES) { - /* D = (D-x)/2 */ - if ((res = mp_sub(&D, &x, &D)) != MP_OKAY) { - goto LBL_ERR; - } - } - /* D = D/2 */ - if ((res = mp_div_2(&D, &D)) != MP_OKAY) { - goto LBL_ERR; - } - } - - /* 6. if u >= v then */ - if (mp_cmp(&u, &v) != MP_LT) { - /* u = u - v, B = B - D */ - if ((res = mp_sub(&u, &v, &u)) != MP_OKAY) { - goto LBL_ERR; - } - - if ((res = mp_sub(&B, &D, &B)) != MP_OKAY) { - goto LBL_ERR; - } - } else { - /* v - v - u, D = D - B */ - if ((res = mp_sub(&v, &u, &v)) != MP_OKAY) { - goto LBL_ERR; - } - - if ((res = mp_sub(&D, &B, &D)) != MP_OKAY) { - goto LBL_ERR; - } - } - - /* if not zero goto step 4 */ - if (mp_iszero(&u) == MP_NO) { - goto top; - } - - /* now a = C, b = D, gcd == g*v */ - - /* if v != 1 then there is no inverse */ - if (mp_cmp_d(&v, 1uL) != MP_EQ) { - res = MP_VAL; - goto LBL_ERR; - } - - /* b is now the inverse */ - neg = a->sign; - while (D.sign == MP_NEG) { - if ((res = mp_add(&D, b, &D)) != MP_OKAY) { - goto LBL_ERR; - } - } - - /* too big */ - while (mp_cmp_mag(&D, b) != MP_LT) { - if ((res = mp_sub(&D, b, &D)) != MP_OKAY) { - goto LBL_ERR; - } - } - - mp_exch(&D, c); - c->sign = neg; - res = MP_OKAY; - -LBL_ERR: - mp_clear_multi(&x, &y, &u, &v, &B, &D, NULL); - return res; -} -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ DELETED libtommath/bn_fast_mp_montgomery_reduce.c Index: libtommath/bn_fast_mp_montgomery_reduce.c ================================================================== --- libtommath/bn_fast_mp_montgomery_reduce.c +++ /dev/null @@ -1,173 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_FAST_MP_MONTGOMERY_REDUCE_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* computes xR**-1 == x (mod N) via Montgomery Reduction - * - * This is an optimized implementation of montgomery_reduce - * which uses the comba method to quickly calculate the columns of the - * reduction. - * - * Based on Algorithm 14.32 on pp.601 of HAC. -*/ -int fast_mp_montgomery_reduce(mp_int *x, const mp_int *n, mp_digit rho) -{ - int ix, res, olduse; - mp_word W[MP_WARRAY]; - - if (x->used > (int)MP_WARRAY) { - return MP_VAL; - } - - /* get old used count */ - olduse = x->used; - - /* grow a as required */ - if (x->alloc < (n->used + 1)) { - if ((res = mp_grow(x, n->used + 1)) != MP_OKAY) { - return res; - } - } - - /* first we have to get the digits of the input into - * an array of double precision words W[...] - */ - { - mp_word *_W; - mp_digit *tmpx; - - /* alias for the W[] array */ - _W = W; - - /* alias for the digits of x*/ - tmpx = x->dp; - - /* copy the digits of a into W[0..a->used-1] */ - for (ix = 0; ix < x->used; ix++) { - *_W++ = *tmpx++; - } - - /* zero the high words of W[a->used..m->used*2] */ - for (; ix < ((n->used * 2) + 1); ix++) { - *_W++ = 0; - } - } - - /* now we proceed to zero successive digits - * from the least significant upwards - */ - for (ix = 0; ix < n->used; ix++) { - /* mu = ai * m' mod b - * - * We avoid a double precision multiplication (which isn't required) - * by casting the value down to a mp_digit. Note this requires - * that W[ix-1] have the carry cleared (see after the inner loop) - */ - mp_digit mu; - mu = ((W[ix] & MP_MASK) * rho) & MP_MASK; - - /* a = a + mu * m * b**i - * - * This is computed in place and on the fly. The multiplication - * by b**i is handled by offseting which columns the results - * are added to. - * - * Note the comba method normally doesn't handle carries in the - * inner loop In this case we fix the carry from the previous - * column since the Montgomery reduction requires digits of the - * result (so far) [see above] to work. This is - * handled by fixing up one carry after the inner loop. The - * carry fixups are done in order so after these loops the - * first m->used words of W[] have the carries fixed - */ - { - int iy; - mp_digit *tmpn; - mp_word *_W; - - /* alias for the digits of the modulus */ - tmpn = n->dp; - - /* Alias for the columns set by an offset of ix */ - _W = W + ix; - - /* inner loop */ - for (iy = 0; iy < n->used; iy++) { - *_W++ += (mp_word)mu * (mp_word)*tmpn++; - } - } - - /* now fix carry for next digit, W[ix+1] */ - W[ix + 1] += W[ix] >> (mp_word)DIGIT_BIT; - } - - /* now we have to propagate the carries and - * shift the words downward [all those least - * significant digits we zeroed]. - */ - { - mp_digit *tmpx; - mp_word *_W, *_W1; - - /* nox fix rest of carries */ - - /* alias for current word */ - _W1 = W + ix; - - /* alias for next word, where the carry goes */ - _W = W + ++ix; - - for (; ix <= ((n->used * 2) + 1); ix++) { - *_W++ += *_W1++ >> (mp_word)DIGIT_BIT; - } - - /* copy out, A = A/b**n - * - * The result is A/b**n but instead of converting from an - * array of mp_word to mp_digit than calling mp_rshd - * we just copy them in the right order - */ - - /* alias for destination word */ - tmpx = x->dp; - - /* alias for shifted double precision result */ - _W = W + n->used; - - for (ix = 0; ix < (n->used + 1); ix++) { - *tmpx++ = *_W++ & (mp_word)MP_MASK; - } - - /* zero oldused digits, if the input a was larger than - * m->used+1 we'll have to clear the digits - */ - for (; ix < olduse; ix++) { - *tmpx++ = 0; - } - } - - /* set the max used and clamp */ - x->used = n->used + 1; - mp_clamp(x); - - /* if A >= m then A = A - m */ - if (mp_cmp_mag(x, n) != MP_LT) { - return s_mp_sub(x, n, x); - } - return MP_OKAY; -} -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ DELETED libtommath/bn_fast_s_mp_mul_digs.c Index: libtommath/bn_fast_s_mp_mul_digs.c ================================================================== --- libtommath/bn_fast_s_mp_mul_digs.c +++ /dev/null @@ -1,104 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_FAST_S_MP_MUL_DIGS_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* Fast (comba) multiplier - * - * This is the fast column-array [comba] multiplier. It is - * designed to compute the columns of the product first - * then handle the carries afterwards. This has the effect - * of making the nested loops that compute the columns very - * simple and schedulable on super-scalar processors. - * - * This has been modified to produce a variable number of - * digits of output so if say only a half-product is required - * you don't have to compute the upper half (a feature - * required for fast Barrett reduction). - * - * Based on Algorithm 14.12 on pp.595 of HAC. - * - */ -int fast_s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs) -{ - int olduse, res, pa, ix, iz; - mp_digit W[MP_WARRAY]; - mp_word _W; - - /* grow the destination as required */ - if (c->alloc < digs) { - if ((res = mp_grow(c, digs)) != MP_OKAY) { - return res; - } - } - - /* number of output digits to produce */ - pa = MIN(digs, a->used + b->used); - - /* clear the carry */ - _W = 0; - for (ix = 0; ix < pa; ix++) { - int tx, ty; - int iy; - mp_digit *tmpx, *tmpy; - - /* get offsets into the two bignums */ - ty = MIN(b->used-1, ix); - tx = ix - ty; - - /* setup temp aliases */ - tmpx = a->dp + tx; - tmpy = b->dp + ty; - - /* this is the number of times the loop will iterrate, essentially - while (tx++ < a->used && ty-- >= 0) { ... } - */ - iy = MIN(a->used-tx, ty+1); - - /* execute loop */ - for (iz = 0; iz < iy; ++iz) { - _W += (mp_word)*tmpx++ * (mp_word)*tmpy--; - - } - - /* store term */ - W[ix] = (mp_digit)_W & MP_MASK; - - /* make next carry */ - _W = _W >> (mp_word)DIGIT_BIT; - } - - /* setup dest */ - olduse = c->used; - c->used = pa; - - { - mp_digit *tmpc; - tmpc = c->dp; - for (ix = 0; ix < pa; ix++) { - /* now extract the previous digit [below the carry] */ - *tmpc++ = W[ix]; - } - - /* clear unused digits [that existed in the old copy of c] */ - for (; ix < olduse; ix++) { - *tmpc++ = 0; - } - } - mp_clamp(c); - return MP_OKAY; -} -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ DELETED libtommath/bn_fast_s_mp_mul_high_digs.c Index: libtommath/bn_fast_s_mp_mul_high_digs.c ================================================================== --- libtommath/bn_fast_s_mp_mul_high_digs.c +++ /dev/null @@ -1,95 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_FAST_S_MP_MUL_HIGH_DIGS_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* this is a modified version of fast_s_mul_digs that only produces - * output digits *above* digs. See the comments for fast_s_mul_digs - * to see how it works. - * - * This is used in the Barrett reduction since for one of the multiplications - * only the higher digits were needed. This essentially halves the work. - * - * Based on Algorithm 14.12 on pp.595 of HAC. - */ -int fast_s_mp_mul_high_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs) -{ - int olduse, res, pa, ix, iz; - mp_digit W[MP_WARRAY]; - mp_word _W; - - /* grow the destination as required */ - pa = a->used + b->used; - if (c->alloc < pa) { - if ((res = mp_grow(c, pa)) != MP_OKAY) { - return res; - } - } - - /* number of output digits to produce */ - pa = a->used + b->used; - _W = 0; - for (ix = digs; ix < pa; ix++) { - int tx, ty, iy; - mp_digit *tmpx, *tmpy; - - /* get offsets into the two bignums */ - ty = MIN(b->used-1, ix); - tx = ix - ty; - - /* setup temp aliases */ - tmpx = a->dp + tx; - tmpy = b->dp + ty; - - /* this is the number of times the loop will iterrate, essentially its - while (tx++ < a->used && ty-- >= 0) { ... } - */ - iy = MIN(a->used-tx, ty+1); - - /* execute loop */ - for (iz = 0; iz < iy; iz++) { - _W += (mp_word)*tmpx++ * (mp_word)*tmpy--; - } - - /* store term */ - W[ix] = (mp_digit)_W & MP_MASK; - - /* make next carry */ - _W = _W >> (mp_word)DIGIT_BIT; - } - - /* setup dest */ - olduse = c->used; - c->used = pa; - - { - mp_digit *tmpc; - - tmpc = c->dp + digs; - for (ix = digs; ix < pa; ix++) { - /* now extract the previous digit [below the carry] */ - *tmpc++ = W[ix]; - } - - /* clear unused digits [that existed in the old copy of c] */ - for (; ix < olduse; ix++) { - *tmpc++ = 0; - } - } - mp_clamp(c); - return MP_OKAY; -} -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ DELETED libtommath/bn_fast_s_mp_sqr.c Index: libtommath/bn_fast_s_mp_sqr.c ================================================================== --- libtommath/bn_fast_s_mp_sqr.c +++ /dev/null @@ -1,111 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_FAST_S_MP_SQR_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* the jist of squaring... - * you do like mult except the offset of the tmpx [one that - * starts closer to zero] can't equal the offset of tmpy. - * So basically you set up iy like before then you min it with - * (ty-tx) so that it never happens. You double all those - * you add in the inner loop - -After that loop you do the squares and add them in. -*/ - -int fast_s_mp_sqr(const mp_int *a, mp_int *b) -{ - int olduse, res, pa, ix, iz; - mp_digit W[MP_WARRAY], *tmpx; - mp_word W1; - - /* grow the destination as required */ - pa = a->used + a->used; - if (b->alloc < pa) { - if ((res = mp_grow(b, pa)) != MP_OKAY) { - return res; - } - } - - /* number of output digits to produce */ - W1 = 0; - for (ix = 0; ix < pa; ix++) { - int tx, ty, iy; - mp_word _W; - mp_digit *tmpy; - - /* clear counter */ - _W = 0; - - /* get offsets into the two bignums */ - ty = MIN(a->used-1, ix); - tx = ix - ty; - - /* setup temp aliases */ - tmpx = a->dp + tx; - tmpy = a->dp + ty; - - /* this is the number of times the loop will iterrate, essentially - while (tx++ < a->used && ty-- >= 0) { ... } - */ - iy = MIN(a->used-tx, ty+1); - - /* now for squaring tx can never equal ty - * we halve the distance since they approach at a rate of 2x - * and we have to round because odd cases need to be executed - */ - iy = MIN(iy, ((ty-tx)+1)>>1); - - /* execute loop */ - for (iz = 0; iz < iy; iz++) { - _W += (mp_word)*tmpx++ * (mp_word)*tmpy--; - } - - /* double the inner product and add carry */ - _W = _W + _W + W1; - - /* even columns have the square term in them */ - if (((unsigned)ix & 1u) == 0u) { - _W += (mp_word)a->dp[ix>>1] * (mp_word)a->dp[ix>>1]; - } - - /* store it */ - W[ix] = _W & MP_MASK; - - /* make next carry */ - W1 = _W >> (mp_word)DIGIT_BIT; - } - - /* setup dest */ - olduse = b->used; - b->used = a->used+a->used; - - { - mp_digit *tmpb; - tmpb = b->dp; - for (ix = 0; ix < pa; ix++) { - *tmpb++ = W[ix] & MP_MASK; - } - - /* clear unused digits [that existed in the old copy of c] */ - for (; ix < olduse; ix++) { - *tmpb++ = 0; - } - } - mp_clamp(b); - return MP_OKAY; -} -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_2expt.c ================================================================== --- libtommath/bn_mp_2expt.c +++ libtommath/bn_mp_2expt.c @@ -1,44 +1,31 @@ #include "tommath_private.h" #ifdef BN_MP_2EXPT_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* computes a = 2**b * * Simple algorithm which zeroes the int, grows it then just sets one bit * as required. */ -int mp_2expt(mp_int *a, int b) +mp_err mp_2expt(mp_int *a, int b) { - int res; + mp_err err; /* zero a as per default */ mp_zero(a); /* grow a to accomodate the single bit */ - if ((res = mp_grow(a, (b / DIGIT_BIT) + 1)) != MP_OKAY) { - return res; + if ((err = mp_grow(a, (b / MP_DIGIT_BIT) + 1)) != MP_OKAY) { + return err; } /* set the used count of where the bit will go */ - a->used = (b / DIGIT_BIT) + 1; + a->used = (b / MP_DIGIT_BIT) + 1; /* put the single bit in its place */ - a->dp[b / DIGIT_BIT] = (mp_digit)1 << (mp_digit)(b % DIGIT_BIT); + a->dp[b / MP_DIGIT_BIT] = (mp_digit)1 << (mp_digit)(b % MP_DIGIT_BIT); return MP_OKAY; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_abs.c ================================================================== --- libtommath/bn_mp_abs.c +++ libtommath/bn_mp_abs.c @@ -1,39 +1,26 @@ #include "tommath_private.h" #ifdef BN_MP_ABS_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* b = |a| * * Simple function copies the input and fixes the sign to positive */ -int mp_abs(const mp_int *a, mp_int *b) +mp_err mp_abs(const mp_int *a, mp_int *b) { - int res; + mp_err err; /* copy a to b */ if (a != b) { - if ((res = mp_copy(a, b)) != MP_OKAY) { - return res; + if ((err = mp_copy(a, b)) != MP_OKAY) { + return err; } } /* force the sign of b to positive */ b->sign = MP_ZPOS; return MP_OKAY; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_add.c ================================================================== --- libtommath/bn_mp_add.c +++ libtommath/bn_mp_add.c @@ -1,23 +1,15 @@ #include "tommath_private.h" #ifdef BN_MP_ADD_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* high level addition (handles signs) */ -int mp_add(const mp_int *a, const mp_int *b, mp_int *c) +mp_err mp_add(const mp_int *a, const mp_int *b, mp_int *c) { - int sa, sb, res; + mp_sign sa, sb; + mp_err err; /* get sign of both inputs */ sa = a->sign; sb = b->sign; @@ -24,27 +16,23 @@ /* handle two cases, not four */ if (sa == sb) { /* both positive or both negative */ /* add their magnitudes, copy the sign */ c->sign = sa; - res = s_mp_add(a, b, c); + err = s_mp_add(a, b, c); } else { /* one positive, the other negative */ /* subtract the one with the greater magnitude from */ /* the one of the lesser magnitude. The result gets */ /* the sign of the one with the greater magnitude. */ if (mp_cmp_mag(a, b) == MP_LT) { c->sign = sb; - res = s_mp_sub(b, a, c); + err = s_mp_sub(b, a, c); } else { c->sign = sa; - res = s_mp_sub(a, b, c); + err = s_mp_sub(a, b, c); } } - return res; + return err; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_add_d.c ================================================================== --- libtommath/bn_mp_add_d.c +++ libtommath/bn_mp_add_d.c @@ -1,29 +1,21 @@ #include "tommath_private.h" #ifdef BN_MP_ADD_D_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* single digit addition */ -int mp_add_d(const mp_int *a, mp_digit b, mp_int *c) +mp_err mp_add_d(const mp_int *a, mp_digit b, mp_int *c) { - int res, ix, oldused; - mp_digit *tmpa, *tmpc, mu; + mp_err err; + int ix, oldused; + mp_digit *tmpa, *tmpc; /* grow c as required */ if (c->alloc < (a->used + 1)) { - if ((res = mp_grow(c, a->used + 1)) != MP_OKAY) { - return res; + if ((err = mp_grow(c, a->used + 1)) != MP_OKAY) { + return err; } } /* if a is negative and |a| >= b, call c = |a| - b */ if ((a->sign == MP_NEG) && ((a->used > 1) || (a->dp[0] >= b))) { @@ -30,19 +22,19 @@ mp_int a_ = *a; /* temporarily fix sign of a */ a_.sign = MP_ZPOS; /* c = |a| - b */ - res = mp_sub_d(&a_, b, c); + err = mp_sub_d(&a_, b, c); /* fix sign */ c->sign = MP_NEG; /* clamp */ mp_clamp(c); - return res; + return err; } /* old number of used digits in c */ oldused = c->used; @@ -52,21 +44,15 @@ /* destination alias */ tmpc = c->dp; /* if a is positive */ if (a->sign == MP_ZPOS) { - /* add digit, after this we're propagating - * the carry. - */ - *tmpc = *tmpa++ + b; - mu = *tmpc >> DIGIT_BIT; - *tmpc++ &= MP_MASK; - - /* now handle rest of the digits */ - for (ix = 1; ix < a->used; ix++) { + /* add digits, mu is carry */ + mp_digit mu = b; + for (ix = 0; ix < a->used; ix++) { *tmpc = *tmpa++ + mu; - mu = *tmpc >> DIGIT_BIT; + mu = *tmpc >> MP_DIGIT_BIT; *tmpc++ &= MP_MASK; } /* set final carry */ ix++; *tmpc++ = mu; @@ -92,18 +78,12 @@ /* sign always positive */ c->sign = MP_ZPOS; /* now zero to oldused */ - while (ix++ < oldused) { - *tmpc++ = 0; - } + MP_ZERO_DIGITS(tmpc, oldused - ix); mp_clamp(c); return MP_OKAY; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_addmod.c ================================================================== --- libtommath/bn_mp_addmod.c +++ libtommath/bn_mp_addmod.c @@ -1,37 +1,25 @@ #include "tommath_private.h" #ifdef BN_MP_ADDMOD_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* d = a + b (mod c) */ -int mp_addmod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d) +mp_err mp_addmod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d) { - int res; + mp_err err; mp_int t; - if ((res = mp_init(&t)) != MP_OKAY) { - return res; - } - - if ((res = mp_add(a, b, &t)) != MP_OKAY) { - mp_clear(&t); - return res; - } - res = mp_mod(&t, c, d); - mp_clear(&t); - return res; + if ((err = mp_init(&t)) != MP_OKAY) { + return err; + } + + if ((err = mp_add(a, b, &t)) != MP_OKAY) { + goto LBL_ERR; + } + err = mp_mod(&t, c, d); + +LBL_ERR: + mp_clear(&t); + return err; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_and.c ================================================================== --- libtommath/bn_mp_and.c +++ libtommath/bn_mp_and.c @@ -4,11 +4,11 @@ /* SPDX-License-Identifier: Unlicense */ /* two complement and */ mp_err mp_and(const mp_int *a, const mp_int *b, mp_int *c) { - int used = MAX(a->used, b->used) + 1, i; + int used = MP_MAX(a->used, b->used) + 1, i; mp_err err; mp_digit ac = 1, bc = 1, cc = 1; mp_sign csign = ((a->sign == MP_NEG) && (b->sign == MP_NEG)) ? MP_NEG : MP_ZPOS; if (c->alloc < used) { Index: libtommath/bn_mp_clamp.c ================================================================== --- libtommath/bn_mp_clamp.c +++ libtommath/bn_mp_clamp.c @@ -1,18 +1,9 @@ #include "tommath_private.h" #ifdef BN_MP_CLAMP_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* trim unused digits * * This is used to ensure that leading zero digits are * trimed and the leading "used" digit will be non-zero @@ -32,9 +23,5 @@ if (a->used == 0) { a->sign = MP_ZPOS; } } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_clear.c ================================================================== --- libtommath/bn_mp_clear.c +++ libtommath/bn_mp_clear.c @@ -1,40 +1,20 @@ #include "tommath_private.h" #ifdef BN_MP_CLEAR_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* clear one (frees) */ void mp_clear(mp_int *a) { - int i; - /* only do anything if a hasn't been freed previously */ if (a->dp != NULL) { - /* first zero the digits */ - for (i = 0; i < a->used; i++) { - a->dp[i] = 0; - } - /* free ram */ - XFREE(a->dp, sizeof (mp_digit) * (size_t)a->alloc); + MP_FREE_DIGITS(a->dp, a->alloc); /* reset members to make debugging easier */ a->dp = NULL; a->alloc = a->used = 0; a->sign = MP_ZPOS; } } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_clear_multi.c ================================================================== --- libtommath/bn_mp_clear_multi.c +++ libtommath/bn_mp_clear_multi.c @@ -1,18 +1,9 @@ #include "tommath_private.h" #ifdef BN_MP_CLEAR_MULTI_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ #include void mp_clear_multi(mp_int *mp, ...) { @@ -24,9 +15,5 @@ next_mp = va_arg(args, mp_int *); } va_end(args); } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_cnt_lsb.c ================================================================== --- libtommath/bn_mp_cnt_lsb.c +++ libtommath/bn_mp_cnt_lsb.c @@ -1,18 +1,9 @@ #include "tommath_private.h" #ifdef BN_MP_CNT_LSB_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ static const int lnz[16] = { 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0 }; @@ -21,18 +12,18 @@ { int x; mp_digit q, qq; /* easy out */ - if (mp_iszero(a) == MP_YES) { + if (MP_IS_ZERO(a)) { return 0; } /* scan lower digits until non-zero */ for (x = 0; (x < a->used) && (a->dp[x] == 0u); x++) {} q = a->dp[x]; - x *= DIGIT_BIT; + x *= MP_DIGIT_BIT; /* now scan this digit until a 1 is found */ if ((q & 1u) == 0u) { do { qq = q & 15u; @@ -42,9 +33,5 @@ } return x; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_complement.c ================================================================== --- libtommath/bn_mp_complement.c +++ libtommath/bn_mp_complement.c @@ -1,25 +1,12 @@ #include "tommath_private.h" #ifdef BN_MP_COMPLEMENT_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* b = ~a */ -int mp_complement(const mp_int *a, mp_int *b) +mp_err mp_complement(const mp_int *a, mp_int *b) { - int res = mp_neg(a, b); - return (res == MP_OKAY) ? mp_sub_d(b, 1uL, b) : res; + mp_err err = mp_neg(a, b); + return (err == MP_OKAY) ? mp_sub_d(b, 1uL, b) : err; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_copy.c ================================================================== --- libtommath/bn_mp_copy.c +++ libtommath/bn_mp_copy.c @@ -1,64 +1,47 @@ #include "tommath_private.h" #ifdef BN_MP_COPY_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* copy, b = a */ -int mp_copy(const mp_int *a, mp_int *b) +mp_err mp_copy(const mp_int *a, mp_int *b) { - int res, n; + int n; + mp_digit *tmpa, *tmpb; + mp_err err; /* if dst == src do nothing */ if (a == b) { return MP_OKAY; } /* grow dest */ if (b->alloc < a->used) { - if ((res = mp_grow(b, a->used)) != MP_OKAY) { - return res; + if ((err = mp_grow(b, a->used)) != MP_OKAY) { + return err; } } /* zero b and copy the parameters over */ - { - mp_digit *tmpa, *tmpb; - - /* pointer aliases */ - - /* source */ - tmpa = a->dp; - - /* destination */ - tmpb = b->dp; - - /* copy all the digits */ - for (n = 0; n < a->used; n++) { - *tmpb++ = *tmpa++; - } - - /* clear high digits */ - for (; n < b->used; n++) { - *tmpb++ = 0; - } - } + /* pointer aliases */ + + /* source */ + tmpa = a->dp; + + /* destination */ + tmpb = b->dp; + + /* copy all the digits */ + for (n = 0; n < a->used; n++) { + *tmpb++ = *tmpa++; + } + + /* clear high digits */ + MP_ZERO_DIGITS(tmpb, b->used - n); /* copy used count and sign */ b->used = a->used; b->sign = a->sign; return MP_OKAY; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_count_bits.c ================================================================== --- libtommath/bn_mp_count_bits.c +++ libtommath/bn_mp_count_bits.c @@ -1,41 +1,28 @@ #include "tommath_private.h" #ifdef BN_MP_COUNT_BITS_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* returns the number of bits in an int */ int mp_count_bits(const mp_int *a) { int r; mp_digit q; /* shortcut */ - if (a->used == 0) { + if (MP_IS_ZERO(a)) { return 0; } /* get number of digits and add that */ - r = (a->used - 1) * DIGIT_BIT; + r = (a->used - 1) * MP_DIGIT_BIT; /* take the last digit and count the bits in it */ q = a->dp[a->used - 1]; - while (q > (mp_digit)0) { + while (q > 0u) { ++r; - q >>= (mp_digit)1; + q >>= 1u; } return r; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ ADDED libtommath/bn_mp_decr.c Index: libtommath/bn_mp_decr.c ================================================================== --- /dev/null +++ libtommath/bn_mp_decr.c @@ -0,0 +1,34 @@ +#include "tommath_private.h" +#ifdef BN_MP_DECR_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +/* Decrement "a" by one like "a--". Changes input! */ +mp_err mp_decr(mp_int *a) +{ + if (MP_IS_ZERO(a)) { + mp_set(a,1uL); + a->sign = MP_NEG; + return MP_OKAY; + } else if (a->sign == MP_NEG) { + mp_err err; + a->sign = MP_ZPOS; + if ((err = mp_incr(a)) != MP_OKAY) { + return err; + } + /* There is no -0 in LTM */ + if (!MP_IS_ZERO(a)) { + a->sign = MP_NEG; + } + return MP_OKAY; + } else if (a->dp[0] > 1uL) { + a->dp[0]--; + if (a->dp[0] == 0u) { + mp_zero(a); + } + return MP_OKAY; + } else { + return mp_sub_d(a, 1uL,a); + } +} +#endif Index: libtommath/bn_mp_div.c ================================================================== --- libtommath/bn_mp_div.c +++ libtommath/bn_mp_div.c @@ -1,87 +1,73 @@ #include "tommath_private.h" #ifdef BN_MP_DIV_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ #ifdef BN_MP_DIV_SMALL /* slower bit-bang division... also smaller */ -int mp_div(const mp_int *a, const mp_int *b, mp_int *c, mp_int *d) +mp_err mp_div(const mp_int *a, const mp_int *b, mp_int *c, mp_int *d) { mp_int ta, tb, tq, q; - int res, n, n2; + int n, n2; + mp_err err; /* is divisor zero ? */ - if (mp_iszero(b) == MP_YES) { + if (MP_IS_ZERO(b)) { return MP_VAL; } /* if a < b then q=0, r = a */ if (mp_cmp_mag(a, b) == MP_LT) { if (d != NULL) { - res = mp_copy(a, d); + err = mp_copy(a, d); } else { - res = MP_OKAY; + err = MP_OKAY; } if (c != NULL) { mp_zero(c); } - return res; + return err; } /* init our temps */ - if ((res = mp_init_multi(&ta, &tb, &tq, &q, NULL)) != MP_OKAY) { - return res; + if ((err = mp_init_multi(&ta, &tb, &tq, &q, NULL)) != MP_OKAY) { + return err; } mp_set(&tq, 1uL); n = mp_count_bits(a) - mp_count_bits(b); - if (((res = mp_abs(a, &ta)) != MP_OKAY) || - ((res = mp_abs(b, &tb)) != MP_OKAY) || - ((res = mp_mul_2d(&tb, n, &tb)) != MP_OKAY) || - ((res = mp_mul_2d(&tq, n, &tq)) != MP_OKAY)) { - goto LBL_ERR; - } + if ((err = mp_abs(a, &ta)) != MP_OKAY) goto LBL_ERR; + if ((err = mp_abs(b, &tb)) != MP_OKAY) goto LBL_ERR; + if ((err = mp_mul_2d(&tb, n, &tb)) != MP_OKAY) goto LBL_ERR; + if ((err = mp_mul_2d(&tq, n, &tq)) != MP_OKAY) goto LBL_ERR; while (n-- >= 0) { if (mp_cmp(&tb, &ta) != MP_GT) { - if (((res = mp_sub(&ta, &tb, &ta)) != MP_OKAY) || - ((res = mp_add(&q, &tq, &q)) != MP_OKAY)) { - goto LBL_ERR; - } - } - if (((res = mp_div_2d(&tb, 1, &tb, NULL)) != MP_OKAY) || - ((res = mp_div_2d(&tq, 1, &tq, NULL)) != MP_OKAY)) { - goto LBL_ERR; - } + if ((err = mp_sub(&ta, &tb, &ta)) != MP_OKAY) goto LBL_ERR; + if ((err = mp_add(&q, &tq, &q)) != MP_OKAY) goto LBL_ERR; + } + if ((err = mp_div_2d(&tb, 1, &tb, NULL)) != MP_OKAY) goto LBL_ERR; + if ((err = mp_div_2d(&tq, 1, &tq, NULL)) != MP_OKAY) goto LBL_ERR; } /* now q == quotient and ta == remainder */ n = a->sign; n2 = (a->sign == b->sign) ? MP_ZPOS : MP_NEG; if (c != NULL) { mp_exch(c, &q); - c->sign = (mp_iszero(c) == MP_YES) ? MP_ZPOS : n2; + c->sign = MP_IS_ZERO(c) ? MP_ZPOS : n2; } if (d != NULL) { mp_exch(d, &ta); - d->sign = (mp_iszero(d) == MP_YES) ? MP_ZPOS : n; + d->sign = MP_IS_ZERO(d) ? MP_ZPOS : n; } LBL_ERR: mp_clear_multi(&ta, &tb, &tq, &q, NULL); - return res; + return err; } #else /* integer signed division. @@ -95,86 +81,73 @@ * case that y has fewer than three digits, etc.. * * The overall algorithm is as described as * 14.20 from HAC but fixed to treat these cases. */ -int mp_div(const mp_int *a, const mp_int *b, mp_int *c, mp_int *d) +mp_err mp_div(const mp_int *a, const mp_int *b, mp_int *c, mp_int *d) { mp_int q, x, y, t1, t2; - int res, n, t, i, norm, neg; + int n, t, i, norm; + mp_sign neg; + mp_err err; /* is divisor zero ? */ - if (mp_iszero(b) == MP_YES) { + if (MP_IS_ZERO(b)) { return MP_VAL; } /* if a < b then q=0, r = a */ if (mp_cmp_mag(a, b) == MP_LT) { if (d != NULL) { - res = mp_copy(a, d); + err = mp_copy(a, d); } else { - res = MP_OKAY; + err = MP_OKAY; } if (c != NULL) { mp_zero(c); } - return res; + return err; } - if ((res = mp_init_size(&q, a->used + 2)) != MP_OKAY) { - return res; + if ((err = mp_init_size(&q, a->used + 2)) != MP_OKAY) { + return err; } q.used = a->used + 2; - if ((res = mp_init(&t1)) != MP_OKAY) { - goto LBL_Q; - } - - if ((res = mp_init(&t2)) != MP_OKAY) { - goto LBL_T1; - } - - if ((res = mp_init_copy(&x, a)) != MP_OKAY) { - goto LBL_T2; - } - - if ((res = mp_init_copy(&y, b)) != MP_OKAY) { - goto LBL_X; - } + if ((err = mp_init(&t1)) != MP_OKAY) goto LBL_Q; + + if ((err = mp_init(&t2)) != MP_OKAY) goto LBL_T1; + + if ((err = mp_init_copy(&x, a)) != MP_OKAY) goto LBL_T2; + + if ((err = mp_init_copy(&y, b)) != MP_OKAY) goto LBL_X; /* fix the sign */ neg = (a->sign == b->sign) ? MP_ZPOS : MP_NEG; x.sign = y.sign = MP_ZPOS; - /* normalize both x and y, ensure that y >= b/2, [b == 2**DIGIT_BIT] */ - norm = mp_count_bits(&y) % DIGIT_BIT; - if (norm < (DIGIT_BIT - 1)) { - norm = (DIGIT_BIT - 1) - norm; - if ((res = mp_mul_2d(&x, norm, &x)) != MP_OKAY) { - goto LBL_Y; - } - if ((res = mp_mul_2d(&y, norm, &y)) != MP_OKAY) { - goto LBL_Y; - } + /* normalize both x and y, ensure that y >= b/2, [b == 2**MP_DIGIT_BIT] */ + norm = mp_count_bits(&y) % MP_DIGIT_BIT; + if (norm < (MP_DIGIT_BIT - 1)) { + norm = (MP_DIGIT_BIT - 1) - norm; + if ((err = mp_mul_2d(&x, norm, &x)) != MP_OKAY) goto LBL_Y; + if ((err = mp_mul_2d(&y, norm, &y)) != MP_OKAY) goto LBL_Y; } else { norm = 0; } /* note hac does 0 based, so if used==5 then its 0,1,2,3,4, e.g. use 4 */ n = x.used - 1; t = y.used - 1; /* while (x >= y*b**n-t) do { q[n-t] += 1; x -= y*b**{n-t} } */ - if ((res = mp_lshd(&y, n - t)) != MP_OKAY) { /* y = y*b**{n-t} */ - goto LBL_Y; - } + /* y = y*b**{n-t} */ + if ((err = mp_lshd(&y, n - t)) != MP_OKAY) goto LBL_Y; while (mp_cmp(&x, &y) != MP_LT) { ++(q.dp[n - t]); - if ((res = mp_sub(&x, &y, &x)) != MP_OKAY) { - goto LBL_Y; - } + if ((err = mp_sub(&x, &y, &x)) != MP_OKAY) goto LBL_Y; } /* reset y by shifting it back down */ mp_rshd(&y, n - t); @@ -185,14 +158,14 @@ } /* step 3.1 if xi == yt then set q{i-t-1} to b-1, * otherwise set q{i-t-1} to (xi*b + x{i-1})/yt */ if (x.dp[i] == y.dp[t]) { - q.dp[(i - t) - 1] = ((mp_digit)1 << (mp_digit)DIGIT_BIT) - (mp_digit)1; + q.dp[(i - t) - 1] = ((mp_digit)1 << (mp_digit)MP_DIGIT_BIT) - (mp_digit)1; } else { mp_word tmp; - tmp = (mp_word)x.dp[i] << (mp_word)DIGIT_BIT; + tmp = (mp_word)x.dp[i] << (mp_word)MP_DIGIT_BIT; tmp |= (mp_word)x.dp[i - 1]; tmp /= (mp_word)y.dp[t]; if (tmp > (mp_word)MP_MASK) { tmp = MP_MASK; } @@ -211,45 +184,31 @@ /* find left hand */ mp_zero(&t1); t1.dp[0] = ((t - 1) < 0) ? 0u : y.dp[t - 1]; t1.dp[1] = y.dp[t]; t1.used = 2; - if ((res = mp_mul_d(&t1, q.dp[(i - t) - 1], &t1)) != MP_OKAY) { - goto LBL_Y; - } + if ((err = mp_mul_d(&t1, q.dp[(i - t) - 1], &t1)) != MP_OKAY) goto LBL_Y; /* find right hand */ t2.dp[0] = ((i - 2) < 0) ? 0u : x.dp[i - 2]; - t2.dp[1] = ((i - 1) < 0) ? 0u : x.dp[i - 1]; + t2.dp[1] = x.dp[i - 1]; /* i >= 1 always holds */ t2.dp[2] = x.dp[i]; t2.used = 3; } while (mp_cmp_mag(&t1, &t2) == MP_GT); /* step 3.3 x = x - q{i-t-1} * y * b**{i-t-1} */ - if ((res = mp_mul_d(&y, q.dp[(i - t) - 1], &t1)) != MP_OKAY) { - goto LBL_Y; - } - - if ((res = mp_lshd(&t1, (i - t) - 1)) != MP_OKAY) { - goto LBL_Y; - } - - if ((res = mp_sub(&x, &t1, &x)) != MP_OKAY) { - goto LBL_Y; - } + if ((err = mp_mul_d(&y, q.dp[(i - t) - 1], &t1)) != MP_OKAY) goto LBL_Y; + + if ((err = mp_lshd(&t1, (i - t) - 1)) != MP_OKAY) goto LBL_Y; + + if ((err = mp_sub(&x, &t1, &x)) != MP_OKAY) goto LBL_Y; /* if x < 0 then { x = x + y*b**{i-t-1}; q{i-t-1} -= 1; } */ if (x.sign == MP_NEG) { - if ((res = mp_copy(&y, &t1)) != MP_OKAY) { - goto LBL_Y; - } - if ((res = mp_lshd(&t1, (i - t) - 1)) != MP_OKAY) { - goto LBL_Y; - } - if ((res = mp_add(&x, &t1, &x)) != MP_OKAY) { - goto LBL_Y; - } + if ((err = mp_copy(&y, &t1)) != MP_OKAY) goto LBL_Y; + if ((err = mp_lshd(&t1, (i - t) - 1)) != MP_OKAY) goto LBL_Y; + if ((err = mp_add(&x, &t1, &x)) != MP_OKAY) goto LBL_Y; q.dp[(i - t) - 1] = (q.dp[(i - t) - 1] - 1uL) & MP_MASK; } } @@ -265,17 +224,15 @@ mp_exch(&q, c); c->sign = neg; } if (d != NULL) { - if ((res = mp_div_2d(&x, norm, &x, NULL)) != MP_OKAY) { - goto LBL_Y; - } + if ((err = mp_div_2d(&x, norm, &x, NULL)) != MP_OKAY) goto LBL_Y; mp_exch(&x, d); } - res = MP_OKAY; + err = MP_OKAY; LBL_Y: mp_clear(&y); LBL_X: mp_clear(&x); @@ -283,15 +240,11 @@ mp_clear(&t2); LBL_T1: mp_clear(&t1); LBL_Q: mp_clear(&q); - return res; + return err; } #endif #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_div_2.c ================================================================== --- libtommath/bn_mp_div_2.c +++ libtommath/bn_mp_div_2.c @@ -1,65 +1,49 @@ #include "tommath_private.h" #ifdef BN_MP_DIV_2_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* b = a/2 */ -int mp_div_2(const mp_int *a, mp_int *b) +mp_err mp_div_2(const mp_int *a, mp_int *b) { - int x, res, oldused; + int x, oldused; + mp_digit r, rr, *tmpa, *tmpb; + mp_err err; /* copy */ if (b->alloc < a->used) { - if ((res = mp_grow(b, a->used)) != MP_OKAY) { - return res; + if ((err = mp_grow(b, a->used)) != MP_OKAY) { + return err; } } oldused = b->used; b->used = a->used; - { - mp_digit r, rr, *tmpa, *tmpb; - - /* source alias */ - tmpa = a->dp + b->used - 1; - - /* dest alias */ - tmpb = b->dp + b->used - 1; - - /* carry */ - r = 0; - for (x = b->used - 1; x >= 0; x--) { - /* get the carry for the next iteration */ - rr = *tmpa & 1u; - - /* shift the current digit, add in carry and store */ - *tmpb-- = (*tmpa-- >> 1) | (r << (DIGIT_BIT - 1)); - - /* forward carry to next iteration */ - r = rr; - } - - /* zero excess digits */ - tmpb = b->dp + b->used; - for (x = b->used; x < oldused; x++) { - *tmpb++ = 0; - } - } + + /* source alias */ + tmpa = a->dp + b->used - 1; + + /* dest alias */ + tmpb = b->dp + b->used - 1; + + /* carry */ + r = 0; + for (x = b->used - 1; x >= 0; x--) { + /* get the carry for the next iteration */ + rr = *tmpa & 1u; + + /* shift the current digit, add in carry and store */ + *tmpb-- = (*tmpa-- >> 1) | (r << (MP_DIGIT_BIT - 1)); + + /* forward carry to next iteration */ + r = rr; + } + + /* zero excess digits */ + MP_ZERO_DIGITS(b->dp + b->used, oldused - b->used); + b->sign = a->sign; mp_clamp(b); return MP_OKAY; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_div_2d.c ================================================================== --- libtommath/bn_mp_div_2d.c +++ libtommath/bn_mp_div_2d.c @@ -1,62 +1,54 @@ #include "tommath_private.h" #ifdef BN_MP_DIV_2D_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* shift right by a certain bit count (store quotient in c, optional remainder in d) */ -int mp_div_2d(const mp_int *a, int b, mp_int *c, mp_int *d) +mp_err mp_div_2d(const mp_int *a, int b, mp_int *c, mp_int *d) { mp_digit D, r, rr; - int x, res; + int x; + mp_err err; /* if the shift count is <= 0 then we do no work */ if (b <= 0) { - res = mp_copy(a, c); + err = mp_copy(a, c); if (d != NULL) { mp_zero(d); } - return res; + return err; } /* copy */ - if ((res = mp_copy(a, c)) != MP_OKAY) { - return res; + if ((err = mp_copy(a, c)) != MP_OKAY) { + return err; } /* 'a' should not be used after here - it might be the same as d */ /* get the remainder */ if (d != NULL) { - if ((res = mp_mod_2d(a, b, d)) != MP_OKAY) { - return res; + if ((err = mp_mod_2d(a, b, d)) != MP_OKAY) { + return err; } } /* shift by as many digits in the bit count */ - if (b >= DIGIT_BIT) { - mp_rshd(c, b / DIGIT_BIT); + if (b >= MP_DIGIT_BIT) { + mp_rshd(c, b / MP_DIGIT_BIT); } - /* shift any bit count < DIGIT_BIT */ - D = (mp_digit)(b % DIGIT_BIT); + /* shift any bit count < MP_DIGIT_BIT */ + D = (mp_digit)(b % MP_DIGIT_BIT); if (D != 0u) { mp_digit *tmpc, mask, shift; /* mask */ mask = ((mp_digit)1 << D) - 1uL; /* shift for lsb */ - shift = (mp_digit)DIGIT_BIT - D; + shift = (mp_digit)MP_DIGIT_BIT - D; /* alias */ tmpc = c->dp + (c->used - 1); /* carry */ @@ -75,9 +67,5 @@ } mp_clamp(c); return MP_OKAY; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_div_3.c ================================================================== --- libtommath/bn_mp_div_3.c +++ libtommath/bn_mp_div_3.c @@ -1,43 +1,35 @@ #include "tommath_private.h" #ifdef BN_MP_DIV_3_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* divide by three (based on routine from MPI and the GMP manual) */ -int mp_div_3(const mp_int *a, mp_int *c, mp_digit *d) +mp_err mp_div_3(const mp_int *a, mp_int *c, mp_digit *d) { mp_int q; mp_word w, t; mp_digit b; - int res, ix; + mp_err err; + int ix; - /* b = 2**DIGIT_BIT / 3 */ - b = ((mp_word)1 << (mp_word)DIGIT_BIT) / (mp_word)3; + /* b = 2**MP_DIGIT_BIT / 3 */ + b = ((mp_word)1 << (mp_word)MP_DIGIT_BIT) / (mp_word)3; - if ((res = mp_init_size(&q, a->used)) != MP_OKAY) { - return res; + if ((err = mp_init_size(&q, a->used)) != MP_OKAY) { + return err; } q.used = a->used; q.sign = a->sign; w = 0; for (ix = a->used - 1; ix >= 0; ix--) { - w = (w << (mp_word)DIGIT_BIT) | (mp_word)a->dp[ix]; + w = (w << (mp_word)MP_DIGIT_BIT) | (mp_word)a->dp[ix]; if (w >= 3u) { /* multiply w by [1/3] */ - t = (w * (mp_word)b) >> (mp_word)DIGIT_BIT; + t = (w * (mp_word)b) >> (mp_word)MP_DIGIT_BIT; /* now subtract 3 * [w/3] from w, to get the remainder */ w -= t+t+t; /* fixup the remainder as required since @@ -63,13 +55,9 @@ mp_clamp(&q); mp_exch(&q, c); } mp_clear(&q); - return res; + return err; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_div_d.c ================================================================== --- libtommath/bn_mp_div_d.c +++ libtommath/bn_mp_div_d.c @@ -1,34 +1,26 @@ #include "tommath_private.h" #ifdef BN_MP_DIV_D_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* single digit division (based on routine from MPI) */ -int mp_div_d(const mp_int *a, mp_digit b, mp_int *c, mp_digit *d) +mp_err mp_div_d(const mp_int *a, mp_digit b, mp_int *c, mp_digit *d) { mp_int q; mp_word w; mp_digit t; - int res, ix; + mp_err err; + int ix; /* cannot divide by zero */ if (b == 0u) { return MP_VAL; } /* quick outs */ - if ((b == 1u) || (mp_iszero(a) == MP_YES)) { + if ((b == 1u) || MP_IS_ZERO(a)) { if (d != NULL) { *d = 0; } if (c != NULL) { return mp_copy(a, c); @@ -35,15 +27,14 @@ } return MP_OKAY; } /* power of two ? */ - if (((b & (b-1)) == 0)) { - for (ix = 1; ix < DIGIT_BIT; ix++) { - if (b == (((mp_digit)1)<dp[0] & (((mp_digit)1<<(mp_digit)ix) - 1uL); } if (c != NULL) { @@ -50,27 +41,25 @@ return mp_div_2d(a, ix, c, NULL); } return MP_OKAY; } -#ifdef BN_MP_DIV_3_C /* three? */ - if (b == 3u) { + if (MP_HAS(MP_DIV_3) && (b == 3u)) { return mp_div_3(a, c, d); } -#endif /* no easy answer [c'est la vie]. Just division */ - if ((res = mp_init_size(&q, a->used)) != MP_OKAY) { - return res; + if ((err = mp_init_size(&q, a->used)) != MP_OKAY) { + return err; } q.used = a->used; q.sign = a->sign; w = 0; for (ix = a->used - 1; ix >= 0; ix--) { - w = (w << (mp_word)DIGIT_BIT) | (mp_word)a->dp[ix]; + w = (w << (mp_word)MP_DIGIT_BIT) | (mp_word)a->dp[ix]; if (w >= b) { t = (mp_digit)(w / b); w -= (mp_word)t * (mp_word)b; } else { @@ -87,13 +76,9 @@ mp_clamp(&q); mp_exch(&q, c); } mp_clear(&q); - return res; + return err; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_dr_is_modulus.c ================================================================== --- libtommath/bn_mp_dr_is_modulus.c +++ libtommath/bn_mp_dr_is_modulus.c @@ -1,40 +1,27 @@ #include "tommath_private.h" #ifdef BN_MP_DR_IS_MODULUS_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* determines if a number is a valid DR modulus */ -int mp_dr_is_modulus(const mp_int *a) +mp_bool mp_dr_is_modulus(const mp_int *a) { int ix; /* must be at least two digits */ if (a->used < 2) { - return 0; + return MP_NO; } /* must be of the form b**k - a [a <= b] so all * but the first digit must be equal to -1 (mod b). */ for (ix = 1; ix < a->used; ix++) { if (a->dp[ix] != MP_MASK) { - return 0; + return MP_NO; } } - return 1; + return MP_YES; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_dr_reduce.c ================================================================== --- libtommath/bn_mp_dr_reduce.c +++ libtommath/bn_mp_dr_reduce.c @@ -1,18 +1,9 @@ #include "tommath_private.h" #ifdef BN_MP_DR_REDUCE_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* reduce "x" in place modulo "n" using the Diminished Radix algorithm. * * Based on algorithm from the paper * @@ -24,13 +15,14 @@ * * Has been modified to use algorithm 7.10 from the LTM book instead * * Input x must be in the range 0 <= x <= (n-1)**2 */ -int mp_dr_reduce(mp_int *x, const mp_int *n, mp_digit k) +mp_err mp_dr_reduce(mp_int *x, const mp_int *n, mp_digit k) { - int err, i, m; + mp_err err; + int i, m; mp_word r; mp_digit mu, *tmpx1, *tmpx2; /* m = digits in modulus */ m = n->used; @@ -58,20 +50,18 @@ /* compute (x mod B**m) + k * [x/B**m] inline and inplace */ for (i = 0; i < m; i++) { r = ((mp_word)*tmpx2++ * (mp_word)k) + *tmpx1 + mu; *tmpx1++ = (mp_digit)(r & MP_MASK); - mu = (mp_digit)(r >> ((mp_word)DIGIT_BIT)); + mu = (mp_digit)(r >> ((mp_word)MP_DIGIT_BIT)); } /* set final carry */ *tmpx1++ = mu; /* zero words above m */ - for (i = m + 1; i < x->used; i++) { - *tmpx1++ = 0; - } + MP_ZERO_DIGITS(tmpx1, (x->used - m) - 1); /* clamp, sub and return */ mp_clamp(x); /* if x >= n then subtract and reduce again @@ -84,9 +74,5 @@ goto top; } return MP_OKAY; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_dr_setup.c ================================================================== --- libtommath/bn_mp_dr_setup.c +++ libtommath/bn_mp_dr_setup.c @@ -1,28 +1,15 @@ #include "tommath_private.h" #ifdef BN_MP_DR_SETUP_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* determines the setup value */ void mp_dr_setup(const mp_int *a, mp_digit *d) { - /* the casts are required if DIGIT_BIT is one less than - * the number of bits in a mp_digit [e.g. DIGIT_BIT==31] + /* the casts are required if MP_DIGIT_BIT is one less than + * the number of bits in a mp_digit [e.g. MP_DIGIT_BIT==31] */ - *d = (mp_digit)(((mp_word)1 << (mp_word)DIGIT_BIT) - (mp_word)a->dp[0]); + *d = (mp_digit)(((mp_word)1 << (mp_word)MP_DIGIT_BIT) - (mp_word)a->dp[0]); } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ ADDED libtommath/bn_mp_error_to_string.c Index: libtommath/bn_mp_error_to_string.c ================================================================== --- /dev/null +++ libtommath/bn_mp_error_to_string.c @@ -0,0 +1,27 @@ +#include "tommath_private.h" +#ifdef BN_MP_ERROR_TO_STRING_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +/* return a char * string for a given code */ +const char *mp_error_to_string(mp_err code) +{ + switch (code) { + case MP_OKAY: + return "Successful"; + case MP_ERR: + return "Unknown error"; + case MP_MEM: + return "Out of heap"; + case MP_VAL: + return "Value out of range"; + case MP_ITER: + return "Max. iterations reached"; + case MP_BUF: + return "Buffer overflow"; + default: + return "Invalid error code"; + } +} + +#endif Index: libtommath/bn_mp_exch.c ================================================================== --- libtommath/bn_mp_exch.c +++ libtommath/bn_mp_exch.c @@ -1,18 +1,9 @@ #include "tommath_private.h" #ifdef BN_MP_EXCH_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* swap the elements of two integers, for cases where you can't simply swap the * mp_int pointers around */ void mp_exch(mp_int *a, mp_int *b) @@ -22,9 +13,5 @@ t = *a; *a = *b; *b = t; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ DELETED libtommath/bn_mp_export.c Index: libtommath/bn_mp_export.c ================================================================== --- libtommath/bn_mp_export.c +++ /dev/null @@ -1,84 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_MP_EXPORT_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* based on gmp's mpz_export. - * see http://gmplib.org/manual/Integer-Import-and-Export.html - */ -int mp_export(void *rop, size_t *countp, int order, size_t size, - int endian, size_t nails, const mp_int *op) -{ - int result; - size_t odd_nails, nail_bytes, i, j, bits, count; - unsigned char odd_nail_mask; - - mp_int t; - - if ((result = mp_init_copy(&t, op)) != MP_OKAY) { - return result; - } - - if (endian == 0) { - union { - unsigned int i; - char c[4]; - } lint; - lint.i = 0x01020304; - - endian = (lint.c[0] == '\x04') ? -1 : 1; - } - - odd_nails = (nails % 8u); - odd_nail_mask = 0xff; - for (i = 0; i < odd_nails; ++i) { - odd_nail_mask ^= (unsigned char)(1u << (7u - i)); - } - nail_bytes = nails / 8u; - - bits = (size_t)mp_count_bits(&t); - count = (bits / ((size * 8u) - nails)) + (((bits % ((size * 8u) - nails)) != 0u) ? 1u : 0u); - - for (i = 0; i < count; ++i) { - for (j = 0; j < size; ++j) { - unsigned char *byte = (unsigned char *)rop + - (((order == -1) ? i : ((count - 1u) - i)) * size) + - ((endian == -1) ? j : ((size - 1u) - j)); - - if (j >= (size - nail_bytes)) { - *byte = 0; - continue; - } - - *byte = (unsigned char)((j == ((size - nail_bytes) - 1u)) ? (t.dp[0] & odd_nail_mask) : (t.dp[0] & 0xFFuL)); - - if ((result = mp_div_2d(&t, (j == ((size - nail_bytes) - 1u)) ? (int)(8u - odd_nails) : 8, &t, NULL)) != MP_OKAY) { - mp_clear(&t); - return result; - } - } - } - - mp_clear(&t); - - if (countp != NULL) { - *countp = count; - } - - return MP_OKAY; -} - -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ DELETED libtommath/bn_mp_expt_d.c Index: libtommath/bn_mp_expt_d.c ================================================================== --- libtommath/bn_mp_expt_d.c +++ /dev/null @@ -1,25 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_MP_EXPT_D_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* wrapper function for mp_expt_d_ex() */ -int mp_expt_d(const mp_int *a, mp_digit b, mp_int *c) -{ - return mp_expt_d_ex(a, b, c, 0); -} - -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ DELETED libtommath/bn_mp_expt_d_ex.c Index: libtommath/bn_mp_expt_d_ex.c ================================================================== --- libtommath/bn_mp_expt_d_ex.c +++ /dev/null @@ -1,79 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_MP_EXPT_D_EX_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* calculate c = a**b using a square-multiply algorithm */ -int mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast) -{ - int res; - unsigned int x; - - mp_int g; - - if ((res = mp_init_copy(&g, a)) != MP_OKAY) { - return res; - } - - /* set initial result */ - mp_set(c, 1uL); - - if (fast != 0) { - while (b > 0u) { - /* if the bit is set multiply */ - if ((b & 1u) != 0u) { - if ((res = mp_mul(c, &g, c)) != MP_OKAY) { - mp_clear(&g); - return res; - } - } - - /* square */ - if (b > 1u) { - if ((res = mp_sqr(&g, &g)) != MP_OKAY) { - mp_clear(&g); - return res; - } - } - - /* shift to next bit */ - b >>= 1; - } - } else { - for (x = 0; x < (unsigned)DIGIT_BIT; x++) { - /* square */ - if ((res = mp_sqr(c, c)) != MP_OKAY) { - mp_clear(&g); - return res; - } - - /* if the bit is set multiply */ - if ((b & ((mp_digit)1 << (DIGIT_BIT - 1))) != 0u) { - if ((res = mp_mul(c, &g, c)) != MP_OKAY) { - mp_clear(&g); - return res; - } - } - - /* shift to next bit */ - b <<= 1; - } - } /* if ... else */ - - mp_clear(&g); - return MP_OKAY; -} -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ ADDED libtommath/bn_mp_expt_u32.c Index: libtommath/bn_mp_expt_u32.c ================================================================== --- /dev/null +++ libtommath/bn_mp_expt_u32.c @@ -0,0 +1,46 @@ +#include "tommath_private.h" +#ifdef BN_MP_EXPT_U32_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +/* calculate c = a**b using a square-multiply algorithm */ +mp_err mp_expt_u32(const mp_int *a, unsigned int b, mp_int *c) +{ + mp_err err; + + mp_int g; + + if ((err = mp_init_copy(&g, a)) != MP_OKAY) { + return err; + } + + /* set initial result */ + mp_set(c, 1uL); + + while (b > 0u) { + /* if the bit is set multiply */ + if ((b & 1u) != 0u) { + if ((err = mp_mul(c, &g, c)) != MP_OKAY) { + goto LBL_ERR; + } + } + + /* square */ + if (b > 1u) { + if ((err = mp_sqr(&g, &g)) != MP_OKAY) { + goto LBL_ERR; + } + } + + /* shift to next bit */ + b >>= 1; + } + + err = MP_OKAY; + +LBL_ERR: + mp_clear(&g); + return err; +} + +#endif Index: libtommath/bn_mp_exptmod.c ================================================================== --- libtommath/bn_mp_exptmod.c +++ libtommath/bn_mp_exptmod.c @@ -1,26 +1,16 @@ #include "tommath_private.h" #ifdef BN_MP_EXPTMOD_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* this is a shell function that calls either the normal or Montgomery * exptmod functions. Originally the call to the montgomery code was * embedded in the normal function but that wasted alot of stack space * for nothing (since 99% of the time the Montgomery code would be called) */ -int mp_exptmod(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y) +mp_err mp_exptmod(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y) { int dr; /* modulus P must be positive */ if (P->sign == MP_NEG) { @@ -27,83 +17,60 @@ return MP_VAL; } /* if exponent X is negative we have to recurse */ if (X->sign == MP_NEG) { -#ifdef BN_MP_INVMOD_C - mp_int tmpG, tmpX; - int err; - - /* first compute 1/G mod P */ - if ((err = mp_init(&tmpG)) != MP_OKAY) { - return err; - } - if ((err = mp_invmod(G, P, &tmpG)) != MP_OKAY) { - mp_clear(&tmpG); + mp_int tmpG, tmpX; + mp_err err; + + if (!MP_HAS(MP_INVMOD)) { + return MP_VAL; + } + + if ((err = mp_init_multi(&tmpG, &tmpX, NULL)) != MP_OKAY) { return err; } - /* now get |X| */ - if ((err = mp_init(&tmpX)) != MP_OKAY) { - mp_clear(&tmpG); - return err; - } - if ((err = mp_abs(X, &tmpX)) != MP_OKAY) { - mp_clear_multi(&tmpG, &tmpX, NULL); - return err; + /* first compute 1/G mod P */ + if ((err = mp_invmod(G, P, &tmpG)) != MP_OKAY) { + goto LBL_ERR; + } + + /* now get |X| */ + if ((err = mp_abs(X, &tmpX)) != MP_OKAY) { + goto LBL_ERR; } /* and now compute (1/G)**|X| instead of G**X [X < 0] */ err = mp_exptmod(&tmpG, &tmpX, P, Y); +LBL_ERR: mp_clear_multi(&tmpG, &tmpX, NULL); return err; -#else - /* no invmod */ - return MP_VAL; -#endif } /* modified diminished radix reduction */ -#if defined(BN_MP_REDUCE_IS_2K_L_C) && defined(BN_MP_REDUCE_2K_L_C) && defined(BN_S_MP_EXPTMOD_C) - if (mp_reduce_is_2k_l(P) == MP_YES) { - return s_mp_exptmod(G, X, P, Y, 1); - } -#endif - -#ifdef BN_MP_DR_IS_MODULUS_C - /* is it a DR modulus? */ - dr = mp_dr_is_modulus(P); -#else - /* default to no */ - dr = 0; -#endif - -#ifdef BN_MP_REDUCE_IS_2K_C - /* if not, is it a unrestricted DR modulus? */ - if (dr == 0) { - dr = mp_reduce_is_2k(P) << 1; - } -#endif - - /* if the modulus is odd or dr != 0 use the montgomery method */ -#ifdef BN_MP_EXPTMOD_FAST_C - if ((mp_isodd(P) == MP_YES) || (dr != 0)) { - return mp_exptmod_fast(G, X, P, Y, dr); - } else { -#endif -#ifdef BN_S_MP_EXPTMOD_C - /* otherwise use the generic Barrett reduction technique */ - return s_mp_exptmod(G, X, P, Y, 0); -#else - /* no exptmod for evens */ - return MP_VAL; -#endif -#ifdef BN_MP_EXPTMOD_FAST_C - } -#endif -} - -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ + if (MP_HAS(MP_REDUCE_IS_2K_L) && MP_HAS(MP_REDUCE_2K_L) && MP_HAS(S_MP_EXPTMOD) && + (mp_reduce_is_2k_l(P) == MP_YES)) { + return s_mp_exptmod(G, X, P, Y, 1); + } + + /* is it a DR modulus? default to no */ + dr = (MP_HAS(MP_DR_IS_MODULUS) && (mp_dr_is_modulus(P) == MP_YES)) ? 1 : 0; + + /* if not, is it a unrestricted DR modulus? */ + if (MP_HAS(MP_REDUCE_IS_2K) && (dr == 0)) { + dr = (mp_reduce_is_2k(P) == MP_YES) ? 2 : 0; + } + + /* if the modulus is odd or dr != 0 use the montgomery method */ + if (MP_HAS(S_MP_EXPTMOD_FAST) && (MP_IS_ODD(P) || (dr != 0))) { + return s_mp_exptmod_fast(G, X, P, Y, dr); + } else if (MP_HAS(S_MP_EXPTMOD)) { + /* otherwise use the generic Barrett reduction technique */ + return s_mp_exptmod(G, X, P, Y, 0); + } else { + /* no exptmod for evens */ + return MP_VAL; + } +} + +#endif DELETED libtommath/bn_mp_exptmod_fast.c Index: libtommath/bn_mp_exptmod_fast.c ================================================================== --- libtommath/bn_mp_exptmod_fast.c +++ /dev/null @@ -1,319 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_MP_EXPTMOD_FAST_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* computes Y == G**X mod P, HAC pp.616, Algorithm 14.85 - * - * Uses a left-to-right k-ary sliding window to compute the modular exponentiation. - * The value of k changes based on the size of the exponent. - * - * Uses Montgomery or Diminished Radix reduction [whichever appropriate] - */ - -#ifdef MP_LOW_MEM -# define TAB_SIZE 32 -#else -# define TAB_SIZE 256 -#endif - -int mp_exptmod_fast(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y, int redmode) -{ - mp_int M[TAB_SIZE], res; - mp_digit buf, mp; - int err, bitbuf, bitcpy, bitcnt, mode, digidx, x, y, winsize; - - /* use a pointer to the reduction algorithm. This allows us to use - * one of many reduction algorithms without modding the guts of - * the code with if statements everywhere. - */ - int (*redux)(mp_int *x, const mp_int *n, mp_digit rho); - - /* find window size */ - x = mp_count_bits(X); - if (x <= 7) { - winsize = 2; - } else if (x <= 36) { - winsize = 3; - } else if (x <= 140) { - winsize = 4; - } else if (x <= 450) { - winsize = 5; - } else if (x <= 1303) { - winsize = 6; - } else if (x <= 3529) { - winsize = 7; - } else { - winsize = 8; - } - -#ifdef MP_LOW_MEM - if (winsize > 5) { - winsize = 5; - } -#endif - - /* init M array */ - /* init first cell */ - if ((err = mp_init_size(&M[1], P->alloc)) != MP_OKAY) { - return err; - } - - /* now init the second half of the array */ - for (x = 1<<(winsize-1); x < (1 << winsize); x++) { - if ((err = mp_init_size(&M[x], P->alloc)) != MP_OKAY) { - for (y = 1<<(winsize-1); y < x; y++) { - mp_clear(&M[y]); - } - mp_clear(&M[1]); - return err; - } - } - - /* determine and setup reduction code */ - if (redmode == 0) { -#ifdef BN_MP_MONTGOMERY_SETUP_C - /* now setup montgomery */ - if ((err = mp_montgomery_setup(P, &mp)) != MP_OKAY) { - goto LBL_M; - } -#else - err = MP_VAL; - goto LBL_M; -#endif - - /* automatically pick the comba one if available (saves quite a few calls/ifs) */ -#ifdef BN_FAST_MP_MONTGOMERY_REDUCE_C - if ((((P->used * 2) + 1) < (int)MP_WARRAY) && - (P->used < (1 << ((CHAR_BIT * sizeof(mp_word)) - (2 * DIGIT_BIT))))) { - redux = fast_mp_montgomery_reduce; - } else -#endif - { -#ifdef BN_MP_MONTGOMERY_REDUCE_C - /* use slower baseline Montgomery method */ - redux = mp_montgomery_reduce; -#else - err = MP_VAL; - goto LBL_M; -#endif - } - } else if (redmode == 1) { -#if defined(BN_MP_DR_SETUP_C) && defined(BN_MP_DR_REDUCE_C) - /* setup DR reduction for moduli of the form B**k - b */ - mp_dr_setup(P, &mp); - redux = mp_dr_reduce; -#else - err = MP_VAL; - goto LBL_M; -#endif - } else { -#if defined(BN_MP_REDUCE_2K_SETUP_C) && defined(BN_MP_REDUCE_2K_C) - /* setup DR reduction for moduli of the form 2**k - b */ - if ((err = mp_reduce_2k_setup(P, &mp)) != MP_OKAY) { - goto LBL_M; - } - redux = mp_reduce_2k; -#else - err = MP_VAL; - goto LBL_M; -#endif - } - - /* setup result */ - if ((err = mp_init_size(&res, P->alloc)) != MP_OKAY) { - goto LBL_M; - } - - /* create M table - * - - * - * The first half of the table is not computed though accept for M[0] and M[1] - */ - - if (redmode == 0) { -#ifdef BN_MP_MONTGOMERY_CALC_NORMALIZATION_C - /* now we need R mod m */ - if ((err = mp_montgomery_calc_normalization(&res, P)) != MP_OKAY) { - goto LBL_RES; - } - - /* now set M[1] to G * R mod m */ - if ((err = mp_mulmod(G, &res, P, &M[1])) != MP_OKAY) { - goto LBL_RES; - } -#else - err = MP_VAL; - goto LBL_RES; -#endif - } else { - mp_set(&res, 1uL); - if ((err = mp_mod(G, P, &M[1])) != MP_OKAY) { - goto LBL_RES; - } - } - - /* compute the value at M[1<<(winsize-1)] by squaring M[1] (winsize-1) times */ - if ((err = mp_copy(&M[1], &M[(size_t)1 << (winsize - 1)])) != MP_OKAY) { - goto LBL_RES; - } - - for (x = 0; x < (winsize - 1); x++) { - if ((err = mp_sqr(&M[(size_t)1 << (winsize - 1)], &M[(size_t)1 << (winsize - 1)])) != MP_OKAY) { - goto LBL_RES; - } - if ((err = redux(&M[(size_t)1 << (winsize - 1)], P, mp)) != MP_OKAY) { - goto LBL_RES; - } - } - - /* create upper table */ - for (x = (1 << (winsize - 1)) + 1; x < (1 << winsize); x++) { - if ((err = mp_mul(&M[x - 1], &M[1], &M[x])) != MP_OKAY) { - goto LBL_RES; - } - if ((err = redux(&M[x], P, mp)) != MP_OKAY) { - goto LBL_RES; - } - } - - /* set initial mode and bit cnt */ - mode = 0; - bitcnt = 1; - buf = 0; - digidx = X->used - 1; - bitcpy = 0; - bitbuf = 0; - - for (;;) { - /* grab next digit as required */ - if (--bitcnt == 0) { - /* if digidx == -1 we are out of digits so break */ - if (digidx == -1) { - break; - } - /* read next digit and reset bitcnt */ - buf = X->dp[digidx--]; - bitcnt = (int)DIGIT_BIT; - } - - /* grab the next msb from the exponent */ - y = (mp_digit)(buf >> (DIGIT_BIT - 1)) & 1; - buf <<= (mp_digit)1; - - /* if the bit is zero and mode == 0 then we ignore it - * These represent the leading zero bits before the first 1 bit - * in the exponent. Technically this opt is not required but it - * does lower the # of trivial squaring/reductions used - */ - if ((mode == 0) && (y == 0)) { - continue; - } - - /* if the bit is zero and mode == 1 then we square */ - if ((mode == 1) && (y == 0)) { - if ((err = mp_sqr(&res, &res)) != MP_OKAY) { - goto LBL_RES; - } - if ((err = redux(&res, P, mp)) != MP_OKAY) { - goto LBL_RES; - } - continue; - } - - /* else we add it to the window */ - bitbuf |= (y << (winsize - ++bitcpy)); - mode = 2; - - if (bitcpy == winsize) { - /* ok window is filled so square as required and multiply */ - /* square first */ - for (x = 0; x < winsize; x++) { - if ((err = mp_sqr(&res, &res)) != MP_OKAY) { - goto LBL_RES; - } - if ((err = redux(&res, P, mp)) != MP_OKAY) { - goto LBL_RES; - } - } - - /* then multiply */ - if ((err = mp_mul(&res, &M[bitbuf], &res)) != MP_OKAY) { - goto LBL_RES; - } - if ((err = redux(&res, P, mp)) != MP_OKAY) { - goto LBL_RES; - } - - /* empty window and reset */ - bitcpy = 0; - bitbuf = 0; - mode = 1; - } - } - - /* if bits remain then square/multiply */ - if ((mode == 2) && (bitcpy > 0)) { - /* square then multiply if the bit is set */ - for (x = 0; x < bitcpy; x++) { - if ((err = mp_sqr(&res, &res)) != MP_OKAY) { - goto LBL_RES; - } - if ((err = redux(&res, P, mp)) != MP_OKAY) { - goto LBL_RES; - } - - /* get next bit of the window */ - bitbuf <<= 1; - if ((bitbuf & (1 << winsize)) != 0) { - /* then multiply */ - if ((err = mp_mul(&res, &M[1], &res)) != MP_OKAY) { - goto LBL_RES; - } - if ((err = redux(&res, P, mp)) != MP_OKAY) { - goto LBL_RES; - } - } - } - } - - if (redmode == 0) { - /* fixup result if Montgomery reduction is used - * recall that any value in a Montgomery system is - * actually multiplied by R mod n. So we have - * to reduce one more time to cancel out the factor - * of R. - */ - if ((err = redux(&res, P, mp)) != MP_OKAY) { - goto LBL_RES; - } - } - - /* swap res with Y */ - mp_exch(&res, Y); - err = MP_OKAY; -LBL_RES: - mp_clear(&res); -LBL_M: - mp_clear(&M[1]); - for (x = 1<<(winsize-1); x < (1 << winsize); x++) { - mp_clear(&M[x]); - } - return err; -} -#endif - - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_exteuclid.c ================================================================== --- libtommath/bn_mp_exteuclid.c +++ libtommath/bn_mp_exteuclid.c @@ -1,104 +1,59 @@ #include "tommath_private.h" #ifdef BN_MP_EXTEUCLID_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* Extended euclidean algorithm of (a, b) produces a*u1 + b*u2 = u3 */ -int mp_exteuclid(const mp_int *a, const mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3) +mp_err mp_exteuclid(const mp_int *a, const mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3) { mp_int u1, u2, u3, v1, v2, v3, t1, t2, t3, q, tmp; - int err; + mp_err err; if ((err = mp_init_multi(&u1, &u2, &u3, &v1, &v2, &v3, &t1, &t2, &t3, &q, &tmp, NULL)) != MP_OKAY) { return err; } /* initialize, (u1,u2,u3) = (1,0,a) */ mp_set(&u1, 1uL); - if ((err = mp_copy(a, &u3)) != MP_OKAY) { - goto LBL_ERR; - } + if ((err = mp_copy(a, &u3)) != MP_OKAY) goto LBL_ERR; /* initialize, (v1,v2,v3) = (0,1,b) */ mp_set(&v2, 1uL); - if ((err = mp_copy(b, &v3)) != MP_OKAY) { - goto LBL_ERR; - } + if ((err = mp_copy(b, &v3)) != MP_OKAY) goto LBL_ERR; /* loop while v3 != 0 */ - while (mp_iszero(&v3) == MP_NO) { + while (!MP_IS_ZERO(&v3)) { /* q = u3/v3 */ - if ((err = mp_div(&u3, &v3, &q, NULL)) != MP_OKAY) { - goto LBL_ERR; - } + if ((err = mp_div(&u3, &v3, &q, NULL)) != MP_OKAY) goto LBL_ERR; /* (t1,t2,t3) = (u1,u2,u3) - (v1,v2,v3)q */ - if ((err = mp_mul(&v1, &q, &tmp)) != MP_OKAY) { - goto LBL_ERR; - } - if ((err = mp_sub(&u1, &tmp, &t1)) != MP_OKAY) { - goto LBL_ERR; - } - if ((err = mp_mul(&v2, &q, &tmp)) != MP_OKAY) { - goto LBL_ERR; - } - if ((err = mp_sub(&u2, &tmp, &t2)) != MP_OKAY) { - goto LBL_ERR; - } - if ((err = mp_mul(&v3, &q, &tmp)) != MP_OKAY) { - goto LBL_ERR; - } - if ((err = mp_sub(&u3, &tmp, &t3)) != MP_OKAY) { - goto LBL_ERR; - } + if ((err = mp_mul(&v1, &q, &tmp)) != MP_OKAY) goto LBL_ERR; + if ((err = mp_sub(&u1, &tmp, &t1)) != MP_OKAY) goto LBL_ERR; + if ((err = mp_mul(&v2, &q, &tmp)) != MP_OKAY) goto LBL_ERR; + if ((err = mp_sub(&u2, &tmp, &t2)) != MP_OKAY) goto LBL_ERR; + if ((err = mp_mul(&v3, &q, &tmp)) != MP_OKAY) goto LBL_ERR; + if ((err = mp_sub(&u3, &tmp, &t3)) != MP_OKAY) goto LBL_ERR; /* (u1,u2,u3) = (v1,v2,v3) */ - if ((err = mp_copy(&v1, &u1)) != MP_OKAY) { - goto LBL_ERR; - } - if ((err = mp_copy(&v2, &u2)) != MP_OKAY) { - goto LBL_ERR; - } - if ((err = mp_copy(&v3, &u3)) != MP_OKAY) { - goto LBL_ERR; - } + if ((err = mp_copy(&v1, &u1)) != MP_OKAY) goto LBL_ERR; + if ((err = mp_copy(&v2, &u2)) != MP_OKAY) goto LBL_ERR; + if ((err = mp_copy(&v3, &u3)) != MP_OKAY) goto LBL_ERR; /* (v1,v2,v3) = (t1,t2,t3) */ - if ((err = mp_copy(&t1, &v1)) != MP_OKAY) { - goto LBL_ERR; - } - if ((err = mp_copy(&t2, &v2)) != MP_OKAY) { - goto LBL_ERR; - } - if ((err = mp_copy(&t3, &v3)) != MP_OKAY) { - goto LBL_ERR; - } + if ((err = mp_copy(&t1, &v1)) != MP_OKAY) goto LBL_ERR; + if ((err = mp_copy(&t2, &v2)) != MP_OKAY) goto LBL_ERR; + if ((err = mp_copy(&t3, &v3)) != MP_OKAY) goto LBL_ERR; } /* make sure U3 >= 0 */ if (u3.sign == MP_NEG) { - if ((err = mp_neg(&u1, &u1)) != MP_OKAY) { - goto LBL_ERR; - } - if ((err = mp_neg(&u2, &u2)) != MP_OKAY) { - goto LBL_ERR; - } - if ((err = mp_neg(&u3, &u3)) != MP_OKAY) { - goto LBL_ERR; - } + if ((err = mp_neg(&u1, &u1)) != MP_OKAY) goto LBL_ERR; + if ((err = mp_neg(&u2, &u2)) != MP_OKAY) goto LBL_ERR; + if ((err = mp_neg(&u3, &u3)) != MP_OKAY) goto LBL_ERR; } /* copy result out */ if (U1 != NULL) { mp_exch(U1, &u1); @@ -114,9 +69,5 @@ LBL_ERR: mp_clear_multi(&u1, &u2, &u3, &v1, &v2, &v3, &t1, &t2, &t3, &q, &tmp, NULL); return err; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_fread.c ================================================================== --- libtommath/bn_mp_fread.c +++ libtommath/bn_mp_fread.c @@ -1,40 +1,37 @@ #include "tommath_private.h" #ifdef BN_MP_FREAD_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -#ifndef LTM_NO_FILE +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +#ifndef MP_NO_FILE /* read a bigint from a file stream in ASCII */ -int mp_fread(mp_int *a, int radix, FILE *stream) +mp_err mp_fread(mp_int *a, int radix, FILE *stream) { - int err, ch, neg, y; - unsigned pos; - - /* clear a */ - mp_zero(a); + mp_err err; + mp_sign neg; /* if first digit is - then set negative */ - ch = fgetc(stream); + int ch = fgetc(stream); if (ch == (int)'-') { neg = MP_NEG; ch = fgetc(stream); } else { neg = MP_ZPOS; } - for (;;) { - pos = (unsigned)(ch - (int)'('); + /* no digits, return error */ + if (ch == EOF) { + return MP_ERR; + } + + /* clear a */ + mp_zero(a); + + do { + int y; + unsigned pos = (unsigned)(ch - (int)'('); if (mp_s_rmap_reverse_sz < pos) { break; } y = (int)mp_s_rmap_reverse[pos]; @@ -48,21 +45,16 @@ return err; } if ((err = mp_add_d(a, (mp_digit)y, a)) != MP_OKAY) { return err; } + } while ((ch = fgetc(stream)) != EOF); - ch = fgetc(stream); - } - if (mp_cmp_d(a, 0uL) != MP_EQ) { + if (a->used != 0) { a->sign = neg; } return MP_OKAY; } #endif #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ ADDED libtommath/bn_mp_from_sbin.c Index: libtommath/bn_mp_from_sbin.c ================================================================== --- /dev/null +++ libtommath/bn_mp_from_sbin.c @@ -0,0 +1,25 @@ +#include "tommath_private.h" +#ifdef BN_MP_FROM_SBIN_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +/* read signed bin, big endian, first byte is 0==positive or 1==negative */ +mp_err mp_from_sbin(mp_int *a, const unsigned char *buf, size_t size) +{ + mp_err err; + + /* read magnitude */ + if ((err = mp_from_ubin(a, buf + 1, size - 1u)) != MP_OKAY) { + return err; + } + + /* first byte is 0 for positive, non-zero for negative */ + if (buf[0] == (unsigned char)0) { + a->sign = MP_ZPOS; + } else { + a->sign = MP_NEG; + } + + return MP_OKAY; +} +#endif ADDED libtommath/bn_mp_from_ubin.c Index: libtommath/bn_mp_from_ubin.c ================================================================== --- /dev/null +++ libtommath/bn_mp_from_ubin.c @@ -0,0 +1,39 @@ +#include "tommath_private.h" +#ifdef BN_MP_FROM_UBIN_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +/* reads a unsigned char array, assumes the msb is stored first [big endian] */ +mp_err mp_from_ubin(mp_int *a, const unsigned char *buf, size_t size) +{ + mp_err err; + + /* make sure there are at least two digits */ + if (a->alloc < 2) { + if ((err = mp_grow(a, 2)) != MP_OKAY) { + return err; + } + } + + /* zero the int */ + mp_zero(a); + + /* read the bytes in */ + while (size-- > 0u) { + if ((err = mp_mul_2d(a, 8, a)) != MP_OKAY) { + return err; + } + +#ifndef MP_8BIT + a->dp[0] |= *buf++; + a->used += 1; +#else + a->dp[0] = (*buf & MP_MASK); + a->dp[1] |= ((*buf++ >> 7) & 1u); + a->used += 2; +#endif + } + mp_clamp(a); + return MP_OKAY; +} +#endif Index: libtommath/bn_mp_fwrite.c ================================================================== --- libtommath/bn_mp_fwrite.c +++ libtommath/bn_mp_fwrite.c @@ -1,51 +1,45 @@ #include "tommath_private.h" #ifdef BN_MP_FWRITE_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -#ifndef LTM_NO_FILE -int mp_fwrite(const mp_int *a, int radix, FILE *stream) -{ - char *buf; - int err, len, x; - - if ((err = mp_radix_size(a, radix, &len)) != MP_OKAY) { - return err; - } - - buf = (char *) XMALLOC((size_t)len); +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +#ifndef MP_NO_FILE +mp_err mp_fwrite(const mp_int *a, int radix, FILE *stream) +{ + char *buf; + mp_err err; + int len; + size_t written; + + /* TODO: this function is not in this PR */ + if (MP_HAS(MP_RADIX_SIZE_OVERESTIMATE)) { + /* if ((err = mp_radix_size_overestimate(&t, base, &len)) != MP_OKAY) goto LBL_ERR; */ + } else { + if ((err = mp_radix_size(a, radix, &len)) != MP_OKAY) { + return err; + } + } + + buf = (char *) MP_MALLOC((size_t)len); if (buf == NULL) { return MP_MEM; } - if ((err = mp_toradix(a, buf, radix)) != MP_OKAY) { - XFREE(buf, len); - return err; - } - - for (x = 0; x < len; x++) { - if (fputc((int)buf[x], stream) == EOF) { - XFREE(buf, len); - return MP_VAL; - } - } - - XFREE(buf, len); - return MP_OKAY; + if ((err = mp_to_radix(a, buf, (size_t)len, &written, radix)) != MP_OKAY) { + goto LBL_ERR; + } + + if (fwrite(buf, written, 1uL, stream) != 1uL) { + err = MP_ERR; + goto LBL_ERR; + } + err = MP_OKAY; + + +LBL_ERR: + MP_FREE_BUFFER(buf, (size_t)len); + return err; } #endif #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_gcd.c ================================================================== --- libtommath/bn_mp_gcd.c +++ libtommath/bn_mp_gcd.c @@ -1,104 +1,92 @@ #include "tommath_private.h" #ifdef BN_MP_GCD_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* Greatest Common Divisor using the binary method */ -int mp_gcd(const mp_int *a, const mp_int *b, mp_int *c) +mp_err mp_gcd(const mp_int *a, const mp_int *b, mp_int *c) { mp_int u, v; - int k, u_lsb, v_lsb, res; + int k, u_lsb, v_lsb; + mp_err err; /* either zero than gcd is the largest */ - if (mp_iszero(a) == MP_YES) { + if (MP_IS_ZERO(a)) { return mp_abs(b, c); } - if (mp_iszero(b) == MP_YES) { + if (MP_IS_ZERO(b)) { return mp_abs(a, c); } /* get copies of a and b we can modify */ - if ((res = mp_init_copy(&u, a)) != MP_OKAY) { - return res; + if ((err = mp_init_copy(&u, a)) != MP_OKAY) { + return err; } - if ((res = mp_init_copy(&v, b)) != MP_OKAY) { + if ((err = mp_init_copy(&v, b)) != MP_OKAY) { goto LBL_U; } /* must be positive for the remainder of the algorithm */ u.sign = v.sign = MP_ZPOS; /* B1. Find the common power of two for u and v */ u_lsb = mp_cnt_lsb(&u); v_lsb = mp_cnt_lsb(&v); - k = MIN(u_lsb, v_lsb); + k = MP_MIN(u_lsb, v_lsb); if (k > 0) { /* divide the power of two out */ - if ((res = mp_div_2d(&u, k, &u, NULL)) != MP_OKAY) { + if ((err = mp_div_2d(&u, k, &u, NULL)) != MP_OKAY) { goto LBL_V; } - if ((res = mp_div_2d(&v, k, &v, NULL)) != MP_OKAY) { + if ((err = mp_div_2d(&v, k, &v, NULL)) != MP_OKAY) { goto LBL_V; } } /* divide any remaining factors of two out */ if (u_lsb != k) { - if ((res = mp_div_2d(&u, u_lsb - k, &u, NULL)) != MP_OKAY) { + if ((err = mp_div_2d(&u, u_lsb - k, &u, NULL)) != MP_OKAY) { goto LBL_V; } } if (v_lsb != k) { - if ((res = mp_div_2d(&v, v_lsb - k, &v, NULL)) != MP_OKAY) { + if ((err = mp_div_2d(&v, v_lsb - k, &v, NULL)) != MP_OKAY) { goto LBL_V; } } - while (mp_iszero(&v) == MP_NO) { + while (!MP_IS_ZERO(&v)) { /* make sure v is the largest */ if (mp_cmp_mag(&u, &v) == MP_GT) { /* swap u and v to make sure v is >= u */ mp_exch(&u, &v); } /* subtract smallest from largest */ - if ((res = s_mp_sub(&v, &u, &v)) != MP_OKAY) { + if ((err = s_mp_sub(&v, &u, &v)) != MP_OKAY) { goto LBL_V; } /* Divide out all factors of two */ - if ((res = mp_div_2d(&v, mp_cnt_lsb(&v), &v, NULL)) != MP_OKAY) { + if ((err = mp_div_2d(&v, mp_cnt_lsb(&v), &v, NULL)) != MP_OKAY) { goto LBL_V; } } /* multiply by 2**k which we divided out at the beginning */ - if ((res = mp_mul_2d(&u, k, c)) != MP_OKAY) { + if ((err = mp_mul_2d(&u, k, c)) != MP_OKAY) { goto LBL_V; } c->sign = MP_ZPOS; - res = MP_OKAY; + err = MP_OKAY; LBL_V: mp_clear(&u); LBL_U: mp_clear(&v); - return res; + return err; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_get_double.c ================================================================== --- libtommath/bn_mp_get_double.c +++ libtommath/bn_mp_get_double.c @@ -1,31 +1,18 @@ #include "tommath_private.h" #ifdef BN_MP_GET_DOUBLE_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ double mp_get_double(const mp_int *a) { int i; double d = 0.0, fac = 1.0; - for (i = 0; i < DIGIT_BIT; ++i) { + for (i = 0; i < MP_DIGIT_BIT; ++i) { fac *= 2.0; } for (i = a->used; i --> 0;) { d = (d * fac) + (double)a->dp[i]; } return (a->sign == MP_NEG) ? -d : d; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ ADDED libtommath/bn_mp_get_i32.c Index: libtommath/bn_mp_get_i32.c ================================================================== --- /dev/null +++ libtommath/bn_mp_get_i32.c @@ -0,0 +1,7 @@ +#include "tommath_private.h" +#ifdef BN_MP_GET_I32_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +MP_GET_SIGNED(mp_get_i32, mp_get_mag_u32, int32_t, uint32_t) +#endif ADDED libtommath/bn_mp_get_i64.c Index: libtommath/bn_mp_get_i64.c ================================================================== --- /dev/null +++ libtommath/bn_mp_get_i64.c @@ -0,0 +1,7 @@ +#include "tommath_private.h" +#ifdef BN_MP_GET_I64_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +MP_GET_SIGNED(mp_get_i64, mp_get_mag_u64, int64_t, uint64_t) +#endif DELETED libtommath/bn_mp_get_int.c Index: libtommath/bn_mp_get_int.c ================================================================== --- libtommath/bn_mp_get_int.c +++ /dev/null @@ -1,25 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_MP_GET_INT_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* get the lower 32-bits of an mp_int */ -unsigned long mp_get_int(const mp_int *a) -{ - /* force result to 32-bits always so it is consistent on non 32-bit platforms */ - return mp_get_long(a) & 0xFFFFFFFFUL; -} -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ ADDED libtommath/bn_mp_get_l.c Index: libtommath/bn_mp_get_l.c ================================================================== --- /dev/null +++ libtommath/bn_mp_get_l.c @@ -0,0 +1,7 @@ +#include "tommath_private.h" +#ifdef BN_MP_GET_L_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +MP_GET_SIGNED(mp_get_l, mp_get_mag_ul, long, unsigned long) +#endif ADDED libtommath/bn_mp_get_ll.c Index: libtommath/bn_mp_get_ll.c ================================================================== --- /dev/null +++ libtommath/bn_mp_get_ll.c @@ -0,0 +1,7 @@ +#include "tommath_private.h" +#ifdef BN_MP_GET_LL_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +MP_GET_SIGNED(mp_get_ll, mp_get_mag_ull, long long, unsigned long long) +#endif DELETED libtommath/bn_mp_get_long.c Index: libtommath/bn_mp_get_long.c ================================================================== --- libtommath/bn_mp_get_long.c +++ /dev/null @@ -1,42 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_MP_GET_LONG_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* get the lower unsigned long of an mp_int, platform dependent */ -unsigned long mp_get_long(const mp_int *a) -{ - int i; - unsigned long res; - - if (IS_ZERO(a)) { - return 0; - } - - /* get number of digits of the lsb we have to read */ - i = MIN(a->used, (((CHAR_BIT * (int)sizeof(unsigned long)) + DIGIT_BIT - 1) / DIGIT_BIT)) - 1; - - /* get most significant digit of result */ - res = (unsigned long)a->dp[i]; - -#if (ULONG_MAX != 0xFFFFFFFFUL) || (DIGIT_BIT < 32) - while (--i >= 0) { - res = (res << DIGIT_BIT) | (unsigned long)a->dp[i]; - } -#endif - return res; -} -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ DELETED libtommath/bn_mp_get_long_long.c Index: libtommath/bn_mp_get_long_long.c ================================================================== --- libtommath/bn_mp_get_long_long.c +++ /dev/null @@ -1,42 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_MP_GET_LONG_LONG_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* get the lower unsigned long long of an mp_int, platform dependent */ -Tcl_WideUInt mp_get_long_long(const mp_int *a) -{ - int i; - Tcl_WideUInt res; - - if (IS_ZERO(a)) { - return 0; - } - - /* get number of digits of the lsb we have to read */ - i = MIN(a->used, (((CHAR_BIT * (int)sizeof(Tcl_WideUInt)) + DIGIT_BIT - 1) / DIGIT_BIT)) - 1; - - /* get most significant digit of result */ - res = (Tcl_WideUInt)a->dp[i]; - -#if DIGIT_BIT < 64 - while (--i >= 0) { - res = (res << DIGIT_BIT) | (Tcl_WideUInt)a->dp[i]; - } -#endif - return res; -} -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ ADDED libtommath/bn_mp_get_mag_u32.c Index: libtommath/bn_mp_get_mag_u32.c ================================================================== --- /dev/null +++ libtommath/bn_mp_get_mag_u32.c @@ -0,0 +1,7 @@ +#include "tommath_private.h" +#ifdef BN_MP_GET_MAG_U32_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +MP_GET_MAG(mp_get_mag_u32, uint32_t) +#endif ADDED libtommath/bn_mp_get_mag_u64.c Index: libtommath/bn_mp_get_mag_u64.c ================================================================== --- /dev/null +++ libtommath/bn_mp_get_mag_u64.c @@ -0,0 +1,7 @@ +#include "tommath_private.h" +#ifdef BN_MP_GET_MAG_U64_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +MP_GET_MAG(mp_get_mag_u64, uint64_t) +#endif ADDED libtommath/bn_mp_get_mag_ul.c Index: libtommath/bn_mp_get_mag_ul.c ================================================================== --- /dev/null +++ libtommath/bn_mp_get_mag_ul.c @@ -0,0 +1,7 @@ +#include "tommath_private.h" +#ifdef BN_MP_GET_MAG_UL_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +MP_GET_MAG(mp_get_mag_ul, unsigned long) +#endif ADDED libtommath/bn_mp_get_mag_ull.c Index: libtommath/bn_mp_get_mag_ull.c ================================================================== --- /dev/null +++ libtommath/bn_mp_get_mag_ull.c @@ -0,0 +1,7 @@ +#include "tommath_private.h" +#ifdef BN_MP_GET_MAG_ULL_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +MP_GET_MAG(mp_get_mag_ull, unsigned long long) +#endif Index: libtommath/bn_mp_grow.c ================================================================== --- libtommath/bn_mp_grow.c +++ libtommath/bn_mp_grow.c @@ -1,39 +1,27 @@ #include "tommath_private.h" #ifdef BN_MP_GROW_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* grow as required */ -int mp_grow(mp_int *a, int size) +mp_err mp_grow(mp_int *a, int size) { int i; mp_digit *tmp; /* if the alloc size is smaller alloc more ram */ if (a->alloc < size) { - /* ensure there are always at least MP_PREC digits extra on top */ - size += (MP_PREC * 2) - (size % MP_PREC); - /* reallocate the array a->dp * * We store the return in a temporary variable * in case the operation failed we don't want * to overwrite the dp member of a. */ - tmp = (mp_digit *) XREALLOC(a->dp, - (size_t)a->alloc * sizeof (mp_digit), - (size_t)size * sizeof(mp_digit)); + tmp = (mp_digit *) MP_REALLOC(a->dp, + (size_t)a->alloc * sizeof(mp_digit), + (size_t)size * sizeof(mp_digit)); if (tmp == NULL) { /* reallocation failed but "a" is still valid [can be freed] */ return MP_MEM; } @@ -41,16 +29,10 @@ a->dp = tmp; /* zero excess digits */ i = a->alloc; a->alloc = size; - for (; i < a->alloc; i++) { - a->dp[i] = 0; - } + MP_ZERO_DIGITS(a->dp + i, a->alloc - i); } return MP_OKAY; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ DELETED libtommath/bn_mp_import.c Index: libtommath/bn_mp_import.c ================================================================== --- libtommath/bn_mp_import.c +++ /dev/null @@ -1,68 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_MP_IMPORT_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* based on gmp's mpz_import. - * see http://gmplib.org/manual/Integer-Import-and-Export.html - */ -int mp_import(mp_int *rop, size_t count, int order, size_t size, - int endian, size_t nails, const void *op) -{ - int result; - size_t odd_nails, nail_bytes, i, j; - unsigned char odd_nail_mask; - - mp_zero(rop); - - if (endian == 0) { - union { - unsigned int i; - char c[4]; - } lint; - lint.i = 0x01020304; - - endian = (lint.c[0] == '\x04') ? -1 : 1; - } - - odd_nails = (nails % 8u); - odd_nail_mask = 0xff; - for (i = 0; i < odd_nails; ++i) { - odd_nail_mask ^= (unsigned char)(1u << (7u - i)); - } - nail_bytes = nails / 8u; - - for (i = 0; i < count; ++i) { - for (j = 0; j < (size - nail_bytes); ++j) { - unsigned char byte = *((unsigned char *)op + - (((order == 1) ? i : ((count - 1u) - i)) * size) + - ((endian == 1) ? (j + nail_bytes) : (((size - 1u) - j) - nail_bytes))); - - if ((result = mp_mul_2d(rop, (j == 0u) ? (int)(8u - odd_nails) : 8, rop)) != MP_OKAY) { - return result; - } - - rop->dp[0] |= (j == 0u) ? (mp_digit)(byte & odd_nail_mask) : (mp_digit)byte; - rop->used += 1; - } - } - - mp_clamp(rop); - - return MP_OKAY; -} - -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ ADDED libtommath/bn_mp_incr.c Index: libtommath/bn_mp_incr.c ================================================================== --- /dev/null +++ libtommath/bn_mp_incr.c @@ -0,0 +1,30 @@ +#include "tommath_private.h" +#ifdef BN_MP_INCR_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +/* Increment "a" by one like "a++". Changes input! */ +mp_err mp_incr(mp_int *a) +{ + if (MP_IS_ZERO(a)) { + mp_set(a,1uL); + return MP_OKAY; + } else if (a->sign == MP_NEG) { + mp_err err; + a->sign = MP_ZPOS; + if ((err = mp_decr(a)) != MP_OKAY) { + return err; + } + /* There is no -0 in LTM */ + if (!MP_IS_ZERO(a)) { + a->sign = MP_NEG; + } + return MP_OKAY; + } else if (a->dp[0] < MP_DIGIT_MAX) { + a->dp[0]++; + return MP_OKAY; + } else { + return mp_add_d(a, 1uL,a); + } +} +#endif Index: libtommath/bn_mp_init.c ================================================================== --- libtommath/bn_mp_init.c +++ libtommath/bn_mp_init.c @@ -1,43 +1,23 @@ #include "tommath_private.h" #ifdef BN_MP_INIT_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* init a new mp_int */ -int mp_init(mp_int *a) +mp_err mp_init(mp_int *a) { - int i; - /* allocate memory required and clear it */ - a->dp = (mp_digit *) XMALLOC(MP_PREC * sizeof(mp_digit)); + a->dp = (mp_digit *) MP_CALLOC((size_t)MP_PREC, sizeof(mp_digit)); if (a->dp == NULL) { return MP_MEM; } - /* set the digits to zero */ - for (i = 0; i < MP_PREC; i++) { - a->dp[i] = 0; - } - /* set the used to zero, allocated digits to the default precision * and sign to positive */ a->used = 0; a->alloc = MP_PREC; a->sign = MP_ZPOS; return MP_OKAY; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_init_copy.c ================================================================== --- libtommath/bn_mp_init_copy.c +++ libtommath/bn_mp_init_copy.c @@ -1,34 +1,21 @@ #include "tommath_private.h" #ifdef BN_MP_INIT_COPY_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* creates "a" then copies b into it */ -int mp_init_copy(mp_int *a, const mp_int *b) +mp_err mp_init_copy(mp_int *a, const mp_int *b) { - int res; + mp_err err; - if ((res = mp_init_size(a, b->used)) != MP_OKAY) { - return res; + if ((err = mp_init_size(a, b->used)) != MP_OKAY) { + return err; } - if ((res = mp_copy(b, a)) != MP_OKAY) { + if ((err = mp_copy(b, a)) != MP_OKAY) { mp_clear(a); } - return res; + return err; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ ADDED libtommath/bn_mp_init_i32.c Index: libtommath/bn_mp_init_i32.c ================================================================== --- /dev/null +++ libtommath/bn_mp_init_i32.c @@ -0,0 +1,7 @@ +#include "tommath_private.h" +#ifdef BN_MP_INIT_I32_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +MP_INIT_INT(mp_init_i32, mp_set_i32, int32_t) +#endif ADDED libtommath/bn_mp_init_i64.c Index: libtommath/bn_mp_init_i64.c ================================================================== --- /dev/null +++ libtommath/bn_mp_init_i64.c @@ -0,0 +1,7 @@ +#include "tommath_private.h" +#ifdef BN_MP_INIT_I64_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +MP_INIT_INT(mp_init_i64, mp_set_i64, int64_t) +#endif ADDED libtommath/bn_mp_init_l.c Index: libtommath/bn_mp_init_l.c ================================================================== --- /dev/null +++ libtommath/bn_mp_init_l.c @@ -0,0 +1,7 @@ +#include "tommath_private.h" +#ifdef BN_MP_INIT_L_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +MP_INIT_INT(mp_init_l, mp_set_l, long) +#endif ADDED libtommath/bn_mp_init_ll.c Index: libtommath/bn_mp_init_ll.c ================================================================== --- /dev/null +++ libtommath/bn_mp_init_ll.c @@ -0,0 +1,7 @@ +#include "tommath_private.h" +#ifdef BN_MP_INIT_LL_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +MP_INIT_INT(mp_init_ll, mp_set_ll, long long) +#endif Index: libtommath/bn_mp_init_multi.c ================================================================== --- libtommath/bn_mp_init_multi.c +++ libtommath/bn_mp_init_multi.c @@ -1,24 +1,15 @@ #include "tommath_private.h" #ifdef BN_MP_INIT_MULTI_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ #include -int mp_init_multi(mp_int *mp, ...) +mp_err mp_init_multi(mp_int *mp, ...) { - mp_err res = MP_OKAY; /* Assume ok until proven otherwise */ + mp_err err = MP_OKAY; /* Assume ok until proven otherwise */ int n = 0; /* Number of ok inits */ mp_int *cur_arg = mp; va_list args; va_start(args, mp); /* init args to next argument from caller */ @@ -35,20 +26,16 @@ while (n-- != 0) { mp_clear(cur_arg); cur_arg = va_arg(clean_args, mp_int *); } va_end(clean_args); - res = MP_MEM; + err = MP_MEM; break; } n++; cur_arg = va_arg(args, mp_int *); } va_end(args); - return res; /* Assumed ok, if error flagged above. */ + return err; /* Assumed ok, if error flagged above. */ } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_init_set.c ================================================================== --- libtommath/bn_mp_init_set.c +++ libtommath/bn_mp_init_set.c @@ -1,29 +1,16 @@ #include "tommath_private.h" #ifdef BN_MP_INIT_SET_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* initialize and set a digit */ -int mp_init_set(mp_int *a, mp_digit b) +mp_err mp_init_set(mp_int *a, mp_digit b) { - int err; + mp_err err; if ((err = mp_init(a)) != MP_OKAY) { return err; } mp_set(a, b); return err; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ DELETED libtommath/bn_mp_init_set_int.c Index: libtommath/bn_mp_init_set_int.c ================================================================== --- libtommath/bn_mp_init_set_int.c +++ /dev/null @@ -1,28 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_MP_INIT_SET_INT_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* initialize and set a digit */ -int mp_init_set_int(mp_int *a, unsigned long b) -{ - int err; - if ((err = mp_init(a)) != MP_OKAY) { - return err; - } - return mp_set_int(a, b); -} -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_init_size.c ================================================================== --- libtommath/bn_mp_init_size.c +++ libtommath/bn_mp_init_size.c @@ -1,45 +1,24 @@ #include "tommath_private.h" #ifdef BN_MP_INIT_SIZE_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* init an mp_init for a given size */ -int mp_init_size(mp_int *a, int size) +mp_err mp_init_size(mp_int *a, int size) { - int x; - - /* pad size so there are always extra digits */ - size += (MP_PREC * 2) - (size % MP_PREC); + size = MP_MAX(MP_MIN_PREC, size); /* alloc mem */ - a->dp = (mp_digit *) XMALLOC((size_t)size * sizeof(mp_digit)); + a->dp = (mp_digit *) MP_CALLOC((size_t)size, sizeof(mp_digit)); if (a->dp == NULL) { return MP_MEM; } /* set the members */ a->used = 0; a->alloc = size; a->sign = MP_ZPOS; - /* zero the digits */ - for (x = 0; x < size; x++) { - a->dp[x] = 0; - } - return MP_OKAY; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ ADDED libtommath/bn_mp_init_u32.c Index: libtommath/bn_mp_init_u32.c ================================================================== --- /dev/null +++ libtommath/bn_mp_init_u32.c @@ -0,0 +1,7 @@ +#include "tommath_private.h" +#ifdef BN_MP_INIT_U32_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +MP_INIT_INT(mp_init_u32, mp_set_u32, uint32_t) +#endif ADDED libtommath/bn_mp_init_u64.c Index: libtommath/bn_mp_init_u64.c ================================================================== --- /dev/null +++ libtommath/bn_mp_init_u64.c @@ -0,0 +1,7 @@ +#include "tommath_private.h" +#ifdef BN_MP_INIT_U64_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +MP_INIT_INT(mp_init_u64, mp_set_u64, uint64_t) +#endif ADDED libtommath/bn_mp_init_ul.c Index: libtommath/bn_mp_init_ul.c ================================================================== --- /dev/null +++ libtommath/bn_mp_init_ul.c @@ -0,0 +1,7 @@ +#include "tommath_private.h" +#ifdef BN_MP_INIT_UL_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +MP_INIT_INT(mp_init_ul, mp_set_ul, unsigned long) +#endif ADDED libtommath/bn_mp_init_ull.c Index: libtommath/bn_mp_init_ull.c ================================================================== --- /dev/null +++ libtommath/bn_mp_init_ull.c @@ -0,0 +1,7 @@ +#include "tommath_private.h" +#ifdef BN_MP_INIT_ULL_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +MP_INIT_INT(mp_init_ull, mp_set_ull, unsigned long long) +#endif Index: libtommath/bn_mp_invmod.c ================================================================== --- libtommath/bn_mp_invmod.c +++ libtommath/bn_mp_invmod.c @@ -1,40 +1,23 @@ #include "tommath_private.h" #ifdef BN_MP_INVMOD_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* hac 14.61, pp608 */ -int mp_invmod(const mp_int *a, const mp_int *b, mp_int *c) +mp_err mp_invmod(const mp_int *a, const mp_int *b, mp_int *c) { /* b cannot be negative and has to be >1 */ if ((b->sign == MP_NEG) || (mp_cmp_d(b, 1uL) != MP_GT)) { return MP_VAL; } -#ifdef BN_FAST_MP_INVMOD_C - /* if the modulus is odd we can use a faster routine instead */ - if ((mp_isodd(b) == MP_YES)) { - return fast_mp_invmod(a, b, c); - } -#endif - -#ifdef BN_MP_INVMOD_SLOW_C - return mp_invmod_slow(a, b, c); -#else - return MP_VAL; -#endif -} -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ + /* if the modulus is odd we can use a faster routine instead */ + if (MP_HAS(S_MP_INVMOD_FAST) && MP_IS_ODD(b)) { + return s_mp_invmod_fast(a, b, c); + } + + return MP_HAS(S_MP_INVMOD_SLOW) + ? s_mp_invmod_slow(a, b, c) + : MP_VAL; +} +#endif DELETED libtommath/bn_mp_invmod_slow.c Index: libtommath/bn_mp_invmod_slow.c ================================================================== --- libtommath/bn_mp_invmod_slow.c +++ /dev/null @@ -1,173 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_MP_INVMOD_SLOW_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* hac 14.61, pp608 */ -int mp_invmod_slow(const mp_int *a, const mp_int *b, mp_int *c) -{ - mp_int x, y, u, v, A, B, C, D; - int res; - - /* b cannot be negative */ - if ((b->sign == MP_NEG) || (mp_iszero(b) == MP_YES)) { - return MP_VAL; - } - - /* init temps */ - if ((res = mp_init_multi(&x, &y, &u, &v, - &A, &B, &C, &D, NULL)) != MP_OKAY) { - return res; - } - - /* x = a, y = b */ - if ((res = mp_mod(a, b, &x)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_copy(b, &y)) != MP_OKAY) { - goto LBL_ERR; - } - - /* 2. [modified] if x,y are both even then return an error! */ - if ((mp_iseven(&x) == MP_YES) && (mp_iseven(&y) == MP_YES)) { - res = MP_VAL; - goto LBL_ERR; - } - - /* 3. u=x, v=y, A=1, B=0, C=0,D=1 */ - if ((res = mp_copy(&x, &u)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_copy(&y, &v)) != MP_OKAY) { - goto LBL_ERR; - } - mp_set(&A, 1uL); - mp_set(&D, 1uL); - -top: - /* 4. while u is even do */ - while (mp_iseven(&u) == MP_YES) { - /* 4.1 u = u/2 */ - if ((res = mp_div_2(&u, &u)) != MP_OKAY) { - goto LBL_ERR; - } - /* 4.2 if A or B is odd then */ - if ((mp_isodd(&A) == MP_YES) || (mp_isodd(&B) == MP_YES)) { - /* A = (A+y)/2, B = (B-x)/2 */ - if ((res = mp_add(&A, &y, &A)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_sub(&B, &x, &B)) != MP_OKAY) { - goto LBL_ERR; - } - } - /* A = A/2, B = B/2 */ - if ((res = mp_div_2(&A, &A)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_div_2(&B, &B)) != MP_OKAY) { - goto LBL_ERR; - } - } - - /* 5. while v is even do */ - while (mp_iseven(&v) == MP_YES) { - /* 5.1 v = v/2 */ - if ((res = mp_div_2(&v, &v)) != MP_OKAY) { - goto LBL_ERR; - } - /* 5.2 if C or D is odd then */ - if ((mp_isodd(&C) == MP_YES) || (mp_isodd(&D) == MP_YES)) { - /* C = (C+y)/2, D = (D-x)/2 */ - if ((res = mp_add(&C, &y, &C)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_sub(&D, &x, &D)) != MP_OKAY) { - goto LBL_ERR; - } - } - /* C = C/2, D = D/2 */ - if ((res = mp_div_2(&C, &C)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_div_2(&D, &D)) != MP_OKAY) { - goto LBL_ERR; - } - } - - /* 6. if u >= v then */ - if (mp_cmp(&u, &v) != MP_LT) { - /* u = u - v, A = A - C, B = B - D */ - if ((res = mp_sub(&u, &v, &u)) != MP_OKAY) { - goto LBL_ERR; - } - - if ((res = mp_sub(&A, &C, &A)) != MP_OKAY) { - goto LBL_ERR; - } - - if ((res = mp_sub(&B, &D, &B)) != MP_OKAY) { - goto LBL_ERR; - } - } else { - /* v - v - u, C = C - A, D = D - B */ - if ((res = mp_sub(&v, &u, &v)) != MP_OKAY) { - goto LBL_ERR; - } - - if ((res = mp_sub(&C, &A, &C)) != MP_OKAY) { - goto LBL_ERR; - } - - if ((res = mp_sub(&D, &B, &D)) != MP_OKAY) { - goto LBL_ERR; - } - } - - /* if not zero goto step 4 */ - if (mp_iszero(&u) == MP_NO) - goto top; - - /* now a = C, b = D, gcd == g*v */ - - /* if v != 1 then there is no inverse */ - if (mp_cmp_d(&v, 1uL) != MP_EQ) { - res = MP_VAL; - goto LBL_ERR; - } - - /* if its too low */ - while (mp_cmp_d(&C, 0uL) == MP_LT) { - if ((res = mp_add(&C, b, &C)) != MP_OKAY) { - goto LBL_ERR; - } - } - - /* too big */ - while (mp_cmp_mag(&C, b) != MP_LT) { - if ((res = mp_sub(&C, b, &C)) != MP_OKAY) { - goto LBL_ERR; - } - } - - /* C is now the inverse */ - mp_exch(&C, c); - res = MP_OKAY; -LBL_ERR: - mp_clear_multi(&x, &y, &u, &v, &A, &B, &C, &D, NULL); - return res; -} -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_is_square.c ================================================================== --- libtommath/bn_mp_is_square.c +++ libtommath/bn_mp_is_square.c @@ -1,18 +1,9 @@ #include "tommath_private.h" #ifdef BN_MP_IS_SQUARE_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* Check if remainders are possible squares - fast exclude non-squares */ static const char rem_128[128] = { 0, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, @@ -33,13 +24,13 @@ 1, 1, 1, 1, 0, 1, 0, 1, 1, 0, 0, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1 }; /* Store non-zero to ret if arg is square, and zero if not */ -int mp_is_square(const mp_int *arg, int *ret) +mp_err mp_is_square(const mp_int *arg, mp_bool *ret) { - int res; + mp_err err; mp_digit c; mp_int t; unsigned long r; /* Default to Non-square :) */ @@ -47,37 +38,37 @@ if (arg->sign == MP_NEG) { return MP_VAL; } - if (IS_ZERO(arg)) { + if (MP_IS_ZERO(arg)) { return MP_OKAY; } - /* First check mod 128 (suppose that DIGIT_BIT is at least 7) */ + /* First check mod 128 (suppose that MP_DIGIT_BIT is at least 7) */ if (rem_128[127u & arg->dp[0]] == (char)1) { return MP_OKAY; } /* Next check mod 105 (3*5*7) */ - if ((res = mp_mod_d(arg, 105uL, &c)) != MP_OKAY) { - return res; + if ((err = mp_mod_d(arg, 105uL, &c)) != MP_OKAY) { + return err; } if (rem_105[c] == (char)1) { return MP_OKAY; } - if ((res = mp_init_set_int(&t, 11L*13L*17L*19L*23L*29L*31L)) != MP_OKAY) { - return res; + if ((err = mp_init_u32(&t, 11u*13u*17u*19u*23u*29u*31u)) != MP_OKAY) { + return err; } - if ((res = mp_mod(arg, &t, &t)) != MP_OKAY) { + if ((err = mp_mod(arg, &t, &t)) != MP_OKAY) { goto LBL_ERR; } - r = mp_get_int(&t); + r = mp_get_u32(&t); /* Check for other prime modules, note it's not an ERROR but we must - * free "t" so the easiest way is to goto LBL_ERR. We know that res + * free "t" so the easiest way is to goto LBL_ERR. We know that err * is already equal to MP_OKAY from the mp_mod call */ if (((1uL<<(r%11uL)) & 0x5C4uL) != 0uL) goto LBL_ERR; if (((1uL<<(r%13uL)) & 0x9E4uL) != 0uL) goto LBL_ERR; if (((1uL<<(r%17uL)) & 0x5CE8uL) != 0uL) goto LBL_ERR; @@ -85,22 +76,18 @@ if (((1uL<<(r%23uL)) & 0x7ACCA0uL) != 0uL) goto LBL_ERR; if (((1uL<<(r%29uL)) & 0xC2EDD0CuL) != 0uL) goto LBL_ERR; if (((1uL<<(r%31uL)) & 0x6DE2B848uL) != 0uL) goto LBL_ERR; /* Final check - is sqr(sqrt(arg)) == arg ? */ - if ((res = mp_sqrt(arg, &t)) != MP_OKAY) { + if ((err = mp_sqrt(arg, &t)) != MP_OKAY) { goto LBL_ERR; } - if ((res = mp_sqr(&t, &t)) != MP_OKAY) { + if ((err = mp_sqr(&t, &t)) != MP_OKAY) { goto LBL_ERR; } *ret = (mp_cmp_mag(&t, arg) == MP_EQ) ? MP_YES : MP_NO; LBL_ERR: mp_clear(&t); - return res; + return err; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ ADDED libtommath/bn_mp_iseven.c Index: libtommath/bn_mp_iseven.c ================================================================== --- /dev/null +++ libtommath/bn_mp_iseven.c @@ -0,0 +1,10 @@ +#include "tommath_private.h" +#ifdef BN_MP_ISEVEN_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +mp_bool mp_iseven(const mp_int *a) +{ + return MP_IS_EVEN(a) ? MP_YES : MP_NO; +} +#endif ADDED libtommath/bn_mp_isodd.c Index: libtommath/bn_mp_isodd.c ================================================================== --- /dev/null +++ libtommath/bn_mp_isodd.c @@ -0,0 +1,10 @@ +#include "tommath_private.h" +#ifdef BN_MP_ISODD_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +mp_bool mp_isodd(const mp_int *a) +{ + return MP_IS_ODD(a) ? MP_YES : MP_NO; +} +#endif DELETED libtommath/bn_mp_jacobi.c Index: libtommath/bn_mp_jacobi.c ================================================================== --- libtommath/bn_mp_jacobi.c +++ /dev/null @@ -1,36 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_MP_JACOBI_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* computes the jacobi c = (a | n) (or Legendre if n is prime) - * Kept for legacy reasons, please use mp_kronecker() instead - */ -int mp_jacobi(const mp_int *a, const mp_int *n, int *c) -{ - /* if a < 0 return MP_VAL */ - if (mp_isneg(a) == MP_YES) { - return MP_VAL; - } - - /* if n <= 0 return MP_VAL */ - if (mp_cmp_d(n, 0uL) != MP_GT) { - return MP_VAL; - } - - return mp_kronecker(a, n, c); -} -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ DELETED libtommath/bn_mp_karatsuba_mul.c Index: libtommath/bn_mp_karatsuba_mul.c ================================================================== --- libtommath/bn_mp_karatsuba_mul.c +++ /dev/null @@ -1,171 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_MP_KARATSUBA_MUL_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* c = |a| * |b| using Karatsuba Multiplication using - * three half size multiplications - * - * Let B represent the radix [e.g. 2**DIGIT_BIT] and - * let n represent half of the number of digits in - * the min(a,b) - * - * a = a1 * B**n + a0 - * b = b1 * B**n + b0 - * - * Then, a * b => - a1b1 * B**2n + ((a1 + a0)(b1 + b0) - (a0b0 + a1b1)) * B + a0b0 - * - * Note that a1b1 and a0b0 are used twice and only need to be - * computed once. So in total three half size (half # of - * digit) multiplications are performed, a0b0, a1b1 and - * (a1+b1)(a0+b0) - * - * Note that a multiplication of half the digits requires - * 1/4th the number of single precision multiplications so in - * total after one call 25% of the single precision multiplications - * are saved. Note also that the call to mp_mul can end up back - * in this function if the a0, a1, b0, or b1 are above the threshold. - * This is known as divide-and-conquer and leads to the famous - * O(N**lg(3)) or O(N**1.584) work which is asymptopically lower than - * the standard O(N**2) that the baseline/comba methods use. - * Generally though the overhead of this method doesn't pay off - * until a certain size (N ~ 80) is reached. - */ -int mp_karatsuba_mul(const mp_int *a, const mp_int *b, mp_int *c) -{ - mp_int x0, x1, y0, y1, t1, x0y0, x1y1; - int B, err; - - /* default the return code to an error */ - err = MP_MEM; - - /* min # of digits */ - B = MIN(a->used, b->used); - - /* now divide in two */ - B = B >> 1; - - /* init copy all the temps */ - if (mp_init_size(&x0, B) != MP_OKAY) - goto LBL_ERR; - if (mp_init_size(&x1, a->used - B) != MP_OKAY) - goto X0; - if (mp_init_size(&y0, B) != MP_OKAY) - goto X1; - if (mp_init_size(&y1, b->used - B) != MP_OKAY) - goto Y0; - - /* init temps */ - if (mp_init_size(&t1, B * 2) != MP_OKAY) - goto Y1; - if (mp_init_size(&x0y0, B * 2) != MP_OKAY) - goto T1; - if (mp_init_size(&x1y1, B * 2) != MP_OKAY) - goto X0Y0; - - /* now shift the digits */ - x0.used = y0.used = B; - x1.used = a->used - B; - y1.used = b->used - B; - - { - int x; - mp_digit *tmpa, *tmpb, *tmpx, *tmpy; - - /* we copy the digits directly instead of using higher level functions - * since we also need to shift the digits - */ - tmpa = a->dp; - tmpb = b->dp; - - tmpx = x0.dp; - tmpy = y0.dp; - for (x = 0; x < B; x++) { - *tmpx++ = *tmpa++; - *tmpy++ = *tmpb++; - } - - tmpx = x1.dp; - for (x = B; x < a->used; x++) { - *tmpx++ = *tmpa++; - } - - tmpy = y1.dp; - for (x = B; x < b->used; x++) { - *tmpy++ = *tmpb++; - } - } - - /* only need to clamp the lower words since by definition the - * upper words x1/y1 must have a known number of digits - */ - mp_clamp(&x0); - mp_clamp(&y0); - - /* now calc the products x0y0 and x1y1 */ - /* after this x0 is no longer required, free temp [x0==t2]! */ - if (mp_mul(&x0, &y0, &x0y0) != MP_OKAY) - goto X1Y1; /* x0y0 = x0*y0 */ - if (mp_mul(&x1, &y1, &x1y1) != MP_OKAY) - goto X1Y1; /* x1y1 = x1*y1 */ - - /* now calc x1+x0 and y1+y0 */ - if (s_mp_add(&x1, &x0, &t1) != MP_OKAY) - goto X1Y1; /* t1 = x1 - x0 */ - if (s_mp_add(&y1, &y0, &x0) != MP_OKAY) - goto X1Y1; /* t2 = y1 - y0 */ - if (mp_mul(&t1, &x0, &t1) != MP_OKAY) - goto X1Y1; /* t1 = (x1 + x0) * (y1 + y0) */ - - /* add x0y0 */ - if (mp_add(&x0y0, &x1y1, &x0) != MP_OKAY) - goto X1Y1; /* t2 = x0y0 + x1y1 */ - if (s_mp_sub(&t1, &x0, &t1) != MP_OKAY) - goto X1Y1; /* t1 = (x1+x0)*(y1+y0) - (x1y1 + x0y0) */ - - /* shift by B */ - if (mp_lshd(&t1, B) != MP_OKAY) - goto X1Y1; /* t1 = (x0y0 + x1y1 - (x1-x0)*(y1-y0))<used; - - /* now divide in two */ - B = B >> 1; - - /* init copy all the temps */ - if (mp_init_size(&x0, B) != MP_OKAY) - goto LBL_ERR; - if (mp_init_size(&x1, a->used - B) != MP_OKAY) - goto X0; - - /* init temps */ - if (mp_init_size(&t1, a->used * 2) != MP_OKAY) - goto X1; - if (mp_init_size(&t2, a->used * 2) != MP_OKAY) - goto T1; - if (mp_init_size(&x0x0, B * 2) != MP_OKAY) - goto T2; - if (mp_init_size(&x1x1, (a->used - B) * 2) != MP_OKAY) - goto X0X0; - - { - int x; - mp_digit *dst, *src; - - src = a->dp; - - /* now shift the digits */ - dst = x0.dp; - for (x = 0; x < B; x++) { - *dst++ = *src++; - } - - dst = x1.dp; - for (x = B; x < a->used; x++) { - *dst++ = *src++; - } - } - - x0.used = B; - x1.used = a->used - B; - - mp_clamp(&x0); - - /* now calc the products x0*x0 and x1*x1 */ - if (mp_sqr(&x0, &x0x0) != MP_OKAY) - goto X1X1; /* x0x0 = x0*x0 */ - if (mp_sqr(&x1, &x1x1) != MP_OKAY) - goto X1X1; /* x1x1 = x1*x1 */ - - /* now calc (x1+x0)**2 */ - if (s_mp_add(&x1, &x0, &t1) != MP_OKAY) - goto X1X1; /* t1 = x1 - x0 */ - if (mp_sqr(&t1, &t1) != MP_OKAY) - goto X1X1; /* t1 = (x1 - x0) * (x1 - x0) */ - - /* add x0y0 */ - if (s_mp_add(&x0x0, &x1x1, &t2) != MP_OKAY) - goto X1X1; /* t2 = x0x0 + x1x1 */ - if (s_mp_sub(&t1, &t2, &t1) != MP_OKAY) - goto X1X1; /* t1 = (x1+x0)**2 - (x0x0 + x1x1) */ - - /* shift by B */ - if (mp_lshd(&t1, B) != MP_OKAY) - goto X1X1; /* t1 = (x0x0 + x1x1 - (x1-x0)*(x1-x0))<used == 1) && (a->dp[0] == 1u)) { *c = 1; - return e; } else { *c = 0; - return e; } + return MP_OKAY; } - if ((mp_iseven(a) != MP_NO) && (mp_iseven(p) != MP_NO)) { + if (MP_IS_EVEN(a) && MP_IS_EVEN(p)) { *c = 0; - return e; + return MP_OKAY; } - if ((e = mp_init_copy(&a1, a)) != MP_OKAY) { - return e; + if ((err = mp_init_copy(&a1, a)) != MP_OKAY) { + return err; } - if ((e = mp_init_copy(&p1, p)) != MP_OKAY) { + if ((err = mp_init_copy(&p1, p)) != MP_OKAY) { goto LBL_KRON_0; } v = mp_cnt_lsb(&p1); - if ((e = mp_div_2d(&p1, v, &p1, NULL)) != MP_OKAY) { + if ((err = mp_div_2d(&p1, v, &p1, NULL)) != MP_OKAY) { goto LBL_KRON_1; } - if ((v & 0x1) == 0) { + if ((v & 1) == 0) { k = 1; } else { k = table[a->dp[0] & 7u]; } @@ -73,16 +62,16 @@ if (a1.sign == MP_NEG) { k = -k; } } - if ((e = mp_init(&r)) != MP_OKAY) { + if ((err = mp_init(&r)) != MP_OKAY) { goto LBL_KRON_1; } for (;;) { - if (mp_iszero(&a1) != MP_NO) { + if (MP_IS_ZERO(&a1)) { if (mp_cmp_d(&p1, 1uL) == MP_EQ) { *c = k; goto LBL_KRON; } else { *c = 0; @@ -89,15 +78,15 @@ goto LBL_KRON; } } v = mp_cnt_lsb(&a1); - if ((e = mp_div_2d(&a1, v, &a1, NULL)) != MP_OKAY) { + if ((err = mp_div_2d(&a1, v, &a1, NULL)) != MP_OKAY) { goto LBL_KRON; } - if ((v & 0x1) == 1) { + if ((v & 1) == 1) { k = k * table[p1.dp[0] & 7u]; } if (a1.sign == MP_NEG) { /* @@ -113,18 +102,18 @@ if ((a1.dp[0] & p1.dp[0] & 2u) != 0u) { k = -k; } } - if ((e = mp_copy(&a1, &r)) != MP_OKAY) { + if ((err = mp_copy(&a1, &r)) != MP_OKAY) { goto LBL_KRON; } r.sign = MP_ZPOS; - if ((e = mp_mod(&p1, &r, &a1)) != MP_OKAY) { + if ((err = mp_mod(&p1, &r, &a1)) != MP_OKAY) { goto LBL_KRON; } - if ((e = mp_copy(&r, &p1)) != MP_OKAY) { + if ((err = mp_copy(&r, &p1)) != MP_OKAY) { goto LBL_KRON; } } LBL_KRON: @@ -132,13 +121,9 @@ LBL_KRON_1: mp_clear(&p1); LBL_KRON_0: mp_clear(&a1); - return e; + return err; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_lcm.c ================================================================== --- libtommath/bn_mp_lcm.c +++ libtommath/bn_mp_lcm.c @@ -1,57 +1,44 @@ #include "tommath_private.h" #ifdef BN_MP_LCM_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* computes least common multiple as |a*b|/(a, b) */ -int mp_lcm(const mp_int *a, const mp_int *b, mp_int *c) -{ - int res; +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +/* computes least common multiple as |a*b|/(a, b) */ +mp_err mp_lcm(const mp_int *a, const mp_int *b, mp_int *c) +{ + mp_err err; mp_int t1, t2; - if ((res = mp_init_multi(&t1, &t2, NULL)) != MP_OKAY) { - return res; + if ((err = mp_init_multi(&t1, &t2, NULL)) != MP_OKAY) { + return err; } /* t1 = get the GCD of the two inputs */ - if ((res = mp_gcd(a, b, &t1)) != MP_OKAY) { + if ((err = mp_gcd(a, b, &t1)) != MP_OKAY) { goto LBL_T; } /* divide the smallest by the GCD */ if (mp_cmp_mag(a, b) == MP_LT) { /* store quotient in t2 such that t2 * b is the LCM */ - if ((res = mp_div(a, &t1, &t2, NULL)) != MP_OKAY) { + if ((err = mp_div(a, &t1, &t2, NULL)) != MP_OKAY) { goto LBL_T; } - res = mp_mul(b, &t2, c); + err = mp_mul(b, &t2, c); } else { /* store quotient in t2 such that t2 * a is the LCM */ - if ((res = mp_div(b, &t1, &t2, NULL)) != MP_OKAY) { + if ((err = mp_div(b, &t1, &t2, NULL)) != MP_OKAY) { goto LBL_T; } - res = mp_mul(a, &t2, c); + err = mp_mul(a, &t2, c); } /* fix the sign to positive */ c->sign = MP_ZPOS; LBL_T: mp_clear_multi(&t1, &t2, NULL); - return res; + return err; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ ADDED libtommath/bn_mp_log_u32.c Index: libtommath/bn_mp_log_u32.c ================================================================== --- /dev/null +++ libtommath/bn_mp_log_u32.c @@ -0,0 +1,180 @@ +#include "tommath_private.h" +#ifdef BN_MP_LOG_U32_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +/* Compute log_{base}(a) */ +static mp_word s_pow(mp_word base, mp_word exponent) +{ + mp_word result = 1; + while (exponent != 0u) { + if ((exponent & 1u) == 1u) { + result *= base; + } + exponent >>= 1; + base *= base; + } + + return result; +} + +static mp_digit s_digit_ilogb(mp_digit base, mp_digit n) +{ + mp_word bracket_low = 1, bracket_mid, bracket_high, N; + mp_digit ret, high = 1uL, low = 0uL, mid; + + if (n < base) { + return 0uL; + } + if (n == base) { + return 1uL; + } + + bracket_high = (mp_word) base ; + N = (mp_word) n; + + while (bracket_high < N) { + low = high; + bracket_low = bracket_high; + high <<= 1; + bracket_high *= bracket_high; + } + + while (((mp_digit)(high - low)) > 1uL) { + mid = (low + high) >> 1; + bracket_mid = bracket_low * s_pow(base, (mp_word)(mid - low)); + + if (N < bracket_mid) { + high = mid ; + bracket_high = bracket_mid ; + } + if (N > bracket_mid) { + low = mid ; + bracket_low = bracket_mid ; + } + if (N == bracket_mid) { + return (mp_digit) mid; + } + } + + if (bracket_high == N) { + ret = high; + } else { + ret = low; + } + + return ret; +} + +/* TODO: output could be "int" because the output of mp_radix_size is int, too, + as is the output of mp_bitcount. + With the same problem: max size is INT_MAX * MP_DIGIT not INT_MAX only! +*/ +mp_err mp_log_u32(const mp_int *a, unsigned int base, unsigned int *c) +{ + mp_err err; + mp_ord cmp; + unsigned int high, low, mid; + mp_int bracket_low, bracket_high, bracket_mid, t, bi_base; + + err = MP_OKAY; + + if (a->sign == MP_NEG) { + return MP_VAL; + } + + if (MP_IS_ZERO(a)) { + return MP_VAL; + } + + if (base < 2u) { + return MP_VAL; + } + + /* A small shortcut for bases that are powers of two. */ + if ((base & (base - 1u)) == 0u) { + int y, bit_count; + for (y=0; (y < 7) && ((base & 1u) == 0u); y++) { + base >>= 1; + } + bit_count = mp_count_bits(a) - 1; + *c = (unsigned int)(bit_count/y); + return MP_OKAY; + } + + if (a->used == 1) { + *c = (unsigned int)s_digit_ilogb(base, a->dp[0]); + return err; + } + + cmp = mp_cmp_d(a, base); + if ((cmp == MP_LT) || (cmp == MP_EQ)) { + *c = cmp == MP_EQ; + return err; + } + + if ((err = + mp_init_multi(&bracket_low, &bracket_high, + &bracket_mid, &t, &bi_base, NULL)) != MP_OKAY) { + return err; + } + + low = 0u; + mp_set(&bracket_low, 1uL); + high = 1u; + + mp_set(&bracket_high, base); + + /* + A kind of Giant-step/baby-step algorithm. + Idea shamelessly stolen from https://programmingpraxis.com/2010/05/07/integer-logarithms/2/ + The effect is asymptotic, hence needs benchmarks to test if the Giant-step should be skipped + for small n. + */ + while (mp_cmp(&bracket_high, a) == MP_LT) { + low = high; + if ((err = mp_copy(&bracket_high, &bracket_low)) != MP_OKAY) { + goto LBL_ERR; + } + high <<= 1; + if ((err = mp_sqr(&bracket_high, &bracket_high)) != MP_OKAY) { + goto LBL_ERR; + } + } + mp_set(&bi_base, base); + + while ((high - low) > 1u) { + mid = (high + low) >> 1; + + if ((err = mp_expt_u32(&bi_base, mid - low, &t)) != MP_OKAY) { + goto LBL_ERR; + } + if ((err = mp_mul(&bracket_low, &t, &bracket_mid)) != MP_OKAY) { + goto LBL_ERR; + } + cmp = mp_cmp(a, &bracket_mid); + if (cmp == MP_LT) { + high = mid; + mp_exch(&bracket_mid, &bracket_high); + } + if (cmp == MP_GT) { + low = mid; + mp_exch(&bracket_mid, &bracket_low); + } + if (cmp == MP_EQ) { + *c = mid; + goto LBL_END; + } + } + + *c = (mp_cmp(&bracket_high, a) == MP_EQ) ? high : low; + +LBL_END: +LBL_ERR: + mp_clear_multi(&bracket_low, &bracket_high, &bracket_mid, + &t, &bi_base, NULL); + return err; +} + + +#endif Index: libtommath/bn_mp_lshd.c ================================================================== --- libtommath/bn_mp_lshd.c +++ libtommath/bn_mp_lshd.c @@ -1,68 +1,51 @@ #include "tommath_private.h" #ifdef BN_MP_LSHD_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* shift left a certain amount of digits */ -int mp_lshd(mp_int *a, int b) +mp_err mp_lshd(mp_int *a, int b) { - int x, res; + int x; + mp_err err; + mp_digit *top, *bottom; /* if its less than zero return */ if (b <= 0) { return MP_OKAY; } /* no need to shift 0 around */ - if (mp_iszero(a) == MP_YES) { + if (MP_IS_ZERO(a)) { return MP_OKAY; } /* grow to fit the new digits */ if (a->alloc < (a->used + b)) { - if ((res = mp_grow(a, a->used + b)) != MP_OKAY) { - return res; - } - } - - { - mp_digit *top, *bottom; - - /* increment the used by the shift amount then copy upwards */ - a->used += b; - - /* top */ - top = a->dp + a->used - 1; - - /* base */ - bottom = (a->dp + a->used - 1) - b; - - /* much like mp_rshd this is implemented using a sliding window - * except the window goes the otherway around. Copying from - * the bottom to the top. see bn_mp_rshd.c for more info. - */ - for (x = a->used - 1; x >= b; x--) { - *top-- = *bottom--; - } - - /* zero the lower digits */ - top = a->dp; - for (x = 0; x < b; x++) { - *top++ = 0; - } - } - return MP_OKAY; -} -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ + if ((err = mp_grow(a, a->used + b)) != MP_OKAY) { + return err; + } + } + + /* increment the used by the shift amount then copy upwards */ + a->used += b; + + /* top */ + top = a->dp + a->used - 1; + + /* base */ + bottom = (a->dp + a->used - 1) - b; + + /* much like mp_rshd this is implemented using a sliding window + * except the window goes the otherway around. Copying from + * the bottom to the top. see bn_mp_rshd.c for more info. + */ + for (x = a->used - 1; x >= b; x--) { + *top-- = *bottom--; + } + + /* zero the lower digits */ + MP_ZERO_DIGITS(a->dp, b); + + return MP_OKAY; +} +#endif Index: libtommath/bn_mp_mod.c ================================================================== --- libtommath/bn_mp_mod.c +++ libtommath/bn_mp_mod.c @@ -1,44 +1,31 @@ #include "tommath_private.h" #ifdef BN_MP_MOD_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* c = a mod b, 0 <= c < b if b > 0, b < c <= 0 if b < 0 */ -int mp_mod(const mp_int *a, const mp_int *b, mp_int *c) -{ - mp_int t; - int res; - - if ((res = mp_init_size(&t, b->used)) != MP_OKAY) { - return res; - } - - if ((res = mp_div(a, b, NULL, &t)) != MP_OKAY) { - mp_clear(&t); - return res; - } - - if ((mp_iszero(&t) != MP_NO) || (t.sign == b->sign)) { - res = MP_OKAY; - mp_exch(&t, c); - } else { - res = mp_add(b, &t, c); - } - - mp_clear(&t); - return res; -} -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +/* c = a mod b, 0 <= c < b if b > 0, b < c <= 0 if b < 0 */ +mp_err mp_mod(const mp_int *a, const mp_int *b, mp_int *c) +{ + mp_int t; + mp_err err; + + if ((err = mp_init_size(&t, b->used)) != MP_OKAY) { + return err; + } + + if ((err = mp_div(a, b, NULL, &t)) != MP_OKAY) { + goto LBL_ERR; + } + + if (MP_IS_ZERO(&t) || (t.sign == b->sign)) { + err = MP_OKAY; + mp_exch(&t, c); + } else { + err = mp_add(b, &t, c); + } + +LBL_ERR: + mp_clear(&t); + return err; +} +#endif Index: libtommath/bn_mp_mod_2d.c ================================================================== --- libtommath/bn_mp_mod_2d.c +++ libtommath/bn_mp_mod_2d.c @@ -1,51 +1,38 @@ #include "tommath_private.h" #ifdef BN_MP_MOD_2D_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* calc a value mod 2**b */ -int mp_mod_2d(const mp_int *a, int b, mp_int *c) +mp_err mp_mod_2d(const mp_int *a, int b, mp_int *c) { - int x, res; + int x; + mp_err err; /* if b is <= 0 then zero the int */ if (b <= 0) { mp_zero(c); return MP_OKAY; } /* if the modulus is larger than the value than return */ - if (b >= (a->used * DIGIT_BIT)) { - res = mp_copy(a, c); - return res; + if (b >= (a->used * MP_DIGIT_BIT)) { + return mp_copy(a, c); } /* copy */ - if ((res = mp_copy(a, c)) != MP_OKAY) { - return res; + if ((err = mp_copy(a, c)) != MP_OKAY) { + return err; } /* zero digits above the last digit of the modulus */ - for (x = (b / DIGIT_BIT) + (((b % DIGIT_BIT) == 0) ? 0 : 1); x < c->used; x++) { - c->dp[x] = 0; - } + x = (b / MP_DIGIT_BIT) + (((b % MP_DIGIT_BIT) == 0) ? 0 : 1); + MP_ZERO_DIGITS(c->dp + x, c->used - x); + /* clear the digit that is not completely outside/inside the modulus */ - c->dp[b / DIGIT_BIT] &= - ((mp_digit)1 << (mp_digit)(b % DIGIT_BIT)) - (mp_digit)1; + c->dp[b / MP_DIGIT_BIT] &= + ((mp_digit)1 << (mp_digit)(b % MP_DIGIT_BIT)) - (mp_digit)1; mp_clamp(c); return MP_OKAY; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_mod_d.c ================================================================== --- libtommath/bn_mp_mod_d.c +++ libtommath/bn_mp_mod_d.c @@ -1,23 +1,10 @@ #include "tommath_private.h" #ifdef BN_MP_MOD_D_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -int mp_mod_d(const mp_int *a, mp_digit b, mp_digit *c) +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +mp_err mp_mod_d(const mp_int *a, mp_digit b, mp_digit *c) { return mp_div_d(a, b, NULL, c); } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_montgomery_calc_normalization.c ================================================================== --- libtommath/bn_mp_montgomery_calc_normalization.c +++ libtommath/bn_mp_montgomery_calc_normalization.c @@ -1,56 +1,44 @@ #include "tommath_private.h" #ifdef BN_MP_MONTGOMERY_CALC_NORMALIZATION_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* * shifts with subtractions when the result is greater than b. * * The method is slightly modified to shift B unconditionally upto just under * the leading bit of b. This saves alot of multiple precision shifting. */ -int mp_montgomery_calc_normalization(mp_int *a, const mp_int *b) +mp_err mp_montgomery_calc_normalization(mp_int *a, const mp_int *b) { - int x, bits, res; + int x, bits; + mp_err err; /* how many bits of last digit does b use */ - bits = mp_count_bits(b) % DIGIT_BIT; + bits = mp_count_bits(b) % MP_DIGIT_BIT; if (b->used > 1) { - if ((res = mp_2expt(a, ((b->used - 1) * DIGIT_BIT) + bits - 1)) != MP_OKAY) { - return res; + if ((err = mp_2expt(a, ((b->used - 1) * MP_DIGIT_BIT) + bits - 1)) != MP_OKAY) { + return err; } } else { mp_set(a, 1uL); bits = 1; } /* now compute C = A * B mod b */ - for (x = bits - 1; x < (int)DIGIT_BIT; x++) { - if ((res = mp_mul_2(a, a)) != MP_OKAY) { - return res; + for (x = bits - 1; x < (int)MP_DIGIT_BIT; x++) { + if ((err = mp_mul_2(a, a)) != MP_OKAY) { + return err; } if (mp_cmp_mag(a, b) != MP_LT) { - if ((res = s_mp_sub(a, b, a)) != MP_OKAY) { - return res; + if ((err = s_mp_sub(a, b, a)) != MP_OKAY) { + return err; } } } return MP_OKAY; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_montgomery_reduce.c ================================================================== --- libtommath/bn_mp_montgomery_reduce.c +++ libtommath/bn_mp_montgomery_reduce.c @@ -1,43 +1,34 @@ #include "tommath_private.h" #ifdef BN_MP_MONTGOMERY_REDUCE_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* computes xR**-1 == x (mod N) via Montgomery Reduction */ -int mp_montgomery_reduce(mp_int *x, const mp_int *n, mp_digit rho) +mp_err mp_montgomery_reduce(mp_int *x, const mp_int *n, mp_digit rho) { - int ix, res, digs; + int ix, digs; + mp_err err; mp_digit mu; /* can the fast reduction [comba] method be used? * * Note that unlike in mul you're safely allowed *less* * than the available columns [255 per default] since carries * are fixed up in the inner loop. */ digs = (n->used * 2) + 1; - if ((digs < (int)MP_WARRAY) && - (x->used <= (int)MP_WARRAY) && - (n->used < - (int)(1u << (((size_t)CHAR_BIT * sizeof(mp_word)) - (2u * (size_t)DIGIT_BIT))))) { - return fast_mp_montgomery_reduce(x, n, rho); + if ((digs < MP_WARRAY) && + (x->used <= MP_WARRAY) && + (n->used < MP_MAXFAST)) { + return s_mp_montgomery_reduce_fast(x, n, rho); } /* grow the input as required */ if (x->alloc < digs) { - if ((res = mp_grow(x, digs)) != MP_OKAY) { - return res; + if ((err = mp_grow(x, digs)) != MP_OKAY) { + return err; } } x->used = digs; for (ix = 0; ix < n->used; ix++) { @@ -71,11 +62,11 @@ /* compute product and sum */ r = ((mp_word)mu * (mp_word)*tmpn++) + (mp_word)u + (mp_word)*tmpx; /* get carry */ - u = (mp_digit)(r >> (mp_word)DIGIT_BIT); + u = (mp_digit)(r >> (mp_word)MP_DIGIT_BIT); /* fix digit */ *tmpx++ = (mp_digit)(r & (mp_word)MP_MASK); } /* At this point the ix'th digit of x should be zero */ @@ -82,11 +73,11 @@ /* propagate carries upwards as required*/ while (u != 0u) { *tmpx += u; - u = *tmpx >> DIGIT_BIT; + u = *tmpx >> MP_DIGIT_BIT; *tmpx++ &= MP_MASK; } } } @@ -107,9 +98,5 @@ } return MP_OKAY; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_montgomery_setup.c ================================================================== --- libtommath/bn_mp_montgomery_setup.c +++ libtommath/bn_mp_montgomery_setup.c @@ -1,21 +1,12 @@ #include "tommath_private.h" #ifdef BN_MP_MONTGOMERY_SETUP_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* setups the montgomery reduction stuff */ -int mp_montgomery_setup(const mp_int *n, mp_digit *rho) +mp_err mp_montgomery_setup(const mp_int *n, mp_digit *rho) { mp_digit x, b; /* fast inversion mod 2**k * @@ -42,14 +33,10 @@ #ifdef MP_64BIT x *= 2u - (b * x); /* here x*a==1 mod 2**64 */ #endif /* rho = -1/m mod b */ - *rho = (mp_digit)(((mp_word)1 << (mp_word)DIGIT_BIT) - x) & MP_MASK; + *rho = (mp_digit)(((mp_word)1 << (mp_word)MP_DIGIT_BIT) - x) & MP_MASK; return MP_OKAY; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_mul.c ================================================================== --- libtommath/bn_mp_mul.c +++ libtommath/bn_mp_mul.c @@ -1,64 +1,54 @@ #include "tommath_private.h" #ifdef BN_MP_MUL_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* high level multiplication (handles sign) */ -int mp_mul(const mp_int *a, const mp_int *b, mp_int *c) -{ - int res, neg; - neg = (a->sign == b->sign) ? MP_ZPOS : MP_NEG; - - /* use Toom-Cook? */ -#ifdef BN_MP_TOOM_MUL_C - if (MIN(a->used, b->used) >= TOOM_MUL_CUTOFF) { - res = mp_toom_mul(a, b, c); - } else -#endif -#ifdef BN_MP_KARATSUBA_MUL_C - /* use Karatsuba? */ - if (MIN(a->used, b->used) >= KARATSUBA_MUL_CUTOFF) { - res = mp_karatsuba_mul(a, b, c); - } else -#endif - { - /* can we use the fast multiplier? - * - * The fast multiplier can be used if the output will - * have less than MP_WARRAY digits and the number of - * digits won't affect carry propagation - */ - int digs = a->used + b->used + 1; - -#ifdef BN_FAST_S_MP_MUL_DIGS_C - if ((digs < (int)MP_WARRAY) && - (MIN(a->used, b->used) <= - (int)(1u << (((size_t)CHAR_BIT * sizeof(mp_word)) - (2u * (size_t)DIGIT_BIT))))) { - res = fast_s_mp_mul_digs(a, b, c, digs); - } else -#endif - { -#ifdef BN_S_MP_MUL_DIGS_C - res = s_mp_mul(a, b, c); /* uses s_mp_mul_digs */ -#else - res = MP_VAL; -#endif - } - } - c->sign = (c->used > 0) ? neg : MP_ZPOS; - return res; -} -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ +mp_err mp_mul(const mp_int *a, const mp_int *b, mp_int *c) +{ + mp_err err; + int min_len = MP_MIN(a->used, b->used), + max_len = MP_MAX(a->used, b->used), + digs = a->used + b->used + 1; + mp_sign neg = (a->sign == b->sign) ? MP_ZPOS : MP_NEG; + + if (a == b) { + return mp_sqr(a,c); + } else if (MP_HAS(S_MP_BALANCE_MUL) && + /* Check sizes. The smaller one needs to be larger than the Karatsuba cut-off. + * The bigger one needs to be at least about one MP_KARATSUBA_MUL_CUTOFF bigger + * to make some sense, but it depends on architecture, OS, position of the + * stars... so YMMV. + * Using it to cut the input into slices small enough for fast_s_mp_mul_digs + * was actually slower on the author's machine, but YMMV. + */ + (min_len >= MP_KARATSUBA_MUL_CUTOFF) && + ((max_len / 2) >= MP_KARATSUBA_MUL_CUTOFF) && + /* Not much effect was observed below a ratio of 1:2, but again: YMMV. */ + (max_len >= (2 * min_len))) { + err = s_mp_balance_mul(a,b,c); + } else if (MP_HAS(S_MP_TOOM_MUL) && + (min_len >= MP_TOOM_MUL_CUTOFF)) { + err = s_mp_toom_mul(a, b, c); + } else if (MP_HAS(S_MP_KARATSUBA_MUL) && + (min_len >= MP_KARATSUBA_MUL_CUTOFF)) { + err = s_mp_karatsuba_mul(a, b, c); + } else if (MP_HAS(S_MP_MUL_DIGS_FAST) && + /* can we use the fast multiplier? + * + * The fast multiplier can be used if the output will + * have less than MP_WARRAY digits and the number of + * digits won't affect carry propagation + */ + (digs < MP_WARRAY) && + (min_len <= MP_MAXFAST)) { + err = s_mp_mul_digs_fast(a, b, c, digs); + } else if (MP_HAS(S_MP_MUL_DIGS)) { + err = s_mp_mul_digs(a, b, c, digs); + } else { + err = MP_VAL; + } + c->sign = (c->used > 0) ? neg : MP_ZPOS; + return err; +} +#endif Index: libtommath/bn_mp_mul_2.c ================================================================== --- libtommath/bn_mp_mul_2.c +++ libtommath/bn_mp_mul_2.c @@ -1,28 +1,20 @@ #include "tommath_private.h" #ifdef BN_MP_MUL_2_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* b = a*2 */ -int mp_mul_2(const mp_int *a, mp_int *b) +mp_err mp_mul_2(const mp_int *a, mp_int *b) { - int x, res, oldused; + int x, oldused; + mp_err err; /* grow to accomodate result */ if (b->alloc < (a->used + 1)) { - if ((res = mp_grow(b, a->used + 1)) != MP_OKAY) { - return res; + if ((err = mp_grow(b, a->used + 1)) != MP_OKAY) { + return err; } } oldused = b->used; b->used = a->used; @@ -41,11 +33,11 @@ for (x = 0; x < a->used; x++) { /* get what will be the *next* carry bit from the * MSB of the current digit */ - rr = *tmpa >> (mp_digit)(DIGIT_BIT - 1); + rr = *tmpa >> (mp_digit)(MP_DIGIT_BIT - 1); /* now shift up this digit, add in the carry [from the previous] */ *tmpb++ = ((*tmpa++ << 1uL) | r) & MP_MASK; /* copy the carry that would be from the source @@ -62,18 +54,11 @@ } /* now zero any excess digits on the destination * that we didn't write to */ - tmpb = b->dp + b->used; - for (x = b->used; x < oldused; x++) { - *tmpb++ = 0; - } + MP_ZERO_DIGITS(b->dp + b->used, oldused - b->used); } b->sign = a->sign; return MP_OKAY; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_mul_2d.c ================================================================== --- libtommath/bn_mp_mul_2d.c +++ libtommath/bn_mp_mul_2d.c @@ -1,56 +1,47 @@ #include "tommath_private.h" #ifdef BN_MP_MUL_2D_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* shift left by a certain bit count */ -int mp_mul_2d(const mp_int *a, int b, mp_int *c) +mp_err mp_mul_2d(const mp_int *a, int b, mp_int *c) { mp_digit d; - int res; + mp_err err; /* copy */ if (a != c) { - if ((res = mp_copy(a, c)) != MP_OKAY) { - return res; + if ((err = mp_copy(a, c)) != MP_OKAY) { + return err; } } - if (c->alloc < (c->used + (b / DIGIT_BIT) + 1)) { - if ((res = mp_grow(c, c->used + (b / DIGIT_BIT) + 1)) != MP_OKAY) { - return res; + if (c->alloc < (c->used + (b / MP_DIGIT_BIT) + 1)) { + if ((err = mp_grow(c, c->used + (b / MP_DIGIT_BIT) + 1)) != MP_OKAY) { + return err; } } /* shift by as many digits in the bit count */ - if (b >= DIGIT_BIT) { - if ((res = mp_lshd(c, b / DIGIT_BIT)) != MP_OKAY) { - return res; + if (b >= MP_DIGIT_BIT) { + if ((err = mp_lshd(c, b / MP_DIGIT_BIT)) != MP_OKAY) { + return err; } } - /* shift any bit count < DIGIT_BIT */ - d = (mp_digit)(b % DIGIT_BIT); + /* shift any bit count < MP_DIGIT_BIT */ + d = (mp_digit)(b % MP_DIGIT_BIT); if (d != 0u) { mp_digit *tmpc, shift, mask, r, rr; int x; /* bitmask for carries */ mask = ((mp_digit)1 << d) - (mp_digit)1; /* shift for msbs */ - shift = (mp_digit)DIGIT_BIT - d; + shift = (mp_digit)MP_DIGIT_BIT - d; /* alias */ tmpc = c->dp; /* carry */ @@ -74,9 +65,5 @@ } mp_clamp(c); return MP_OKAY; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_mul_d.c ================================================================== --- libtommath/bn_mp_mul_d.c +++ libtommath/bn_mp_mul_d.c @@ -1,30 +1,22 @@ #include "tommath_private.h" #ifdef BN_MP_MUL_D_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* multiply by a digit */ -int mp_mul_d(const mp_int *a, mp_digit b, mp_int *c) +mp_err mp_mul_d(const mp_int *a, mp_digit b, mp_int *c) { mp_digit u, *tmpa, *tmpc; mp_word r; - int ix, res, olduse; + mp_err err; + int ix, olduse; /* make sure c is big enough to hold a*b */ if (c->alloc < (a->used + 1)) { - if ((res = mp_grow(c, a->used + 1)) != MP_OKAY) { - return res; + if ((err = mp_grow(c, a->used + 1)) != MP_OKAY) { + return err; } } /* get the original destinations used count */ olduse = c->used; @@ -48,28 +40,22 @@ /* mask off higher bits to get a single digit */ *tmpc++ = (mp_digit)(r & (mp_word)MP_MASK); /* send carry into next iteration */ - u = (mp_digit)(r >> (mp_word)DIGIT_BIT); + u = (mp_digit)(r >> (mp_word)MP_DIGIT_BIT); } /* store final carry [if any] and increment ix offset */ *tmpc++ = u; ++ix; /* now zero digits above the top */ - while (ix++ < olduse) { - *tmpc++ = 0; - } + MP_ZERO_DIGITS(tmpc, olduse - ix); /* set used count */ c->used = a->used + 1; mp_clamp(c); return MP_OKAY; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_mulmod.c ================================================================== --- libtommath/bn_mp_mulmod.c +++ libtommath/bn_mp_mulmod.c @@ -1,37 +1,25 @@ #include "tommath_private.h" #ifdef BN_MP_MULMOD_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* d = a * b (mod c) */ -int mp_mulmod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d) -{ - int res; - mp_int t; - - if ((res = mp_init_size(&t, c->used)) != MP_OKAY) { - return res; - } - - if ((res = mp_mul(a, b, &t)) != MP_OKAY) { - mp_clear(&t); - return res; - } - res = mp_mod(&t, c, d); - mp_clear(&t); - return res; +mp_err mp_mulmod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d) +{ + mp_err err; + mp_int t; + + if ((err = mp_init_size(&t, c->used)) != MP_OKAY) { + return err; + } + + if ((err = mp_mul(a, b, &t)) != MP_OKAY) { + goto LBL_ERR; + } + err = mp_mod(&t, c, d); + +LBL_ERR: + mp_clear(&t); + return err; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ DELETED libtommath/bn_mp_n_root.c Index: libtommath/bn_mp_n_root.c ================================================================== --- libtommath/bn_mp_n_root.c +++ /dev/null @@ -1,27 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_MP_N_ROOT_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* wrapper function for mp_n_root_ex() - * computes c = (a)**(1/b) such that (c)**b <= a and (c+1)**b > a - */ -int mp_n_root(const mp_int *a, mp_digit b, mp_int *c) -{ - return mp_n_root_ex(a, b, c, 0); -} - -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ DELETED libtommath/bn_mp_n_root_ex.c Index: libtommath/bn_mp_n_root_ex.c ================================================================== --- libtommath/bn_mp_n_root_ex.c +++ /dev/null @@ -1,129 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_MP_N_ROOT_EX_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* find the n'th root of an integer - * - * Result found such that (c)**b <= a and (c+1)**b > a - * - * This algorithm uses Newton's approximation - * x[i+1] = x[i] - f(x[i])/f'(x[i]) - * which will find the root in log(N) time where - * each step involves a fair bit. This is not meant to - * find huge roots [square and cube, etc]. - */ -int mp_n_root_ex(const mp_int *a, mp_digit b, mp_int *c, int fast) -{ - mp_int t1, t2, t3, a_; - int res; - - /* input must be positive if b is even */ - if (((b & 1u) == 0u) && (a->sign == MP_NEG)) { - return MP_VAL; - } - - if ((res = mp_init(&t1)) != MP_OKAY) { - return res; - } - - if ((res = mp_init(&t2)) != MP_OKAY) { - goto LBL_T1; - } - - if ((res = mp_init(&t3)) != MP_OKAY) { - goto LBL_T2; - } - - /* if a is negative fudge the sign but keep track */ - a_ = *a; - a_.sign = MP_ZPOS; - - /* t2 = 2 */ - mp_set(&t2, 2uL); - - do { - /* t1 = t2 */ - if ((res = mp_copy(&t2, &t1)) != MP_OKAY) { - goto LBL_T3; - } - - /* t2 = t1 - ((t1**b - a) / (b * t1**(b-1))) */ - - /* t3 = t1**(b-1) */ - if ((res = mp_expt_d_ex(&t1, b - 1u, &t3, fast)) != MP_OKAY) { - goto LBL_T3; - } - - /* numerator */ - /* t2 = t1**b */ - if ((res = mp_mul(&t3, &t1, &t2)) != MP_OKAY) { - goto LBL_T3; - } - - /* t2 = t1**b - a */ - if ((res = mp_sub(&t2, &a_, &t2)) != MP_OKAY) { - goto LBL_T3; - } - - /* denominator */ - /* t3 = t1**(b-1) * b */ - if ((res = mp_mul_d(&t3, b, &t3)) != MP_OKAY) { - goto LBL_T3; - } - - /* t3 = (t1**b - a)/(b * t1**(b-1)) */ - if ((res = mp_div(&t2, &t3, &t3, NULL)) != MP_OKAY) { - goto LBL_T3; - } - - if ((res = mp_sub(&t1, &t3, &t2)) != MP_OKAY) { - goto LBL_T3; - } - } while (mp_cmp(&t1, &t2) != MP_EQ); - - /* result can be off by a few so check */ - for (;;) { - if ((res = mp_expt_d_ex(&t1, b, &t2, fast)) != MP_OKAY) { - goto LBL_T3; - } - - if (mp_cmp(&t2, &a_) == MP_GT) { - if ((res = mp_sub_d(&t1, 1uL, &t1)) != MP_OKAY) { - goto LBL_T3; - } - } else { - break; - } - } - - /* set the result */ - mp_exch(&t1, c); - - /* set the sign of the result */ - c->sign = a->sign; - - res = MP_OKAY; - -LBL_T3: - mp_clear(&t3); -LBL_T2: - mp_clear(&t2); -LBL_T1: - mp_clear(&t1); - return res; -} -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_neg.c ================================================================== --- libtommath/bn_mp_neg.c +++ libtommath/bn_mp_neg.c @@ -1,37 +1,24 @@ #include "tommath_private.h" #ifdef BN_MP_NEG_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* b = -a */ -int mp_neg(const mp_int *a, mp_int *b) -{ - int res; - if (a != b) { - if ((res = mp_copy(a, b)) != MP_OKAY) { - return res; - } - } - - if (mp_iszero(b) != MP_YES) { +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +/* b = -a */ +mp_err mp_neg(const mp_int *a, mp_int *b) +{ + mp_err err; + if (a != b) { + if ((err = mp_copy(a, b)) != MP_OKAY) { + return err; + } + } + + if (!MP_IS_ZERO(b)) { b->sign = (a->sign == MP_ZPOS) ? MP_NEG : MP_ZPOS; } else { b->sign = MP_ZPOS; } return MP_OKAY; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_or.c ================================================================== --- libtommath/bn_mp_or.c +++ libtommath/bn_mp_or.c @@ -4,11 +4,11 @@ /* SPDX-License-Identifier: Unlicense */ /* two complement or */ mp_err mp_or(const mp_int *a, const mp_int *b, mp_int *c) { - int used = MAX(a->used, b->used) + 1, i; + int used = MP_MAX(a->used, b->used) + 1, i; mp_err err; mp_digit ac = 1, bc = 1, cc = 1; mp_sign csign = ((a->sign == MP_NEG) || (b->sign == MP_NEG)) ? MP_NEG : MP_ZPOS; if (c->alloc < used) { ADDED libtommath/bn_mp_pack.c Index: libtommath/bn_mp_pack.c ================================================================== --- /dev/null +++ libtommath/bn_mp_pack.c @@ -0,0 +1,69 @@ +#include "tommath_private.h" +#ifdef BN_MP_PACK_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +/* based on gmp's mpz_export. + * see http://gmplib.org/manual/Integer-Import-and-Export.html + */ +mp_err mp_pack(void *rop, size_t maxcount, size_t *written, mp_order order, size_t size, + mp_endian endian, size_t nails, const mp_int *op) +{ + mp_err err; + size_t odd_nails, nail_bytes, i, j, count; + unsigned char odd_nail_mask; + + mp_int t; + + count = mp_pack_count(op, nails, size); + + if (count > maxcount) { + return MP_BUF; + } + + if ((err = mp_init_copy(&t, op)) != MP_OKAY) { + return err; + } + + if (endian == MP_NATIVE_ENDIAN) { + MP_GET_ENDIANNESS(endian); + } + + odd_nails = (nails % 8u); + odd_nail_mask = 0xff; + for (i = 0u; i < odd_nails; ++i) { + odd_nail_mask ^= (unsigned char)(1u << (7u - i)); + } + nail_bytes = nails / 8u; + + for (i = 0u; i < count; ++i) { + for (j = 0u; j < size; ++j) { + unsigned char *byte = (unsigned char *)rop + + (((order == MP_LSB_FIRST) ? i : ((count - 1u) - i)) * size) + + ((endian == MP_LITTLE_ENDIAN) ? j : ((size - 1u) - j)); + + if (j >= (size - nail_bytes)) { + *byte = 0; + continue; + } + + *byte = (unsigned char)((j == ((size - nail_bytes) - 1u)) ? (t.dp[0] & odd_nail_mask) : (t.dp[0] & 0xFFuL)); + + if ((err = mp_div_2d(&t, (j == ((size - nail_bytes) - 1u)) ? (int)(8u - odd_nails) : 8, &t, NULL)) != MP_OKAY) { + goto LBL_ERR; + } + + } + } + + if (written != NULL) { + *written = count; + } + err = MP_OKAY; + +LBL_ERR: + mp_clear(&t); + return err; +} + +#endif ADDED libtommath/bn_mp_pack_count.c Index: libtommath/bn_mp_pack_count.c ================================================================== --- /dev/null +++ libtommath/bn_mp_pack_count.c @@ -0,0 +1,12 @@ +#include "tommath_private.h" +#ifdef BN_MP_PACK_COUNT_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +size_t mp_pack_count(const mp_int *a, size_t nails, size_t size) +{ + size_t bits = (size_t)mp_count_bits(a); + return ((bits / ((size * 8u) - nails)) + (((bits % ((size * 8u) - nails)) != 0u) ? 1u : 0u)); +} + +#endif Index: libtommath/bn_mp_prime_fermat.c ================================================================== --- libtommath/bn_mp_prime_fermat.c +++ libtommath/bn_mp_prime_fermat.c @@ -1,31 +1,22 @@ #include "tommath_private.h" #ifdef BN_MP_PRIME_FERMAT_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* performs one Fermat test. * * If "a" were prime then b**a == b (mod a) since the order of * the multiplicative sub-group would be phi(a) = a-1. That means * it would be the same as b**(a mod (a-1)) == b**1 == b (mod a). * * Sets result to 1 if the congruence holds, or zero otherwise. */ -int mp_prime_fermat(const mp_int *a, const mp_int *b, int *result) +mp_err mp_prime_fermat(const mp_int *a, const mp_int *b, mp_bool *result) { mp_int t; - int err; + mp_err err; /* default to composite */ *result = MP_NO; /* ensure b > 1 */ @@ -52,9 +43,5 @@ LBL_T: mp_clear(&t); return err; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_prime_frobenius_underwood.c ================================================================== --- libtommath/bn_mp_prime_frobenius_underwood.c +++ libtommath/bn_mp_prime_frobenius_underwood.c @@ -1,24 +1,15 @@ #include "tommath_private.h" #ifdef BN_MP_PRIME_FROBENIUS_UNDERWOOD_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* * See file bn_mp_prime_is_prime.c or the documentation in doc/bn.tex for the details */ -#ifndef LTM_USE_FIPS_ONLY +#ifndef LTM_USE_ONLY_MR #ifdef MP_8BIT /* * floor of positive solution of * (2^16)-1 = (a+4)*(2*a+5) @@ -30,45 +21,37 @@ */ #define LTM_FROBENIUS_UNDERWOOD_A 177 #else #define LTM_FROBENIUS_UNDERWOOD_A 32764 #endif -int mp_prime_frobenius_underwood(const mp_int *N, int *result) +mp_err mp_prime_frobenius_underwood(const mp_int *N, mp_bool *result) { mp_int T1z, T2z, Np1z, sz, tz; - int a, ap2, length, i, j, isset; - int e; + int a, ap2, length, i, j; + mp_err err; *result = MP_NO; - if ((e = mp_init_multi(&T1z, &T2z, &Np1z, &sz, &tz, NULL)) != MP_OKAY) { - return e; + if ((err = mp_init_multi(&T1z, &T2z, &Np1z, &sz, &tz, NULL)) != MP_OKAY) { + return err; } for (a = 0; a < LTM_FROBENIUS_UNDERWOOD_A; a++) { /* TODO: That's ugly! No, really, it is! */ if ((a==2) || (a==4) || (a==7) || (a==8) || (a==10) || (a==14) || (a==18) || (a==23) || (a==26) || (a==28)) { continue; } /* (32764^2 - 4) < 2^31, no bigint for >MP_8BIT needed) */ - if ((e = mp_set_long(&T1z, (unsigned long)a)) != MP_OKAY) { - goto LBL_FU_ERR; - } - - if ((e = mp_sqr(&T1z, &T1z)) != MP_OKAY) { - goto LBL_FU_ERR; - } - - if ((e = mp_sub_d(&T1z, 4uL, &T1z)) != MP_OKAY) { - goto LBL_FU_ERR; - } - - if ((e = mp_kronecker(&T1z, N, &j)) != MP_OKAY) { - goto LBL_FU_ERR; - } + mp_set_u32(&T1z, (uint32_t)a); + + if ((err = mp_sqr(&T1z, &T1z)) != MP_OKAY) goto LBL_FU_ERR; + + if ((err = mp_sub_d(&T1z, 4uL, &T1z)) != MP_OKAY) goto LBL_FU_ERR; + + if ((err = mp_kronecker(&T1z, N, &j)) != MP_OKAY) goto LBL_FU_ERR; if (j == -1) { break; } @@ -77,30 +60,22 @@ goto LBL_FU_ERR; } } /* Tell it a composite and set return value accordingly */ if (a >= LTM_FROBENIUS_UNDERWOOD_A) { - e = MP_ITER; + err = MP_ITER; goto LBL_FU_ERR; } /* Composite if N and (a+4)*(2*a+5) are not coprime */ - if ((e = mp_set_long(&T1z, (unsigned long)((a+4)*((2*a)+5)))) != MP_OKAY) { - goto LBL_FU_ERR; - } - - if ((e = mp_gcd(N, &T1z, &T1z)) != MP_OKAY) { - goto LBL_FU_ERR; - } - - if (!((T1z.used == 1) && (T1z.dp[0] == 1u))) { - goto LBL_FU_ERR; - } + mp_set_u32(&T1z, (uint32_t)((a+4)*((2*a)+5))); + + if ((err = mp_gcd(N, &T1z, &T1z)) != MP_OKAY) goto LBL_FU_ERR; + + if (!((T1z.used == 1) && (T1z.dp[0] == 1u))) goto LBL_FU_ERR; ap2 = a + 2; - if ((e = mp_add_d(N, 1uL, &Np1z)) != MP_OKAY) { - goto LBL_FU_ERR; - } + if ((err = mp_add_d(N, 1uL, &Np1z)) != MP_OKAY) goto LBL_FU_ERR; mp_set(&sz, 1uL); mp_set(&tz, 2uL); length = mp_count_bits(&Np1z); @@ -108,91 +83,50 @@ /* * temp = (sz*(a*sz+2*tz))%N; * tz = ((tz-sz)*(tz+sz))%N; * sz = temp; */ - if ((e = mp_mul_2(&tz, &T2z)) != MP_OKAY) { - goto LBL_FU_ERR; - } + if ((err = mp_mul_2(&tz, &T2z)) != MP_OKAY) goto LBL_FU_ERR; /* a = 0 at about 50% of the cases (non-square and odd input) */ if (a != 0) { - if ((e = mp_mul_d(&sz, (mp_digit)a, &T1z)) != MP_OKAY) { - goto LBL_FU_ERR; - } - if ((e = mp_add(&T1z, &T2z, &T2z)) != MP_OKAY) { - goto LBL_FU_ERR; - } - } - - if ((e = mp_mul(&T2z, &sz, &T1z)) != MP_OKAY) { - goto LBL_FU_ERR; - } - if ((e = mp_sub(&tz, &sz, &T2z)) != MP_OKAY) { - goto LBL_FU_ERR; - } - if ((e = mp_add(&sz, &tz, &sz)) != MP_OKAY) { - goto LBL_FU_ERR; - } - if ((e = mp_mul(&sz, &T2z, &tz)) != MP_OKAY) { - goto LBL_FU_ERR; - } - if ((e = mp_mod(&tz, N, &tz)) != MP_OKAY) { - goto LBL_FU_ERR; - } - if ((e = mp_mod(&T1z, N, &sz)) != MP_OKAY) { - goto LBL_FU_ERR; - } - if ((isset = mp_get_bit(&Np1z, i)) == MP_VAL) { - e = isset; - goto LBL_FU_ERR; - } - if (isset == MP_YES) { + if ((err = mp_mul_d(&sz, (mp_digit)a, &T1z)) != MP_OKAY) goto LBL_FU_ERR; + if ((err = mp_add(&T1z, &T2z, &T2z)) != MP_OKAY) goto LBL_FU_ERR; + } + + if ((err = mp_mul(&T2z, &sz, &T1z)) != MP_OKAY) goto LBL_FU_ERR; + if ((err = mp_sub(&tz, &sz, &T2z)) != MP_OKAY) goto LBL_FU_ERR; + if ((err = mp_add(&sz, &tz, &sz)) != MP_OKAY) goto LBL_FU_ERR; + if ((err = mp_mul(&sz, &T2z, &tz)) != MP_OKAY) goto LBL_FU_ERR; + if ((err = mp_mod(&tz, N, &tz)) != MP_OKAY) goto LBL_FU_ERR; + if ((err = mp_mod(&T1z, N, &sz)) != MP_OKAY) goto LBL_FU_ERR; + if (s_mp_get_bit(&Np1z, (unsigned int)i) == MP_YES) { /* * temp = (a+2) * sz + tz * tz = 2 * tz - sz * sz = temp */ if (a == 0) { - if ((e = mp_mul_2(&sz, &T1z)) != MP_OKAY) { - goto LBL_FU_ERR; - } - } else { - if ((e = mp_mul_d(&sz, (mp_digit)ap2, &T1z)) != MP_OKAY) { - goto LBL_FU_ERR; - } - } - if ((e = mp_add(&T1z, &tz, &T1z)) != MP_OKAY) { - goto LBL_FU_ERR; - } - if ((e = mp_mul_2(&tz, &T2z)) != MP_OKAY) { - goto LBL_FU_ERR; - } - if ((e = mp_sub(&T2z, &sz, &tz)) != MP_OKAY) { - goto LBL_FU_ERR; - } + if ((err = mp_mul_2(&sz, &T1z)) != MP_OKAY) goto LBL_FU_ERR; + } else { + if ((err = mp_mul_d(&sz, (mp_digit)ap2, &T1z)) != MP_OKAY) goto LBL_FU_ERR; + } + if ((err = mp_add(&T1z, &tz, &T1z)) != MP_OKAY) goto LBL_FU_ERR; + if ((err = mp_mul_2(&tz, &T2z)) != MP_OKAY) goto LBL_FU_ERR; + if ((err = mp_sub(&T2z, &sz, &tz)) != MP_OKAY) goto LBL_FU_ERR; mp_exch(&sz, &T1z); } } - if ((e = mp_set_long(&T1z, (unsigned long)((2 * a) + 5))) != MP_OKAY) { - goto LBL_FU_ERR; - } - if ((e = mp_mod(&T1z, N, &T1z)) != MP_OKAY) { - goto LBL_FU_ERR; - } - if ((mp_iszero(&sz) != MP_NO) && (mp_cmp(&tz, &T1z) == MP_EQ)) { + mp_set_u32(&T1z, (uint32_t)((2 * a) + 5)); + if ((err = mp_mod(&T1z, N, &T1z)) != MP_OKAY) goto LBL_FU_ERR; + if (MP_IS_ZERO(&sz) && (mp_cmp(&tz, &T1z) == MP_EQ)) { *result = MP_YES; - goto LBL_FU_ERR; } LBL_FU_ERR: mp_clear_multi(&tz, &sz, &Np1z, &T2z, &T1z, NULL); - return e; + return err; } #endif #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ DELETED libtommath/bn_mp_prime_is_divisible.c Index: libtommath/bn_mp_prime_is_divisible.c ================================================================== --- libtommath/bn_mp_prime_is_divisible.c +++ /dev/null @@ -1,47 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_MP_PRIME_IS_DIVISIBLE_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* determines if an integers is divisible by one - * of the first PRIME_SIZE primes or not - * - * sets result to 0 if not, 1 if yes - */ -int mp_prime_is_divisible(const mp_int *a, int *result) -{ - int err, ix; - mp_digit res; - - /* default to not */ - *result = MP_NO; - - for (ix = 0; ix < PRIME_SIZE; ix++) { - /* what is a mod LBL_prime_tab[ix] */ - if ((err = mp_mod_d(a, ltm_prime_tab[ix], &res)) != MP_OKAY) { - return err; - } - - /* is the residue zero? */ - if (res == 0u) { - *result = MP_YES; - return MP_OKAY; - } - } - - return MP_OKAY; -} -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_prime_is_prime.c ================================================================== --- libtommath/bn_mp_prime_is_prime.c +++ libtommath/bn_mp_prime_is_prime.c @@ -1,18 +1,9 @@ #include "tommath_private.h" #ifdef BN_MP_PRIME_IS_PRIME_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* portable integer log of two with small footprint */ static unsigned int s_floor_ilog2(int value) { unsigned int r = 0; @@ -21,65 +12,62 @@ } return r; } -int mp_prime_is_prime(const mp_int *a, int t, int *result) +mp_err mp_prime_is_prime(const mp_int *a, int t, mp_bool *result) { mp_int b; - int ix, err, res, p_max = 0, size_a, len; + int ix, p_max = 0, size_a, len; + mp_bool res; + mp_err err; unsigned int fips_rand, mask; /* default to no */ *result = MP_NO; - /* valid value of t? */ - if (t > PRIME_SIZE) { - return MP_VAL; - } - /* Some shortcuts */ /* N > 3 */ if (a->used == 1) { if ((a->dp[0] == 0u) || (a->dp[0] == 1u)) { - *result = 0; + *result = MP_NO; return MP_OKAY; } if (a->dp[0] == 2u) { - *result = 1; + *result = MP_YES; return MP_OKAY; } } /* N must be odd */ - if (mp_iseven(a) == MP_YES) { + if (MP_IS_EVEN(a)) { return MP_OKAY; } /* N is not a perfect square: floor(sqrt(N))^2 != N */ if ((err = mp_is_square(a, &res)) != MP_OKAY) { return err; } - if (res != 0) { + if (res != MP_NO) { return MP_OKAY; } /* is the input equal to one of the primes in the table? */ - for (ix = 0; ix < PRIME_SIZE; ix++) { - if (mp_cmp_d(a, ltm_prime_tab[ix]) == MP_EQ) { + for (ix = 0; ix < PRIVATE_MP_PRIME_TAB_SIZE; ix++) { + if (mp_cmp_d(a, s_mp_prime_tab[ix]) == MP_EQ) { *result = MP_YES; return MP_OKAY; } } #ifdef MP_8BIT /* The search in the loop above was exhaustive in this case */ - if ((a->used == 1) && (PRIME_SIZE >= 31)) { + if ((a->used == 1) && (PRIVATE_MP_PRIME_TAB_SIZE >= 31)) { return MP_OKAY; } #endif /* first perform trial division */ - if ((err = mp_prime_is_divisible(a, &res)) != MP_OKAY) { + if ((err = s_mp_prime_is_divisible(a, &res)) != MP_OKAY) { return err; } /* return if it was trivially divisible */ if (res == MP_YES) { @@ -112,14 +100,14 @@ goto LBL_B; } /* * Both, the Frobenius-Underwood test and the the Lucas-Selfridge test are quite - * slow so if speed is an issue, define LTM_USE_FIPS_ONLY to use M-R tests with + * slow so if speed is an issue, define LTM_USE_ONLY_MR to use M-R tests with * bases 2, 3 and t random bases. */ -#ifndef LTM_USE_FIPS_ONLY +#ifndef LTM_USE_ONLY_MR if (t >= 0) { /* * Use a Frobenius-Underwood test instead of the Lucas-Selfridge test for * MP_8BIT (It is unknown if the Lucas-Selfridge test works with 16-bit * integers but the necesssary analysis is on the todo-list). @@ -147,48 +135,18 @@ if (t == 0) { t = 1; } /* - abs(t) extra rounds of M-R to extend the range of primes it can find if t < 0. Only recommended if the input range is known to be < 3317044064679887385961981 - It uses the bases for a deterministic M-R test if input < 3317044064679887385961981 + It uses the bases necessary for a deterministic M-R test if the input is + smaller than 3317044064679887385961981 The caller has to check the size. - - Not for cryptographic use because with known bases strong M-R pseudoprimes can - be constructed. Use at least one M-R test with a random base (t >= 1). - - The 1119 bit large number - - 80383745745363949125707961434194210813883768828755814583748891752229742737653\ - 33652186502336163960045457915042023603208766569966760987284043965408232928738\ - 79185086916685732826776177102938969773947016708230428687109997439976544144845\ - 34115587245063340927902227529622941498423068816854043264575340183297861112989\ - 60644845216191652872597534901 - - has been constructed by F. Arnault (F. Arnault, "Rabin-Miller primality test: - composite numbers which pass it.", Mathematics of Computation, 1995, 64. Jg., - Nr. 209, S. 355-361), is a semiprime with the two factors - - 40095821663949960541830645208454685300518816604113250877450620473800321707011\ - 96242716223191597219733582163165085358166969145233813917169287527980445796800\ - 452592031836601 - - 20047910831974980270915322604227342650259408302056625438725310236900160853505\ - 98121358111595798609866791081582542679083484572616906958584643763990222898400\ - 226296015918301 - - and it is a strong pseudoprime to all forty-six prime M-R bases up to 200 - - It does not fail the strong Bailley-PSP test as implemented here, it is just - given as an example, if not the reason to use the BPSW-test instead of M-R-tests - with a sequence of primes 2...n. - + TODO: can be made a bit finer grained but comparing is not free. */ if (t < 0) { - t = -t; /* Sorenson, Jonathan; Webster, Jonathan (2015). "Strong Pseudoprimes to Twelve Prime Bases". */ /* 0x437ae92817f9fc85b7e5 = 318665857834031151167461 */ @@ -210,22 +168,13 @@ err = MP_VAL; goto LBL_B; } } - /* for compatibility with the current API (well, compatible within a sign's width) */ - if (p_max < t) { - p_max = t; - } - - if (p_max > PRIME_SIZE) { - err = MP_VAL; - goto LBL_B; - } /* we did bases 2 and 3 already, skip them */ for (ix = 2; ix < p_max; ix++) { - mp_set(&b, ltm_prime_tab[ix]); + mp_set(&b, s_mp_prime_tab[ix]); if ((err = mp_prime_miller_rabin(a, &b, &res)) != MP_OKAY) { goto LBL_B; } if (res == MP_NO) { goto LBL_B; @@ -294,23 +243,23 @@ #ifdef MP_8BIT /* * One 8-bit digit is too small, so concatenate two if the size of * unsigned int allows for it. */ - if (((sizeof(unsigned int) * CHAR_BIT)/2) >= (sizeof(mp_digit) * CHAR_BIT)) { + if ((MP_SIZEOF_BITS(unsigned int)/2) >= MP_SIZEOF_BITS(mp_digit)) { if ((err = mp_rand(&b, 1)) != MP_OKAY) { goto LBL_B; } - fips_rand <<= sizeof(mp_digit) * CHAR_BIT; + fips_rand <<= MP_SIZEOF_BITS(mp_digit); fips_rand |= (unsigned int) b.dp[0]; fips_rand &= mask; } #endif - if (fips_rand > (unsigned int)(INT_MAX - DIGIT_BIT)) { - len = INT_MAX / DIGIT_BIT; + if (fips_rand > (unsigned int)(INT_MAX - MP_DIGIT_BIT)) { + len = INT_MAX / MP_DIGIT_BIT; } else { - len = (((int)fips_rand + DIGIT_BIT) / DIGIT_BIT); + len = (((int)fips_rand + MP_DIGIT_BIT) / MP_DIGIT_BIT); } /* Unlikely. */ if (len < 0) { ix--; continue; @@ -330,20 +279,19 @@ if ((err = mp_rand(&b, len)) != MP_OKAY) { goto LBL_B; } /* * That number might got too big and the witness has to be - * smaller than or equal to "a" + * smaller than "a" */ len = mp_count_bits(&b); - if (len > size_a) { - len = len - size_a; + if (len >= size_a) { + len = (len - size_a) + 1; if ((err = mp_div_2d(&b, len, &b, NULL)) != MP_OKAY) { goto LBL_B; } } - /* Although the chance for b <= 3 is miniscule, try again. */ if (mp_cmp_d(&b, 3uL) != MP_GT) { ix--; continue; } @@ -362,9 +310,5 @@ mp_clear(&b); return err; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_prime_miller_rabin.c ================================================================== --- libtommath/bn_mp_prime_miller_rabin.c +++ libtommath/bn_mp_prime_miller_rabin.c @@ -1,30 +1,22 @@ #include "tommath_private.h" #ifdef BN_MP_PRIME_MILLER_RABIN_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* Miller-Rabin test of "a" to the base of "b" as described in * HAC pp. 139 Algorithm 4.24 * * Sets result to 0 if definitely composite or 1 if probably prime. * Randomly the chance of error is no more than 1/4 and often * very much lower. */ -int mp_prime_miller_rabin(const mp_int *a, const mp_int *b, int *result) +mp_err mp_prime_miller_rabin(const mp_int *a, const mp_int *b, mp_bool *result) { mp_int n1, y, r; - int s, j, err; + mp_err err; + int s, j; /* default */ *result = MP_NO; /* ensure b > 1 */ @@ -95,9 +87,5 @@ LBL_N1: mp_clear(&n1); return err; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_prime_next_prime.c ================================================================== --- libtommath/bn_mp_prime_next_prime.c +++ libtommath/bn_mp_prime_next_prime.c @@ -1,64 +1,44 @@ #include "tommath_private.h" #ifdef BN_MP_PRIME_NEXT_PRIME_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* finds the next prime after the number "a" using "t" trials * of Miller-Rabin. * * bbs_style = 1 means the prime must be congruent to 3 mod 4 */ -int mp_prime_next_prime(mp_int *a, int t, int bbs_style) +mp_err mp_prime_next_prime(mp_int *a, int t, int bbs_style) { - int err, res = MP_NO, x, y; - mp_digit res_tab[PRIME_SIZE], step, kstep; + int x, y; + mp_ord cmp; + mp_err err; + mp_bool res = MP_NO; + mp_digit res_tab[PRIVATE_MP_PRIME_TAB_SIZE], step, kstep; mp_int b; /* force positive */ a->sign = MP_ZPOS; /* simple algo if a is less than the largest prime in the table */ - if (mp_cmp_d(a, ltm_prime_tab[PRIME_SIZE-1]) == MP_LT) { - /* find which prime it is bigger than */ - for (x = PRIME_SIZE - 2; x >= 0; x--) { - if (mp_cmp_d(a, ltm_prime_tab[x]) != MP_LT) { - if (bbs_style == 1) { - /* ok we found a prime smaller or - * equal [so the next is larger] - * - * however, the prime must be - * congruent to 3 mod 4 - */ - if ((ltm_prime_tab[x + 1] & 3u) != 3u) { - /* scan upwards for a prime congruent to 3 mod 4 */ - for (y = x + 1; y < PRIME_SIZE; y++) { - if ((ltm_prime_tab[y] & 3u) == 3u) { - mp_set(a, ltm_prime_tab[y]); - return MP_OKAY; - } - } - } - } else { - mp_set(a, ltm_prime_tab[x + 1]); - return MP_OKAY; - } - } - } - /* at this point a maybe 1 */ - if (mp_cmp_d(a, 1uL) == MP_EQ) { - mp_set(a, 2uL); - return MP_OKAY; + if (mp_cmp_d(a, s_mp_prime_tab[PRIVATE_MP_PRIME_TAB_SIZE-1]) == MP_LT) { + /* find which prime it is bigger than "a" */ + for (x = 0; x < PRIVATE_MP_PRIME_TAB_SIZE; x++) { + cmp = mp_cmp_d(a, s_mp_prime_tab[x]); + if (cmp == MP_EQ) { + continue; + } + if (cmp != MP_GT) { + if ((bbs_style == 1) && ((s_mp_prime_tab[x] & 3u) != 3u)) { + /* try again until we get a prime congruent to 3 mod 4 */ + continue; + } else { + mp_set(a, s_mp_prime_tab[x]); + return MP_OKAY; + } + } } /* fall through to the sieve */ } /* generate a prime congruent to 3 mod 4 or 1/3 mod 4? */ @@ -73,24 +53,24 @@ if (bbs_style == 1) { /* if a mod 4 != 3 subtract the correct value to make it so */ if ((a->dp[0] & 3u) != 3u) { if ((err = mp_sub_d(a, (a->dp[0] & 3u) + 1u, a)) != MP_OKAY) { return err; - }; + } } } else { - if (mp_iseven(a) == MP_YES) { + if (MP_IS_EVEN(a)) { /* force odd */ if ((err = mp_sub_d(a, 1uL, a)) != MP_OKAY) { return err; } } } /* generate the restable */ - for (x = 1; x < PRIME_SIZE; x++) { - if ((err = mp_mod_d(a, ltm_prime_tab[x], res_tab + x)) != MP_OKAY) { + for (x = 1; x < PRIVATE_MP_PRIME_TAB_SIZE; x++) { + if ((err = mp_mod_d(a, s_mp_prime_tab[x], res_tab + x)) != MP_OKAY) { return err; } } /* init temp used for Miller-Rabin Testing */ @@ -107,33 +87,33 @@ /* increase step to next candidate */ step += kstep; /* compute the new residue without using division */ - for (x = 1; x < PRIME_SIZE; x++) { + for (x = 1; x < PRIVATE_MP_PRIME_TAB_SIZE; x++) { /* add the step to each residue */ res_tab[x] += kstep; /* subtract the modulus [instead of using division] */ - if (res_tab[x] >= ltm_prime_tab[x]) { - res_tab[x] -= ltm_prime_tab[x]; + if (res_tab[x] >= s_mp_prime_tab[x]) { + res_tab[x] -= s_mp_prime_tab[x]; } /* set flag if zero */ if (res_tab[x] == 0u) { y = 1; } } - } while ((y == 1) && (step < (((mp_digit)1 << DIGIT_BIT) - kstep))); + } while ((y == 1) && (step < (((mp_digit)1 << MP_DIGIT_BIT) - kstep))); /* add the step */ if ((err = mp_add_d(a, step, a)) != MP_OKAY) { goto LBL_ERR; } - /* if didn't pass sieve and step == MAX then skip test */ - if ((y == 1) && (step >= (((mp_digit)1 << DIGIT_BIT) - kstep))) { + /* if didn't pass sieve and step == MP_MAX then skip test */ + if ((y == 1) && (step >= (((mp_digit)1 << MP_DIGIT_BIT) - kstep))) { continue; } if ((err = mp_prime_is_prime(a, t, &res)) != MP_OKAY) { goto LBL_ERR; @@ -148,9 +128,5 @@ mp_clear(&b); return err; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_prime_rabin_miller_trials.c ================================================================== --- libtommath/bn_mp_prime_rabin_miller_trials.c +++ libtommath/bn_mp_prime_rabin_miller_trials.c @@ -1,41 +1,36 @@ #include "tommath_private.h" #ifdef BN_MP_PRIME_RABIN_MILLER_TRIALS_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ static const struct { int k, t; } sizes[] = { - { 80, -1 }, /* Use deterministic algorithm for size <= 80 bits */ - { 81, 39 }, - { 96, 37 }, - { 128, 32 }, - { 160, 27 }, - { 192, 21 }, - { 256, 16 }, - { 384, 10 }, - { 512, 7 }, - { 640, 6 }, - { 768, 5 }, - { 896, 4 }, - { 1024, 4 }, - { 2048, 2 }, - { 4096, 1 }, + { 80, -1 }, /* Use deterministic algorithm for size <= 80 bits */ + { 81, 37 }, /* max. error = 2^(-96)*/ + { 96, 32 }, /* max. error = 2^(-96)*/ + { 128, 40 }, /* max. error = 2^(-112)*/ + { 160, 35 }, /* max. error = 2^(-112)*/ + { 256, 27 }, /* max. error = 2^(-128)*/ + { 384, 16 }, /* max. error = 2^(-128)*/ + { 512, 18 }, /* max. error = 2^(-160)*/ + { 768, 11 }, /* max. error = 2^(-160)*/ + { 896, 10 }, /* max. error = 2^(-160)*/ + { 1024, 12 }, /* max. error = 2^(-192)*/ + { 1536, 8 }, /* max. error = 2^(-192)*/ + { 2048, 6 }, /* max. error = 2^(-192)*/ + { 3072, 4 }, /* max. error = 2^(-192)*/ + { 4096, 5 }, /* max. error = 2^(-256)*/ + { 5120, 4 }, /* max. error = 2^(-256)*/ + { 6144, 4 }, /* max. error = 2^(-256)*/ + { 8192, 3 }, /* max. error = 2^(-256)*/ + { 9216, 3 }, /* max. error = 2^(-256)*/ + { 10240, 2 } /* For bigger keysizes use always at least 2 Rounds */ }; -/* returns # of RM trials required for a given bit size and max. error of 2^(-96)*/ +/* returns # of RM trials required for a given bit size */ int mp_prime_rabin_miller_trials(int size) { int x; for (x = 0; x < (int)(sizeof(sizes)/(sizeof(sizes[0]))); x++) { @@ -43,14 +38,10 @@ return sizes[x].t; } else if (sizes[x].k > size) { return (x == 0) ? sizes[0].t : sizes[x - 1].t; } } - return sizes[x-1].t + 1; + return sizes[x-1].t; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ ADDED libtommath/bn_mp_prime_rand.c Index: libtommath/bn_mp_prime_rand.c ================================================================== --- /dev/null +++ libtommath/bn_mp_prime_rand.c @@ -0,0 +1,141 @@ +#include "tommath_private.h" +#ifdef BN_MP_PRIME_RAND_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +/* makes a truly random prime of a given size (bits), + * + * Flags are as follows: + * + * MP_PRIME_BBS - make prime congruent to 3 mod 4 + * MP_PRIME_SAFE - make sure (p-1)/2 is prime as well (implies MP_PRIME_BBS) + * MP_PRIME_2MSB_ON - make the 2nd highest bit one + * + * You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can + * have passed to the callback (e.g. a state or something). This function doesn't use "dat" itself + * so it can be NULL + * + */ + +/* This is possibly the mother of all prime generation functions, muahahahahaha! */ +mp_err s_mp_prime_random_ex(mp_int *a, int t, int size, int flags, private_mp_prime_callback cb, void *dat) +{ + unsigned char *tmp, maskAND, maskOR_msb, maskOR_lsb; + int bsize, maskOR_msb_offset; + mp_bool res; + mp_err err; + + /* sanity check the input */ + if ((size <= 1) || (t <= 0)) { + return MP_VAL; + } + + /* MP_PRIME_SAFE implies MP_PRIME_BBS */ + if ((flags & MP_PRIME_SAFE) != 0) { + flags |= MP_PRIME_BBS; + } + + /* calc the byte size */ + bsize = (size>>3) + ((size&7)?1:0); + + /* we need a buffer of bsize bytes */ + tmp = (unsigned char *) MP_MALLOC((size_t)bsize); + if (tmp == NULL) { + return MP_MEM; + } + + /* calc the maskAND value for the MSbyte*/ + maskAND = ((size&7) == 0) ? 0xFFu : (unsigned char)(0xFFu >> (8 - (size & 7))); + + /* calc the maskOR_msb */ + maskOR_msb = 0; + maskOR_msb_offset = ((size & 7) == 1) ? 1 : 0; + if ((flags & MP_PRIME_2MSB_ON) != 0) { + maskOR_msb |= (unsigned char)(0x80 >> ((9 - size) & 7)); + } + + /* get the maskOR_lsb */ + maskOR_lsb = 1u; + if ((flags & MP_PRIME_BBS) != 0) { + maskOR_lsb |= 3u; + } + + do { + /* read the bytes */ + if (cb(tmp, bsize, dat) != bsize) { + err = MP_VAL; + goto error; + } + + /* work over the MSbyte */ + tmp[0] &= maskAND; + tmp[0] |= (unsigned char)(1 << ((size - 1) & 7)); + + /* mix in the maskORs */ + tmp[maskOR_msb_offset] |= maskOR_msb; + tmp[bsize-1] |= maskOR_lsb; + + /* read it in */ + /* TODO: casting only for now until all lengths have been changed to the type "size_t"*/ + if ((err = mp_from_ubin(a, tmp, (size_t)bsize)) != MP_OKAY) { + goto error; + } + + /* is it prime? */ + if ((err = mp_prime_is_prime(a, t, &res)) != MP_OKAY) { + goto error; + } + if (res == MP_NO) { + continue; + } + + if ((flags & MP_PRIME_SAFE) != 0) { + /* see if (a-1)/2 is prime */ + if ((err = mp_sub_d(a, 1uL, a)) != MP_OKAY) { + goto error; + } + if ((err = mp_div_2(a, a)) != MP_OKAY) { + goto error; + } + + /* is it prime? */ + if ((err = mp_prime_is_prime(a, t, &res)) != MP_OKAY) { + goto error; + } + } + } while (res == MP_NO); + + if ((flags & MP_PRIME_SAFE) != 0) { + /* restore a to the original value */ + if ((err = mp_mul_2(a, a)) != MP_OKAY) { + goto error; + } + if ((err = mp_add_d(a, 1uL, a)) != MP_OKAY) { + goto error; + } + } + + err = MP_OKAY; +error: + MP_FREE_BUFFER(tmp, (size_t)bsize); + return err; +} + +static int s_mp_rand_cb(unsigned char *dst, int len, void *dat) +{ + (void)dat; + if (len <= 0) { + return len; + } + if (s_mp_rand_source(dst, (size_t)len) != MP_OKAY) { + return 0; + } + return len; +} + +mp_err mp_prime_rand(mp_int *a, int t, int size, int flags) +{ + return s_mp_prime_random_ex(a, t, size, flags, s_mp_rand_cb, NULL); +} + +#endif DELETED libtommath/bn_mp_prime_random_ex.c Index: libtommath/bn_mp_prime_random_ex.c ================================================================== --- libtommath/bn_mp_prime_random_ex.c +++ /dev/null @@ -1,135 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_MP_PRIME_RANDOM_EX_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* makes a truly random prime of a given size (bits), - * - * Flags are as follows: - * - * LTM_PRIME_BBS - make prime congruent to 3 mod 4 - * LTM_PRIME_SAFE - make sure (p-1)/2 is prime as well (implies LTM_PRIME_BBS) - * LTM_PRIME_2MSB_ON - make the 2nd highest bit one - * - * You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can - * have passed to the callback (e.g. a state or something). This function doesn't use "dat" itself - * so it can be NULL - * - */ - -/* This is possibly the mother of all prime generation functions, muahahahahaha! */ -int mp_prime_random_ex(mp_int *a, int t, int size, int flags, ltm_prime_callback cb, void *dat) -{ - unsigned char *tmp, maskAND, maskOR_msb, maskOR_lsb; - int res, err, bsize, maskOR_msb_offset; - - /* sanity check the input */ - if ((size <= 1) || (t <= 0)) { - return MP_VAL; - } - - /* LTM_PRIME_SAFE implies LTM_PRIME_BBS */ - if ((flags & LTM_PRIME_SAFE) != 0) { - flags |= LTM_PRIME_BBS; - } - - /* calc the byte size */ - bsize = (size>>3) + ((size&7)?1:0); - - /* we need a buffer of bsize bytes */ - tmp = (unsigned char *) XMALLOC((size_t)bsize); - if (tmp == NULL) { - return MP_MEM; - } - - /* calc the maskAND value for the MSbyte*/ - maskAND = ((size&7) == 0) ? 0xFF : (unsigned char)(0xFF >> (8 - (size & 7))); - - /* calc the maskOR_msb */ - maskOR_msb = 0; - maskOR_msb_offset = ((size & 7) == 1) ? 1 : 0; - if ((flags & LTM_PRIME_2MSB_ON) != 0) { - maskOR_msb |= (unsigned char)(0x80 >> ((9 - size) & 7)); - } - - /* get the maskOR_lsb */ - maskOR_lsb = 1; - if ((flags & LTM_PRIME_BBS) != 0) { - maskOR_lsb |= 3; - } - - do { - /* read the bytes */ - if (cb(tmp, bsize, dat) != bsize) { - err = MP_VAL; - goto error; - } - - /* work over the MSbyte */ - tmp[0] &= maskAND; - tmp[0] |= (unsigned char)(1 << ((size - 1) & 7)); - - /* mix in the maskORs */ - tmp[maskOR_msb_offset] |= maskOR_msb; - tmp[bsize-1] |= maskOR_lsb; - - /* read it in */ - if ((err = mp_read_unsigned_bin(a, tmp, bsize)) != MP_OKAY) { - goto error; - } - - /* is it prime? */ - if ((err = mp_prime_is_prime(a, t, &res)) != MP_OKAY) { - goto error; - } - if (res == MP_NO) { - continue; - } - - if ((flags & LTM_PRIME_SAFE) != 0) { - /* see if (a-1)/2 is prime */ - if ((err = mp_sub_d(a, 1uL, a)) != MP_OKAY) { - goto error; - } - if ((err = mp_div_2(a, a)) != MP_OKAY) { - goto error; - } - - /* is it prime? */ - if ((err = mp_prime_is_prime(a, t, &res)) != MP_OKAY) { - goto error; - } - } - } while (res == MP_NO); - - if ((flags & LTM_PRIME_SAFE) != 0) { - /* restore a to the original value */ - if ((err = mp_mul_2(a, a)) != MP_OKAY) { - goto error; - } - if ((err = mp_add_d(a, 1uL, a)) != MP_OKAY) { - goto error; - } - } - - err = MP_OKAY; -error: - XFREE(tmp, bsize); - return err; -} - - -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_prime_strong_lucas_selfridge.c ================================================================== --- libtommath/bn_mp_prime_strong_lucas_selfridge.c +++ libtommath/bn_mp_prime_strong_lucas_selfridge.c @@ -1,24 +1,15 @@ #include "tommath_private.h" #ifdef BN_MP_PRIME_STRONG_LUCAS_SELFRIDGE_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* * See file bn_mp_prime_is_prime.c or the documentation in doc/bn.tex for the details */ -#ifndef LTM_USE_FIPS_ONLY +#ifndef LTM_USE_ONLY_MR /* * 8-bit is just too small. You can try the Frobenius test * but that frobenius test can fail, too, for the same reason. */ @@ -26,37 +17,25 @@ /* * multiply bigint a with int d and put the result in c * Like mp_mul_d() but with a signed long as the small input */ -static int s_mp_mul_si(const mp_int *a, long d, mp_int *c) +static mp_err s_mp_mul_si(const mp_int *a, int32_t d, mp_int *c) { mp_int t; - int err, neg = 0; + mp_err err; if ((err = mp_init(&t)) != MP_OKAY) { return err; } - if (d < 0) { - neg = 1; - d = -d; - } /* * mp_digit might be smaller than a long, which excludes * the use of mp_mul_d() here. */ - if ((err = mp_set_long(&t, (unsigned long) d)) != MP_OKAY) { - goto LBL_MPMULSI_ERR; - } - if ((err = mp_mul(a, &t, c)) != MP_OKAY) { - goto LBL_MPMULSI_ERR; - } - if (neg == 1) { - c->sign = (a->sign == MP_NEG) ? MP_ZPOS: MP_NEG; - } -LBL_MPMULSI_ERR: + mp_set_i32(&t, d); + err = mp_mul(a, &t, c); mp_clear(&t); return err; } /* Strong Lucas-Selfridge test. @@ -73,18 +52,18 @@ Additional comments marked "CZ" (without the quotes) are by the code-portist. (If that name sounds familiar, he is the guy who found the fdiv bug in the Pentium (P5x, I think) Intel processor) */ -int mp_prime_strong_lucas_selfridge(const mp_int *a, int *result) +mp_err mp_prime_strong_lucas_selfridge(const mp_int *a, mp_bool *result) { /* CZ TODO: choose better variable names! */ mp_int Dz, gcd, Np1, Uz, Vz, U2mz, V2mz, Qmz, Q2mz, Qkdz, T1z, T2z, T3z, T4z, Q2kdz; /* CZ TODO: Some of them need the full 32 bit, hence the (temporary) exclusion of MP_8BIT */ int32_t D, Ds, J, sign, P, Q, r, s, u, Nbits; - int e; - int isset, oddness; + mp_err err; + mp_bool oddness; *result = MP_NO; /* Find the first element D in the sequence {5, -7, 9, -11, 13, ...} such that Jacobi(D,N) = -1 (Selfridge's algorithm). Theory @@ -91,47 +70,42 @@ indicates that, if N is not a perfect square, D will "nearly always" be "small." Just in case, an overflow trap for D is included. */ - if ((e = mp_init_multi(&Dz, &gcd, &Np1, &Uz, &Vz, &U2mz, &V2mz, &Qmz, &Q2mz, &Qkdz, &T1z, &T2z, &T3z, &T4z, &Q2kdz, - NULL)) != MP_OKAY) { - return e; + if ((err = mp_init_multi(&Dz, &gcd, &Np1, &Uz, &Vz, &U2mz, &V2mz, &Qmz, &Q2mz, &Qkdz, &T1z, &T2z, &T3z, &T4z, &Q2kdz, + NULL)) != MP_OKAY) { + return err; } D = 5; sign = 1; for (;;) { Ds = sign * D; sign = -sign; - if ((e = mp_set_long(&Dz, (unsigned long)D)) != MP_OKAY) { - goto LBL_LS_ERR; - } - if ((e = mp_gcd(a, &Dz, &gcd)) != MP_OKAY) { - goto LBL_LS_ERR; - } + mp_set_u32(&Dz, (uint32_t)D); + if ((err = mp_gcd(a, &Dz, &gcd)) != MP_OKAY) goto LBL_LS_ERR; + /* if 1 < GCD < N then N is composite with factor "D", and Jacobi(D,N) is technically undefined (but often returned as zero). */ if ((mp_cmp_d(&gcd, 1uL) == MP_GT) && (mp_cmp(&gcd, a) == MP_LT)) { goto LBL_LS_ERR; } if (Ds < 0) { Dz.sign = MP_NEG; } - if ((e = mp_kronecker(&Dz, a, &J)) != MP_OKAY) { - goto LBL_LS_ERR; - } + if ((err = mp_kronecker(&Dz, a, &J)) != MP_OKAY) goto LBL_LS_ERR; if (J == -1) { break; } D += 2; if (D > (INT_MAX - 2)) { - e = MP_VAL; + err = MP_VAL; goto LBL_LS_ERR; } } @@ -167,25 +141,21 @@ the evidence indicates that the strong Lucas-Selfridge test is more effective than the standard Lucas-Selfridge test, and a Baillie-PSW test based on the strong Lucas-Selfridge test should be more reliable. */ - if ((e = mp_add_d(a, 1uL, &Np1)) != MP_OKAY) { - goto LBL_LS_ERR; - } + if ((err = mp_add_d(a, 1uL, &Np1)) != MP_OKAY) goto LBL_LS_ERR; s = mp_cnt_lsb(&Np1); /* CZ * This should round towards zero because * Thomas R. Nicely used GMP's mpz_tdiv_q_2exp() * and mp_div_2d() is equivalent. Additionally: * dividing an even number by two does not produce * any leftovers. */ - if ((e = mp_div_2d(&Np1, s, &Dz, NULL)) != MP_OKAY) { - goto LBL_LS_ERR; - } + if ((err = mp_div_2d(&Np1, s, &Dz, NULL)) != MP_OKAY) goto LBL_LS_ERR; /* We must now compute U_d and V_d. Since d is odd, the accumulated values U and V are initialized to U_1 and V_1 (if the target index were even, U and V would be initialized instead to U_0=0 and V_0=2). The values of U_2m and V_2m are also initialized to U_1 and V_1; the FOR loop calculates in succession U_2 and V_2, @@ -198,38 +168,14 @@ mp_set(&Uz, 1uL); /* U=U_1 */ mp_set(&Vz, (mp_digit)P); /* V=V_1 */ mp_set(&U2mz, 1uL); /* U_1 */ mp_set(&V2mz, (mp_digit)P); /* V_1 */ - if (Q < 0) { - Q = -Q; - if ((e = mp_set_long(&Qmz, (unsigned long)Q)) != MP_OKAY) { - goto LBL_LS_ERR; - } - if ((e = mp_mul_2(&Qmz, &Q2mz)) != MP_OKAY) { - goto LBL_LS_ERR; - } - /* Initializes calculation of Q^d */ - if ((e = mp_set_long(&Qkdz, (unsigned long)Q)) != MP_OKAY) { - goto LBL_LS_ERR; - } - Qmz.sign = MP_NEG; - Q2mz.sign = MP_NEG; - Qkdz.sign = MP_NEG; - Q = -Q; - } else { - if ((e = mp_set_long(&Qmz, (unsigned long)Q)) != MP_OKAY) { - goto LBL_LS_ERR; - } - if ((e = mp_mul_2(&Qmz, &Q2mz)) != MP_OKAY) { - goto LBL_LS_ERR; - } - /* Initializes calculation of Q^d */ - if ((e = mp_set_long(&Qkdz, (unsigned long)Q)) != MP_OKAY) { - goto LBL_LS_ERR; - } - } + mp_set_i32(&Qmz, Q); + if ((err = mp_mul_2(&Qmz, &Q2mz)) != MP_OKAY) goto LBL_LS_ERR; + /* Initializes calculation of Q^d */ + mp_set_i32(&Qkdz, Q); Nbits = mp_count_bits(&Dz); for (u = 1; u < Nbits; u++) { /* zero bit off, already accounted for */ /* Formulas for doubling of indices (carried out mod N). Note that @@ -238,121 +184,71 @@ * * U_2m = U_m*V_m * V_2m = V_m*V_m - 2*Q^m */ - if ((e = mp_mul(&U2mz, &V2mz, &U2mz)) != MP_OKAY) { - goto LBL_LS_ERR; - } - if ((e = mp_mod(&U2mz, a, &U2mz)) != MP_OKAY) { - goto LBL_LS_ERR; - } - if ((e = mp_sqr(&V2mz, &V2mz)) != MP_OKAY) { - goto LBL_LS_ERR; - } - if ((e = mp_sub(&V2mz, &Q2mz, &V2mz)) != MP_OKAY) { - goto LBL_LS_ERR; - } - if ((e = mp_mod(&V2mz, a, &V2mz)) != MP_OKAY) { - goto LBL_LS_ERR; - } + if ((err = mp_mul(&U2mz, &V2mz, &U2mz)) != MP_OKAY) goto LBL_LS_ERR; + if ((err = mp_mod(&U2mz, a, &U2mz)) != MP_OKAY) goto LBL_LS_ERR; + if ((err = mp_sqr(&V2mz, &V2mz)) != MP_OKAY) goto LBL_LS_ERR; + if ((err = mp_sub(&V2mz, &Q2mz, &V2mz)) != MP_OKAY) goto LBL_LS_ERR; + if ((err = mp_mod(&V2mz, a, &V2mz)) != MP_OKAY) goto LBL_LS_ERR; + /* Must calculate powers of Q for use in V_2m, also for Q^d later */ - if ((e = mp_sqr(&Qmz, &Qmz)) != MP_OKAY) { - goto LBL_LS_ERR; - } + if ((err = mp_sqr(&Qmz, &Qmz)) != MP_OKAY) goto LBL_LS_ERR; + /* prevents overflow */ /* CZ still necessary without a fixed prealloc'd mem.? */ - if ((e = mp_mod(&Qmz, a, &Qmz)) != MP_OKAY) { - goto LBL_LS_ERR; - } - if ((e = mp_mul_2(&Qmz, &Q2mz)) != MP_OKAY) { - goto LBL_LS_ERR; - } - if ((isset = mp_get_bit(&Dz, u)) == MP_VAL) { - e = isset; - goto LBL_LS_ERR; - } - if (isset == MP_YES) { + if ((err = mp_mod(&Qmz, a, &Qmz)) != MP_OKAY) goto LBL_LS_ERR; + if ((err = mp_mul_2(&Qmz, &Q2mz)) != MP_OKAY) goto LBL_LS_ERR; + + if (s_mp_get_bit(&Dz, (unsigned int)u) == MP_YES) { /* Formulas for addition of indices (carried out mod N); * * U_(m+n) = (U_m*V_n + U_n*V_m)/2 * V_(m+n) = (V_m*V_n + D*U_m*U_n)/2 * * Be careful with division by 2 (mod N)! */ - if ((e = mp_mul(&U2mz, &Vz, &T1z)) != MP_OKAY) { - goto LBL_LS_ERR; - } - if ((e = mp_mul(&Uz, &V2mz, &T2z)) != MP_OKAY) { - goto LBL_LS_ERR; - } - if ((e = mp_mul(&V2mz, &Vz, &T3z)) != MP_OKAY) { - goto LBL_LS_ERR; - } - if ((e = mp_mul(&U2mz, &Uz, &T4z)) != MP_OKAY) { - goto LBL_LS_ERR; - } - if ((e = s_mp_mul_si(&T4z, (long)Ds, &T4z)) != MP_OKAY) { - goto LBL_LS_ERR; - } - if ((e = mp_add(&T1z, &T2z, &Uz)) != MP_OKAY) { - goto LBL_LS_ERR; - } - if (mp_isodd(&Uz) != MP_NO) { - if ((e = mp_add(&Uz, a, &Uz)) != MP_OKAY) { - goto LBL_LS_ERR; - } + if ((err = mp_mul(&U2mz, &Vz, &T1z)) != MP_OKAY) goto LBL_LS_ERR; + if ((err = mp_mul(&Uz, &V2mz, &T2z)) != MP_OKAY) goto LBL_LS_ERR; + if ((err = mp_mul(&V2mz, &Vz, &T3z)) != MP_OKAY) goto LBL_LS_ERR; + if ((err = mp_mul(&U2mz, &Uz, &T4z)) != MP_OKAY) goto LBL_LS_ERR; + if ((err = s_mp_mul_si(&T4z, Ds, &T4z)) != MP_OKAY) goto LBL_LS_ERR; + if ((err = mp_add(&T1z, &T2z, &Uz)) != MP_OKAY) goto LBL_LS_ERR; + if (MP_IS_ODD(&Uz)) { + if ((err = mp_add(&Uz, a, &Uz)) != MP_OKAY) goto LBL_LS_ERR; } /* CZ * This should round towards negative infinity because * Thomas R. Nicely used GMP's mpz_fdiv_q_2exp(). * But mp_div_2() does not do so, it is truncating instead. */ - oddness = mp_isodd(&Uz); - if ((e = mp_div_2(&Uz, &Uz)) != MP_OKAY) { - goto LBL_LS_ERR; - } - if ((Uz.sign == MP_NEG) && (oddness != MP_NO)) { - if ((e = mp_sub_d(&Uz, 1uL, &Uz)) != MP_OKAY) { - goto LBL_LS_ERR; - } - } - if ((e = mp_add(&T3z, &T4z, &Vz)) != MP_OKAY) { - goto LBL_LS_ERR; - } - if (mp_isodd(&Vz) != MP_NO) { - if ((e = mp_add(&Vz, a, &Vz)) != MP_OKAY) { - goto LBL_LS_ERR; - } - } - oddness = mp_isodd(&Vz); - if ((e = mp_div_2(&Vz, &Vz)) != MP_OKAY) { - goto LBL_LS_ERR; - } - if ((Vz.sign == MP_NEG) && (oddness != MP_NO)) { - if ((e = mp_sub_d(&Vz, 1uL, &Vz)) != MP_OKAY) { - goto LBL_LS_ERR; - } - } - if ((e = mp_mod(&Uz, a, &Uz)) != MP_OKAY) { - goto LBL_LS_ERR; - } - if ((e = mp_mod(&Vz, a, &Vz)) != MP_OKAY) { - goto LBL_LS_ERR; - } - /* Calculating Q^d for later use */ - if ((e = mp_mul(&Qkdz, &Qmz, &Qkdz)) != MP_OKAY) { - goto LBL_LS_ERR; - } - if ((e = mp_mod(&Qkdz, a, &Qkdz)) != MP_OKAY) { - goto LBL_LS_ERR; - } + oddness = MP_IS_ODD(&Uz) ? MP_YES : MP_NO; + if ((err = mp_div_2(&Uz, &Uz)) != MP_OKAY) goto LBL_LS_ERR; + if ((Uz.sign == MP_NEG) && (oddness != MP_NO)) { + if ((err = mp_sub_d(&Uz, 1uL, &Uz)) != MP_OKAY) goto LBL_LS_ERR; + } + if ((err = mp_add(&T3z, &T4z, &Vz)) != MP_OKAY) goto LBL_LS_ERR; + if (MP_IS_ODD(&Vz)) { + if ((err = mp_add(&Vz, a, &Vz)) != MP_OKAY) goto LBL_LS_ERR; + } + oddness = MP_IS_ODD(&Vz) ? MP_YES : MP_NO; + if ((err = mp_div_2(&Vz, &Vz)) != MP_OKAY) goto LBL_LS_ERR; + if ((Vz.sign == MP_NEG) && (oddness != MP_NO)) { + if ((err = mp_sub_d(&Vz, 1uL, &Vz)) != MP_OKAY) goto LBL_LS_ERR; + } + if ((err = mp_mod(&Uz, a, &Uz)) != MP_OKAY) goto LBL_LS_ERR; + if ((err = mp_mod(&Vz, a, &Vz)) != MP_OKAY) goto LBL_LS_ERR; + + /* Calculating Q^d for later use */ + if ((err = mp_mul(&Qkdz, &Qmz, &Qkdz)) != MP_OKAY) goto LBL_LS_ERR; + if ((err = mp_mod(&Qkdz, a, &Qkdz)) != MP_OKAY) goto LBL_LS_ERR; } } /* If U_d or V_d is congruent to 0 mod N, then N is a prime or a strong Lucas pseudoprime. */ - if ((mp_iszero(&Uz) != MP_NO) || (mp_iszero(&Vz) != MP_NO)) { + if (MP_IS_ZERO(&Uz) || MP_IS_ZERO(&Vz)) { *result = MP_YES; goto LBL_LS_ERR; } /* NOTE: Ribenboim ("The new book of prime number records," 3rd ed., @@ -365,47 +261,29 @@ by repeated use of the formula V_2m = V_m*V_m - 2*Q^m. If any of these are congruent to 0 mod N, then N is a prime or a strong Lucas pseudoprime. */ /* Initialize 2*Q^(d*2^r) for V_2m */ - if ((e = mp_mul_2(&Qkdz, &Q2kdz)) != MP_OKAY) { - goto LBL_LS_ERR; - } + if ((err = mp_mul_2(&Qkdz, &Q2kdz)) != MP_OKAY) goto LBL_LS_ERR; for (r = 1; r < s; r++) { - if ((e = mp_sqr(&Vz, &Vz)) != MP_OKAY) { - goto LBL_LS_ERR; - } - if ((e = mp_sub(&Vz, &Q2kdz, &Vz)) != MP_OKAY) { - goto LBL_LS_ERR; - } - if ((e = mp_mod(&Vz, a, &Vz)) != MP_OKAY) { - goto LBL_LS_ERR; - } - if (mp_iszero(&Vz) != MP_NO) { + if ((err = mp_sqr(&Vz, &Vz)) != MP_OKAY) goto LBL_LS_ERR; + if ((err = mp_sub(&Vz, &Q2kdz, &Vz)) != MP_OKAY) goto LBL_LS_ERR; + if ((err = mp_mod(&Vz, a, &Vz)) != MP_OKAY) goto LBL_LS_ERR; + if (MP_IS_ZERO(&Vz)) { *result = MP_YES; goto LBL_LS_ERR; } /* Calculate Q^{d*2^r} for next r (final iteration irrelevant). */ if (r < (s - 1)) { - if ((e = mp_sqr(&Qkdz, &Qkdz)) != MP_OKAY) { - goto LBL_LS_ERR; - } - if ((e = mp_mod(&Qkdz, a, &Qkdz)) != MP_OKAY) { - goto LBL_LS_ERR; - } - if ((e = mp_mul_2(&Qkdz, &Q2kdz)) != MP_OKAY) { - goto LBL_LS_ERR; - } + if ((err = mp_sqr(&Qkdz, &Qkdz)) != MP_OKAY) goto LBL_LS_ERR; + if ((err = mp_mod(&Qkdz, a, &Qkdz)) != MP_OKAY) goto LBL_LS_ERR; + if ((err = mp_mul_2(&Qkdz, &Q2kdz)) != MP_OKAY) goto LBL_LS_ERR; } } LBL_LS_ERR: mp_clear_multi(&Q2kdz, &T4z, &T3z, &T2z, &T1z, &Qkdz, &Q2mz, &Qmz, &V2mz, &U2mz, &Vz, &Uz, &Np1, &gcd, &Dz, NULL); - return e; + return err; } #endif #endif #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_radix_size.c ================================================================== --- libtommath/bn_mp_radix_size.c +++ libtommath/bn_mp_radix_size.c @@ -1,41 +1,33 @@ #include "tommath_private.h" #ifdef BN_MP_RADIX_SIZE_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* returns size of ASCII reprensentation */ -int mp_radix_size(const mp_int *a, int radix, int *size) -{ - int res, digs; - mp_int t; +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +/* returns size of ASCII representation */ +mp_err mp_radix_size(const mp_int *a, int radix, int *size) +{ + mp_err err; + int digs; + mp_int t; mp_digit d; *size = 0; /* make sure the radix is in range */ if ((radix < 2) || (radix > 64)) { return MP_VAL; } - if (mp_iszero(a) == MP_YES) { + if (MP_IS_ZERO(a)) { *size = 2; return MP_OKAY; } /* special case for binary */ if (radix == 2) { - *size = mp_count_bits(a) + ((a->sign == MP_NEG) ? 1 : 0) + 1; + *size = (mp_count_bits(a) + ((a->sign == MP_NEG) ? 1 : 0) + 1); return MP_OKAY; } /* digs is the digit count */ digs = 0; @@ -44,32 +36,30 @@ if (a->sign == MP_NEG) { ++digs; } /* init a copy of the input */ - if ((res = mp_init_copy(&t, a)) != MP_OKAY) { - return res; + if ((err = mp_init_copy(&t, a)) != MP_OKAY) { + return err; } /* force temp to positive */ t.sign = MP_ZPOS; /* fetch out all of the digits */ - while (mp_iszero(&t) == MP_NO) { - if ((res = mp_div_d(&t, (mp_digit)radix, &t, &d)) != MP_OKAY) { - mp_clear(&t); - return res; + while (!MP_IS_ZERO(&t)) { + if ((err = mp_div_d(&t, (mp_digit)radix, &t, &d)) != MP_OKAY) { + goto LBL_ERR; } ++digs; } - mp_clear(&t); /* return digs + 1, the 1 is for the NULL byte that would be required. */ *size = digs + 1; - return MP_OKAY; + err = MP_OKAY; + +LBL_ERR: + mp_clear(&t); + return err; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_radix_smap.c ================================================================== --- libtommath/bn_mp_radix_smap.c +++ libtommath/bn_mp_radix_smap.c @@ -1,18 +1,9 @@ #include "tommath_private.h" #ifdef BN_MP_RADIX_SMAP_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* chars used in radix conversions */ const char *const mp_s_rmap = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+/"; const unsigned char mp_s_rmap_reverse[] = { 0xff, 0xff, 0xff, 0x3e, 0xff, 0xff, 0xff, 0x3f, /* ()*+,-./ */ @@ -27,9 +18,5 @@ 0x33, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39, 0x3a, /* pqrstuvw */ 0x3b, 0x3c, 0x3d, 0xff, 0xff, 0xff, 0xff, 0xff, /* xyz{|}~. */ }; const size_t mp_s_rmap_reverse_sz = sizeof(mp_s_rmap_reverse); #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_rand.c ================================================================== --- libtommath/bn_mp_rand.c +++ libtommath/bn_mp_rand.c @@ -1,222 +1,46 @@ #include "tommath_private.h" #ifdef BN_MP_RAND_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* First the OS-specific special cases - * - *BSD - * - Windows - */ -#if defined(__FreeBSD__) || defined(__OpenBSD__) || defined(__NetBSD__) || defined(__DragonFly__) -#define MP_ARC4RANDOM -#define MP_GEN_RANDOM_MAX 0xffffffffu -#define MP_GEN_RANDOM_SHIFT 32 - -static int s_read_arc4random(mp_digit *p) -{ - mp_digit d = 0, msk = 0; - do { - d <<= MP_GEN_RANDOM_SHIFT; - d |= ((mp_digit) arc4random()); - msk <<= MP_GEN_RANDOM_SHIFT; - msk |= (MP_MASK & MP_GEN_RANDOM_MAX); - } while ((MP_MASK & msk) != MP_MASK); - *p = d; - return MP_OKAY; -} -#endif - -#if defined(_WIN32) || defined(_WIN32_WCE) -#define MP_WIN_CSP - -#ifndef _WIN32_WINNT -#define _WIN32_WINNT 0x0400 -#endif -#ifdef _WIN32_WCE -#define UNDER_CE -#define ARM -#endif - -#define WIN32_LEAN_AND_MEAN -#include -#include - -static HCRYPTPROV hProv = 0; - -static void s_cleanup_win_csp(void) -{ - CryptReleaseContext(hProv, 0); - hProv = 0; -} - -static int s_read_win_csp(mp_digit *p) -{ - int ret = -1; - if (hProv == 0) { - if (!CryptAcquireContext(&hProv, NULL, MS_DEF_PROV, PROV_RSA_FULL, - (CRYPT_VERIFYCONTEXT | CRYPT_MACHINE_KEYSET)) && - !CryptAcquireContext(&hProv, NULL, MS_DEF_PROV, PROV_RSA_FULL, - CRYPT_VERIFYCONTEXT | CRYPT_MACHINE_KEYSET | CRYPT_NEWKEYSET)) { - hProv = 0; - return ret; - } - atexit(s_cleanup_win_csp); - } - if (CryptGenRandom(hProv, sizeof(*p), (void *)p) == TRUE) { - ret = MP_OKAY; - } - return ret; -} -#endif /* WIN32 */ - -#if !defined(MP_WIN_CSP) && defined(__linux__) && defined(__GLIBC_PREREQ) -#if __GLIBC_PREREQ(2, 25) -#define MP_GETRANDOM -#include -#include - -static int s_read_getrandom(mp_digit *p) -{ - int ret; - do { - ret = getrandom(p, sizeof(*p), 0); - } while ((ret == -1) && (errno == EINTR)); - if (ret == sizeof(*p)) return MP_OKAY; - return -1; -} -#endif -#endif - -/* We assume all platforms besides windows provide "/dev/urandom". - * In case yours doesn't, define MP_NO_DEV_URANDOM at compile-time. - */ -#if !defined(MP_WIN_CSP) && !defined(MP_NO_DEV_URANDOM) -#ifndef MP_DEV_URANDOM -#define MP_DEV_URANDOM "/dev/urandom" -#endif -#include -#include -#include - -static int s_read_dev_urandom(mp_digit *p) -{ - ssize_t r; - int fd; - do { - fd = open(MP_DEV_URANDOM, O_RDONLY); - } while ((fd == -1) && (errno == EINTR)); - if (fd == -1) return -1; - do { - r = read(fd, p, sizeof(*p)); - } while ((r == -1) && (errno == EINTR)); - close(fd); - if (r != sizeof(*p)) return -1; - return MP_OKAY; -} -#endif - -#if defined(MP_PRNG_ENABLE_LTM_RNG) -unsigned long (*ltm_rng)(unsigned char *out, unsigned long outlen, void (*callback)(void)); -void (*ltm_rng_callback)(void); - -static int s_read_ltm_rng(mp_digit *p) -{ - unsigned long ret; - if (ltm_rng == NULL) return -1; - ret = ltm_rng((void *)p, sizeof(*p), ltm_rng_callback); - if (ret != sizeof(*p)) return -1; - return MP_OKAY; -} -#endif - -static int s_rand_digit(mp_digit *p) -{ - int ret = -1; - -#if defined(MP_ARC4RANDOM) - ret = s_read_arc4random(p); - if (ret == MP_OKAY) return ret; -#endif - -#if defined(MP_WIN_CSP) - ret = s_read_win_csp(p); - if (ret == MP_OKAY) return ret; -#else - -#if defined(MP_GETRANDOM) - ret = s_read_getrandom(p); - if (ret == MP_OKAY) return ret; -#endif -#if defined(MP_DEV_URANDOM) - ret = s_read_dev_urandom(p); - if (ret == MP_OKAY) return ret; -#endif - -#endif /* MP_WIN_CSP */ - -#if defined(MP_PRNG_ENABLE_LTM_RNG) - ret = s_read_ltm_rng(p); - if (ret == MP_OKAY) return ret; -#endif - - return ret; -} - -/* makes a pseudo-random int of a given size */ -int mp_rand_digit(mp_digit *r) -{ - int ret = s_rand_digit(r); - *r &= MP_MASK; - return ret; -} - -int mp_rand(mp_int *a, int digits) -{ - int res; - mp_digit d; - - mp_zero(a); - if (digits <= 0) { - return MP_OKAY; - } - - /* first place a random non-zero digit */ - do { - if (mp_rand_digit(&d) != MP_OKAY) { - return MP_VAL; - } - } while (d == 0u); - - if ((res = mp_add_d(a, d, a)) != MP_OKAY) { - return res; - } - - while (--digits > 0) { - if ((res = mp_lshd(a, 1)) != MP_OKAY) { - return res; - } - - if (mp_rand_digit(&d) != MP_OKAY) { - return MP_VAL; - } - if ((res = mp_add_d(a, d, a)) != MP_OKAY) { - return res; - } - } - - return MP_OKAY; -} -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +mp_err(*s_mp_rand_source)(void *out, size_t size) = s_mp_rand_platform; + +void mp_rand_source(mp_err(*source)(void *out, size_t size)) +{ + s_mp_rand_source = (source == NULL) ? s_mp_rand_platform : source; +} + +mp_err mp_rand(mp_int *a, int digits) +{ + int i; + mp_err err; + + mp_zero(a); + + if (digits <= 0) { + return MP_OKAY; + } + + if ((err = mp_grow(a, digits)) != MP_OKAY) { + return err; + } + + if ((err = s_mp_rand_source(a->dp, (size_t)digits * sizeof(mp_digit))) != MP_OKAY) { + return err; + } + + /* TODO: We ensure that the highest digit is nonzero. Should this be removed? */ + while ((a->dp[digits - 1] & MP_MASK) == 0u) { + if ((err = s_mp_rand_source(a->dp + digits - 1, sizeof(mp_digit))) != MP_OKAY) { + return err; + } + } + + a->used = digits; + for (i = 0; i < digits; ++i) { + a->dp[i] &= MP_MASK; + } + + return MP_OKAY; +} +#endif Index: libtommath/bn_mp_read_radix.c ================================================================== --- libtommath/bn_mp_read_radix.c +++ libtommath/bn_mp_read_radix.c @@ -1,27 +1,20 @@ #include "tommath_private.h" #ifdef BN_MP_READ_RADIX_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ #define MP_TOUPPER(c) ((((c) >= 'a') && ((c) <= 'z')) ? (((c) + 'A') - 'a') : (c)) /* read a string [ASCII] in a given radix */ -int mp_read_radix(mp_int *a, const char *str, int radix) +mp_err mp_read_radix(mp_int *a, const char *str, int radix) { - int y, res, neg; + mp_err err; + int y; + mp_sign neg; unsigned pos; - char ch; + char ch; /* zero the digit bignum */ mp_zero(a); /* make sure the radix is ok */ @@ -60,15 +53,15 @@ * to the number, otherwise exit the loop. */ if ((y == 0xff) || (y >= radix)) { break; } - if ((res = mp_mul_d(a, (mp_digit)radix, a)) != MP_OKAY) { - return res; + if ((err = mp_mul_d(a, (mp_digit)radix, a)) != MP_OKAY) { + return err; } - if ((res = mp_add_d(a, (mp_digit)y, a)) != MP_OKAY) { - return res; + if ((err = mp_add_d(a, (mp_digit)y, a)) != MP_OKAY) { + return err; } ++str; } /* if an illegal character was found, fail. */ @@ -76,15 +69,11 @@ mp_zero(a); return MP_VAL; } /* set the sign only if a != 0 */ - if (mp_iszero(a) != MP_YES) { + if (!MP_IS_ZERO(a)) { a->sign = neg; } return MP_OKAY; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ DELETED libtommath/bn_mp_read_signed_bin.c Index: libtommath/bn_mp_read_signed_bin.c ================================================================== --- libtommath/bn_mp_read_signed_bin.c +++ /dev/null @@ -1,38 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_MP_READ_SIGNED_BIN_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* read signed bin, big endian, first byte is 0==positive or 1==negative */ -int mp_read_signed_bin(mp_int *a, const unsigned char *b, int c) -{ - int res; - - /* read magnitude */ - if ((res = mp_read_unsigned_bin(a, b + 1, c - 1)) != MP_OKAY) { - return res; - } - - /* first byte is 0 for positive, non-zero for negative */ - if (b[0] == (unsigned char)0) { - a->sign = MP_ZPOS; - } else { - a->sign = MP_NEG; - } - - return MP_OKAY; -} -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ DELETED libtommath/bn_mp_read_unsigned_bin.c Index: libtommath/bn_mp_read_unsigned_bin.c ================================================================== --- libtommath/bn_mp_read_unsigned_bin.c +++ /dev/null @@ -1,52 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_MP_READ_UNSIGNED_BIN_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* reads a unsigned char array, assumes the msb is stored first [big endian] */ -int mp_read_unsigned_bin(mp_int *a, const unsigned char *b, int c) -{ - int res; - - /* make sure there are at least two digits */ - if (a->alloc < 2) { - if ((res = mp_grow(a, 2)) != MP_OKAY) { - return res; - } - } - - /* zero the int */ - mp_zero(a); - - /* read the bytes in */ - while (c-- > 0) { - if ((res = mp_mul_2d(a, 8, a)) != MP_OKAY) { - return res; - } - -#ifndef MP_8BIT - a->dp[0] |= *b++; - a->used += 1; -#else - a->dp[0] = (*b & MP_MASK); - a->dp[1] |= ((*b++ >> 7) & 1u); - a->used += 2; -#endif - } - mp_clamp(a); - return MP_OKAY; -} -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_reduce.c ================================================================== --- libtommath/bn_mp_reduce.c +++ libtommath/bn_mp_reduce.c @@ -1,97 +1,83 @@ #include "tommath_private.h" #ifdef BN_MP_REDUCE_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* reduces x mod m, assumes 0 < x < m**2, mu is * precomputed via mp_reduce_setup. * From HAC pp.604 Algorithm 14.42 */ -int mp_reduce(mp_int *x, const mp_int *m, const mp_int *mu) +mp_err mp_reduce(mp_int *x, const mp_int *m, const mp_int *mu) { mp_int q; - int res, um = m->used; + mp_err err; + int um = m->used; /* q = x */ - if ((res = mp_init_copy(&q, x)) != MP_OKAY) { - return res; + if ((err = mp_init_copy(&q, x)) != MP_OKAY) { + return err; } /* q1 = x / b**(k-1) */ mp_rshd(&q, um - 1); /* according to HAC this optimization is ok */ - if ((mp_digit)um > ((mp_digit)1 << (DIGIT_BIT - 1))) { - if ((res = mp_mul(&q, mu, &q)) != MP_OKAY) { + if ((mp_digit)um > ((mp_digit)1 << (MP_DIGIT_BIT - 1))) { + if ((err = mp_mul(&q, mu, &q)) != MP_OKAY) { + goto CLEANUP; + } + } else if (MP_HAS(S_MP_MUL_HIGH_DIGS)) { + if ((err = s_mp_mul_high_digs(&q, mu, &q, um)) != MP_OKAY) { + goto CLEANUP; + } + } else if (MP_HAS(S_MP_MUL_HIGH_DIGS_FAST)) { + if ((err = s_mp_mul_high_digs_fast(&q, mu, &q, um)) != MP_OKAY) { goto CLEANUP; } } else { -#ifdef BN_S_MP_MUL_HIGH_DIGS_C - if ((res = s_mp_mul_high_digs(&q, mu, &q, um)) != MP_OKAY) { - goto CLEANUP; - } -#elif defined(BN_FAST_S_MP_MUL_HIGH_DIGS_C) - if ((res = fast_s_mp_mul_high_digs(&q, mu, &q, um)) != MP_OKAY) { - goto CLEANUP; - } -#else - { - res = MP_VAL; - goto CLEANUP; - } -#endif + err = MP_VAL; + goto CLEANUP; } /* q3 = q2 / b**(k+1) */ mp_rshd(&q, um + 1); /* x = x mod b**(k+1), quick (no division) */ - if ((res = mp_mod_2d(x, DIGIT_BIT * (um + 1), x)) != MP_OKAY) { + if ((err = mp_mod_2d(x, MP_DIGIT_BIT * (um + 1), x)) != MP_OKAY) { goto CLEANUP; } /* q = q * m mod b**(k+1), quick (no division) */ - if ((res = s_mp_mul_digs(&q, m, &q, um + 1)) != MP_OKAY) { + if ((err = s_mp_mul_digs(&q, m, &q, um + 1)) != MP_OKAY) { goto CLEANUP; } /* x = x - q */ - if ((res = mp_sub(x, &q, x)) != MP_OKAY) { + if ((err = mp_sub(x, &q, x)) != MP_OKAY) { goto CLEANUP; } /* If x < 0, add b**(k+1) to it */ if (mp_cmp_d(x, 0uL) == MP_LT) { mp_set(&q, 1uL); - if ((res = mp_lshd(&q, um + 1)) != MP_OKAY) + if ((err = mp_lshd(&q, um + 1)) != MP_OKAY) { goto CLEANUP; - if ((res = mp_add(x, &q, x)) != MP_OKAY) + } + if ((err = mp_add(x, &q, x)) != MP_OKAY) { goto CLEANUP; + } } /* Back off if it's too big */ while (mp_cmp(x, m) != MP_LT) { - if ((res = s_mp_sub(x, m, x)) != MP_OKAY) { + if ((err = s_mp_sub(x, m, x)) != MP_OKAY) { goto CLEANUP; } } CLEANUP: mp_clear(&q); - return res; + return err; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_reduce_2k.c ================================================================== --- libtommath/bn_mp_reduce_2k.c +++ libtommath/bn_mp_reduce_2k.c @@ -1,60 +1,48 @@ #include "tommath_private.h" #ifdef BN_MP_REDUCE_2K_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* reduces a modulo n where n is of the form 2**p - d */ -int mp_reduce_2k(mp_int *a, const mp_int *n, mp_digit d) +mp_err mp_reduce_2k(mp_int *a, const mp_int *n, mp_digit d) { mp_int q; - int p, res; + mp_err err; + int p; - if ((res = mp_init(&q)) != MP_OKAY) { - return res; + if ((err = mp_init(&q)) != MP_OKAY) { + return err; } p = mp_count_bits(n); top: /* q = a/2**p, a = a mod 2**p */ - if ((res = mp_div_2d(a, p, &q, a)) != MP_OKAY) { + if ((err = mp_div_2d(a, p, &q, a)) != MP_OKAY) { goto LBL_ERR; } if (d != 1u) { /* q = q * d */ - if ((res = mp_mul_d(&q, d, &q)) != MP_OKAY) { + if ((err = mp_mul_d(&q, d, &q)) != MP_OKAY) { goto LBL_ERR; } } /* a = a + q */ - if ((res = s_mp_add(a, &q, a)) != MP_OKAY) { + if ((err = s_mp_add(a, &q, a)) != MP_OKAY) { goto LBL_ERR; } if (mp_cmp_mag(a, n) != MP_LT) { - if ((res = s_mp_sub(a, n, a)) != MP_OKAY) { + if ((err = s_mp_sub(a, n, a)) != MP_OKAY) { goto LBL_ERR; } goto top; } LBL_ERR: mp_clear(&q); - return res; + return err; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_reduce_2k_l.c ================================================================== --- libtommath/bn_mp_reduce_2k_l.c +++ libtommath/bn_mp_reduce_2k_l.c @@ -1,61 +1,49 @@ #include "tommath_private.h" #ifdef BN_MP_REDUCE_2K_L_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* reduces a modulo n where n is of the form 2**p - d This differs from reduce_2k since "d" can be larger than a single digit. */ -int mp_reduce_2k_l(mp_int *a, const mp_int *n, const mp_int *d) +mp_err mp_reduce_2k_l(mp_int *a, const mp_int *n, const mp_int *d) { mp_int q; - int p, res; + mp_err err; + int p; - if ((res = mp_init(&q)) != MP_OKAY) { - return res; + if ((err = mp_init(&q)) != MP_OKAY) { + return err; } p = mp_count_bits(n); top: /* q = a/2**p, a = a mod 2**p */ - if ((res = mp_div_2d(a, p, &q, a)) != MP_OKAY) { + if ((err = mp_div_2d(a, p, &q, a)) != MP_OKAY) { goto LBL_ERR; } /* q = q * d */ - if ((res = mp_mul(&q, d, &q)) != MP_OKAY) { + if ((err = mp_mul(&q, d, &q)) != MP_OKAY) { goto LBL_ERR; } /* a = a + q */ - if ((res = s_mp_add(a, &q, a)) != MP_OKAY) { + if ((err = s_mp_add(a, &q, a)) != MP_OKAY) { goto LBL_ERR; } if (mp_cmp_mag(a, n) != MP_LT) { - if ((res = s_mp_sub(a, n, a)) != MP_OKAY) { + if ((err = s_mp_sub(a, n, a)) != MP_OKAY) { goto LBL_ERR; } goto top; } LBL_ERR: mp_clear(&q); - return res; + return err; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_reduce_2k_setup.c ================================================================== --- libtommath/bn_mp_reduce_2k_setup.c +++ libtommath/bn_mp_reduce_2k_setup.c @@ -1,44 +1,32 @@ #include "tommath_private.h" #ifdef BN_MP_REDUCE_2K_SETUP_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* determines the setup value */ -int mp_reduce_2k_setup(const mp_int *a, mp_digit *d) +mp_err mp_reduce_2k_setup(const mp_int *a, mp_digit *d) { - int res, p; + mp_err err; mp_int tmp; + int p; - if ((res = mp_init(&tmp)) != MP_OKAY) { - return res; + if ((err = mp_init(&tmp)) != MP_OKAY) { + return err; } p = mp_count_bits(a); - if ((res = mp_2expt(&tmp, p)) != MP_OKAY) { + if ((err = mp_2expt(&tmp, p)) != MP_OKAY) { mp_clear(&tmp); - return res; + return err; } - if ((res = s_mp_sub(&tmp, a, &tmp)) != MP_OKAY) { + if ((err = s_mp_sub(&tmp, a, &tmp)) != MP_OKAY) { mp_clear(&tmp); - return res; + return err; } *d = tmp.dp[0]; mp_clear(&tmp); return MP_OKAY; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_reduce_2k_setup_l.c ================================================================== --- libtommath/bn_mp_reduce_2k_setup_l.c +++ libtommath/bn_mp_reduce_2k_setup_l.c @@ -1,41 +1,28 @@ #include "tommath_private.h" #ifdef BN_MP_REDUCE_2K_SETUP_L_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* determines the setup value */ -int mp_reduce_2k_setup_l(const mp_int *a, mp_int *d) +mp_err mp_reduce_2k_setup_l(const mp_int *a, mp_int *d) { - int res; + mp_err err; mp_int tmp; - if ((res = mp_init(&tmp)) != MP_OKAY) { - return res; + if ((err = mp_init(&tmp)) != MP_OKAY) { + return err; } - if ((res = mp_2expt(&tmp, mp_count_bits(a))) != MP_OKAY) { + if ((err = mp_2expt(&tmp, mp_count_bits(a))) != MP_OKAY) { goto LBL_ERR; } - if ((res = s_mp_sub(&tmp, a, d)) != MP_OKAY) { + if ((err = s_mp_sub(&tmp, a, d)) != MP_OKAY) { goto LBL_ERR; } LBL_ERR: mp_clear(&tmp); - return res; + return err; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_reduce_is_2k.c ================================================================== --- libtommath/bn_mp_reduce_is_2k.c +++ libtommath/bn_mp_reduce_is_2k.c @@ -1,21 +1,12 @@ #include "tommath_private.h" #ifdef BN_MP_REDUCE_IS_2K_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* determines if mp_reduce_2k can be used */ -int mp_reduce_is_2k(const mp_int *a) +mp_bool mp_reduce_is_2k(const mp_int *a) { int ix, iy, iw; mp_digit iz; if (a->used == 0) { @@ -26,24 +17,22 @@ iy = mp_count_bits(a); iz = 1; iw = 1; /* Test every bit from the second digit up, must be 1 */ - for (ix = DIGIT_BIT; ix < iy; ix++) { + for (ix = MP_DIGIT_BIT; ix < iy; ix++) { if ((a->dp[iw] & iz) == 0u) { return MP_NO; } iz <<= 1; - if (iz > (mp_digit)MP_MASK) { + if (iz > MP_DIGIT_MAX) { ++iw; iz = 1; } } + return MP_YES; + } else { + return MP_YES; } - return MP_YES; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_reduce_is_2k_l.c ================================================================== --- libtommath/bn_mp_reduce_is_2k_l.c +++ libtommath/bn_mp_reduce_is_2k_l.c @@ -1,21 +1,12 @@ #include "tommath_private.h" #ifdef BN_MP_REDUCE_IS_2K_L_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* determines if reduce_2k_l can be used */ -int mp_reduce_is_2k_l(const mp_int *a) +mp_bool mp_reduce_is_2k_l(const mp_int *a) { int ix, iy; if (a->used == 0) { return MP_NO; @@ -22,20 +13,16 @@ } else if (a->used == 1) { return MP_YES; } else if (a->used > 1) { /* if more than half of the digits are -1 we're sold */ for (iy = ix = 0; ix < a->used; ix++) { - if (a->dp[ix] == MP_MASK) { + if (a->dp[ix] == MP_DIGIT_MAX) { ++iy; } } return (iy >= (a->used/2)) ? MP_YES : MP_NO; - + } else { + return MP_NO; } - return MP_NO; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_reduce_setup.c ================================================================== --- libtommath/bn_mp_reduce_setup.c +++ libtommath/bn_mp_reduce_setup.c @@ -1,31 +1,17 @@ #include "tommath_private.h" #ifdef BN_MP_REDUCE_SETUP_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* pre-calculate the value required for Barrett reduction * For a given modulus "b" it calulates the value required in "a" */ -int mp_reduce_setup(mp_int *a, const mp_int *b) +mp_err mp_reduce_setup(mp_int *a, const mp_int *b) { - int res; - - if ((res = mp_2expt(a, b->used * 2 * DIGIT_BIT)) != MP_OKAY) { - return res; + mp_err err; + if ((err = mp_2expt(a, b->used * 2 * MP_DIGIT_BIT)) != MP_OKAY) { + return err; } return mp_div(a, b, a, NULL); } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ ADDED libtommath/bn_mp_root_u32.c Index: libtommath/bn_mp_root_u32.c ================================================================== --- /dev/null +++ libtommath/bn_mp_root_u32.c @@ -0,0 +1,139 @@ +#include "tommath_private.h" +#ifdef BN_MP_ROOT_U32_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +/* find the n'th root of an integer + * + * Result found such that (c)**b <= a and (c+1)**b > a + * + * This algorithm uses Newton's approximation + * x[i+1] = x[i] - f(x[i])/f'(x[i]) + * which will find the root in log(N) time where + * each step involves a fair bit. + */ +mp_err mp_root_u32(const mp_int *a, unsigned int b, mp_int *c) +{ + mp_int t1, t2, t3, a_; + mp_ord cmp; + int ilog2; + mp_err err; + + /* input must be positive if b is even */ + if (((b & 1u) == 0u) && (a->sign == MP_NEG)) { + return MP_VAL; + } + + if ((err = mp_init_multi(&t1, &t2, &t3, NULL)) != MP_OKAY) { + return err; + } + + /* if a is negative fudge the sign but keep track */ + a_ = *a; + a_.sign = MP_ZPOS; + + /* Compute seed: 2^(log_2(n)/b + 2)*/ + ilog2 = mp_count_bits(a); + + /* + If "b" is larger than INT_MAX it is also larger than + log_2(n) because the bit-length of the "n" is measured + with an int and hence the root is always < 2 (two). + */ + if (b > (unsigned int)(INT_MAX/2)) { + mp_set(c, 1uL); + c->sign = a->sign; + err = MP_OKAY; + goto LBL_ERR; + } + + /* "b" is smaller than INT_MAX, we can cast safely */ + if (ilog2 < (int)b) { + mp_set(c, 1uL); + c->sign = a->sign; + err = MP_OKAY; + goto LBL_ERR; + } + ilog2 = ilog2 / ((int)b); + if (ilog2 == 0) { + mp_set(c, 1uL); + c->sign = a->sign; + err = MP_OKAY; + goto LBL_ERR; + } + /* Start value must be larger than root */ + ilog2 += 2; + if ((err = mp_2expt(&t2,ilog2)) != MP_OKAY) goto LBL_ERR; + do { + /* t1 = t2 */ + if ((err = mp_copy(&t2, &t1)) != MP_OKAY) goto LBL_ERR; + + /* t2 = t1 - ((t1**b - a) / (b * t1**(b-1))) */ + + /* t3 = t1**(b-1) */ + if ((err = mp_expt_u32(&t1, b - 1u, &t3)) != MP_OKAY) goto LBL_ERR; + + /* numerator */ + /* t2 = t1**b */ + if ((err = mp_mul(&t3, &t1, &t2)) != MP_OKAY) goto LBL_ERR; + + /* t2 = t1**b - a */ + if ((err = mp_sub(&t2, &a_, &t2)) != MP_OKAY) goto LBL_ERR; + + /* denominator */ + /* t3 = t1**(b-1) * b */ + if ((err = mp_mul_d(&t3, b, &t3)) != MP_OKAY) goto LBL_ERR; + + /* t3 = (t1**b - a)/(b * t1**(b-1)) */ + if ((err = mp_div(&t2, &t3, &t3, NULL)) != MP_OKAY) goto LBL_ERR; + + if ((err = mp_sub(&t1, &t3, &t2)) != MP_OKAY) goto LBL_ERR; + + /* + Number of rounds is at most log_2(root). If it is more it + got stuck, so break out of the loop and do the rest manually. + */ + if (ilog2-- == 0) { + break; + } + } while (mp_cmp(&t1, &t2) != MP_EQ); + + /* result can be off by a few so check */ + /* Loop beneath can overshoot by one if found root is smaller than actual root */ + for (;;) { + if ((err = mp_expt_u32(&t1, b, &t2)) != MP_OKAY) goto LBL_ERR; + cmp = mp_cmp(&t2, &a_); + if (cmp == MP_EQ) { + err = MP_OKAY; + goto LBL_ERR; + } + if (cmp == MP_LT) { + if ((err = mp_add_d(&t1, 1uL, &t1)) != MP_OKAY) goto LBL_ERR; + } else { + break; + } + } + /* correct overshoot from above or from recurrence */ + for (;;) { + if ((err = mp_expt_u32(&t1, b, &t2)) != MP_OKAY) goto LBL_ERR; + if (mp_cmp(&t2, &a_) == MP_GT) { + if ((err = mp_sub_d(&t1, 1uL, &t1)) != MP_OKAY) goto LBL_ERR; + } else { + break; + } + } + + /* set the result */ + mp_exch(&t1, c); + + /* set the sign of the result */ + c->sign = a->sign; + + err = MP_OKAY; + +LBL_ERR: + mp_clear_multi(&t1, &t2, &t3, NULL); + return err; +} + +#endif Index: libtommath/bn_mp_rshd.c ================================================================== --- libtommath/bn_mp_rshd.c +++ libtommath/bn_mp_rshd.c @@ -1,23 +1,15 @@ #include "tommath_private.h" #ifdef BN_MP_RSHD_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* shift right a certain amount of digits */ void mp_rshd(mp_int *a, int b) { int x; + mp_digit *bottom, *top; /* if b <= 0 then ignore it */ if (b <= 0) { return; } @@ -26,44 +18,34 @@ if (a->used <= b) { mp_zero(a); return; } - { - mp_digit *bottom, *top; - - /* shift the digits down */ - - /* bottom */ - bottom = a->dp; - - /* top [offset into digits] */ - top = a->dp + b; - - /* this is implemented as a sliding window where - * the window is b-digits long and digits from - * the top of the window are copied to the bottom - * - * e.g. - - b-2 | b-1 | b0 | b1 | b2 | ... | bb | ----> - /\ | ----> - \-------------------/ ----> - */ - for (x = 0; x < (a->used - b); x++) { - *bottom++ = *top++; - } - - /* zero the top digits */ - for (; x < a->used; x++) { - *bottom++ = 0; - } - } + /* shift the digits down */ + + /* bottom */ + bottom = a->dp; + + /* top [offset into digits] */ + top = a->dp + b; + + /* this is implemented as a sliding window where + * the window is b-digits long and digits from + * the top of the window are copied to the bottom + * + * e.g. + + b-2 | b-1 | b0 | b1 | b2 | ... | bb | ----> + /\ | ----> + \-------------------/ ----> + */ + for (x = 0; x < (a->used - b); x++) { + *bottom++ = *top++; + } + + /* zero the top digits */ + MP_ZERO_DIGITS(bottom, a->used - x); /* remove excess digits */ a->used -= b; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ ADDED libtommath/bn_mp_sbin_size.c Index: libtommath/bn_mp_sbin_size.c ================================================================== --- /dev/null +++ libtommath/bn_mp_sbin_size.c @@ -0,0 +1,11 @@ +#include "tommath_private.h" +#ifdef BN_MP_SBIN_SIZE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +/* get the size for an signed equivalent */ +size_t mp_sbin_size(const mp_int *a) +{ + return 1u + mp_ubin_size(a); +} +#endif Index: libtommath/bn_mp_set.c ================================================================== --- libtommath/bn_mp_set.c +++ libtommath/bn_mp_set.c @@ -1,26 +1,14 @@ #include "tommath_private.h" #ifdef BN_MP_SET_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* set to a digit */ void mp_set(mp_int *a, mp_digit b) { - mp_zero(a); a->dp[0] = b & MP_MASK; + a->sign = MP_ZPOS; a->used = (a->dp[0] != 0u) ? 1 : 0; + MP_ZERO_DIGITS(a->dp + a->used, a->alloc - a->used); } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_set_double.c ================================================================== --- libtommath/bn_mp_set_double.c +++ libtommath/bn_mp_set_double.c @@ -1,49 +1,38 @@ #include "tommath_private.h" #ifdef BN_MP_SET_DOUBLE_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ #if defined(__STDC_IEC_559__) || defined(__GCC_IEC_559) -int mp_set_double(mp_int *a, double b) +mp_err mp_set_double(mp_int *a, double b) { - unsigned long long frac; - int exp, res; + uint64_t frac; + int exp; + mp_err err; union { double dbl; - unsigned long long bits; + uint64_t bits; } cast; cast.dbl = b; - exp = (int)((unsigned)(cast.bits >> 52) & 0x7FFU); - frac = (cast.bits & ((1ULL << 52) - 1ULL)) | (1ULL << 52); + exp = (int)((unsigned)(cast.bits >> 52) & 0x7FFu); + frac = (cast.bits & ((1uLL << 52) - 1uLL)) | (1uLL << 52); if (exp == 0x7FF) { /* +-inf, NaN */ return MP_VAL; } exp -= 1023 + 52; - res = mp_set_long_long(a, frac); - if (res != MP_OKAY) { - return res; + mp_set_u64(a, frac); + + err = (exp < 0) ? mp_div_2d(a, -exp, a, NULL) : mp_mul_2d(a, exp, a); + if (err != MP_OKAY) { + return err; } - res = (exp < 0) ? mp_div_2d(a, -exp, a, NULL) : mp_mul_2d(a, exp, a); - if (res != MP_OKAY) { - return res; - } - - if (((cast.bits >> 63) != 0ULL) && !IS_ZERO(a)) { + if (((cast.bits >> 63) != 0uLL) && !MP_IS_ZERO(a)) { a->sign = MP_NEG; } return MP_OKAY; } @@ -54,9 +43,5 @@ # else # warning "mp_set_double implementation is only available on platforms with IEEE754 floating point format" # endif #endif #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ ADDED libtommath/bn_mp_set_i32.c Index: libtommath/bn_mp_set_i32.c ================================================================== --- /dev/null +++ libtommath/bn_mp_set_i32.c @@ -0,0 +1,7 @@ +#include "tommath_private.h" +#ifdef BN_MP_SET_I32_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +MP_SET_SIGNED(mp_set_i32, mp_set_u32, int32_t, uint32_t) +#endif ADDED libtommath/bn_mp_set_i64.c Index: libtommath/bn_mp_set_i64.c ================================================================== --- /dev/null +++ libtommath/bn_mp_set_i64.c @@ -0,0 +1,7 @@ +#include "tommath_private.h" +#ifdef BN_MP_SET_I64_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +MP_SET_SIGNED(mp_set_i64, mp_set_u64, int64_t, uint64_t) +#endif DELETED libtommath/bn_mp_set_int.c Index: libtommath/bn_mp_set_int.c ================================================================== --- libtommath/bn_mp_set_int.c +++ /dev/null @@ -1,45 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_MP_SET_INT_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* set a 32-bit const */ -int mp_set_int(mp_int *a, unsigned long b) -{ - int x, res; - - mp_zero(a); - - /* set four bits at a time */ - for (x = 0; x < 8; x++) { - /* shift the number up four bits */ - if ((res = mp_mul_2d(a, 4, a)) != MP_OKAY) { - return res; - } - - /* OR in the top four bits of the source */ - a->dp[0] |= (mp_digit)(b >> 28) & 15uL; - - /* shift the source up to the next four bits */ - b <<= 4; - - /* ensure that digits are not clamped off */ - a->used += 1; - } - mp_clamp(a); - return MP_OKAY; -} -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ ADDED libtommath/bn_mp_set_l.c Index: libtommath/bn_mp_set_l.c ================================================================== --- /dev/null +++ libtommath/bn_mp_set_l.c @@ -0,0 +1,7 @@ +#include "tommath_private.h" +#ifdef BN_MP_SET_L_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +MP_SET_SIGNED(mp_set_l, mp_set_ul, long, unsigned long) +#endif ADDED libtommath/bn_mp_set_ll.c Index: libtommath/bn_mp_set_ll.c ================================================================== --- /dev/null +++ libtommath/bn_mp_set_ll.c @@ -0,0 +1,7 @@ +#include "tommath_private.h" +#ifdef BN_MP_SET_LL_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +MP_SET_SIGNED(mp_set_ll, mp_set_ull, long long, unsigned long long) +#endif DELETED libtommath/bn_mp_set_long.c Index: libtommath/bn_mp_set_long.c ================================================================== --- libtommath/bn_mp_set_long.c +++ /dev/null @@ -1,21 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_MP_SET_LONG_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* set a platform dependent unsigned long int */ -MP_SET_XLONG(mp_set_long, unsigned long) -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ DELETED libtommath/bn_mp_set_long_long.c Index: libtommath/bn_mp_set_long_long.c ================================================================== --- libtommath/bn_mp_set_long_long.c +++ /dev/null @@ -1,21 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_MP_SET_LONG_LONG_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* set a platform dependent unsigned long long int */ -MP_SET_XLONG(mp_set_long_long, Tcl_WideUInt) -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ ADDED libtommath/bn_mp_set_u32.c Index: libtommath/bn_mp_set_u32.c ================================================================== --- /dev/null +++ libtommath/bn_mp_set_u32.c @@ -0,0 +1,7 @@ +#include "tommath_private.h" +#ifdef BN_MP_SET_U32_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +MP_SET_UNSIGNED(mp_set_u32, uint32_t) +#endif ADDED libtommath/bn_mp_set_u64.c Index: libtommath/bn_mp_set_u64.c ================================================================== --- /dev/null +++ libtommath/bn_mp_set_u64.c @@ -0,0 +1,7 @@ +#include "tommath_private.h" +#ifdef BN_MP_SET_U64_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +MP_SET_UNSIGNED(mp_set_u64, uint64_t) +#endif ADDED libtommath/bn_mp_set_ul.c Index: libtommath/bn_mp_set_ul.c ================================================================== --- /dev/null +++ libtommath/bn_mp_set_ul.c @@ -0,0 +1,7 @@ +#include "tommath_private.h" +#ifdef BN_MP_SET_UL_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +MP_SET_UNSIGNED(mp_set_ul, unsigned long) +#endif ADDED libtommath/bn_mp_set_ull.c Index: libtommath/bn_mp_set_ull.c ================================================================== --- /dev/null +++ libtommath/bn_mp_set_ull.c @@ -0,0 +1,7 @@ +#include "tommath_private.h" +#ifdef BN_MP_SET_ULL_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +MP_SET_UNSIGNED(mp_set_ull, unsigned long long) +#endif Index: libtommath/bn_mp_shrink.c ================================================================== --- libtommath/bn_mp_shrink.c +++ libtommath/bn_mp_shrink.c @@ -1,40 +1,22 @@ #include "tommath_private.h" #ifdef BN_MP_SHRINK_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* shrink a bignum */ -int mp_shrink(mp_int *a) +mp_err mp_shrink(mp_int *a) { mp_digit *tmp; - int used = 1; - - if (a->used > 0) { - used = a->used; - } - - if (a->alloc != used) { - if ((tmp = (mp_digit *) XREALLOC(a->dp, - (size_t)a->alloc * sizeof (mp_digit), - (size_t)used * sizeof(mp_digit))) == NULL) { + int alloc = MP_MAX(MP_MIN_PREC, a->used); + if (a->alloc != alloc) { + if ((tmp = (mp_digit *) MP_REALLOC(a->dp, + (size_t)a->alloc * sizeof(mp_digit), + (size_t)alloc * sizeof(mp_digit))) == NULL) { return MP_MEM; } a->dp = tmp; - a->alloc = used; + a->alloc = alloc; } return MP_OKAY; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ DELETED libtommath/bn_mp_signed_bin_size.c Index: libtommath/bn_mp_signed_bin_size.c ================================================================== --- libtommath/bn_mp_signed_bin_size.c +++ /dev/null @@ -1,24 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_MP_SIGNED_BIN_SIZE_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* get the size for an signed equivalent */ -int mp_signed_bin_size(const mp_int *a) -{ - return 1 + mp_unsigned_bin_size(a); -} -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_sqr.c ================================================================== --- libtommath/bn_mp_sqr.c +++ libtommath/bn_mp_sqr.c @@ -1,56 +1,28 @@ #include "tommath_private.h" #ifdef BN_MP_SQR_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* computes b = a*a */ -int mp_sqr(const mp_int *a, mp_int *b) -{ - int res; - -#ifdef BN_MP_TOOM_SQR_C - /* use Toom-Cook? */ - if (a->used >= TOOM_SQR_CUTOFF) { - res = mp_toom_sqr(a, b); - /* Karatsuba? */ - } else -#endif -#ifdef BN_MP_KARATSUBA_SQR_C - if (a->used >= KARATSUBA_SQR_CUTOFF) { - res = mp_karatsuba_sqr(a, b); - } else -#endif - { -#ifdef BN_FAST_S_MP_SQR_C - /* can we use the fast comba multiplier? */ - if ((((a->used * 2) + 1) < (int)MP_WARRAY) && - (a->used < - (int)(1u << (((sizeof(mp_word) * (size_t)CHAR_BIT) - (2u * (size_t)DIGIT_BIT)) - 1u)))) { - res = fast_s_mp_sqr(a, b); - } else -#endif - { -#ifdef BN_S_MP_SQR_C - res = s_mp_sqr(a, b); -#else - res = MP_VAL; -#endif - } - } - b->sign = MP_ZPOS; - return res; -} -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ +mp_err mp_sqr(const mp_int *a, mp_int *b) +{ + mp_err err; + if (MP_HAS(S_MP_TOOM_SQR) && /* use Toom-Cook? */ + (a->used >= MP_TOOM_SQR_CUTOFF)) { + err = s_mp_toom_sqr(a, b); + } else if (MP_HAS(S_MP_KARATSUBA_SQR) && /* Karatsuba? */ + (a->used >= MP_KARATSUBA_SQR_CUTOFF)) { + err = s_mp_karatsuba_sqr(a, b); + } else if (MP_HAS(S_MP_SQR_FAST) && /* can we use the fast comba multiplier? */ + (((a->used * 2) + 1) < MP_WARRAY) && + (a->used < (MP_MAXFAST / 2))) { + err = s_mp_sqr_fast(a, b); + } else if (MP_HAS(S_MP_SQR)) { + err = s_mp_sqr(a, b); + } else { + err = MP_VAL; + } + b->sign = MP_ZPOS; + return err; +} +#endif Index: libtommath/bn_mp_sqrmod.c ================================================================== --- libtommath/bn_mp_sqrmod.c +++ libtommath/bn_mp_sqrmod.c @@ -1,37 +1,25 @@ #include "tommath_private.h" #ifdef BN_MP_SQRMOD_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* c = a * a (mod b) */ -int mp_sqrmod(const mp_int *a, const mp_int *b, mp_int *c) +mp_err mp_sqrmod(const mp_int *a, const mp_int *b, mp_int *c) { - int res; + mp_err err; mp_int t; - if ((res = mp_init(&t)) != MP_OKAY) { - return res; - } - - if ((res = mp_sqr(a, &t)) != MP_OKAY) { - mp_clear(&t); - return res; - } - res = mp_mod(&t, b, c); - mp_clear(&t); - return res; + if ((err = mp_init(&t)) != MP_OKAY) { + return err; + } + + if ((err = mp_sqr(a, &t)) != MP_OKAY) { + goto LBL_ERR; + } + err = mp_mod(&t, b, c); + +LBL_ERR: + mp_clear(&t); + return err; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_sqrt.c ================================================================== --- libtommath/bn_mp_sqrt.c +++ libtommath/bn_mp_sqrt.c @@ -1,30 +1,21 @@ #include "tommath_private.h" #ifdef BN_MP_SQRT_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ #ifndef NO_FLOATING_POINT #include -#if (DIGIT_BIT != 28) || (FLT_RADIX != 2) || (DBL_MANT_DIG != 53) || (DBL_MAX_EXP != 1024) +#if (MP_DIGIT_BIT != 28) || (FLT_RADIX != 2) || (DBL_MANT_DIG != 53) || (DBL_MAX_EXP != 1024) #define NO_FLOATING_POINT #endif #endif /* this function is less generic than mp_n_root, simpler and faster */ -int mp_sqrt(const mp_int *arg, mp_int *ret) +mp_err mp_sqrt(const mp_int *arg, mp_int *ret) { - int res; + mp_err err; mp_int t1, t2; #ifndef NO_FLOATING_POINT int i, j, k; volatile double d; mp_digit dig; @@ -34,24 +25,24 @@ if (arg->sign == MP_NEG) { return MP_VAL; } /* easy out */ - if (mp_iszero(arg) == MP_YES) { + if (MP_IS_ZERO(arg)) { mp_zero(ret); return MP_OKAY; } #ifndef NO_FLOATING_POINT i = (arg->used / 2) - 1; j = 2 * i; - if ((res = mp_init_size(&t1, i+2)) != MP_OKAY) { - return res; + if ((err = mp_init_size(&t1, i+2)) != MP_OKAY) { + return err; } - if ((res = mp_init(&t2)) != MP_OKAY) { + if ((err = mp_init(&t2)) != MP_OKAY) { goto E2; } for (k = 0; k < i; ++k) { t1.dp[k] = (mp_digit) 0; @@ -59,11 +50,11 @@ /* Estimate the square root using the hardware floating point unit. */ d = 0.0; for (k = arg->used-1; k >= j; --k) { - d = ldexp(d, DIGIT_BIT) + (double)(arg->dp[k]); + d = ldexp(d, MP_DIGIT_BIT) + (double)(arg->dp[k]); } /* * At this point, d is the nearest floating point number to the most * significant 1 or 2 mp_digits of arg. Extract its square root. @@ -71,22 +62,22 @@ d = sqrt(d); /* dig is the most significant mp_digit of the square root */ - dig = (mp_digit) ldexp(d, -DIGIT_BIT); + dig = (mp_digit) ldexp(d, -MP_DIGIT_BIT); /* * If the most significant digit is nonzero, find the next digit down - * by subtracting DIGIT_BIT times thie most significant digit. + * by subtracting MP_DIGIT_BIT times thie most significant digit. * Subtract one from the result so that our initial estimate is always * low. */ if (dig) { t1.used = i+2; - d -= ldexp((double) dig, DIGIT_BIT); + d -= ldexp((double) dig, MP_DIGIT_BIT); if (d >= 1.0) { t1.dp[i+1] = dig; t1.dp[i] = ((mp_digit) d) - 1; } else { t1.dp[i+1] = dig-1; @@ -97,42 +88,42 @@ t1.dp[i] = ((mp_digit) d) - 1; } #else - if ((res = mp_init_copy(&t1, arg)) != MP_OKAY) { - return res; + if ((err = mp_init_copy(&t1, arg)) != MP_OKAY) { + return err; } - if ((res = mp_init(&t2)) != MP_OKAY) { + if ((err = mp_init(&t2)) != MP_OKAY) { goto E2; } /* First approx. (not very bad for large arg) */ mp_rshd(&t1, t1.used/2); #endif /* t1 > 0 */ - if ((res = mp_div(arg, &t1, &t2, NULL)) != MP_OKAY) { + if ((err = mp_div(arg, &t1, &t2, NULL)) != MP_OKAY) { goto E1; } - if ((res = mp_add(&t1, &t2, &t1)) != MP_OKAY) { + if ((err = mp_add(&t1, &t2, &t1)) != MP_OKAY) { goto E1; } - if ((res = mp_div_2(&t1, &t1)) != MP_OKAY) { + if ((err = mp_div_2(&t1, &t1)) != MP_OKAY) { goto E1; } /* And now t1 > sqrt(arg) */ do { - if ((res = mp_div(arg, &t1, &t2, NULL)) != MP_OKAY) { + if ((err = mp_div(arg, &t1, &t2, NULL)) != MP_OKAY) { goto E1; } - if ((res = mp_add(&t1, &t2, &t1)) != MP_OKAY) { + if ((err = mp_add(&t1, &t2, &t1)) != MP_OKAY) { goto E1; } - if ((res = mp_div_2(&t1, &t1)) != MP_OKAY) { + if ((err = mp_div_2(&t1, &t1)) != MP_OKAY) { goto E1; } /* t1 >= sqrt(arg) >= t2 at this point */ } while (mp_cmp_mag(&t1, &t2) == MP_GT); @@ -140,13 +131,9 @@ E1: mp_clear(&t2); E2: mp_clear(&t1); - return res; + return err; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_sqrtmod_prime.c ================================================================== --- libtommath/bn_mp_sqrtmod_prime.c +++ libtommath/bn_mp_sqrtmod_prime.c @@ -1,131 +1,118 @@ #include "tommath_private.h" #ifdef BN_MP_SQRTMOD_PRIME_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* Tonelli-Shanks algorithm * https://en.wikipedia.org/wiki/Tonelli%E2%80%93Shanks_algorithm * https://gmplib.org/list-archives/gmp-discuss/2013-April/005300.html * */ -int mp_sqrtmod_prime(const mp_int *n, const mp_int *prime, mp_int *ret) +mp_err mp_sqrtmod_prime(const mp_int *n, const mp_int *prime, mp_int *ret) { - int res, legendre; + mp_err err; + int legendre; mp_int t1, C, Q, S, Z, M, T, R, two; mp_digit i; /* first handle the simple cases */ if (mp_cmp_d(n, 0uL) == MP_EQ) { mp_zero(ret); return MP_OKAY; } if (mp_cmp_d(prime, 2uL) == MP_EQ) return MP_VAL; /* prime must be odd */ - if ((res = mp_jacobi(n, prime, &legendre)) != MP_OKAY) return res; + if ((err = mp_kronecker(n, prime, &legendre)) != MP_OKAY) return err; if (legendre == -1) return MP_VAL; /* quadratic non-residue mod prime */ - if ((res = mp_init_multi(&t1, &C, &Q, &S, &Z, &M, &T, &R, &two, NULL)) != MP_OKAY) { - return res; + if ((err = mp_init_multi(&t1, &C, &Q, &S, &Z, &M, &T, &R, &two, NULL)) != MP_OKAY) { + return err; } /* SPECIAL CASE: if prime mod 4 == 3 - * compute directly: res = n^(prime+1)/4 mod prime + * compute directly: err = n^(prime+1)/4 mod prime * Handbook of Applied Cryptography algorithm 3.36 */ - if ((res = mp_mod_d(prime, 4uL, &i)) != MP_OKAY) goto cleanup; + if ((err = mp_mod_d(prime, 4uL, &i)) != MP_OKAY) goto cleanup; if (i == 3u) { - if ((res = mp_add_d(prime, 1uL, &t1)) != MP_OKAY) goto cleanup; - if ((res = mp_div_2(&t1, &t1)) != MP_OKAY) goto cleanup; - if ((res = mp_div_2(&t1, &t1)) != MP_OKAY) goto cleanup; - if ((res = mp_exptmod(n, &t1, prime, ret)) != MP_OKAY) goto cleanup; - res = MP_OKAY; + if ((err = mp_add_d(prime, 1uL, &t1)) != MP_OKAY) goto cleanup; + if ((err = mp_div_2(&t1, &t1)) != MP_OKAY) goto cleanup; + if ((err = mp_div_2(&t1, &t1)) != MP_OKAY) goto cleanup; + if ((err = mp_exptmod(n, &t1, prime, ret)) != MP_OKAY) goto cleanup; + err = MP_OKAY; goto cleanup; } /* NOW: Tonelli-Shanks algorithm */ /* factor out powers of 2 from prime-1, defining Q and S as: prime-1 = Q*2^S */ - if ((res = mp_copy(prime, &Q)) != MP_OKAY) goto cleanup; - if ((res = mp_sub_d(&Q, 1uL, &Q)) != MP_OKAY) goto cleanup; + if ((err = mp_copy(prime, &Q)) != MP_OKAY) goto cleanup; + if ((err = mp_sub_d(&Q, 1uL, &Q)) != MP_OKAY) goto cleanup; /* Q = prime - 1 */ mp_zero(&S); /* S = 0 */ - while (mp_iseven(&Q) != MP_NO) { - if ((res = mp_div_2(&Q, &Q)) != MP_OKAY) goto cleanup; + while (MP_IS_EVEN(&Q)) { + if ((err = mp_div_2(&Q, &Q)) != MP_OKAY) goto cleanup; /* Q = Q / 2 */ - if ((res = mp_add_d(&S, 1uL, &S)) != MP_OKAY) goto cleanup; + if ((err = mp_add_d(&S, 1uL, &S)) != MP_OKAY) goto cleanup; /* S = S + 1 */ } /* find a Z such that the Legendre symbol (Z|prime) == -1 */ - if ((res = mp_set_int(&Z, 2uL)) != MP_OKAY) goto cleanup; + mp_set_u32(&Z, 2u); /* Z = 2 */ - while (1) { - if ((res = mp_jacobi(&Z, prime, &legendre)) != MP_OKAY) goto cleanup; + for (;;) { + if ((err = mp_kronecker(&Z, prime, &legendre)) != MP_OKAY) goto cleanup; if (legendre == -1) break; - if ((res = mp_add_d(&Z, 1uL, &Z)) != MP_OKAY) goto cleanup; + if ((err = mp_add_d(&Z, 1uL, &Z)) != MP_OKAY) goto cleanup; /* Z = Z + 1 */ } - if ((res = mp_exptmod(&Z, &Q, prime, &C)) != MP_OKAY) goto cleanup; + if ((err = mp_exptmod(&Z, &Q, prime, &C)) != MP_OKAY) goto cleanup; /* C = Z ^ Q mod prime */ - if ((res = mp_add_d(&Q, 1uL, &t1)) != MP_OKAY) goto cleanup; - if ((res = mp_div_2(&t1, &t1)) != MP_OKAY) goto cleanup; + if ((err = mp_add_d(&Q, 1uL, &t1)) != MP_OKAY) goto cleanup; + if ((err = mp_div_2(&t1, &t1)) != MP_OKAY) goto cleanup; /* t1 = (Q + 1) / 2 */ - if ((res = mp_exptmod(n, &t1, prime, &R)) != MP_OKAY) goto cleanup; + if ((err = mp_exptmod(n, &t1, prime, &R)) != MP_OKAY) goto cleanup; /* R = n ^ ((Q + 1) / 2) mod prime */ - if ((res = mp_exptmod(n, &Q, prime, &T)) != MP_OKAY) goto cleanup; + if ((err = mp_exptmod(n, &Q, prime, &T)) != MP_OKAY) goto cleanup; /* T = n ^ Q mod prime */ - if ((res = mp_copy(&S, &M)) != MP_OKAY) goto cleanup; + if ((err = mp_copy(&S, &M)) != MP_OKAY) goto cleanup; /* M = S */ - if ((res = mp_set_int(&two, 2uL)) != MP_OKAY) goto cleanup; + mp_set_u32(&two, 2u); - res = MP_VAL; - while (1) { - if ((res = mp_copy(&T, &t1)) != MP_OKAY) goto cleanup; + for (;;) { + if ((err = mp_copy(&T, &t1)) != MP_OKAY) goto cleanup; i = 0; - while (1) { + for (;;) { if (mp_cmp_d(&t1, 1uL) == MP_EQ) break; - if ((res = mp_exptmod(&t1, &two, prime, &t1)) != MP_OKAY) goto cleanup; + if ((err = mp_exptmod(&t1, &two, prime, &t1)) != MP_OKAY) goto cleanup; i++; } if (i == 0u) { - if ((res = mp_copy(&R, ret)) != MP_OKAY) goto cleanup; - res = MP_OKAY; + if ((err = mp_copy(&R, ret)) != MP_OKAY) goto cleanup; + err = MP_OKAY; goto cleanup; } - if ((res = mp_sub_d(&M, i, &t1)) != MP_OKAY) goto cleanup; - if ((res = mp_sub_d(&t1, 1uL, &t1)) != MP_OKAY) goto cleanup; - if ((res = mp_exptmod(&two, &t1, prime, &t1)) != MP_OKAY) goto cleanup; + if ((err = mp_sub_d(&M, i, &t1)) != MP_OKAY) goto cleanup; + if ((err = mp_sub_d(&t1, 1uL, &t1)) != MP_OKAY) goto cleanup; + if ((err = mp_exptmod(&two, &t1, prime, &t1)) != MP_OKAY) goto cleanup; /* t1 = 2 ^ (M - i - 1) */ - if ((res = mp_exptmod(&C, &t1, prime, &t1)) != MP_OKAY) goto cleanup; + if ((err = mp_exptmod(&C, &t1, prime, &t1)) != MP_OKAY) goto cleanup; /* t1 = C ^ (2 ^ (M - i - 1)) mod prime */ - if ((res = mp_sqrmod(&t1, prime, &C)) != MP_OKAY) goto cleanup; + if ((err = mp_sqrmod(&t1, prime, &C)) != MP_OKAY) goto cleanup; /* C = (t1 * t1) mod prime */ - if ((res = mp_mulmod(&R, &t1, prime, &R)) != MP_OKAY) goto cleanup; + if ((err = mp_mulmod(&R, &t1, prime, &R)) != MP_OKAY) goto cleanup; /* R = (R * t1) mod prime */ - if ((res = mp_mulmod(&T, &C, prime, &T)) != MP_OKAY) goto cleanup; + if ((err = mp_mulmod(&T, &C, prime, &T)) != MP_OKAY) goto cleanup; /* T = (T * C) mod prime */ mp_set(&M, i); /* M = i */ } cleanup: mp_clear_multi(&t1, &C, &Q, &S, &Z, &M, &T, &R, &two, NULL); - return res; + return err; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_sub.c ================================================================== --- libtommath/bn_mp_sub.c +++ libtommath/bn_mp_sub.c @@ -1,55 +1,40 @@ #include "tommath_private.h" #ifdef BN_MP_SUB_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* high level subtraction (handles signs) */ -int mp_sub(const mp_int *a, const mp_int *b, mp_int *c) +mp_err mp_sub(const mp_int *a, const mp_int *b, mp_int *c) { - int sa, sb, res; - - sa = a->sign; - sb = b->sign; + mp_sign sa = a->sign, sb = b->sign; + mp_err err; if (sa != sb) { /* subtract a negative from a positive, OR */ /* subtract a positive from a negative. */ /* In either case, ADD their magnitudes, */ /* and use the sign of the first number. */ c->sign = sa; - res = s_mp_add(a, b, c); + err = s_mp_add(a, b, c); } else { /* subtract a positive from a positive, OR */ /* subtract a negative from a negative. */ /* First, take the difference between their */ /* magnitudes, then... */ if (mp_cmp_mag(a, b) != MP_LT) { /* Copy the sign from the first */ c->sign = sa; /* The first has a larger or equal magnitude */ - res = s_mp_sub(a, b, c); + err = s_mp_sub(a, b, c); } else { /* The result has the *opposite* sign from */ /* the first number. */ c->sign = (sa == MP_ZPOS) ? MP_NEG : MP_ZPOS; /* The second has a larger magnitude */ - res = s_mp_sub(b, a, c); + err = s_mp_sub(b, a, c); } } - return res; + return err; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_sub_d.c ================================================================== --- libtommath/bn_mp_sub_d.c +++ libtommath/bn_mp_sub_d.c @@ -1,45 +1,37 @@ #include "tommath_private.h" #ifdef BN_MP_SUB_D_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* single digit subtraction */ -int mp_sub_d(const mp_int *a, mp_digit b, mp_int *c) +mp_err mp_sub_d(const mp_int *a, mp_digit b, mp_int *c) { - mp_digit *tmpa, *tmpc, mu; - int res, ix, oldused; + mp_digit *tmpa, *tmpc; + mp_err err; + int ix, oldused; /* grow c as required */ if (c->alloc < (a->used + 1)) { - if ((res = mp_grow(c, a->used + 1)) != MP_OKAY) { - return res; + if ((err = mp_grow(c, a->used + 1)) != MP_OKAY) { + return err; } } /* if a is negative just do an unsigned * addition [with fudged signs] */ if (a->sign == MP_NEG) { mp_int a_ = *a; a_.sign = MP_ZPOS; - res = mp_add_d(&a_, b, c); + err = mp_add_d(&a_, b, c); c->sign = MP_NEG; /* clamp */ mp_clamp(c); - return res; + return err; } /* setup regs */ oldused = c->used; tmpa = a->dp; @@ -56,35 +48,27 @@ /* negative/1digit */ c->sign = MP_NEG; c->used = 1; } else { + mp_digit mu = b; + /* positive/size */ c->sign = MP_ZPOS; c->used = a->used; - /* subtract first digit */ - *tmpc = *tmpa++ - b; - mu = *tmpc >> ((sizeof(mp_digit) * (size_t)CHAR_BIT) - 1u); - *tmpc++ &= MP_MASK; - - /* handle rest of the digits */ - for (ix = 1; ix < a->used; ix++) { + /* subtract digits, mu is carry */ + for (ix = 0; ix < a->used; ix++) { *tmpc = *tmpa++ - mu; - mu = *tmpc >> ((sizeof(mp_digit) * (size_t)CHAR_BIT) - 1u); + mu = *tmpc >> (MP_SIZEOF_BITS(mp_digit) - 1u); *tmpc++ &= MP_MASK; } } /* zero excess digits */ - while (ix++ < oldused) { - *tmpc++ = 0; - } + MP_ZERO_DIGITS(tmpc, oldused - ix); + mp_clamp(c); return MP_OKAY; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_submod.c ================================================================== --- libtommath/bn_mp_submod.c +++ libtommath/bn_mp_submod.c @@ -1,38 +1,25 @@ #include "tommath_private.h" #ifdef BN_MP_SUBMOD_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* d = a - b (mod c) */ -int mp_submod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d) -{ - int res; - mp_int t; - - - if ((res = mp_init(&t)) != MP_OKAY) { - return res; - } - - if ((res = mp_sub(a, b, &t)) != MP_OKAY) { - mp_clear(&t); - return res; - } - res = mp_mod(&t, c, d); - mp_clear(&t); - return res; +mp_err mp_submod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d) +{ + mp_err err; + mp_int t; + + if ((err = mp_init(&t)) != MP_OKAY) { + return err; + } + + if ((err = mp_sub(a, b, &t)) != MP_OKAY) { + goto LBL_ERR; + } + err = mp_mod(&t, c, d); + +LBL_ERR: + mp_clear(&t); + return err; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ ADDED libtommath/bn_mp_to_radix.c Index: libtommath/bn_mp_to_radix.c ================================================================== --- /dev/null +++ libtommath/bn_mp_to_radix.c @@ -0,0 +1,84 @@ +#include "tommath_private.h" +#ifdef BN_MP_TO_RADIX_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +/* stores a bignum as a ASCII string in a given radix (2..64) + * + * Stores upto "size - 1" chars and always a NULL byte, puts the number of characters + * written, including the '\0', in "written". + */ +mp_err mp_to_radix(const mp_int *a, char *str, size_t maxlen, size_t *written, int radix) +{ + size_t digs; + mp_err err; + mp_int t; + mp_digit d; + char *_s = str; + + /* check range of radix and size*/ + if (maxlen < 2u) { + return MP_BUF; + } + if ((radix < 2) || (radix > 64)) { + return MP_VAL; + } + + /* quick out if its zero */ + if (MP_IS_ZERO(a)) { + *str++ = '0'; + *str = '\0'; + if (written != NULL) { + *written = 2u; + } + return MP_OKAY; + } + + if ((err = mp_init_copy(&t, a)) != MP_OKAY) { + return err; + } + + /* if it is negative output a - */ + if (t.sign == MP_NEG) { + /* we have to reverse our digits later... but not the - sign!! */ + ++_s; + + /* store the flag and mark the number as positive */ + *str++ = '-'; + t.sign = MP_ZPOS; + + /* subtract a char */ + --maxlen; + } + digs = 0u; + while (!MP_IS_ZERO(&t)) { + if (--maxlen < 1u) { + /* no more room */ + err = MP_BUF; + goto LBL_ERR; + } + if ((err = mp_div_d(&t, (mp_digit)radix, &t, &d)) != MP_OKAY) { + goto LBL_ERR; + } + *str++ = mp_s_rmap[d]; + ++digs; + } + /* reverse the digits of the string. In this case _s points + * to the first digit [exluding the sign] of the number + */ + s_mp_reverse((unsigned char *)_s, digs); + + /* append a NULL so the string is properly terminated */ + *str = '\0'; + digs++; + + if (written != NULL) { + *written = (a->sign == MP_NEG) ? (digs + 1u): digs; + } + +LBL_ERR: + mp_clear(&t); + return err; +} + +#endif ADDED libtommath/bn_mp_to_sbin.c Index: libtommath/bn_mp_to_sbin.c ================================================================== --- /dev/null +++ libtommath/bn_mp_to_sbin.c @@ -0,0 +1,22 @@ +#include "tommath_private.h" +#ifdef BN_MP_TO_SBIN_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +/* store in signed [big endian] format */ +mp_err mp_to_sbin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written) +{ + mp_err err; + if (maxlen == 0u) { + return MP_BUF; + } + if ((err = mp_to_ubin(a, buf + 1, maxlen - 1u, written)) != MP_OKAY) { + return err; + } + if (written != NULL) { + (*written)++; + } + buf[0] = (a->sign == MP_ZPOS) ? (unsigned char)0 : (unsigned char)1; + return MP_OKAY; +} +#endif DELETED libtommath/bn_mp_to_signed_bin.c Index: libtommath/bn_mp_to_signed_bin.c ================================================================== --- libtommath/bn_mp_to_signed_bin.c +++ /dev/null @@ -1,30 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_MP_TO_SIGNED_BIN_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* store in signed [big endian] format */ -int mp_to_signed_bin(const mp_int *a, unsigned char *b) -{ - int res; - - if ((res = mp_to_unsigned_bin(a, b + 1)) != MP_OKAY) { - return res; - } - b[0] = (a->sign == MP_ZPOS) ? (unsigned char)0 : (unsigned char)1; - return MP_OKAY; -} -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ DELETED libtommath/bn_mp_to_signed_bin_n.c Index: libtommath/bn_mp_to_signed_bin_n.c ================================================================== --- libtommath/bn_mp_to_signed_bin_n.c +++ /dev/null @@ -1,28 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_MP_TO_SIGNED_BIN_N_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* store in signed [big endian] format */ -int mp_to_signed_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen) -{ - if (*outlen < (unsigned long)mp_signed_bin_size(a)) { - return MP_VAL; - } - *outlen = (unsigned long)mp_signed_bin_size(a); - return mp_to_signed_bin(a, b); -} -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ ADDED libtommath/bn_mp_to_ubin.c Index: libtommath/bn_mp_to_ubin.c ================================================================== --- /dev/null +++ libtommath/bn_mp_to_ubin.c @@ -0,0 +1,42 @@ +#include "tommath_private.h" +#ifdef BN_MP_TO_UBIN_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +/* store in unsigned [big endian] format */ +mp_err mp_to_ubin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written) +{ + size_t x, count; + mp_err err; + mp_int t; + + size_t size = (size_t)mp_count_bits(a); + count = (size / 8u) + (((size & 7u) != 0u) ? 1u : 0u); + if (count > maxlen) { + return MP_BUF; + } + + if ((err = mp_init_copy(&t, a)) != MP_OKAY) { + return err; + } + + for (x = count; x --> 0u;) { +#ifndef MP_8BIT + buf[x] = (unsigned char)(t.dp[0] & 255u); +#else + buf[x] = (unsigned char)(t.dp[0] | ((t.dp[1] & 1u) << 7)); +#endif + if ((err = mp_div_2d(&t, 8, &t, NULL)) != MP_OKAY) { + goto LBL_ERR; + } + } + + if (written != NULL) { + *written = count; + } + +LBL_ERR: + mp_clear(&t); + return err; +} +#endif DELETED libtommath/bn_mp_to_unsigned_bin.c Index: libtommath/bn_mp_to_unsigned_bin.c ================================================================== --- libtommath/bn_mp_to_unsigned_bin.c +++ /dev/null @@ -1,45 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_MP_TO_UNSIGNED_BIN_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* store in unsigned [big endian] format */ -int mp_to_unsigned_bin(const mp_int *a, unsigned char *b) -{ - int x, res; - mp_int t; - - if ((res = mp_init_copy(&t, a)) != MP_OKAY) { - return res; - } - - x = 0; - while (mp_iszero(&t) == MP_NO) { -#ifndef MP_8BIT - b[x++] = (unsigned char)(t.dp[0] & 255u); -#else - b[x++] = (unsigned char)(t.dp[0] | ((t.dp[1] & 1u) << 7)); -#endif - if ((res = mp_div_2d(&t, 8, &t, NULL)) != MP_OKAY) { - mp_clear(&t); - return res; - } - } - bn_reverse(b, x); - mp_clear(&t); - return MP_OKAY; -} -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ DELETED libtommath/bn_mp_to_unsigned_bin_n.c Index: libtommath/bn_mp_to_unsigned_bin_n.c ================================================================== --- libtommath/bn_mp_to_unsigned_bin_n.c +++ /dev/null @@ -1,28 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_MP_TO_UNSIGNED_BIN_N_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* store in unsigned [big endian] format */ -int mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen) -{ - if (*outlen < (unsigned long)mp_unsigned_bin_size(a)) { - return MP_VAL; - } - *outlen = (unsigned long)mp_unsigned_bin_size(a); - return mp_to_unsigned_bin(a, b); -} -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ DELETED libtommath/bn_mp_toom_mul.c Index: libtommath/bn_mp_toom_mul.c ================================================================== --- libtommath/bn_mp_toom_mul.c +++ /dev/null @@ -1,283 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_MP_TOOM_MUL_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* multiplication using the Toom-Cook 3-way algorithm - * - * Much more complicated than Karatsuba but has a lower - * asymptotic running time of O(N**1.464). This algorithm is - * only particularly useful on VERY large inputs - * (we're talking 1000s of digits here...). -*/ -int mp_toom_mul(const mp_int *a, const mp_int *b, mp_int *c) -{ - mp_int w0, w1, w2, w3, w4, tmp1, tmp2, a0, a1, a2, b0, b1, b2; - int res, B; - - /* init temps */ - if ((res = mp_init_multi(&w0, &w1, &w2, &w3, &w4, - &a0, &a1, &a2, &b0, &b1, - &b2, &tmp1, &tmp2, NULL)) != MP_OKAY) { - return res; - } - - /* B */ - B = MIN(a->used, b->used) / 3; - - /* a = a2 * B**2 + a1 * B + a0 */ - if ((res = mp_mod_2d(a, DIGIT_BIT * B, &a0)) != MP_OKAY) { - goto LBL_ERR; - } - - if ((res = mp_copy(a, &a1)) != MP_OKAY) { - goto LBL_ERR; - } - mp_rshd(&a1, B); - if ((res = mp_mod_2d(&a1, DIGIT_BIT * B, &a1)) != MP_OKAY) { - goto LBL_ERR; - } - - if ((res = mp_copy(a, &a2)) != MP_OKAY) { - goto LBL_ERR; - } - mp_rshd(&a2, B*2); - - /* b = b2 * B**2 + b1 * B + b0 */ - if ((res = mp_mod_2d(b, DIGIT_BIT * B, &b0)) != MP_OKAY) { - goto LBL_ERR; - } - - if ((res = mp_copy(b, &b1)) != MP_OKAY) { - goto LBL_ERR; - } - mp_rshd(&b1, B); - (void)mp_mod_2d(&b1, DIGIT_BIT * B, &b1); - - if ((res = mp_copy(b, &b2)) != MP_OKAY) { - goto LBL_ERR; - } - mp_rshd(&b2, B*2); - - /* w0 = a0*b0 */ - if ((res = mp_mul(&a0, &b0, &w0)) != MP_OKAY) { - goto LBL_ERR; - } - - /* w4 = a2 * b2 */ - if ((res = mp_mul(&a2, &b2, &w4)) != MP_OKAY) { - goto LBL_ERR; - } - - /* w1 = (a2 + 2(a1 + 2a0))(b2 + 2(b1 + 2b0)) */ - if ((res = mp_mul_2(&a0, &tmp1)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_add(&tmp1, &a2, &tmp1)) != MP_OKAY) { - goto LBL_ERR; - } - - if ((res = mp_mul_2(&b0, &tmp2)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_add(&tmp2, &b1, &tmp2)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_mul_2(&tmp2, &tmp2)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_add(&tmp2, &b2, &tmp2)) != MP_OKAY) { - goto LBL_ERR; - } - - if ((res = mp_mul(&tmp1, &tmp2, &w1)) != MP_OKAY) { - goto LBL_ERR; - } - - /* w3 = (a0 + 2(a1 + 2a2))(b0 + 2(b1 + 2b2)) */ - if ((res = mp_mul_2(&a2, &tmp1)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) { - goto LBL_ERR; - } - - if ((res = mp_mul_2(&b2, &tmp2)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_add(&tmp2, &b1, &tmp2)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_mul_2(&tmp2, &tmp2)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_add(&tmp2, &b0, &tmp2)) != MP_OKAY) { - goto LBL_ERR; - } - - if ((res = mp_mul(&tmp1, &tmp2, &w3)) != MP_OKAY) { - goto LBL_ERR; - } - - - /* w2 = (a2 + a1 + a0)(b2 + b1 + b0) */ - if ((res = mp_add(&a2, &a1, &tmp1)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_add(&b2, &b1, &tmp2)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_add(&tmp2, &b0, &tmp2)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_mul(&tmp1, &tmp2, &w2)) != MP_OKAY) { - goto LBL_ERR; - } - - /* now solve the matrix - - 0 0 0 0 1 - 1 2 4 8 16 - 1 1 1 1 1 - 16 8 4 2 1 - 1 0 0 0 0 - - using 12 subtractions, 4 shifts, - 2 small divisions and 1 small multiplication - */ - - /* r1 - r4 */ - if ((res = mp_sub(&w1, &w4, &w1)) != MP_OKAY) { - goto LBL_ERR; - } - /* r3 - r0 */ - if ((res = mp_sub(&w3, &w0, &w3)) != MP_OKAY) { - goto LBL_ERR; - } - /* r1/2 */ - if ((res = mp_div_2(&w1, &w1)) != MP_OKAY) { - goto LBL_ERR; - } - /* r3/2 */ - if ((res = mp_div_2(&w3, &w3)) != MP_OKAY) { - goto LBL_ERR; - } - /* r2 - r0 - r4 */ - if ((res = mp_sub(&w2, &w0, &w2)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_sub(&w2, &w4, &w2)) != MP_OKAY) { - goto LBL_ERR; - } - /* r1 - r2 */ - if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) { - goto LBL_ERR; - } - /* r3 - r2 */ - if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) { - goto LBL_ERR; - } - /* r1 - 8r0 */ - if ((res = mp_mul_2d(&w0, 3, &tmp1)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_sub(&w1, &tmp1, &w1)) != MP_OKAY) { - goto LBL_ERR; - } - /* r3 - 8r4 */ - if ((res = mp_mul_2d(&w4, 3, &tmp1)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_sub(&w3, &tmp1, &w3)) != MP_OKAY) { - goto LBL_ERR; - } - /* 3r2 - r1 - r3 */ - if ((res = mp_mul_d(&w2, 3uL, &w2)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_sub(&w2, &w1, &w2)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_sub(&w2, &w3, &w2)) != MP_OKAY) { - goto LBL_ERR; - } - /* r1 - r2 */ - if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) { - goto LBL_ERR; - } - /* r3 - r2 */ - if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) { - goto LBL_ERR; - } - /* r1/3 */ - if ((res = mp_div_3(&w1, &w1, NULL)) != MP_OKAY) { - goto LBL_ERR; - } - /* r3/3 */ - if ((res = mp_div_3(&w3, &w3, NULL)) != MP_OKAY) { - goto LBL_ERR; - } - - /* at this point shift W[n] by B*n */ - if ((res = mp_lshd(&w1, 1*B)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_lshd(&w2, 2*B)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_lshd(&w3, 3*B)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_lshd(&w4, 4*B)) != MP_OKAY) { - goto LBL_ERR; - } - - if ((res = mp_add(&w0, &w1, c)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_add(&w2, &w3, &tmp1)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_add(&w4, &tmp1, &tmp1)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_add(&tmp1, c, c)) != MP_OKAY) { - goto LBL_ERR; - } - -LBL_ERR: - mp_clear_multi(&w0, &w1, &w2, &w3, &w4, - &a0, &a1, &a2, &b0, &b1, - &b2, &tmp1, &tmp2, NULL); - return res; -} - -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ DELETED libtommath/bn_mp_toom_sqr.c Index: libtommath/bn_mp_toom_sqr.c ================================================================== --- libtommath/bn_mp_toom_sqr.c +++ /dev/null @@ -1,224 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_MP_TOOM_SQR_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* squaring using Toom-Cook 3-way algorithm */ -int mp_toom_sqr(const mp_int *a, mp_int *b) -{ - mp_int w0, w1, w2, w3, w4, tmp1, a0, a1, a2; - int res, B; - - /* init temps */ - if ((res = mp_init_multi(&w0, &w1, &w2, &w3, &w4, &a0, &a1, &a2, &tmp1, NULL)) != MP_OKAY) { - return res; - } - - /* B */ - B = a->used / 3; - - /* a = a2 * B**2 + a1 * B + a0 */ - if ((res = mp_mod_2d(a, DIGIT_BIT * B, &a0)) != MP_OKAY) { - goto LBL_ERR; - } - - if ((res = mp_copy(a, &a1)) != MP_OKAY) { - goto LBL_ERR; - } - mp_rshd(&a1, B); - if ((res = mp_mod_2d(&a1, DIGIT_BIT * B, &a1)) != MP_OKAY) { - goto LBL_ERR; - } - - if ((res = mp_copy(a, &a2)) != MP_OKAY) { - goto LBL_ERR; - } - mp_rshd(&a2, B*2); - - /* w0 = a0*a0 */ - if ((res = mp_sqr(&a0, &w0)) != MP_OKAY) { - goto LBL_ERR; - } - - /* w4 = a2 * a2 */ - if ((res = mp_sqr(&a2, &w4)) != MP_OKAY) { - goto LBL_ERR; - } - - /* w1 = (a2 + 2(a1 + 2a0))**2 */ - if ((res = mp_mul_2(&a0, &tmp1)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_add(&tmp1, &a2, &tmp1)) != MP_OKAY) { - goto LBL_ERR; - } - - if ((res = mp_sqr(&tmp1, &w1)) != MP_OKAY) { - goto LBL_ERR; - } - - /* w3 = (a0 + 2(a1 + 2a2))**2 */ - if ((res = mp_mul_2(&a2, &tmp1)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) { - goto LBL_ERR; - } - - if ((res = mp_sqr(&tmp1, &w3)) != MP_OKAY) { - goto LBL_ERR; - } - - - /* w2 = (a2 + a1 + a0)**2 */ - if ((res = mp_add(&a2, &a1, &tmp1)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_sqr(&tmp1, &w2)) != MP_OKAY) { - goto LBL_ERR; - } - - /* now solve the matrix - - 0 0 0 0 1 - 1 2 4 8 16 - 1 1 1 1 1 - 16 8 4 2 1 - 1 0 0 0 0 - - using 12 subtractions, 4 shifts, 2 small divisions and 1 small multiplication. - */ - - /* r1 - r4 */ - if ((res = mp_sub(&w1, &w4, &w1)) != MP_OKAY) { - goto LBL_ERR; - } - /* r3 - r0 */ - if ((res = mp_sub(&w3, &w0, &w3)) != MP_OKAY) { - goto LBL_ERR; - } - /* r1/2 */ - if ((res = mp_div_2(&w1, &w1)) != MP_OKAY) { - goto LBL_ERR; - } - /* r3/2 */ - if ((res = mp_div_2(&w3, &w3)) != MP_OKAY) { - goto LBL_ERR; - } - /* r2 - r0 - r4 */ - if ((res = mp_sub(&w2, &w0, &w2)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_sub(&w2, &w4, &w2)) != MP_OKAY) { - goto LBL_ERR; - } - /* r1 - r2 */ - if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) { - goto LBL_ERR; - } - /* r3 - r2 */ - if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) { - goto LBL_ERR; - } - /* r1 - 8r0 */ - if ((res = mp_mul_2d(&w0, 3, &tmp1)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_sub(&w1, &tmp1, &w1)) != MP_OKAY) { - goto LBL_ERR; - } - /* r3 - 8r4 */ - if ((res = mp_mul_2d(&w4, 3, &tmp1)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_sub(&w3, &tmp1, &w3)) != MP_OKAY) { - goto LBL_ERR; - } - /* 3r2 - r1 - r3 */ - if ((res = mp_mul_d(&w2, 3uL, &w2)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_sub(&w2, &w1, &w2)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_sub(&w2, &w3, &w2)) != MP_OKAY) { - goto LBL_ERR; - } - /* r1 - r2 */ - if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) { - goto LBL_ERR; - } - /* r3 - r2 */ - if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) { - goto LBL_ERR; - } - /* r1/3 */ - if ((res = mp_div_3(&w1, &w1, NULL)) != MP_OKAY) { - goto LBL_ERR; - } - /* r3/3 */ - if ((res = mp_div_3(&w3, &w3, NULL)) != MP_OKAY) { - goto LBL_ERR; - } - - /* at this point shift W[n] by B*n */ - if ((res = mp_lshd(&w1, 1*B)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_lshd(&w2, 2*B)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_lshd(&w3, 3*B)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_lshd(&w4, 4*B)) != MP_OKAY) { - goto LBL_ERR; - } - - if ((res = mp_add(&w0, &w1, b)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_add(&w2, &w3, &tmp1)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_add(&w4, &tmp1, &tmp1)) != MP_OKAY) { - goto LBL_ERR; - } - if ((res = mp_add(&tmp1, b, b)) != MP_OKAY) { - goto LBL_ERR; - } - -LBL_ERR: - mp_clear_multi(&w0, &w1, &w2, &w3, &w4, &a0, &a1, &a2, &tmp1, NULL); - return res; -} - -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ DELETED libtommath/bn_mp_toradix.c Index: libtommath/bn_mp_toradix.c ================================================================== --- libtommath/bn_mp_toradix.c +++ /dev/null @@ -1,72 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_MP_TORADIX_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* stores a bignum as a ASCII string in a given radix (2..64) */ -int mp_toradix(const mp_int *a, char *str, int radix) -{ - int res, digs; - mp_int t; - mp_digit d; - char *_s = str; - - /* check range of the radix */ - if ((radix < 2) || (radix > 64)) { - return MP_VAL; - } - - /* quick out if its zero */ - if (mp_iszero(a) == MP_YES) { - *str++ = '0'; - *str = '\0'; - return MP_OKAY; - } - - if ((res = mp_init_copy(&t, a)) != MP_OKAY) { - return res; - } - - /* if it is negative output a - */ - if (t.sign == MP_NEG) { - ++_s; - *str++ = '-'; - t.sign = MP_ZPOS; - } - - digs = 0; - while (mp_iszero(&t) == MP_NO) { - if ((res = mp_div_d(&t, (mp_digit)radix, &t, &d)) != MP_OKAY) { - mp_clear(&t); - return res; - } - *str++ = mp_s_rmap[d]; - ++digs; - } - - /* reverse the digits of the string. In this case _s points - * to the first digit [exluding the sign] of the number] - */ - bn_reverse((unsigned char *)_s, digs); - - /* append a NULL so the string is properly terminated */ - *str = '\0'; - - mp_clear(&t); - return MP_OKAY; -} - -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ DELETED libtommath/bn_mp_toradix_n.c Index: libtommath/bn_mp_toradix_n.c ================================================================== --- libtommath/bn_mp_toradix_n.c +++ /dev/null @@ -1,85 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_MP_TORADIX_N_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* stores a bignum as a ASCII string in a given radix (2..64) - * - * Stores upto maxlen-1 chars and always a NULL byte - */ -int mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen) -{ - int res, digs; - mp_int t; - mp_digit d; - char *_s = str; - - /* check range of the maxlen, radix */ - if ((maxlen < 2) || (radix < 2) || (radix > 64)) { - return MP_VAL; - } - - /* quick out if its zero */ - if (mp_iszero(a) == MP_YES) { - *str++ = '0'; - *str = '\0'; - return MP_OKAY; - } - - if ((res = mp_init_copy(&t, a)) != MP_OKAY) { - return res; - } - - /* if it is negative output a - */ - if (t.sign == MP_NEG) { - /* we have to reverse our digits later... but not the - sign!! */ - ++_s; - - /* store the flag and mark the number as positive */ - *str++ = '-'; - t.sign = MP_ZPOS; - - /* subtract a char */ - --maxlen; - } - - digs = 0; - while (mp_iszero(&t) == MP_NO) { - if (--maxlen < 1) { - /* no more room */ - break; - } - if ((res = mp_div_d(&t, (mp_digit)radix, &t, &d)) != MP_OKAY) { - mp_clear(&t); - return res; - } - *str++ = mp_s_rmap[d]; - ++digs; - } - - /* reverse the digits of the string. In this case _s points - * to the first digit [exluding the sign] of the number - */ - bn_reverse((unsigned char *)_s, digs); - - /* append a NULL so the string is properly terminated */ - *str = '\0'; - - mp_clear(&t); - return MP_OKAY; -} - -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ ADDED libtommath/bn_mp_ubin_size.c Index: libtommath/bn_mp_ubin_size.c ================================================================== --- /dev/null +++ libtommath/bn_mp_ubin_size.c @@ -0,0 +1,12 @@ +#include "tommath_private.h" +#ifdef BN_MP_UBIN_SIZE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +/* get the size for an unsigned equivalent */ +size_t mp_ubin_size(const mp_int *a) +{ + size_t size = (size_t)mp_count_bits(a); + return (size / 8u) + (((size & 7u) != 0u) ? 1u : 0u); +} +#endif ADDED libtommath/bn_mp_unpack.c Index: libtommath/bn_mp_unpack.c ================================================================== --- /dev/null +++ libtommath/bn_mp_unpack.c @@ -0,0 +1,49 @@ +#include "tommath_private.h" +#ifdef BN_MP_UNPACK_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +/* based on gmp's mpz_import. + * see http://gmplib.org/manual/Integer-Import-and-Export.html + */ +mp_err mp_unpack(mp_int *rop, size_t count, mp_order order, size_t size, + mp_endian endian, size_t nails, const void *op) +{ + mp_err err; + size_t odd_nails, nail_bytes, i, j; + unsigned char odd_nail_mask; + + mp_zero(rop); + + if (endian == MP_NATIVE_ENDIAN) { + MP_GET_ENDIANNESS(endian); + } + + odd_nails = (nails % 8u); + odd_nail_mask = 0xff; + for (i = 0; i < odd_nails; ++i) { + odd_nail_mask ^= (unsigned char)(1u << (7u - i)); + } + nail_bytes = nails / 8u; + + for (i = 0; i < count; ++i) { + for (j = 0; j < (size - nail_bytes); ++j) { + unsigned char byte = *((const unsigned char *)op + + (((order == MP_MSB_FIRST) ? i : ((count - 1u) - i)) * size) + + ((endian == MP_BIG_ENDIAN) ? (j + nail_bytes) : (((size - 1u) - j) - nail_bytes))); + + if ((err = mp_mul_2d(rop, (j == 0u) ? (int)(8u - odd_nails) : 8, rop)) != MP_OKAY) { + return err; + } + + rop->dp[0] |= (j == 0u) ? (mp_digit)(byte & odd_nail_mask) : (mp_digit)byte; + rop->used += 1; + } + } + + mp_clamp(rop); + + return MP_OKAY; +} + +#endif DELETED libtommath/bn_mp_unsigned_bin_size.c Index: libtommath/bn_mp_unsigned_bin_size.c ================================================================== --- libtommath/bn_mp_unsigned_bin_size.c +++ /dev/null @@ -1,25 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_MP_UNSIGNED_BIN_SIZE_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* get the size for an unsigned equivalent */ -int mp_unsigned_bin_size(const mp_int *a) -{ - int size = mp_count_bits(a); - return (size / 8) + ((((unsigned)size & 7u) != 0u) ? 1 : 0); -} -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_mp_xor.c ================================================================== --- libtommath/bn_mp_xor.c +++ libtommath/bn_mp_xor.c @@ -4,11 +4,11 @@ /* SPDX-License-Identifier: Unlicense */ /* two complement xor */ mp_err mp_xor(const mp_int *a, const mp_int *b, mp_int *c) { - int used = MAX(a->used, b->used) + 1, i; + int used = MP_MAX(a->used, b->used) + 1, i; mp_err err; mp_digit ac = 1, bc = 1, cc = 1; mp_sign csign = (a->sign != b->sign) ? MP_NEG : MP_ZPOS; if (c->alloc < used) { Index: libtommath/bn_mp_zero.c ================================================================== --- libtommath/bn_mp_zero.c +++ libtommath/bn_mp_zero.c @@ -1,33 +1,13 @@ #include "tommath_private.h" #ifdef BN_MP_ZERO_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* set to zero */ void mp_zero(mp_int *a) { - int n; - mp_digit *tmp; - a->sign = MP_ZPOS; a->used = 0; - - tmp = a->dp; - for (n = 0; n < a->alloc; n++) { - *tmp++ = 0; - } + MP_ZERO_DIGITS(a->dp, a->alloc); } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_prime_tab.c ================================================================== --- libtommath/bn_prime_tab.c +++ libtommath/bn_prime_tab.c @@ -1,18 +1,9 @@ #include "tommath_private.h" #ifdef BN_PRIME_TAB_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ const mp_digit ltm_prime_tab[] = { 0x0002, 0x0003, 0x0005, 0x0007, 0x000B, 0x000D, 0x0011, 0x0013, 0x0017, 0x001D, 0x001F, 0x0025, 0x0029, 0x002B, 0x002F, 0x0035, 0x003B, 0x003D, 0x0043, 0x0047, 0x0049, 0x004F, 0x0053, 0x0059, @@ -50,10 +41,21 @@ 0x05BF, 0x05C9, 0x05CB, 0x05CF, 0x05D1, 0x05D5, 0x05DB, 0x05E7, 0x05F3, 0x05FB, 0x0607, 0x060D, 0x0611, 0x0617, 0x061F, 0x0623, 0x062B, 0x062F, 0x063D, 0x0641, 0x0647, 0x0649, 0x064D, 0x0653 #endif }; + +#if defined(__GNUC__) && __GNUC__ >= 4 +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Wdeprecated-declarations" +const mp_digit *s_mp_prime_tab = ltm_prime_tab; +#pragma GCC diagnostic pop +#elif defined(_MSC_VER) && _MSC_VER >= 1500 +#pragma warning(push) +#pragma warning(disable: 4996) +const mp_digit *s_mp_prime_tab = ltm_prime_tab; +#pragma warning(pop) +#else +const mp_digit *s_mp_prime_tab = ltm_prime_tab; #endif -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ +#endif DELETED libtommath/bn_reverse.c Index: libtommath/bn_reverse.c ================================================================== --- libtommath/bn_reverse.c +++ /dev/null @@ -1,35 +0,0 @@ -#include "tommath_private.h" -#ifdef BN_REVERSE_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* reverse an array, used for radix code */ -void bn_reverse(unsigned char *s, int len) -{ - int ix, iy; - unsigned char t; - - ix = 0; - iy = len - 1; - while (ix < iy) { - t = s[ix]; - s[ix] = s[iy]; - s[iy] = t; - ++ix; - --iy; - } -} -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/bn_s_mp_add.c ================================================================== --- libtommath/bn_s_mp_add.c +++ libtommath/bn_s_mp_add.c @@ -1,24 +1,16 @@ #include "tommath_private.h" #ifdef BN_S_MP_ADD_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* low level addition, based on HAC pp.594, Algorithm 14.7 */ -int s_mp_add(const mp_int *a, const mp_int *b, mp_int *c) +mp_err s_mp_add(const mp_int *a, const mp_int *b, mp_int *c) { const mp_int *x; - int olduse, res, min, max; + mp_err err; + int olduse, min, max; /* find sizes, we let |a| <= |b| which means we have to sort * them. "x" will point to the input with the most digits */ if (a->used > b->used) { @@ -31,12 +23,12 @@ x = b; } /* init result */ if (c->alloc < (max + 1)) { - if ((res = mp_grow(c, max + 1)) != MP_OKAY) { - return res; + if ((err = mp_grow(c, max + 1)) != MP_OKAY) { + return err; } } /* get old used digit count and set new one */ olduse = c->used; @@ -62,11 +54,11 @@ for (i = 0; i < min; i++) { /* Compute the sum at one digit, T[i] = A[i] + B[i] + U */ *tmpc = *tmpa++ + *tmpb++ + u; /* U = carry bit of T[i] */ - u = *tmpc >> (mp_digit)DIGIT_BIT; + u = *tmpc >> (mp_digit)MP_DIGIT_BIT; /* take away carry bit from T[i] */ *tmpc++ &= MP_MASK; } @@ -77,11 +69,11 @@ for (; i < max; i++) { /* T[i] = X[i] + U */ *tmpc = x->dp[i] + u; /* U = carry bit of T[i] */ - u = *tmpc >> (mp_digit)DIGIT_BIT; + u = *tmpc >> (mp_digit)MP_DIGIT_BIT; /* take away carry bit from T[i] */ *tmpc++ &= MP_MASK; } } @@ -88,18 +80,12 @@ /* add carry */ *tmpc++ = u; /* clear digits above oldused */ - for (i = c->used; i < olduse; i++) { - *tmpc++ = 0; - } + MP_ZERO_DIGITS(tmpc, olduse - c->used); } mp_clamp(c); return MP_OKAY; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ ADDED libtommath/bn_s_mp_balance_mul.c Index: libtommath/bn_s_mp_balance_mul.c ================================================================== --- /dev/null +++ libtommath/bn_s_mp_balance_mul.c @@ -0,0 +1,81 @@ +#include "tommath_private.h" +#ifdef BN_S_MP_BALANCE_MUL_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +/* single-digit multiplication with the smaller number as the single-digit */ +mp_err s_mp_balance_mul(const mp_int *a, const mp_int *b, mp_int *c) +{ + int count, len_a, len_b, nblocks, i, j, bsize; + mp_int a0, tmp, A, B, r; + mp_err err; + + len_a = a->used; + len_b = b->used; + + nblocks = MP_MAX(a->used, b->used) / MP_MIN(a->used, b->used); + bsize = MP_MIN(a->used, b->used) ; + + if ((err = mp_init_size(&a0, bsize + 2)) != MP_OKAY) { + return err; + } + if ((err = mp_init_multi(&tmp, &r, NULL)) != MP_OKAY) { + mp_clear(&a0); + return err; + } + + /* Make sure that A is the larger one*/ + if (len_a < len_b) { + B = *a; + A = *b; + } else { + A = *a; + B = *b; + } + + for (i = 0, j=0; i < nblocks; i++) { + /* Cut a slice off of a */ + a0.used = 0; + for (count = 0; count < bsize; count++) { + a0.dp[count] = A.dp[ j++ ]; + a0.used++; + } + mp_clamp(&a0); + /* Multiply with b */ + if ((err = mp_mul(&a0, &B, &tmp)) != MP_OKAY) { + goto LBL_ERR; + } + /* Shift tmp to the correct position */ + if ((err = mp_lshd(&tmp, bsize * i)) != MP_OKAY) { + goto LBL_ERR; + } + /* Add to output. No carry needed */ + if ((err = mp_add(&r, &tmp, &r)) != MP_OKAY) { + goto LBL_ERR; + } + } + /* The left-overs; there are always left-overs */ + if (j < A.used) { + a0.used = 0; + for (count = 0; j < A.used; count++) { + a0.dp[count] = A.dp[ j++ ]; + a0.used++; + } + mp_clamp(&a0); + if ((err = mp_mul(&a0, &B, &tmp)) != MP_OKAY) { + goto LBL_ERR; + } + if ((err = mp_lshd(&tmp, bsize * i)) != MP_OKAY) { + goto LBL_ERR; + } + if ((err = mp_add(&r, &tmp, &r)) != MP_OKAY) { + goto LBL_ERR; + } + } + + mp_exch(&r,c); +LBL_ERR: + mp_clear_multi(&a0, &tmp, &r,NULL); + return err; +} +#endif Index: libtommath/bn_s_mp_exptmod.c ================================================================== --- libtommath/bn_s_mp_exptmod.c +++ libtommath/bn_s_mp_exptmod.c @@ -1,31 +1,25 @@ #include "tommath_private.h" #ifdef BN_S_MP_EXPTMOD_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ #ifdef MP_LOW_MEM # define TAB_SIZE 32 +# define MAX_WINSIZE 5 #else # define TAB_SIZE 256 +# define MAX_WINSIZE 0 #endif -int s_mp_exptmod(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y, int redmode) +mp_err s_mp_exptmod(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y, int redmode) { mp_int M[TAB_SIZE], res, mu; mp_digit buf; - int err, bitbuf, bitcpy, bitcnt, mode, digidx, x, y, winsize; - int (*redux)(mp_int *x, const mp_int *m, const mp_int *mu); + mp_err err; + int bitbuf, bitcpy, bitcnt, mode, digidx, x, y, winsize; + mp_err(*redux)(mp_int *x, const mp_int *m, const mp_int *mu); /* find window size */ x = mp_count_bits(X); if (x <= 7) { winsize = 2; @@ -41,15 +35,11 @@ winsize = 7; } else { winsize = 8; } -#ifdef MP_LOW_MEM - if (winsize > 5) { - winsize = 5; - } -#endif + winsize = MAX_WINSIZE ? MP_MIN(MAX_WINSIZE, winsize) : winsize; /* init M array */ /* init first cell */ if ((err = mp_init(&M[1])) != MP_OKAY) { return err; @@ -65,23 +55,17 @@ return err; } } /* create mu, used for Barrett reduction */ - if ((err = mp_init(&mu)) != MP_OKAY) { - goto LBL_M; - } + if ((err = mp_init(&mu)) != MP_OKAY) goto LBL_M; if (redmode == 0) { - if ((err = mp_reduce_setup(&mu, P)) != MP_OKAY) { - goto LBL_MU; - } + if ((err = mp_reduce_setup(&mu, P)) != MP_OKAY) goto LBL_MU; redux = mp_reduce; } else { - if ((err = mp_reduce_2k_setup_l(P, &mu)) != MP_OKAY) { - goto LBL_MU; - } + if ((err = mp_reduce_2k_setup_l(P, &mu)) != MP_OKAY) goto LBL_MU; redux = mp_reduce_2k_l; } /* create M table * @@ -89,50 +73,36 @@ * e.g. M[x] = G**x mod P * * The first half of the table is not * computed though accept for M[0] and M[1] */ - if ((err = mp_mod(G, P, &M[1])) != MP_OKAY) { - goto LBL_MU; - } + if ((err = mp_mod(G, P, &M[1])) != MP_OKAY) goto LBL_MU; /* compute the value at M[1<<(winsize-1)] by squaring * M[1] (winsize-1) times */ - if ((err = mp_copy(&M[1], &M[(size_t)1 << (winsize - 1)])) != MP_OKAY) { - goto LBL_MU; - } + if ((err = mp_copy(&M[1], &M[(size_t)1 << (winsize - 1)])) != MP_OKAY) goto LBL_MU; for (x = 0; x < (winsize - 1); x++) { /* square it */ if ((err = mp_sqr(&M[(size_t)1 << (winsize - 1)], - &M[(size_t)1 << (winsize - 1)])) != MP_OKAY) { - goto LBL_MU; - } + &M[(size_t)1 << (winsize - 1)])) != MP_OKAY) goto LBL_MU; /* reduce modulo P */ - if ((err = redux(&M[(size_t)1 << (winsize - 1)], P, &mu)) != MP_OKAY) { - goto LBL_MU; - } + if ((err = redux(&M[(size_t)1 << (winsize - 1)], P, &mu)) != MP_OKAY) goto LBL_MU; } /* create upper table, that is M[x] = M[x-1] * M[1] (mod P) * for x = (2**(winsize - 1) + 1) to (2**winsize - 1) */ for (x = (1 << (winsize - 1)) + 1; x < (1 << winsize); x++) { - if ((err = mp_mul(&M[x - 1], &M[1], &M[x])) != MP_OKAY) { - goto LBL_MU; - } - if ((err = redux(&M[x], P, &mu)) != MP_OKAY) { - goto LBL_MU; - } + if ((err = mp_mul(&M[x - 1], &M[1], &M[x])) != MP_OKAY) goto LBL_MU; + if ((err = redux(&M[x], P, &mu)) != MP_OKAY) goto LBL_MU; } /* setup result */ - if ((err = mp_init(&res)) != MP_OKAY) { - goto LBL_MU; - } + if ((err = mp_init(&res)) != MP_OKAY) goto LBL_MU; mp_set(&res, 1uL); /* set initial mode and bit cnt */ mode = 0; bitcnt = 1; @@ -148,15 +118,15 @@ if (digidx == -1) { break; } /* read next digit and reset the bitcnt */ buf = X->dp[digidx--]; - bitcnt = (int)DIGIT_BIT; + bitcnt = (int)MP_DIGIT_BIT; } /* grab the next msb from the exponent */ - y = (buf >> (mp_digit)(DIGIT_BIT - 1)) & 1; + y = (buf >> (mp_digit)(MP_DIGIT_BIT - 1)) & 1uL; buf <<= (mp_digit)1; /* if the bit is zero and mode == 0 then we ignore it * These represent the leading zero bits before the first 1 bit * in the exponent. Technically this opt is not required but it @@ -166,16 +136,12 @@ continue; } /* if the bit is zero and mode == 1 then we square */ if ((mode == 1) && (y == 0)) { - if ((err = mp_sqr(&res, &res)) != MP_OKAY) { - goto LBL_RES; - } - if ((err = redux(&res, P, &mu)) != MP_OKAY) { - goto LBL_RES; - } + if ((err = mp_sqr(&res, &res)) != MP_OKAY) goto LBL_RES; + if ((err = redux(&res, P, &mu)) != MP_OKAY) goto LBL_RES; continue; } /* else we add it to the window */ bitbuf |= (y << (winsize - ++bitcpy)); @@ -183,25 +149,17 @@ if (bitcpy == winsize) { /* ok window is filled so square as required and multiply */ /* square first */ for (x = 0; x < winsize; x++) { - if ((err = mp_sqr(&res, &res)) != MP_OKAY) { - goto LBL_RES; - } - if ((err = redux(&res, P, &mu)) != MP_OKAY) { - goto LBL_RES; - } + if ((err = mp_sqr(&res, &res)) != MP_OKAY) goto LBL_RES; + if ((err = redux(&res, P, &mu)) != MP_OKAY) goto LBL_RES; } /* then multiply */ - if ((err = mp_mul(&res, &M[bitbuf], &res)) != MP_OKAY) { - goto LBL_RES; - } - if ((err = redux(&res, P, &mu)) != MP_OKAY) { - goto LBL_RES; - } + if ((err = mp_mul(&res, &M[bitbuf], &res)) != MP_OKAY) goto LBL_RES; + if ((err = redux(&res, P, &mu)) != MP_OKAY) goto LBL_RES; /* empty window and reset */ bitcpy = 0; bitbuf = 0; mode = 1; @@ -210,26 +168,18 @@ /* if bits remain then square/multiply */ if ((mode == 2) && (bitcpy > 0)) { /* square then multiply if the bit is set */ for (x = 0; x < bitcpy; x++) { - if ((err = mp_sqr(&res, &res)) != MP_OKAY) { - goto LBL_RES; - } - if ((err = redux(&res, P, &mu)) != MP_OKAY) { - goto LBL_RES; - } + if ((err = mp_sqr(&res, &res)) != MP_OKAY) goto LBL_RES; + if ((err = redux(&res, P, &mu)) != MP_OKAY) goto LBL_RES; bitbuf <<= 1; if ((bitbuf & (1 << winsize)) != 0) { /* then multiply */ - if ((err = mp_mul(&res, &M[1], &res)) != MP_OKAY) { - goto LBL_RES; - } - if ((err = redux(&res, P, &mu)) != MP_OKAY) { - goto LBL_RES; - } + if ((err = mp_mul(&res, &M[1], &res)) != MP_OKAY) goto LBL_RES; + if ((err = redux(&res, P, &mu)) != MP_OKAY) goto LBL_RES; } } } mp_exch(&res, Y); @@ -244,9 +194,5 @@ mp_clear(&M[x]); } return err; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ ADDED libtommath/bn_s_mp_exptmod_fast.c Index: libtommath/bn_s_mp_exptmod_fast.c ================================================================== --- /dev/null +++ libtommath/bn_s_mp_exptmod_fast.c @@ -0,0 +1,254 @@ +#include "tommath_private.h" +#ifdef BN_S_MP_EXPTMOD_FAST_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +/* computes Y == G**X mod P, HAC pp.616, Algorithm 14.85 + * + * Uses a left-to-right k-ary sliding window to compute the modular exponentiation. + * The value of k changes based on the size of the exponent. + * + * Uses Montgomery or Diminished Radix reduction [whichever appropriate] + */ + +#ifdef MP_LOW_MEM +# define TAB_SIZE 32 +# define MAX_WINSIZE 5 +#else +# define TAB_SIZE 256 +# define MAX_WINSIZE 0 +#endif + +mp_err s_mp_exptmod_fast(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y, int redmode) +{ + mp_int M[TAB_SIZE], res; + mp_digit buf, mp; + int bitbuf, bitcpy, bitcnt, mode, digidx, x, y, winsize; + mp_err err; + + /* use a pointer to the reduction algorithm. This allows us to use + * one of many reduction algorithms without modding the guts of + * the code with if statements everywhere. + */ + mp_err(*redux)(mp_int *x, const mp_int *n, mp_digit rho); + + /* find window size */ + x = mp_count_bits(X); + if (x <= 7) { + winsize = 2; + } else if (x <= 36) { + winsize = 3; + } else if (x <= 140) { + winsize = 4; + } else if (x <= 450) { + winsize = 5; + } else if (x <= 1303) { + winsize = 6; + } else if (x <= 3529) { + winsize = 7; + } else { + winsize = 8; + } + + winsize = MAX_WINSIZE ? MP_MIN(MAX_WINSIZE, winsize) : winsize; + + /* init M array */ + /* init first cell */ + if ((err = mp_init_size(&M[1], P->alloc)) != MP_OKAY) { + return err; + } + + /* now init the second half of the array */ + for (x = 1<<(winsize-1); x < (1 << winsize); x++) { + if ((err = mp_init_size(&M[x], P->alloc)) != MP_OKAY) { + for (y = 1<<(winsize-1); y < x; y++) { + mp_clear(&M[y]); + } + mp_clear(&M[1]); + return err; + } + } + + /* determine and setup reduction code */ + if (redmode == 0) { + if (MP_HAS(MP_MONTGOMERY_SETUP)) { + /* now setup montgomery */ + if ((err = mp_montgomery_setup(P, &mp)) != MP_OKAY) goto LBL_M; + } else { + err = MP_VAL; + goto LBL_M; + } + + /* automatically pick the comba one if available (saves quite a few calls/ifs) */ + if (MP_HAS(S_MP_MONTGOMERY_REDUCE_FAST) && + (((P->used * 2) + 1) < MP_WARRAY) && + (P->used < MP_MAXFAST)) { + redux = s_mp_montgomery_reduce_fast; + } else if (MP_HAS(MP_MONTGOMERY_REDUCE)) { + /* use slower baseline Montgomery method */ + redux = mp_montgomery_reduce; + } else { + err = MP_VAL; + goto LBL_M; + } + } else if (redmode == 1) { + if (MP_HAS(MP_DR_SETUP) && MP_HAS(MP_DR_REDUCE)) { + /* setup DR reduction for moduli of the form B**k - b */ + mp_dr_setup(P, &mp); + redux = mp_dr_reduce; + } else { + err = MP_VAL; + goto LBL_M; + } + } else if (MP_HAS(MP_REDUCE_2K_SETUP) && MP_HAS(MP_REDUCE_2K)) { + /* setup DR reduction for moduli of the form 2**k - b */ + if ((err = mp_reduce_2k_setup(P, &mp)) != MP_OKAY) goto LBL_M; + redux = mp_reduce_2k; + } else { + err = MP_VAL; + goto LBL_M; + } + + /* setup result */ + if ((err = mp_init_size(&res, P->alloc)) != MP_OKAY) goto LBL_M; + + /* create M table + * + + * + * The first half of the table is not computed though accept for M[0] and M[1] + */ + + if (redmode == 0) { + if (MP_HAS(MP_MONTGOMERY_CALC_NORMALIZATION)) { + /* now we need R mod m */ + if ((err = mp_montgomery_calc_normalization(&res, P)) != MP_OKAY) goto LBL_RES; + + /* now set M[1] to G * R mod m */ + if ((err = mp_mulmod(G, &res, P, &M[1])) != MP_OKAY) goto LBL_RES; + } else { + err = MP_VAL; + goto LBL_RES; + } + } else { + mp_set(&res, 1uL); + if ((err = mp_mod(G, P, &M[1])) != MP_OKAY) goto LBL_RES; + } + + /* compute the value at M[1<<(winsize-1)] by squaring M[1] (winsize-1) times */ + if ((err = mp_copy(&M[1], &M[(size_t)1 << (winsize - 1)])) != MP_OKAY) goto LBL_RES; + + for (x = 0; x < (winsize - 1); x++) { + if ((err = mp_sqr(&M[(size_t)1 << (winsize - 1)], &M[(size_t)1 << (winsize - 1)])) != MP_OKAY) goto LBL_RES; + if ((err = redux(&M[(size_t)1 << (winsize - 1)], P, mp)) != MP_OKAY) goto LBL_RES; + } + + /* create upper table */ + for (x = (1 << (winsize - 1)) + 1; x < (1 << winsize); x++) { + if ((err = mp_mul(&M[x - 1], &M[1], &M[x])) != MP_OKAY) goto LBL_RES; + if ((err = redux(&M[x], P, mp)) != MP_OKAY) goto LBL_RES; + } + + /* set initial mode and bit cnt */ + mode = 0; + bitcnt = 1; + buf = 0; + digidx = X->used - 1; + bitcpy = 0; + bitbuf = 0; + + for (;;) { + /* grab next digit as required */ + if (--bitcnt == 0) { + /* if digidx == -1 we are out of digits so break */ + if (digidx == -1) { + break; + } + /* read next digit and reset bitcnt */ + buf = X->dp[digidx--]; + bitcnt = (int)MP_DIGIT_BIT; + } + + /* grab the next msb from the exponent */ + y = (mp_digit)(buf >> (MP_DIGIT_BIT - 1)) & 1uL; + buf <<= (mp_digit)1; + + /* if the bit is zero and mode == 0 then we ignore it + * These represent the leading zero bits before the first 1 bit + * in the exponent. Technically this opt is not required but it + * does lower the # of trivial squaring/reductions used + */ + if ((mode == 0) && (y == 0)) { + continue; + } + + /* if the bit is zero and mode == 1 then we square */ + if ((mode == 1) && (y == 0)) { + if ((err = mp_sqr(&res, &res)) != MP_OKAY) goto LBL_RES; + if ((err = redux(&res, P, mp)) != MP_OKAY) goto LBL_RES; + continue; + } + + /* else we add it to the window */ + bitbuf |= (y << (winsize - ++bitcpy)); + mode = 2; + + if (bitcpy == winsize) { + /* ok window is filled so square as required and multiply */ + /* square first */ + for (x = 0; x < winsize; x++) { + if ((err = mp_sqr(&res, &res)) != MP_OKAY) goto LBL_RES; + if ((err = redux(&res, P, mp)) != MP_OKAY) goto LBL_RES; + } + + /* then multiply */ + if ((err = mp_mul(&res, &M[bitbuf], &res)) != MP_OKAY) goto LBL_RES; + if ((err = redux(&res, P, mp)) != MP_OKAY) goto LBL_RES; + + /* empty window and reset */ + bitcpy = 0; + bitbuf = 0; + mode = 1; + } + } + + /* if bits remain then square/multiply */ + if ((mode == 2) && (bitcpy > 0)) { + /* square then multiply if the bit is set */ + for (x = 0; x < bitcpy; x++) { + if ((err = mp_sqr(&res, &res)) != MP_OKAY) goto LBL_RES; + if ((err = redux(&res, P, mp)) != MP_OKAY) goto LBL_RES; + + /* get next bit of the window */ + bitbuf <<= 1; + if ((bitbuf & (1 << winsize)) != 0) { + /* then multiply */ + if ((err = mp_mul(&res, &M[1], &res)) != MP_OKAY) goto LBL_RES; + if ((err = redux(&res, P, mp)) != MP_OKAY) goto LBL_RES; + } + } + } + + if (redmode == 0) { + /* fixup result if Montgomery reduction is used + * recall that any value in a Montgomery system is + * actually multiplied by R mod n. So we have + * to reduce one more time to cancel out the factor + * of R. + */ + if ((err = redux(&res, P, mp)) != MP_OKAY) goto LBL_RES; + } + + /* swap res with Y */ + mp_exch(&res, Y); + err = MP_OKAY; +LBL_RES: + mp_clear(&res); +LBL_M: + mp_clear(&M[1]); + for (x = 1<<(winsize-1); x < (1 << winsize); x++) { + mp_clear(&M[x]); + } + return err; +} +#endif Index: libtommath/bn_s_mp_get_bit.c ================================================================== --- libtommath/bn_s_mp_get_bit.c +++ libtommath/bn_s_mp_get_bit.c @@ -3,19 +3,19 @@ /* LibTomMath, multiple-precision integer library -- Tom St Denis */ /* SPDX-License-Identifier: Unlicense */ /* Get bit at position b and return MP_YES if the bit is 1, MP_NO if it is 0 */ -mp_bool s_mp_get_bit(const mp_int *a, int b) +mp_bool s_mp_get_bit(const mp_int *a, unsigned int b) { mp_digit bit; - int limb = (int)((unsigned)b / MP_DIGIT_BIT); + int limb = (int)(b / MP_DIGIT_BIT); if (limb >= a->used) { return MP_NO; } - bit = (mp_digit)1 << ((unsigned)b % MP_DIGIT_BIT); + bit = (mp_digit)1 << (b % MP_DIGIT_BIT); return ((a->dp[limb] & bit) != 0u) ? MP_YES : MP_NO; } #endif ADDED libtommath/bn_s_mp_invmod_fast.c Index: libtommath/bn_s_mp_invmod_fast.c ================================================================== --- /dev/null +++ libtommath/bn_s_mp_invmod_fast.c @@ -0,0 +1,118 @@ +#include "tommath_private.h" +#ifdef BN_S_MP_INVMOD_FAST_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +/* computes the modular inverse via binary extended euclidean algorithm, + * that is c = 1/a mod b + * + * Based on slow invmod except this is optimized for the case where b is + * odd as per HAC Note 14.64 on pp. 610 + */ +mp_err s_mp_invmod_fast(const mp_int *a, const mp_int *b, mp_int *c) +{ + mp_int x, y, u, v, B, D; + mp_sign neg; + mp_err err; + + /* 2. [modified] b must be odd */ + if (MP_IS_EVEN(b)) { + return MP_VAL; + } + + /* init all our temps */ + if ((err = mp_init_multi(&x, &y, &u, &v, &B, &D, NULL)) != MP_OKAY) { + return err; + } + + /* x == modulus, y == value to invert */ + if ((err = mp_copy(b, &x)) != MP_OKAY) goto LBL_ERR; + + /* we need y = |a| */ + if ((err = mp_mod(a, b, &y)) != MP_OKAY) goto LBL_ERR; + + /* if one of x,y is zero return an error! */ + if (MP_IS_ZERO(&x) || MP_IS_ZERO(&y)) { + err = MP_VAL; + goto LBL_ERR; + } + + /* 3. u=x, v=y, A=1, B=0, C=0,D=1 */ + if ((err = mp_copy(&x, &u)) != MP_OKAY) goto LBL_ERR; + if ((err = mp_copy(&y, &v)) != MP_OKAY) goto LBL_ERR; + mp_set(&D, 1uL); + +top: + /* 4. while u is even do */ + while (MP_IS_EVEN(&u)) { + /* 4.1 u = u/2 */ + if ((err = mp_div_2(&u, &u)) != MP_OKAY) goto LBL_ERR; + + /* 4.2 if B is odd then */ + if (MP_IS_ODD(&B)) { + if ((err = mp_sub(&B, &x, &B)) != MP_OKAY) goto LBL_ERR; + } + /* B = B/2 */ + if ((err = mp_div_2(&B, &B)) != MP_OKAY) goto LBL_ERR; + } + + /* 5. while v is even do */ + while (MP_IS_EVEN(&v)) { + /* 5.1 v = v/2 */ + if ((err = mp_div_2(&v, &v)) != MP_OKAY) goto LBL_ERR; + + /* 5.2 if D is odd then */ + if (MP_IS_ODD(&D)) { + /* D = (D-x)/2 */ + if ((err = mp_sub(&D, &x, &D)) != MP_OKAY) goto LBL_ERR; + } + /* D = D/2 */ + if ((err = mp_div_2(&D, &D)) != MP_OKAY) goto LBL_ERR; + } + + /* 6. if u >= v then */ + if (mp_cmp(&u, &v) != MP_LT) { + /* u = u - v, B = B - D */ + if ((err = mp_sub(&u, &v, &u)) != MP_OKAY) goto LBL_ERR; + + if ((err = mp_sub(&B, &D, &B)) != MP_OKAY) goto LBL_ERR; + } else { + /* v - v - u, D = D - B */ + if ((err = mp_sub(&v, &u, &v)) != MP_OKAY) goto LBL_ERR; + + if ((err = mp_sub(&D, &B, &D)) != MP_OKAY) goto LBL_ERR; + } + + /* if not zero goto step 4 */ + if (!MP_IS_ZERO(&u)) { + goto top; + } + + /* now a = C, b = D, gcd == g*v */ + + /* if v != 1 then there is no inverse */ + if (mp_cmp_d(&v, 1uL) != MP_EQ) { + err = MP_VAL; + goto LBL_ERR; + } + + /* b is now the inverse */ + neg = a->sign; + while (D.sign == MP_NEG) { + if ((err = mp_add(&D, b, &D)) != MP_OKAY) goto LBL_ERR; + } + + /* too big */ + while (mp_cmp_mag(&D, b) != MP_LT) { + if ((err = mp_sub(&D, b, &D)) != MP_OKAY) goto LBL_ERR; + } + + mp_exch(&D, c); + c->sign = neg; + err = MP_OKAY; + +LBL_ERR: + mp_clear_multi(&x, &y, &u, &v, &B, &D, NULL); + return err; +} +#endif ADDED libtommath/bn_s_mp_invmod_slow.c Index: libtommath/bn_s_mp_invmod_slow.c ================================================================== --- /dev/null +++ libtommath/bn_s_mp_invmod_slow.c @@ -0,0 +1,119 @@ +#include "tommath_private.h" +#ifdef BN_S_MP_INVMOD_SLOW_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +/* hac 14.61, pp608 */ +mp_err s_mp_invmod_slow(const mp_int *a, const mp_int *b, mp_int *c) +{ + mp_int x, y, u, v, A, B, C, D; + mp_err err; + + /* b cannot be negative */ + if ((b->sign == MP_NEG) || MP_IS_ZERO(b)) { + return MP_VAL; + } + + /* init temps */ + if ((err = mp_init_multi(&x, &y, &u, &v, + &A, &B, &C, &D, NULL)) != MP_OKAY) { + return err; + } + + /* x = a, y = b */ + if ((err = mp_mod(a, b, &x)) != MP_OKAY) goto LBL_ERR; + if ((err = mp_copy(b, &y)) != MP_OKAY) goto LBL_ERR; + + /* 2. [modified] if x,y are both even then return an error! */ + if (MP_IS_EVEN(&x) && MP_IS_EVEN(&y)) { + err = MP_VAL; + goto LBL_ERR; + } + + /* 3. u=x, v=y, A=1, B=0, C=0,D=1 */ + if ((err = mp_copy(&x, &u)) != MP_OKAY) goto LBL_ERR; + if ((err = mp_copy(&y, &v)) != MP_OKAY) goto LBL_ERR; + mp_set(&A, 1uL); + mp_set(&D, 1uL); + +top: + /* 4. while u is even do */ + while (MP_IS_EVEN(&u)) { + /* 4.1 u = u/2 */ + if ((err = mp_div_2(&u, &u)) != MP_OKAY) goto LBL_ERR; + + /* 4.2 if A or B is odd then */ + if (MP_IS_ODD(&A) || MP_IS_ODD(&B)) { + /* A = (A+y)/2, B = (B-x)/2 */ + if ((err = mp_add(&A, &y, &A)) != MP_OKAY) goto LBL_ERR; + if ((err = mp_sub(&B, &x, &B)) != MP_OKAY) goto LBL_ERR; + } + /* A = A/2, B = B/2 */ + if ((err = mp_div_2(&A, &A)) != MP_OKAY) goto LBL_ERR; + if ((err = mp_div_2(&B, &B)) != MP_OKAY) goto LBL_ERR; + } + + /* 5. while v is even do */ + while (MP_IS_EVEN(&v)) { + /* 5.1 v = v/2 */ + if ((err = mp_div_2(&v, &v)) != MP_OKAY) goto LBL_ERR; + + /* 5.2 if C or D is odd then */ + if (MP_IS_ODD(&C) || MP_IS_ODD(&D)) { + /* C = (C+y)/2, D = (D-x)/2 */ + if ((err = mp_add(&C, &y, &C)) != MP_OKAY) goto LBL_ERR; + if ((err = mp_sub(&D, &x, &D)) != MP_OKAY) goto LBL_ERR; + } + /* C = C/2, D = D/2 */ + if ((err = mp_div_2(&C, &C)) != MP_OKAY) goto LBL_ERR; + if ((err = mp_div_2(&D, &D)) != MP_OKAY) goto LBL_ERR; + } + + /* 6. if u >= v then */ + if (mp_cmp(&u, &v) != MP_LT) { + /* u = u - v, A = A - C, B = B - D */ + if ((err = mp_sub(&u, &v, &u)) != MP_OKAY) goto LBL_ERR; + + if ((err = mp_sub(&A, &C, &A)) != MP_OKAY) goto LBL_ERR; + + if ((err = mp_sub(&B, &D, &B)) != MP_OKAY) goto LBL_ERR; + } else { + /* v - v - u, C = C - A, D = D - B */ + if ((err = mp_sub(&v, &u, &v)) != MP_OKAY) goto LBL_ERR; + + if ((err = mp_sub(&C, &A, &C)) != MP_OKAY) goto LBL_ERR; + + if ((err = mp_sub(&D, &B, &D)) != MP_OKAY) goto LBL_ERR; + } + + /* if not zero goto step 4 */ + if (!MP_IS_ZERO(&u)) { + goto top; + } + + /* now a = C, b = D, gcd == g*v */ + + /* if v != 1 then there is no inverse */ + if (mp_cmp_d(&v, 1uL) != MP_EQ) { + err = MP_VAL; + goto LBL_ERR; + } + + /* if its too low */ + while (mp_cmp_d(&C, 0uL) == MP_LT) { + if ((err = mp_add(&C, b, &C)) != MP_OKAY) goto LBL_ERR; + } + + /* too big */ + while (mp_cmp_mag(&C, b) != MP_LT) { + if ((err = mp_sub(&C, b, &C)) != MP_OKAY) goto LBL_ERR; + } + + /* C is now the inverse */ + mp_exch(&C, c); + err = MP_OKAY; +LBL_ERR: + mp_clear_multi(&x, &y, &u, &v, &A, &B, &C, &D, NULL); + return err; +} +#endif ADDED libtommath/bn_s_mp_karatsuba_mul.c Index: libtommath/bn_s_mp_karatsuba_mul.c ================================================================== --- /dev/null +++ libtommath/bn_s_mp_karatsuba_mul.c @@ -0,0 +1,174 @@ +#include "tommath_private.h" +#ifdef BN_S_MP_KARATSUBA_MUL_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +/* c = |a| * |b| using Karatsuba Multiplication using + * three half size multiplications + * + * Let B represent the radix [e.g. 2**MP_DIGIT_BIT] and + * let n represent half of the number of digits in + * the min(a,b) + * + * a = a1 * B**n + a0 + * b = b1 * B**n + b0 + * + * Then, a * b => + a1b1 * B**2n + ((a1 + a0)(b1 + b0) - (a0b0 + a1b1)) * B + a0b0 + * + * Note that a1b1 and a0b0 are used twice and only need to be + * computed once. So in total three half size (half # of + * digit) multiplications are performed, a0b0, a1b1 and + * (a1+b1)(a0+b0) + * + * Note that a multiplication of half the digits requires + * 1/4th the number of single precision multiplications so in + * total after one call 25% of the single precision multiplications + * are saved. Note also that the call to mp_mul can end up back + * in this function if the a0, a1, b0, or b1 are above the threshold. + * This is known as divide-and-conquer and leads to the famous + * O(N**lg(3)) or O(N**1.584) work which is asymptopically lower than + * the standard O(N**2) that the baseline/comba methods use. + * Generally though the overhead of this method doesn't pay off + * until a certain size (N ~ 80) is reached. + */ +mp_err s_mp_karatsuba_mul(const mp_int *a, const mp_int *b, mp_int *c) +{ + mp_int x0, x1, y0, y1, t1, x0y0, x1y1; + int B; + mp_err err = MP_MEM; /* default the return code to an error */ + + /* min # of digits */ + B = MP_MIN(a->used, b->used); + + /* now divide in two */ + B = B >> 1; + + /* init copy all the temps */ + if (mp_init_size(&x0, B) != MP_OKAY) { + goto LBL_ERR; + } + if (mp_init_size(&x1, a->used - B) != MP_OKAY) { + goto X0; + } + if (mp_init_size(&y0, B) != MP_OKAY) { + goto X1; + } + if (mp_init_size(&y1, b->used - B) != MP_OKAY) { + goto Y0; + } + + /* init temps */ + if (mp_init_size(&t1, B * 2) != MP_OKAY) { + goto Y1; + } + if (mp_init_size(&x0y0, B * 2) != MP_OKAY) { + goto T1; + } + if (mp_init_size(&x1y1, B * 2) != MP_OKAY) { + goto X0Y0; + } + + /* now shift the digits */ + x0.used = y0.used = B; + x1.used = a->used - B; + y1.used = b->used - B; + + { + int x; + mp_digit *tmpa, *tmpb, *tmpx, *tmpy; + + /* we copy the digits directly instead of using higher level functions + * since we also need to shift the digits + */ + tmpa = a->dp; + tmpb = b->dp; + + tmpx = x0.dp; + tmpy = y0.dp; + for (x = 0; x < B; x++) { + *tmpx++ = *tmpa++; + *tmpy++ = *tmpb++; + } + + tmpx = x1.dp; + for (x = B; x < a->used; x++) { + *tmpx++ = *tmpa++; + } + + tmpy = y1.dp; + for (x = B; x < b->used; x++) { + *tmpy++ = *tmpb++; + } + } + + /* only need to clamp the lower words since by definition the + * upper words x1/y1 must have a known number of digits + */ + mp_clamp(&x0); + mp_clamp(&y0); + + /* now calc the products x0y0 and x1y1 */ + /* after this x0 is no longer required, free temp [x0==t2]! */ + if (mp_mul(&x0, &y0, &x0y0) != MP_OKAY) { + goto X1Y1; /* x0y0 = x0*y0 */ + } + if (mp_mul(&x1, &y1, &x1y1) != MP_OKAY) { + goto X1Y1; /* x1y1 = x1*y1 */ + } + + /* now calc x1+x0 and y1+y0 */ + if (s_mp_add(&x1, &x0, &t1) != MP_OKAY) { + goto X1Y1; /* t1 = x1 - x0 */ + } + if (s_mp_add(&y1, &y0, &x0) != MP_OKAY) { + goto X1Y1; /* t2 = y1 - y0 */ + } + if (mp_mul(&t1, &x0, &t1) != MP_OKAY) { + goto X1Y1; /* t1 = (x1 + x0) * (y1 + y0) */ + } + + /* add x0y0 */ + if (mp_add(&x0y0, &x1y1, &x0) != MP_OKAY) { + goto X1Y1; /* t2 = x0y0 + x1y1 */ + } + if (s_mp_sub(&t1, &x0, &t1) != MP_OKAY) { + goto X1Y1; /* t1 = (x1+x0)*(y1+y0) - (x1y1 + x0y0) */ + } + + /* shift by B */ + if (mp_lshd(&t1, B) != MP_OKAY) { + goto X1Y1; /* t1 = (x0y0 + x1y1 - (x1-x0)*(y1-y0))<used; + + /* now divide in two */ + B = B >> 1; + + /* init copy all the temps */ + if (mp_init_size(&x0, B) != MP_OKAY) + goto LBL_ERR; + if (mp_init_size(&x1, a->used - B) != MP_OKAY) + goto X0; + + /* init temps */ + if (mp_init_size(&t1, a->used * 2) != MP_OKAY) + goto X1; + if (mp_init_size(&t2, a->used * 2) != MP_OKAY) + goto T1; + if (mp_init_size(&x0x0, B * 2) != MP_OKAY) + goto T2; + if (mp_init_size(&x1x1, (a->used - B) * 2) != MP_OKAY) + goto X0X0; + + { + int x; + mp_digit *dst, *src; + + src = a->dp; + + /* now shift the digits */ + dst = x0.dp; + for (x = 0; x < B; x++) { + *dst++ = *src++; + } + + dst = x1.dp; + for (x = B; x < a->used; x++) { + *dst++ = *src++; + } + } + + x0.used = B; + x1.used = a->used - B; + + mp_clamp(&x0); + + /* now calc the products x0*x0 and x1*x1 */ + if (mp_sqr(&x0, &x0x0) != MP_OKAY) + goto X1X1; /* x0x0 = x0*x0 */ + if (mp_sqr(&x1, &x1x1) != MP_OKAY) + goto X1X1; /* x1x1 = x1*x1 */ + + /* now calc (x1+x0)**2 */ + if (s_mp_add(&x1, &x0, &t1) != MP_OKAY) + goto X1X1; /* t1 = x1 - x0 */ + if (mp_sqr(&t1, &t1) != MP_OKAY) + goto X1X1; /* t1 = (x1 - x0) * (x1 - x0) */ + + /* add x0y0 */ + if (s_mp_add(&x0x0, &x1x1, &t2) != MP_OKAY) + goto X1X1; /* t2 = x0x0 + x1x1 */ + if (s_mp_sub(&t1, &t2, &t1) != MP_OKAY) + goto X1X1; /* t1 = (x1+x0)**2 - (x0x0 + x1x1) */ + + /* shift by B */ + if (mp_lshd(&t1, B) != MP_OKAY) + goto X1X1; /* t1 = (x0x0 + x1x1 - (x1-x0)*(x1-x0))<used > MP_WARRAY) { + return MP_VAL; + } + + /* get old used count */ + olduse = x->used; + + /* grow a as required */ + if (x->alloc < (n->used + 1)) { + if ((err = mp_grow(x, n->used + 1)) != MP_OKAY) { + return err; + } + } + + /* first we have to get the digits of the input into + * an array of double precision words W[...] + */ + { + mp_word *_W; + mp_digit *tmpx; + + /* alias for the W[] array */ + _W = W; + + /* alias for the digits of x*/ + tmpx = x->dp; + + /* copy the digits of a into W[0..a->used-1] */ + for (ix = 0; ix < x->used; ix++) { + *_W++ = *tmpx++; + } + + /* zero the high words of W[a->used..m->used*2] */ + if (ix < ((n->used * 2) + 1)) { + MP_ZERO_BUFFER(_W, sizeof(mp_word) * (size_t)(((n->used * 2) + 1) - ix)); + } + } + + /* now we proceed to zero successive digits + * from the least significant upwards + */ + for (ix = 0; ix < n->used; ix++) { + /* mu = ai * m' mod b + * + * We avoid a double precision multiplication (which isn't required) + * by casting the value down to a mp_digit. Note this requires + * that W[ix-1] have the carry cleared (see after the inner loop) + */ + mp_digit mu; + mu = ((W[ix] & MP_MASK) * rho) & MP_MASK; + + /* a = a + mu * m * b**i + * + * This is computed in place and on the fly. The multiplication + * by b**i is handled by offseting which columns the results + * are added to. + * + * Note the comba method normally doesn't handle carries in the + * inner loop In this case we fix the carry from the previous + * column since the Montgomery reduction requires digits of the + * result (so far) [see above] to work. This is + * handled by fixing up one carry after the inner loop. The + * carry fixups are done in order so after these loops the + * first m->used words of W[] have the carries fixed + */ + { + int iy; + mp_digit *tmpn; + mp_word *_W; + + /* alias for the digits of the modulus */ + tmpn = n->dp; + + /* Alias for the columns set by an offset of ix */ + _W = W + ix; + + /* inner loop */ + for (iy = 0; iy < n->used; iy++) { + *_W++ += (mp_word)mu * (mp_word)*tmpn++; + } + } + + /* now fix carry for next digit, W[ix+1] */ + W[ix + 1] += W[ix] >> (mp_word)MP_DIGIT_BIT; + } + + /* now we have to propagate the carries and + * shift the words downward [all those least + * significant digits we zeroed]. + */ + { + mp_digit *tmpx; + mp_word *_W, *_W1; + + /* nox fix rest of carries */ + + /* alias for current word */ + _W1 = W + ix; + + /* alias for next word, where the carry goes */ + _W = W + ++ix; + + for (; ix < ((n->used * 2) + 1); ix++) { + *_W++ += *_W1++ >> (mp_word)MP_DIGIT_BIT; + } + + /* copy out, A = A/b**n + * + * The result is A/b**n but instead of converting from an + * array of mp_word to mp_digit than calling mp_rshd + * we just copy them in the right order + */ + + /* alias for destination word */ + tmpx = x->dp; + + /* alias for shifted double precision result */ + _W = W + n->used; + + for (ix = 0; ix < (n->used + 1); ix++) { + *tmpx++ = *_W++ & (mp_word)MP_MASK; + } + + /* zero oldused digits, if the input a was larger than + * m->used+1 we'll have to clear the digits + */ + MP_ZERO_DIGITS(tmpx, olduse - ix); + } + + /* set the max used and clamp */ + x->used = n->used + 1; + mp_clamp(x); + + /* if A >= m then A = A - m */ + if (mp_cmp_mag(x, n) != MP_LT) { + return s_mp_sub(x, n, x); + } + return MP_OKAY; +} +#endif Index: libtommath/bn_s_mp_mul_digs.c ================================================================== --- libtommath/bn_s_mp_mul_digs.c +++ libtommath/bn_s_mp_mul_digs.c @@ -1,40 +1,31 @@ #include "tommath_private.h" #ifdef BN_S_MP_MUL_DIGS_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* multiplies |a| * |b| and only computes upto digs digits of result * HAC pp. 595, Algorithm 14.12 Modified so you can control how * many digits of output are created. */ -int s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs) +mp_err s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs) { mp_int t; - int res, pa, pb, ix, iy; + mp_err err; + int pa, pb, ix, iy; mp_digit u; mp_word r; mp_digit tmpx, *tmpt, *tmpy; /* can we use the fast multiplier? */ - if ((digs < (int)MP_WARRAY) && - (MIN(a->used, b->used) < - (int)(1u << (((size_t)CHAR_BIT * sizeof(mp_word)) - (2u * (size_t)DIGIT_BIT))))) { - return fast_s_mp_mul_digs(a, b, c, digs); + if ((digs < MP_WARRAY) && + (MP_MIN(a->used, b->used) < MP_MAXFAST)) { + return s_mp_mul_digs_fast(a, b, c, digs); } - if ((res = mp_init_size(&t, digs)) != MP_OKAY) { - return res; + if ((err = mp_init_size(&t, digs)) != MP_OKAY) { + return err; } t.used = digs; /* compute the digits of the product directly */ pa = a->used; @@ -41,11 +32,11 @@ for (ix = 0; ix < pa; ix++) { /* set the carry to zero */ u = 0; /* limit ourselves to making digs digits of output */ - pb = MIN(b->used, digs - ix); + pb = MP_MIN(b->used, digs - ix); /* setup some aliases */ /* copy of the digit from a used within the nested loop */ tmpx = a->dp[ix]; @@ -64,11 +55,11 @@ /* the new column is the lower part of the result */ *tmpt++ = (mp_digit)(r & (mp_word)MP_MASK); /* get the carry word from the result */ - u = (mp_digit)(r >> (mp_word)DIGIT_BIT); + u = (mp_digit)(r >> (mp_word)MP_DIGIT_BIT); } /* set carry if it is placed below digs */ if ((ix + iy) < digs) { *tmpt = u; } @@ -79,9 +70,5 @@ mp_clear(&t); return MP_OKAY; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ ADDED libtommath/bn_s_mp_mul_digs_fast.c Index: libtommath/bn_s_mp_mul_digs_fast.c ================================================================== --- /dev/null +++ libtommath/bn_s_mp_mul_digs_fast.c @@ -0,0 +1,90 @@ +#include "tommath_private.h" +#ifdef BN_S_MP_MUL_DIGS_FAST_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +/* Fast (comba) multiplier + * + * This is the fast column-array [comba] multiplier. It is + * designed to compute the columns of the product first + * then handle the carries afterwards. This has the effect + * of making the nested loops that compute the columns very + * simple and schedulable on super-scalar processors. + * + * This has been modified to produce a variable number of + * digits of output so if say only a half-product is required + * you don't have to compute the upper half (a feature + * required for fast Barrett reduction). + * + * Based on Algorithm 14.12 on pp.595 of HAC. + * + */ +mp_err s_mp_mul_digs_fast(const mp_int *a, const mp_int *b, mp_int *c, int digs) +{ + int olduse, pa, ix, iz; + mp_err err; + mp_digit W[MP_WARRAY]; + mp_word _W; + + /* grow the destination as required */ + if (c->alloc < digs) { + if ((err = mp_grow(c, digs)) != MP_OKAY) { + return err; + } + } + + /* number of output digits to produce */ + pa = MP_MIN(digs, a->used + b->used); + + /* clear the carry */ + _W = 0; + for (ix = 0; ix < pa; ix++) { + int tx, ty; + int iy; + mp_digit *tmpx, *tmpy; + + /* get offsets into the two bignums */ + ty = MP_MIN(b->used-1, ix); + tx = ix - ty; + + /* setup temp aliases */ + tmpx = a->dp + tx; + tmpy = b->dp + ty; + + /* this is the number of times the loop will iterrate, essentially + while (tx++ < a->used && ty-- >= 0) { ... } + */ + iy = MP_MIN(a->used-tx, ty+1); + + /* execute loop */ + for (iz = 0; iz < iy; ++iz) { + _W += (mp_word)*tmpx++ * (mp_word)*tmpy--; + + } + + /* store term */ + W[ix] = (mp_digit)_W & MP_MASK; + + /* make next carry */ + _W = _W >> (mp_word)MP_DIGIT_BIT; + } + + /* setup dest */ + olduse = c->used; + c->used = pa; + + { + mp_digit *tmpc; + tmpc = c->dp; + for (ix = 0; ix < pa; ix++) { + /* now extract the previous digit [below the carry] */ + *tmpc++ = W[ix]; + } + + /* clear unused digits [that existed in the old copy of c] */ + MP_ZERO_DIGITS(tmpc, olduse - ix); + } + mp_clamp(c); + return MP_OKAY; +} +#endif Index: libtommath/bn_s_mp_mul_high_digs.c ================================================================== --- libtommath/bn_s_mp_mul_high_digs.c +++ libtommath/bn_s_mp_mul_high_digs.c @@ -1,40 +1,31 @@ #include "tommath_private.h" #ifdef BN_S_MP_MUL_HIGH_DIGS_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* multiplies |a| * |b| and does not compute the lower digs digits * [meant to get the higher part of the product] */ -int s_mp_mul_high_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs) +mp_err s_mp_mul_high_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs) { - mp_int t; - int res, pa, pb, ix, iy; + mp_int t; + int pa, pb, ix, iy; + mp_err err; mp_digit u; - mp_word r; + mp_word r; mp_digit tmpx, *tmpt, *tmpy; /* can we use the fast multiplier? */ -#ifdef BN_FAST_S_MP_MUL_HIGH_DIGS_C - if (((a->used + b->used + 1) < (int)MP_WARRAY) - && (MIN(a->used, b->used) < (int)(1u << (((size_t)CHAR_BIT * sizeof(mp_word)) - (2u * (size_t)DIGIT_BIT))))) { - return fast_s_mp_mul_high_digs(a, b, c, digs); - } -#endif - - if ((res = mp_init_size(&t, a->used + b->used + 1)) != MP_OKAY) { - return res; + if (MP_HAS(S_MP_MUL_HIGH_DIGS_FAST) + && ((a->used + b->used + 1) < MP_WARRAY) + && (MP_MIN(a->used, b->used) < MP_MAXFAST)) { + return s_mp_mul_high_digs_fast(a, b, c, digs); + } + + if ((err = mp_init_size(&t, a->used + b->used + 1)) != MP_OKAY) { + return err; } t.used = a->used + b->used + 1; pa = a->used; pb = b->used; @@ -59,19 +50,15 @@ /* get the lower part */ *tmpt++ = (mp_digit)(r & (mp_word)MP_MASK); /* carry the carry */ - u = (mp_digit)(r >> (mp_word)DIGIT_BIT); + u = (mp_digit)(r >> (mp_word)MP_DIGIT_BIT); } *tmpt = u; } mp_clamp(&t); mp_exch(&t, c); mp_clear(&t); return MP_OKAY; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ ADDED libtommath/bn_s_mp_mul_high_digs_fast.c Index: libtommath/bn_s_mp_mul_high_digs_fast.c ================================================================== --- /dev/null +++ libtommath/bn_s_mp_mul_high_digs_fast.c @@ -0,0 +1,81 @@ +#include "tommath_private.h" +#ifdef BN_S_MP_MUL_HIGH_DIGS_FAST_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +/* this is a modified version of fast_s_mul_digs that only produces + * output digits *above* digs. See the comments for fast_s_mul_digs + * to see how it works. + * + * This is used in the Barrett reduction since for one of the multiplications + * only the higher digits were needed. This essentially halves the work. + * + * Based on Algorithm 14.12 on pp.595 of HAC. + */ +mp_err s_mp_mul_high_digs_fast(const mp_int *a, const mp_int *b, mp_int *c, int digs) +{ + int olduse, pa, ix, iz; + mp_err err; + mp_digit W[MP_WARRAY]; + mp_word _W; + + /* grow the destination as required */ + pa = a->used + b->used; + if (c->alloc < pa) { + if ((err = mp_grow(c, pa)) != MP_OKAY) { + return err; + } + } + + /* number of output digits to produce */ + pa = a->used + b->used; + _W = 0; + for (ix = digs; ix < pa; ix++) { + int tx, ty, iy; + mp_digit *tmpx, *tmpy; + + /* get offsets into the two bignums */ + ty = MP_MIN(b->used-1, ix); + tx = ix - ty; + + /* setup temp aliases */ + tmpx = a->dp + tx; + tmpy = b->dp + ty; + + /* this is the number of times the loop will iterrate, essentially its + while (tx++ < a->used && ty-- >= 0) { ... } + */ + iy = MP_MIN(a->used-tx, ty+1); + + /* execute loop */ + for (iz = 0; iz < iy; iz++) { + _W += (mp_word)*tmpx++ * (mp_word)*tmpy--; + } + + /* store term */ + W[ix] = (mp_digit)_W & MP_MASK; + + /* make next carry */ + _W = _W >> (mp_word)MP_DIGIT_BIT; + } + + /* setup dest */ + olduse = c->used; + c->used = pa; + + { + mp_digit *tmpc; + + tmpc = c->dp + digs; + for (ix = digs; ix < pa; ix++) { + /* now extract the previous digit [below the carry] */ + *tmpc++ = W[ix]; + } + + /* clear unused digits [that existed in the old copy of c] */ + MP_ZERO_DIGITS(tmpc, olduse - ix); + } + mp_clamp(c); + return MP_OKAY; +} +#endif ADDED libtommath/bn_s_mp_prime_is_divisible.c Index: libtommath/bn_s_mp_prime_is_divisible.c ================================================================== --- /dev/null +++ libtommath/bn_s_mp_prime_is_divisible.c @@ -0,0 +1,35 @@ +#include "tommath_private.h" +#ifdef BN_S_MP_PRIME_IS_DIVISIBLE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +/* determines if an integers is divisible by one + * of the first PRIME_SIZE primes or not + * + * sets result to 0 if not, 1 if yes + */ +mp_err s_mp_prime_is_divisible(const mp_int *a, mp_bool *result) +{ + int ix; + mp_err err; + mp_digit res; + + /* default to not */ + *result = MP_NO; + + for (ix = 0; ix < PRIVATE_MP_PRIME_TAB_SIZE; ix++) { + /* what is a mod LBL_prime_tab[ix] */ + if ((err = mp_mod_d(a, s_mp_prime_tab[ix], &res)) != MP_OKAY) { + return err; + } + + /* is the residue zero? */ + if (res == 0u) { + *result = MP_YES; + return MP_OKAY; + } + } + + return MP_OKAY; +} +#endif ADDED libtommath/bn_s_mp_rand_jenkins.c Index: libtommath/bn_s_mp_rand_jenkins.c ================================================================== --- /dev/null +++ libtommath/bn_s_mp_rand_jenkins.c @@ -0,0 +1,52 @@ +#include "tommath_private.h" +#ifdef BN_S_MP_RAND_JENKINS_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +/* Bob Jenkins' http://burtleburtle.net/bob/rand/smallprng.html */ +/* Chosen for speed and a good "mix" */ +typedef struct { + uint64_t a; + uint64_t b; + uint64_t c; + uint64_t d; +} ranctx; + +static ranctx jenkins_x; + +#define rot(x,k) (((x)<<(k))|((x)>>(64-(k)))) +static uint64_t s_rand_jenkins_val(void) +{ + uint64_t e = jenkins_x.a - rot(jenkins_x.b, 7); + jenkins_x.a = jenkins_x.b ^ rot(jenkins_x.c, 13); + jenkins_x.b = jenkins_x.c + rot(jenkins_x.d, 37); + jenkins_x.c = jenkins_x.d + e; + jenkins_x.d = e + jenkins_x.a; + return jenkins_x.d; +} + +void s_mp_rand_jenkins_init(uint64_t seed) +{ + uint64_t i; + jenkins_x.a = 0xf1ea5eedULL; + jenkins_x.b = jenkins_x.c = jenkins_x.d = seed; + for (i = 0uLL; i < 20uLL; ++i) { + (void)s_rand_jenkins_val(); + } +} + +mp_err s_mp_rand_jenkins(void *p, size_t n) +{ + char *q = (char *)p; + while (n > 0u) { + int i; + uint64_t x = s_rand_jenkins_val(); + for (i = 0; (i < 8) && (n > 0u); ++i, --n) { + *q++ = (char)(x & 0xFFuLL); + x >>= 8; + } + } + return MP_OKAY; +} + +#endif ADDED libtommath/bn_s_mp_rand_platform.c Index: libtommath/bn_s_mp_rand_platform.c ================================================================== --- /dev/null +++ libtommath/bn_s_mp_rand_platform.c @@ -0,0 +1,148 @@ +#include "tommath_private.h" +#ifdef BN_S_MP_RAND_PLATFORM_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +/* First the OS-specific special cases + * - *BSD + * - Windows + */ +#if defined(__FreeBSD__) || defined(__OpenBSD__) || defined(__NetBSD__) || defined(__DragonFly__) +#define BN_S_READ_ARC4RANDOM_C +static mp_err s_read_arc4random(void *p, size_t n) +{ + arc4random_buf(p, n); + return MP_OKAY; +} +#endif + +#if defined(_WIN32) || defined(_WIN32_WCE) +#define BN_S_READ_WINCSP_C + +#ifndef _WIN32_WINNT +#define _WIN32_WINNT 0x0400 +#endif +#ifdef _WIN32_WCE +#define UNDER_CE +#define ARM +#endif + +#define WIN32_LEAN_AND_MEAN +#include +#include + +static mp_err s_read_wincsp(void *p, size_t n) +{ + static HCRYPTPROV hProv = 0; + if (hProv == 0) { + HCRYPTPROV h = 0; + if (!CryptAcquireContext(&h, NULL, MS_DEF_PROV, PROV_RSA_FULL, + (CRYPT_VERIFYCONTEXT | CRYPT_MACHINE_KEYSET)) && + !CryptAcquireContext(&h, NULL, MS_DEF_PROV, PROV_RSA_FULL, + CRYPT_VERIFYCONTEXT | CRYPT_MACHINE_KEYSET | CRYPT_NEWKEYSET)) { + return MP_ERR; + } + hProv = h; + } + return CryptGenRandom(hProv, (DWORD)n, (BYTE *)p) == TRUE ? MP_OKAY : MP_ERR; +} +#endif /* WIN32 */ + +#if !defined(BN_S_READ_WINCSP_C) && defined(__linux__) && defined(__GLIBC_PREREQ) +#if __GLIBC_PREREQ(2, 25) +#define BN_S_READ_GETRANDOM_C +#include +#include + +static mp_err s_read_getrandom(void *p, size_t n) +{ + char *q = (char *)p; + while (n > 0u) { + ssize_t ret = getrandom(q, n, 0); + if (ret < 0) { + if (errno == EINTR) { + continue; + } + return MP_ERR; + } + q += ret; + n -= (size_t)ret; + } + return MP_OKAY; +} +#endif +#endif + +/* We assume all platforms besides windows provide "/dev/urandom". + * In case yours doesn't, define MP_NO_DEV_URANDOM at compile-time. + */ +#if !defined(BN_S_READ_WINCSP_C) && !defined(MP_NO_DEV_URANDOM) +#define BN_S_READ_URANDOM_C +#ifndef MP_DEV_URANDOM +#define MP_DEV_URANDOM "/dev/urandom" +#endif +#include +#include +#include + +static mp_err s_read_urandom(void *p, size_t n) +{ + int fd; + char *q = (char *)p; + + do { + fd = open(MP_DEV_URANDOM, O_RDONLY); + } while ((fd == -1) && (errno == EINTR)); + if (fd == -1) return MP_ERR; + + while (n > 0u) { + ssize_t ret = read(fd, p, n); + if (ret < 0) { + if (errno == EINTR) { + continue; + } + close(fd); + return MP_ERR; + } + q += ret; + n -= (size_t)ret; + } + + close(fd); + return MP_OKAY; +} +#endif + +#if defined(MP_PRNG_ENABLE_LTM_RNG) +#define BN_S_READ_LTM_RNG +unsigned long (*ltm_rng)(unsigned char *out, unsigned long outlen, void (*callback)(void)); +void (*ltm_rng_callback)(void); + +static mp_err s_read_ltm_rng(void *p, size_t n) +{ + unsigned long res; + if (ltm_rng == NULL) return MP_ERR; + res = ltm_rng(p, n, ltm_rng_callback); + if (res != n) return MP_ERR; + return MP_OKAY; +} +#endif + +mp_err s_read_arc4random(void *p, size_t n); +mp_err s_read_wincsp(void *p, size_t n); +mp_err s_read_getrandom(void *p, size_t n); +mp_err s_read_urandom(void *p, size_t n); +mp_err s_read_ltm_rng(void *p, size_t n); + +mp_err s_mp_rand_platform(void *p, size_t n) +{ + mp_err err = MP_ERR; + if ((err != MP_OKAY) && MP_HAS(S_READ_ARC4RANDOM)) err = s_read_arc4random(p, n); + if ((err != MP_OKAY) && MP_HAS(S_READ_WINCSP)) err = s_read_wincsp(p, n); + if ((err != MP_OKAY) && MP_HAS(S_READ_GETRANDOM)) err = s_read_getrandom(p, n); + if ((err != MP_OKAY) && MP_HAS(S_READ_URANDOM)) err = s_read_urandom(p, n); + if ((err != MP_OKAY) && MP_HAS(S_READ_LTM_RNG)) err = s_read_ltm_rng(p, n); + return err; +} + +#endif ADDED libtommath/bn_s_mp_reverse.c Index: libtommath/bn_s_mp_reverse.c ================================================================== --- /dev/null +++ libtommath/bn_s_mp_reverse.c @@ -0,0 +1,22 @@ +#include "tommath_private.h" +#ifdef BN_S_MP_REVERSE_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +/* reverse an array, used for radix code */ +void s_mp_reverse(unsigned char *s, size_t len) +{ + size_t ix, iy; + unsigned char t; + + ix = 0u; + iy = len - 1u; + while (ix < iy) { + t = s[ix]; + s[ix] = s[iy]; + s[iy] = t; + ++ix; + --iy; + } +} +#endif Index: libtommath/bn_s_mp_sqr.c ================================================================== --- libtommath/bn_s_mp_sqr.c +++ libtommath/bn_s_mp_sqr.c @@ -1,30 +1,22 @@ #include "tommath_private.h" #ifdef BN_S_MP_SQR_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* low level squaring, b = a*a, HAC pp.596-597, Algorithm 14.16 */ -int s_mp_sqr(const mp_int *a, mp_int *b) +mp_err s_mp_sqr(const mp_int *a, mp_int *b) { - mp_int t; - int res, ix, iy, pa; - mp_word r; + mp_int t; + int ix, iy, pa; + mp_err err; + mp_word r; mp_digit u, tmpx, *tmpt; pa = a->used; - if ((res = mp_init_size(&t, (2 * pa) + 1)) != MP_OKAY) { - return res; + if ((err = mp_init_size(&t, (2 * pa) + 1)) != MP_OKAY) { + return err; } /* default used is maximum possible size */ t.used = (2 * pa) + 1; @@ -36,11 +28,11 @@ /* store lower part in result */ t.dp[ix+ix] = (mp_digit)(r & (mp_word)MP_MASK); /* get the carry */ - u = (mp_digit)(r >> (mp_word)DIGIT_BIT); + u = (mp_digit)(r >> (mp_word)MP_DIGIT_BIT); /* left hand side of A[ix] * A[iy] */ tmpx = a->dp[ix]; /* alias for where to store the results */ @@ -57,25 +49,21 @@ /* store lower part */ *tmpt++ = (mp_digit)(r & (mp_word)MP_MASK); /* get carry */ - u = (mp_digit)(r >> (mp_word)DIGIT_BIT); + u = (mp_digit)(r >> (mp_word)MP_DIGIT_BIT); } /* propagate upwards */ while (u != 0uL) { r = (mp_word)*tmpt + (mp_word)u; *tmpt++ = (mp_digit)(r & (mp_word)MP_MASK); - u = (mp_digit)(r >> (mp_word)DIGIT_BIT); + u = (mp_digit)(r >> (mp_word)MP_DIGIT_BIT); } } mp_clamp(&t); mp_exch(&t, b); mp_clear(&t); return MP_OKAY; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ ADDED libtommath/bn_s_mp_sqr_fast.c Index: libtommath/bn_s_mp_sqr_fast.c ================================================================== --- /dev/null +++ libtommath/bn_s_mp_sqr_fast.c @@ -0,0 +1,97 @@ +#include "tommath_private.h" +#ifdef BN_S_MP_SQR_FAST_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +/* the jist of squaring... + * you do like mult except the offset of the tmpx [one that + * starts closer to zero] can't equal the offset of tmpy. + * So basically you set up iy like before then you min it with + * (ty-tx) so that it never happens. You double all those + * you add in the inner loop + +After that loop you do the squares and add them in. +*/ + +mp_err s_mp_sqr_fast(const mp_int *a, mp_int *b) +{ + int olduse, pa, ix, iz; + mp_digit W[MP_WARRAY], *tmpx; + mp_word W1; + mp_err err; + + /* grow the destination as required */ + pa = a->used + a->used; + if (b->alloc < pa) { + if ((err = mp_grow(b, pa)) != MP_OKAY) { + return err; + } + } + + /* number of output digits to produce */ + W1 = 0; + for (ix = 0; ix < pa; ix++) { + int tx, ty, iy; + mp_word _W; + mp_digit *tmpy; + + /* clear counter */ + _W = 0; + + /* get offsets into the two bignums */ + ty = MP_MIN(a->used-1, ix); + tx = ix - ty; + + /* setup temp aliases */ + tmpx = a->dp + tx; + tmpy = a->dp + ty; + + /* this is the number of times the loop will iterrate, essentially + while (tx++ < a->used && ty-- >= 0) { ... } + */ + iy = MP_MIN(a->used-tx, ty+1); + + /* now for squaring tx can never equal ty + * we halve the distance since they approach at a rate of 2x + * and we have to round because odd cases need to be executed + */ + iy = MP_MIN(iy, ((ty-tx)+1)>>1); + + /* execute loop */ + for (iz = 0; iz < iy; iz++) { + _W += (mp_word)*tmpx++ * (mp_word)*tmpy--; + } + + /* double the inner product and add carry */ + _W = _W + _W + W1; + + /* even columns have the square term in them */ + if (((unsigned)ix & 1u) == 0u) { + _W += (mp_word)a->dp[ix>>1] * (mp_word)a->dp[ix>>1]; + } + + /* store it */ + W[ix] = (mp_digit)_W & MP_MASK; + + /* make next carry */ + W1 = _W >> (mp_word)MP_DIGIT_BIT; + } + + /* setup dest */ + olduse = b->used; + b->used = a->used+a->used; + + { + mp_digit *tmpb; + tmpb = b->dp; + for (ix = 0; ix < pa; ix++) { + *tmpb++ = W[ix] & MP_MASK; + } + + /* clear unused digits [that existed in the old copy of c] */ + MP_ZERO_DIGITS(tmpb, olduse - ix); + } + mp_clamp(b); + return MP_OKAY; +} +#endif Index: libtommath/bn_s_mp_sub.c ================================================================== --- libtommath/bn_s_mp_sub.c +++ libtommath/bn_s_mp_sub.c @@ -1,32 +1,24 @@ #include "tommath_private.h" #ifdef BN_S_MP_SUB_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* low level subtraction (assumes |a| > |b|), HAC pp.595 Algorithm 14.9 */ -int s_mp_sub(const mp_int *a, const mp_int *b, mp_int *c) +mp_err s_mp_sub(const mp_int *a, const mp_int *b, mp_int *c) { - int olduse, res, min, max; + int olduse, min, max; + mp_err err; /* find sizes */ min = b->used; max = a->used; /* init result */ if (c->alloc < max) { - if ((res = mp_grow(c, max)) != MP_OKAY) { - return res; + if ((err = mp_grow(c, max)) != MP_OKAY) { + return err; } } olduse = c->used; c->used = max; @@ -48,11 +40,11 @@ /* U = carry bit of T[i] * Note this saves performing an AND operation since * if a carry does occur it will propagate all the way to the * MSB. As a result a single shift is enough to get the carry */ - u = *tmpc >> (((size_t)CHAR_BIT * sizeof(mp_digit)) - 1u); + u = *tmpc >> (MP_SIZEOF_BITS(mp_digit) - 1u); /* Clear carry from T[i] */ *tmpc++ &= MP_MASK; } @@ -60,26 +52,20 @@ for (; i < max; i++) { /* T[i] = A[i] - U */ *tmpc = *tmpa++ - u; /* U = carry bit of T[i] */ - u = *tmpc >> (((size_t)CHAR_BIT * sizeof(mp_digit)) - 1u); + u = *tmpc >> (MP_SIZEOF_BITS(mp_digit) - 1u); /* Clear carry from T[i] */ *tmpc++ &= MP_MASK; } /* clear digits above used (since we may not have grown result above) */ - for (i = c->used; i < olduse; i++) { - *tmpc++ = 0; - } + MP_ZERO_DIGITS(tmpc, olduse - c->used); } mp_clamp(c); return MP_OKAY; } #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ ADDED libtommath/bn_s_mp_toom_mul.c Index: libtommath/bn_s_mp_toom_mul.c ================================================================== --- /dev/null +++ libtommath/bn_s_mp_toom_mul.c @@ -0,0 +1,215 @@ +#include "tommath_private.h" +#ifdef BN_S_MP_TOOM_MUL_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +/* multiplication using the Toom-Cook 3-way algorithm + * + * Much more complicated than Karatsuba but has a lower + * asymptotic running time of O(N**1.464). This algorithm is + * only particularly useful on VERY large inputs + * (we're talking 1000s of digits here...). +*/ + +/* + This file contains code from J. Arndt's book "Matters Computational" + and the accompanying FXT-library with permission of the author. +*/ + +/* + Setup from + + Chung, Jaewook, and M. Anwar Hasan. "Asymmetric squaring formulae." + 18th IEEE Symposium on Computer Arithmetic (ARITH'07). IEEE, 2007. + + The interpolation from above needed one temporary variable more + than the interpolation here: + + Bodrato, Marco, and Alberto Zanoni. "What about Toom-Cook matrices optimality." + Centro Vito Volterra Universita di Roma Tor Vergata (2006) +*/ + +mp_err s_mp_toom_mul(const mp_int *a, const mp_int *b, mp_int *c) +{ + mp_int S1, S2, T1, a0, a1, a2, b0, b1, b2; + int B, count; + mp_err err; + + /* init temps */ + if ((err = mp_init_multi(&S1, &S2, &T1, NULL)) != MP_OKAY) { + return err; + } + + /* B */ + B = MP_MIN(a->used, b->used) / 3; + + /** a = a2 * x^2 + a1 * x + a0; */ + if ((err = mp_init_size(&a0, B)) != MP_OKAY) goto LBL_ERRa0; + + for (count = 0; count < B; count++) { + a0.dp[count] = a->dp[count]; + a0.used++; + } + mp_clamp(&a0); + if ((err = mp_init_size(&a1, B)) != MP_OKAY) goto LBL_ERRa1; + for (; count < (2 * B); count++) { + a1.dp[count - B] = a->dp[count]; + a1.used++; + } + mp_clamp(&a1); + if ((err = mp_init_size(&a2, B + (a->used - (3 * B)))) != MP_OKAY) goto LBL_ERRa2; + for (; count < a->used; count++) { + a2.dp[count - (2 * B)] = a->dp[count]; + a2.used++; + } + mp_clamp(&a2); + + /** b = b2 * x^2 + b1 * x + b0; */ + if ((err = mp_init_size(&b0, B)) != MP_OKAY) goto LBL_ERRb0; + for (count = 0; count < B; count++) { + b0.dp[count] = b->dp[count]; + b0.used++; + } + mp_clamp(&b0); + if ((err = mp_init_size(&b1, B)) != MP_OKAY) goto LBL_ERRb1; + for (; count < (2 * B); count++) { + b1.dp[count - B] = b->dp[count]; + b1.used++; + } + mp_clamp(&b1); + if ((err = mp_init_size(&b2, B + (b->used - (3 * B)))) != MP_OKAY) goto LBL_ERRb2; + for (; count < b->used; count++) { + b2.dp[count - (2 * B)] = b->dp[count]; + b2.used++; + } + mp_clamp(&b2); + + /** \\ S1 = (a2+a1+a0) * (b2+b1+b0); */ + /** T1 = a2 + a1; */ + if ((err = mp_add(&a2, &a1, &T1)) != MP_OKAY) goto LBL_ERR; + + /** S2 = T1 + a0; */ + if ((err = mp_add(&T1, &a0, &S2)) != MP_OKAY) goto LBL_ERR; + + /** c = b2 + b1; */ + if ((err = mp_add(&b2, &b1, c)) != MP_OKAY) goto LBL_ERR; + + /** S1 = c + b0; */ + if ((err = mp_add(c, &b0, &S1)) != MP_OKAY) goto LBL_ERR; + + /** S1 = S1 * S2; */ + if ((err = mp_mul(&S1, &S2, &S1)) != MP_OKAY) goto LBL_ERR; + + /** \\S2 = (4*a2+2*a1+a0) * (4*b2+2*b1+b0); */ + /** T1 = T1 + a2; */ + if ((err = mp_add(&T1, &a2, &T1)) != MP_OKAY) goto LBL_ERR; + + /** T1 = T1 << 1; */ + if ((err = mp_mul_2(&T1, &T1)) != MP_OKAY) goto LBL_ERR; + + /** T1 = T1 + a0; */ + if ((err = mp_add(&T1, &a0, &T1)) != MP_OKAY) goto LBL_ERR; + + /** c = c + b2; */ + if ((err = mp_add(c, &b2, c)) != MP_OKAY) goto LBL_ERR; + + /** c = c << 1; */ + if ((err = mp_mul_2(c, c)) != MP_OKAY) goto LBL_ERR; + + /** c = c + b0; */ + if ((err = mp_add(c, &b0, c)) != MP_OKAY) goto LBL_ERR; + + /** S2 = T1 * c; */ + if ((err = mp_mul(&T1, c, &S2)) != MP_OKAY) goto LBL_ERR; + + /** \\S3 = (a2-a1+a0) * (b2-b1+b0); */ + /** a1 = a2 - a1; */ + if ((err = mp_sub(&a2, &a1, &a1)) != MP_OKAY) goto LBL_ERR; + + /** a1 = a1 + a0; */ + if ((err = mp_add(&a1, &a0, &a1)) != MP_OKAY) goto LBL_ERR; + + /** b1 = b2 - b1; */ + if ((err = mp_sub(&b2, &b1, &b1)) != MP_OKAY) goto LBL_ERR; + + /** b1 = b1 + b0; */ + if ((err = mp_add(&b1, &b0, &b1)) != MP_OKAY) goto LBL_ERR; + + /** a1 = a1 * b1; */ + if ((err = mp_mul(&a1, &b1, &a1)) != MP_OKAY) goto LBL_ERR; + + /** b1 = a2 * b2; */ + if ((err = mp_mul(&a2, &b2, &b1)) != MP_OKAY) goto LBL_ERR; + + /** \\S2 = (S2 - S3)/3; */ + /** S2 = S2 - a1; */ + if ((err = mp_sub(&S2, &a1, &S2)) != MP_OKAY) goto LBL_ERR; + + /** S2 = S2 / 3; \\ this is an exact division */ + if ((err = mp_div_3(&S2, &S2, NULL)) != MP_OKAY) goto LBL_ERR; + + /** a1 = S1 - a1; */ + if ((err = mp_sub(&S1, &a1, &a1)) != MP_OKAY) goto LBL_ERR; + + /** a1 = a1 >> 1; */ + if ((err = mp_div_2(&a1, &a1)) != MP_OKAY) goto LBL_ERR; + + /** a0 = a0 * b0; */ + if ((err = mp_mul(&a0, &b0, &a0)) != MP_OKAY) goto LBL_ERR; + + /** S1 = S1 - a0; */ + if ((err = mp_sub(&S1, &a0, &S1)) != MP_OKAY) goto LBL_ERR; + + /** S2 = S2 - S1; */ + if ((err = mp_sub(&S2, &S1, &S2)) != MP_OKAY) goto LBL_ERR; + + /** S2 = S2 >> 1; */ + if ((err = mp_div_2(&S2, &S2)) != MP_OKAY) goto LBL_ERR; + + /** S1 = S1 - a1; */ + if ((err = mp_sub(&S1, &a1, &S1)) != MP_OKAY) goto LBL_ERR; + + /** S1 = S1 - b1; */ + if ((err = mp_sub(&S1, &b1, &S1)) != MP_OKAY) goto LBL_ERR; + + /** T1 = b1 << 1; */ + if ((err = mp_mul_2(&b1, &T1)) != MP_OKAY) goto LBL_ERR; + + /** S2 = S2 - T1; */ + if ((err = mp_sub(&S2, &T1, &S2)) != MP_OKAY) goto LBL_ERR; + + /** a1 = a1 - S2; */ + if ((err = mp_sub(&a1, &S2, &a1)) != MP_OKAY) goto LBL_ERR; + + + /** P = b1*x^4+ S2*x^3+ S1*x^2+ a1*x + a0; */ + if ((err = mp_lshd(&b1, 4 * B)) != MP_OKAY) goto LBL_ERR; + if ((err = mp_lshd(&S2, 3 * B)) != MP_OKAY) goto LBL_ERR; + if ((err = mp_add(&b1, &S2, &b1)) != MP_OKAY) goto LBL_ERR; + if ((err = mp_lshd(&S1, 2 * B)) != MP_OKAY) goto LBL_ERR; + if ((err = mp_add(&b1, &S1, &b1)) != MP_OKAY) goto LBL_ERR; + if ((err = mp_lshd(&a1, 1 * B)) != MP_OKAY) goto LBL_ERR; + if ((err = mp_add(&b1, &a1, &b1)) != MP_OKAY) goto LBL_ERR; + if ((err = mp_add(&b1, &a0, c)) != MP_OKAY) goto LBL_ERR; + + /** a * b - P */ + + +LBL_ERR: + mp_clear(&b2); +LBL_ERRb2: + mp_clear(&b1); +LBL_ERRb1: + mp_clear(&b0); +LBL_ERRb0: + mp_clear(&a2); +LBL_ERRa2: + mp_clear(&a1); +LBL_ERRa1: + mp_clear(&a0); +LBL_ERRa0: + mp_clear_multi(&S1, &S2, &T1, NULL); + return err; +} + +#endif ADDED libtommath/bn_s_mp_toom_sqr.c Index: libtommath/bn_s_mp_toom_sqr.c ================================================================== --- /dev/null +++ libtommath/bn_s_mp_toom_sqr.c @@ -0,0 +1,147 @@ +#include "tommath_private.h" +#ifdef BN_S_MP_TOOM_SQR_C +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +/* squaring using Toom-Cook 3-way algorithm */ + +/* + This file contains code from J. Arndt's book "Matters Computational" + and the accompanying FXT-library with permission of the author. +*/ + +/* squaring using Toom-Cook 3-way algorithm */ +/* + Setup and interpolation from algorithm SQR_3 in + + Chung, Jaewook, and M. Anwar Hasan. "Asymmetric squaring formulae." + 18th IEEE Symposium on Computer Arithmetic (ARITH'07). IEEE, 2007. + +*/ +mp_err s_mp_toom_sqr(const mp_int *a, mp_int *b) +{ + mp_int S0, a0, a1, a2; + mp_digit *tmpa, *tmpc; + int B, count; + mp_err err; + + + /* init temps */ + if ((err = mp_init(&S0)) != MP_OKAY) { + return err; + } + + /* B */ + B = a->used / 3; + + /** a = a2 * x^2 + a1 * x + a0; */ + if ((err = mp_init_size(&a0, B)) != MP_OKAY) goto LBL_ERRa0; + + a0.used = B; + if ((err = mp_init_size(&a1, B)) != MP_OKAY) goto LBL_ERRa1; + a1.used = B; + if ((err = mp_init_size(&a2, B + (a->used - (3 * B)))) != MP_OKAY) goto LBL_ERRa2; + + tmpa = a->dp; + tmpc = a0.dp; + for (count = 0; count < B; count++) { + *tmpc++ = *tmpa++; + } + tmpc = a1.dp; + for (; count < (2 * B); count++) { + *tmpc++ = *tmpa++; + } + tmpc = a2.dp; + for (; count < a->used; count++) { + *tmpc++ = *tmpa++; + a2.used++; + } + mp_clamp(&a0); + mp_clamp(&a1); + mp_clamp(&a2); + + /** S0 = a0^2; */ + if ((err = mp_sqr(&a0, &S0)) != MP_OKAY) goto LBL_ERR; + + /** \\S1 = (a2 + a1 + a0)^2 */ + /** \\S2 = (a2 - a1 + a0)^2 */ + /** \\S1 = a0 + a2; */ + /** a0 = a0 + a2; */ + if ((err = mp_add(&a0, &a2, &a0)) != MP_OKAY) goto LBL_ERR; + /** \\S2 = S1 - a1; */ + /** b = a0 - a1; */ + if ((err = mp_sub(&a0, &a1, b)) != MP_OKAY) goto LBL_ERR; + /** \\S1 = S1 + a1; */ + /** a0 = a0 + a1; */ + if ((err = mp_add(&a0, &a1, &a0)) != MP_OKAY) goto LBL_ERR; + /** \\S1 = S1^2; */ + /** a0 = a0^2; */ + if ((err = mp_sqr(&a0, &a0)) != MP_OKAY) goto LBL_ERR; + /** \\S2 = S2^2; */ + /** b = b^2; */ + if ((err = mp_sqr(b, b)) != MP_OKAY) goto LBL_ERR; + + /** \\ S3 = 2 * a1 * a2 */ + /** \\S3 = a1 * a2; */ + /** a1 = a1 * a2; */ + if ((err = mp_mul(&a1, &a2, &a1)) != MP_OKAY) goto LBL_ERR; + /** \\S3 = S3 << 1; */ + /** a1 = a1 << 1; */ + if ((err = mp_mul_2(&a1, &a1)) != MP_OKAY) goto LBL_ERR; + + /** \\S4 = a2^2; */ + /** a2 = a2^2; */ + if ((err = mp_sqr(&a2, &a2)) != MP_OKAY) goto LBL_ERR; + + /** \\ tmp = (S1 + S2)/2 */ + /** \\tmp = S1 + S2; */ + /** b = a0 + b; */ + if ((err = mp_add(&a0, b, b)) != MP_OKAY) goto LBL_ERR; + /** \\tmp = tmp >> 1; */ + /** b = b >> 1; */ + if ((err = mp_div_2(b, b)) != MP_OKAY) goto LBL_ERR; + + /** \\ S1 = S1 - tmp - S3 */ + /** \\S1 = S1 - tmp; */ + /** a0 = a0 - b; */ + if ((err = mp_sub(&a0, b, &a0)) != MP_OKAY) goto LBL_ERR; + /** \\S1 = S1 - S3; */ + /** a0 = a0 - a1; */ + if ((err = mp_sub(&a0, &a1, &a0)) != MP_OKAY) goto LBL_ERR; + + /** \\S2 = tmp - S4 -S0 */ + /** \\S2 = tmp - S4; */ + /** b = b - a2; */ + if ((err = mp_sub(b, &a2, b)) != MP_OKAY) goto LBL_ERR; + /** \\S2 = S2 - S0; */ + /** b = b - S0; */ + if ((err = mp_sub(b, &S0, b)) != MP_OKAY) goto LBL_ERR; + + + /** \\P = S4*x^4 + S3*x^3 + S2*x^2 + S1*x + S0; */ + /** P = a2*x^4 + a1*x^3 + b*x^2 + a0*x + S0; */ + + if ((err = mp_lshd(&a2, 4 * B)) != MP_OKAY) goto LBL_ERR; + if ((err = mp_lshd(&a1, 3 * B)) != MP_OKAY) goto LBL_ERR; + if ((err = mp_lshd(b, 2 * B)) != MP_OKAY) goto LBL_ERR; + if ((err = mp_lshd(&a0, 1 * B)) != MP_OKAY) goto LBL_ERR; + if ((err = mp_add(&a2, &a1, &a2)) != MP_OKAY) goto LBL_ERR; + if ((err = mp_add(&a2, b, b)) != MP_OKAY) goto LBL_ERR; + if ((err = mp_add(b, &a0, b)) != MP_OKAY) goto LBL_ERR; + if ((err = mp_add(b, &S0, b)) != MP_OKAY) goto LBL_ERR; + /** a^2 - P */ + + +LBL_ERR: + mp_clear(&a2); +LBL_ERRa2: + mp_clear(&a1); +LBL_ERRa1: + mp_clear(&a0); +LBL_ERRa0: + mp_clear(&S0); + + return err; +} + +#endif DELETED libtommath/bncore.c Index: libtommath/bncore.c ================================================================== --- libtommath/bncore.c +++ /dev/null @@ -1,33 +0,0 @@ -#include "tommath_private.h" -#ifdef BNCORE_C -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ - -/* Known optimal configurations - - CPU /Compiler /MUL CUTOFF/SQR CUTOFF -------------------------------------------------------------- - Intel P4 Northwood /GCC v3.4.1 / 88/ 128/LTM 0.32 ;-) - AMD Athlon64 /GCC v3.4.4 / 80/ 120/LTM 0.35 - -*/ - -int KARATSUBA_MUL_CUTOFF = 80, /* Min. number of digits before Karatsuba multiplication is used. */ - KARATSUBA_SQR_CUTOFF = 120, /* Min. number of digits before Karatsuba squaring is used. */ - - TOOM_MUL_CUTOFF = 350, /* no optimal values of these are known yet so set em high */ - TOOM_SQR_CUTOFF = 400; -#endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/changes.txt ================================================================== --- libtommath/changes.txt +++ libtommath/changes.txt @@ -1,5 +1,42 @@ +XXX XXth, 2019 +v1.2.0 + -- A huge refactoring of the library happened - renaming, + deprecating and replacing existing functions by improved API's. + + All deprecated functions, macros and symbols are only marked as such + so this version is still API and ABI compatible to v1.x. + + -- Daniel Mendler was pushing for those changes and contributing a load of patches, + refactorings, code reviews and whatnotelse. + -- Christoph Zurnieden re-worked internals of the library, improved the performance, + did code reviews and wrote documentation. + -- Francois Perrad did some refactoring and took again care of linting the sources and + provided all fixes. + -- Jan Nijtmans, Karel Miko and Joachim Breitner contributed various patches. + + -- Private symbols can now be hidden for the shared library builds, disabled by default. + -- All API's follow a single code style, are prefixed the same etc. + -- Unified, safer and improved API's + -- Less magic numbers - return values (where appropriate) and most flags are now enums, + this was implemented in a backwards compatible way where return values were int. + -- API's with return values are now by default marked as "warn on unsused result", this + can be disabled if required (which will most likely hide bugs), c.f. MP_WUR in tommath.h + -- Provide a whole set of setters&getters for different primitive types (long, uint32_t, etc.) + -- All those primitive setters are now optimized. + -- It's possible to automatically tune the cutoff values for Karatsuba&Toom-Cook + -- The custom allocators which were formerly known as XMALLOC(), XFREE() etc. are now available + as MP_MALLOC(), MP_REALLOC(), MP_CALLOC() and MP_FREE(). MP_REALLOC() and MP_FREE() now also + provide the allocated size to ease the usage of simple allocators without tracking. + -- Building is now also possible with MSVC 2015, 2017 and 2019 (use makefile.msvc) + -- Added mp_decr() and mp_incr() + -- Added mp_log_u32() + -- Improved prime-checking + -- Improved Toom-Cook multiplication + -- Removed the LTM book (`make docs` now builds the user manual) + + Jan 28th, 2019 v1.1.0 -- Christoph Zurnieden contributed FIPS 186.4 compliant prime-checking (PR #113), several other fixes and a load of documentation -- Daniel Mendler provided two's-complement functions (PR #124) ADDED libtommath/helper.pl Index: libtommath/helper.pl ================================================================== --- /dev/null +++ libtommath/helper.pl @@ -0,0 +1,482 @@ +#!/usr/bin/env perl + +use strict; +use warnings; + +use Getopt::Long; +use File::Find 'find'; +use File::Basename 'basename'; +use File::Glob 'bsd_glob'; + +sub read_file { + my $f = shift; + open my $fh, "<", $f or die "FATAL: read_rawfile() cannot open file '$f': $!"; + binmode $fh; + return do { local $/; <$fh> }; +} + +sub write_file { + my ($f, $data) = @_; + die "FATAL: write_file() no data" unless defined $data; + open my $fh, ">", $f or die "FATAL: write_file() cannot open file '$f': $!"; + binmode $fh; + print $fh $data or die "FATAL: write_file() cannot write to '$f': $!"; + close $fh or die "FATAL: write_file() cannot close '$f': $!"; + return; +} + +sub sanitize_comments { + my($content) = @_; + $content =~ s{/\*(.*?)\*/}{my $x=$1; $x =~ s/\w/x/g; "/*$x*/";}egs; + return $content; +} + +sub check_source { + my @all_files = ( + bsd_glob("makefile*"), + bsd_glob("*.{h,c,sh,pl}"), + bsd_glob("*/*.{h,c,sh,pl}"), + ); + + my $fails = 0; + for my $file (sort @all_files) { + my $troubles = {}; + my $lineno = 1; + my $content = read_file($file); + $content = sanitize_comments $content; + push @{$troubles->{crlf_line_end}}, '?' if $content =~ /\r/; + for my $l (split /\n/, $content) { + push @{$troubles->{merge_conflict}}, $lineno if $l =~ /^(<<<<<<<|=======|>>>>>>>)([^<=>]|$)/; + push @{$troubles->{trailing_space}}, $lineno if $l =~ / $/; + push @{$troubles->{tab}}, $lineno if $l =~ /\t/ && basename($file) !~ /^makefile/i; + push @{$troubles->{non_ascii_char}}, $lineno if $l =~ /[^[:ascii:]]/; + push @{$troubles->{cpp_comment}}, $lineno if $file =~ /\.(c|h)$/ && ($l =~ /\s\/\// || $l =~ /\/\/\s/); + # we prefer using XMALLOC, XFREE, XREALLOC, XCALLOC ... + push @{$troubles->{unwanted_malloc}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bmalloc\s*\(/; + push @{$troubles->{unwanted_realloc}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\brealloc\s*\(/; + push @{$troubles->{unwanted_calloc}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bcalloc\s*\(/; + push @{$troubles->{unwanted_free}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bfree\s*\(/; + # and we probably want to also avoid the following + push @{$troubles->{unwanted_memcpy}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bmemcpy\s*\(/; + push @{$troubles->{unwanted_memset}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bmemset\s*\(/; + push @{$troubles->{unwanted_memcpy}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bmemcpy\s*\(/; + push @{$troubles->{unwanted_memmove}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bmemmove\s*\(/; + push @{$troubles->{unwanted_memcmp}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bmemcmp\s*\(/; + push @{$troubles->{unwanted_strcmp}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bstrcmp\s*\(/; + push @{$troubles->{unwanted_strcpy}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bstrcpy\s*\(/; + push @{$troubles->{unwanted_strncpy}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bstrncpy\s*\(/; + push @{$troubles->{unwanted_clock}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bclock\s*\(/; + push @{$troubles->{unwanted_qsort}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bqsort\s*\(/; + push @{$troubles->{sizeof_no_brackets}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bsizeof\s*[^\(]/; + if ($file =~ m|^[^\/]+\.c$| && $l =~ /^static(\s+[a-zA-Z0-9_]+)+\s+([a-zA-Z0-9_]+)\s*\(/) { + my $funcname = $2; + # static functions should start with s_ + push @{$troubles->{staticfunc_name}}, "$lineno($funcname)" if $funcname !~ /^s_/; + } + $lineno++; + } + for my $k (sort keys %$troubles) { + warn "[$k] $file line:" . join(",", @{$troubles->{$k}}) . "\n"; + $fails++; + } + } + + warn( $fails > 0 ? "check-source: FAIL $fails\n" : "check-source: PASS\n" ); + return $fails; +} + +sub check_comments { + my $fails = 0; + my $first_comment = <<'MARKER'; +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ +MARKER + #my @all_files = (bsd_glob("*.{h,c}"), bsd_glob("*/*.{h,c}")); + my @all_files = (bsd_glob("*.{h,c}")); + for my $f (@all_files) { + my $txt = read_file($f); + if ($txt !~ /\Q$first_comment\E/s) { + warn "[first_comment] $f\n"; + $fails++; + } + } + warn( $fails > 0 ? "check-comments: FAIL $fails\n" : "check-comments: PASS\n" ); + return $fails; +} + +sub check_doc { + my $fails = 0; + my $tex = read_file('doc/bn.tex'); + my $tmh = read_file('tommath.h'); + my @functions = $tmh =~ /\n\s*[a-zA-Z0-9_* ]+?(mp_[a-z0-9_]+)\s*\([^\)]+\)\s*;/sg; + my @macros = $tmh =~ /\n\s*#define\s+([a-z0-9_]+)\s*\([^\)]+\)/sg; + for my $n (sort @functions) { + (my $nn = $n) =~ s/_/\\_/g; # mp_sub_d >> mp\_sub\_d + if ($tex !~ /index\Q{$nn}\E/) { + warn "[missing_doc_for_function] $n\n"; + $fails++ + } + } + for my $n (sort @macros) { + (my $nn = $n) =~ s/_/\\_/g; # mp_iszero >> mp\_iszero + if ($tex !~ /index\Q{$nn}\E/) { + warn "[missing_doc_for_macro] $n\n"; + $fails++ + } + } + warn( $fails > 0 ? "check_doc: FAIL $fails\n" : "check-doc: PASS\n" ); + return $fails; +} + +sub prepare_variable { + my ($varname, @list) = @_; + my $output = "$varname="; + my $len = length($output); + foreach my $obj (sort @list) { + $len = $len + length $obj; + $obj =~ s/\*/\$/; + if ($len > 100) { + $output .= "\\\n"; + $len = length $obj; + } + $output .= $obj . ' '; + } + $output =~ s/ $//; + return $output; +} + +sub prepare_msvc_files_xml { + my ($all, $exclude_re, $targets) = @_; + my $last = []; + my $depth = 2; + + # sort files in the same order as visual studio (ugly, I know) + my @parts = (); + for my $orig (@$all) { + my $p = $orig; + $p =~ s|/|/~|g; + $p =~ s|/~([^/]+)$|/$1|g; + my @l = map { sprintf "% -99s", $_ } split /\//, $p; + push @parts, [ $orig, join(':', @l) ]; + } + my @sorted = map { $_->[0] } sort { $a->[1] cmp $b->[1] } @parts; + + my $files = "\r\n"; + for my $full (@sorted) { + my @items = split /\//, $full; # split by '/' + $full =~ s|/|\\|g; # replace '/' bt '\' + shift @items; # drop first one (src) + pop @items; # drop last one (filename.ext) + my $current = \@items; + if (join(':', @$current) ne join(':', @$last)) { + my $common = 0; + $common++ while ($last->[$common] && $current->[$common] && $last->[$common] eq $current->[$common]); + my $back = @$last - $common; + if ($back > 0) { + $files .= ("\t" x --$depth) . "\r\n" for (1..$back); + } + my $fwd = [ @$current ]; splice(@$fwd, 0, $common); + for my $i (0..scalar(@$fwd) - 1) { + $files .= ("\t" x $depth) . "[$i]\"\r\n"; + $files .= ("\t" x $depth) . "\t>\r\n"; + $depth++; + } + $last = $current; + } + $files .= ("\t" x $depth) . "\r\n"; + if ($full =~ $exclude_re) { + for (@$targets) { + $files .= ("\t" x $depth) . "\t\r\n"; + $files .= ("\t" x $depth) . "\t\t\r\n"; + $files .= ("\t" x $depth) . "\t\r\n"; + } + } + $files .= ("\t" x $depth) . "\r\n"; + } + $files .= ("\t" x --$depth) . "\r\n" for (@$last); + $files .= "\t"; + return $files; +} + +sub patch_file { + my ($content, @variables) = @_; + for my $v (@variables) { + if ($v =~ /^([A-Z0-9_]+)\s*=.*$/si) { + my $name = $1; + $content =~ s/\n\Q$name\E\b.*?[^\\]\n/\n$v\n/s; + } + else { + die "patch_file failed: " . substr($v, 0, 30) . ".."; + } + } + return $content; +} + +sub process_makefiles { + my $write = shift; + my $changed_count = 0; + my @o = map { my $x = $_; $x =~ s/\.c$/.o/; $x } bsd_glob("*.c"); + my @all = bsd_glob("*.{c,h}"); + + my $var_o = prepare_variable("OBJECTS", @o); + (my $var_obj = $var_o) =~ s/\.o\b/.obj/sg; + + # update MSVC project files + my $msvc_files = prepare_msvc_files_xml(\@all, qr/NOT_USED_HERE/, ['Debug|Win32', 'Release|Win32', 'Debug|x64', 'Release|x64']); + for my $m (qw/libtommath_VS2008.vcproj/) { + my $old = read_file($m); + my $new = $old; + $new =~ s|.*|$msvc_files|s; + if ($old ne $new) { + write_file($m, $new) if $write; + warn "changed: $m\n"; + $changed_count++; + } + } + + # update OBJECTS + HEADERS in makefile* + for my $m (qw/ makefile makefile.shared makefile_include.mk makefile.msvc makefile.unix makefile.mingw /) { + my $old = read_file($m); + my $new = $m eq 'makefile.msvc' ? patch_file($old, $var_obj) + : patch_file($old, $var_o); + if ($old ne $new) { + write_file($m, $new) if $write; + warn "changed: $m\n"; + $changed_count++; + } + } + + if ($write) { + return 0; # no failures + } + else { + warn( $changed_count > 0 ? "check-makefiles: FAIL $changed_count\n" : "check-makefiles: PASS\n" ); + return $changed_count; + } +} + +sub draw_func +{ + my ($deplist, $depmap, $out, $indent, $funcslist) = @_; + my @funcs = split ',', $funcslist; + # try this if you want to have a look at a minimized version of the callgraph without all the trivial functions + #if ($deplist =~ /$funcs[0]/ || $funcs[0] =~ /BN_MP_(ADD|SUB|CLEAR|CLEAR_\S+|DIV|MUL|COPY|ZERO|GROW|CLAMP|INIT|INIT_\S+|SET|ABS|CMP|CMP_D|EXCH)_C/) { + if ($deplist =~ /$funcs[0]/) { + return $deplist; + } else { + $deplist = $deplist . $funcs[0]; + } + if ($indent == 0) { + } elsif ($indent >= 1) { + print {$out} '| ' x ($indent - 1) . '+--->'; + } + print {$out} $funcs[0] . "\n"; + shift @funcs; + my $olddeplist = $deplist; + foreach my $i (@funcs) { + $deplist = draw_func($deplist, $depmap, $out, $indent + 1, ${$depmap}{$i}) if exists ${$depmap}{$i}; + } + return $olddeplist; +} + +sub update_dep +{ + #open class file and write preamble + open(my $class, '>', 'tommath_class.h') or die "Couldn't open tommath_class.h for writing\n"; + print {$class} << 'EOS'; +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +#if !(defined(LTM1) && defined(LTM2) && defined(LTM3)) +#define LTM_INSIDE +#if defined(LTM2) +# define LTM3 +#endif +#if defined(LTM1) +# define LTM2 +#endif +#define LTM1 +#if defined(LTM_ALL) +EOS + + foreach my $filename (glob 'bn*.c') { + my $define = $filename; + + print "Processing $filename\n"; + + # convert filename to upper case so we can use it as a define + $define =~ tr/[a-z]/[A-Z]/; + $define =~ tr/\./_/; + print {$class} "# define $define\n"; + + # now copy text and apply #ifdef as required + my $apply = 0; + open(my $src, '<', $filename); + open(my $out, '>', 'tmp'); + + # first line will be the #ifdef + my $line = <$src>; + if ($line =~ /include/) { + print {$out} $line; + } else { + print {$out} << "EOS"; +#include "tommath_private.h" +#ifdef $define +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ +$line +EOS + $apply = 1; + } + while (<$src>) { + if ($_ !~ /tommath\.h/) { + print {$out} $_; + } + } + if ($apply == 1) { + print {$out} "#endif\n"; + } + close $src; + close $out; + + unlink $filename; + rename 'tmp', $filename; + } + print {$class} "#endif\n#endif\n"; + + # now do classes + my %depmap; + foreach my $filename (glob 'bn*.c') { + my $content; + if ($filename =~ "bn_deprecated.c") { + open(my $src, '<', $filename) or die "Can't open source file!\n"; + read $src, $content, -s $src; + close $src; + } else { + my $cc = $ENV{'CC'} || 'gcc'; + $content = `$cc -E -x c -DLTM_ALL $filename`; + $content =~ s/^# 1 "$filename".*?^# 2 "$filename"//ms; + } + + # convert filename to upper case so we can use it as a define + $filename =~ tr/[a-z]/[A-Z]/; + $filename =~ tr/\./_/; + + print {$class} "#if defined($filename)\n"; + my $list = $filename; + + # strip comments + $content =~ s{/\*.*?\*/}{}gs; + + # scan for mp_* and make classes + my @deps = (); + foreach my $line (split /\n/, $content) { + while ($line =~ /(fast_)?(s_)?mp\_[a-z_0-9]*((?=\;)|(?=\())|(?<=\()mp\_[a-z_0-9]*(?=\()/g) { + my $a = $&; + next if $a eq "mp_err"; + $a =~ tr/[a-z]/[A-Z]/; + $a = 'BN_' . $a . '_C'; + push @deps, $a; + } + } + @deps = sort(@deps); + foreach my $a (@deps) { + if ($list !~ /$a/) { + print {$class} "# define $a\n"; + } + $list = $list . ',' . $a; + } + $depmap{$filename} = $list; + + print {$class} "#endif\n\n"; + } + + print {$class} << 'EOS'; +#ifdef LTM_INSIDE +#undef LTM_INSIDE +#ifdef LTM3 +# define LTM_LAST +#endif + +#include "tommath_superclass.h" +#include "tommath_class.h" +#else +# define LTM_LAST +#endif +EOS + close $class; + + #now let's make a cool call graph... + + open(my $out, '>', 'callgraph.txt'); + foreach (sort keys %depmap) { + draw_func("", \%depmap, $out, 0, $depmap{$_}); + print {$out} "\n\n"; + } + close $out; + + return 0; +} + +sub generate_def { + my @files = split /\n/, `git ls-files`; + @files = grep(/\.c/, @files); + @files = map { my $x = $_; $x =~ s/^bn_|\.c$//g; $x; } @files; + @files = grep(!/mp_radix_smap/, @files); + + push(@files, qw(mp_set_int mp_set_long mp_set_long_long mp_get_int mp_get_long mp_get_long_long mp_init_set_int)); + + my $files = join("\n ", sort(grep(/^mp_/, @files))); + write_file "tommath.def", "; libtommath +; +; Use this command to produce a 32-bit .lib file, for use in any MSVC version +; lib -machine:X86 -name:libtommath.dll -def:tommath.def -out:tommath.lib +; Use this command to produce a 64-bit .lib file, for use in any MSVC version +; lib -machine:X64 -name:libtommath.dll -def:tommath.def -out:tommath.lib +; +EXPORTS + $files +"; + return 0; +} + +sub die_usage { + die <<"MARKER"; +usage: $0 -s OR $0 --check-source + $0 -o OR $0 --check-comments + $0 -m OR $0 --check-makefiles + $0 -a OR $0 --check-all + $0 -u OR $0 --update-files +MARKER +} + +GetOptions( "s|check-source" => \my $check_source, + "o|check-comments" => \my $check_comments, + "m|check-makefiles" => \my $check_makefiles, + "d|check-doc" => \my $check_doc, + "a|check-all" => \my $check_all, + "u|update-files" => \my $update_files, + "h|help" => \my $help + ) or die_usage; + +my $failure; +$failure ||= check_source() if $check_all || $check_source; +$failure ||= check_comments() if $check_all || $check_comments; +$failure ||= check_doc() if $check_doc; # temporarily excluded from --check-all +$failure ||= process_makefiles(0) if $check_all || $check_makefiles; +$failure ||= process_makefiles(1) if $update_files; +$failure ||= update_dep() if $update_files; +$failure ||= generate_def() if $update_files; + +die_usage unless defined $failure; +exit $failure ? 1 : 0; Index: libtommath/libtommath_VS2008.sln ================================================================== --- libtommath/libtommath_VS2008.sln +++ libtommath/libtommath_VS2008.sln Index: libtommath/libtommath_VS2008.vcproj ================================================================== --- libtommath/libtommath_VS2008.vcproj +++ libtommath/libtommath_VS2008.vcproj @@ -311,31 +311,15 @@ - - - - - - - - @@ -397,10 +381,14 @@ > + + @@ -429,134 +417,174 @@ > + + - - - - - - + + + + - - + + + + + + + + + + + + + + + + + + - - + + + + + + - - + + @@ -601,38 +629,34 @@ > - - - - + + + + - - @@ -647,11 +671,11 @@ @@ -669,18 +693,10 @@ > - - - - @@ -709,14 +725,22 @@ > + + + + @@ -723,27 +747,47 @@ + + + + + + + + + + @@ -771,59 +815,27 @@ - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + @@ -833,50 +845,114 @@ > - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Index: libtommath/makefile ================================================================== --- libtommath/makefile +++ libtommath/makefile @@ -15,50 +15,51 @@ coverage: LIBNAME:=-Wl,--whole-archive $(LIBNAME) -Wl,--no-whole-archive include makefile_include.mk -%.o: %.c +%.o: %.c $(HEADERS) ifneq ($V,1) @echo " * ${CC} $@" endif - ${silent} ${CC} -c ${CFLAGS} $< -o $@ + ${silent} ${CC} -c ${LTM_CFLAGS} $< -o $@ LCOV_ARGS=--directory . #START_INS -OBJECTS=bn_error.o bn_fast_mp_invmod.o bn_fast_mp_montgomery_reduce.o bn_fast_s_mp_mul_digs.o \ -bn_fast_s_mp_mul_high_digs.o bn_fast_s_mp_sqr.o bn_mp_2expt.o bn_mp_abs.o bn_mp_add.o bn_mp_add_d.o \ -bn_mp_addmod.o bn_mp_and.o bn_mp_clamp.o bn_mp_clear.o bn_mp_clear_multi.o bn_mp_cmp.o bn_mp_cmp_d.o \ -bn_mp_cmp_mag.o bn_mp_cnt_lsb.o bn_mp_complement.o bn_mp_copy.o bn_mp_count_bits.o bn_mp_div.o \ -bn_mp_div_2.o bn_mp_div_2d.o bn_mp_div_3.o bn_mp_div_d.o bn_mp_dr_is_modulus.o bn_mp_dr_reduce.o \ -bn_mp_dr_setup.o bn_mp_exch.o bn_mp_export.o bn_mp_expt_d.o bn_mp_expt_d_ex.o bn_mp_exptmod.o \ -bn_mp_exptmod_fast.o bn_mp_exteuclid.o bn_mp_fread.o bn_mp_fwrite.o bn_mp_gcd.o bn_mp_get_bit.o \ -bn_mp_get_double.o bn_mp_get_int.o bn_mp_get_long.o bn_mp_get_long_long.o bn_mp_grow.o bn_mp_import.o \ -bn_mp_init.o bn_mp_init_copy.o bn_mp_init_multi.o bn_mp_init_set.o bn_mp_init_set_int.o bn_mp_init_size.o \ -bn_mp_invmod.o bn_mp_invmod_slow.o bn_mp_is_square.o bn_mp_jacobi.o bn_mp_karatsuba_mul.o \ -bn_mp_karatsuba_sqr.o bn_mp_kronecker.o bn_mp_lcm.o bn_mp_lshd.o bn_mp_mod.o bn_mp_mod_2d.o bn_mp_mod_d.o \ -bn_mp_montgomery_calc_normalization.o bn_mp_montgomery_reduce.o bn_mp_montgomery_setup.o bn_mp_mul.o \ -bn_mp_mul_2.o bn_mp_mul_2d.o bn_mp_mul_d.o bn_mp_mulmod.o bn_mp_n_root.o bn_mp_n_root_ex.o bn_mp_neg.o \ -bn_mp_or.o bn_mp_prime_fermat.o bn_mp_prime_frobenius_underwood.o bn_mp_prime_is_divisible.o \ +OBJECTS=bn_cutoffs.o bn_deprecated.o bn_mp_2expt.o bn_mp_abs.o bn_mp_add.o bn_mp_add_d.o bn_mp_addmod.o \ +bn_mp_and.o bn_mp_clamp.o bn_mp_clear.o bn_mp_clear_multi.o bn_mp_cmp.o bn_mp_cmp_d.o bn_mp_cmp_mag.o \ +bn_mp_cnt_lsb.o bn_mp_complement.o bn_mp_copy.o bn_mp_count_bits.o bn_mp_decr.o bn_mp_div.o bn_mp_div_2.o \ +bn_mp_div_2d.o bn_mp_div_3.o bn_mp_div_d.o bn_mp_dr_is_modulus.o bn_mp_dr_reduce.o bn_mp_dr_setup.o \ +bn_mp_error_to_string.o bn_mp_exch.o bn_mp_expt_u32.o bn_mp_exptmod.o bn_mp_exteuclid.o bn_mp_fread.o \ +bn_mp_from_sbin.o bn_mp_from_ubin.o bn_mp_fwrite.o bn_mp_gcd.o bn_mp_get_double.o bn_mp_get_i32.o \ +bn_mp_get_i64.o bn_mp_get_l.o bn_mp_get_ll.o bn_mp_get_mag_u32.o bn_mp_get_mag_u64.o bn_mp_get_mag_ul.o \ +bn_mp_get_mag_ull.o bn_mp_grow.o bn_mp_incr.o bn_mp_init.o bn_mp_init_copy.o bn_mp_init_i32.o \ +bn_mp_init_i64.o bn_mp_init_l.o bn_mp_init_ll.o bn_mp_init_multi.o bn_mp_init_set.o bn_mp_init_size.o \ +bn_mp_init_u32.o bn_mp_init_u64.o bn_mp_init_ul.o bn_mp_init_ull.o bn_mp_invmod.o bn_mp_is_square.o \ +bn_mp_iseven.o bn_mp_isodd.o bn_mp_kronecker.o bn_mp_lcm.o bn_mp_log_u32.o bn_mp_lshd.o bn_mp_mod.o \ +bn_mp_mod_2d.o bn_mp_mod_d.o bn_mp_montgomery_calc_normalization.o bn_mp_montgomery_reduce.o \ +bn_mp_montgomery_setup.o bn_mp_mul.o bn_mp_mul_2.o bn_mp_mul_2d.o bn_mp_mul_d.o bn_mp_mulmod.o bn_mp_neg.o \ +bn_mp_or.o bn_mp_pack.o bn_mp_pack_count.o bn_mp_prime_fermat.o bn_mp_prime_frobenius_underwood.o \ bn_mp_prime_is_prime.o bn_mp_prime_miller_rabin.o bn_mp_prime_next_prime.o \ -bn_mp_prime_rabin_miller_trials.o bn_mp_prime_random_ex.o bn_mp_prime_strong_lucas_selfridge.o \ -bn_mp_radix_size.o bn_mp_radix_smap.o bn_mp_rand.o bn_mp_read_radix.o bn_mp_read_signed_bin.o \ -bn_mp_read_unsigned_bin.o bn_mp_reduce.o bn_mp_reduce_2k.o bn_mp_reduce_2k_l.o bn_mp_reduce_2k_setup.o \ -bn_mp_reduce_2k_setup_l.o bn_mp_reduce_is_2k.o bn_mp_reduce_is_2k_l.o bn_mp_reduce_setup.o bn_mp_rshd.o \ -bn_mp_set.o bn_mp_set_double.o bn_mp_set_int.o bn_mp_set_long.o bn_mp_set_long_long.o bn_mp_shrink.o \ -bn_mp_signed_bin_size.o bn_mp_sqr.o bn_mp_sqrmod.o bn_mp_sqrt.o bn_mp_sqrtmod_prime.o bn_mp_sub.o \ -bn_mp_sub_d.o bn_mp_submod.o bn_mp_tc_and.o bn_mp_tc_div_2d.o bn_mp_tc_or.o bn_mp_tc_xor.o \ -bn_mp_to_signed_bin.o bn_mp_to_signed_bin_n.o bn_mp_to_unsigned_bin.o bn_mp_to_unsigned_bin_n.o \ -bn_mp_toom_mul.o bn_mp_toom_sqr.o bn_mp_toradix.o bn_mp_toradix_n.o bn_mp_unsigned_bin_size.o bn_mp_xor.o \ -bn_mp_zero.o bn_prime_tab.o bn_reverse.o bn_s_mp_add.o bn_s_mp_exptmod.o bn_s_mp_mul_digs.o \ -bn_s_mp_mul_high_digs.o bn_s_mp_sqr.o bn_s_mp_sub.o bncore.o +bn_mp_prime_rabin_miller_trials.o bn_mp_prime_rand.o bn_mp_prime_strong_lucas_selfridge.o \ +bn_mp_radix_size.o bn_mp_radix_smap.o bn_mp_rand.o bn_mp_read_radix.o bn_mp_reduce.o bn_mp_reduce_2k.o \ +bn_mp_reduce_2k_l.o bn_mp_reduce_2k_setup.o bn_mp_reduce_2k_setup_l.o bn_mp_reduce_is_2k.o \ +bn_mp_reduce_is_2k_l.o bn_mp_reduce_setup.o bn_mp_root_u32.o bn_mp_rshd.o bn_mp_sbin_size.o bn_mp_set.o \ +bn_mp_set_double.o bn_mp_set_i32.o bn_mp_set_i64.o bn_mp_set_l.o bn_mp_set_ll.o bn_mp_set_u32.o \ +bn_mp_set_u64.o bn_mp_set_ul.o bn_mp_set_ull.o bn_mp_shrink.o bn_mp_signed_rsh.o bn_mp_sqr.o \ +bn_mp_sqrmod.o bn_mp_sqrt.o bn_mp_sqrtmod_prime.o bn_mp_sub.o bn_mp_sub_d.o bn_mp_submod.o \ +bn_mp_to_radix.o bn_mp_to_sbin.o bn_mp_to_ubin.o bn_mp_ubin_size.o bn_mp_unpack.o bn_mp_xor.o bn_mp_zero.o \ +bn_prime_tab.o bn_s_mp_add.o bn_s_mp_balance_mul.o bn_s_mp_exptmod.o bn_s_mp_exptmod_fast.o \ +bn_s_mp_get_bit.o bn_s_mp_invmod_fast.o bn_s_mp_invmod_slow.o bn_s_mp_karatsuba_mul.o \ +bn_s_mp_karatsuba_sqr.o bn_s_mp_montgomery_reduce_fast.o bn_s_mp_mul_digs.o bn_s_mp_mul_digs_fast.o \ +bn_s_mp_mul_high_digs.o bn_s_mp_mul_high_digs_fast.o bn_s_mp_prime_is_divisible.o \ +bn_s_mp_rand_jenkins.o bn_s_mp_rand_platform.o bn_s_mp_reverse.o bn_s_mp_sqr.o bn_s_mp_sqr_fast.o \ +bn_s_mp_sub.o bn_s_mp_toom_mul.o bn_s_mp_toom_sqr.o #END_INS -$(OBJECTS): $(HEADERS) - $(LIBNAME): $(OBJECTS) $(AR) $(ARFLAGS) $@ $(OBJECTS) $(RANLIB) $@ #make a profiled library (takes a while!!!) @@ -74,15 +75,15 @@ make CFLAGS="$(CFLAGS) -fbranch-probabilities" #make a single object profiled library profiled_single: perl gen.pl - $(CC) $(CFLAGS) -fprofile-arcs -DTESTING -c mpi.c -o mpi.o - $(CC) $(CFLAGS) -DTESTING -DTIMER demo/timing.c mpi.o -lgcov -o timing + $(CC) $(LTM_CFLAGS) -fprofile-arcs -DTESTING -c mpi.c -o mpi.o + $(CC) $(LTM_CFLAGS) -DTESTING -DTIMER demo/timing.c mpi.o -lgcov -o timing ./timing rm -f *.o timing - $(CC) $(CFLAGS) -fbranch-probabilities -DTESTING -c mpi.c -o mpi.o + $(CC) $(LTM_CFLAGS) -fbranch-probabilities -DTESTING -c mpi.c -o mpi.o $(AR) $(ARFLAGS) $(LIBNAME) mpi.o ranlib $(LIBNAME) install: $(LIBNAME) install -d $(DESTDIR)$(LIBPATH) @@ -92,42 +93,49 @@ uninstall: rm $(DESTDIR)$(LIBPATH)/$(LIBNAME) rm $(HEADERS_PUB:%=$(DESTDIR)$(INCPATH)/%) -test: $(LIBNAME) demo/demo.o - $(CC) $(CFLAGS) demo/demo.o $(LIBNAME) $(LFLAGS) -o test +test_standalone: test + @echo "test_standalone is deprecated, please use make-target 'test'" + +DEMOS=test mtest_opponent + +define DEMO_template +$(1): demo/$(1).o demo/shared.o $$(LIBNAME) + $$(CC) $$(LTM_CFLAGS) $$(LTM_LFLAGS) $$^ -o $$@ +endef -test_standalone: $(LIBNAME) demo/demo.o - $(CC) $(CFLAGS) demo/demo.o $(LIBNAME) $(LFLAGS) -o test +$(foreach demo, $(strip $(DEMOS)), $(eval $(call DEMO_template,$(demo)))) .PHONY: mtest mtest: - cd mtest ; $(CC) $(CFLAGS) -O0 mtest.c $(LFLAGS) -o mtest + cd mtest ; $(CC) $(LTM_CFLAGS) -O0 mtest.c $(LTM_LFLAGS) -o mtest timing: $(LIBNAME) demo/timing.c - $(CC) $(CFLAGS) -DTIMER demo/timing.c $(LIBNAME) $(LFLAGS) -o timing + $(CC) $(LTM_CFLAGS) -DTIMER demo/timing.c $(LIBNAME) $(LTM_LFLAGS) -o timing + +tune: $(LIBNAME) + $(MAKE) -C etc tune CFLAGS="$(LTM_CFLAGS)" + $(MAKE) # You have to create a file .coveralls.yml with the content "repo_token: " # in the base folder to be able to submit to coveralls coveralls: lcov coveralls-lcov -docdvi poster docs mandvi manual: +docs manual: $(MAKE) -C doc/ $@ V=$(V) -pretty: - perl pretty.build - .PHONY: pre_gen pre_gen: mkdir -p pre_gen perl gen.pl sed -e 's/[[:blank:]]*$$//' mpi.c > pre_gen/mpi.c rm mpi.c -zipup: clean astyle new_file manual poster docs +zipup: clean astyle new_file docs @# Update the index, so diff-index won't fail in case the pdf has been created. @# As the pdf creation modifies the tex files, git sometimes detects the @# modified files, but misses that it's put back to its original version. @git update-index --refresh @git diff-index --quiet HEAD -- || ( echo "FAILURE: uncommited changes or not a git" && exit 1 ) @@ -135,24 +143,23 @@ @# files/dirs excluded from "git archive" are defined in .gitattributes git archive --format=tar --prefix=libtommath-$(VERSION)/ HEAD | tar x @echo 'fixme check' -@(find libtommath-$(VERSION)/ -type f | xargs grep 'FIXM[E]') && echo '############## BEWARE: the "fixme" marker was found !!! ##############' || true mkdir -p libtommath-$(VERSION)/doc - cp doc/bn.pdf doc/tommath.pdf doc/poster.pdf libtommath-$(VERSION)/doc/ + cp doc/bn.pdf libtommath-$(VERSION)/doc/ $(MAKE) -C libtommath-$(VERSION)/ pre_gen tar -c libtommath-$(VERSION)/ | xz -6e -c - > ltm-$(VERSION).tar.xz zip -9rq ltm-$(VERSION).zip libtommath-$(VERSION) cp doc/bn.pdf bn-$(VERSION).pdf - cp doc/tommath.pdf tommath-$(VERSION).pdf rm -rf libtommath-$(VERSION) gpg -b -a ltm-$(VERSION).tar.xz gpg -b -a ltm-$(VERSION).zip new_file: - bash updatemakes.sh - perl dep.pl + perl helper.pl --update-files perlcritic: perlcritic *.pl doc/*.pl astyle: - astyle --options=astylerc $(OBJECTS:.o=.c) tommath*.h demo/*.c etc/*.c mtest/mtest.c + @echo " * run astyle on all sources" + @astyle --options=astylerc --formatted $(OBJECTS:.o=.c) tommath*.h demo/*.c etc/*.c mtest/mtest.c Index: libtommath/makefile.mingw ================================================================== --- libtommath/makefile.mingw +++ libtommath/makefile.mingw @@ -1,8 +1,8 @@ # MAKEFILE for MS Windows (mingw + gcc + gmake) # -# BEWARE: variable OBJECTS is updated via ./updatemakes.sh +# BEWARE: variable OBJECTS is updated via helper.pl ### USAGE: # Open a command prompt with gcc + gmake in PATH and start: # # gmake -f makefile.mingw all @@ -19,48 +19,50 @@ CFLAGS = -O2 LDFLAGS = #Compilation flags LTM_CFLAGS = -I. $(CFLAGS) -LTM_LDFLAGS = $(LDFLAGS) +LTM_LDFLAGS = $(LDFLAGS) -static-libgcc #Libraries to be created LIBMAIN_S =libtommath.a LIBMAIN_I =libtommath.dll.a LIBMAIN_D =libtommath.dll #List of objects to compile (all goes to libtommath.a) -OBJECTS=bn_error.o bn_fast_mp_invmod.o bn_fast_mp_montgomery_reduce.o bn_fast_s_mp_mul_digs.o \ -bn_fast_s_mp_mul_high_digs.o bn_fast_s_mp_sqr.o bn_mp_2expt.o bn_mp_abs.o bn_mp_add.o bn_mp_add_d.o \ -bn_mp_addmod.o bn_mp_and.o bn_mp_clamp.o bn_mp_clear.o bn_mp_clear_multi.o bn_mp_cmp.o bn_mp_cmp_d.o \ -bn_mp_cmp_mag.o bn_mp_cnt_lsb.o bn_mp_complement.o bn_mp_copy.o bn_mp_count_bits.o bn_mp_div.o \ -bn_mp_div_2.o bn_mp_div_2d.o bn_mp_div_3.o bn_mp_div_d.o bn_mp_dr_is_modulus.o bn_mp_dr_reduce.o \ -bn_mp_dr_setup.o bn_mp_exch.o bn_mp_export.o bn_mp_expt_d.o bn_mp_expt_d_ex.o bn_mp_exptmod.o \ -bn_mp_exptmod_fast.o bn_mp_exteuclid.o bn_mp_fread.o bn_mp_fwrite.o bn_mp_gcd.o bn_mp_get_bit.o \ -bn_mp_get_double.o bn_mp_get_int.o bn_mp_get_long.o bn_mp_get_long_long.o bn_mp_grow.o bn_mp_import.o \ -bn_mp_init.o bn_mp_init_copy.o bn_mp_init_multi.o bn_mp_init_set.o bn_mp_init_set_int.o bn_mp_init_size.o \ -bn_mp_invmod.o bn_mp_invmod_slow.o bn_mp_is_square.o bn_mp_jacobi.o bn_mp_karatsuba_mul.o \ -bn_mp_karatsuba_sqr.o bn_mp_kronecker.o bn_mp_lcm.o bn_mp_lshd.o bn_mp_mod.o bn_mp_mod_2d.o bn_mp_mod_d.o \ -bn_mp_montgomery_calc_normalization.o bn_mp_montgomery_reduce.o bn_mp_montgomery_setup.o bn_mp_mul.o \ -bn_mp_mul_2.o bn_mp_mul_2d.o bn_mp_mul_d.o bn_mp_mulmod.o bn_mp_n_root.o bn_mp_n_root_ex.o bn_mp_neg.o \ -bn_mp_or.o bn_mp_prime_fermat.o bn_mp_prime_frobenius_underwood.o bn_mp_prime_is_divisible.o \ +OBJECTS=bn_cutoffs.o bn_deprecated.o bn_mp_2expt.o bn_mp_abs.o bn_mp_add.o bn_mp_add_d.o bn_mp_addmod.o \ +bn_mp_and.o bn_mp_clamp.o bn_mp_clear.o bn_mp_clear_multi.o bn_mp_cmp.o bn_mp_cmp_d.o bn_mp_cmp_mag.o \ +bn_mp_cnt_lsb.o bn_mp_complement.o bn_mp_copy.o bn_mp_count_bits.o bn_mp_decr.o bn_mp_div.o bn_mp_div_2.o \ +bn_mp_div_2d.o bn_mp_div_3.o bn_mp_div_d.o bn_mp_dr_is_modulus.o bn_mp_dr_reduce.o bn_mp_dr_setup.o \ +bn_mp_error_to_string.o bn_mp_exch.o bn_mp_expt_u32.o bn_mp_exptmod.o bn_mp_exteuclid.o bn_mp_fread.o \ +bn_mp_from_sbin.o bn_mp_from_ubin.o bn_mp_fwrite.o bn_mp_gcd.o bn_mp_get_double.o bn_mp_get_i32.o \ +bn_mp_get_i64.o bn_mp_get_l.o bn_mp_get_ll.o bn_mp_get_mag_u32.o bn_mp_get_mag_u64.o bn_mp_get_mag_ul.o \ +bn_mp_get_mag_ull.o bn_mp_grow.o bn_mp_incr.o bn_mp_init.o bn_mp_init_copy.o bn_mp_init_i32.o \ +bn_mp_init_i64.o bn_mp_init_l.o bn_mp_init_ll.o bn_mp_init_multi.o bn_mp_init_set.o bn_mp_init_size.o \ +bn_mp_init_u32.o bn_mp_init_u64.o bn_mp_init_ul.o bn_mp_init_ull.o bn_mp_invmod.o bn_mp_is_square.o \ +bn_mp_iseven.o bn_mp_isodd.o bn_mp_kronecker.o bn_mp_lcm.o bn_mp_log_u32.o bn_mp_lshd.o bn_mp_mod.o \ +bn_mp_mod_2d.o bn_mp_mod_d.o bn_mp_montgomery_calc_normalization.o bn_mp_montgomery_reduce.o \ +bn_mp_montgomery_setup.o bn_mp_mul.o bn_mp_mul_2.o bn_mp_mul_2d.o bn_mp_mul_d.o bn_mp_mulmod.o bn_mp_neg.o \ +bn_mp_or.o bn_mp_pack.o bn_mp_pack_count.o bn_mp_prime_fermat.o bn_mp_prime_frobenius_underwood.o \ bn_mp_prime_is_prime.o bn_mp_prime_miller_rabin.o bn_mp_prime_next_prime.o \ -bn_mp_prime_rabin_miller_trials.o bn_mp_prime_random_ex.o bn_mp_prime_strong_lucas_selfridge.o \ -bn_mp_radix_size.o bn_mp_radix_smap.o bn_mp_rand.o bn_mp_read_radix.o bn_mp_read_signed_bin.o \ -bn_mp_read_unsigned_bin.o bn_mp_reduce.o bn_mp_reduce_2k.o bn_mp_reduce_2k_l.o bn_mp_reduce_2k_setup.o \ -bn_mp_reduce_2k_setup_l.o bn_mp_reduce_is_2k.o bn_mp_reduce_is_2k_l.o bn_mp_reduce_setup.o bn_mp_rshd.o \ -bn_mp_set.o bn_mp_set_double.o bn_mp_set_int.o bn_mp_set_long.o bn_mp_set_long_long.o bn_mp_shrink.o \ -bn_mp_signed_bin_size.o bn_mp_sqr.o bn_mp_sqrmod.o bn_mp_sqrt.o bn_mp_sqrtmod_prime.o bn_mp_sub.o \ -bn_mp_sub_d.o bn_mp_submod.o bn_mp_tc_and.o bn_mp_tc_div_2d.o bn_mp_tc_or.o bn_mp_tc_xor.o \ -bn_mp_to_signed_bin.o bn_mp_to_signed_bin_n.o bn_mp_to_unsigned_bin.o bn_mp_to_unsigned_bin_n.o \ -bn_mp_toom_mul.o bn_mp_toom_sqr.o bn_mp_toradix.o bn_mp_toradix_n.o bn_mp_unsigned_bin_size.o bn_mp_xor.o \ -bn_mp_zero.o bn_prime_tab.o bn_reverse.o bn_s_mp_add.o bn_s_mp_exptmod.o bn_s_mp_mul_digs.o \ -bn_s_mp_mul_high_digs.o bn_s_mp_sqr.o bn_s_mp_sub.o bncore.o - -HEADERS_PUB=tommath.h tommath_class.h tommath_superclass.h - -HEADERS=tommath_private.h $(HEADERS_PUB) +bn_mp_prime_rabin_miller_trials.o bn_mp_prime_rand.o bn_mp_prime_strong_lucas_selfridge.o \ +bn_mp_radix_size.o bn_mp_radix_smap.o bn_mp_rand.o bn_mp_read_radix.o bn_mp_reduce.o bn_mp_reduce_2k.o \ +bn_mp_reduce_2k_l.o bn_mp_reduce_2k_setup.o bn_mp_reduce_2k_setup_l.o bn_mp_reduce_is_2k.o \ +bn_mp_reduce_is_2k_l.o bn_mp_reduce_setup.o bn_mp_root_u32.o bn_mp_rshd.o bn_mp_sbin_size.o bn_mp_set.o \ +bn_mp_set_double.o bn_mp_set_i32.o bn_mp_set_i64.o bn_mp_set_l.o bn_mp_set_ll.o bn_mp_set_u32.o \ +bn_mp_set_u64.o bn_mp_set_ul.o bn_mp_set_ull.o bn_mp_shrink.o bn_mp_signed_rsh.o bn_mp_sqr.o \ +bn_mp_sqrmod.o bn_mp_sqrt.o bn_mp_sqrtmod_prime.o bn_mp_sub.o bn_mp_sub_d.o bn_mp_submod.o \ +bn_mp_to_radix.o bn_mp_to_sbin.o bn_mp_to_ubin.o bn_mp_ubin_size.o bn_mp_unpack.o bn_mp_xor.o bn_mp_zero.o \ +bn_prime_tab.o bn_s_mp_add.o bn_s_mp_balance_mul.o bn_s_mp_exptmod.o bn_s_mp_exptmod_fast.o \ +bn_s_mp_get_bit.o bn_s_mp_invmod_fast.o bn_s_mp_invmod_slow.o bn_s_mp_karatsuba_mul.o \ +bn_s_mp_karatsuba_sqr.o bn_s_mp_montgomery_reduce_fast.o bn_s_mp_mul_digs.o bn_s_mp_mul_digs_fast.o \ +bn_s_mp_mul_high_digs.o bn_s_mp_mul_high_digs_fast.o bn_s_mp_prime_is_divisible.o \ +bn_s_mp_rand_jenkins.o bn_s_mp_rand_platform.o bn_s_mp_reverse.o bn_s_mp_sqr.o bn_s_mp_sqr_fast.o \ +bn_s_mp_sub.o bn_s_mp_toom_mul.o bn_s_mp_toom_sqr.o + +HEADERS_PUB=tommath.h +HEADERS=tommath_private.h tommath_class.h tommath_superclass.h tommath_cutoffs.h $(HEADERS_PUB) #The default rule for make builds the libtommath.a library (static) default: $(LIBMAIN_S) #Dependencies on *.h @@ -77,18 +79,23 @@ #Create DLL + import library libtommath.dll.a $(LIBMAIN_D) $(LIBMAIN_I): $(OBJECTS) $(CC) -s -shared -o $(LIBMAIN_D) $^ -Wl,--enable-auto-import,--export-all -Wl,--out-implib=$(LIBMAIN_I) $(LTM_LDFLAGS) $(STRIP) -S $(LIBMAIN_D) -#Build test_standalone suite -test.exe: $(LIBMAIN_S) demo/demo.c - $(CC) $(LTM_CFLAGS) $(LTM_LDFLAGS) demo/demo.c $(LIBMAIN_S) -DLTM_DEMO_TEST_VS_MTEST=0 -o $@ +#Build test suite +test.exe: demo/shared.o demo/test.o $(LIBMAIN_S) + $(CC) $(LTM_CFLAGS) $(LTM_LDFLAGS) $^ -o $@ @echo NOTICE: start the tests by launching test.exe test_standalone: test.exe + @echo test_standalone is deprecated, please use make-target 'test.exe' + +all: $(LIBMAIN_S) test.exe -all: $(LIBMAIN_S) test_standalone +tune: $(LIBNAME_S) + $(MAKE) -C etc tune + $(MAKE) clean: @-cmd /c del /Q /S *.o *.a *.exe *.dll 2>nul #Install the library + headers @@ -98,9 +105,5 @@ cmd /c if not exist "$(PREFIX)\include" mkdir "$(PREFIX)\include" copy /Y $(LIBMAIN_S) "$(PREFIX)\lib" copy /Y $(LIBMAIN_I) "$(PREFIX)\lib" copy /Y $(LIBMAIN_D) "$(PREFIX)\bin" copy /Y tommath*.h "$(PREFIX)\include" - -# ref: $Format:%D$ -# git commit: $Format:%H$ -# commit time: $Format:%ai$ Index: libtommath/makefile.msvc ================================================================== --- libtommath/makefile.msvc +++ libtommath/makefile.msvc @@ -1,8 +1,8 @@ # MAKEFILE for MS Windows (nmake + Windows SDK) # -# BEWARE: variable OBJECTS is updated via ./updatemakes.sh +# BEWARE: variable OBJECTS is updated via helper.pl ### USAGE: # Open a command prompt with WinSDK variables set and start: # # nmake -f makefile.msvc all @@ -12,47 +12,49 @@ #The following can be overridden from command line e.g. make -f makefile.msvc CC=gcc ARFLAGS=rcs PREFIX = c:\devel CFLAGS = /Ox #Compilation flags -LTM_CFLAGS = /nologo /I./ /D_CRT_SECURE_NO_WARNINGS /D_CRT_NONSTDC_NO_DEPRECATE /W3 $(CFLAGS) +LTM_CFLAGS = /nologo /I./ /D_CRT_SECURE_NO_WARNINGS /D_CRT_NONSTDC_NO_DEPRECATE /D__STDC_WANT_SECURE_LIB__=1 /D_CRT_HAS_CXX17=0 /Wall /wd4146 /wd4127 /wd4668 /wd4710 /wd4711 /wd4820 /wd5045 /WX $(CFLAGS) LTM_LDFLAGS = advapi32.lib #Libraries to be created (this makefile builds only static libraries) LIBMAIN_S =tommath.lib #List of objects to compile (all goes to tommath.lib) -OBJECTS=bn_error.obj bn_fast_mp_invmod.obj bn_fast_mp_montgomery_reduce.obj bn_fast_s_mp_mul_digs.obj \ -bn_fast_s_mp_mul_high_digs.obj bn_fast_s_mp_sqr.obj bn_mp_2expt.obj bn_mp_abs.obj bn_mp_add.obj bn_mp_add_d.obj \ -bn_mp_addmod.obj bn_mp_and.obj bn_mp_clamp.obj bn_mp_clear.obj bn_mp_clear_multi.obj bn_mp_cmp.obj bn_mp_cmp_d.obj \ -bn_mp_cmp_mag.obj bn_mp_cnt_lsb.obj bn_mp_complement.obj bn_mp_copy.obj bn_mp_count_bits.obj bn_mp_div.obj \ -bn_mp_div_2.obj bn_mp_div_2d.obj bn_mp_div_3.obj bn_mp_div_d.obj bn_mp_dr_is_modulus.obj bn_mp_dr_reduce.obj \ -bn_mp_dr_setup.obj bn_mp_exch.obj bn_mp_export.obj bn_mp_expt_d.obj bn_mp_expt_d_ex.obj bn_mp_exptmod.obj \ -bn_mp_exptmod_fast.obj bn_mp_exteuclid.obj bn_mp_fread.obj bn_mp_fwrite.obj bn_mp_gcd.obj bn_mp_get_bit.obj \ -bn_mp_get_double.obj bn_mp_get_int.obj bn_mp_get_long.obj bn_mp_get_long_long.obj bn_mp_grow.obj bn_mp_import.obj \ -bn_mp_init.obj bn_mp_init_copy.obj bn_mp_init_multi.obj bn_mp_init_set.obj bn_mp_init_set_int.obj bn_mp_init_size.obj \ -bn_mp_invmod.obj bn_mp_invmod_slow.obj bn_mp_is_square.obj bn_mp_jacobi.obj bn_mp_karatsuba_mul.obj \ -bn_mp_karatsuba_sqr.obj bn_mp_kronecker.obj bn_mp_lcm.obj bn_mp_lshd.obj bn_mp_mod.obj bn_mp_mod_2d.obj bn_mp_mod_d.obj \ -bn_mp_montgomery_calc_normalization.obj bn_mp_montgomery_reduce.obj bn_mp_montgomery_setup.obj bn_mp_mul.obj \ -bn_mp_mul_2.obj bn_mp_mul_2d.obj bn_mp_mul_d.obj bn_mp_mulmod.obj bn_mp_n_root.obj bn_mp_n_root_ex.obj bn_mp_neg.obj \ -bn_mp_or.obj bn_mp_prime_fermat.obj bn_mp_prime_frobenius_underwood.obj bn_mp_prime_is_divisible.obj \ +OBJECTS=bn_cutoffs.obj bn_deprecated.obj bn_mp_2expt.obj bn_mp_abs.obj bn_mp_add.obj bn_mp_add_d.obj bn_mp_addmod.obj \ +bn_mp_and.obj bn_mp_clamp.obj bn_mp_clear.obj bn_mp_clear_multi.obj bn_mp_cmp.obj bn_mp_cmp_d.obj bn_mp_cmp_mag.obj \ +bn_mp_cnt_lsb.obj bn_mp_complement.obj bn_mp_copy.obj bn_mp_count_bits.obj bn_mp_decr.obj bn_mp_div.obj bn_mp_div_2.obj \ +bn_mp_div_2d.obj bn_mp_div_3.obj bn_mp_div_d.obj bn_mp_dr_is_modulus.obj bn_mp_dr_reduce.obj bn_mp_dr_setup.obj \ +bn_mp_error_to_string.obj bn_mp_exch.obj bn_mp_expt_u32.obj bn_mp_exptmod.obj bn_mp_exteuclid.obj bn_mp_fread.obj \ +bn_mp_from_sbin.obj bn_mp_from_ubin.obj bn_mp_fwrite.obj bn_mp_gcd.obj bn_mp_get_double.obj bn_mp_get_i32.obj \ +bn_mp_get_i64.obj bn_mp_get_l.obj bn_mp_get_ll.obj bn_mp_get_mag_u32.obj bn_mp_get_mag_u64.obj bn_mp_get_mag_ul.obj \ +bn_mp_get_mag_ull.obj bn_mp_grow.obj bn_mp_incr.obj bn_mp_init.obj bn_mp_init_copy.obj bn_mp_init_i32.obj \ +bn_mp_init_i64.obj bn_mp_init_l.obj bn_mp_init_ll.obj bn_mp_init_multi.obj bn_mp_init_set.obj bn_mp_init_size.obj \ +bn_mp_init_u32.obj bn_mp_init_u64.obj bn_mp_init_ul.obj bn_mp_init_ull.obj bn_mp_invmod.obj bn_mp_is_square.obj \ +bn_mp_iseven.obj bn_mp_isodd.obj bn_mp_kronecker.obj bn_mp_lcm.obj bn_mp_log_u32.obj bn_mp_lshd.obj bn_mp_mod.obj \ +bn_mp_mod_2d.obj bn_mp_mod_d.obj bn_mp_montgomery_calc_normalization.obj bn_mp_montgomery_reduce.obj \ +bn_mp_montgomery_setup.obj bn_mp_mul.obj bn_mp_mul_2.obj bn_mp_mul_2d.obj bn_mp_mul_d.obj bn_mp_mulmod.obj bn_mp_neg.obj \ +bn_mp_or.obj bn_mp_pack.obj bn_mp_pack_count.obj bn_mp_prime_fermat.obj bn_mp_prime_frobenius_underwood.obj \ bn_mp_prime_is_prime.obj bn_mp_prime_miller_rabin.obj bn_mp_prime_next_prime.obj \ -bn_mp_prime_rabin_miller_trials.obj bn_mp_prime_random_ex.obj bn_mp_prime_strong_lucas_selfridge.obj \ -bn_mp_radix_size.obj bn_mp_radix_smap.obj bn_mp_rand.obj bn_mp_read_radix.obj bn_mp_read_signed_bin.obj \ -bn_mp_read_unsigned_bin.obj bn_mp_reduce.obj bn_mp_reduce_2k.obj bn_mp_reduce_2k_l.obj bn_mp_reduce_2k_setup.obj \ -bn_mp_reduce_2k_setup_l.obj bn_mp_reduce_is_2k.obj bn_mp_reduce_is_2k_l.obj bn_mp_reduce_setup.obj bn_mp_rshd.obj \ -bn_mp_set.obj bn_mp_set_double.obj bn_mp_set_int.obj bn_mp_set_long.obj bn_mp_set_long_long.obj bn_mp_shrink.obj \ -bn_mp_signed_bin_size.obj bn_mp_sqr.obj bn_mp_sqrmod.obj bn_mp_sqrt.obj bn_mp_sqrtmod_prime.obj bn_mp_sub.obj \ -bn_mp_sub_d.obj bn_mp_submod.obj bn_mp_tc_and.obj bn_mp_tc_div_2d.obj bn_mp_tc_or.obj bn_mp_tc_xor.obj \ -bn_mp_to_signed_bin.obj bn_mp_to_signed_bin_n.obj bn_mp_to_unsigned_bin.obj bn_mp_to_unsigned_bin_n.obj \ -bn_mp_toom_mul.obj bn_mp_toom_sqr.obj bn_mp_toradix.obj bn_mp_toradix_n.obj bn_mp_unsigned_bin_size.obj bn_mp_xor.obj \ -bn_mp_zero.obj bn_prime_tab.obj bn_reverse.obj bn_s_mp_add.obj bn_s_mp_exptmod.obj bn_s_mp_mul_digs.obj \ -bn_s_mp_mul_high_digs.obj bn_s_mp_sqr.obj bn_s_mp_sub.obj bncore.obj - -HEADERS_PUB=tommath.h tommath_class.h tommath_superclass.h - -HEADERS=tommath_private.h $(HEADERS_PUB) +bn_mp_prime_rabin_miller_trials.obj bn_mp_prime_rand.obj bn_mp_prime_strong_lucas_selfridge.obj \ +bn_mp_radix_size.obj bn_mp_radix_smap.obj bn_mp_rand.obj bn_mp_read_radix.obj bn_mp_reduce.obj bn_mp_reduce_2k.obj \ +bn_mp_reduce_2k_l.obj bn_mp_reduce_2k_setup.obj bn_mp_reduce_2k_setup_l.obj bn_mp_reduce_is_2k.obj \ +bn_mp_reduce_is_2k_l.obj bn_mp_reduce_setup.obj bn_mp_root_u32.obj bn_mp_rshd.obj bn_mp_sbin_size.obj bn_mp_set.obj \ +bn_mp_set_double.obj bn_mp_set_i32.obj bn_mp_set_i64.obj bn_mp_set_l.obj bn_mp_set_ll.obj bn_mp_set_u32.obj \ +bn_mp_set_u64.obj bn_mp_set_ul.obj bn_mp_set_ull.obj bn_mp_shrink.obj bn_mp_signed_rsh.obj bn_mp_sqr.obj \ +bn_mp_sqrmod.obj bn_mp_sqrt.obj bn_mp_sqrtmod_prime.obj bn_mp_sub.obj bn_mp_sub_d.obj bn_mp_submod.obj \ +bn_mp_to_radix.obj bn_mp_to_sbin.obj bn_mp_to_ubin.obj bn_mp_ubin_size.obj bn_mp_unpack.obj bn_mp_xor.obj bn_mp_zero.obj \ +bn_prime_tab.obj bn_s_mp_add.obj bn_s_mp_balance_mul.obj bn_s_mp_exptmod.obj bn_s_mp_exptmod_fast.obj \ +bn_s_mp_get_bit.obj bn_s_mp_invmod_fast.obj bn_s_mp_invmod_slow.obj bn_s_mp_karatsuba_mul.obj \ +bn_s_mp_karatsuba_sqr.obj bn_s_mp_montgomery_reduce_fast.obj bn_s_mp_mul_digs.obj bn_s_mp_mul_digs_fast.obj \ +bn_s_mp_mul_high_digs.obj bn_s_mp_mul_high_digs_fast.obj bn_s_mp_prime_is_divisible.obj \ +bn_s_mp_rand_jenkins.obj bn_s_mp_rand_platform.obj bn_s_mp_reverse.obj bn_s_mp_sqr.obj bn_s_mp_sqr_fast.obj \ +bn_s_mp_sub.obj bn_s_mp_toom_mul.obj bn_s_mp_toom_sqr.obj + +HEADERS_PUB=tommath.h +HEADERS=tommath_private.h tommath_class.h tommath_superclass.h tommath_cutoffs.h $(HEADERS_PUB) #The default rule for make builds the tommath.lib library (static) default: $(LIBMAIN_S) #Dependencies on *.h @@ -59,22 +61,27 @@ $(OBJECTS): $(HEADERS) .c.obj: $(CC) $(LTM_CFLAGS) /c $< /Fo$@ -#Create tomcrypt.lib +#Create tommath.lib $(LIBMAIN_S): $(OBJECTS) lib /out:$(LIBMAIN_S) $(OBJECTS) -#Build test_standalone suite -test.exe: $(LIBMAIN_S) demo/demo.c - cl $(LTM_CFLAGS) $(TOBJECTS) $(LIBMAIN_S) $(LTM_LDFLAGS) demo/demo.c /DLTM_DEMO_TEST_VS_MTEST=0 /Fe$@ +#Build test suite +test.exe: $(LIBMAIN_S) demo/shared.obj demo/test.obj + cl $(LTM_CFLAGS) $(TOBJECTS) $(LIBMAIN_S) $(LTM_LDFLAGS) demo/shared.c demo/test.c /Fe$@ @echo NOTICE: start the tests by launching test.exe test_standalone: test.exe + @echo test_standalone is deprecated, please use make-target 'test.exe' + +all: $(LIBMAIN_S) test.exe -all: $(LIBMAIN_S) test_standalone +tune: $(LIBMAIN_S) + $(MAKE) -C etc tune + $(MAKE) clean: @-cmd /c del /Q /S *.OBJ *.LIB *.EXE *.DLL 2>nul #Install the library + headers @@ -82,9 +89,5 @@ cmd /c if not exist "$(PREFIX)\bin" mkdir "$(PREFIX)\bin" cmd /c if not exist "$(PREFIX)\lib" mkdir "$(PREFIX)\lib" cmd /c if not exist "$(PREFIX)\include" mkdir "$(PREFIX)\include" copy /Y $(LIBMAIN_S) "$(PREFIX)\lib" copy /Y tommath*.h "$(PREFIX)\include" - -# ref: $Format:%D$ -# git commit: $Format:%H$ -# commit time: $Format:%ai$ Index: libtommath/makefile.shared ================================================================== --- libtommath/makefile.shared +++ libtommath/makefile.shared @@ -16,52 +16,56 @@ else LIBTOOL:=libtool endif endif LTCOMPILE = $(LIBTOOL) --mode=compile --tag=CC $(CC) +LTLINK = $(LIBTOOL) --mode=link --tag=CC $(CC) LCOV_ARGS=--directory .libs --directory . #START_INS -OBJECTS=bn_error.o bn_fast_mp_invmod.o bn_fast_mp_montgomery_reduce.o bn_fast_s_mp_mul_digs.o \ -bn_fast_s_mp_mul_high_digs.o bn_fast_s_mp_sqr.o bn_mp_2expt.o bn_mp_abs.o bn_mp_add.o bn_mp_add_d.o \ -bn_mp_addmod.o bn_mp_and.o bn_mp_clamp.o bn_mp_clear.o bn_mp_clear_multi.o bn_mp_cmp.o bn_mp_cmp_d.o \ -bn_mp_cmp_mag.o bn_mp_cnt_lsb.o bn_mp_complement.o bn_mp_copy.o bn_mp_count_bits.o bn_mp_div.o \ -bn_mp_div_2.o bn_mp_div_2d.o bn_mp_div_3.o bn_mp_div_d.o bn_mp_dr_is_modulus.o bn_mp_dr_reduce.o \ -bn_mp_dr_setup.o bn_mp_exch.o bn_mp_export.o bn_mp_expt_d.o bn_mp_expt_d_ex.o bn_mp_exptmod.o \ -bn_mp_exptmod_fast.o bn_mp_exteuclid.o bn_mp_fread.o bn_mp_fwrite.o bn_mp_gcd.o bn_mp_get_bit.o \ -bn_mp_get_double.o bn_mp_get_int.o bn_mp_get_long.o bn_mp_get_long_long.o bn_mp_grow.o bn_mp_import.o \ -bn_mp_init.o bn_mp_init_copy.o bn_mp_init_multi.o bn_mp_init_set.o bn_mp_init_set_int.o bn_mp_init_size.o \ -bn_mp_invmod.o bn_mp_invmod_slow.o bn_mp_is_square.o bn_mp_jacobi.o bn_mp_karatsuba_mul.o \ -bn_mp_karatsuba_sqr.o bn_mp_kronecker.o bn_mp_lcm.o bn_mp_lshd.o bn_mp_mod.o bn_mp_mod_2d.o bn_mp_mod_d.o \ -bn_mp_montgomery_calc_normalization.o bn_mp_montgomery_reduce.o bn_mp_montgomery_setup.o bn_mp_mul.o \ -bn_mp_mul_2.o bn_mp_mul_2d.o bn_mp_mul_d.o bn_mp_mulmod.o bn_mp_n_root.o bn_mp_n_root_ex.o bn_mp_neg.o \ -bn_mp_or.o bn_mp_prime_fermat.o bn_mp_prime_frobenius_underwood.o bn_mp_prime_is_divisible.o \ +OBJECTS=bn_cutoffs.o bn_deprecated.o bn_mp_2expt.o bn_mp_abs.o bn_mp_add.o bn_mp_add_d.o bn_mp_addmod.o \ +bn_mp_and.o bn_mp_clamp.o bn_mp_clear.o bn_mp_clear_multi.o bn_mp_cmp.o bn_mp_cmp_d.o bn_mp_cmp_mag.o \ +bn_mp_cnt_lsb.o bn_mp_complement.o bn_mp_copy.o bn_mp_count_bits.o bn_mp_decr.o bn_mp_div.o bn_mp_div_2.o \ +bn_mp_div_2d.o bn_mp_div_3.o bn_mp_div_d.o bn_mp_dr_is_modulus.o bn_mp_dr_reduce.o bn_mp_dr_setup.o \ +bn_mp_error_to_string.o bn_mp_exch.o bn_mp_expt_u32.o bn_mp_exptmod.o bn_mp_exteuclid.o bn_mp_fread.o \ +bn_mp_from_sbin.o bn_mp_from_ubin.o bn_mp_fwrite.o bn_mp_gcd.o bn_mp_get_double.o bn_mp_get_i32.o \ +bn_mp_get_i64.o bn_mp_get_l.o bn_mp_get_ll.o bn_mp_get_mag_u32.o bn_mp_get_mag_u64.o bn_mp_get_mag_ul.o \ +bn_mp_get_mag_ull.o bn_mp_grow.o bn_mp_incr.o bn_mp_init.o bn_mp_init_copy.o bn_mp_init_i32.o \ +bn_mp_init_i64.o bn_mp_init_l.o bn_mp_init_ll.o bn_mp_init_multi.o bn_mp_init_set.o bn_mp_init_size.o \ +bn_mp_init_u32.o bn_mp_init_u64.o bn_mp_init_ul.o bn_mp_init_ull.o bn_mp_invmod.o bn_mp_is_square.o \ +bn_mp_iseven.o bn_mp_isodd.o bn_mp_kronecker.o bn_mp_lcm.o bn_mp_log_u32.o bn_mp_lshd.o bn_mp_mod.o \ +bn_mp_mod_2d.o bn_mp_mod_d.o bn_mp_montgomery_calc_normalization.o bn_mp_montgomery_reduce.o \ +bn_mp_montgomery_setup.o bn_mp_mul.o bn_mp_mul_2.o bn_mp_mul_2d.o bn_mp_mul_d.o bn_mp_mulmod.o bn_mp_neg.o \ +bn_mp_or.o bn_mp_pack.o bn_mp_pack_count.o bn_mp_prime_fermat.o bn_mp_prime_frobenius_underwood.o \ bn_mp_prime_is_prime.o bn_mp_prime_miller_rabin.o bn_mp_prime_next_prime.o \ -bn_mp_prime_rabin_miller_trials.o bn_mp_prime_random_ex.o bn_mp_prime_strong_lucas_selfridge.o \ -bn_mp_radix_size.o bn_mp_radix_smap.o bn_mp_rand.o bn_mp_read_radix.o bn_mp_read_signed_bin.o \ -bn_mp_read_unsigned_bin.o bn_mp_reduce.o bn_mp_reduce_2k.o bn_mp_reduce_2k_l.o bn_mp_reduce_2k_setup.o \ -bn_mp_reduce_2k_setup_l.o bn_mp_reduce_is_2k.o bn_mp_reduce_is_2k_l.o bn_mp_reduce_setup.o bn_mp_rshd.o \ -bn_mp_set.o bn_mp_set_double.o bn_mp_set_int.o bn_mp_set_long.o bn_mp_set_long_long.o bn_mp_shrink.o \ -bn_mp_signed_bin_size.o bn_mp_sqr.o bn_mp_sqrmod.o bn_mp_sqrt.o bn_mp_sqrtmod_prime.o bn_mp_sub.o \ -bn_mp_sub_d.o bn_mp_submod.o bn_mp_tc_and.o bn_mp_tc_div_2d.o bn_mp_tc_or.o bn_mp_tc_xor.o \ -bn_mp_to_signed_bin.o bn_mp_to_signed_bin_n.o bn_mp_to_unsigned_bin.o bn_mp_to_unsigned_bin_n.o \ -bn_mp_toom_mul.o bn_mp_toom_sqr.o bn_mp_toradix.o bn_mp_toradix_n.o bn_mp_unsigned_bin_size.o bn_mp_xor.o \ -bn_mp_zero.o bn_prime_tab.o bn_reverse.o bn_s_mp_add.o bn_s_mp_exptmod.o bn_s_mp_mul_digs.o \ -bn_s_mp_mul_high_digs.o bn_s_mp_sqr.o bn_s_mp_sub.o bncore.o +bn_mp_prime_rabin_miller_trials.o bn_mp_prime_rand.o bn_mp_prime_strong_lucas_selfridge.o \ +bn_mp_radix_size.o bn_mp_radix_smap.o bn_mp_rand.o bn_mp_read_radix.o bn_mp_reduce.o bn_mp_reduce_2k.o \ +bn_mp_reduce_2k_l.o bn_mp_reduce_2k_setup.o bn_mp_reduce_2k_setup_l.o bn_mp_reduce_is_2k.o \ +bn_mp_reduce_is_2k_l.o bn_mp_reduce_setup.o bn_mp_root_u32.o bn_mp_rshd.o bn_mp_sbin_size.o bn_mp_set.o \ +bn_mp_set_double.o bn_mp_set_i32.o bn_mp_set_i64.o bn_mp_set_l.o bn_mp_set_ll.o bn_mp_set_u32.o \ +bn_mp_set_u64.o bn_mp_set_ul.o bn_mp_set_ull.o bn_mp_shrink.o bn_mp_signed_rsh.o bn_mp_sqr.o \ +bn_mp_sqrmod.o bn_mp_sqrt.o bn_mp_sqrtmod_prime.o bn_mp_sub.o bn_mp_sub_d.o bn_mp_submod.o \ +bn_mp_to_radix.o bn_mp_to_sbin.o bn_mp_to_ubin.o bn_mp_ubin_size.o bn_mp_unpack.o bn_mp_xor.o bn_mp_zero.o \ +bn_prime_tab.o bn_s_mp_add.o bn_s_mp_balance_mul.o bn_s_mp_exptmod.o bn_s_mp_exptmod_fast.o \ +bn_s_mp_get_bit.o bn_s_mp_invmod_fast.o bn_s_mp_invmod_slow.o bn_s_mp_karatsuba_mul.o \ +bn_s_mp_karatsuba_sqr.o bn_s_mp_montgomery_reduce_fast.o bn_s_mp_mul_digs.o bn_s_mp_mul_digs_fast.o \ +bn_s_mp_mul_high_digs.o bn_s_mp_mul_high_digs_fast.o bn_s_mp_prime_is_divisible.o \ +bn_s_mp_rand_jenkins.o bn_s_mp_rand_platform.o bn_s_mp_reverse.o bn_s_mp_sqr.o bn_s_mp_sqr_fast.o \ +bn_s_mp_sub.o bn_s_mp_toom_mul.o bn_s_mp_toom_sqr.o #END_INS objs: $(OBJECTS) -.c.o: - $(LTCOMPILE) $(CFLAGS) $(LDFLAGS) -o $@ -c $< +.c.o: $(HEADERS) + $(LTCOMPILE) $(LTM_CFLAGS) $(LTM_LDFLAGS) -o $@ -c $< LOBJECTS = $(OBJECTS:.o=.lo) $(LIBNAME): $(OBJECTS) - $(LIBTOOL) --mode=link --tag=CC $(CC) $(LDFLAGS) $(LOBJECTS) -o $(LIBNAME) -rpath $(LIBPATH) -version-info $(VERSION_SO) $(LIBTOOLFLAGS) + $(LTLINK) $(LTM_LDFLAGS) $(LOBJECTS) -o $(LIBNAME) -rpath $(LIBPATH) -version-info $(VERSION_SO) $(LTM_LIBTOOLFLAGS) install: $(LIBNAME) install -d $(DESTDIR)$(LIBPATH) install -d $(DESTDIR)$(INCPATH) $(LIBTOOL) --mode=install install -m 644 $(LIBNAME) $(DESTDIR)$(LIBPATH)/$(LIBNAME) @@ -73,19 +77,23 @@ uninstall: $(LIBTOOL) --mode=uninstall rm $(DESTDIR)$(LIBPATH)/$(LIBNAME) rm $(HEADERS_PUB:%=$(DESTDIR)$(INCPATH)/%) rm $(DESTDIR)$(LIBPATH)/pkgconfig/libtommath.pc -test: $(LIBNAME) demo/demo.o - $(CC) $(CFLAGS) -c demo/demo.c -o demo/demo.o - $(LIBTOOL) --mode=link $(CC) $(LDFLAGS) -o test demo/demo.o $(LIBNAME) +test_standalone: test + @echo "test_standalone is deprecated, please use make-target 'test'" -test_standalone: $(LIBNAME) demo/demo.o - $(CC) $(CFLAGS) -c demo/demo.c -o demo/demo.o - $(LIBTOOL) --mode=link $(CC) $(LDFLAGS) -o test demo/demo.o $(LIBNAME) +test mtest_opponent: demo/shared.o $(LIBNAME) | demo/test.o demo/mtest_opponent.o + $(LTLINK) $(LTM_LDFLAGS) demo/$@.o $^ -o $@ .PHONY: mtest mtest: - cd mtest ; $(CC) $(CFLAGS) $(LDFLAGS) mtest.c -o mtest + cd mtest ; $(CC) $(LTM_CFLAGS) -O0 mtest.c $(LTM_LDFLAGS) -o mtest timing: $(LIBNAME) demo/timing.c - $(LIBTOOL) --mode=link $(CC) $(CFLAGS) $(LDFLAGS) -DTIMER demo/timing.c $(LIBNAME) -o timing + $(LTLINK) $(LTM_CFLAGS) $(LTM_LDFLAGS) -DTIMER demo/timing.c $(LIBNAME) -o timing + +tune: $(LIBNAME) + $(LTCOMPILE) $(LTM_CFLAGS) -c etc/tune.c -o etc/tune.o + $(LTLINK) $(LTM_LDFLAGS) -o etc/tune etc/tune.o $(LIBNAME) + cd etc/; /bin/sh tune_it.sh; cd .. + $(MAKE) -f makefile.shared Index: libtommath/makefile.unix ================================================================== --- libtommath/makefile.unix +++ libtommath/makefile.unix @@ -19,49 +19,51 @@ ARFLAGS = r RANLIB = ranlib CFLAGS = -O2 LDFLAGS = -VERSION = 1.1.0 +VERSION = 1.2.0 #Compilation flags LTM_CFLAGS = -I. $(CFLAGS) LTM_LDFLAGS = $(LDFLAGS) #Library to be created (this makefile builds only static library) LIBMAIN_S = libtommath.a -OBJECTS=bn_error.o bn_fast_mp_invmod.o bn_fast_mp_montgomery_reduce.o bn_fast_s_mp_mul_digs.o \ -bn_fast_s_mp_mul_high_digs.o bn_fast_s_mp_sqr.o bn_mp_2expt.o bn_mp_abs.o bn_mp_add.o bn_mp_add_d.o \ -bn_mp_addmod.o bn_mp_and.o bn_mp_clamp.o bn_mp_clear.o bn_mp_clear_multi.o bn_mp_cmp.o bn_mp_cmp_d.o \ -bn_mp_cmp_mag.o bn_mp_cnt_lsb.o bn_mp_complement.o bn_mp_copy.o bn_mp_count_bits.o bn_mp_div.o \ -bn_mp_div_2.o bn_mp_div_2d.o bn_mp_div_3.o bn_mp_div_d.o bn_mp_dr_is_modulus.o bn_mp_dr_reduce.o \ -bn_mp_dr_setup.o bn_mp_exch.o bn_mp_export.o bn_mp_expt_d.o bn_mp_expt_d_ex.o bn_mp_exptmod.o \ -bn_mp_exptmod_fast.o bn_mp_exteuclid.o bn_mp_fread.o bn_mp_fwrite.o bn_mp_gcd.o bn_mp_get_bit.o \ -bn_mp_get_double.o bn_mp_get_int.o bn_mp_get_long.o bn_mp_get_long_long.o bn_mp_grow.o bn_mp_import.o \ -bn_mp_init.o bn_mp_init_copy.o bn_mp_init_multi.o bn_mp_init_set.o bn_mp_init_set_int.o bn_mp_init_size.o \ -bn_mp_invmod.o bn_mp_invmod_slow.o bn_mp_is_square.o bn_mp_jacobi.o bn_mp_karatsuba_mul.o \ -bn_mp_karatsuba_sqr.o bn_mp_kronecker.o bn_mp_lcm.o bn_mp_lshd.o bn_mp_mod.o bn_mp_mod_2d.o bn_mp_mod_d.o \ -bn_mp_montgomery_calc_normalization.o bn_mp_montgomery_reduce.o bn_mp_montgomery_setup.o bn_mp_mul.o \ -bn_mp_mul_2.o bn_mp_mul_2d.o bn_mp_mul_d.o bn_mp_mulmod.o bn_mp_n_root.o bn_mp_n_root_ex.o bn_mp_neg.o \ -bn_mp_or.o bn_mp_prime_fermat.o bn_mp_prime_frobenius_underwood.o bn_mp_prime_is_divisible.o \ +OBJECTS=bn_cutoffs.o bn_deprecated.o bn_mp_2expt.o bn_mp_abs.o bn_mp_add.o bn_mp_add_d.o bn_mp_addmod.o \ +bn_mp_and.o bn_mp_clamp.o bn_mp_clear.o bn_mp_clear_multi.o bn_mp_cmp.o bn_mp_cmp_d.o bn_mp_cmp_mag.o \ +bn_mp_cnt_lsb.o bn_mp_complement.o bn_mp_copy.o bn_mp_count_bits.o bn_mp_decr.o bn_mp_div.o bn_mp_div_2.o \ +bn_mp_div_2d.o bn_mp_div_3.o bn_mp_div_d.o bn_mp_dr_is_modulus.o bn_mp_dr_reduce.o bn_mp_dr_setup.o \ +bn_mp_error_to_string.o bn_mp_exch.o bn_mp_expt_u32.o bn_mp_exptmod.o bn_mp_exteuclid.o bn_mp_fread.o \ +bn_mp_from_sbin.o bn_mp_from_ubin.o bn_mp_fwrite.o bn_mp_gcd.o bn_mp_get_double.o bn_mp_get_i32.o \ +bn_mp_get_i64.o bn_mp_get_l.o bn_mp_get_ll.o bn_mp_get_mag_u32.o bn_mp_get_mag_u64.o bn_mp_get_mag_ul.o \ +bn_mp_get_mag_ull.o bn_mp_grow.o bn_mp_incr.o bn_mp_init.o bn_mp_init_copy.o bn_mp_init_i32.o \ +bn_mp_init_i64.o bn_mp_init_l.o bn_mp_init_ll.o bn_mp_init_multi.o bn_mp_init_set.o bn_mp_init_size.o \ +bn_mp_init_u32.o bn_mp_init_u64.o bn_mp_init_ul.o bn_mp_init_ull.o bn_mp_invmod.o bn_mp_is_square.o \ +bn_mp_iseven.o bn_mp_isodd.o bn_mp_kronecker.o bn_mp_lcm.o bn_mp_log_u32.o bn_mp_lshd.o bn_mp_mod.o \ +bn_mp_mod_2d.o bn_mp_mod_d.o bn_mp_montgomery_calc_normalization.o bn_mp_montgomery_reduce.o \ +bn_mp_montgomery_setup.o bn_mp_mul.o bn_mp_mul_2.o bn_mp_mul_2d.o bn_mp_mul_d.o bn_mp_mulmod.o bn_mp_neg.o \ +bn_mp_or.o bn_mp_pack.o bn_mp_pack_count.o bn_mp_prime_fermat.o bn_mp_prime_frobenius_underwood.o \ bn_mp_prime_is_prime.o bn_mp_prime_miller_rabin.o bn_mp_prime_next_prime.o \ -bn_mp_prime_rabin_miller_trials.o bn_mp_prime_random_ex.o bn_mp_prime_strong_lucas_selfridge.o \ -bn_mp_radix_size.o bn_mp_radix_smap.o bn_mp_rand.o bn_mp_read_radix.o bn_mp_read_signed_bin.o \ -bn_mp_read_unsigned_bin.o bn_mp_reduce.o bn_mp_reduce_2k.o bn_mp_reduce_2k_l.o bn_mp_reduce_2k_setup.o \ -bn_mp_reduce_2k_setup_l.o bn_mp_reduce_is_2k.o bn_mp_reduce_is_2k_l.o bn_mp_reduce_setup.o bn_mp_rshd.o \ -bn_mp_set.o bn_mp_set_double.o bn_mp_set_int.o bn_mp_set_long.o bn_mp_set_long_long.o bn_mp_shrink.o \ -bn_mp_signed_bin_size.o bn_mp_sqr.o bn_mp_sqrmod.o bn_mp_sqrt.o bn_mp_sqrtmod_prime.o bn_mp_sub.o \ -bn_mp_sub_d.o bn_mp_submod.o bn_mp_tc_and.o bn_mp_tc_div_2d.o bn_mp_tc_or.o bn_mp_tc_xor.o \ -bn_mp_to_signed_bin.o bn_mp_to_signed_bin_n.o bn_mp_to_unsigned_bin.o bn_mp_to_unsigned_bin_n.o \ -bn_mp_toom_mul.o bn_mp_toom_sqr.o bn_mp_toradix.o bn_mp_toradix_n.o bn_mp_unsigned_bin_size.o bn_mp_xor.o \ -bn_mp_zero.o bn_prime_tab.o bn_reverse.o bn_s_mp_add.o bn_s_mp_exptmod.o bn_s_mp_mul_digs.o \ -bn_s_mp_mul_high_digs.o bn_s_mp_sqr.o bn_s_mp_sub.o bncore.o - -HEADERS_PUB=tommath.h tommath_class.h tommath_superclass.h - -HEADERS=tommath_private.h $(HEADERS_PUB) +bn_mp_prime_rabin_miller_trials.o bn_mp_prime_rand.o bn_mp_prime_strong_lucas_selfridge.o \ +bn_mp_radix_size.o bn_mp_radix_smap.o bn_mp_rand.o bn_mp_read_radix.o bn_mp_reduce.o bn_mp_reduce_2k.o \ +bn_mp_reduce_2k_l.o bn_mp_reduce_2k_setup.o bn_mp_reduce_2k_setup_l.o bn_mp_reduce_is_2k.o \ +bn_mp_reduce_is_2k_l.o bn_mp_reduce_setup.o bn_mp_root_u32.o bn_mp_rshd.o bn_mp_sbin_size.o bn_mp_set.o \ +bn_mp_set_double.o bn_mp_set_i32.o bn_mp_set_i64.o bn_mp_set_l.o bn_mp_set_ll.o bn_mp_set_u32.o \ +bn_mp_set_u64.o bn_mp_set_ul.o bn_mp_set_ull.o bn_mp_shrink.o bn_mp_signed_rsh.o bn_mp_sqr.o \ +bn_mp_sqrmod.o bn_mp_sqrt.o bn_mp_sqrtmod_prime.o bn_mp_sub.o bn_mp_sub_d.o bn_mp_submod.o \ +bn_mp_to_radix.o bn_mp_to_sbin.o bn_mp_to_ubin.o bn_mp_ubin_size.o bn_mp_unpack.o bn_mp_xor.o bn_mp_zero.o \ +bn_prime_tab.o bn_s_mp_add.o bn_s_mp_balance_mul.o bn_s_mp_exptmod.o bn_s_mp_exptmod_fast.o \ +bn_s_mp_get_bit.o bn_s_mp_invmod_fast.o bn_s_mp_invmod_slow.o bn_s_mp_karatsuba_mul.o \ +bn_s_mp_karatsuba_sqr.o bn_s_mp_montgomery_reduce_fast.o bn_s_mp_mul_digs.o bn_s_mp_mul_digs_fast.o \ +bn_s_mp_mul_high_digs.o bn_s_mp_mul_high_digs_fast.o bn_s_mp_prime_is_divisible.o \ +bn_s_mp_rand_jenkins.o bn_s_mp_rand_platform.o bn_s_mp_reverse.o bn_s_mp_sqr.o bn_s_mp_sqr_fast.o \ +bn_s_mp_sub.o bn_s_mp_toom_mul.o bn_s_mp_toom_sqr.o + +HEADERS_PUB=tommath.h +HEADERS=tommath_private.h tommath_class.h tommath_superclass.h tommath_cutoffs.h $(HEADERS_PUB) #The default rule for make builds the libtommath.a library (static) default: $(LIBMAIN_S) #Dependencies on *.h @@ -76,28 +78,29 @@ $(LIBMAIN_S): $(OBJECTS) $(AR) $(ARFLAGS) $@ $(OBJECTS) $(RANLIB) $@ #Build test_standalone suite -test: $(LIBMAIN_S) demo/demo.c - $(CC) $(LTM_CFLAGS) $(LTM_LDFLAGS) demo/demo.c $(LIBMAIN_S) -DLTM_DEMO_TEST_VS_MTEST=0 -o $@ +test: demo/shared.o demo/test.o $(LIBMAIN_S) + $(CC) $(LTM_CFLAGS) $(LTM_LDFLAGS) $^ -o $@ @echo "NOTICE: start the tests by: ./test" test_standalone: test + @echo "test_standalone is deprecated, please use make-target 'test'" + +all: $(LIBMAIN_S) test -all: $(LIBMAIN_S) test_standalone +tune: $(LIBMAIN_S) + $(MAKE) -C etc tune + $(MAKE) #NOTE: this makefile works also on cygwin, thus we need to delete *.exe clean: -@rm -f $(OBJECTS) $(LIBMAIN_S) - -@rm -f demo/demo.o test test.exe + -@rm -f demo/main.o demo/opponent.o demo/test.o test test.exe #Install the library + headers install: $(LIBMAIN_S) @mkdir -p $(DESTDIR)$(INCPATH) $(DESTDIR)$(LIBPATH)/pkgconfig @cp $(LIBMAIN_S) $(DESTDIR)$(LIBPATH)/ @cp $(HEADERS_PUB) $(DESTDIR)$(INCPATH)/ @sed -e 's,^prefix=.*,prefix=$(PREFIX),' -e 's,^Version:.*,Version: $(VERSION),' libtommath.pc.in > $(DESTDIR)$(LIBPATH)/pkgconfig/libtommath.pc - -# ref: $Format:%D$ -# git commit: $Format:%H$ -# commit time: $Format:%ai$ Index: libtommath/makefile_include.mk ================================================================== --- libtommath/makefile_include.mk +++ libtommath/makefile_include.mk @@ -1,13 +1,13 @@ # # Include makefile for libtommath # #version of library -VERSION=1.1.0 -VERSION_PC=1.1.0 -VERSION_SO=2:0:1 +VERSION=1.2.0 +VERSION_PC=1.2.0 +VERSION_SO=3:0:2 PLATFORM := $(shell uname | sed -e 's/_.*//') # default make target default: ${LIBNAME} @@ -45,56 +45,75 @@ else MAKE=make endif endif -CFLAGS += -I./ -Wall -Wsign-compare -Wextra -Wshadow +LTM_CFLAGS += -I./ -Wall -Wsign-compare -Wextra -Wshadow + +ifdef SANITIZER +LTM_CFLAGS += -fsanitize=undefined -fno-sanitize-recover=all -fno-sanitize=float-divide-by-zero +endif ifndef NO_ADDTL_WARNINGS # additional warnings -CFLAGS += -Wsystem-headers -Wdeclaration-after-statement -Wbad-function-cast -Wcast-align -CFLAGS += -Wstrict-prototypes -Wpointer-arith +LTM_CFLAGS += -Wdeclaration-after-statement -Wbad-function-cast -Wcast-align +LTM_CFLAGS += -Wstrict-prototypes -Wpointer-arith +endif + +ifdef CONV_WARNINGS +LTM_CFLAGS += -std=c89 -Wconversion -Wsign-conversion +ifeq ($(CONV_WARNINGS), strict) +LTM_CFLAGS += -DMP_USE_ENUMS -Wc++-compat +endif +else +LTM_CFLAGS += -Wsystem-headers endif ifdef COMPILE_DEBUG #debug -CFLAGS += -g3 -else +LTM_CFLAGS += -g3 +endif ifdef COMPILE_SIZE #for size -CFLAGS += -Os +LTM_CFLAGS += -Os else ifndef IGNORE_SPEED #for speed -CFLAGS += -O3 -funroll-loops +LTM_CFLAGS += -O3 -funroll-loops #x86 optimizations [should be valid for any GCC install though] -CFLAGS += -fomit-frame-pointer +LTM_CFLAGS += -fomit-frame-pointer endif endif # COMPILE_SIZE -endif # COMPILE_DEBUG ifneq ($(findstring clang,$(CC)),) -CFLAGS += -Wno-typedef-redefinition -Wno-tautological-compare -Wno-builtin-requires-header +LTM_CFLAGS += -Wno-typedef-redefinition -Wno-tautological-compare -Wno-builtin-requires-header endif ifneq ($(findstring mingw,$(CC)),) -CFLAGS += -Wno-shadow +LTM_CFLAGS += -Wno-shadow endif ifeq ($(PLATFORM), Darwin) -CFLAGS += -Wno-nullability-completeness +LTM_CFLAGS += -Wno-nullability-completeness endif ifeq ($(PLATFORM), CYGWIN) LIBTOOLFLAGS += -no-undefined endif + +# add in the standard FLAGS +LTM_CFLAGS += $(CFLAGS) +LTM_LFLAGS += $(LFLAGS) +LTM_LDFLAGS += $(LDFLAGS) +LTM_LIBTOOLFLAGS += $(LIBTOOLFLAGS) + ifeq ($(PLATFORM),FreeBSD) _ARCH := $(shell sysctl -b hw.machine_arch) else - _ARCH := $(shell arch) + _ARCH := $(shell uname -m) endif # adjust coverage set ifneq ($(filter $(_ARCH), i386 i686 x86_64 amd64 ia64),) COVERAGE = test_standalone timing @@ -102,14 +121,12 @@ else COVERAGE = test_standalone COVERAGE_APP = ./test endif -HEADERS_PUB=tommath.h tommath_class.h tommath_superclass.h -HEADERS=tommath_private.h $(HEADERS_PUB) - -test_standalone: CFLAGS+=-DLTM_DEMO_TEST_VS_MTEST=0 +HEADERS_PUB=tommath.h +HEADERS=tommath_private.h tommath_class.h tommath_superclass.h tommath_cutoffs.h $(HEADERS_PUB) #LIBPATH The directory for libtommath to be installed to. #INCPATH The directory to install the header files for libtommath. #DATAPATH The directory to install the pdf docs. DESTDIR ?= @@ -118,13 +135,13 @@ INCPATH ?= $(PREFIX)/include DATAPATH ?= $(PREFIX)/share/doc/libtommath/pdf #make the code coverage of the library # -coverage: CFLAGS += -fprofile-arcs -ftest-coverage -DTIMING_NO_LOGS -coverage: LFLAGS += -lgcov -coverage: LDFLAGS += -lgcov +coverage: LTM_CFLAGS += -fprofile-arcs -ftest-coverage -DTIMING_NO_LOGS +coverage: LTM_LFLAGS += -lgcov +coverage: LTM_LDFLAGS += -lgcov coverage: $(COVERAGE) $(COVERAGE_APP) lcov: coverage @@ -139,10 +156,11 @@ # cleans everything - coverage output and standard 'clean' cleancov: cleancov-clean clean clean: - rm -f *.gcda *.gcno *.gcov *.bat *.o *.a *.obj *.lib *.exe *.dll etclib/*.o demo/demo.o test timing mpitest mtest/mtest mtest/mtest.exe \ - *.idx *.toc *.log *.aux *.dvi *.lof *.ind *.ilg *.ps *.log *.s mpi.c *.da *.dyn *.dpi tommath.tex `find . -type f | grep [~] | xargs` *.lo *.la - rm -rf .libs/ + rm -f *.gcda *.gcno *.gcov *.bat *.o *.a *.obj *.lib *.exe *.dll etclib/*.o \ + demo/*.o test timing mtest_opponent mtest/mtest mtest/mtest.exe tuning_list \ + *.s mpi.c *.da *.dyn *.dpi tommath.tex `find . -type f | grep [~] | xargs` *.lo *.la + rm -rf .libs/ demo/.libs ${MAKE} -C etc/ clean MAKE=${MAKE} ${MAKE} -C doc/ clean MAKE=${MAKE} ADDED libtommath/tommath.def Index: libtommath/tommath.def ================================================================== --- /dev/null +++ libtommath/tommath.def @@ -0,0 +1,145 @@ +; libtommath +; +; Use this command to produce a 32-bit .lib file, for use in any MSVC version +; lib -machine:X86 -name:libtommath.dll -def:tommath.def -out:tommath.lib +; Use this command to produce a 64-bit .lib file, for use in any MSVC version +; lib -machine:X64 -name:libtommath.dll -def:tommath.def -out:tommath.lib +; +EXPORTS + mp_2expt + mp_abs + mp_add + mp_add_d + mp_addmod + mp_and + mp_clamp + mp_clear + mp_clear_multi + mp_cmp + mp_cmp_d + mp_cmp_mag + mp_cnt_lsb + mp_complement + mp_copy + mp_count_bits + mp_decr + mp_div + mp_div_2 + mp_div_2d + mp_div_3 + mp_div_d + mp_dr_is_modulus + mp_dr_reduce + mp_dr_setup + mp_error_to_string + mp_exch + mp_expt_u32 + mp_exptmod + mp_exteuclid + mp_fread + mp_from_sbin + mp_from_ubin + mp_fwrite + mp_gcd + mp_get_double + mp_get_i32 + mp_get_i64 + mp_get_int + mp_get_l + mp_get_ll + mp_get_long + mp_get_long_long + mp_get_mag_u32 + mp_get_mag_u64 + mp_get_mag_ul + mp_get_mag_ull + mp_grow + mp_incr + mp_init + mp_init_copy + mp_init_i32 + mp_init_i64 + mp_init_l + mp_init_ll + mp_init_multi + mp_init_set + mp_init_set_int + mp_init_size + mp_init_u32 + mp_init_u64 + mp_init_ul + mp_init_ull + mp_invmod + mp_is_square + mp_iseven + mp_isodd + mp_kronecker + mp_lcm + mp_log_u32 + mp_lshd + mp_mod + mp_mod_2d + mp_mod_d + mp_montgomery_calc_normalization + mp_montgomery_reduce + mp_montgomery_setup + mp_mul + mp_mul_2 + mp_mul_2d + mp_mul_d + mp_mulmod + mp_neg + mp_or + mp_pack + mp_pack_count + mp_prime_fermat + mp_prime_frobenius_underwood + mp_prime_is_prime + mp_prime_miller_rabin + mp_prime_next_prime + mp_prime_rabin_miller_trials + mp_prime_rand + mp_prime_strong_lucas_selfridge + mp_radix_size + mp_rand + mp_read_radix + mp_reduce + mp_reduce_2k + mp_reduce_2k_l + mp_reduce_2k_setup + mp_reduce_2k_setup_l + mp_reduce_is_2k + mp_reduce_is_2k_l + mp_reduce_setup + mp_root_u32 + mp_rshd + mp_sbin_size + mp_set + mp_set_double + mp_set_i32 + mp_set_i64 + mp_set_int + mp_set_l + mp_set_ll + mp_set_long + mp_set_long_long + mp_set_u32 + mp_set_u64 + mp_set_ul + mp_set_ull + mp_shrink + mp_signed_rsh + mp_sqr + mp_sqrmod + mp_sqrt + mp_sqrtmod_prime + mp_sub + mp_sub_d + mp_submod + mp_to_radix + mp_to_sbin + mp_to_ubin + mp_ubin_size + mp_unpack + mp_xor + mp_zero Index: libtommath/tommath.h ================================================================== --- libtommath/tommath.h +++ libtommath/tommath.h @@ -2,22 +2,39 @@ /* SPDX-License-Identifier: Unlicense */ #ifndef BN_H_ #define BN_H_ -#include -#include +#ifndef MP_NO_STDINT +# include +#endif +#include #include -#include "tommath_class.h" +#ifdef LTM_NO_FILE +# warning LTM_NO_FILE has been deprecated, use MP_NO_FILE. +# define MP_NO_FILE +#endif + +#ifndef MP_NO_FILE +# include +#endif + +#ifdef MP_8BIT +# ifdef _MSC_VER +# pragma message("8-bit (MP_8BIT) support is deprecated and will be dropped completely in the next version.") +# else +# warning "8-bit (MP_8BIT) support is deprecated and will be dropped completely in the next version." +# endif +#endif #ifdef __cplusplus extern "C" { #endif /* MS Visual C++ doesn't have a 128bit type for words, so fall back to 32bit MPI's (where words are 64bit) */ -#if defined(_WIN32) || defined(__LLP64__) || defined(__e2k__) || defined(__LCC__) +#if (defined(_WIN32) || defined(__LLP64__) || defined(__e2k__) || defined(__LCC__)) && !defined(MP_64BIT) # define MP_32BIT #endif /* detect 64-bit mode if possible */ #if defined(__x86_64__) || defined(_M_X64) || defined(_M_AMD64) || \ @@ -24,472 +41,635 @@ defined(__powerpc64__) || defined(__ppc64__) || defined(__PPC64__) || \ defined(__s390x__) || defined(__arch64__) || defined(__aarch64__) || \ defined(__sparcv9) || defined(__sparc_v9__) || defined(__sparc64__) || \ defined(__ia64) || defined(__ia64__) || defined(__itanium__) || defined(_M_IA64) || \ defined(__LP64__) || defined(_LP64) || defined(__64BIT__) -# if !(defined(MP_32BIT) || defined(MP_16BIT) || defined(MP_8BIT)) -# if defined(__GNUC__) +# if !(defined(MP_64BIT) || defined(MP_32BIT) || defined(MP_16BIT) || defined(MP_8BIT)) +# if defined(__GNUC__) && !defined(__hppa) /* we support 128bit integers only via: __attribute__((mode(TI))) */ # define MP_64BIT # else /* otherwise we fall back to MP_32BIT even on 64bit platforms */ # define MP_32BIT # endif # endif #endif -typedef unsigned long long Tcl_WideUInt; +#ifdef MP_DIGIT_BIT +# error Defining MP_DIGIT_BIT is disallowed, use MP_8/16/31/32/64BIT +#endif /* some default configurations. * - * A "mp_digit" must be able to hold DIGIT_BIT + 1 bits - * A "mp_word" must be able to hold 2*DIGIT_BIT + 1 bits + * A "mp_digit" must be able to hold MP_DIGIT_BIT + 1 bits + * A "mp_word" must be able to hold 2*MP_DIGIT_BIT + 1 bits * * At the very least a mp_digit must be able to hold 7 bits * [any size beyond that is ok provided it doesn't overflow the data type] */ + #ifdef MP_8BIT typedef unsigned char mp_digit; -typedef unsigned short mp_word; -# define MP_SIZEOF_MP_DIGIT 1 -# ifdef DIGIT_BIT -# error You must not define DIGIT_BIT when using MP_8BIT -# endif +typedef unsigned short private_mp_word; +# define MP_DIGIT_BIT 7 #elif defined(MP_16BIT) typedef unsigned short mp_digit; -typedef unsigned int mp_word; -# define MP_SIZEOF_MP_DIGIT 2 -# ifdef DIGIT_BIT -# error You must not define DIGIT_BIT when using MP_16BIT -# endif +typedef unsigned int private_mp_word; +# define MP_DIGIT_BIT 15 #elif defined(MP_64BIT) /* for GCC only on supported platforms */ -typedef unsigned long long mp_digit; -typedef unsigned long mp_word __attribute__((mode(TI))); -# define DIGIT_BIT 60 +typedef Tcl_WideUInt mp_digit; +#if defined(__GNUC__) +typedef unsigned long private_mp_word __attribute__((mode(TI))); +#endif +# define MP_DIGIT_BIT 60 #else -/* this is the default case, 28-bit digits */ - -/* this is to make porting into LibTomCrypt easier :-) */ typedef unsigned int mp_digit; -typedef unsigned long long mp_word; - +typedef Tcl_WideUInt private_mp_word; # ifdef MP_31BIT -/* this is an extension that uses 31-bit digits */ -# define DIGIT_BIT 31 +/* + * This is an extension that uses 31-bit digits. + * Please be aware that not all functions support this size, especially s_mp_mul_digs_fast + * will be reduced to work on small numbers only: + * Up to 8 limbs, 248 bits instead of up to 512 limbs, 15872 bits with MP_28BIT. + */ +# define MP_DIGIT_BIT 31 # else /* default case is 28-bit digits, defines MP_28BIT as a handy macro to test */ -# define DIGIT_BIT 28 +# define MP_DIGIT_BIT 28 # define MP_28BIT # endif #endif -#define MP_MASK ((((mp_digit)1)<<((mp_digit)DIGIT_BIT))-((mp_digit)1)) +/* mp_word is a private type */ +#define mp_word MP_DEPRECATED_PRAGMA("mp_word has been made private") private_mp_word -/* equalities */ +#define MP_SIZEOF_MP_DIGIT (MP_DEPRECATED_PRAGMA("MP_SIZEOF_MP_DIGIT has been deprecated, use sizeof (mp_digit)") sizeof (mp_digit)) + +#define MP_MASK ((((mp_digit)1)<<((mp_digit)MP_DIGIT_BIT))-((mp_digit)1)) +#define MP_DIGIT_MAX MP_MASK + +/* Primality generation flags */ +#define MP_PRIME_BBS 0x0001 /* BBS style prime */ +#define MP_PRIME_SAFE 0x0002 /* Safe prime (p-1)/2 == prime */ +#define MP_PRIME_2MSB_ON 0x0008 /* force 2nd MSB to 1 */ + +#define LTM_PRIME_BBS (MP_DEPRECATED_PRAGMA("LTM_PRIME_BBS has been deprecated, use MP_PRIME_BBS") MP_PRIME_BBS) +#define LTM_PRIME_SAFE (MP_DEPRECATED_PRAGMA("LTM_PRIME_SAFE has been deprecated, use MP_PRIME_SAFE") MP_PRIME_SAFE) +#define LTM_PRIME_2MSB_ON (MP_DEPRECATED_PRAGMA("LTM_PRIME_2MSB_ON has been deprecated, use MP_PRIME_2MSB_ON") MP_PRIME_2MSB_ON) + +#ifdef MP_USE_ENUMS +typedef enum { + MP_ZPOS = 0, /* positive */ + MP_NEG = 1 /* negative */ +} mp_sign; +typedef enum { + MP_LT = -1, /* less than */ + MP_EQ = 0, /* equal */ + MP_GT = 1 /* greater than */ +} mp_ord; +typedef enum { + MP_NO = 0, + MP_YES = 1 +} mp_bool; +typedef enum { + MP_OKAY = 0, /* no error */ + MP_ERR = -1, /* unknown error */ + MP_MEM = -2, /* out of mem */ + MP_VAL = -3, /* invalid input */ + MP_ITER = -4, /* maximum iterations reached */ + MP_BUF = -5 /* buffer overflow, supplied buffer too small */ +} mp_err; +typedef enum { + MP_LSB_FIRST = -1, + MP_MSB_FIRST = 1 +} mp_order; +typedef enum { + MP_LITTLE_ENDIAN = -1, + MP_NATIVE_ENDIAN = 0, + MP_BIG_ENDIAN = 1 +} mp_endian; +#else +typedef int mp_sign; +#define MP_ZPOS 0 /* positive integer */ +#define MP_NEG 1 /* negative */ +typedef int mp_ord; #define MP_LT -1 /* less than */ #define MP_EQ 0 /* equal to */ #define MP_GT 1 /* greater than */ - -#define MP_ZPOS 0 /* positive integer */ -#define MP_NEG 1 /* negative */ - -#define MP_OKAY 0 /* ok result */ +typedef int mp_bool; +#define MP_YES 1 +#define MP_NO 0 +typedef int mp_err; +#define MP_OKAY 0 /* no error */ +#define MP_ERR -1 /* unknown error */ #define MP_MEM -2 /* out of mem */ #define MP_VAL -3 /* invalid input */ -#define MP_RANGE MP_VAL -#define MP_ITER -4 /* Max. iterations reached */ - -#define MP_YES 1 /* yes response */ -#define MP_NO 0 /* no response */ - -/* Primality generation flags */ -#define LTM_PRIME_BBS 0x0001 /* BBS style prime */ -#define LTM_PRIME_SAFE 0x0002 /* Safe prime (p-1)/2 == prime */ -#define LTM_PRIME_2MSB_ON 0x0008 /* force 2nd MSB to 1 */ - -typedef int mp_err; +#define MP_RANGE (MP_DEPRECATED_PRAGMA("MP_RANGE has been deprecated in favor of MP_VAL") MP_VAL) +#define MP_ITER -4 /* maximum iterations reached */ +#define MP_BUF -5 /* buffer overflow, supplied buffer too small */ +typedef int mp_order; +#define MP_LSB_FIRST -1 +#define MP_MSB_FIRST 1 +typedef int mp_endian; +#define MP_LITTLE_ENDIAN -1 +#define MP_NATIVE_ENDIAN 0 +#define MP_BIG_ENDIAN 1 +#endif + +/* tunable cutoffs */ + +#ifndef MP_FIXED_CUTOFFS +extern int +KARATSUBA_MUL_CUTOFF, +KARATSUBA_SQR_CUTOFF, +TOOM_MUL_CUTOFF, +TOOM_SQR_CUTOFF; +#endif /* define this to use lower memory usage routines (exptmods mostly) */ /* #define MP_LOW_MEM */ /* default precision */ #ifndef MP_PREC # ifndef MP_LOW_MEM -# define MP_PREC 32 /* default digits of precision */ +# define PRIVATE_MP_PREC 32 /* default digits of precision */ +# elif defined(MP_8BIT) +# define PRIVATE_MP_PREC 16 /* default digits of precision */ # else -# define MP_PREC 8 /* default digits of precision */ +# define PRIVATE_MP_PREC 8 /* default digits of precision */ # endif +# define MP_PREC (MP_DEPRECATED_PRAGMA("MP_PREC is an internal macro") PRIVATE_MP_PREC) +#endif + +/* size of comba arrays, should be at least 2 * 2**(BITS_PER_WORD - BITS_PER_DIGIT*2) */ +#define PRIVATE_MP_WARRAY (int)(1 << (((CHAR_BIT * (int)sizeof(private_mp_word)) - (2 * MP_DIGIT_BIT)) + 1)) +#define MP_WARRAY (MP_DEPRECATED_PRAGMA("MP_WARRAY is an internal macro") PRIVATE_MP_WARRAY) + +#if defined(__GNUC__) && __GNUC__ >= 4 +# define MP_NULL_TERMINATED __attribute__((sentinel)) +#else +# define MP_NULL_TERMINATED +#endif + +/* + * MP_WUR - warn unused result + * --------------------------- + * + * The result of functions annotated with MP_WUR must be + * checked and cannot be ignored. + * + * Most functions in libtommath return an error code. + * This error code must be checked in order to prevent crashes or invalid + * results. + * + * If you still want to avoid the error checks for quick and dirty programs + * without robustness guarantees, you can `#define MP_WUR` before including + * tommath.h, disabling the warnings. + */ +#ifndef MP_WUR +# if defined(__GNUC__) && __GNUC__ >= 4 +# define MP_WUR __attribute__((warn_unused_result)) +# else +# define MP_WUR +# endif +#endif + +#if defined(__GNUC__) && (__GNUC__ * 100 + __GNUC_MINOR__ >= 405) +# define MP_DEPRECATED(x) __attribute__((deprecated("replaced by " #x))) +# define PRIVATE_MP_DEPRECATED_PRAGMA(s) _Pragma(#s) +# define MP_DEPRECATED_PRAGMA(s) PRIVATE_MP_DEPRECATED_PRAGMA(GCC warning s) +#elif defined(_MSC_VER) && _MSC_VER >= 1500 +# define MP_DEPRECATED(x) __declspec(deprecated("replaced by " #x)) +# define MP_DEPRECATED_PRAGMA(s) __pragma(message(s)) +#else +# define MP_DEPRECATED(s) +# define MP_DEPRECATED_PRAGMA(s) #endif + +#define DIGIT_BIT (MP_DEPRECATED_PRAGMA("DIGIT_BIT macro is deprecated, MP_DIGIT_BIT instead") MP_DIGIT_BIT) +#define USED(m) (MP_DEPRECATED_PRAGMA("USED macro is deprecated, use z->used instead") (m)->used) +#define DIGIT(m, k) (MP_DEPRECATED_PRAGMA("DIGIT macro is deprecated, use z->dp instead") (m)->dp[(k)]) +#define SIGN(m) (MP_DEPRECATED_PRAGMA("SIGN macro is deprecated, use z->sign instead") (m)->sign) /* the infamous mp_int structure */ typedef struct { - int used, alloc, sign; + int used, alloc; + mp_sign sign; mp_digit *dp; } mp_int; /* callback for mp_prime_random, should fill dst with random bytes and return how many read [upto len] */ -typedef int ltm_prime_callback(unsigned char *dst, int len, void *dat); - +typedef int private_mp_prime_callback(unsigned char *dst, int len, void *dat); +typedef private_mp_prime_callback MP_DEPRECATED(mp_rand_source) ltm_prime_callback; /* error code to char* string */ -const char *mp_error_to_string(int code); +const char *mp_error_to_string(mp_err code) MP_WUR; /* ---> init and deinit bignum functions <--- */ /* init a bignum */ -int mp_init(mp_int *a); +mp_err mp_init(mp_int *a) MP_WUR; /* free a bignum */ void mp_clear(mp_int *a); /* init a null terminated series of arguments */ -int mp_init_multi(mp_int *mp, ...); +mp_err mp_init_multi(mp_int *mp, ...) MP_NULL_TERMINATED MP_WUR; /* clear a null terminated series of arguments */ -void mp_clear_multi(mp_int *mp, ...); +void mp_clear_multi(mp_int *mp, ...) MP_NULL_TERMINATED; /* exchange two ints */ void mp_exch(mp_int *a, mp_int *b); /* shrink ram required for a bignum */ -mp_err mp_shrink(mp_int *a); +mp_err mp_shrink(mp_int *a) MP_WUR; /* grow an int to a given size */ -mp_err mp_grow(mp_int *a, int size); +mp_err mp_grow(mp_int *a, int size) MP_WUR; /* init to a given number of digits */ -mp_err mp_init_size(mp_int *a, int size); +mp_err mp_init_size(mp_int *a, int size) MP_WUR; /* ---> Basic Manipulations <--- */ #define mp_iszero(a) (((a)->used == 0) ? MP_YES : MP_NO) -#define mp_iseven(a) (((a)->used == 0 || (((a)->dp[0] & 1) == 0)) ? MP_YES : MP_NO) -#define mp_isodd(a) (((a)->used > 0 && (((a)->dp[0] & 1) == 1)) ? MP_YES : MP_NO) +mp_bool mp_iseven(const mp_int *a) MP_WUR; +mp_bool mp_isodd(const mp_int *a) MP_WUR; #define mp_isneg(a) (((a)->sign != MP_ZPOS) ? MP_YES : MP_NO) /* set to zero */ void mp_zero(mp_int *a); -/* set to a digit */ +/* get and set doubles */ +double mp_get_double(const mp_int *a) MP_WUR; +mp_err mp_set_double(mp_int *a, double b) MP_WUR; + +/* get integer, set integer and init with integer (int32_t) */ +#ifndef MP_NO_STDINT +int32_t mp_get_i32(const mp_int *a) MP_WUR; +void mp_set_i32(mp_int *a, int32_t b); +mp_err mp_init_i32(mp_int *a, int32_t b) MP_WUR; + +/* get integer, set integer and init with integer, behaves like two complement for negative numbers (uint32_t) */ +#define mp_get_u32(a) ((uint32_t)mp_get_i32(a)) +void mp_set_u32(mp_int *a, uint32_t b); +mp_err mp_init_u32(mp_int *a, uint32_t b) MP_WUR; + +/* get integer, set integer and init with integer (int64_t) */ +int64_t mp_get_i64(const mp_int *a) MP_WUR; +void mp_set_i64(mp_int *a, int64_t b); +mp_err mp_init_i64(mp_int *a, int64_t b) MP_WUR; + +/* get integer, set integer and init with integer, behaves like two complement for negative numbers (uint64_t) */ +#define mp_get_u64(a) ((uint64_t)mp_get_i64(a)) +void mp_set_u64(mp_int *a, uint64_t b); +mp_err mp_init_u64(mp_int *a, uint64_t b) MP_WUR; + +/* get magnitude */ +uint32_t mp_get_mag_u32(const mp_int *a) MP_WUR; +uint64_t mp_get_mag_u64(const mp_int *a) MP_WUR; +#endif +unsigned long mp_get_mag_ul(const mp_int *a) MP_WUR; +Tcl_WideUInt mp_get_mag_ull(const mp_int *a) MP_WUR; + +/* get integer, set integer (long) */ +long mp_get_l(const mp_int *a) MP_WUR; +void mp_set_l(mp_int *a, long b); +mp_err mp_init_l(mp_int *a, long b) MP_WUR; + +/* get integer, set integer (unsigned long) */ +#define mp_get_ul(a) ((unsigned long)mp_get_l(a)) +void mp_set_ul(mp_int *a, unsigned long b); +mp_err mp_init_ul(mp_int *a, unsigned long b) MP_WUR; + +/* get integer, set integer (Tcl_WideInt) */ +Tcl_WideInt mp_get_ll(const mp_int *a) MP_WUR; +void mp_set_ll(mp_int *a, Tcl_WideInt b); +mp_err mp_init_ll(mp_int *a, Tcl_WideInt b) MP_WUR; + +/* get integer, set integer (Tcl_WideUInt) */ +#define mp_get_ull(a) ((Tcl_WideUInt)mp_get_ll(a)) +void mp_set_ull(mp_int *a, Tcl_WideUInt b); +mp_err mp_init_ull(mp_int *a, Tcl_WideUInt b) MP_WUR; + +/* set to single unsigned digit, up to MP_DIGIT_MAX */ void mp_set(mp_int *a, mp_digit b); - -/* set a double */ -int mp_set_double(mp_int *a, double b); - -/* set a 32-bit const */ -int mp_set_int(mp_int *a, unsigned long b); - -/* set a platform dependent unsigned long value */ -int mp_set_long(mp_int *a, unsigned long b); - -/* set a platform dependent unsigned long long value */ -int mp_set_long_long(mp_int *a, unsigned long long b); - -/* get a double */ -double mp_get_double(const mp_int *a); - -/* get a 32-bit value */ -unsigned long mp_get_int(const mp_int *a); - -/* get a platform dependent unsigned long value */ -unsigned long mp_get_long(const mp_int *a); - -/* get a platform dependent unsigned long long value */ -unsigned long long mp_get_long_long(const mp_int *a); - -/* initialize and set a digit */ -int mp_init_set(mp_int *a, mp_digit b); - -/* initialize and set 32-bit value */ -int mp_init_set_int(mp_int *a, unsigned long b); +mp_err mp_init_set(mp_int *a, mp_digit b) MP_WUR; + +/* get integer, set integer and init with integer (deprecated) */ +MP_DEPRECATED(mp_get_mag_u32/mp_get_u32) unsigned long mp_get_int(const mp_int *a) MP_WUR; +MP_DEPRECATED(mp_get_mag_ul/mp_get_ul) unsigned long mp_get_long(const mp_int *a) MP_WUR; +MP_DEPRECATED(mp_get_mag_ull/mp_get_ull) Tcl_WideUInt mp_get_long_long(const mp_int *a) MP_WUR; +MP_DEPRECATED(mp_set_ul) mp_err mp_set_int(mp_int *a, unsigned long b); +MP_DEPRECATED(mp_set_ul) mp_err mp_set_long(mp_int *a, unsigned long b); +MP_DEPRECATED(mp_set_ull) mp_err mp_set_long_long(mp_int *a, Tcl_WideUInt b); +MP_DEPRECATED(mp_init_ul) mp_err mp_init_set_int(mp_int *a, unsigned long b) MP_WUR; /* copy, b = a */ -int mp_copy(const mp_int *a, mp_int *b); +mp_err mp_copy(const mp_int *a, mp_int *b) MP_WUR; /* inits and copies, a = b */ -int mp_init_copy(mp_int *a, const mp_int *b); +mp_err mp_init_copy(mp_int *a, const mp_int *b) MP_WUR; /* trim unused digits */ void mp_clamp(mp_int *a); -/* import binary data */ -int mp_import(mp_int *rop, size_t count, int order, size_t size, int endian, size_t nails, const void *op); /* export binary data */ -int mp_export(void *rop, size_t *countp, int order, size_t size, int endian, size_t nails, const mp_int *op); +MP_DEPRECATED(mp_pack) mp_err mp_export(void *rop, size_t *countp, int order, size_t size, + int endian, size_t nails, const mp_int *op) MP_WUR; + +/* import binary data */ +MP_DEPRECATED(mp_unpack) mp_err mp_import(mp_int *rop, size_t count, int order, + size_t size, int endian, size_t nails, + const void *op) MP_WUR; + +/* unpack binary data */ +mp_err mp_unpack(mp_int *rop, size_t count, mp_order order, size_t size, mp_endian endian, + size_t nails, const void *op) MP_WUR; + +/* pack binary data */ +size_t mp_pack_count(const mp_int *a, size_t nails, size_t size) MP_WUR; +mp_err mp_pack(void *rop, size_t maxcount, size_t *written, mp_order order, size_t size, + mp_endian endian, size_t nails, const mp_int *op) MP_WUR; /* ---> digit manipulation <--- */ /* right shift by "b" digits */ void mp_rshd(mp_int *a, int b); /* left shift by "b" digits */ -int mp_lshd(mp_int *a, int b); +mp_err mp_lshd(mp_int *a, int b) MP_WUR; /* c = a / 2**b, implemented as c = a >> b */ -int mp_div_2d(const mp_int *a, int b, mp_int *c, mp_int *d); +mp_err mp_div_2d(const mp_int *a, int b, mp_int *c, mp_int *d) MP_WUR; /* b = a/2 */ -int mp_div_2(const mp_int *a, mp_int *b); +mp_err mp_div_2(const mp_int *a, mp_int *b) MP_WUR; + +/* a/3 => 3c + d == a */ +mp_err mp_div_3(const mp_int *a, mp_int *c, mp_digit *d) MP_WUR; /* c = a * 2**b, implemented as c = a << b */ -int mp_mul_2d(const mp_int *a, int b, mp_int *c); +mp_err mp_mul_2d(const mp_int *a, int b, mp_int *c) MP_WUR; /* b = a*2 */ -int mp_mul_2(const mp_int *a, mp_int *b); +mp_err mp_mul_2(const mp_int *a, mp_int *b) MP_WUR; /* c = a mod 2**b */ -int mp_mod_2d(const mp_int *a, int b, mp_int *c); +mp_err mp_mod_2d(const mp_int *a, int b, mp_int *c) MP_WUR; /* computes a = 2**b */ -int mp_2expt(mp_int *a, int b); +mp_err mp_2expt(mp_int *a, int b) MP_WUR; /* Counts the number of lsbs which are zero before the first zero bit */ -int mp_cnt_lsb(const mp_int *a); +int mp_cnt_lsb(const mp_int *a) MP_WUR; /* I Love Earth! */ /* makes a pseudo-random mp_int of a given size */ -int mp_rand(mp_int *a, int digits); +mp_err mp_rand(mp_int *a, int digits) MP_WUR; /* makes a pseudo-random small int of a given size */ -int mp_rand_digit(mp_digit *r); +MP_DEPRECATED(mp_rand) mp_err mp_rand_digit(mp_digit *r) MP_WUR; +/* use custom random data source instead of source provided the platform */ +void mp_rand_source(mp_err(*source)(void *out, size_t size)); #ifdef MP_PRNG_ENABLE_LTM_RNG +# warning MP_PRNG_ENABLE_LTM_RNG has been deprecated, use mp_rand_source instead. /* A last resort to provide random data on systems without any of the other * implemented ways to gather entropy. * It is compatible with `rng_get_bytes()` from libtomcrypt so you could * provide that one and then set `ltm_rng = rng_get_bytes;` */ extern unsigned long (*ltm_rng)(unsigned char *out, unsigned long outlen, void (*callback)(void)); extern void (*ltm_rng_callback)(void); #endif /* ---> binary operations <--- */ -/* c = a XOR b */ -int mp_xor(const mp_int *a, const mp_int *b, mp_int *c); - -/* c = a OR b */ -int mp_or(const mp_int *a, const mp_int *b, mp_int *c); - -/* c = a AND b */ -int mp_and(const mp_int *a, const mp_int *b, mp_int *c); /* Checks the bit at position b and returns MP_YES - if the bit is 1, MP_NO if it is 0 and MP_VAL - in case of error */ -int mp_get_bit(const mp_int *a, int b); + * if the bit is 1, MP_NO if it is 0 and MP_VAL + * in case of error + */ +MP_DEPRECATED(s_mp_get_bit) int mp_get_bit(const mp_int *a, int b) MP_WUR; /* c = a XOR b (two complement) */ -int mp_tc_xor(const mp_int *a, const mp_int *b, mp_int *c); +MP_DEPRECATED(mp_xor) mp_err mp_tc_xor(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; +mp_err mp_xor(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* c = a OR b (two complement) */ -int mp_tc_or(const mp_int *a, const mp_int *b, mp_int *c); +MP_DEPRECATED(mp_or) mp_err mp_tc_or(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; +mp_err mp_or(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* c = a AND b (two complement) */ -int mp_tc_and(const mp_int *a, const mp_int *b, mp_int *c); +MP_DEPRECATED(mp_and) mp_err mp_tc_and(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; +mp_err mp_and(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; -/* right shift (two complement) */ -int mp_signed_rsh(const mp_int *a, int b, mp_int *c); +/* b = ~a (bitwise not, two complement) */ +mp_err mp_complement(const mp_int *a, mp_int *b) MP_WUR; + +/* right shift with sign extension */ +MP_DEPRECATED(mp_signed_rsh) mp_err mp_tc_div_2d(const mp_int *a, int b, mp_int *c) MP_WUR; +mp_err mp_signed_rsh(const mp_int *a, int b, mp_int *c) MP_WUR; /* ---> Basic arithmetic <--- */ -/* b = ~a */ -int mp_complement(const mp_int *a, mp_int *b); - /* b = -a */ -int mp_neg(const mp_int *a, mp_int *b); +mp_err mp_neg(const mp_int *a, mp_int *b) MP_WUR; /* b = |a| */ -int mp_abs(const mp_int *a, mp_int *b); +mp_err mp_abs(const mp_int *a, mp_int *b) MP_WUR; /* compare a to b */ -int mp_cmp(const mp_int *a, const mp_int *b); +mp_ord mp_cmp(const mp_int *a, const mp_int *b) MP_WUR; /* compare |a| to |b| */ -int mp_cmp_mag(const mp_int *a, const mp_int *b); +mp_ord mp_cmp_mag(const mp_int *a, const mp_int *b) MP_WUR; /* c = a + b */ -int mp_add(const mp_int *a, const mp_int *b, mp_int *c); +mp_err mp_add(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* c = a - b */ -int mp_sub(const mp_int *a, const mp_int *b, mp_int *c); +mp_err mp_sub(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* c = a * b */ -int mp_mul(const mp_int *a, const mp_int *b, mp_int *c); +mp_err mp_mul(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* b = a*a */ -int mp_sqr(const mp_int *a, mp_int *b); +mp_err mp_sqr(const mp_int *a, mp_int *b) MP_WUR; /* a/b => cb + d == a */ -int mp_div(const mp_int *a, const mp_int *b, mp_int *c, mp_int *d); +mp_err mp_div(const mp_int *a, const mp_int *b, mp_int *c, mp_int *d) MP_WUR; /* c = a mod b, 0 <= c < b */ -int mp_mod(const mp_int *a, const mp_int *b, mp_int *c); +mp_err mp_mod(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; + +/* Increment "a" by one like "a++". Changes input! */ +mp_err mp_incr(mp_int *a) MP_WUR; + +/* Decrement "a" by one like "a--". Changes input! */ +mp_err mp_decr(mp_int *a) MP_WUR; /* ---> single digit functions <--- */ /* compare against a single digit */ -int mp_cmp_d(const mp_int *a, mp_digit b); +mp_ord mp_cmp_d(const mp_int *a, mp_digit b) MP_WUR; /* c = a + b */ -int mp_add_d(const mp_int *a, mp_digit b, mp_int *c); +mp_err mp_add_d(const mp_int *a, mp_digit b, mp_int *c) MP_WUR; /* c = a - b */ -int mp_sub_d(const mp_int *a, mp_digit b, mp_int *c); +mp_err mp_sub_d(const mp_int *a, mp_digit b, mp_int *c) MP_WUR; /* c = a * b */ -int mp_mul_d(const mp_int *a, mp_digit b, mp_int *c); +mp_err mp_mul_d(const mp_int *a, mp_digit b, mp_int *c) MP_WUR; /* a/b => cb + d == a */ -int mp_div_d(const mp_int *a, mp_digit b, mp_int *c, mp_digit *d); - -/* a/3 => 3c + d == a */ -int mp_div_3(const mp_int *a, mp_int *c, mp_digit *d); - -/* c = a**b */ -int mp_expt_d(const mp_int *a, mp_digit b, mp_int *c); -int mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast); +mp_err mp_div_d(const mp_int *a, mp_digit b, mp_int *c, mp_digit *d) MP_WUR; /* c = a mod b, 0 <= c < b */ -int mp_mod_d(const mp_int *a, mp_digit b, mp_digit *c); +mp_err mp_mod_d(const mp_int *a, mp_digit b, mp_digit *c) MP_WUR; /* ---> number theory <--- */ /* d = a + b (mod c) */ -int mp_addmod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d); +mp_err mp_addmod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d) MP_WUR; /* d = a - b (mod c) */ -int mp_submod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d); +mp_err mp_submod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d) MP_WUR; /* d = a * b (mod c) */ -int mp_mulmod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d); +mp_err mp_mulmod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d) MP_WUR; /* c = a * a (mod b) */ -int mp_sqrmod(const mp_int *a, const mp_int *b, mp_int *c); +mp_err mp_sqrmod(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* c = 1/a (mod b) */ -int mp_invmod(const mp_int *a, const mp_int *b, mp_int *c); +mp_err mp_invmod(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* c = (a, b) */ -int mp_gcd(const mp_int *a, const mp_int *b, mp_int *c); +mp_err mp_gcd(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* produces value such that U1*a + U2*b = U3 */ -int mp_exteuclid(const mp_int *a, const mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3); +mp_err mp_exteuclid(const mp_int *a, const mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3) MP_WUR; /* c = [a, b] or (a*b)/(a, b) */ -int mp_lcm(const mp_int *a, const mp_int *b, mp_int *c); +mp_err mp_lcm(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* finds one of the b'th root of a, such that |c|**b <= |a| * * returns error if a < 0 and b is even */ -int mp_n_root(const mp_int *a, mp_digit b, mp_int *c); -int mp_n_root_ex(const mp_int *a, mp_digit b, mp_int *c, int fast); +mp_err mp_root_u32(const mp_int *a, unsigned int b, mp_int *c) MP_WUR; +MP_DEPRECATED(mp_root_u32) mp_err mp_n_root(const mp_int *a, mp_digit b, mp_int *c) MP_WUR; +MP_DEPRECATED(mp_root_u32) mp_err mp_n_root_ex(const mp_int *a, mp_digit b, mp_int *c, int fast) MP_WUR; /* special sqrt algo */ -int mp_sqrt(const mp_int *arg, mp_int *ret); +mp_err mp_sqrt(const mp_int *arg, mp_int *ret) MP_WUR; /* special sqrt (mod prime) */ -int mp_sqrtmod_prime(const mp_int *n, const mp_int *prime, mp_int *ret); +mp_err mp_sqrtmod_prime(const mp_int *n, const mp_int *prime, mp_int *ret) MP_WUR; /* is number a square? */ -int mp_is_square(const mp_int *arg, int *ret); +mp_err mp_is_square(const mp_int *arg, mp_bool *ret) MP_WUR; /* computes the jacobi c = (a | n) (or Legendre if b is prime) */ -int mp_jacobi(const mp_int *a, const mp_int *n, int *c); +MP_DEPRECATED(mp_kronecker) mp_err mp_jacobi(const mp_int *a, const mp_int *n, int *c) MP_WUR; /* computes the Kronecker symbol c = (a | p) (like jacobi() but with {a,p} in Z */ -int mp_kronecker(const mp_int *a, const mp_int *p, int *c); +mp_err mp_kronecker(const mp_int *a, const mp_int *p, int *c) MP_WUR; /* used to setup the Barrett reduction for a given modulus b */ -int mp_reduce_setup(mp_int *a, const mp_int *b); +mp_err mp_reduce_setup(mp_int *a, const mp_int *b) MP_WUR; /* Barrett Reduction, computes a (mod b) with a precomputed value c * * Assumes that 0 < x <= m*m, note if 0 > x > -(m*m) then you can merely * compute the reduction as -1 * mp_reduce(mp_abs(x)) [pseudo code]. */ -int mp_reduce(mp_int *x, const mp_int *m, const mp_int *mu); +mp_err mp_reduce(mp_int *x, const mp_int *m, const mp_int *mu) MP_WUR; /* setups the montgomery reduction */ -int mp_montgomery_setup(const mp_int *n, mp_digit *rho); +mp_err mp_montgomery_setup(const mp_int *n, mp_digit *rho) MP_WUR; /* computes a = B**n mod b without division or multiplication useful for * normalizing numbers in a Montgomery system. */ -int mp_montgomery_calc_normalization(mp_int *a, const mp_int *b); +mp_err mp_montgomery_calc_normalization(mp_int *a, const mp_int *b) MP_WUR; /* computes x/R == x (mod N) via Montgomery Reduction */ -int mp_montgomery_reduce(mp_int *x, const mp_int *n, mp_digit rho); +mp_err mp_montgomery_reduce(mp_int *x, const mp_int *n, mp_digit rho) MP_WUR; /* returns 1 if a is a valid DR modulus */ -int mp_dr_is_modulus(const mp_int *a); +mp_bool mp_dr_is_modulus(const mp_int *a) MP_WUR; /* sets the value of "d" required for mp_dr_reduce */ void mp_dr_setup(const mp_int *a, mp_digit *d); /* reduces a modulo n using the Diminished Radix method */ -int mp_dr_reduce(mp_int *x, const mp_int *n, mp_digit k); +mp_err mp_dr_reduce(mp_int *x, const mp_int *n, mp_digit k) MP_WUR; /* returns true if a can be reduced with mp_reduce_2k */ -int mp_reduce_is_2k(const mp_int *a); +mp_bool mp_reduce_is_2k(const mp_int *a) MP_WUR; /* determines k value for 2k reduction */ -int mp_reduce_2k_setup(const mp_int *a, mp_digit *d); +mp_err mp_reduce_2k_setup(const mp_int *a, mp_digit *d) MP_WUR; /* reduces a modulo b where b is of the form 2**p - k [0 <= a] */ -int mp_reduce_2k(mp_int *a, const mp_int *n, mp_digit d); +mp_err mp_reduce_2k(mp_int *a, const mp_int *n, mp_digit d) MP_WUR; /* returns true if a can be reduced with mp_reduce_2k_l */ -int mp_reduce_is_2k_l(const mp_int *a); +mp_bool mp_reduce_is_2k_l(const mp_int *a) MP_WUR; /* determines k value for 2k reduction */ -int mp_reduce_2k_setup_l(const mp_int *a, mp_int *d); +mp_err mp_reduce_2k_setup_l(const mp_int *a, mp_int *d) MP_WUR; /* reduces a modulo b where b is of the form 2**p - k [0 <= a] */ -int mp_reduce_2k_l(mp_int *a, const mp_int *n, const mp_int *d); +mp_err mp_reduce_2k_l(mp_int *a, const mp_int *n, const mp_int *d) MP_WUR; /* Y = G**X (mod P) */ -int mp_exptmod(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y); +mp_err mp_exptmod(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y) MP_WUR; /* ---> Primes <--- */ /* number of primes */ #ifdef MP_8BIT -# define PRIME_SIZE 31 +# define PRIVATE_MP_PRIME_TAB_SIZE 31 #else -# define PRIME_SIZE 256 +# define PRIVATE_MP_PRIME_TAB_SIZE 256 #endif +#define PRIME_SIZE (MP_DEPRECATED_PRAGMA("PRIME_SIZE has been made internal") PRIVATE_MP_PRIME_TAB_SIZE) /* table of first PRIME_SIZE primes */ -extern const mp_digit ltm_prime_tab[PRIME_SIZE]; +MP_DEPRECATED(internal) extern const mp_digit ltm_prime_tab[PRIVATE_MP_PRIME_TAB_SIZE]; /* result=1 if a is divisible by one of the first PRIME_SIZE primes */ -int mp_prime_is_divisible(const mp_int *a, int *result); +MP_DEPRECATED(mp_prime_is_prime) mp_err mp_prime_is_divisible(const mp_int *a, mp_bool *result) MP_WUR; /* performs one Fermat test of "a" using base "b". * Sets result to 0 if composite or 1 if probable prime */ -int mp_prime_fermat(const mp_int *a, const mp_int *b, int *result); +mp_err mp_prime_fermat(const mp_int *a, const mp_int *b, mp_bool *result) MP_WUR; /* performs one Miller-Rabin test of "a" using base "b". * Sets result to 0 if composite or 1 if probable prime */ -int mp_prime_miller_rabin(const mp_int *a, const mp_int *b, int *result); +mp_err mp_prime_miller_rabin(const mp_int *a, const mp_int *b, mp_bool *result) MP_WUR; /* This gives [for a given bit size] the number of trials required * such that Miller-Rabin gives a prob of failure lower than 2^-96 */ -int mp_prime_rabin_miller_trials(int size); +int mp_prime_rabin_miller_trials(int size) MP_WUR; /* performs one strong Lucas-Selfridge test of "a". * Sets result to 0 if composite or 1 if probable prime */ -int mp_prime_strong_lucas_selfridge(const mp_int *a, int *result); +mp_err mp_prime_strong_lucas_selfridge(const mp_int *a, mp_bool *result) MP_WUR; /* performs one Frobenius test of "a" as described by Paul Underwood. * Sets result to 0 if composite or 1 if probable prime */ -int mp_prime_frobenius_underwood(const mp_int *N, int *result); +mp_err mp_prime_frobenius_underwood(const mp_int *N, mp_bool *result) MP_WUR; /* performs t random rounds of Miller-Rabin on "a" additional to * bases 2 and 3. Also performs an initial sieve of trial * division. Determines if "a" is prime with probability * of error no more than (1/4)**t. @@ -501,18 +681,18 @@ * Is Fips 186.4 compliant if called with t as computed by * mp_prime_rabin_miller_trials(); * * Sets result to 1 if probably prime, 0 otherwise */ -int mp_prime_is_prime(const mp_int *a, int t, int *result); +mp_err mp_prime_is_prime(const mp_int *a, int t, mp_bool *result) MP_WUR; /* finds the next prime after the number "a" using "t" trials * of Miller-Rabin. * * bbs_style = 1 means the prime must be congruent to 3 mod 4 */ -int mp_prime_next_prime(mp_int *a, int t, int bbs_style); +mp_err mp_prime_next_prime(mp_int *a, int t, int bbs_style) MP_WUR; /* makes a truly random prime of a given size (bytes), * call with bbs = 1 if you want it to be congruent to 3 mod 4 * * You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can @@ -519,67 +699,87 @@ * have passed to the callback (e.g. a state or something). This function doesn't use "dat" itself * so it can be NULL * * The prime generated will be larger than 2^(8*size). */ -#define mp_prime_random(a, t, size, bbs, cb, dat) mp_prime_random_ex(a, t, ((size) * 8) + 1, (bbs==1)?LTM_PRIME_BBS:0, cb, dat) +#define mp_prime_random(a, t, size, bbs, cb, dat) (MP_DEPRECATED_PRAGMA("mp_prime_random has been deprecated, use mp_prime_rand instead") mp_prime_random_ex(a, t, ((size) * 8) + 1, (bbs==1)?MP_PRIME_BBS:0, cb, dat)) /* makes a truly random prime of a given size (bits), * * Flags are as follows: * - * LTM_PRIME_BBS - make prime congruent to 3 mod 4 - * LTM_PRIME_SAFE - make sure (p-1)/2 is prime as well (implies LTM_PRIME_BBS) - * LTM_PRIME_2MSB_ON - make the 2nd highest bit one + * MP_PRIME_BBS - make prime congruent to 3 mod 4 + * MP_PRIME_SAFE - make sure (p-1)/2 is prime as well (implies MP_PRIME_BBS) + * MP_PRIME_2MSB_ON - make the 2nd highest bit one * * You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can * have passed to the callback (e.g. a state or something). This function doesn't use "dat" itself * so it can be NULL * */ -int mp_prime_random_ex(mp_int *a, int t, int size, int flags, ltm_prime_callback cb, void *dat); +MP_DEPRECATED(mp_prime_rand) mp_err mp_prime_random_ex(mp_int *a, int t, int size, int flags, + private_mp_prime_callback cb, void *dat) MP_WUR; +mp_err mp_prime_rand(mp_int *a, int t, int size, int flags) MP_WUR; + +/* Integer logarithm to integer base */ +mp_err mp_log_u32(const mp_int *a, unsigned int base, unsigned int *c) MP_WUR; + +/* c = a**b */ +mp_err mp_expt_u32(const mp_int *a, unsigned int b, mp_int *c) MP_WUR; +MP_DEPRECATED(mp_expt_u32) mp_err mp_expt_d(const mp_int *a, mp_digit b, mp_int *c) MP_WUR; +MP_DEPRECATED(mp_expt_u32) mp_err mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast) MP_WUR; /* ---> radix conversion <--- */ -int mp_count_bits(const mp_int *a); - -int mp_unsigned_bin_size(const mp_int *a); -int mp_read_unsigned_bin(mp_int *a, const unsigned char *b, int c); -int mp_to_unsigned_bin(const mp_int *a, unsigned char *b); -int mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen); - -int mp_signed_bin_size(const mp_int *a); -int mp_read_signed_bin(mp_int *a, const unsigned char *b, int c); -int mp_to_signed_bin(const mp_int *a, unsigned char *b); -int mp_to_signed_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen); - -int mp_read_radix(mp_int *a, const char *str, int radix); -int mp_toradix(const mp_int *a, char *str, int radix); -int mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen); -int mp_radix_size(const mp_int *a, int radix, int *size); - -#ifndef LTM_NO_FILE -int mp_fread(mp_int *a, int radix, FILE *stream); -int mp_fwrite(const mp_int *a, int radix, FILE *stream); +int mp_count_bits(const mp_int *a) MP_WUR; + + +MP_DEPRECATED(mp_ubin_size) int mp_unsigned_bin_size(const mp_int *a) MP_WUR; +MP_DEPRECATED(mp_from_ubin) mp_err mp_read_unsigned_bin(mp_int *a, const unsigned char *b, int c) MP_WUR; +MP_DEPRECATED(mp_to_ubin) mp_err mp_to_unsigned_bin(const mp_int *a, unsigned char *b) MP_WUR; +MP_DEPRECATED(mp_to_ubin) mp_err mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen) MP_WUR; + +MP_DEPRECATED(mp_sbin_size) int mp_signed_bin_size(const mp_int *a) MP_WUR; +MP_DEPRECATED(mp_from_sbin) mp_err mp_read_signed_bin(mp_int *a, const unsigned char *b, int c) MP_WUR; +MP_DEPRECATED(mp_to_sbin) mp_err mp_to_signed_bin(const mp_int *a, unsigned char *b) MP_WUR; +MP_DEPRECATED(mp_to_sbin) mp_err mp_to_signed_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen) MP_WUR; + +size_t mp_ubin_size(const mp_int *a) MP_WUR; +mp_err mp_from_ubin(mp_int *a, const unsigned char *buf, size_t size) MP_WUR; +mp_err mp_to_ubin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written) MP_WUR; + +size_t mp_sbin_size(const mp_int *a) MP_WUR; +mp_err mp_from_sbin(mp_int *a, const unsigned char *buf, size_t size) MP_WUR; +mp_err mp_to_sbin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written) MP_WUR; + +mp_err mp_read_radix(mp_int *a, const char *str, int radix) MP_WUR; +MP_DEPRECATED(mp_to_radix) mp_err mp_toradix(const mp_int *a, char *str, int radix) MP_WUR; +MP_DEPRECATED(mp_to_radix) mp_err mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen) MP_WUR; +mp_err mp_to_radix(const mp_int *a, char *str, size_t maxlen, size_t *written, int radix) MP_WUR; +mp_err mp_radix_size(const mp_int *a, int radix, int *size) MP_WUR; + +#ifndef MP_NO_FILE +mp_err mp_fread(mp_int *a, int radix, FILE *stream) MP_WUR; +mp_err mp_fwrite(const mp_int *a, int radix, FILE *stream) MP_WUR; #endif -#define mp_read_raw(mp, str, len) mp_read_signed_bin((mp), (str), (len)) -#define mp_raw_size(mp) mp_signed_bin_size(mp) -#define mp_toraw(mp, str) mp_to_signed_bin((mp), (str)) -#define mp_read_mag(mp, str, len) mp_read_unsigned_bin((mp), (str), (len)) -#define mp_mag_size(mp) mp_unsigned_bin_size(mp) -#define mp_tomag(mp, str) mp_to_unsigned_bin((mp), (str)) - -#define mp_tobinary(M, S) mp_toradix((M), (S), 2) -#define mp_tooctal(M, S) mp_toradix((M), (S), 8) -#define mp_todecimal(M, S) mp_toradix((M), (S), 10) -#define mp_tohex(M, S) mp_toradix((M), (S), 16) +#define mp_read_raw(mp, str, len) (MP_DEPRECATED_PRAGMA("replaced by mp_read_signed_bin") mp_read_signed_bin((mp), (str), (len))) +#define mp_raw_size(mp) (MP_DEPRECATED_PRAGMA("replaced by mp_signed_bin_size") mp_signed_bin_size(mp)) +#define mp_toraw(mp, str) (MP_DEPRECATED_PRAGMA("replaced by mp_to_signed_bin") mp_to_signed_bin((mp), (str))) +#define mp_read_mag(mp, str, len) (MP_DEPRECATED_PRAGMA("replaced by mp_read_unsigned_bin") mp_read_unsigned_bin((mp), (str), (len)) +#define mp_mag_size(mp) (MP_DEPRECATED_PRAGMA("replaced by mp_unsigned_bin_size") mp_unsigned_bin_size(mp)) +#define mp_tomag(mp, str) (MP_DEPRECATED_PRAGMA("replaced by mp_to_unsigned_bin") mp_to_unsigned_bin((mp), (str))) + +#define mp_tobinary(M, S) (MP_DEPRECATED_PRAGMA("replaced by mp_to_binary") mp_toradix((M), (S), 2)) +#define mp_tooctal(M, S) (MP_DEPRECATED_PRAGMA("replaced by mp_to_octal") mp_toradix((M), (S), 8)) +#define mp_todecimal(M, S) (MP_DEPRECATED_PRAGMA("replaced by mp_to_decimal") mp_toradix((M), (S), 10)) +#define mp_tohex(M, S) (MP_DEPRECATED_PRAGMA("replaced by mp_to_hex") mp_toradix((M), (S), 16)) + +#define mp_to_binary(M, S, N) mp_to_radix((M), (S), (N), NULL, 2) +#define mp_to_octal(M, S, N) mp_to_radix((M), (S), (N), NULL, 8) +#define mp_to_decimal(M, S, N) mp_to_radix((M), (S), (N), NULL, 10) +#define mp_to_hex(M, S, N) mp_to_radix((M), (S), (N), NULL, 16) #ifdef __cplusplus } #endif #endif - - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: libtommath/tommath_class.h ================================================================== --- libtommath/tommath_class.h +++ libtommath/tommath_class.h @@ -1,32 +1,20 @@ -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ #if !(defined(LTM1) && defined(LTM2) && defined(LTM3)) +#define LTM_INSIDE #if defined(LTM2) # define LTM3 #endif #if defined(LTM1) # define LTM2 #endif #define LTM1 #if defined(LTM_ALL) -# define BN_ERROR_C -# define BN_FAST_MP_INVMOD_C -# define BN_FAST_MP_MONTGOMERY_REDUCE_C -# define BN_FAST_S_MP_MUL_DIGS_C -# define BN_FAST_S_MP_MUL_HIGH_DIGS_C -# define BN_FAST_S_MP_SQR_C +# define BN_CUTOFFS_C +# define BN_DEPRECATED_C # define BN_MP_2EXPT_C # define BN_MP_ABS_C # define BN_MP_ADD_C # define BN_MP_ADD_D_C # define BN_MP_ADDMOD_C @@ -39,49 +27,60 @@ # define BN_MP_CMP_MAG_C # define BN_MP_CNT_LSB_C # define BN_MP_COMPLEMENT_C # define BN_MP_COPY_C # define BN_MP_COUNT_BITS_C +# define BN_MP_DECR_C # define BN_MP_DIV_C # define BN_MP_DIV_2_C # define BN_MP_DIV_2D_C # define BN_MP_DIV_3_C # define BN_MP_DIV_D_C # define BN_MP_DR_IS_MODULUS_C # define BN_MP_DR_REDUCE_C # define BN_MP_DR_SETUP_C +# define BN_MP_ERROR_TO_STRING_C # define BN_MP_EXCH_C -# define BN_MP_EXPORT_C -# define BN_MP_EXPT_D_C -# define BN_MP_EXPT_D_EX_C +# define BN_MP_EXPT_U32_C # define BN_MP_EXPTMOD_C -# define BN_MP_EXPTMOD_FAST_C # define BN_MP_EXTEUCLID_C # define BN_MP_FREAD_C +# define BN_MP_FROM_SBIN_C +# define BN_MP_FROM_UBIN_C # define BN_MP_FWRITE_C # define BN_MP_GCD_C -# define BN_S_MP_GET_BIT_C # define BN_MP_GET_DOUBLE_C -# define BN_MP_GET_INT_C -# define BN_MP_GET_LONG_C -# define BN_MP_GET_LONG_LONG_C +# define BN_MP_GET_I32_C +# define BN_MP_GET_I64_C +# define BN_MP_GET_L_C +# define BN_MP_GET_LL_C +# define BN_MP_GET_MAG_U32_C +# define BN_MP_GET_MAG_U64_C +# define BN_MP_GET_MAG_UL_C +# define BN_MP_GET_MAG_ULL_C # define BN_MP_GROW_C -# define BN_MP_IMPORT_C +# define BN_MP_INCR_C # define BN_MP_INIT_C # define BN_MP_INIT_COPY_C +# define BN_MP_INIT_I32_C +# define BN_MP_INIT_I64_C +# define BN_MP_INIT_L_C +# define BN_MP_INIT_LL_C # define BN_MP_INIT_MULTI_C # define BN_MP_INIT_SET_C -# define BN_MP_INIT_SET_INT_C # define BN_MP_INIT_SIZE_C +# define BN_MP_INIT_U32_C +# define BN_MP_INIT_U64_C +# define BN_MP_INIT_UL_C +# define BN_MP_INIT_ULL_C # define BN_MP_INVMOD_C -# define BN_MP_INVMOD_SLOW_C # define BN_MP_IS_SQUARE_C -# define BN_MP_JACOBI_C -# define BN_MP_KARATSUBA_MUL_C -# define BN_MP_KARATSUBA_SQR_C +# define BN_MP_ISEVEN_C +# define BN_MP_ISODD_C # define BN_MP_KRONECKER_C # define BN_MP_LCM_C +# define BN_MP_LOG_U32_C # define BN_MP_LSHD_C # define BN_MP_MOD_C # define BN_MP_MOD_2D_C # define BN_MP_MOD_D_C # define BN_MP_MONTGOMERY_CALC_NORMALIZATION_C @@ -90,155 +89,210 @@ # define BN_MP_MUL_C # define BN_MP_MUL_2_C # define BN_MP_MUL_2D_C # define BN_MP_MUL_D_C # define BN_MP_MULMOD_C -# define BN_MP_N_ROOT_C -# define BN_MP_N_ROOT_EX_C # define BN_MP_NEG_C # define BN_MP_OR_C +# define BN_MP_PACK_C +# define BN_MP_PACK_COUNT_C # define BN_MP_PRIME_FERMAT_C # define BN_MP_PRIME_FROBENIUS_UNDERWOOD_C -# define BN_MP_PRIME_IS_DIVISIBLE_C # define BN_MP_PRIME_IS_PRIME_C # define BN_MP_PRIME_MILLER_RABIN_C # define BN_MP_PRIME_NEXT_PRIME_C # define BN_MP_PRIME_RABIN_MILLER_TRIALS_C -# define BN_MP_PRIME_RANDOM_EX_C +# define BN_MP_PRIME_RAND_C # define BN_MP_PRIME_STRONG_LUCAS_SELFRIDGE_C # define BN_MP_RADIX_SIZE_C # define BN_MP_RADIX_SMAP_C # define BN_MP_RAND_C # define BN_MP_READ_RADIX_C -# define BN_MP_READ_SIGNED_BIN_C -# define BN_MP_READ_UNSIGNED_BIN_C # define BN_MP_REDUCE_C # define BN_MP_REDUCE_2K_C # define BN_MP_REDUCE_2K_L_C # define BN_MP_REDUCE_2K_SETUP_C # define BN_MP_REDUCE_2K_SETUP_L_C # define BN_MP_REDUCE_IS_2K_C # define BN_MP_REDUCE_IS_2K_L_C # define BN_MP_REDUCE_SETUP_C +# define BN_MP_ROOT_U32_C # define BN_MP_RSHD_C +# define BN_MP_SBIN_SIZE_C # define BN_MP_SET_C # define BN_MP_SET_DOUBLE_C -# define BN_MP_SET_INT_C -# define BN_MP_SET_LONG_C -# define BN_MP_SET_LONG_LONG_C +# define BN_MP_SET_I32_C +# define BN_MP_SET_I64_C +# define BN_MP_SET_L_C +# define BN_MP_SET_LL_C +# define BN_MP_SET_U32_C +# define BN_MP_SET_U64_C +# define BN_MP_SET_UL_C +# define BN_MP_SET_ULL_C # define BN_MP_SHRINK_C -# define BN_MP_SIGNED_BIN_SIZE_C +# define BN_MP_SIGNED_RSH_C # define BN_MP_SQR_C # define BN_MP_SQRMOD_C # define BN_MP_SQRT_C # define BN_MP_SQRTMOD_PRIME_C # define BN_MP_SUB_C # define BN_MP_SUB_D_C # define BN_MP_SUBMOD_C -# define BN_MP_TC_AND_C +# define BN_MP_TO_RADIX_C +# define BN_MP_TO_SBIN_C +# define BN_MP_TO_UBIN_C +# define BN_MP_UBIN_SIZE_C +# define BN_MP_UNPACK_C +# define BN_MP_XOR_C +# define BN_MP_ZERO_C +# define BN_PRIME_TAB_C +# define BN_S_MP_ADD_C +# define BN_S_MP_BALANCE_MUL_C +# define BN_S_MP_EXPTMOD_C +# define BN_S_MP_EXPTMOD_FAST_C +# define BN_S_MP_GET_BIT_C +# define BN_S_MP_INVMOD_FAST_C +# define BN_S_MP_INVMOD_SLOW_C +# define BN_S_MP_KARATSUBA_MUL_C +# define BN_S_MP_KARATSUBA_SQR_C +# define BN_S_MP_MONTGOMERY_REDUCE_FAST_C +# define BN_S_MP_MUL_DIGS_C +# define BN_S_MP_MUL_DIGS_FAST_C +# define BN_S_MP_MUL_HIGH_DIGS_C +# define BN_S_MP_MUL_HIGH_DIGS_FAST_C +# define BN_S_MP_PRIME_IS_DIVISIBLE_C +# define BN_S_MP_RAND_JENKINS_C +# define BN_S_MP_RAND_PLATFORM_C +# define BN_S_MP_REVERSE_C +# define BN_S_MP_SQR_C +# define BN_S_MP_SQR_FAST_C +# define BN_S_MP_SUB_C +# define BN_S_MP_TOOM_MUL_C +# define BN_S_MP_TOOM_SQR_C +#endif +#endif +#if defined(BN_CUTOFFS_C) +#endif + +#if defined(BN_DEPRECATED_C) +# define BN_FAST_MP_INVMOD_C +# define BN_FAST_MP_MONTGOMERY_REDUCE_C +# define BN_FAST_S_MP_MUL_DIGS_C +# define BN_FAST_S_MP_MUL_HIGH_DIGS_C +# define BN_FAST_S_MP_SQR_C +# define BN_MP_AND_C +# define BN_MP_BALANCE_MUL_C +# define BN_MP_CMP_D_C +# define BN_MP_EXPORT_C +# define BN_MP_EXPTMOD_FAST_C +# define BN_MP_EXPT_D_C +# define BN_MP_EXPT_D_EX_C +# define BN_MP_EXPT_U32_C +# define BN_MP_FROM_SBIN_C +# define BN_MP_FROM_UBIN_C +# define BN_MP_GET_BIT_C +# define BN_MP_GET_INT_C +# define BN_MP_GET_LONG_C +# define BN_MP_GET_LONG_LONG_C +# define BN_MP_GET_MAG_U32_C +# define BN_MP_GET_MAG_ULL_C +# define BN_MP_GET_MAG_UL_C +# define BN_MP_IMPORT_C +# define BN_MP_INIT_SET_INT_C +# define BN_MP_INIT_U32_C +# define BN_MP_INVMOD_SLOW_C +# define BN_MP_JACOBI_C +# define BN_MP_KARATSUBA_MUL_C +# define BN_MP_KARATSUBA_SQR_C +# define BN_MP_KRONECKER_C +# define BN_MP_N_ROOT_C +# define BN_MP_N_ROOT_EX_C +# define BN_MP_OR_C +# define BN_MP_PACK_C +# define BN_MP_PRIME_IS_DIVISIBLE_C +# define BN_MP_PRIME_RANDOM_EX_C +# define BN_MP_RAND_DIGIT_C +# define BN_MP_READ_SIGNED_BIN_C +# define BN_MP_READ_UNSIGNED_BIN_C +# define BN_MP_ROOT_U32_C +# define BN_MP_SBIN_SIZE_C +# define BN_MP_SET_INT_C +# define BN_MP_SET_LONG_C +# define BN_MP_SET_LONG_LONG_C +# define BN_MP_SET_U32_C +# define BN_MP_SET_U64_C +# define BN_MP_SIGNED_BIN_SIZE_C # define BN_MP_SIGNED_RSH_C +# define BN_MP_TC_AND_C +# define BN_MP_TC_DIV_2D_C # define BN_MP_TC_OR_C # define BN_MP_TC_XOR_C -# define BN_MP_TO_SIGNED_BIN_C -# define BN_MP_TO_SIGNED_BIN_N_C -# define BN_MP_TO_UNSIGNED_BIN_C -# define BN_MP_TO_UNSIGNED_BIN_N_C # define BN_MP_TOOM_MUL_C # define BN_MP_TOOM_SQR_C # define BN_MP_TORADIX_C # define BN_MP_TORADIX_N_C +# define BN_MP_TO_RADIX_C +# define BN_MP_TO_SBIN_C +# define BN_MP_TO_SIGNED_BIN_C +# define BN_MP_TO_SIGNED_BIN_N_C +# define BN_MP_TO_UBIN_C +# define BN_MP_TO_UNSIGNED_BIN_C +# define BN_MP_TO_UNSIGNED_BIN_N_C +# define BN_MP_UBIN_SIZE_C +# define BN_MP_UNPACK_C # define BN_MP_UNSIGNED_BIN_SIZE_C # define BN_MP_XOR_C -# define BN_MP_ZERO_C -# define BN_PRIME_TAB_C -# define BN_REVERSE_C -# define BN_S_MP_ADD_C -# define BN_S_MP_EXPTMOD_C -# define BN_S_MP_MUL_DIGS_C -# define BN_S_MP_MUL_HIGH_DIGS_C -# define BN_S_MP_SQR_C -# define BN_S_MP_SUB_C -# define BNCORE_C -#endif -#if defined(BN_ERROR_C) -# define BN_MP_ERROR_TO_STRING_C -#endif - -#if defined(BN_FAST_MP_INVMOD_C) -# define BN_MP_ISEVEN_C -# define BN_MP_INIT_MULTI_C -# define BN_MP_COPY_C -# define BN_MP_MOD_C -# define BN_MP_ISZERO_C -# define BN_MP_SET_C -# define BN_MP_DIV_2_C -# define BN_MP_ISODD_C -# define BN_MP_SUB_C -# define BN_MP_CMP_C -# define BN_MP_CMP_D_C -# define BN_MP_ADD_C -# define BN_MP_CMP_MAG_C -# define BN_MP_EXCH_C -# define BN_MP_CLEAR_MULTI_C -#endif - -#if defined(BN_FAST_MP_MONTGOMERY_REDUCE_C) -# define BN_MP_GROW_C -# define BN_MP_RSHD_C -# define BN_MP_CLAMP_C -# define BN_MP_CMP_MAG_C -# define BN_S_MP_SUB_C -#endif - -#if defined(BN_FAST_S_MP_MUL_DIGS_C) -# define BN_MP_GROW_C -# define BN_MP_CLAMP_C -#endif - -#if defined(BN_FAST_S_MP_MUL_HIGH_DIGS_C) -# define BN_MP_GROW_C -# define BN_MP_CLAMP_C -#endif - -#if defined(BN_FAST_S_MP_SQR_C) -# define BN_MP_GROW_C -# define BN_MP_CLAMP_C +# define BN_S_MP_BALANCE_MUL_C +# define BN_S_MP_EXPTMOD_FAST_C +# define BN_S_MP_GET_BIT_C +# define BN_S_MP_INVMOD_FAST_C +# define BN_S_MP_INVMOD_SLOW_C +# define BN_S_MP_KARATSUBA_MUL_C +# define BN_S_MP_KARATSUBA_SQR_C +# define BN_S_MP_MONTGOMERY_REDUCE_FAST_C +# define BN_S_MP_MUL_DIGS_FAST_C +# define BN_S_MP_MUL_HIGH_DIGS_FAST_C +# define BN_S_MP_PRIME_IS_DIVISIBLE_C +# define BN_S_MP_PRIME_RANDOM_EX_C +# define BN_S_MP_RAND_SOURCE_C +# define BN_S_MP_REVERSE_C +# define BN_S_MP_SQR_FAST_C +# define BN_S_MP_TOOM_MUL_C +# define BN_S_MP_TOOM_SQR_C #endif #if defined(BN_MP_2EXPT_C) -# define BN_MP_ZERO_C # define BN_MP_GROW_C +# define BN_MP_ZERO_C #endif #if defined(BN_MP_ABS_C) # define BN_MP_COPY_C #endif #if defined(BN_MP_ADD_C) -# define BN_S_MP_ADD_C # define BN_MP_CMP_MAG_C +# define BN_S_MP_ADD_C # define BN_S_MP_SUB_C #endif #if defined(BN_MP_ADD_D_C) +# define BN_MP_CLAMP_C # define BN_MP_GROW_C # define BN_MP_SUB_D_C -# define BN_MP_CLAMP_C #endif #if defined(BN_MP_ADDMOD_C) -# define BN_MP_INIT_C # define BN_MP_ADD_C # define BN_MP_CLEAR_C +# define BN_MP_INIT_C # define BN_MP_MOD_C #endif #if defined(BN_MP_AND_C) -# define BN_MP_INIT_COPY_C # define BN_MP_CLAMP_C -# define BN_MP_EXCH_C -# define BN_MP_CLEAR_C +# define BN_MP_GROW_C #endif #if defined(BN_MP_CLAMP_C) #endif @@ -258,11 +312,10 @@ #if defined(BN_MP_CMP_MAG_C) #endif #if defined(BN_MP_CNT_LSB_C) -# define BN_MP_ISZERO_C #endif #if defined(BN_MP_COMPLEMENT_C) # define BN_MP_NEG_C # define BN_MP_SUB_D_C @@ -272,647 +325,601 @@ # define BN_MP_GROW_C #endif #if defined(BN_MP_COUNT_BITS_C) #endif + +#if defined(BN_MP_DECR_C) +# define BN_MP_INCR_C +# define BN_MP_SET_C +# define BN_MP_SUB_D_C +# define BN_MP_ZERO_C +#endif #if defined(BN_MP_DIV_C) -# define BN_MP_ISZERO_C +# define BN_MP_ADD_C +# define BN_MP_CLAMP_C +# define BN_MP_CLEAR_C +# define BN_MP_CMP_C # define BN_MP_CMP_MAG_C # define BN_MP_COPY_C -# define BN_MP_ZERO_C -# define BN_MP_INIT_MULTI_C -# define BN_MP_SET_C # define BN_MP_COUNT_BITS_C -# define BN_MP_ABS_C -# define BN_MP_MUL_2D_C -# define BN_MP_CMP_C -# define BN_MP_SUB_C -# define BN_MP_ADD_C # define BN_MP_DIV_2D_C # define BN_MP_EXCH_C -# define BN_MP_CLEAR_MULTI_C -# define BN_MP_INIT_SIZE_C # define BN_MP_INIT_C # define BN_MP_INIT_COPY_C +# define BN_MP_INIT_SIZE_C # define BN_MP_LSHD_C -# define BN_MP_RSHD_C +# define BN_MP_MUL_2D_C # define BN_MP_MUL_D_C -# define BN_MP_CLAMP_C -# define BN_MP_CLEAR_C +# define BN_MP_RSHD_C +# define BN_MP_SUB_C +# define BN_MP_ZERO_C #endif #if defined(BN_MP_DIV_2_C) -# define BN_MP_GROW_C # define BN_MP_CLAMP_C +# define BN_MP_GROW_C #endif #if defined(BN_MP_DIV_2D_C) +# define BN_MP_CLAMP_C # define BN_MP_COPY_C -# define BN_MP_ZERO_C # define BN_MP_MOD_2D_C # define BN_MP_RSHD_C -# define BN_MP_CLAMP_C +# define BN_MP_ZERO_C #endif #if defined(BN_MP_DIV_3_C) -# define BN_MP_INIT_SIZE_C # define BN_MP_CLAMP_C +# define BN_MP_CLEAR_C # define BN_MP_EXCH_C -# define BN_MP_CLEAR_C +# define BN_MP_INIT_SIZE_C #endif #if defined(BN_MP_DIV_D_C) -# define BN_MP_ISZERO_C +# define BN_MP_CLAMP_C +# define BN_MP_CLEAR_C # define BN_MP_COPY_C # define BN_MP_DIV_2D_C # define BN_MP_DIV_3_C -# define BN_MP_INIT_SIZE_C -# define BN_MP_CLAMP_C # define BN_MP_EXCH_C -# define BN_MP_CLEAR_C +# define BN_MP_INIT_SIZE_C #endif #if defined(BN_MP_DR_IS_MODULUS_C) #endif #if defined(BN_MP_DR_REDUCE_C) -# define BN_MP_GROW_C # define BN_MP_CLAMP_C # define BN_MP_CMP_MAG_C +# define BN_MP_GROW_C # define BN_S_MP_SUB_C #endif #if defined(BN_MP_DR_SETUP_C) #endif + +#if defined(BN_MP_ERROR_TO_STRING_C) +#endif #if defined(BN_MP_EXCH_C) #endif -#if defined(BN_MP_EXPORT_C) -# define BN_MP_INIT_COPY_C -# define BN_MP_COUNT_BITS_C -# define BN_MP_DIV_2D_C -# define BN_MP_CLEAR_C -#endif - -#if defined(BN_MP_EXPT_D_C) -# define BN_MP_EXPT_D_EX_C -#endif - -#if defined(BN_MP_EXPT_D_EX_C) -# define BN_MP_INIT_COPY_C -# define BN_MP_SET_C -# define BN_MP_MUL_C -# define BN_MP_CLEAR_C +#if defined(BN_MP_EXPT_U32_C) +# define BN_MP_CLEAR_C +# define BN_MP_INIT_COPY_C +# define BN_MP_MUL_C +# define BN_MP_SET_C # define BN_MP_SQR_C #endif #if defined(BN_MP_EXPTMOD_C) -# define BN_MP_INIT_C -# define BN_MP_INVMOD_C -# define BN_MP_CLEAR_C # define BN_MP_ABS_C # define BN_MP_CLEAR_MULTI_C +# define BN_MP_DR_IS_MODULUS_C +# define BN_MP_INIT_MULTI_C +# define BN_MP_INVMOD_C +# define BN_MP_REDUCE_IS_2K_C # define BN_MP_REDUCE_IS_2K_L_C # define BN_S_MP_EXPTMOD_C -# define BN_MP_DR_IS_MODULUS_C -# define BN_MP_REDUCE_IS_2K_C -# define BN_MP_ISODD_C -# define BN_MP_EXPTMOD_FAST_C -#endif - -#if defined(BN_MP_EXPTMOD_FAST_C) -# define BN_MP_COUNT_BITS_C -# define BN_MP_INIT_SIZE_C -# define BN_MP_CLEAR_C -# define BN_MP_MONTGOMERY_SETUP_C -# define BN_FAST_MP_MONTGOMERY_REDUCE_C -# define BN_MP_MONTGOMERY_REDUCE_C -# define BN_MP_DR_SETUP_C -# define BN_MP_DR_REDUCE_C -# define BN_MP_REDUCE_2K_SETUP_C -# define BN_MP_REDUCE_2K_C -# define BN_MP_MONTGOMERY_CALC_NORMALIZATION_C -# define BN_MP_MULMOD_C -# define BN_MP_SET_C -# define BN_MP_MOD_C -# define BN_MP_COPY_C -# define BN_MP_SQR_C -# define BN_MP_MUL_C -# define BN_MP_EXCH_C +# define BN_S_MP_EXPTMOD_FAST_C #endif #if defined(BN_MP_EXTEUCLID_C) -# define BN_MP_INIT_MULTI_C -# define BN_MP_SET_C +# define BN_MP_CLEAR_MULTI_C # define BN_MP_COPY_C -# define BN_MP_ISZERO_C # define BN_MP_DIV_C +# define BN_MP_EXCH_C +# define BN_MP_INIT_MULTI_C # define BN_MP_MUL_C -# define BN_MP_SUB_C # define BN_MP_NEG_C -# define BN_MP_EXCH_C -# define BN_MP_CLEAR_MULTI_C +# define BN_MP_SET_C +# define BN_MP_SUB_C #endif #if defined(BN_MP_FREAD_C) -# define BN_MP_ZERO_C -# define BN_MP_S_RMAP_REVERSE_SZ_C -# define BN_MP_S_RMAP_REVERSE_C +# define BN_MP_ADD_D_C # define BN_MP_MUL_D_C -# define BN_MP_ADD_D_C -# define BN_MP_CMP_D_C +# define BN_MP_ZERO_C +#endif + +#if defined(BN_MP_FROM_SBIN_C) +# define BN_MP_FROM_UBIN_C +#endif + +#if defined(BN_MP_FROM_UBIN_C) +# define BN_MP_CLAMP_C +# define BN_MP_GROW_C +# define BN_MP_MUL_2D_C +# define BN_MP_ZERO_C #endif #if defined(BN_MP_FWRITE_C) # define BN_MP_RADIX_SIZE_C -# define BN_MP_TORADIX_C +# define BN_MP_TO_RADIX_C #endif #if defined(BN_MP_GCD_C) -# define BN_MP_ISZERO_C # define BN_MP_ABS_C -# define BN_MP_INIT_COPY_C +# define BN_MP_CLEAR_C +# define BN_MP_CMP_MAG_C # define BN_MP_CNT_LSB_C # define BN_MP_DIV_2D_C -# define BN_MP_CMP_MAG_C # define BN_MP_EXCH_C -# define BN_S_MP_SUB_C +# define BN_MP_INIT_COPY_C # define BN_MP_MUL_2D_C -# define BN_MP_CLEAR_C -#endif - -#if defined(BN_S_MP_GET_BIT_C) -# define BN_MP_ISZERO_C +# define BN_S_MP_SUB_C #endif #if defined(BN_MP_GET_DOUBLE_C) -# define BN_MP_ISNEG_C #endif -#if defined(BN_MP_GET_INT_C) +#if defined(BN_MP_GET_I32_C) +# define BN_MP_GET_MAG_U32_C #endif -#if defined(BN_MP_GET_LONG_C) +#if defined(BN_MP_GET_I64_C) +# define BN_MP_GET_MAG_U64_C #endif -#if defined(BN_MP_GET_LONG_LONG_C) +#if defined(BN_MP_GET_L_C) +# define BN_MP_GET_MAG_UL_C +#endif + +#if defined(BN_MP_GET_LL_C) +# define BN_MP_GET_MAG_ULL_C +#endif + +#if defined(BN_MP_GET_MAG_U32_C) +#endif + +#if defined(BN_MP_GET_MAG_U64_C) +#endif + +#if defined(BN_MP_GET_MAG_UL_C) +#endif + +#if defined(BN_MP_GET_MAG_ULL_C) #endif #if defined(BN_MP_GROW_C) #endif -#if defined(BN_MP_IMPORT_C) -# define BN_MP_ZERO_C -# define BN_MP_MUL_2D_C -# define BN_MP_CLAMP_C +#if defined(BN_MP_INCR_C) +# define BN_MP_ADD_D_C +# define BN_MP_DECR_C +# define BN_MP_SET_C #endif #if defined(BN_MP_INIT_C) #endif #if defined(BN_MP_INIT_COPY_C) -# define BN_MP_INIT_SIZE_C +# define BN_MP_CLEAR_C # define BN_MP_COPY_C -# define BN_MP_CLEAR_C +# define BN_MP_INIT_SIZE_C +#endif + +#if defined(BN_MP_INIT_I32_C) +# define BN_MP_INIT_C +# define BN_MP_SET_I32_C +#endif + +#if defined(BN_MP_INIT_I64_C) +# define BN_MP_INIT_C +# define BN_MP_SET_I64_C +#endif + +#if defined(BN_MP_INIT_L_C) +# define BN_MP_INIT_C +# define BN_MP_SET_L_C +#endif + +#if defined(BN_MP_INIT_LL_C) +# define BN_MP_INIT_C +# define BN_MP_SET_LL_C #endif #if defined(BN_MP_INIT_MULTI_C) -# define BN_MP_ERR_C -# define BN_MP_INIT_C # define BN_MP_CLEAR_C +# define BN_MP_INIT_C #endif #if defined(BN_MP_INIT_SET_C) # define BN_MP_INIT_C # define BN_MP_SET_C #endif -#if defined(BN_MP_INIT_SET_INT_C) -# define BN_MP_INIT_C -# define BN_MP_SET_INT_C -#endif - #if defined(BN_MP_INIT_SIZE_C) +#endif + +#if defined(BN_MP_INIT_U32_C) +# define BN_MP_INIT_C +# define BN_MP_SET_U32_C +#endif + +#if defined(BN_MP_INIT_U64_C) +# define BN_MP_INIT_C +# define BN_MP_SET_U64_C +#endif + +#if defined(BN_MP_INIT_UL_C) +# define BN_MP_INIT_C +# define BN_MP_SET_UL_C +#endif + +#if defined(BN_MP_INIT_ULL_C) # define BN_MP_INIT_C +# define BN_MP_SET_ULL_C #endif #if defined(BN_MP_INVMOD_C) # define BN_MP_CMP_D_C -# define BN_MP_ISODD_C -# define BN_FAST_MP_INVMOD_C -# define BN_MP_INVMOD_SLOW_C -#endif - -#if defined(BN_MP_INVMOD_SLOW_C) -# define BN_MP_ISZERO_C -# define BN_MP_INIT_MULTI_C -# define BN_MP_MOD_C -# define BN_MP_COPY_C -# define BN_MP_ISEVEN_C -# define BN_MP_SET_C -# define BN_MP_DIV_2_C -# define BN_MP_ISODD_C -# define BN_MP_ADD_C -# define BN_MP_SUB_C -# define BN_MP_CMP_C -# define BN_MP_CMP_D_C -# define BN_MP_CMP_MAG_C -# define BN_MP_EXCH_C -# define BN_MP_CLEAR_MULTI_C +# define BN_S_MP_INVMOD_FAST_C +# define BN_S_MP_INVMOD_SLOW_C #endif #if defined(BN_MP_IS_SQUARE_C) -# define BN_MP_MOD_D_C -# define BN_MP_INIT_SET_INT_C +# define BN_MP_CLEAR_C +# define BN_MP_CMP_MAG_C +# define BN_MP_GET_I32_C +# define BN_MP_INIT_U32_C # define BN_MP_MOD_C -# define BN_MP_GET_INT_C +# define BN_MP_MOD_D_C # define BN_MP_SQRT_C # define BN_MP_SQR_C -# define BN_MP_CMP_MAG_C -# define BN_MP_CLEAR_C -#endif - -#if defined(BN_MP_JACOBI_C) -# define BN_MP_KRONECKER_C -# define BN_MP_ISNEG_C -# define BN_MP_CMP_D_C -#endif - -#if defined(BN_MP_KARATSUBA_MUL_C) -# define BN_MP_MUL_C -# define BN_MP_INIT_SIZE_C -# define BN_MP_CLAMP_C -# define BN_S_MP_ADD_C -# define BN_MP_ADD_C -# define BN_S_MP_SUB_C -# define BN_MP_LSHD_C -# define BN_MP_CLEAR_C -#endif - -#if defined(BN_MP_KARATSUBA_SQR_C) -# define BN_MP_INIT_SIZE_C -# define BN_MP_CLAMP_C -# define BN_MP_SQR_C -# define BN_S_MP_ADD_C -# define BN_S_MP_SUB_C -# define BN_MP_LSHD_C -# define BN_MP_ADD_C -# define BN_MP_CLEAR_C +#endif + +#if defined(BN_MP_ISEVEN_C) +#endif + +#if defined(BN_MP_ISODD_C) #endif #if defined(BN_MP_KRONECKER_C) -# define BN_MP_ISZERO_C -# define BN_MP_ISEVEN_C -# define BN_MP_INIT_COPY_C +# define BN_MP_CLEAR_C +# define BN_MP_CMP_D_C # define BN_MP_CNT_LSB_C -# define BN_MP_DIV_2D_C -# define BN_MP_CMP_D_C # define BN_MP_COPY_C +# define BN_MP_DIV_2D_C +# define BN_MP_INIT_C +# define BN_MP_INIT_COPY_C # define BN_MP_MOD_C -# define BN_MP_CLEAR_C #endif #if defined(BN_MP_LCM_C) -# define BN_MP_INIT_MULTI_C -# define BN_MP_GCD_C +# define BN_MP_CLEAR_MULTI_C # define BN_MP_CMP_MAG_C # define BN_MP_DIV_C +# define BN_MP_GCD_C +# define BN_MP_INIT_MULTI_C # define BN_MP_MUL_C +#endif + +#if defined(BN_MP_LOG_U32_C) # define BN_MP_CLEAR_MULTI_C +# define BN_MP_CMP_C +# define BN_MP_CMP_D_C +# define BN_MP_COPY_C +# define BN_MP_COUNT_BITS_C +# define BN_MP_EXCH_C +# define BN_MP_EXPT_U32_C +# define BN_MP_INIT_MULTI_C +# define BN_MP_MUL_C +# define BN_MP_SET_C +# define BN_MP_SQR_C #endif #if defined(BN_MP_LSHD_C) -# define BN_MP_ISZERO_C # define BN_MP_GROW_C -# define BN_MP_RSHD_C #endif #if defined(BN_MP_MOD_C) -# define BN_MP_INIT_SIZE_C +# define BN_MP_ADD_C +# define BN_MP_CLEAR_C # define BN_MP_DIV_C -# define BN_MP_CLEAR_C -# define BN_MP_ISZERO_C # define BN_MP_EXCH_C -# define BN_MP_ADD_C +# define BN_MP_INIT_SIZE_C #endif #if defined(BN_MP_MOD_2D_C) -# define BN_MP_ZERO_C +# define BN_MP_CLAMP_C # define BN_MP_COPY_C -# define BN_MP_CLAMP_C +# define BN_MP_ZERO_C #endif #if defined(BN_MP_MOD_D_C) # define BN_MP_DIV_D_C #endif #if defined(BN_MP_MONTGOMERY_CALC_NORMALIZATION_C) -# define BN_MP_COUNT_BITS_C # define BN_MP_2EXPT_C -# define BN_MP_SET_C +# define BN_MP_CMP_MAG_C +# define BN_MP_COUNT_BITS_C # define BN_MP_MUL_2_C -# define BN_MP_CMP_MAG_C +# define BN_MP_SET_C # define BN_S_MP_SUB_C #endif #if defined(BN_MP_MONTGOMERY_REDUCE_C) -# define BN_FAST_MP_MONTGOMERY_REDUCE_C -# define BN_MP_GROW_C # define BN_MP_CLAMP_C +# define BN_MP_CMP_MAG_C +# define BN_MP_GROW_C # define BN_MP_RSHD_C -# define BN_MP_CMP_MAG_C +# define BN_S_MP_MONTGOMERY_REDUCE_FAST_C # define BN_S_MP_SUB_C #endif #if defined(BN_MP_MONTGOMERY_SETUP_C) #endif #if defined(BN_MP_MUL_C) -# define BN_MP_TOOM_MUL_C -# define BN_MP_KARATSUBA_MUL_C -# define BN_FAST_S_MP_MUL_DIGS_C -# define BN_S_MP_MUL_C +# define BN_S_MP_BALANCE_MUL_C +# define BN_S_MP_KARATSUBA_MUL_C # define BN_S_MP_MUL_DIGS_C +# define BN_S_MP_MUL_DIGS_FAST_C +# define BN_S_MP_TOOM_MUL_C #endif #if defined(BN_MP_MUL_2_C) # define BN_MP_GROW_C #endif #if defined(BN_MP_MUL_2D_C) +# define BN_MP_CLAMP_C # define BN_MP_COPY_C # define BN_MP_GROW_C # define BN_MP_LSHD_C -# define BN_MP_CLAMP_C #endif #if defined(BN_MP_MUL_D_C) -# define BN_MP_GROW_C # define BN_MP_CLAMP_C +# define BN_MP_GROW_C #endif #if defined(BN_MP_MULMOD_C) -# define BN_MP_INIT_SIZE_C -# define BN_MP_MUL_C # define BN_MP_CLEAR_C +# define BN_MP_INIT_SIZE_C # define BN_MP_MOD_C -#endif - -#if defined(BN_MP_N_ROOT_C) -# define BN_MP_N_ROOT_EX_C -#endif - -#if defined(BN_MP_N_ROOT_EX_C) -# define BN_MP_INIT_C -# define BN_MP_SET_C -# define BN_MP_COPY_C -# define BN_MP_EXPT_D_EX_C # define BN_MP_MUL_C -# define BN_MP_SUB_C -# define BN_MP_MUL_D_C -# define BN_MP_DIV_C -# define BN_MP_CMP_C -# define BN_MP_SUB_D_C -# define BN_MP_EXCH_C -# define BN_MP_CLEAR_C #endif #if defined(BN_MP_NEG_C) # define BN_MP_COPY_C -# define BN_MP_ISZERO_C #endif #if defined(BN_MP_OR_C) -# define BN_MP_INIT_COPY_C # define BN_MP_CLAMP_C -# define BN_MP_EXCH_C +# define BN_MP_GROW_C +#endif + +#if defined(BN_MP_PACK_C) # define BN_MP_CLEAR_C +# define BN_MP_DIV_2D_C +# define BN_MP_INIT_COPY_C +# define BN_MP_PACK_COUNT_C +#endif + +#if defined(BN_MP_PACK_COUNT_C) +# define BN_MP_COUNT_BITS_C #endif #if defined(BN_MP_PRIME_FERMAT_C) +# define BN_MP_CLEAR_C +# define BN_MP_CMP_C # define BN_MP_CMP_D_C -# define BN_MP_INIT_C # define BN_MP_EXPTMOD_C -# define BN_MP_CMP_C -# define BN_MP_CLEAR_C +# define BN_MP_INIT_C #endif #if defined(BN_MP_PRIME_FROBENIUS_UNDERWOOD_C) -# define BN_MP_PRIME_IS_PRIME_C -# define BN_MP_INIT_MULTI_C -# define BN_MP_SET_LONG_C -# define BN_MP_SQR_C -# define BN_MP_SUB_D_C -# define BN_MP_KRONECKER_C +# define BN_MP_ADD_C +# define BN_MP_ADD_D_C +# define BN_MP_CLEAR_MULTI_C +# define BN_MP_CMP_C +# define BN_MP_COUNT_BITS_C +# define BN_MP_EXCH_C # define BN_MP_GCD_C -# define BN_MP_ADD_D_C -# define BN_MP_SET_C -# define BN_MP_COUNT_BITS_C +# define BN_MP_INIT_MULTI_C +# define BN_MP_KRONECKER_C +# define BN_MP_MOD_C # define BN_MP_MUL_2_C +# define BN_MP_MUL_C # define BN_MP_MUL_D_C -# define BN_MP_ADD_C -# define BN_MP_MUL_C +# define BN_MP_SET_C +# define BN_MP_SET_U32_C +# define BN_MP_SQR_C # define BN_MP_SUB_C -# define BN_MP_MOD_C +# define BN_MP_SUB_D_C # define BN_S_MP_GET_BIT_C -# define BN_MP_EXCH_C -# define BN_MP_ISZERO_C -# define BN_MP_CMP_C -# define BN_MP_CLEAR_MULTI_C -#endif - -#if defined(BN_MP_PRIME_IS_DIVISIBLE_C) -# define BN_MP_MOD_D_C #endif #if defined(BN_MP_PRIME_IS_PRIME_C) -# define BN_MP_ISEVEN_C -# define BN_MP_IS_SQUARE_C +# define BN_MP_CLEAR_C +# define BN_MP_CMP_C # define BN_MP_CMP_D_C -# define BN_MP_PRIME_IS_DIVISIBLE_C +# define BN_MP_COUNT_BITS_C +# define BN_MP_DIV_2D_C # define BN_MP_INIT_SET_C +# define BN_MP_IS_SQUARE_C # define BN_MP_PRIME_MILLER_RABIN_C -# define BN_MP_PRIME_FROBENIUS_UNDERWOOD_C # define BN_MP_PRIME_STRONG_LUCAS_SELFRIDGE_C +# define BN_MP_RAND_C # define BN_MP_READ_RADIX_C -# define BN_MP_CMP_C # define BN_MP_SET_C -# define BN_MP_COUNT_BITS_C -# define BN_MP_RAND_C -# define BN_MP_DIV_2D_C -# define BN_MP_CLEAR_C +# define BN_S_MP_PRIME_IS_DIVISIBLE_C #endif #if defined(BN_MP_PRIME_MILLER_RABIN_C) +# define BN_MP_CLEAR_C +# define BN_MP_CMP_C # define BN_MP_CMP_D_C -# define BN_MP_INIT_COPY_C -# define BN_MP_SUB_D_C # define BN_MP_CNT_LSB_C # define BN_MP_DIV_2D_C # define BN_MP_EXPTMOD_C -# define BN_MP_CMP_C +# define BN_MP_INIT_C +# define BN_MP_INIT_COPY_C # define BN_MP_SQRMOD_C -# define BN_MP_CLEAR_C +# define BN_MP_SUB_D_C #endif #if defined(BN_MP_PRIME_NEXT_PRIME_C) +# define BN_MP_ADD_D_C +# define BN_MP_CLEAR_C # define BN_MP_CMP_D_C -# define BN_MP_SET_C -# define BN_MP_SUB_D_C -# define BN_MP_ISEVEN_C +# define BN_MP_INIT_C # define BN_MP_MOD_D_C -# define BN_MP_INIT_C -# define BN_MP_ADD_D_C # define BN_MP_PRIME_IS_PRIME_C -# define BN_MP_CLEAR_C +# define BN_MP_SET_C +# define BN_MP_SUB_D_C #endif #if defined(BN_MP_PRIME_RABIN_MILLER_TRIALS_C) #endif -#if defined(BN_MP_PRIME_RANDOM_EX_C) -# define BN_MP_READ_UNSIGNED_BIN_C +#if defined(BN_MP_PRIME_RAND_C) +# define BN_MP_ADD_D_C +# define BN_MP_DIV_2_C +# define BN_MP_FROM_UBIN_C +# define BN_MP_MUL_2_C # define BN_MP_PRIME_IS_PRIME_C # define BN_MP_SUB_D_C -# define BN_MP_DIV_2_C -# define BN_MP_MUL_2_C -# define BN_MP_ADD_D_C +# define BN_S_MP_PRIME_RANDOM_EX_C +# define BN_S_MP_RAND_CB_C +# define BN_S_MP_RAND_SOURCE_C #endif #if defined(BN_MP_PRIME_STRONG_LUCAS_SELFRIDGE_C) -# define BN_MP_PRIME_IS_PRIME_C -# define BN_MP_MUL_D_C -# define BN_S_MP_MUL_SI_C -# define BN_MP_INIT_C -# define BN_MP_SET_LONG_C -# define BN_MP_MUL_C +# define BN_MP_ADD_C +# define BN_MP_ADD_D_C # define BN_MP_CLEAR_C -# define BN_MP_INIT_MULTI_C +# define BN_MP_CLEAR_MULTI_C +# define BN_MP_CMP_C +# define BN_MP_CMP_D_C +# define BN_MP_CNT_LSB_C +# define BN_MP_COUNT_BITS_C +# define BN_MP_DIV_2D_C +# define BN_MP_DIV_2_C # define BN_MP_GCD_C -# define BN_MP_CMP_D_C -# define BN_MP_CMP_C +# define BN_MP_INIT_C +# define BN_MP_INIT_MULTI_C # define BN_MP_KRONECKER_C -# define BN_MP_ADD_D_C -# define BN_MP_CNT_LSB_C -# define BN_MP_DIV_2D_C -# define BN_MP_SET_C +# define BN_MP_MOD_C # define BN_MP_MUL_2_C -# define BN_MP_COUNT_BITS_C -# define BN_MP_MOD_C +# define BN_MP_MUL_C +# define BN_MP_SET_C +# define BN_MP_SET_I32_C +# define BN_MP_SET_U32_C # define BN_MP_SQR_C # define BN_MP_SUB_C +# define BN_MP_SUB_D_C # define BN_S_MP_GET_BIT_C -# define BN_MP_ADD_C -# define BN_MP_ISODD_C -# define BN_MP_DIV_2_C -# define BN_MP_SUB_D_C -# define BN_MP_ISZERO_C -# define BN_MP_CLEAR_MULTI_C +# define BN_S_MP_MUL_SI_C #endif #if defined(BN_MP_RADIX_SIZE_C) -# define BN_MP_ISZERO_C +# define BN_MP_CLEAR_C # define BN_MP_COUNT_BITS_C -# define BN_MP_INIT_COPY_C # define BN_MP_DIV_D_C -# define BN_MP_CLEAR_C +# define BN_MP_INIT_COPY_C #endif #if defined(BN_MP_RADIX_SMAP_C) -# define BN_MP_S_RMAP_C -# define BN_MP_S_RMAP_REVERSE_C -# define BN_MP_S_RMAP_REVERSE_SZ_C #endif #if defined(BN_MP_RAND_C) -# define BN_MP_RAND_DIGIT_C +# define BN_MP_GROW_C +# define BN_MP_RAND_SOURCE_C # define BN_MP_ZERO_C -# define BN_MP_ADD_D_C -# define BN_MP_LSHD_C +# define BN_S_MP_RAND_PLATFORM_C +# define BN_S_MP_RAND_SOURCE_C #endif #if defined(BN_MP_READ_RADIX_C) -# define BN_MP_ZERO_C -# define BN_MP_S_RMAP_REVERSE_SZ_C -# define BN_MP_S_RMAP_REVERSE_C +# define BN_MP_ADD_D_C # define BN_MP_MUL_D_C -# define BN_MP_ADD_D_C -# define BN_MP_ISZERO_C -#endif - -#if defined(BN_MP_READ_SIGNED_BIN_C) -# define BN_MP_READ_UNSIGNED_BIN_C -#endif - -#if defined(BN_MP_READ_UNSIGNED_BIN_C) -# define BN_MP_GROW_C # define BN_MP_ZERO_C -# define BN_MP_MUL_2D_C -# define BN_MP_CLAMP_C #endif #if defined(BN_MP_REDUCE_C) -# define BN_MP_REDUCE_SETUP_C +# define BN_MP_ADD_C +# define BN_MP_CLEAR_C +# define BN_MP_CMP_C +# define BN_MP_CMP_D_C # define BN_MP_INIT_COPY_C -# define BN_MP_RSHD_C -# define BN_MP_MUL_C -# define BN_S_MP_MUL_HIGH_DIGS_C -# define BN_FAST_S_MP_MUL_HIGH_DIGS_C +# define BN_MP_LSHD_C # define BN_MP_MOD_2D_C +# define BN_MP_MUL_C +# define BN_MP_RSHD_C +# define BN_MP_SET_C +# define BN_MP_SUB_C # define BN_S_MP_MUL_DIGS_C -# define BN_MP_SUB_C -# define BN_MP_CMP_D_C -# define BN_MP_SET_C -# define BN_MP_LSHD_C -# define BN_MP_ADD_C -# define BN_MP_CMP_C +# define BN_S_MP_MUL_HIGH_DIGS_C +# define BN_S_MP_MUL_HIGH_DIGS_FAST_C # define BN_S_MP_SUB_C -# define BN_MP_CLEAR_C #endif #if defined(BN_MP_REDUCE_2K_C) -# define BN_MP_INIT_C +# define BN_MP_CLEAR_C +# define BN_MP_CMP_MAG_C # define BN_MP_COUNT_BITS_C # define BN_MP_DIV_2D_C +# define BN_MP_INIT_C # define BN_MP_MUL_D_C # define BN_S_MP_ADD_C -# define BN_MP_CMP_MAG_C # define BN_S_MP_SUB_C -# define BN_MP_CLEAR_C #endif #if defined(BN_MP_REDUCE_2K_L_C) -# define BN_MP_INIT_C +# define BN_MP_CLEAR_C +# define BN_MP_CMP_MAG_C # define BN_MP_COUNT_BITS_C # define BN_MP_DIV_2D_C +# define BN_MP_INIT_C # define BN_MP_MUL_C # define BN_S_MP_ADD_C -# define BN_MP_CMP_MAG_C # define BN_S_MP_SUB_C -# define BN_MP_CLEAR_C #endif #if defined(BN_MP_REDUCE_2K_SETUP_C) -# define BN_MP_INIT_C -# define BN_MP_COUNT_BITS_C # define BN_MP_2EXPT_C # define BN_MP_CLEAR_C +# define BN_MP_COUNT_BITS_C +# define BN_MP_INIT_C # define BN_S_MP_SUB_C #endif #if defined(BN_MP_REDUCE_2K_SETUP_L_C) -# define BN_MP_INIT_C # define BN_MP_2EXPT_C +# define BN_MP_CLEAR_C # define BN_MP_COUNT_BITS_C +# define BN_MP_INIT_C # define BN_S_MP_SUB_C -# define BN_MP_CLEAR_C #endif #if defined(BN_MP_REDUCE_IS_2K_C) -# define BN_MP_REDUCE_2K_C # define BN_MP_COUNT_BITS_C #endif #if defined(BN_MP_REDUCE_IS_2K_L_C) #endif @@ -919,305 +926,394 @@ #if defined(BN_MP_REDUCE_SETUP_C) # define BN_MP_2EXPT_C # define BN_MP_DIV_C #endif + +#if defined(BN_MP_ROOT_U32_C) +# define BN_MP_2EXPT_C +# define BN_MP_ADD_D_C +# define BN_MP_CLEAR_MULTI_C +# define BN_MP_CMP_C +# define BN_MP_COPY_C +# define BN_MP_COUNT_BITS_C +# define BN_MP_DIV_C +# define BN_MP_EXCH_C +# define BN_MP_EXPT_U32_C +# define BN_MP_INIT_MULTI_C +# define BN_MP_MUL_C +# define BN_MP_MUL_D_C +# define BN_MP_SET_C +# define BN_MP_SUB_C +# define BN_MP_SUB_D_C +#endif #if defined(BN_MP_RSHD_C) # define BN_MP_ZERO_C #endif + +#if defined(BN_MP_SBIN_SIZE_C) +# define BN_MP_UBIN_SIZE_C +#endif #if defined(BN_MP_SET_C) -# define BN_MP_ZERO_C #endif #if defined(BN_MP_SET_DOUBLE_C) -# define BN_MP_SET_LONG_LONG_C # define BN_MP_DIV_2D_C # define BN_MP_MUL_2D_C -# define BN_MP_ISZERO_C +# define BN_MP_SET_U64_C +#endif + +#if defined(BN_MP_SET_I32_C) +# define BN_MP_SET_U32_C +#endif + +#if defined(BN_MP_SET_I64_C) +# define BN_MP_SET_U64_C +#endif + +#if defined(BN_MP_SET_L_C) +# define BN_MP_SET_UL_C +#endif + +#if defined(BN_MP_SET_LL_C) +# define BN_MP_SET_ULL_C +#endif + +#if defined(BN_MP_SET_U32_C) +#endif + +#if defined(BN_MP_SET_U64_C) #endif -#if defined(BN_MP_SET_INT_C) -# define BN_MP_ZERO_C -# define BN_MP_MUL_2D_C -# define BN_MP_CLAMP_C +#if defined(BN_MP_SET_UL_C) #endif -#if defined(BN_MP_SET_LONG_C) -#endif - -#if defined(BN_MP_SET_LONG_LONG_C) +#if defined(BN_MP_SET_ULL_C) #endif #if defined(BN_MP_SHRINK_C) #endif -#if defined(BN_MP_SIGNED_BIN_SIZE_C) -# define BN_MP_UNSIGNED_BIN_SIZE_C +#if defined(BN_MP_SIGNED_RSH_C) +# define BN_MP_ADD_D_C +# define BN_MP_DIV_2D_C +# define BN_MP_SUB_D_C #endif #if defined(BN_MP_SQR_C) -# define BN_MP_TOOM_SQR_C -# define BN_MP_KARATSUBA_SQR_C -# define BN_FAST_S_MP_SQR_C +# define BN_S_MP_KARATSUBA_SQR_C # define BN_S_MP_SQR_C +# define BN_S_MP_SQR_FAST_C +# define BN_S_MP_TOOM_SQR_C #endif #if defined(BN_MP_SQRMOD_C) -# define BN_MP_INIT_C -# define BN_MP_SQR_C # define BN_MP_CLEAR_C +# define BN_MP_INIT_C # define BN_MP_MOD_C +# define BN_MP_SQR_C #endif #if defined(BN_MP_SQRT_C) -# define BN_MP_N_ROOT_C -# define BN_MP_ISZERO_C -# define BN_MP_ZERO_C +# define BN_MP_ADD_C +# define BN_MP_CLEAR_C +# define BN_MP_CMP_MAG_C +# define BN_MP_DIV_2_C +# define BN_MP_DIV_C +# define BN_MP_EXCH_C +# define BN_MP_INIT_C # define BN_MP_INIT_COPY_C # define BN_MP_RSHD_C -# define BN_MP_DIV_C -# define BN_MP_ADD_C -# define BN_MP_DIV_2_C -# define BN_MP_CMP_MAG_C -# define BN_MP_EXCH_C -# define BN_MP_CLEAR_C +# define BN_MP_ZERO_C #endif #if defined(BN_MP_SQRTMOD_PRIME_C) +# define BN_MP_ADD_D_C +# define BN_MP_CLEAR_MULTI_C # define BN_MP_CMP_D_C -# define BN_MP_ZERO_C -# define BN_MP_JACOBI_C -# define BN_MP_INIT_MULTI_C -# define BN_MP_MOD_D_C -# define BN_MP_ADD_D_C +# define BN_MP_COPY_C # define BN_MP_DIV_2_C # define BN_MP_EXPTMOD_C -# define BN_MP_COPY_C -# define BN_MP_SUB_D_C -# define BN_MP_ISEVEN_C -# define BN_MP_SET_INT_C -# define BN_MP_SQRMOD_C +# define BN_MP_INIT_MULTI_C +# define BN_MP_KRONECKER_C +# define BN_MP_MOD_D_C # define BN_MP_MULMOD_C # define BN_MP_SET_C -# define BN_MP_CLEAR_MULTI_C +# define BN_MP_SET_U32_C +# define BN_MP_SQRMOD_C +# define BN_MP_SUB_D_C +# define BN_MP_ZERO_C #endif #if defined(BN_MP_SUB_C) -# define BN_S_MP_ADD_C # define BN_MP_CMP_MAG_C +# define BN_S_MP_ADD_C # define BN_S_MP_SUB_C #endif #if defined(BN_MP_SUB_D_C) -# define BN_MP_GROW_C -# define BN_MP_ADD_D_C -# define BN_MP_CLAMP_C -#endif - -#if defined(BN_MP_SUBMOD_C) -# define BN_MP_INIT_C -# define BN_MP_SUB_C -# define BN_MP_CLEAR_C -# define BN_MP_MOD_C -#endif - -#if defined(BN_MP_TC_AND_C) -# define BN_MP_ISNEG_C -# define BN_MP_COUNT_BITS_C -# define BN_MP_INIT_SET_INT_C -# define BN_MP_MUL_2D_C -# define BN_MP_INIT_C -# define BN_MP_ADD_C -# define BN_MP_CLEAR_C -# define BN_MP_AND_C -# define BN_MP_SUB_C -#endif - -#if defined(BN_MP_SIGNED_RSH_C) -# define BN_MP_ISNEG_C -# define BN_MP_DIV_2D_C -# define BN_MP_ADD_D_C -# define BN_MP_SUB_D_C -#endif - -#if defined(BN_MP_TC_OR_C) -# define BN_MP_ISNEG_C -# define BN_MP_COUNT_BITS_C -# define BN_MP_INIT_SET_INT_C -# define BN_MP_MUL_2D_C -# define BN_MP_INIT_C -# define BN_MP_ADD_C -# define BN_MP_CLEAR_C -# define BN_MP_OR_C -# define BN_MP_SUB_C -#endif - -#if defined(BN_MP_TC_XOR_C) -# define BN_MP_ISNEG_C -# define BN_MP_COUNT_BITS_C -# define BN_MP_INIT_SET_INT_C -# define BN_MP_MUL_2D_C -# define BN_MP_INIT_C -# define BN_MP_ADD_C -# define BN_MP_CLEAR_C -# define BN_MP_XOR_C -# define BN_MP_SUB_C -#endif - -#if defined(BN_MP_TO_SIGNED_BIN_C) -# define BN_MP_TO_UNSIGNED_BIN_C -#endif - -#if defined(BN_MP_TO_SIGNED_BIN_N_C) -# define BN_MP_SIGNED_BIN_SIZE_C -# define BN_MP_TO_SIGNED_BIN_C -#endif - -#if defined(BN_MP_TO_UNSIGNED_BIN_C) -# define BN_MP_INIT_COPY_C -# define BN_MP_ISZERO_C -# define BN_MP_DIV_2D_C -# define BN_MP_CLEAR_C -#endif - -#if defined(BN_MP_TO_UNSIGNED_BIN_N_C) -# define BN_MP_UNSIGNED_BIN_SIZE_C -# define BN_MP_TO_UNSIGNED_BIN_C -#endif - -#if defined(BN_MP_TOOM_MUL_C) -# define BN_MP_INIT_MULTI_C -# define BN_MP_MOD_2D_C -# define BN_MP_COPY_C -# define BN_MP_RSHD_C -# define BN_MP_MUL_C -# define BN_MP_MUL_2_C -# define BN_MP_ADD_C -# define BN_MP_SUB_C -# define BN_MP_DIV_2_C -# define BN_MP_MUL_2D_C -# define BN_MP_MUL_D_C -# define BN_MP_DIV_3_C -# define BN_MP_LSHD_C -# define BN_MP_CLEAR_MULTI_C -#endif - -#if defined(BN_MP_TOOM_SQR_C) -# define BN_MP_INIT_MULTI_C -# define BN_MP_MOD_2D_C -# define BN_MP_COPY_C -# define BN_MP_RSHD_C -# define BN_MP_SQR_C -# define BN_MP_MUL_2_C -# define BN_MP_ADD_C -# define BN_MP_SUB_C -# define BN_MP_DIV_2_C -# define BN_MP_MUL_2D_C -# define BN_MP_MUL_D_C -# define BN_MP_DIV_3_C -# define BN_MP_LSHD_C -# define BN_MP_CLEAR_MULTI_C -#endif - -#if defined(BN_MP_TORADIX_C) -# define BN_MP_ISZERO_C -# define BN_MP_INIT_COPY_C -# define BN_MP_DIV_D_C -# define BN_MP_CLEAR_C -# define BN_MP_S_RMAP_C -#endif - -#if defined(BN_MP_TORADIX_N_C) -# define BN_MP_ISZERO_C -# define BN_MP_INIT_COPY_C -# define BN_MP_DIV_D_C -# define BN_MP_CLEAR_C -# define BN_MP_S_RMAP_C -#endif - -#if defined(BN_MP_UNSIGNED_BIN_SIZE_C) -# define BN_MP_COUNT_BITS_C -#endif - -#if defined(BN_MP_XOR_C) -# define BN_MP_INIT_COPY_C -# define BN_MP_CLAMP_C -# define BN_MP_EXCH_C -# define BN_MP_CLEAR_C +# define BN_MP_ADD_D_C +# define BN_MP_CLAMP_C +# define BN_MP_GROW_C +#endif + +#if defined(BN_MP_SUBMOD_C) +# define BN_MP_CLEAR_C +# define BN_MP_INIT_C +# define BN_MP_MOD_C +# define BN_MP_SUB_C +#endif + +#if defined(BN_MP_TO_RADIX_C) +# define BN_MP_CLEAR_C +# define BN_MP_DIV_D_C +# define BN_MP_INIT_COPY_C +# define BN_S_MP_REVERSE_C +#endif + +#if defined(BN_MP_TO_SBIN_C) +# define BN_MP_TO_UBIN_C +#endif + +#if defined(BN_MP_TO_UBIN_C) +# define BN_MP_CLEAR_C +# define BN_MP_DIV_2D_C +# define BN_MP_INIT_COPY_C +# define BN_MP_UBIN_SIZE_C +#endif + +#if defined(BN_MP_UBIN_SIZE_C) +# define BN_MP_COUNT_BITS_C +#endif + +#if defined(BN_MP_UNPACK_C) +# define BN_MP_CLAMP_C +# define BN_MP_MUL_2D_C +# define BN_MP_ZERO_C +#endif + +#if defined(BN_MP_XOR_C) +# define BN_MP_CLAMP_C +# define BN_MP_GROW_C #endif #if defined(BN_MP_ZERO_C) #endif #if defined(BN_PRIME_TAB_C) #endif -#if defined(BN_REVERSE_C) -#endif - #if defined(BN_S_MP_ADD_C) +# define BN_MP_CLAMP_C # define BN_MP_GROW_C +#endif + +#if defined(BN_S_MP_BALANCE_MUL_C) +# define BN_MP_ADD_C # define BN_MP_CLAMP_C +# define BN_MP_CLEAR_C +# define BN_MP_CLEAR_MULTI_C +# define BN_MP_EXCH_C +# define BN_MP_INIT_MULTI_C +# define BN_MP_INIT_SIZE_C +# define BN_MP_LSHD_C +# define BN_MP_MUL_C #endif #if defined(BN_S_MP_EXPTMOD_C) +# define BN_MP_CLEAR_C +# define BN_MP_COPY_C # define BN_MP_COUNT_BITS_C +# define BN_MP_EXCH_C # define BN_MP_INIT_C -# define BN_MP_CLEAR_C -# define BN_MP_REDUCE_SETUP_C -# define BN_MP_REDUCE_C -# define BN_MP_REDUCE_2K_SETUP_L_C +# define BN_MP_MOD_C +# define BN_MP_MUL_C # define BN_MP_REDUCE_2K_L_C -# define BN_MP_MOD_C -# define BN_MP_COPY_C +# define BN_MP_REDUCE_2K_SETUP_L_C +# define BN_MP_REDUCE_C +# define BN_MP_REDUCE_SETUP_C +# define BN_MP_SET_C # define BN_MP_SQR_C +#endif + +#if defined(BN_S_MP_EXPTMOD_FAST_C) +# define BN_MP_CLEAR_C +# define BN_MP_COPY_C +# define BN_MP_COUNT_BITS_C +# define BN_MP_DR_REDUCE_C +# define BN_MP_DR_SETUP_C +# define BN_MP_EXCH_C +# define BN_MP_INIT_SIZE_C +# define BN_MP_MOD_C +# define BN_MP_MONTGOMERY_CALC_NORMALIZATION_C +# define BN_MP_MONTGOMERY_REDUCE_C +# define BN_MP_MONTGOMERY_SETUP_C +# define BN_MP_MULMOD_C # define BN_MP_MUL_C +# define BN_MP_REDUCE_2K_C +# define BN_MP_REDUCE_2K_SETUP_C +# define BN_MP_SET_C +# define BN_MP_SQR_C +# define BN_S_MP_MONTGOMERY_REDUCE_FAST_C +#endif + +#if defined(BN_S_MP_GET_BIT_C) +#endif + +#if defined(BN_S_MP_INVMOD_FAST_C) +# define BN_MP_ADD_C +# define BN_MP_CLEAR_MULTI_C +# define BN_MP_CMP_C +# define BN_MP_CMP_D_C +# define BN_MP_CMP_MAG_C +# define BN_MP_COPY_C +# define BN_MP_DIV_2_C +# define BN_MP_EXCH_C +# define BN_MP_INIT_MULTI_C +# define BN_MP_MOD_C # define BN_MP_SET_C +# define BN_MP_SUB_C +#endif + +#if defined(BN_S_MP_INVMOD_SLOW_C) +# define BN_MP_ADD_C +# define BN_MP_CLEAR_MULTI_C +# define BN_MP_CMP_C +# define BN_MP_CMP_D_C +# define BN_MP_CMP_MAG_C +# define BN_MP_COPY_C +# define BN_MP_DIV_2_C # define BN_MP_EXCH_C +# define BN_MP_INIT_MULTI_C +# define BN_MP_MOD_C +# define BN_MP_SET_C +# define BN_MP_SUB_C +#endif + +#if defined(BN_S_MP_KARATSUBA_MUL_C) +# define BN_MP_ADD_C +# define BN_MP_CLAMP_C +# define BN_MP_CLEAR_C +# define BN_MP_INIT_SIZE_C +# define BN_MP_LSHD_C +# define BN_MP_MUL_C +# define BN_S_MP_ADD_C +# define BN_S_MP_SUB_C +#endif + +#if defined(BN_S_MP_KARATSUBA_SQR_C) +# define BN_MP_ADD_C +# define BN_MP_CLAMP_C +# define BN_MP_CLEAR_C +# define BN_MP_INIT_SIZE_C +# define BN_MP_LSHD_C +# define BN_MP_SQR_C +# define BN_S_MP_ADD_C +# define BN_S_MP_SUB_C +#endif + +#if defined(BN_S_MP_MONTGOMERY_REDUCE_FAST_C) +# define BN_MP_CLAMP_C +# define BN_MP_CMP_MAG_C +# define BN_MP_GROW_C +# define BN_S_MP_SUB_C #endif #if defined(BN_S_MP_MUL_DIGS_C) -# define BN_FAST_S_MP_MUL_DIGS_C -# define BN_MP_INIT_SIZE_C # define BN_MP_CLAMP_C +# define BN_MP_CLEAR_C # define BN_MP_EXCH_C -# define BN_MP_CLEAR_C +# define BN_MP_INIT_SIZE_C +# define BN_S_MP_MUL_DIGS_FAST_C +#endif + +#if defined(BN_S_MP_MUL_DIGS_FAST_C) +# define BN_MP_CLAMP_C +# define BN_MP_GROW_C #endif #if defined(BN_S_MP_MUL_HIGH_DIGS_C) -# define BN_FAST_S_MP_MUL_HIGH_DIGS_C -# define BN_MP_INIT_SIZE_C # define BN_MP_CLAMP_C +# define BN_MP_CLEAR_C # define BN_MP_EXCH_C -# define BN_MP_CLEAR_C +# define BN_MP_INIT_SIZE_C +# define BN_S_MP_MUL_HIGH_DIGS_FAST_C +#endif + +#if defined(BN_S_MP_MUL_HIGH_DIGS_FAST_C) +# define BN_MP_CLAMP_C +# define BN_MP_GROW_C +#endif + +#if defined(BN_S_MP_PRIME_IS_DIVISIBLE_C) +# define BN_MP_MOD_D_C +#endif + +#if defined(BN_S_MP_RAND_JENKINS_C) +# define BN_S_MP_RAND_JENKINS_INIT_C +#endif + +#if defined(BN_S_MP_RAND_PLATFORM_C) +#endif + +#if defined(BN_S_MP_REVERSE_C) #endif #if defined(BN_S_MP_SQR_C) -# define BN_MP_INIT_SIZE_C # define BN_MP_CLAMP_C +# define BN_MP_CLEAR_C # define BN_MP_EXCH_C -# define BN_MP_CLEAR_C +# define BN_MP_INIT_SIZE_C +#endif + +#if defined(BN_S_MP_SQR_FAST_C) +# define BN_MP_CLAMP_C +# define BN_MP_GROW_C #endif #if defined(BN_S_MP_SUB_C) +# define BN_MP_CLAMP_C # define BN_MP_GROW_C +#endif + +#if defined(BN_S_MP_TOOM_MUL_C) +# define BN_MP_ADD_C +# define BN_MP_CLAMP_C +# define BN_MP_CLEAR_C +# define BN_MP_CLEAR_MULTI_C +# define BN_MP_DIV_2_C +# define BN_MP_DIV_3_C +# define BN_MP_INIT_MULTI_C +# define BN_MP_INIT_SIZE_C +# define BN_MP_LSHD_C +# define BN_MP_MUL_2_C +# define BN_MP_MUL_C +# define BN_MP_SUB_C +#endif + +#if defined(BN_S_MP_TOOM_SQR_C) +# define BN_MP_ADD_C # define BN_MP_CLAMP_C +# define BN_MP_CLEAR_C +# define BN_MP_DIV_2_C +# define BN_MP_INIT_C +# define BN_MP_INIT_SIZE_C +# define BN_MP_LSHD_C +# define BN_MP_MUL_2_C +# define BN_MP_MUL_C +# define BN_MP_SQR_C +# define BN_MP_SUB_C #endif -#if defined(BNCORE_C) -#endif - +#ifdef LTM_INSIDE +#undef LTM_INSIDE #ifdef LTM3 # define LTM_LAST #endif -#include -#include +#include "tommath_superclass.h" +#include "tommath_class.h" #else # define LTM_LAST #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ ADDED libtommath/tommath_cutoffs.h Index: libtommath/tommath_cutoffs.h ================================================================== --- /dev/null +++ libtommath/tommath_cutoffs.h @@ -0,0 +1,13 @@ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ +/* + Current values evaluated on an AMD A8-6600K (64-bit). + Type "make tune" to optimize them for your machine but + be aware that it may take a long time. It took 2:30 minutes + on the aforementioned machine for example. + */ + +#define MP_DEFAULT_KARATSUBA_MUL_CUTOFF 80 +#define MP_DEFAULT_KARATSUBA_SQR_CUTOFF 120 +#define MP_DEFAULT_TOOM_MUL_CUTOFF 350 +#define MP_DEFAULT_TOOM_SQR_CUTOFF 400 Index: libtommath/tommath_private.h ================================================================== --- libtommath/tommath_private.h +++ libtommath/tommath_private.h @@ -1,114 +1,310 @@ -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + #ifndef TOMMATH_PRIV_H_ #define TOMMATH_PRIV_H_ #include +#include "tommath_class.h" + +/* + * Private symbols + * --------------- + * + * On Unix symbols can be marked as hidden if libtommath is compiled + * as a shared object. By default, symbols are visible. + * As of now, this feature is opt-in via the MP_PRIVATE_SYMBOLS define. + * + * On Win32 a .def file must be used to specify the exported symbols. + */ +#if defined (MP_PRIVATE_SYMBOLS) && defined(__GNUC__) && __GNUC__ >= 4 +# define MP_PRIVATE __attribute__ ((visibility ("hidden"))) +#else +# define MP_PRIVATE +#endif -#ifndef MIN -#define MIN(x, y) (((x) < (y)) ? (x) : (y)) +/* Hardening libtommath + * -------------------- + * + * By default memory is zeroed before calling + * MP_FREE to avoid leaking data. This is good + * practice in cryptographical applications. + * + * Note however that memory allocators used + * in cryptographical applications can often + * be configured by itself to clear memory, + * rendering the clearing in tommath unnecessary. + * See for example https://github.com/GrapheneOS/hardened_malloc + * and the option CONFIG_ZERO_ON_FREE. + * + * Furthermore there are applications which + * value performance more and want this + * feature to be disabled. For such applications + * define MP_NO_ZERO_ON_FREE during compilation. + */ +#ifdef MP_NO_ZERO_ON_FREE +# define MP_FREE_BUFFER(mem, size) MP_FREE((mem), (size)) +# define MP_FREE_DIGITS(mem, digits) MP_FREE((mem), sizeof (mp_digit) * (size_t)(digits)) +#else +# define MP_FREE_BUFFER(mem, size) \ +do { \ + size_t fs_ = (size); \ + void* fm_ = (mem); \ + if (fm_ != NULL) { \ + MP_ZERO_BUFFER(fm_, fs_); \ + MP_FREE(fm_, fs_); \ + } \ +} while (0) +# define MP_FREE_DIGITS(mem, digits) \ +do { \ + int fd_ = (digits); \ + void* fm_ = (mem); \ + if (fm_ != NULL) { \ + size_t fs_ = sizeof (mp_digit) * (size_t)fd_; \ + MP_ZERO_BUFFER(fm_, fs_); \ + MP_FREE(fm_, fs_); \ + } \ +} while (0) #endif -#ifndef MAX -#define MAX(x, y) (((x) > (y)) ? (x) : (y)) +#ifdef MP_USE_MEMSET +# include +# define MP_ZERO_BUFFER(mem, size) memset((mem), 0, (size)) +# define MP_ZERO_DIGITS(mem, digits) \ +do { \ + int zd_ = (digits); \ + if (zd_ > 0) { \ + memset((mem), 0, sizeof(mp_digit) * (size_t)zd_); \ + } \ +} while (0) +#else +# define MP_ZERO_BUFFER(mem, size) \ +do { \ + size_t zs_ = (size); \ + char* zm_ = (char*)(mem); \ + while (zs_-- > 0u) { \ + *zm_++ = '\0'; \ + } \ +} while (0) +# define MP_ZERO_DIGITS(mem, digits) \ +do { \ + int zd_ = (digits); \ + mp_digit* zm_ = (mem); \ + while (zd_-- > 0) { \ + *zm_++ = 0; \ + } \ +} while (0) #endif -#ifdef __cplusplus -extern "C" { +/* Tunable cutoffs + * --------------- + * + * - In the default settings, a cutoff X can be modified at runtime + * by adjusting the corresponding X_CUTOFF variable. + * + * - Tunability of the library can be disabled at compile time + * by defining the MP_FIXED_CUTOFFS macro. + * + * - There is an additional file tommath_cutoffs.h, which defines + * the default cutoffs. These can be adjusted manually or by the + * autotuner. + * + */ + +#ifdef MP_FIXED_CUTOFFS +# include "tommath_cutoffs.h" +# define MP_KARATSUBA_MUL_CUTOFF MP_DEFAULT_KARATSUBA_MUL_CUTOFF +# define MP_KARATSUBA_SQR_CUTOFF MP_DEFAULT_KARATSUBA_SQR_CUTOFF +# define MP_TOOM_MUL_CUTOFF MP_DEFAULT_TOOM_MUL_CUTOFF +# define MP_TOOM_SQR_CUTOFF MP_DEFAULT_TOOM_SQR_CUTOFF +#else +# define MP_KARATSUBA_MUL_CUTOFF KARATSUBA_MUL_CUTOFF +# define MP_KARATSUBA_SQR_CUTOFF KARATSUBA_SQR_CUTOFF +# define MP_TOOM_MUL_CUTOFF TOOM_MUL_CUTOFF +# define MP_TOOM_SQR_CUTOFF TOOM_SQR_CUTOFF #endif /* define heap macros */ -#ifndef XMALLOC +#ifndef MP_MALLOC /* default to libc stuff */ -# define XMALLOC(size) malloc(size) -# define XFREE(mem, size) free(mem) -# define XREALLOC(mem, oldsize, newsize) realloc(mem, newsize) +# include +# define MP_MALLOC(size) malloc(size) +# define MP_REALLOC(mem, oldsize, newsize) realloc((mem), (newsize)) +# define MP_CALLOC(nmemb, size) calloc((nmemb), (size)) +# define MP_FREE(mem, size) free(mem) #elif 0 /* prototypes for our heap functions */ -extern void *XMALLOC(size_t size); -extern void *XREALLOC(void *mem, size_t oldsize, size_t newsize); -extern void XFREE(void *mem, size_t size); +extern void *MP_MALLOC(size_t size); +extern void *MP_REALLOC(void *mem, size_t oldsize, size_t newsize); +extern void *MP_CALLOC(size_t nmemb, size_t size); +extern void MP_FREE(void *mem, size_t size); +#endif + +/* feature detection macro */ +#ifdef _MSC_VER +/* Prevent false positive: not enough arguments for function-like macro invocation */ +#pragma warning(disable: 4003) #endif - -/* you'll have to tune these... */ -#define KARATSUBA_MUL_CUTOFF 80 /* Min. number of digits before Karatsuba multiplication is used. */ -#define KARATSUBA_SQR_CUTOFF 120 /* Min. number of digits before Karatsuba squaring is used. */ -#define TOOM_MUL_CUTOFF 350 /* no optimal values of these are known yet so set em high */ -#define TOOM_SQR_CUTOFF 400 - -/* size of comba arrays, should be at least 2 * 2**(BITS_PER_WORD - BITS_PER_DIGIT*2) */ -#define MP_WARRAY (1u << (((sizeof(mp_word) * CHAR_BIT) - (2 * DIGIT_BIT)) + 1)) +#define MP_STRINGIZE(x) MP__STRINGIZE(x) +#define MP__STRINGIZE(x) ""#x"" +#define MP_HAS(x) (sizeof(MP_STRINGIZE(BN_##x##_C)) == 1u) + +/* TODO: Remove private_mp_word as soon as deprecated mp_word is removed from tommath. */ +#undef mp_word +typedef private_mp_word mp_word; + +#define MP_MIN(x, y) (((x) < (y)) ? (x) : (y)) +#define MP_MAX(x, y) (((x) > (y)) ? (x) : (y)) + +/* Static assertion */ +#define MP_STATIC_ASSERT(msg, cond) typedef char mp_static_assert_##msg[(cond) ? 1 : -1]; /* ---> Basic Manipulations <--- */ -#define IS_ZERO(a) ((a)->used == 0) -#define IS_EVEN(a) (((a)->used == 0) || (((a)->dp[0] & 1u) == 0u)) -#define IS_ODD(a) (((a)->used > 0) && (((a)->dp[0] & 1u) == 1u)) +#define MP_IS_ZERO(a) ((a)->used == 0) +#define MP_IS_EVEN(a) (((a)->used == 0) || (((a)->dp[0] & 1u) == 0u)) +#define MP_IS_ODD(a) (((a)->used > 0) && (((a)->dp[0] & 1u) == 1u)) + +#define MP_SIZEOF_BITS(type) ((size_t)CHAR_BIT * sizeof(type)) +#define MP_MAXFAST (int)(1uL << (MP_SIZEOF_BITS(mp_word) - (2u * (size_t)MP_DIGIT_BIT))) + +/* TODO: Remove PRIVATE_MP_WARRAY as soon as deprecated MP_WARRAY is removed from tommath.h */ +#undef MP_WARRAY +#define MP_WARRAY PRIVATE_MP_WARRAY + +/* TODO: Remove PRIVATE_MP_PREC as soon as deprecated MP_PREC is removed from tommath.h */ +#ifdef PRIVATE_MP_PREC +# undef MP_PREC +# define MP_PREC PRIVATE_MP_PREC +#endif + +/* Minimum number of available digits in mp_int, MP_PREC >= MP_MIN_PREC */ +#define MP_MIN_PREC ((((int)MP_SIZEOF_BITS(Tcl_WideInt) + MP_DIGIT_BIT) - 1) / MP_DIGIT_BIT) + +MP_STATIC_ASSERT(prec_geq_min_prec, MP_PREC >= MP_MIN_PREC) + +/* random number source */ +extern MP_PRIVATE mp_err(*s_mp_rand_source)(void *out, size_t size); /* lowlevel functions, do not call! */ -int s_mp_add(const mp_int *a, const mp_int *b, mp_int *c); -int s_mp_sub(const mp_int *a, const mp_int *b, mp_int *c); -#define s_mp_mul(a, b, c) s_mp_mul_digs(a, b, c, (a)->used + (b)->used + 1) -int fast_s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs); -int s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs); -int fast_s_mp_mul_high_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs); -int s_mp_mul_high_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs); -int fast_s_mp_sqr(const mp_int *a, mp_int *b); -int s_mp_sqr(const mp_int *a, mp_int *b); -int mp_karatsuba_mul(const mp_int *a, const mp_int *b, mp_int *c); -int mp_toom_mul(const mp_int *a, const mp_int *b, mp_int *c); -int mp_karatsuba_sqr(const mp_int *a, mp_int *b); -int mp_toom_sqr(const mp_int *a, mp_int *b); -int fast_mp_invmod(const mp_int *a, const mp_int *b, mp_int *c); -int mp_invmod_slow(const mp_int *a, const mp_int *b, mp_int *c); -int fast_mp_montgomery_reduce(mp_int *x, const mp_int *n, mp_digit rho); -int mp_exptmod_fast(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y, int redmode); -int s_mp_exptmod(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y, int redmode); -void bn_reverse(unsigned char *s, int len); - -extern const char *const mp_s_rmap; -extern const unsigned char mp_s_rmap_reverse[]; -extern const size_t mp_s_rmap_reverse_sz; - -/* Fancy macro to set an MPI from another type. - * There are several things assumed: - * x is the counter - * a is the pointer to the MPI - * b is the original value that should be set in the MPI. - */ -#define MP_SET_XLONG(func_name, type) \ -int func_name (mp_int * a, type b) \ -{ \ - int x = 0; \ - int new_size = (((CHAR_BIT * sizeof(type)) + DIGIT_BIT) - 1) / DIGIT_BIT; \ - int res = mp_grow(a, new_size); \ - if (res == MP_OKAY) { \ - mp_zero(a); \ - while (b != 0u) { \ - a->dp[x++] = ((mp_digit)b & MP_MASK); \ - if ((CHAR_BIT * sizeof (b)) <= DIGIT_BIT) { break; } \ - b >>= ((CHAR_BIT * sizeof (b)) <= DIGIT_BIT ? 0 : DIGIT_BIT); \ - } \ - a->used = x; \ - } \ - return res; \ -} - -#ifdef __cplusplus -} -#endif - -#endif - - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ +MP_PRIVATE mp_bool s_mp_get_bit(const mp_int *a, unsigned int b); +MP_PRIVATE mp_err s_mp_add(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; +MP_PRIVATE mp_err s_mp_sub(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; +MP_PRIVATE mp_err s_mp_mul_digs_fast(const mp_int *a, const mp_int *b, mp_int *c, int digs) MP_WUR; +MP_PRIVATE mp_err s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs) MP_WUR; +MP_PRIVATE mp_err s_mp_mul_high_digs_fast(const mp_int *a, const mp_int *b, mp_int *c, int digs) MP_WUR; +MP_PRIVATE mp_err s_mp_mul_high_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs) MP_WUR; +MP_PRIVATE mp_err s_mp_sqr_fast(const mp_int *a, mp_int *b) MP_WUR; +MP_PRIVATE mp_err s_mp_sqr(const mp_int *a, mp_int *b) MP_WUR; +MP_PRIVATE mp_err s_mp_balance_mul(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; +MP_PRIVATE mp_err s_mp_karatsuba_mul(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; +MP_PRIVATE mp_err s_mp_toom_mul(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; +MP_PRIVATE mp_err s_mp_karatsuba_sqr(const mp_int *a, mp_int *b) MP_WUR; +MP_PRIVATE mp_err s_mp_toom_sqr(const mp_int *a, mp_int *b) MP_WUR; +MP_PRIVATE mp_err s_mp_invmod_fast(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; +MP_PRIVATE mp_err s_mp_invmod_slow(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; +MP_PRIVATE mp_err s_mp_montgomery_reduce_fast(mp_int *x, const mp_int *n, mp_digit rho) MP_WUR; +MP_PRIVATE mp_err s_mp_exptmod_fast(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y, int redmode) MP_WUR; +MP_PRIVATE mp_err s_mp_exptmod(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y, int redmode) MP_WUR; +MP_PRIVATE mp_err s_mp_rand_platform(void *p, size_t n) MP_WUR; +MP_PRIVATE mp_err s_mp_prime_random_ex(mp_int *a, int t, int size, int flags, private_mp_prime_callback cb, void *dat); +MP_PRIVATE void s_mp_reverse(unsigned char *s, size_t len); +MP_PRIVATE mp_err s_mp_prime_is_divisible(const mp_int *a, mp_bool *result); + +/* TODO: jenkins prng is not thread safe as of now */ +MP_PRIVATE mp_err s_mp_rand_jenkins(void *p, size_t n) MP_WUR; +#ifndef MP_NO_STDINT +MP_PRIVATE void s_mp_rand_jenkins_init(uint64_t seed); +#endif + +extern MP_PRIVATE const char *const mp_s_rmap; +extern MP_PRIVATE const unsigned char mp_s_rmap_reverse[]; +extern MP_PRIVATE const size_t mp_s_rmap_reverse_sz; +extern MP_PRIVATE const mp_digit *s_mp_prime_tab; + +/* deprecated functions */ +#if 0 +MP_DEPRECATED(s_mp_invmod_fast) mp_err fast_mp_invmod(const mp_int *a, const mp_int *b, mp_int *c); +MP_DEPRECATED(s_mp_montgomery_reduce_fast) mp_err fast_mp_montgomery_reduce(mp_int *x, const mp_int *n, + mp_digit rho); +MP_DEPRECATED(s_mp_mul_digs_fast) mp_err fast_s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, + int digs); +MP_DEPRECATED(s_mp_mul_high_digs_fast) mp_err fast_s_mp_mul_high_digs(const mp_int *a, const mp_int *b, + mp_int *c, + int digs); +MP_DEPRECATED(s_mp_sqr_fast) mp_err fast_s_mp_sqr(const mp_int *a, mp_int *b); +MP_DEPRECATED(s_mp_balance_mul) mp_err mp_balance_mul(const mp_int *a, const mp_int *b, mp_int *c); +MP_DEPRECATED(s_mp_exptmod_fast) mp_err mp_exptmod_fast(const mp_int *G, const mp_int *X, const mp_int *P, + mp_int *Y, + int redmode); +MP_DEPRECATED(s_mp_invmod_slow) mp_err mp_invmod_slow(const mp_int *a, const mp_int *b, mp_int *c); +MP_DEPRECATED(s_mp_karatsuba_mul) mp_err mp_karatsuba_mul(const mp_int *a, const mp_int *b, mp_int *c); +MP_DEPRECATED(s_mp_karatsuba_sqr) mp_err mp_karatsuba_sqr(const mp_int *a, mp_int *b); +MP_DEPRECATED(s_mp_toom_mul) mp_err mp_toom_mul(const mp_int *a, const mp_int *b, mp_int *c); +MP_DEPRECATED(s_mp_toom_sqr) mp_err mp_toom_sqr(const mp_int *a, mp_int *b); +MP_DEPRECATED(s_mp_reverse) void bn_reverse(unsigned char *s, int len); +#endif + +#define MP_GET_ENDIANNESS(x) \ + do{\ + int16_t n = 0x1; \ + char *p = (char *)&n; \ + x = (p[0] == '\x01') ? MP_LITTLE_ENDIAN : MP_BIG_ENDIAN; \ + } while (0) + +/* code-generating macros */ +#define MP_SET_UNSIGNED(name, type) \ + void name(mp_int * a, type b) \ + { \ + int i = 0; \ + while (b != 0u) { \ + a->dp[i++] = ((mp_digit)b & MP_MASK); \ + if (MP_SIZEOF_BITS(type) <= MP_DIGIT_BIT) { break; } \ + b >>= ((MP_SIZEOF_BITS(type) <= MP_DIGIT_BIT) ? 0 : MP_DIGIT_BIT); \ + } \ + a->used = i; \ + a->sign = MP_ZPOS; \ + MP_ZERO_DIGITS(a->dp + a->used, a->alloc - a->used); \ + } + +#define MP_SET_SIGNED(name, uname, type, utype) \ + void name(mp_int * a, type b) \ + { \ + uname(a, (b < 0) ? -(utype)b : (utype)b); \ + if (b < 0) { a->sign = MP_NEG; } \ + } + +#define MP_INIT_INT(name , set, type) \ + mp_err name(mp_int * a, type b) \ + { \ + mp_err err; \ + if ((err = mp_init(a)) != MP_OKAY) { \ + return err; \ + } \ + set(a, b); \ + return MP_OKAY; \ + } + +#define MP_GET_MAG(name, type) \ + type name(const mp_int* a) \ + { \ + unsigned i = MP_MIN((unsigned)a->used, (unsigned)((MP_SIZEOF_BITS(type) + MP_DIGIT_BIT - 1) / MP_DIGIT_BIT)); \ + type res = 0u; \ + while (i --> 0u) { \ + res <<= ((MP_SIZEOF_BITS(type) <= MP_DIGIT_BIT) ? 0 : MP_DIGIT_BIT); \ + res |= (type)a->dp[i]; \ + if (MP_SIZEOF_BITS(type) <= MP_DIGIT_BIT) { break; } \ + } \ + return res; \ + } + +#define MP_GET_SIGNED(name, mag, type, utype) \ + type name(const mp_int* a) \ + { \ + utype res = mag(a); \ + return (a->sign == MP_NEG) ? (type)-res : (type)res; \ + } + +#undef mp_isodd +#define mp_isodd TclBN_mp_isodd + +#endif Index: libtommath/tommath_superclass.h ================================================================== --- libtommath/tommath_superclass.h +++ libtommath/tommath_superclass.h @@ -1,88 +1,110 @@ -/* LibTomMath, multiple-precision integer library -- Tom St Denis - * - * LibTomMath is a library that provides multiple-precision - * integer arithmetic as well as number theoretic functionality. - * - * The library was designed directly after the MPI library by - * Michael Fromberger but has been written from scratch with - * additional optimizations in place. - * - * SPDX-License-Identifier: Unlicense - */ +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ /* super class file for PK algos */ /* default ... include all MPI */ +#ifndef LTM_NOTHING #define LTM_ALL +#endif /* RSA only (does not support DH/DSA/ECC) */ /* #define SC_RSA_1 */ +/* #define SC_RSA_1_WITH_TESTS */ /* For reference.... On an Athlon64 optimizing for speed... LTM's mpi.o with all functions [striped] is 142KiB in size. */ + +#ifdef SC_RSA_1_WITH_TESTS +# define BN_MP_ERROR_TO_STRING_C +# define BN_MP_FREAD_C +# define BN_MP_FWRITE_C +# define BN_MP_INCR_C +# define BN_MP_ISEVEN_C +# define BN_MP_ISODD_C +# define BN_MP_NEG_C +# define BN_MP_PRIME_FROBENIUS_UNDERWOOD_C +# define BN_MP_RADIX_SIZE_C +# define BN_MP_RAND_C +# define BN_MP_REDUCE_C +# define BN_MP_REDUCE_2K_L_C +# define BN_MP_FROM_SBIN_C +# define BN_MP_ROOT_U32_C +# define BN_MP_SET_L_C +# define BN_MP_SET_UL_C +# define BN_MP_SBIN_SIZE_C +# define BN_MP_TO_RADIX_C +# define BN_MP_TO_SBIN_C +# define BN_S_MP_RAND_JENKINS_C +# define BN_S_MP_RAND_PLATFORM_C +#endif /* Works for RSA only, mpi.o is 68KiB */ -#ifdef SC_RSA_1 -# define BN_MP_SHRINK_C -# define BN_MP_LCM_C -# define BN_MP_PRIME_RANDOM_EX_C -# define BN_MP_INVMOD_C -# define BN_MP_GCD_C -# define BN_MP_MOD_C -# define BN_MP_MULMOD_C +#if defined(SC_RSA_1) || defined (SC_RSA_1_WITH_TESTS) +# define BN_CUTOFFS_C # define BN_MP_ADDMOD_C -# define BN_MP_EXPTMOD_C -# define BN_MP_SET_INT_C -# define BN_MP_INIT_MULTI_C # define BN_MP_CLEAR_MULTI_C -# define BN_MP_UNSIGNED_BIN_SIZE_C -# define BN_MP_TO_UNSIGNED_BIN_C +# define BN_MP_EXPTMOD_C +# define BN_MP_GCD_C +# define BN_MP_INIT_MULTI_C +# define BN_MP_INVMOD_C +# define BN_MP_LCM_C +# define BN_MP_MOD_C # define BN_MP_MOD_D_C +# define BN_MP_MULMOD_C +# define BN_MP_PRIME_IS_PRIME_C # define BN_MP_PRIME_RABIN_MILLER_TRIALS_C -# define BN_REVERSE_C +# define BN_MP_PRIME_RAND_C +# define BN_MP_RADIX_SMAP_C +# define BN_MP_SET_INT_C +# define BN_MP_SHRINK_C +# define BN_MP_TO_UNSIGNED_BIN_C +# define BN_MP_UNSIGNED_BIN_SIZE_C # define BN_PRIME_TAB_C +# define BN_S_MP_REVERSE_C /* other modifiers */ # define BN_MP_DIV_SMALL /* Slower division, not critical */ + /* here we are on the last pass so we turn things off. The functions classes are still there * but we remove them specifically from the build. This also invokes tweaks in functions * like removing support for even moduli, etc... */ # ifdef LTM_LAST -# undef BN_MP_TOOM_MUL_C -# undef BN_MP_TOOM_SQR_C -# undef BN_MP_KARATSUBA_MUL_C -# undef BN_MP_KARATSUBA_SQR_C -# undef BN_MP_REDUCE_C -# undef BN_MP_REDUCE_SETUP_C # undef BN_MP_DR_IS_MODULUS_C # undef BN_MP_DR_SETUP_C # undef BN_MP_DR_REDUCE_C -# undef BN_MP_REDUCE_IS_2K_C +# undef BN_MP_DIV_3_C # undef BN_MP_REDUCE_2K_SETUP_C # undef BN_MP_REDUCE_2K_C +# undef BN_MP_REDUCE_IS_2K_C +# undef BN_MP_REDUCE_SETUP_C +# undef BN_S_MP_BALANCE_MUL_C # undef BN_S_MP_EXPTMOD_C -# undef BN_MP_DIV_3_C +# undef BN_S_MP_INVMOD_FAST_C +# undef BN_S_MP_KARATSUBA_MUL_C +# undef BN_S_MP_KARATSUBA_SQR_C # undef BN_S_MP_MUL_HIGH_DIGS_C -# undef BN_FAST_S_MP_MUL_HIGH_DIGS_C -# undef BN_FAST_MP_INVMOD_C +# undef BN_S_MP_MUL_HIGH_DIGS_FAST_C +# undef BN_S_MP_TOOM_MUL_C +# undef BN_S_MP_TOOM_SQR_C + +# ifndef SC_RSA_1_WITH_TESTS +# undef BN_MP_REDUCE_C +# endif /* To safely undefine these you have to make sure your RSA key won't exceed the Comba threshold * which is roughly 255 digits [7140 bits for 32-bit machines, 15300 bits for 64-bit machines] * which means roughly speaking you can handle upto 2536-bit RSA keys with these defined without * trouble. */ +# undef BN_MP_MONTGOMERY_REDUCE_C # undef BN_S_MP_MUL_DIGS_C # undef BN_S_MP_SQR_C -# undef BN_MP_MONTGOMERY_REDUCE_C # endif #endif - -/* ref: $Format:%D$ */ -/* git commit: $Format:%H$ */ -/* commit time: $Format:%ai$ */ Index: macosx/GNUmakefile ================================================================== --- macosx/GNUmakefile +++ macosx/GNUmakefile @@ -29,10 +29,22 @@ LIBDIR ?= ${INSTALL_PATH} MANDIR ?= ${PREFIX}/man # set to non-empty value to install manpages in addition to html help: INSTALL_MANPAGES ?= + +# Checks and overrides for subframework builds +ifeq (${SUBFRAMEWORK},1) +ifeq (${DYLIB_INSTALL_DIR},) + @echo "Cannot install subframework with empty DYLIB_INSTALL_DIR !" && false +endif +ifeq (${DESTDIR},) + @echo "Cannot install subframework with empty DESTDIR !" && false +endif +override BUILD_DIR = ${DESTDIR}/build +override INSTALL_PATH = /Frameworks +endif #------------------------------------------------------------------------------------------------------- # meta targets meta := all install embedded install-embedded clean distclean test @@ -90,11 +102,11 @@ PROJECT := tcl PRODUCT_NAME := Tcl UNIX_DIR := ${CURDIR}/../unix -VERSION := $(shell awk -F= '/^TCL_VERSION/ {print $$2; nextfile}' ${UNIX_DIR}/configure.ac) +VERSION := $(shell awk -F= '/^TCL_VERSION/ {print $$2; nextfile}' ${UNIX_DIR}/configure.in) TCLSH := tclsh${VERSION} BUILD_TARGET := all tcltest INSTALL_TARGET := install @@ -130,11 +142,11 @@ ${objdir}/Makefile: ${UNIX_DIR}/Makefile.in ${UNIX_DIR}/configure \ ${UNIX_DIR}/tclConfig.sh.in Tcl-Info.plist.in mkdir -p "${OBJ_DIR}" && cd "${OBJ_DIR}" && \ if [ ${UNIX_DIR}/configure -nt config.status ]; then ${UNIX_DIR}/configure -C \ --prefix="${PREFIX}" --bindir="${BINDIR}" --libdir="${LIBDIR}" \ - --mandir="${MANDIR}" --enable-framework --enable-dtrace \ + --mandir="${MANDIR}" --enable-threads --enable-framework --enable-dtrace \ ${CONFIGURE_ARGS} ${EXTRA_CONFIGURE_ARGS}; else ./config.status; fi build-${PROJECT}: ${objdir}/Makefile ${DO_MAKE} ifeq (${INSTALL_BUILD},) Index: macosx/README ================================================================== --- macosx/README +++ macosx/README @@ -19,11 +19,11 @@ - The Tcl'ers Wiki also has many pages dealing with Tcl & Tk on Mac OS X, see http://wiki.tcl.tk/_/ref?N=3753 http://wiki.tcl.tk/_/ref?N=8361 - Please report bugs with Tcl on Mac OS X to the tracker: - http://core.tcl.tk/tcl/reportlist + https://core.tcl-lang.org/tcl/reportlist 2. Using Tcl on Mac OS X ------------------------ - At a minimum, Mac OS X 10.3 is required to run Tcl. @@ -34,12 +34,12 @@ in a binary built on 10.x). Weak-linking is available on OS X 10.2 or later, it additionally allows Tcl built on 10.x to run on any 10.y with x > y >= z (for a chosen z >= 2). - Tcl extensions can be installed in any of: - $HOME/Library/Tcl /Library/Tcl /System/Library/Tcl - $HOME/Library/Frameworks /Library/Frameworks /System/Library/Frameworks + $HOME/Library/Tcl /Library/Tcl + $HOME/Library/Frameworks /Library/Frameworks (searched in that order). Given a potential package directory $pkg, Tcl on OSX checks for the file $pkg/Resources/Scripts/pkgIndex.tcl as well as the usual $pkg/pkgIndex.tcl. This allows building extensions as frameworks with all script files contained in the Resources/Scripts directory of the framework. @@ -55,11 +55,11 @@ Tcl.framework/Resources/Documentation/Reference/Tcl No nroff manpages are installed by default by the GNUmakefile. - The Tcl framework can be installed in any of the system's standard framework directories: - $HOME/Library/Frameworks /Library/Frameworks /System/Library/Frameworks + $HOME/Library/Frameworks /Library/Frameworks 3. Building Tcl on Mac OS X --------------------------- @@ -111,11 +111,11 @@ Note that the non-SDK configurations have their deployment target set to 10.5 (Tcl.xcode) resp. 10.6 (Tcl.xcodeproj). The Xcode projects refer to the toplevel tcl source directory via the TCL_SRCROOT user build setting, by default this is set to the project-relative path '../../tcl', if your tcl source directory is named differently, e.g. -'../../tcl9.0', you need to manually change the TCL_SRCROOT setting by editing +'../../tcl8.6', you need to manually change the TCL_SRCROOT setting by editing your ${USER}.pbxuser file (located inside the Tcl.xcodeproj bundle directory) with a text editor. - To build universal binaries outside of the Xcode IDE, set CFLAGS as follows: export CFLAGS="-arch i386 -arch x86_64 -arch ppc" @@ -132,13 +132,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.0'). +(where ${ver} is a shell variable containing the Tcl version number e.g. '8.6'). Setup this shell variable as follows: - ver="9.0" + ver="8.6" If you are building from CVS, omit this step (CVS source tree names usually do not contain a version number). - Setup environment variables as desired, e.g. for a universal build on 10.5: CFLAGS="-arch i386 -arch x86_64 -arch ppc -mmacosx-version-min=10.5" @@ -163,5 +163,15 @@ If you only want to build and install the debug or optimized build, use the 'develop' or 'deploy' target variants of the GNUmakefile, respectively. For example, to build and install only the optimized versions: make -C tcl${ver}/macosx deploy sudo make -C tcl${ver}/macosx install-deploy + +- To build a Tcl.framework for use as a subframework in another framework, use the +install-embedded target and set SUBFRAMEWORK=1. Set the DYLIB_INSTALL_DIR +variable to the path which should be the install_name path of the Tcl library, set +the DESTDIR variable to the pathname of a staging directory where the framework +will be written . For example, running this command in the Tcl source directory: + make -C macosx install-embedded SUBFRAMEWORK=1 DESTDIR=/tmp/tcl \ + DYLIB_INSTALL_DIR=/Library/Frameworks/Some.framework/Versions/X.Y/Frameworks/Tcl.framework +will produce a Tcl.framework intended for installing as a subframework of +Some.framework. The framework will be found in /tmp/tcl/Frameworks/ Index: macosx/Tcl-Common.xcconfig ================================================================== --- macosx/Tcl-Common.xcconfig +++ macosx/Tcl-Common.xcconfig @@ -17,11 +17,11 @@ GCC_GENERATE_DEBUGGING_SYMBOLS = YES GCC_NO_COMMON_BLOCKS = YES GCC_DYNAMIC_NO_PIC = YES GCC_VERSION = 4.2 GCC = gcc-$(GCC_VERSION) -WARNING_CFLAGS = -Wall -Wwrite-strings -Wextra -Wdeclaration-after-statement -Wno-unused-parameter -Wno-missing-field-initializers -Wno-unused-value -Winit-self -Wpointer-arith -Wcast-align -Wdisabled-optimization -Winline $(WARNING_CFLAGS) +WARNING_CFLAGS = -Wall -Wextra -Wno-unused-parameter -Wno-missing-field-initializers -Wno-unused-value -Winit-self -Wpointer-arith -Wcast-align -Wdisabled-optimization -Winline $(WARNING_CFLAGS) BINDIR = $(PREFIX)/bin CFLAGS = $(CFLAGS) CPPFLAGS = -mmacosx-version-min=$(MACOSX_DEPLOYMENT_TARGET) $(CPPFLAGS) FRAMEWORK_INSTALL_PATH = /Library/Frameworks INCLUDEDIR = $(PREFIX)/include @@ -28,10 +28,10 @@ LIBDIR = $(PREFIX)/lib MANDIR = $(PREFIX)/man PER_ARCH_CFLAGS_ppc = -mcpu=G3 -mtune=G4 $(PER_ARCH_CFLAGS_ppc) PER_ARCH_CFLAGS_ppc64 = -mcpu=G5 -mpowerpc64 $(PER_ARCH_CFLAGS_ppc64) PREFIX = /usr/local -TCL_CONFIGURE_ARGS = --enable-dtrace +TCL_CONFIGURE_ARGS = --enable-threads --enable-dtrace TCL_LIBRARY = $(LIBDIR)/tcl$(VERSION) TCL_PACKAGE_PATH = "$(LIBDIR)" TCL_DEFS = HAVE_TCL_CONFIG_H -VERSION = 9.0 +VERSION = 8.6 Index: macosx/Tcl.xcode/project.pbxproj ================================================================== --- macosx/Tcl.xcode/project.pbxproj +++ macosx/Tcl.xcode/project.pbxproj @@ -136,11 +136,11 @@ F96D493C08F272C3004A47F5 /* bn_mp_sqr.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42BE08F272B3004A47F5 /* bn_mp_sqr.c */; }; F96D493F08F272C3004A47F5 /* bn_mp_sub.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C108F272B3004A47F5 /* bn_mp_sub.c */; }; F96D494008F272C3004A47F5 /* bn_mp_sub_d.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C208F272B3004A47F5 /* bn_mp_sub_d.c */; }; F96D494608F272C3004A47F5 /* bn_mp_toom_mul.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C808F272B3004A47F5 /* bn_mp_toom_mul.c */; }; F96D494708F272C3004A47F5 /* bn_mp_toom_sqr.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C908F272B3004A47F5 /* bn_mp_toom_sqr.c */; }; - F96D494908F272C3004A47F5 /* bn_mp_toradix_n.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42CB08F272B3004A47F5 /* bn_mp_toradix_n.c */; }; + F96D494908F272C3004A47F5 /* bn_mp_to_radix.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42CB08F272B3004A47F5 /* bn_mp_to_radix.c */; }; F96D494C08F272C3004A47F5 /* bn_mp_zero.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42CE08F272B3004A47F5 /* bn_mp_zero.c */; }; F96D494E08F272C3004A47F5 /* bn_reverse.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D008F272B3004A47F5 /* bn_reverse.c */; }; F96D494F08F272C3004A47F5 /* bn_s_mp_add.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D108F272B3004A47F5 /* bn_s_mp_add.c */; }; F96D495108F272C3004A47F5 /* bn_s_mp_mul_digs.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D308F272B3004A47F5 /* bn_s_mp_mul_digs.c */; }; F96D495308F272C3004A47F5 /* bn_s_mp_sqr.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D508F272B3004A47F5 /* bn_s_mp_sqr.c */; }; @@ -162,18 +162,16 @@ F96D4AD608F272CA004A47F5 /* tclUnixTime.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D446B08F272B9004A47F5 /* tclUnixTime.c */; }; F9E61D28090A481F002B3151 /* bn_mp_cmp_d.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D427108F272B3004A47F5 /* bn_mp_cmp_d.c */; }; F9E61D29090A486C002B3151 /* bn_mp_neg.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42A208F272B3004A47F5 /* bn_mp_neg.c */; }; F9E61D2A090A4891002B3151 /* bn_mp_sqrt.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C008F272B3004A47F5 /* bn_mp_sqrt.c */; }; F9E61D2B090A48A4002B3151 /* bn_mp_and.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D426C08F272B3004A47F5 /* bn_mp_and.c */; }; - F9E61D2C090A48AC002B3151 /* bn_mp_expt_d.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D427F08F272B3004A47F5 /* bn_mp_expt_d.c */; }; - F9E61D2C090A48AC002B3151 /* bn_mp_expt_d_ex.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D427F08F272B3004A47F5 /* bn_mp_expt_d_ex.c */; }; + F9E61D2C090A48AC002B3151 /* bn_mp_expt_u32.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D427F08F272B3004A47F5 /* bn_mp_expt_u32.c */; }; F9E61D2D090A48BB002B3151 /* bn_mp_xor.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42CD08F272B3004A47F5 /* bn_mp_xor.c */; }; F9E61D2E090A48BF002B3151 /* bn_mp_or.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42A308F272B3004A47F5 /* bn_mp_or.c */; }; F9E61D2F090A48C7002B3151 /* bn_mp_shrink.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42BC08F272B3004A47F5 /* bn_mp_shrink.c */; }; - F9E61D30090A48E2002B3151 /* bn_mp_to_unsigned_bin_n.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C708F272B3004A47F5 /* bn_mp_to_unsigned_bin_n.c */; }; - F9E61D31090A48F9002B3151 /* bn_mp_to_unsigned_bin.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C608F272B3004A47F5 /* bn_mp_to_unsigned_bin.c */; }; - F9E61D32090A48FA002B3151 /* bn_mp_unsigned_bin_size.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42CC08F272B3004A47F5 /* bn_mp_unsigned_bin_size.c */; }; + F9E61D31090A48F9002B3151 /* bn_mp_to_ubin.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C608F272B3004A47F5 /* bn_mp_to_ubin.c */; }; + F9E61D32090A48FA002B3151 /* bn_mp_ubin_size.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42CC08F272B3004A47F5 /* bn_mp_ubin_size.c */; }; F9F4415E0C8BAE6F00BCCD67 /* tclDTrace.d in Sources */ = {isa = PBXBuildFile; fileRef = F9F4415D0C8BAE6F00BCCD67 /* tclDTrace.d */; }; F9FC77B80AB29E9100B7077D /* tclUnixCompat.c in Sources */ = {isa = PBXBuildFile; fileRef = F9FC77B70AB29E9100B7077D /* tclUnixCompat.c */; }; /* End PBXBuildFile section */ /* Begin PBXContainerItemProxy section */ @@ -263,11 +261,11 @@ F96D3E1D08F272A5004A47F5 /* CrtCommand.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtCommand.3; sourceTree = ""; }; F96D3E1E08F272A5004A47F5 /* CrtFileHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtFileHdlr.3; sourceTree = ""; }; F96D3E1F08F272A5004A47F5 /* CrtInterp.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtInterp.3; sourceTree = ""; }; F96D3E2008F272A5004A47F5 /* CrtMathFnc.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtMathFnc.3; sourceTree = ""; }; F96D3E2108F272A5004A47F5 /* CrtObjCmd.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtObjCmd.3; sourceTree = ""; }; - F96D3E2208F272A5004A47F5 /* CrtSlave.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtSlave.3; sourceTree = ""; }; + F96D3E2208F272A5004A47F5 /* CrtAlias.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtAlias.3; sourceTree = ""; }; F96D3E2308F272A5004A47F5 /* CrtTimerHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtTimerHdlr.3; sourceTree = ""; }; F96D3E2408F272A5004A47F5 /* CrtTrace.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtTrace.3; sourceTree = ""; }; F96D3E2508F272A5004A47F5 /* dde.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = dde.n; sourceTree = ""; }; F96D3E2608F272A5004A47F5 /* DetachPids.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = DetachPids.3; sourceTree = ""; }; F96D3E2708F272A5004A47F5 /* dict.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = dict.n; sourceTree = ""; }; @@ -576,11 +574,11 @@ F96D427708F272B3004A47F5 /* bn_mp_div_2.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_div_2.c; sourceTree = ""; }; F96D427808F272B3004A47F5 /* bn_mp_div_2d.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_div_2d.c; sourceTree = ""; }; F96D427908F272B3004A47F5 /* bn_mp_div_3.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_div_3.c; sourceTree = ""; }; F96D427A08F272B3004A47F5 /* bn_mp_div_d.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_div_d.c; sourceTree = ""; }; F96D427E08F272B3004A47F5 /* bn_mp_exch.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_exch.c; sourceTree = ""; }; - F96D427F08F272B3004A47F5 /* bn_mp_expt_d.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_expt_d.c; sourceTree = ""; }; + F96D427F08F272B3004A47F5 /* bn_mp_expt_u32.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_expt_u32.c; sourceTree = ""; }; F96D428708F272B3004A47F5 /* bn_mp_grow.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_grow.c; sourceTree = ""; }; F96D428808F272B3004A47F5 /* bn_mp_init.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_init.c; sourceTree = ""; }; F96D428908F272B3004A47F5 /* bn_mp_init_copy.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_init_copy.c; sourceTree = ""; }; F96D428A08F272B3004A47F5 /* bn_mp_init_multi.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_init_multi.c; sourceTree = ""; }; F96D428B08F272B3004A47F5 /* bn_mp_init_set.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_init_set.c; sourceTree = ""; }; @@ -604,16 +602,15 @@ F96D42BC08F272B3004A47F5 /* bn_mp_shrink.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_shrink.c; sourceTree = ""; }; F96D42BE08F272B3004A47F5 /* bn_mp_sqr.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_sqr.c; sourceTree = ""; }; F96D42C008F272B3004A47F5 /* bn_mp_sqrt.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_sqrt.c; sourceTree = ""; }; F96D42C108F272B3004A47F5 /* bn_mp_sub.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_sub.c; sourceTree = ""; }; F96D42C208F272B3004A47F5 /* bn_mp_sub_d.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_sub_d.c; sourceTree = ""; }; - F96D42C608F272B3004A47F5 /* bn_mp_to_unsigned_bin.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_to_unsigned_bin.c; sourceTree = ""; }; - F96D42C708F272B3004A47F5 /* bn_mp_to_unsigned_bin_n.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_to_unsigned_bin_n.c; sourceTree = ""; }; + F96D42C608F272B3004A47F5 /* bn_mp_to_ubin.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_to_ubin.c; sourceTree = ""; }; F96D42C808F272B3004A47F5 /* bn_mp_toom_mul.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_toom_mul.c; sourceTree = ""; }; F96D42C908F272B3004A47F5 /* bn_mp_toom_sqr.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_toom_sqr.c; sourceTree = ""; }; - F96D42CB08F272B3004A47F5 /* bn_mp_toradix_n.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_toradix_n.c; sourceTree = ""; }; - F96D42CC08F272B3004A47F5 /* bn_mp_unsigned_bin_size.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_unsigned_bin_size.c; sourceTree = ""; }; + F96D42CB08F272B3004A47F5 /* bn_mp_to_radix.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_to_radix.c; sourceTree = ""; }; + F96D42CC08F272B3004A47F5 /* bn_mp_ubin_size.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_ubin_size.c; sourceTree = ""; }; F96D42CD08F272B3004A47F5 /* bn_mp_xor.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_xor.c; sourceTree = ""; }; F96D42CE08F272B3004A47F5 /* bn_mp_zero.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_zero.c; sourceTree = ""; }; F96D42D008F272B3004A47F5 /* bn_reverse.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_reverse.c; sourceTree = ""; }; F96D42D108F272B3004A47F5 /* bn_s_mp_add.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_s_mp_add.c; sourceTree = ""; }; F96D42D308F272B3004A47F5 /* bn_s_mp_mul_digs.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_s_mp_mul_digs.c; sourceTree = ""; }; @@ -766,11 +763,11 @@ F96D43CD08F272B7004A47F5 /* winNotify.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = winNotify.test; sourceTree = ""; }; F96D43CE08F272B7004A47F5 /* winPipe.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = winPipe.test; sourceTree = ""; }; F96D43CF08F272B7004A47F5 /* winTime.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = winTime.test; sourceTree = ""; }; F96D43D108F272B8004A47F5 /* checkLibraryDoc.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = checkLibraryDoc.tcl; sourceTree = ""; }; F96D43D208F272B8004A47F5 /* configure */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text.script.sh; path = configure; sourceTree = ""; }; - F96D43D308F272B8004A47F5 /* configure.ac */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = configure.ac; sourceTree = ""; }; + F96D43D308F272B8004A47F5 /* configure.in */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = configure.in; sourceTree = ""; }; F96D442408F272B8004A47F5 /* fix_tommath_h.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = fix_tommath_h.tcl; sourceTree = ""; }; F96D442508F272B8004A47F5 /* genStubs.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = genStubs.tcl; sourceTree = ""; }; F96D442708F272B8004A47F5 /* index.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = index.tcl; sourceTree = ""; }; F96D442808F272B8004A47F5 /* installData.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = installData.tcl; sourceTree = ""; }; F96D442908F272B8004A47F5 /* loadICU.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = loadICU.tcl; sourceTree = ""; }; @@ -789,11 +786,11 @@ F96D443A08F272B9004A47F5 /* tclZIC.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = tclZIC.tcl; sourceTree = ""; }; F96D443B08F272B9004A47F5 /* uniClass.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = uniClass.tcl; sourceTree = ""; }; F96D443C08F272B9004A47F5 /* uniParse.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = uniParse.tcl; sourceTree = ""; }; F96D444008F272B9004A47F5 /* aclocal.m4 */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = aclocal.m4; sourceTree = ""; }; F96D444108F272B9004A47F5 /* configure */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text.script.sh; path = configure; sourceTree = ""; }; - F96D444208F272B9004A47F5 /* configure.ac */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = configure.ac; sourceTree = ""; }; + F96D444208F272B9004A47F5 /* configure.in */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = configure.in; sourceTree = ""; }; F96D444408F272B9004A47F5 /* Makefile.in */ = {isa = PBXFileReference; explicitFileType = sourcecode.make; fileEncoding = 4; path = Makefile.in; sourceTree = ""; }; F96D444508F272B9004A47F5 /* pkga.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = pkga.c; sourceTree = ""; }; F96D444608F272B9004A47F5 /* pkgb.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = pkgb.c; sourceTree = ""; }; F96D444708F272B9004A47F5 /* pkgc.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = pkgc.c; sourceTree = ""; }; F96D444808F272B9004A47F5 /* pkgd.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = pkgd.c; sourceTree = ""; }; @@ -833,11 +830,11 @@ F96D447008F272BA004A47F5 /* aclocal.m4 */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = aclocal.m4; sourceTree = ""; }; F96D447108F272BA004A47F5 /* buildall.vc.bat */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = buildall.vc.bat; sourceTree = ""; }; F96D447208F272BA004A47F5 /* cat.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = cat.c; sourceTree = ""; }; F96D447308F272BA004A47F5 /* coffbase.txt */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = coffbase.txt; sourceTree = ""; }; F96D447408F272BA004A47F5 /* configure */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text.script.sh; path = configure; sourceTree = ""; }; - F96D447508F272BA004A47F5 /* configure.ac */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = configure.ac; sourceTree = ""; }; + F96D447508F272BA004A47F5 /* configure.in */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = configure.in; sourceTree = ""; }; F96D447708F272BA004A47F5 /* Makefile.in */ = {isa = PBXFileReference; explicitFileType = sourcecode.make; fileEncoding = 4; path = Makefile.in; sourceTree = ""; }; F96D447808F272BA004A47F5 /* makefile.vc */ = {isa = PBXFileReference; explicitFileType = sourcecode.make; fileEncoding = 4; path = makefile.vc; sourceTree = ""; }; F96D447908F272BA004A47F5 /* nmakehlp.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = nmakehlp.c; sourceTree = ""; }; F96D447A08F272BA004A47F5 /* README */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = README; sourceTree = ""; }; F96D447C08F272BA004A47F5 /* rules.vc */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = rules.vc; sourceTree = ""; }; @@ -1014,11 +1011,11 @@ F96D3E1D08F272A5004A47F5 /* CrtCommand.3 */, F96D3E1E08F272A5004A47F5 /* CrtFileHdlr.3 */, F96D3E1F08F272A5004A47F5 /* CrtInterp.3 */, F96D3E2008F272A5004A47F5 /* CrtMathFnc.3 */, F96D3E2108F272A5004A47F5 /* CrtObjCmd.3 */, - F96D3E2208F272A5004A47F5 /* CrtSlave.3 */, + F96D3E2208F272A5004A47F5 /* CrtAlias.3 */, F96D3E2308F272A5004A47F5 /* CrtTimerHdlr.3 */, F96D3E2408F272A5004A47F5 /* CrtTrace.3 */, F96D3E2508F272A5004A47F5 /* dde.n */, F93599D30DF1F8F500E04F67 /* define.n */, F96D3E2608F272A5004A47F5 /* DetachPids.3 */, @@ -1336,10 +1333,11 @@ F96D3F3908F272A8004A47F5 /* auto.tcl */, F96D3F3A08F272A8004A47F5 /* clock.tcl */, F96D3F3B08F272A8004A47F5 /* dde */, F96D3F8C08F272A8004A47F5 /* history.tcl */, F96D3F8D08F272A8004A47F5 /* http */, + F96D3F9008F272A8004A47F5 /* http1.0 */, F96D3F9308F272A8004A47F5 /* init.tcl */, F96D3F9408F272A8004A47F5 /* msgcat */, F96D401708F272AA004A47F5 /* opt */, F96D401A08F272AA004A47F5 /* package.tcl */, F96D401B08F272AA004A47F5 /* parray.tcl */, @@ -1368,10 +1366,19 @@ F96D3F8E08F272A8004A47F5 /* http.tcl */, F96D3F8F08F272A8004A47F5 /* pkgIndex.tcl */, ); path = http; sourceTree = ""; + }; + F96D3F9008F272A8004A47F5 /* http1.0 */ = { + isa = PBXGroup; + children = ( + F96D3F9108F272A8004A47F5 /* http.tcl */, + F96D3F9208F272A8004A47F5 /* pkgIndex.tcl */, + ); + path = http1.0; + sourceTree = ""; }; F96D3F9408F272A8004A47F5 /* msgcat */ = { isa = PBXGroup; children = ( F96D3F9508F272A8004A47F5 /* msgcat.tcl */, @@ -1426,12 +1433,11 @@ F96D427708F272B3004A47F5 /* bn_mp_div_2.c */, F96D427808F272B3004A47F5 /* bn_mp_div_2d.c */, F96D427908F272B3004A47F5 /* bn_mp_div_3.c */, F96D427A08F272B3004A47F5 /* bn_mp_div_d.c */, F96D427E08F272B3004A47F5 /* bn_mp_exch.c */, - F96D427F08F272B3004A47F5 /* bn_mp_expt_d.c */, - F96D427F08F272B3004A47F5 /* bn_mp_expt_d_ex.c */, + F96D427F08F272B3004A47F5 /* bn_mp_expt_u32.c */, F96D428708F272B3004A47F5 /* bn_mp_grow.c */, F96D428808F272B3004A47F5 /* bn_mp_init.c */, F96D428908F272B3004A47F5 /* bn_mp_init_copy.c */, F96D428A08F272B3004A47F5 /* bn_mp_init_multi.c */, F96D428B08F272B3004A47F5 /* bn_mp_init_set.c */, @@ -1455,16 +1461,15 @@ F96D42BC08F272B3004A47F5 /* bn_mp_shrink.c */, F96D42BE08F272B3004A47F5 /* bn_mp_sqr.c */, F96D42C008F272B3004A47F5 /* bn_mp_sqrt.c */, F96D42C108F272B3004A47F5 /* bn_mp_sub.c */, F96D42C208F272B3004A47F5 /* bn_mp_sub_d.c */, - F96D42C608F272B3004A47F5 /* bn_mp_to_unsigned_bin.c */, - F96D42C708F272B3004A47F5 /* bn_mp_to_unsigned_bin_n.c */, + F96D42C608F272B3004A47F5 /* bn_mp_to_ubin.c */, F96D42C808F272B3004A47F5 /* bn_mp_toom_mul.c */, F96D42C908F272B3004A47F5 /* bn_mp_toom_sqr.c */, - F96D42CB08F272B3004A47F5 /* bn_mp_toradix_n.c */, - F96D42CC08F272B3004A47F5 /* bn_mp_unsigned_bin_size.c */, + F96D42CB08F272B3004A47F5 /* bn_mp_to_radix.c */, + F96D42CC08F272B3004A47F5 /* bn_mp_ubin_size.c */, F96D42CD08F272B3004A47F5 /* bn_mp_xor.c */, F96D42CE08F272B3004A47F5 /* bn_mp_zero.c */, F96D42D008F272B3004A47F5 /* bn_reverse.c */, F96D42D108F272B3004A47F5 /* bn_s_mp_add.c */, F96D42D308F272B3004A47F5 /* bn_s_mp_mul_digs.c */, @@ -1651,11 +1656,11 @@ F96D43D008F272B8004A47F5 /* tools */ = { isa = PBXGroup; children = ( F96D43D108F272B8004A47F5 /* checkLibraryDoc.tcl */, F96D43D208F272B8004A47F5 /* configure */, - F96D43D308F272B8004A47F5 /* configure.ac */, + F96D43D308F272B8004A47F5 /* configure.in */, F96D442408F272B8004A47F5 /* fix_tommath_h.tcl */, F96D442508F272B8004A47F5 /* genStubs.tcl */, F96D442708F272B8004A47F5 /* index.tcl */, F96D442808F272B8004A47F5 /* installData.tcl */, F96D442908F272B8004A47F5 /* loadICU.tcl */, @@ -1682,11 +1687,11 @@ F96D443E08F272B9004A47F5 /* unix */ = { isa = PBXGroup; children = ( F96D444008F272B9004A47F5 /* aclocal.m4 */, F96D444108F272B9004A47F5 /* configure */, - F96D444208F272B9004A47F5 /* configure.ac */, + F96D444208F272B9004A47F5 /* configure.in */, F96D444308F272B9004A47F5 /* dltest */, F96D444D08F272B9004A47F5 /* install-sh */, F96D444E08F272B9004A47F5 /* installManPage */, F96D444F08F272B9004A47F5 /* ldAix */, F96D445008F272B9004A47F5 /* Makefile.in */, @@ -1743,11 +1748,11 @@ F96D447008F272BA004A47F5 /* aclocal.m4 */, F96D447108F272BA004A47F5 /* buildall.vc.bat */, F96D447208F272BA004A47F5 /* cat.c */, F96D447308F272BA004A47F5 /* coffbase.txt */, F96D447408F272BA004A47F5 /* configure */, - F96D447508F272BA004A47F5 /* configure.ac */, + F96D447508F272BA004A47F5 /* configure.in */, F96D447708F272BA004A47F5 /* Makefile.in */, F96D447808F272BA004A47F5 /* makefile.vc */, F96D447908F272BA004A47F5 /* nmakehlp.c */, F96D447A08F272BA004A47F5 /* README */, F96D447C08F272BA004A47F5 /* rules.vc */, @@ -1902,11 +1907,11 @@ name = "Run Testsuite"; outputPaths = ( ); runOnlyForDeploymentPostprocessing = 0; shellPath = /bin/bash; - shellScript = "if [ \"${ACTION:-build}\" == \"build\" ]; then\nif [ -z \"${HOME}\" ]; then export HOME=\"$(echo ~)\"; fi\ncd \"${TARGET_TEMP_DIR}\"; rm -rf \"${DERIVED_FILE_DIR}\"; mkdir -p \"${DERIVED_FILE_DIR}\"\nprintf '%s%s%s%s%s' '\npackage require tcltest 2.2\nnamespace import tcltest::*\nconfigure -testdir [file normalize {' \"${TCL_SRCROOT}\" '/tests}]\nconfigure -tmpdir [file normalize {' \"${DERIVED_FILE_DIR}\" '}]\nconfigure -verbose [concat [configure -verbose] line]\nrunAllTests\n' | \"${TEST_RIG}\"; TEST_RIG_RESULT=$?\n[ ${TEST_RIG_RESULT} -ne 0 ] && echo \"tcltest:0: error: tcltest exited abnormally with code ${TEST_RIG_RESULT}.\"\nexit ${TEST_RIG_RESULT}\nfi"; + shellScript = "if [ \"${ACTION:-build}\" == \"build\" ]; then\nif [ -z \"${HOME}\" ]; then export HOME=\"$(echo ~)\"; fi\ncd \"${TARGET_TEMP_DIR}\"; rm -rf \"${DERIVED_FILE_DIR}\"; mkdir -p \"${DERIVED_FILE_DIR}\"\nprintf '%s%s%s%s%s' '\npackage require tcltest 2.5\nnamespace import tcltest::*\nconfigure -testdir [file normalize {' \"${TCL_SRCROOT}\" '/tests}]\nconfigure -tmpdir [file normalize {' \"${DERIVED_FILE_DIR}\" '}]\nconfigure -verbose [concat [configure -verbose] line]\nrunAllTests\n' | \"${TEST_RIG}\"; TEST_RIG_RESULT=$?\n[ ${TEST_RIG_RESULT} -ne 0 ] && echo \"tcltest:0: error: tcltest exited abnormally with code ${TEST_RIG_RESULT}.\"\nexit ${TEST_RIG_RESULT}\nfi"; showEnvVarsInLog = 0; }; F97AF02F0B665DA900310EA2 /* Build Tcl */ = { isa = PBXShellScriptBuildPhase; buildActionMask = 2147483647; @@ -1929,11 +1934,11 @@ buildActionMask = 2147483647; files = ( ); inputPaths = ( "$(TCL_SRCROOT)/macosx/configure.ac", - "$(TCL_SRCROOT)/unix/configure.ac", + "$(TCL_SRCROOT)/unix/configure.in", "$(TCL_SRCROOT)/unix/tcl.m4", "$(TCL_SRCROOT)/unix/aclocal.m4", "$(TCL_SRCROOT)/unix/tclConfig.sh.in", "$(TCL_SRCROOT)/unix/Makefile.in", "$(TCL_SRCROOT)/unix/dltest/Makefile.in", @@ -1942,11 +1947,11 @@ outputPaths = ( "$(DERIVED_FILE_DIR)/tcl/tclConfig.sh", ); runOnlyForDeploymentPostprocessing = 0; shellPath = /bin/bash; - shellScript = "## tcl configure shell script phase\n\ncd \"${TCL_SRCROOT}\"/macosx &&\nif [ configure.ac -nt configure -o ../unix/configure.ac -nt configure -o ../unix/tcl.m4 -nt configure -o ../unix/aclocal.m4 -nt configure ]; then\n echo \"Running autoconf & autoheader in tcl/macosx\"\n rm -rf autom4te.cache\n ${AUTOCONF:-${DEVELOPER_DIR}/usr/bin/autoconf} && ${AUTOHEADER:-${DEVELOPER_DIR}/usr/bin/autoheader} || exit $?\n rm -rf autom4te.cache\nfi\n\ncd \"${DERIVED_FILE_DIR}\" && mkdir -p tcl && cd tcl &&\nif [ \"${TCL_SRCROOT}\"/macosx/configure -nt config.status ]; then\n echo \"Configuring Tcl\"\n CC=$(xcrun -find ${GCC} || echo ${GCC})\n \"${TCL_SRCROOT}\"/macosx/configure --cache-file=../config.cache --prefix=${PREFIX} --bindir=${BINDIR} --libdir=${LIBDIR} --mandir=${MANDIR} --includedir=${INCLUDEDIR} --disable-shared CC=${CC} LD=${CC} ${CONFIGURE_ARGS}\nelse\n ./config.status\nfi\n"; + shellScript = "## tcl configure shell script phase\n\ncd \"${TCL_SRCROOT}\"/macosx &&\nif [ configure.ac -nt configure -o ../unix/configure.in -nt configure -o ../unix/tcl.m4 -nt configure -o ../unix/aclocal.m4 -nt configure ]; then\n echo \"Running autoconf & autoheader in tcl/macosx\"\n rm -rf autom4te.cache\n ${AUTOCONF:-${DEVELOPER_DIR}/usr/bin/autoconf} && ${AUTOHEADER:-${DEVELOPER_DIR}/usr/bin/autoheader} || exit $?\n rm -rf autom4te.cache\nfi\n\ncd \"${DERIVED_FILE_DIR}\" && mkdir -p tcl && cd tcl &&\nif [ \"${TCL_SRCROOT}\"/macosx/configure -nt config.status ]; then\n echo \"Configuring Tcl\"\n CC=$(xcrun -find ${GCC} || echo ${GCC})\n \"${TCL_SRCROOT}\"/macosx/configure --cache-file=../config.cache --prefix=${PREFIX} --bindir=${BINDIR} --libdir=${LIBDIR} --mandir=${MANDIR} --includedir=${INCLUDEDIR} --disable-shared CC=${CC} LD=${CC} ${CONFIGURE_ARGS}\nelse\n ./config.status\nfi\n"; showEnvVarsInLog = 0; }; /* End PBXShellScriptBuildPhase section */ /* Begin PBXSourcesBuildPhase section */ @@ -2057,12 +2062,11 @@ F96D48F508F272C3004A47F5 /* bn_mp_div_2.c in Sources */, F96D48F608F272C3004A47F5 /* bn_mp_div_2d.c in Sources */, F96D48F708F272C3004A47F5 /* bn_mp_div_3.c in Sources */, F96D48F808F272C3004A47F5 /* bn_mp_div_d.c in Sources */, F96D48FC08F272C3004A47F5 /* bn_mp_exch.c in Sources */, - F9E61D2C090A48AC002B3151 /* bn_mp_expt_d.c in Sources */, - F9E61D2C090A48AC002B3151 /* bn_mp_expt_d_ex.c in Sources */, + F9E61D2C090A48AC002B3151 /* bn_mp_expt_u32.c in Sources */, F96D490508F272C3004A47F5 /* bn_mp_grow.c in Sources */, F96D490608F272C3004A47F5 /* bn_mp_init.c in Sources */, F96D490708F272C3004A47F5 /* bn_mp_init_copy.c in Sources */, F96D490808F272C3004A47F5 /* bn_mp_init_multi.c in Sources */, F96D490908F272C3004A47F5 /* bn_mp_init_set.c in Sources */, @@ -2086,16 +2090,15 @@ F9E61D2F090A48C7002B3151 /* bn_mp_shrink.c in Sources */, F96D493C08F272C3004A47F5 /* bn_mp_sqr.c in Sources */, F9E61D2A090A4891002B3151 /* bn_mp_sqrt.c in Sources */, F96D493F08F272C3004A47F5 /* bn_mp_sub.c in Sources */, F96D494008F272C3004A47F5 /* bn_mp_sub_d.c in Sources */, - F9E61D30090A48E2002B3151 /* bn_mp_to_unsigned_bin_n.c in Sources */, - F9E61D31090A48F9002B3151 /* bn_mp_to_unsigned_bin.c in Sources */, + F9E61D31090A48F9002B3151 /* bn_mp_to_ubin.c in Sources */, F96D494608F272C3004A47F5 /* bn_mp_toom_mul.c in Sources */, F96D494708F272C3004A47F5 /* bn_mp_toom_sqr.c in Sources */, - F96D494908F272C3004A47F5 /* bn_mp_toradix_n.c in Sources */, - F9E61D32090A48FA002B3151 /* bn_mp_unsigned_bin_size.c in Sources */, + F96D494908F272C3004A47F5 /* bn_mp_to_radix.c in Sources */, + F9E61D32090A48FA002B3151 /* bn_mp_ubin_size.c in Sources */, F9E61D2D090A48BB002B3151 /* bn_mp_xor.c in Sources */, F96D494C08F272C3004A47F5 /* bn_mp_zero.c in Sources */, F96D494E08F272C3004A47F5 /* bn_reverse.c in Sources */, F96D494F08F272C3004A47F5 /* bn_s_mp_add.c in Sources */, F96D495108F272C3004A47F5 /* bn_s_mp_mul_digs.c in Sources */, Index: macosx/Tcl.xcodeproj/project.pbxproj ================================================================== --- macosx/Tcl.xcodeproj/project.pbxproj +++ macosx/Tcl.xcodeproj/project.pbxproj @@ -136,11 +136,11 @@ F96D493C08F272C3004A47F5 /* bn_mp_sqr.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42BE08F272B3004A47F5 /* bn_mp_sqr.c */; }; F96D493F08F272C3004A47F5 /* bn_mp_sub.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C108F272B3004A47F5 /* bn_mp_sub.c */; }; F96D494008F272C3004A47F5 /* bn_mp_sub_d.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C208F272B3004A47F5 /* bn_mp_sub_d.c */; }; F96D494608F272C3004A47F5 /* bn_mp_toom_mul.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C808F272B3004A47F5 /* bn_mp_toom_mul.c */; }; F96D494708F272C3004A47F5 /* bn_mp_toom_sqr.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C908F272B3004A47F5 /* bn_mp_toom_sqr.c */; }; - F96D494908F272C3004A47F5 /* bn_mp_toradix_n.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42CB08F272B3004A47F5 /* bn_mp_toradix_n.c */; }; + F96D494908F272C3004A47F5 /* bn_mp_to_radix.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42CB08F272B3004A47F5 /* bn_mp_to_radix.c */; }; F96D494C08F272C3004A47F5 /* bn_mp_zero.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42CE08F272B3004A47F5 /* bn_mp_zero.c */; }; F96D494E08F272C3004A47F5 /* bn_reverse.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D008F272B3004A47F5 /* bn_reverse.c */; }; F96D494F08F272C3004A47F5 /* bn_s_mp_add.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D108F272B3004A47F5 /* bn_s_mp_add.c */; }; F96D495108F272C3004A47F5 /* bn_s_mp_mul_digs.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D308F272B3004A47F5 /* bn_s_mp_mul_digs.c */; }; F96D495308F272C3004A47F5 /* bn_s_mp_sqr.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D508F272B3004A47F5 /* bn_s_mp_sqr.c */; }; @@ -162,18 +162,16 @@ F96D4AD608F272CA004A47F5 /* tclUnixTime.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D446B08F272B9004A47F5 /* tclUnixTime.c */; }; F9E61D28090A481F002B3151 /* bn_mp_cmp_d.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D427108F272B3004A47F5 /* bn_mp_cmp_d.c */; }; F9E61D29090A486C002B3151 /* bn_mp_neg.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42A208F272B3004A47F5 /* bn_mp_neg.c */; }; F9E61D2A090A4891002B3151 /* bn_mp_sqrt.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C008F272B3004A47F5 /* bn_mp_sqrt.c */; }; F9E61D2B090A48A4002B3151 /* bn_mp_and.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D426C08F272B3004A47F5 /* bn_mp_and.c */; }; - F9E61D2C090A48AC002B3151 /* bn_mp_expt_d.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D427F08F272B3004A47F5 /* bn_mp_expt_d_ex.c */; }; - F9E61D2C090A48AC002B3151 /* bn_mp_expt_d_ex.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D427F08F272B3004A47F5 /* bn_mp_expt_d.c */; }; + F9E61D2C090A48AC002B3151 /* bn_mp_expt_u32.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D427F08F272B3004A47F5 /* bn_mp_expt_u32.c */; }; F9E61D2D090A48BB002B3151 /* bn_mp_xor.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42CD08F272B3004A47F5 /* bn_mp_xor.c */; }; F9E61D2E090A48BF002B3151 /* bn_mp_or.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42A308F272B3004A47F5 /* bn_mp_or.c */; }; F9E61D2F090A48C7002B3151 /* bn_mp_shrink.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42BC08F272B3004A47F5 /* bn_mp_shrink.c */; }; - F9E61D30090A48E2002B3151 /* bn_mp_to_unsigned_bin_n.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C708F272B3004A47F5 /* bn_mp_to_unsigned_bin_n.c */; }; - F9E61D31090A48F9002B3151 /* bn_mp_to_unsigned_bin.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C608F272B3004A47F5 /* bn_mp_to_unsigned_bin.c */; }; - F9E61D32090A48FA002B3151 /* bn_mp_unsigned_bin_size.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42CC08F272B3004A47F5 /* bn_mp_unsigned_bin_size.c */; }; + F9E61D31090A48F9002B3151 /* bn_mp_to_ubin.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C608F272B3004A47F5 /* bn_mp_to_ubin.c */; }; + F9E61D32090A48FA002B3151 /* bn_mp_ubin_size.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42CC08F272B3004A47F5 /* bn_mp_ubin_size.c */; }; F9F4415E0C8BAE6F00BCCD67 /* tclDTrace.d in Sources */ = {isa = PBXBuildFile; fileRef = F9F4415D0C8BAE6F00BCCD67 /* tclDTrace.d */; }; F9FC77B80AB29E9100B7077D /* tclUnixCompat.c in Sources */ = {isa = PBXBuildFile; fileRef = F9FC77B70AB29E9100B7077D /* tclUnixCompat.c */; }; /* End PBXBuildFile section */ /* Begin PBXContainerItemProxy section */ @@ -263,11 +261,11 @@ F96D3E1D08F272A5004A47F5 /* CrtCommand.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtCommand.3; sourceTree = ""; }; F96D3E1E08F272A5004A47F5 /* CrtFileHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtFileHdlr.3; sourceTree = ""; }; F96D3E1F08F272A5004A47F5 /* CrtInterp.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtInterp.3; sourceTree = ""; }; F96D3E2008F272A5004A47F5 /* CrtMathFnc.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtMathFnc.3; sourceTree = ""; }; F96D3E2108F272A5004A47F5 /* CrtObjCmd.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtObjCmd.3; sourceTree = ""; }; - F96D3E2208F272A5004A47F5 /* CrtSlave.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtSlave.3; sourceTree = ""; }; + F96D3E2208F272A5004A47F5 /* CrtAlias.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtAlias.3; sourceTree = ""; }; F96D3E2308F272A5004A47F5 /* CrtTimerHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtTimerHdlr.3; sourceTree = ""; }; F96D3E2408F272A5004A47F5 /* CrtTrace.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtTrace.3; sourceTree = ""; }; F96D3E2508F272A5004A47F5 /* dde.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = dde.n; sourceTree = ""; }; F96D3E2608F272A5004A47F5 /* DetachPids.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = DetachPids.3; sourceTree = ""; }; F96D3E2708F272A5004A47F5 /* dict.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = dict.n; sourceTree = ""; }; @@ -576,12 +574,11 @@ F96D427708F272B3004A47F5 /* bn_mp_div_2.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_div_2.c; sourceTree = ""; }; F96D427808F272B3004A47F5 /* bn_mp_div_2d.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_div_2d.c; sourceTree = ""; }; F96D427908F272B3004A47F5 /* bn_mp_div_3.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_div_3.c; sourceTree = ""; }; F96D427A08F272B3004A47F5 /* bn_mp_div_d.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_div_d.c; sourceTree = ""; }; F96D427E08F272B3004A47F5 /* bn_mp_exch.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_exch.c; sourceTree = ""; }; - F96D427F08F272B3004A47F5 /* bn_mp_expt_d.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_expt_d.c; sourceTree = ""; }; - F96D427F08F272B3004A47F5 /* bn_mp_expt_d_ex.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_expt_d_ex.c; sourceTree = ""; }; + F96D427F08F272B3004A47F5 /* bn_mp_expt_u32.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_expt_u32.c; sourceTree = ""; }; F96D428708F272B3004A47F5 /* bn_mp_grow.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_grow.c; sourceTree = ""; }; F96D428808F272B3004A47F5 /* bn_mp_init.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_init.c; sourceTree = ""; }; F96D428908F272B3004A47F5 /* bn_mp_init_copy.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_init_copy.c; sourceTree = ""; }; F96D428A08F272B3004A47F5 /* bn_mp_init_multi.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_init_multi.c; sourceTree = ""; }; F96D428B08F272B3004A47F5 /* bn_mp_init_set.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_init_set.c; sourceTree = ""; }; @@ -605,16 +602,15 @@ F96D42BC08F272B3004A47F5 /* bn_mp_shrink.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_shrink.c; sourceTree = ""; }; F96D42BE08F272B3004A47F5 /* bn_mp_sqr.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_sqr.c; sourceTree = ""; }; F96D42C008F272B3004A47F5 /* bn_mp_sqrt.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_sqrt.c; sourceTree = ""; }; F96D42C108F272B3004A47F5 /* bn_mp_sub.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_sub.c; sourceTree = ""; }; F96D42C208F272B3004A47F5 /* bn_mp_sub_d.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_sub_d.c; sourceTree = ""; }; - F96D42C608F272B3004A47F5 /* bn_mp_to_unsigned_bin.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_to_unsigned_bin.c; sourceTree = ""; }; - F96D42C708F272B3004A47F5 /* bn_mp_to_unsigned_bin_n.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_to_unsigned_bin_n.c; sourceTree = ""; }; + F96D42C608F272B3004A47F5 /* bn_mp_to_ubin.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_to_ubin.c; sourceTree = ""; }; F96D42C808F272B3004A47F5 /* bn_mp_toom_mul.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_toom_mul.c; sourceTree = ""; }; F96D42C908F272B3004A47F5 /* bn_mp_toom_sqr.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_toom_sqr.c; sourceTree = ""; }; - F96D42CB08F272B3004A47F5 /* bn_mp_toradix_n.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_toradix_n.c; sourceTree = ""; }; - F96D42CC08F272B3004A47F5 /* bn_mp_unsigned_bin_size.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_unsigned_bin_size.c; sourceTree = ""; }; + F96D42CB08F272B3004A47F5 /* bn_mp_to_radix.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_to_radix.c; sourceTree = ""; }; + F96D42CC08F272B3004A47F5 /* bn_mp_ubin_size.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_ubin_size.c; sourceTree = ""; }; F96D42CD08F272B3004A47F5 /* bn_mp_xor.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_xor.c; sourceTree = ""; }; F96D42CE08F272B3004A47F5 /* bn_mp_zero.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_zero.c; sourceTree = ""; }; F96D42D008F272B3004A47F5 /* bn_reverse.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_reverse.c; sourceTree = ""; }; F96D42D108F272B3004A47F5 /* bn_s_mp_add.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_s_mp_add.c; sourceTree = ""; }; F96D42D308F272B3004A47F5 /* bn_s_mp_mul_digs.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_s_mp_mul_digs.c; sourceTree = ""; }; @@ -767,11 +763,11 @@ F96D43CD08F272B7004A47F5 /* winNotify.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = winNotify.test; sourceTree = ""; }; F96D43CE08F272B7004A47F5 /* winPipe.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = winPipe.test; sourceTree = ""; }; F96D43CF08F272B7004A47F5 /* winTime.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = winTime.test; sourceTree = ""; }; F96D43D108F272B8004A47F5 /* checkLibraryDoc.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = checkLibraryDoc.tcl; sourceTree = ""; }; F96D43D208F272B8004A47F5 /* configure */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text.script.sh; path = configure; sourceTree = ""; }; - F96D43D308F272B8004A47F5 /* configure.ac */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = configure.ac; sourceTree = ""; }; + F96D43D308F272B8004A47F5 /* configure.in */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = configure.in; sourceTree = ""; }; F96D442408F272B8004A47F5 /* fix_tommath_h.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = fix_tommath_h.tcl; sourceTree = ""; }; F96D442508F272B8004A47F5 /* genStubs.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = genStubs.tcl; sourceTree = ""; }; F96D442708F272B8004A47F5 /* index.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = index.tcl; sourceTree = ""; }; F96D442808F272B8004A47F5 /* installData.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = installData.tcl; sourceTree = ""; }; F96D442908F272B8004A47F5 /* loadICU.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = loadICU.tcl; sourceTree = ""; }; @@ -790,11 +786,11 @@ F96D443A08F272B9004A47F5 /* tclZIC.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = tclZIC.tcl; sourceTree = ""; }; F96D443B08F272B9004A47F5 /* uniClass.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = uniClass.tcl; sourceTree = ""; }; F96D443C08F272B9004A47F5 /* uniParse.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = uniParse.tcl; sourceTree = ""; }; F96D444008F272B9004A47F5 /* aclocal.m4 */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = aclocal.m4; sourceTree = ""; }; F96D444108F272B9004A47F5 /* configure */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text.script.sh; path = configure; sourceTree = ""; }; - F96D444208F272B9004A47F5 /* configure.ac */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = configure.ac; sourceTree = ""; }; + F96D444208F272B9004A47F5 /* configure.in */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = configure.in; sourceTree = ""; }; F96D444408F272B9004A47F5 /* Makefile.in */ = {isa = PBXFileReference; explicitFileType = sourcecode.make; fileEncoding = 4; path = Makefile.in; sourceTree = ""; }; F96D444508F272B9004A47F5 /* pkga.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = pkga.c; sourceTree = ""; }; F96D444608F272B9004A47F5 /* pkgb.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = pkgb.c; sourceTree = ""; }; F96D444708F272B9004A47F5 /* pkgc.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = pkgc.c; sourceTree = ""; }; F96D444808F272B9004A47F5 /* pkgd.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = pkgd.c; sourceTree = ""; }; @@ -834,11 +830,11 @@ F96D447008F272BA004A47F5 /* aclocal.m4 */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = aclocal.m4; sourceTree = ""; }; F96D447108F272BA004A47F5 /* buildall.vc.bat */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = buildall.vc.bat; sourceTree = ""; }; F96D447208F272BA004A47F5 /* cat.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = cat.c; sourceTree = ""; }; F96D447308F272BA004A47F5 /* coffbase.txt */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = coffbase.txt; sourceTree = ""; }; F96D447408F272BA004A47F5 /* configure */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text.script.sh; path = configure; sourceTree = ""; }; - F96D447508F272BA004A47F5 /* configure.ac */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = configure.ac; sourceTree = ""; }; + F96D447508F272BA004A47F5 /* configure.in */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = configure.in; sourceTree = ""; }; F96D447708F272BA004A47F5 /* Makefile.in */ = {isa = PBXFileReference; explicitFileType = sourcecode.make; fileEncoding = 4; path = Makefile.in; sourceTree = ""; }; F96D447808F272BA004A47F5 /* makefile.vc */ = {isa = PBXFileReference; explicitFileType = sourcecode.make; fileEncoding = 4; path = makefile.vc; sourceTree = ""; }; F96D447908F272BA004A47F5 /* nmakehlp.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = nmakehlp.c; sourceTree = ""; }; F96D447A08F272BA004A47F5 /* README */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = README; sourceTree = ""; }; F96D447C08F272BA004A47F5 /* rules.vc */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = rules.vc; sourceTree = ""; }; @@ -1015,11 +1011,11 @@ F96D3E1D08F272A5004A47F5 /* CrtCommand.3 */, F96D3E1E08F272A5004A47F5 /* CrtFileHdlr.3 */, F96D3E1F08F272A5004A47F5 /* CrtInterp.3 */, F96D3E2008F272A5004A47F5 /* CrtMathFnc.3 */, F96D3E2108F272A5004A47F5 /* CrtObjCmd.3 */, - F96D3E2208F272A5004A47F5 /* CrtSlave.3 */, + F96D3E2208F272A5004A47F5 /* CrtAlias.3 */, F96D3E2308F272A5004A47F5 /* CrtTimerHdlr.3 */, F96D3E2408F272A5004A47F5 /* CrtTrace.3 */, F96D3E2508F272A5004A47F5 /* dde.n */, F93599D30DF1F8F500E04F67 /* define.n */, F96D3E2608F272A5004A47F5 /* DetachPids.3 */, @@ -1337,10 +1333,11 @@ F96D3F3908F272A8004A47F5 /* auto.tcl */, F96D3F3A08F272A8004A47F5 /* clock.tcl */, F96D3F3B08F272A8004A47F5 /* dde */, F96D3F8C08F272A8004A47F5 /* history.tcl */, F96D3F8D08F272A8004A47F5 /* http */, + F96D3F9008F272A8004A47F5 /* http1.0 */, F96D3F9308F272A8004A47F5 /* init.tcl */, F96D3F9408F272A8004A47F5 /* msgcat */, F96D401708F272AA004A47F5 /* opt */, F96D401A08F272AA004A47F5 /* package.tcl */, F96D401B08F272AA004A47F5 /* parray.tcl */, @@ -1369,10 +1366,19 @@ F96D3F8E08F272A8004A47F5 /* http.tcl */, F96D3F8F08F272A8004A47F5 /* pkgIndex.tcl */, ); path = http; sourceTree = ""; + }; + F96D3F9008F272A8004A47F5 /* http1.0 */ = { + isa = PBXGroup; + children = ( + F96D3F9108F272A8004A47F5 /* http.tcl */, + F96D3F9208F272A8004A47F5 /* pkgIndex.tcl */, + ); + path = http1.0; + sourceTree = ""; }; F96D3F9408F272A8004A47F5 /* msgcat */ = { isa = PBXGroup; children = ( F96D3F9508F272A8004A47F5 /* msgcat.tcl */, @@ -1427,12 +1433,11 @@ F96D427708F272B3004A47F5 /* bn_mp_div_2.c */, F96D427808F272B3004A47F5 /* bn_mp_div_2d.c */, F96D427908F272B3004A47F5 /* bn_mp_div_3.c */, F96D427A08F272B3004A47F5 /* bn_mp_div_d.c */, F96D427E08F272B3004A47F5 /* bn_mp_exch.c */, - F96D427F08F272B3004A47F5 /* bn_mp_expt_d.c */, - F96D427F08F272B3004A47F5 /* bn_mp_expt_d_ex.c */, + F96D427F08F272B3004A47F5 /* bn_mp_expt_u32.c */, F96D428708F272B3004A47F5 /* bn_mp_grow.c */, F96D428808F272B3004A47F5 /* bn_mp_init.c */, F96D428908F272B3004A47F5 /* bn_mp_init_copy.c */, F96D428A08F272B3004A47F5 /* bn_mp_init_multi.c */, F96D428B08F272B3004A47F5 /* bn_mp_init_set.c */, @@ -1456,16 +1461,15 @@ F96D42BC08F272B3004A47F5 /* bn_mp_shrink.c */, F96D42BE08F272B3004A47F5 /* bn_mp_sqr.c */, F96D42C008F272B3004A47F5 /* bn_mp_sqrt.c */, F96D42C108F272B3004A47F5 /* bn_mp_sub.c */, F96D42C208F272B3004A47F5 /* bn_mp_sub_d.c */, - F96D42C608F272B3004A47F5 /* bn_mp_to_unsigned_bin.c */, - F96D42C708F272B3004A47F5 /* bn_mp_to_unsigned_bin_n.c */, + F96D42C608F272B3004A47F5 /* bn_mp_to_ubin.c */, F96D42C808F272B3004A47F5 /* bn_mp_toom_mul.c */, F96D42C908F272B3004A47F5 /* bn_mp_toom_sqr.c */, - F96D42CB08F272B3004A47F5 /* bn_mp_toradix_n.c */, - F96D42CC08F272B3004A47F5 /* bn_mp_unsigned_bin_size.c */, + F96D42CB08F272B3004A47F5 /* bn_mp_to_radix.c */, + F96D42CC08F272B3004A47F5 /* bn_mp_ubin_size.c */, F96D42CD08F272B3004A47F5 /* bn_mp_xor.c */, F96D42CE08F272B3004A47F5 /* bn_mp_zero.c */, F96D42D008F272B3004A47F5 /* bn_reverse.c */, F96D42D108F272B3004A47F5 /* bn_s_mp_add.c */, F96D42D308F272B3004A47F5 /* bn_s_mp_mul_digs.c */, @@ -1652,11 +1656,11 @@ F96D43D008F272B8004A47F5 /* tools */ = { isa = PBXGroup; children = ( F96D43D108F272B8004A47F5 /* checkLibraryDoc.tcl */, F96D43D208F272B8004A47F5 /* configure */, - F96D43D308F272B8004A47F5 /* configure.ac */, + F96D43D308F272B8004A47F5 /* configure.in */, F96D442408F272B8004A47F5 /* fix_tommath_h.tcl */, F96D442508F272B8004A47F5 /* genStubs.tcl */, F96D442708F272B8004A47F5 /* index.tcl */, F96D442808F272B8004A47F5 /* installData.tcl */, F96D442908F272B8004A47F5 /* loadICU.tcl */, @@ -1683,11 +1687,11 @@ F96D443E08F272B9004A47F5 /* unix */ = { isa = PBXGroup; children = ( F96D444008F272B9004A47F5 /* aclocal.m4 */, F96D444108F272B9004A47F5 /* configure */, - F96D444208F272B9004A47F5 /* configure.ac */, + F96D444208F272B9004A47F5 /* configure.in */, F96D444308F272B9004A47F5 /* dltest */, F96D444D08F272B9004A47F5 /* install-sh */, F96D444E08F272B9004A47F5 /* installManPage */, F96D444F08F272B9004A47F5 /* ldAix */, F96D445008F272B9004A47F5 /* Makefile.in */, @@ -1744,11 +1748,11 @@ F96D447008F272BA004A47F5 /* aclocal.m4 */, F96D447108F272BA004A47F5 /* buildall.vc.bat */, F96D447208F272BA004A47F5 /* cat.c */, F96D447308F272BA004A47F5 /* coffbase.txt */, F96D447408F272BA004A47F5 /* configure */, - F96D447508F272BA004A47F5 /* configure.ac */, + F96D447508F272BA004A47F5 /* configure.in */, F96D447708F272BA004A47F5 /* Makefile.in */, F96D447808F272BA004A47F5 /* makefile.vc */, F96D447908F272BA004A47F5 /* nmakehlp.c */, F96D447A08F272BA004A47F5 /* README */, F96D447C08F272BA004A47F5 /* rules.vc */, @@ -1903,11 +1907,11 @@ name = "Run Testsuite"; outputPaths = ( ); runOnlyForDeploymentPostprocessing = 0; shellPath = /bin/bash; - shellScript = "if [ \"${ACTION:-build}\" == \"build\" ]; then\nif [ -z \"${HOME}\" ]; then export HOME=\"$(echo ~)\"; fi\ncd \"${TARGET_TEMP_DIR}\"; rm -rf \"${DERIVED_FILE_DIR}\"; mkdir -p \"${DERIVED_FILE_DIR}\"\nprintf '%s%s%s%s%s' '\npackage require tcltest 2.2\nnamespace import tcltest::*\nconfigure -testdir [file normalize {' \"${TCL_SRCROOT}\" '/tests}]\nconfigure -tmpdir [file normalize {' \"${DERIVED_FILE_DIR}\" '}]\nconfigure -verbose [concat [configure -verbose] line]\nrunAllTests\n' | \"${TEST_RIG}\"; TEST_RIG_RESULT=$?\n[ ${TEST_RIG_RESULT} -ne 0 ] && echo \"tcltest:0: error: tcltest exited abnormally with code ${TEST_RIG_RESULT}.\"\nexit ${TEST_RIG_RESULT}\nfi"; + shellScript = "if [ \"${ACTION:-build}\" == \"build\" ]; then\nif [ -z \"${HOME}\" ]; then export HOME=\"$(echo ~)\"; fi\ncd \"${TARGET_TEMP_DIR}\"; rm -rf \"${DERIVED_FILE_DIR}\"; mkdir -p \"${DERIVED_FILE_DIR}\"\nprintf '%s%s%s%s%s' '\npackage require tcltest 2.5\nnamespace import tcltest::*\nconfigure -testdir [file normalize {' \"${TCL_SRCROOT}\" '/tests}]\nconfigure -tmpdir [file normalize {' \"${DERIVED_FILE_DIR}\" '}]\nconfigure -verbose [concat [configure -verbose] line]\nrunAllTests\n' | \"${TEST_RIG}\"; TEST_RIG_RESULT=$?\n[ ${TEST_RIG_RESULT} -ne 0 ] && echo \"tcltest:0: error: tcltest exited abnormally with code ${TEST_RIG_RESULT}.\"\nexit ${TEST_RIG_RESULT}\nfi"; showEnvVarsInLog = 0; }; F97AF02F0B665DA900310EA2 /* Build Tcl */ = { isa = PBXShellScriptBuildPhase; buildActionMask = 2147483647; @@ -1930,11 +1934,11 @@ buildActionMask = 2147483647; files = ( ); inputPaths = ( "$(TCL_SRCROOT)/macosx/configure.ac", - "$(TCL_SRCROOT)/unix/configure.ac", + "$(TCL_SRCROOT)/unix/configure.in", "$(TCL_SRCROOT)/unix/tcl.m4", "$(TCL_SRCROOT)/unix/aclocal.m4", "$(TCL_SRCROOT)/unix/tclConfig.sh.in", "$(TCL_SRCROOT)/unix/Makefile.in", "$(TCL_SRCROOT)/unix/dltest/Makefile.in", @@ -1943,11 +1947,11 @@ outputPaths = ( "$(DERIVED_FILE_DIR)/tcl/tclConfig.sh", ); runOnlyForDeploymentPostprocessing = 0; shellPath = /bin/bash; - shellScript = "## tcl configure shell script phase\n\ncd \"${TCL_SRCROOT}\"/macosx &&\nif [ configure.ac -nt configure -o ../unix/configure.ac -nt configure -o ../unix/tcl.m4 -nt configure -o ../unix/aclocal.m4 -nt configure ]; then\n echo \"Running autoconf & autoheader in tcl/macosx\"\n rm -rf autom4te.cache\n ${AUTOCONF:-${DEVELOPER_DIR}/usr/bin/autoconf} && ${AUTOHEADER:-${DEVELOPER_DIR}/usr/bin/autoheader} || exit $?\n rm -rf autom4te.cache\nfi\n\ncd \"${DERIVED_FILE_DIR}\" && mkdir -p tcl && cd tcl &&\nif [ \"${TCL_SRCROOT}\"/macosx/configure -nt config.status ]; then\n echo \"Configuring Tcl\"\n CC=$(xcrun -find ${GCC} || echo ${GCC})\n \"${TCL_SRCROOT}\"/macosx/configure --cache-file=../config.cache --prefix=${PREFIX} --bindir=${BINDIR} --libdir=${LIBDIR} --mandir=${MANDIR} --includedir=${INCLUDEDIR} --disable-shared CC=${CC} LD=${CC} ${CONFIGURE_ARGS}\nelse\n ./config.status\nfi\n"; + shellScript = "## tcl configure shell script phase\n\ncd \"${TCL_SRCROOT}\"/macosx &&\nif [ configure.ac -nt configure -o ../unix/configure.in -nt configure -o ../unix/tcl.m4 -nt configure -o ../unix/aclocal.m4 -nt configure ]; then\n echo \"Running autoconf & autoheader in tcl/macosx\"\n rm -rf autom4te.cache\n ${AUTOCONF:-${DEVELOPER_DIR}/usr/bin/autoconf} && ${AUTOHEADER:-${DEVELOPER_DIR}/usr/bin/autoheader} || exit $?\n rm -rf autom4te.cache\nfi\n\ncd \"${DERIVED_FILE_DIR}\" && mkdir -p tcl && cd tcl &&\nif [ \"${TCL_SRCROOT}\"/macosx/configure -nt config.status ]; then\n echo \"Configuring Tcl\"\n CC=$(xcrun -find ${GCC} || echo ${GCC})\n \"${TCL_SRCROOT}\"/macosx/configure --cache-file=../config.cache --prefix=${PREFIX} --bindir=${BINDIR} --libdir=${LIBDIR} --mandir=${MANDIR} --includedir=${INCLUDEDIR} --disable-shared CC=${CC} LD=${CC} ${CONFIGURE_ARGS}\nelse\n ./config.status\nfi\n"; showEnvVarsInLog = 0; }; /* End PBXShellScriptBuildPhase section */ /* Begin PBXSourcesBuildPhase section */ @@ -2058,12 +2062,11 @@ F96D48F508F272C3004A47F5 /* bn_mp_div_2.c in Sources */, F96D48F608F272C3004A47F5 /* bn_mp_div_2d.c in Sources */, F96D48F708F272C3004A47F5 /* bn_mp_div_3.c in Sources */, F96D48F808F272C3004A47F5 /* bn_mp_div_d.c in Sources */, F96D48FC08F272C3004A47F5 /* bn_mp_exch.c in Sources */, - F9E61D2C090A48AC002B3151 /* bn_mp_expt_d.c in Sources */, - F9E61D2C090A48AC002B3151 /* bn_mp_expt_d_ex.c in Sources */, + F9E61D2C090A48AC002B3151 /* bn_mp_expt_u32.c in Sources */, F96D490508F272C3004A47F5 /* bn_mp_grow.c in Sources */, F96D490608F272C3004A47F5 /* bn_mp_init.c in Sources */, F96D490708F272C3004A47F5 /* bn_mp_init_copy.c in Sources */, F96D490808F272C3004A47F5 /* bn_mp_init_multi.c in Sources */, F96D490908F272C3004A47F5 /* bn_mp_init_set.c in Sources */, @@ -2087,16 +2090,15 @@ F9E61D2F090A48C7002B3151 /* bn_mp_shrink.c in Sources */, F96D493C08F272C3004A47F5 /* bn_mp_sqr.c in Sources */, F9E61D2A090A4891002B3151 /* bn_mp_sqrt.c in Sources */, F96D493F08F272C3004A47F5 /* bn_mp_sub.c in Sources */, F96D494008F272C3004A47F5 /* bn_mp_sub_d.c in Sources */, - F9E61D30090A48E2002B3151 /* bn_mp_to_unsigned_bin_n.c in Sources */, - F9E61D31090A48F9002B3151 /* bn_mp_to_unsigned_bin.c in Sources */, + F9E61D31090A48F9002B3151 /* bn_mp_to_ubin.c in Sources */, F96D494608F272C3004A47F5 /* bn_mp_toom_mul.c in Sources */, F96D494708F272C3004A47F5 /* bn_mp_toom_sqr.c in Sources */, - F96D494908F272C3004A47F5 /* bn_mp_toradix_n.c in Sources */, - F9E61D32090A48FA002B3151 /* bn_mp_unsigned_bin_size.c in Sources */, + F96D494908F272C3004A47F5 /* bn_mp_to_radix.c in Sources */, + F9E61D32090A48FA002B3151 /* bn_mp_ubin_size.c in Sources */, F9E61D2D090A48BB002B3151 /* bn_mp_xor.c in Sources */, F96D494C08F272C3004A47F5 /* bn_mp_zero.c in Sources */, F96D494E08F272C3004A47F5 /* bn_reverse.c in Sources */, F96D494F08F272C3004A47F5 /* bn_s_mp_add.c in Sources */, F96D495108F272C3004A47F5 /* bn_s_mp_mul_digs.c in Sources */, Index: macosx/configure.ac ================================================================== --- macosx/configure.ac +++ macosx/configure.ac @@ -6,6 +6,6 @@ dnl Ensure that the config (auto)headers support is used, then just dnl include the configure sources from ../unix: m4_include(../unix/aclocal.m4) m4_define(SC_USE_CONFIG_HEADERS) -m4_include(../unix/configure.ac) +m4_include(../unix/configure.in) Index: macosx/tclMacOSXBundle.c ================================================================== --- macosx/tclMacOSXBundle.c +++ macosx/tclMacOSXBundle.c @@ -104,11 +104,11 @@ #if TCL_DYLD_USE_DLFCN #if MAC_OS_X_VERSION_MIN_REQUIRED < 1040 if (tclMacOSXDarwinRelease >= 8) #endif { - openresourcemap = dlsym(RTLD_NEXT, + openresourcemap = (short (*)(CFBundleRef))dlsym(RTLD_NEXT, "CFBundleOpenBundleResourceMap"); #ifdef TCL_DEBUG_LOAD if (!openresourcemap) { const char *errMsg = dlerror(); @@ -160,16 +160,17 @@ * libraryVariableName may be set, and the resource file opened. * *---------------------------------------------------------------------- */ +#undef Tcl_MacOSXOpenBundleResources int Tcl_MacOSXOpenBundleResources( Tcl_Interp *interp, const char *bundleName, int hasResourceFile, - size_t maxPathLen, + int maxPathLen, char *libraryPath) { return Tcl_MacOSXOpenVersionedBundleResources(interp, bundleName, NULL, hasResourceFile, maxPathLen, libraryPath); } @@ -199,11 +200,11 @@ Tcl_MacOSXOpenVersionedBundleResources( Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, - size_t maxPathLen, + int maxPathLen, char *libraryPath) { #ifdef HAVE_COREFOUNDATION CFBundleRef bundleRef, versionedBundleRef = NULL; CFStringRef bundleNameRef; Index: macosx/tclMacOSXFCmd.c ================================================================== --- macosx/tclMacOSXFCmd.c +++ macosx/tclMacOSXFCmd.c @@ -170,11 +170,11 @@ if (objIndex == MACOSX_RSRCLENGTH_ATTRIBUTE) { alist.fileattr = ATTR_FILE_RSRCLENGTH; } else { alist.commonattr = ATTR_CMN_FNDRINFO; } - native = Tcl_FSGetNativePath(fileName); + native = (const char *)Tcl_FSGetNativePath(fileName); result = getattrlist(native, &alist, &finfo, sizeof(fileinfobuf), 0); if (result != 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "could not read attributes of \"%s\": %s", @@ -190,11 +190,11 @@ case MACOSX_TYPE_ATTRIBUTE: *attributePtrPtr = NewOSTypeObj( OSSwapBigToHostInt32(finder->type)); break; case MACOSX_HIDDEN_ATTRIBUTE: - *attributePtrPtr = Tcl_NewWideIntObj( + *attributePtrPtr = Tcl_NewBooleanObj( (finder->fdFlags & kFinfoIsInvisible) != 0); break; case MACOSX_RSRCLENGTH_ATTRIBUTE: *attributePtrPtr = Tcl_NewWideIntObj(*rsrcForkSize); break; @@ -266,11 +266,11 @@ if (objIndex == MACOSX_RSRCLENGTH_ATTRIBUTE) { alist.fileattr = ATTR_FILE_RSRCLENGTH; } else { alist.commonattr = ATTR_CMN_FNDRINFO; } - native = Tcl_FSGetNativePath(fileName); + native = (const char *)Tcl_FSGetNativePath(fileName); result = getattrlist(native, &alist, &finfo, sizeof(fileinfobuf), 0); if (result != 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "could not read attributes of \"%s\": %s", @@ -345,11 +345,11 @@ Tcl_DStringInit(&ds); Tcl_DStringAppend(&ds, native, -1); Tcl_DStringAppend(&ds, _PATH_RSRCFORKSPEC, -1); - result = truncate(Tcl_DStringValue(&ds), (off_t)0); + result = truncate(Tcl_DStringValue(&ds), 0); if (result != 0) { /* * truncate() on a valid resource fork path may fail with a * permission error in some OS releases, try truncating with * open() instead: @@ -575,14 +575,14 @@ Tcl_Obj *objPtr, /* The object from which to get an OSType. */ OSType *osTypePtr) /* Place to store resulting OSType. */ { int result = TCL_OK; - if (!TclHasIntRep(objPtr, &tclOSTypeType)) { + if (objPtr->typePtr != &tclOSTypeType) { result = SetOSTypeFromAny(interp, objPtr); } - *osTypePtr = (OSType) objPtr->internalRep.wideValue; + *osTypePtr = (OSType) objPtr->internalRep.longValue; return result; } /* *---------------------------------------------------------------------- @@ -607,11 +607,11 @@ { Tcl_Obj *objPtr; TclNewObj(objPtr); TclInvalidateStringRep(objPtr); - objPtr->internalRep.wideValue = (Tcl_WideInt) osType; + objPtr->internalRep.longValue = (long) osType; objPtr->typePtr = &tclOSTypeType; return objPtr; } /* @@ -634,16 +634,15 @@ SetOSTypeFromAny( Tcl_Interp *interp, /* Tcl interpreter */ Tcl_Obj *objPtr) /* Pointer to the object to convert */ { const char *string; - int result = TCL_OK; + int length, result = TCL_OK; Tcl_DString ds; Tcl_Encoding encoding = Tcl_GetEncoding(NULL, "macRoman"); - size_t length; - string = TclGetStringFromObj(objPtr, &length); + string = Tcl_GetStringFromObj(objPtr, &length); Tcl_UtfToExternalDString(encoding, string, length, &ds); if (Tcl_DStringLength(&ds) > 4) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -659,11 +658,11 @@ osType = (OSType) bytes[0] << 24 | (OSType) bytes[1] << 16 | (OSType) bytes[2] << 8 | (OSType) bytes[3]; TclFreeIntRep(objPtr); - objPtr->internalRep.wideValue = (Tcl_WideInt) osType; + objPtr->internalRep.longValue = (long) osType; objPtr->typePtr = &tclOSTypeType; } Tcl_DStringFree(&ds); Tcl_FreeEncoding(encoding); return result; @@ -688,39 +687,35 @@ *---------------------------------------------------------------------- */ static void UpdateStringOfOSType( - register Tcl_Obj *objPtr) /* OSType object whose string rep to + Tcl_Obj *objPtr) /* OSType object whose string rep to * update. */ { - const int size = TCL_UTF_MAX * 4; - char *dst = Tcl_InitStringRep(objPtr, NULL, size); - OSType osType = (OSType) objPtr->internalRep.wideValue; - int written = 0; - Tcl_Encoding encoding; - char src[5]; - - TclOOM(dst, size); - - src[0] = (char) (osType >> 24); - src[1] = (char) (osType >> 16); - src[2] = (char) (osType >> 8); - src[3] = (char) (osType); - src[4] = '\0'; - - encoding = Tcl_GetEncoding(NULL, "macRoman"); - Tcl_ExternalToUtf(NULL, encoding, src, -1, /* flags */ 0, - /* statePtr */ NULL, dst, size, /* srcReadPtr */ NULL, - /* dstWrotePtr */ &written, /* dstCharsPtr */ NULL); - Tcl_FreeEncoding(encoding); - - (void)Tcl_InitStringRep(objPtr, NULL, written); + char string[5]; + OSType osType = (OSType) objPtr->internalRep.longValue; + Tcl_DString ds; + Tcl_Encoding encoding = Tcl_GetEncoding(NULL, "macRoman"); + unsigned len; + + string[0] = (char) (osType >> 24); + string[1] = (char) (osType >> 16); + string[2] = (char) (osType >> 8); + string[3] = (char) (osType); + string[4] = '\0'; + Tcl_ExternalToUtfDString(encoding, string, -1, &ds); + len = (unsigned) Tcl_DStringLength(&ds) + 1; + objPtr->bytes = ckalloc(len); + memcpy(objPtr->bytes, Tcl_DStringValue(&ds), len); + objPtr->length = Tcl_DStringLength(&ds); + Tcl_DStringFree(&ds); + Tcl_FreeEncoding(encoding); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: macosx/tclMacOSXNotify.c ================================================================== --- macosx/tclMacOSXNotify.c +++ macosx/tclMacOSXNotify.c @@ -12,16 +12,30 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" + +/* + * In macOS 10.12 the os_unfair_lock was introduced as a replacement for the + * OSSpinLock, and the OSSpinLock was deprecated. + */ + +#if MAC_OS_X_VERSION_MIN_REQUIRED >= 101200 +#define USE_OS_UNFAIR_LOCK +#include +#undef TCL_MAC_DEBUG_NOTIFIER +#endif + #ifdef HAVE_COREFOUNDATION /* Traditional unix select-based notifier is * in tclUnixNotfy.c */ #include #include /* #define TCL_MAC_DEBUG_NOTIFIER 1 */ + +#if !defined(USE_OS_UNFAIR_LOCK) /* * We use the Darwin-native spinlock API rather than pthread mutexes for * notifier locking: this radically simplifies the implementation and lowers * overhead. Note that these are not pure spinlocks, they employ various @@ -81,119 +95,75 @@ lockTry = OSSpinLockTry != NULL ? OSSpinLockTry : _spin_lock_try; if (lockLock == NULL || lockUnlock == NULL) { Tcl_Panic("SpinLockLockInit: no spinlock API available"); } } - -/* - * Wrappers so that we get warnings in just one small part of this file. - */ - -static inline void -SpinLockLock( - VOLATILE OSSpinLock *lock) -{ - lockLock(lock); -} -static inline void -SpinLockUnlock( - VOLATILE OSSpinLock *lock) -{ - lockUnlock(lock); -} -static inline bool -SpinLockTry( - VOLATILE OSSpinLock *lock) -{ - return lockTry(lock); -} - -#else /* !HAVE_WEAK_IMPORT */ - -/* - * Wrappers so that we get warnings in just one small part of this file. - */ - -static inline void -SpinLockLock( - OSSpinLock *lock) -{ - OSSpinLockLock(lock); -} -static inline void -SpinLockUnlock( - OSSpinLock *lock) -{ - OSSpinLockUnlock(lock); -} -static inline bool -SpinLockTry( - OSSpinLock *lock) -{ - return OSSpinLockTry(lock); -} +#define SpinLockLock(p) lockLock(p) +#define SpinLockUnlock(p) lockUnlock(p) +#define SpinLockTry(p) lockTry(p) +#else +#define SpinLockLock(p) OSSpinLockLock(p) +#define SpinLockUnlock(p) OSSpinLockUnlock(p) +#define SpinLockTry(p) OSSpinLockTry(p) #endif /* HAVE_WEAK_IMPORT */ #define SPINLOCK_INIT OS_SPINLOCK_INIT #else /* * Otherwise, use commpage spinlock SPI directly. */ typedef uint32_t OSSpinLock; - -static inline void -SpinLockLock( - OSSpinLock *lock) -{ - extern void _spin_lock(OSSpinLock *lock); - - _spin_lock(lock); -} - -static inline void -SpinLockUnlock( - OSSpinLock *lock) -{ - extern void _spin_unlock(OSSpinLock *lock); - - _spin_unlock(lock); -} - -static inline int -SpinLockTry( - OSSpinLock *lock) -{ - extern int _spin_lock_try(OSSpinLock *lock); - - return _spin_lock_try(lock); -} - +extern void _spin_lock(OSSpinLock *lock); +extern void _spin_unlock(OSSpinLock *lock); +extern int _spin_lock_try(OSSpinLock *lock); +#define SpinLockLock(p) _spin_lock(p) +#define SpinLockUnlock(p) _spin_unlock(p) +#define SpinLockTry(p) _spin_lock_try(p) #define SPINLOCK_INIT 0 #pragma GCC diagnostic pop #endif /* HAVE_LIBKERN_OSATOMIC_H && HAVE_OSSPINLOCKLOCK */ +#endif /* not using os_unfair_lock */ /* - * These spinlocks lock access to the global notifier state. + * These locks control access to the global notifier state. */ +#if defined(USE_OS_UNFAIR_LOCK) +static os_unfair_lock notifierInitLock = OS_UNFAIR_LOCK_INIT; +static os_unfair_lock notifierLock = OS_UNFAIR_LOCK_INIT; +#else static OSSpinLock notifierInitLock = SPINLOCK_INIT; static OSSpinLock notifierLock = SPINLOCK_INIT; +#endif /* - * Macros abstracting notifier locking/unlocking + * Macros that abstract notifier locking/unlocking */ +#if defined(USE_OS_UNFAIR_LOCK) +#define LOCK_NOTIFIER_INIT os_unfair_lock_lock(¬ifierInitLock) +#define UNLOCK_NOTIFIER_INIT os_unfair_lock_unlock(¬ifierInitLock) +#define LOCK_NOTIFIER os_unfair_lock_lock(¬ifierLock) +#define UNLOCK_NOTIFIER os_unfair_lock_unlock(¬ifierLock) +#define LOCK_NOTIFIER_TSD os_unfair_lock_lock(&tsdPtr->tsdLock) +#define UNLOCK_NOTIFIER_TSD os_unfair_lock_unlock(&tsdPtr->tsdLock) +#else #define LOCK_NOTIFIER_INIT SpinLockLock(¬ifierInitLock) #define UNLOCK_NOTIFIER_INIT SpinLockUnlock(¬ifierInitLock) #define LOCK_NOTIFIER SpinLockLock(¬ifierLock) #define UNLOCK_NOTIFIER SpinLockUnlock(¬ifierLock) #define LOCK_NOTIFIER_TSD SpinLockLock(&tsdPtr->tsdLock) #define UNLOCK_NOTIFIER_TSD SpinLockUnlock(&tsdPtr->tsdLock) +#endif -#ifdef TCL_MAC_DEBUG_NOTIFIER +/* + * The debug version of the Notifier only works if using OSSpinLock. + */ + +#if defined(TCL_MAC_DEBUG_NOTIFIER) && !defined(USE_OS_UNFAIR_LOCK) #define TclMacOSXNotifierDbgMsg(m, ...) \ do { \ fprintf(notifierLog?notifierLog:stderr, "tclMacOSXNotify.c:%d: " \ "%s() pid %5d thread %10p: " m "\n", __LINE__, __func__, \ getpid(), pthread_self(), ##__VA_ARGS__); \ @@ -216,11 +186,11 @@ #undef LOCK_NOTIFIER_INIT #define LOCK_NOTIFIER_INIT SpinLockLockDbg(¬ifierInitLock) #undef LOCK_NOTIFIER #define LOCK_NOTIFIER SpinLockLockDbg(¬ifierLock) #undef LOCK_NOTIFIER_TSD -#define LOCK_NOTIFIER_TSD SpinLockLockDbg(&tsdPtr->tsdLock) +#define LOCK_NOTIFIER_TSD SpinLockLockDbg(tsdPtr->tsdLock) #include static FILE *notifierLog = NULL; #ifndef NOTIFIER_LOG #define NOTIFIER_LOG "/tmp/tclMacOSXNotify.log" #endif @@ -323,12 +293,10 @@ int runLoopSourcePerformed; /* True after the runLoopSource callack was * performed. */ int runLoopRunning; /* True if this thread's Tcl runLoop is * running. */ int runLoopNestingLevel; /* Level of nested runLoop invocations. */ - int runLoopServicingEvents; /* True if this thread's runLoop is servicing - * Tcl events. */ /* Must hold the notifierLock before accessing the following fields: */ /* Start notifierLock section */ int onList; /* True if this thread is on the * waitingList */ @@ -337,13 +305,18 @@ * an event have their ThreadSpecificData * structure on a doubly-linked listed formed * from these pointers. */ /* End notifierLock section */ +#if defined(USE_OS_UNFAIR_LOCK) + os_unfair_lock tsdLock; +#else OSSpinLock tsdLock; /* Must hold this lock before acessing the * following fields from more than one * thread. */ +#endif + /* Start tsdLock section */ SelectMasks checkMasks; /* This structure is used to build up the * masks to be used in the next call to * select. Bits are set in response to calls * to Tcl_CreateFileHandler. */ @@ -453,11 +426,12 @@ /* * Static routines defined in this file. */ static void StartNotifierThread(void); -static TCL_NORETURN void NotifierThreadProc(ClientData clientData); +static void NotifierThreadProc(ClientData clientData) + __attribute__ ((__noreturn__)); static int FileHandlerEventProc(Tcl_Event *evPtr, int flags); static void TimerWakeUp(CFRunLoopTimerRef timer, void *info); static void QueueFileEvents(void *info); static void UpdateWaitingListAndServiceEvents( CFRunLoopObserverRef observer, @@ -524,11 +498,10 @@ #ifdef WEAK_IMPORT_SPINLOCKLOCK /* * Initialize support for weakly imported spinlock API. */ - if (pthread_once(&spinLockLockInitControl, SpinLockLockInit)) { Tcl_Panic("Tcl_InitNotifier: pthread_once failed"); } #endif @@ -561,11 +534,11 @@ CFRunLoopAddSource(runLoop, runLoopSource, tclEventsOnlyRunLoopMode); bzero(&runLoopObserverContext, sizeof(CFRunLoopObserverContext)); runLoopObserverContext.info = tsdPtr; runLoopObserver = CFRunLoopObserverCreate(NULL, - kCFRunLoopEntry|kCFRunLoopExit|kCFRunLoopBeforeWaiting, TRUE, + kCFRunLoopEntry|kCFRunLoopExit, TRUE, LONG_MIN, UpdateWaitingListAndServiceEvents, &runLoopObserverContext); if (!runLoopObserver) { Tcl_Panic("Tcl_InitNotifier: could not create " "CFRunLoopObserver"); @@ -579,11 +552,11 @@ * (CFRunLoop prevents observer callback re-entry of a given observer * instance). */ runLoopObserverTcl = CFRunLoopObserverCreate(NULL, - kCFRunLoopEntry|kCFRunLoopExit|kCFRunLoopBeforeWaiting, TRUE, + kCFRunLoopEntry|kCFRunLoopExit, TRUE, LONG_MIN, UpdateWaitingListAndServiceEvents, &runLoopObserverContext); if (!runLoopObserverTcl) { Tcl_Panic("Tcl_InitNotifier: could not create " "CFRunLoopObserver"); @@ -595,11 +568,15 @@ tsdPtr->runLoopSource = runLoopSource; tsdPtr->runLoopObserver = runLoopObserver; tsdPtr->runLoopObserverTcl = runLoopObserverTcl; tsdPtr->runLoopTimer = NULL; tsdPtr->waitTime = CF_TIMEINTERVAL_FOREVER; +#if defined(USE_OS_UNFAIR_LOCK) + tsdPtr->tsdLock = OS_UNFAIR_LOCK_INIT; +#else tsdPtr->tsdLock = SPINLOCK_INIT; +#endif } LOCK_NOTIFIER_INIT; #ifdef HAVE_PTHREAD_ATFORK /* @@ -653,11 +630,10 @@ OPEN_NOTIFIER_LOG; } ENABLE_ASL; notifierCount++; UNLOCK_NOTIFIER_INIT; - return tsdPtr; } /* *---------------------------------------------------------------------- @@ -753,11 +729,11 @@ *---------------------------------------------------------------------- */ void Tcl_FinalizeNotifier( - ClientData clientData) /* Not used. */ + ClientData clientData) { ThreadSpecificData *tsdPtr; if (tclNotifierHooks.finalizeNotifierProc) { tclNotifierHooks.finalizeNotifierProc(clientData); @@ -856,11 +832,11 @@ void Tcl_AlertNotifier( ClientData clientData) { - ThreadSpecificData *tsdPtr = clientData; + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)clientData; if (tclNotifierHooks.alertNotifierProc) { tclNotifierHooks.alertNotifierProc(clientData); return; } @@ -1034,11 +1010,11 @@ if (filePtr->fd == fd) { break; } } if (filePtr == NULL) { - filePtr = Tcl_Alloc(sizeof(FileHandler)); + filePtr = (FileHandler *)ckalloc(sizeof(FileHandler)); filePtr->fd = fd; filePtr->readyMask = 0; filePtr->nextPtr = tsdPtr->firstFileHandlerPtr; tsdPtr->firstFileHandlerPtr = filePtr; } @@ -1162,11 +1138,11 @@ if (prevPtr == NULL) { tsdPtr->firstFileHandlerPtr = filePtr->nextPtr; } else { prevPtr->nextPtr = filePtr->nextPtr; } - Tcl_Free(filePtr); + ckfree(filePtr); } /* *---------------------------------------------------------------------- * @@ -1289,10 +1265,14 @@ if (!tsdPtr->runLoop) { Tcl_Panic("Tcl_WaitForEvent: Notifier not initialized"); } + /* + * A NULL timePtr means wait forever. + */ + if (timePtr) { Tcl_Time vTime = *timePtr; /* * TIP #233 (Virtualized Time). Is virtual time in effect? And do we @@ -1302,18 +1282,27 @@ if (vTime.sec != 0 || vTime.usec != 0) { tclScaleTimeProcPtr(&vTime, tclTimeClientData); waitTime = vTime.sec + 1.0e-6 * vTime.usec; } else { + /* - * Polling: pretend to wait for files and tell the notifier thread - * what we are doing. The notifier thread makes sure it goes - * through select with its select mask in the same state as ours - * currently is. We block until that happens. + * The max block time was set to 0. + * + * If we set the waitTime to 0, then the call to CFRunLoopInMode + * may return without processing all of its sources. The Apple + * documentation says that if the waitTime is 0 "only one pass is + * made through the run loop before returning; if multiple sources + * or timers are ready to fire immediately, only one (possibly two + * if one is a version 0 source) will be fired, regardless of the + * value of returnAfterSourceHandled." This can cause some chanio + * tests to fail. So we use a small positive waitTime unless there + * is another RunLoop running. */ polling = 1; + waitTime = tsdPtr->runLoopRunning ? 0 : 0.0001; } } StartNotifierThread(); @@ -1322,22 +1311,22 @@ UNLOCK_NOTIFIER_TSD; tsdPtr->runLoopSourcePerformed = 0; /* * If the Tcl runloop is already running (e.g. if Tcl_WaitForEvent was - * called recursively) or is servicing events via the runloop observer, - * re-run it in a custom runloop mode containing only the source for the - * notifier thread, otherwise wakeups from other sources added to the - * common runloop modes might get lost or 3rd party event handlers might - * get called when they do not expect to be. + * called recursively) start a new runloop in a custom runloop mode + * containing only the source for the notifier thread. Otherwise wakeups + * from other sources added to the common runloop mode might get lost or + * 3rd party event handlers might get called when they do not expect to + * be. */ runLoopRunning = tsdPtr->runLoopRunning; tsdPtr->runLoopRunning = 1; - runLoopStatus = CFRunLoopRunInMode(tsdPtr->runLoopServicingEvents || - runLoopRunning ? tclEventsOnlyRunLoopMode : kCFRunLoopDefaultMode, - waitTime, TRUE); + runLoopStatus = CFRunLoopRunInMode( + runLoopRunning ? tclEventsOnlyRunLoopMode : kCFRunLoopDefaultMode, + waitTime, TRUE); tsdPtr->runLoopRunning = runLoopRunning; LOCK_NOTIFIER_TSD; tsdPtr->polling = 0; UNLOCK_NOTIFIER_TSD; @@ -1378,11 +1367,11 @@ QueueFileEvents( void *info) { SelectMasks readyMasks; FileHandler *filePtr; - ThreadSpecificData *tsdPtr = info; + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)info; /* * Queue all detected file events. */ @@ -1417,11 +1406,11 @@ * Don't bother to queue an event if the mask was previously non-zero * since an event must still be on the queue. */ if (filePtr->readyMask == 0) { - FileHandlerEvent *fileEvPtr = Tcl_Alloc(sizeof(FileHandlerEvent)); + FileHandlerEvent *fileEvPtr = (FileHandlerEvent *)ckalloc(sizeof(FileHandlerEvent)); fileEvPtr->header.proc = FileHandlerEventProc; fileEvPtr->fd = filePtr->fd; Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL); } @@ -1450,12 +1439,11 @@ UpdateWaitingListAndServiceEvents( CFRunLoopObserverRef observer, CFRunLoopActivity activity, void *info) { - ThreadSpecificData *tsdPtr = info; - + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)info; if (tsdPtr->sleeping) { return; } switch (activity) { case kCFRunLoopEntry: @@ -1473,23 +1461,10 @@ LOCK_NOTIFIER; OnOffWaitingList(tsdPtr, 0, 1); UNLOCK_NOTIFIER; } tsdPtr->runLoopNestingLevel--; - break; - case kCFRunLoopBeforeWaiting: - if (tsdPtr->runLoopTimer && !tsdPtr->runLoopServicingEvents && - (tsdPtr->runLoopNestingLevel > 1 - || !tsdPtr->runLoopRunning)) { - tsdPtr->runLoopServicingEvents = 1; - /* - * This call seems to simply force event processing through and - * prevents hangups that have long been observed with Tk-Cocoa. - */ - Tcl_ServiceAll(); - tsdPtr->runLoopServicingEvents = 0; - } break; default: break; } } @@ -1519,11 +1494,11 @@ int onList, int signalNotifier) { int changeWaitingList; -#ifdef TCL_MAC_DEBUG_NOTIFIER +#if defined(TCL_MAC_DEBUG_NOTIFIER) && !defined(USE_OS_UNFAIR_LOCK) if (SpinLockTry(¬ifierLock)) { Tcl_Panic("OnOffWaitingList: notifierLock unlocked"); } #endif changeWaitingList = (!onList ^ !tsdPtr->onList); @@ -1823,11 +1798,11 @@ * the notifier thread first starts. * *---------------------------------------------------------------------- */ -static TCL_NORETURN void +static void NotifierThreadProc( ClientData clientData) /* Not used. */ { ThreadSpecificData *tsdPtr; fd_set readableMask, writableMask, exceptionalMask; @@ -2050,13 +2025,23 @@ static void AtForkChild(void) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - UNLOCK_NOTIFIER_TSD; - UNLOCK_NOTIFIER; - UNLOCK_NOTIFIER_INIT; + /* + * If a child process unlocks an os_unfair_lock that was created in its parent + * the child will exit with an illegal instruction error. So we reinitialize + * the lock in the child rather than attempt to unlock it. + */ + +#if defined(USE_OS_UNFAIR_LOCK) + tsdPtr->tsdLock = OS_UNFAIR_LOCK_INIT; +#else + UNLOCK_NOTIFIER_TSD; + UNLOCK_NOTIFIER; + UNLOCK_NOTIFIER_INIT; +#endif if (tsdPtr->runLoop) { tsdPtr->runLoop = NULL; if (!noCFafterFork) { CFRunLoopSourceInvalidate(tsdPtr->runLoopSource); CFRelease(tsdPtr->runLoopSource); Index: pkgs/README ================================================================== --- pkgs/README +++ pkgs/README @@ -15,11 +15,11 @@ In that subdirectory of "pkgs" there must be an executable file named "configure". When the program "configure" is run, it should generate a file "Makefile" in the current working directory. The "configure" program should be able to accept as command line arguments all the - arguments that can be passed to the master unix/configure program. It + arguments that can be passed to the top unix/configure program. It should also accept the --with-tcl= and --with-tclinclude= options in the conventional way. The generated "Makefile" must be one suitable for controlling the operations of a `make` program. The following targets must be defined: Index: tests-perf/clock.perf.tcl ================================================================== --- tests-perf/clock.perf.tcl +++ tests-perf/clock.perf.tcl @@ -120,11 +120,11 @@ {clock format 1482525936 -format "%%a = %a | %%A = %A | %%b = %b | %%h = %h | %%B = %B | %%C = %C | %%d = %d | %%e = %e | %%g = %g | %%G = %G | %%H = %H | %%I = %I | %%j = %j | %%J = %J | %%k = %k | %%l = %l | %%m = %m | %%M = %M | %%N = %N | %%p = %p | %%P = %P | %%Q = %Q | %%s = %s | %%S = %S | %%t = %t | %%u = %u | %%U = %U | %%V = %V | %%w = %w | %%W = %W | %%y = %y | %%Y = %Y | %%z = %z | %%Z = %Z | %%n = %n | %%EE = %EE | %%EC = %EC | %%Ey = %Ey | %%n = %n | %%Od = %Od | %%Oe = %Oe | %%OH = %OH | %%Ok = %Ok | %%OI = %OI | %%Ol = %Ol | %%Om = %Om | %%OM = %OM | %%OS = %OS | %%Ou = %Ou | %%Ow = %Ow | %%Oy = %Oy" -timezone :CET -locale de} } } proc test-scan {{reptime 1000}} { - _test_run $reptime { + _test_run -convert-result {clock format $_(r) -locale en} $reptime { # Scan : date (in gmt) {clock scan "25.11.2015" -format "%d.%m.%Y" -base 0 -gmt 1} # Scan : date (system time zone, with base) {clock scan "25.11.2015" -format "%d.%m.%Y" -base 0} # Scan : date (system time zone, without base) @@ -196,15 +196,15 @@ # {clock scan "25.11.2015" -format "%d.%m.%Y %d.%m.%Y %d.%m.%Y %d.%m.%Y %d.%m.%Y %d.%m.%Y %d.%m.%Y %d.%m.%Y" -base 0 -gmt 1} # # Scan : dynamic, very long format test (create obj representation, allock chain, GC, etc): # {clock scan "25.11.2015" -format [string repeat "[incr i] %d.%m.%Y %d.%m.%Y" 10] -base 0 -gmt 1} # # Scan : again: # {clock scan "25.11.2015" -format [string repeat "[incr i -1] %d.%m.%Y %d.%m.%Y" 10] -base 0 -gmt 1} - } {puts [clock format $_(r) -locale en]} + } } proc test-freescan {{reptime 1000}} { - _test_run $reptime { + _test_run -convert-result {clock format $_(r) -locale en} $reptime { # FreeScan : relative date {clock scan "5 years 18 months 385 days" -base 0 -gmt 1} # FreeScan : relative date with relative weekday {clock scan "5 years 18 months 385 days Fri" -base 0 -gmt 1} # FreeScan : relative date with ordinal month @@ -237,11 +237,11 @@ {clock scan "19:18:30 GMT" -base 148863600} # FreeScan : fast switch of zones in cycle - GMT, MST, CET (system) and EST {clock scan "19:18:30 MST" -base 148863600 -gmt 1 clock scan "19:18:30 EST" -base 148863600 } - } {puts [clock format $_(r) -locale en]} + } } proc test-add {{reptime 1000}} { set tests { # Add : years @@ -280,11 +280,11 @@ } # if does not support add of weekdays: if {[catch {clock add 0 3 weekdays -gmt 1}]} { regsub -all {\mweekdays\M} $tests "days" tests } - _test_run $reptime $tests {puts [clock format $_(r) -locale en]} + _test_run -convert-result {clock format $_(r) -locale en} $reptime $tests } proc test-convert {{reptime 1000}} { _test_run $reptime { # Convert locale (en -> de): Index: tests-perf/test-performance.tcl ================================================================== --- tests-perf/test-performance.tcl +++ tests-perf/test-performance.tcl @@ -125,19 +125,27 @@ } proc _test_run {args} { upvar _ _ # parse args: - array set _ [set _opts {-no-result 0 -uplevel 0}] + array set _ {-no-result 0 -uplevel 0 -convert-result {}} while {[llength $args] > 2} { - if {[set o [lindex $args 0]] ni $_opts || $_($o)} { + if {![info exists _([set o [lindex $args 0]])]} { break } - set _($o) 1 - set args [lrange $args 1 end] + if {[string is boolean -strict $_($o)]} { + set _($o) [expr {! $_($o)}] + set args [lrange $args 1 end] + } else { + if {[llength $args] <= 2} { + return -code error "value expected for option $o" + } + set _($o) [lindex $args 1] + set args [lrange $args 2 end] + } } - unset -nocomplain _opts o + unset -nocomplain o if {[llength $args] < 2 || [llength $args] > 3} { return -code error "wrong # args: should be \"[lindex [info level [info level]] 0] ?-no-result? reptime lst ?outcmd?\"" } set _(outcmd) {puts} set args [lassign $args reptime lst] @@ -171,11 +179,12 @@ } set _(ittime) $_(reptime) # if output result (and not once): if {!$_(-no-result)} { set _(r) [if 1 $_(c)] - if {$_(outcmd) ne {}} {{*}$_(outcmd) $_(r)} + if {$_(-convert-result) ne ""} { set _(r) [if 1 $_(-convert-result)] } + {*}$_(outcmd) $_(r) if {[llength $_(ittime)] > 1} { # decrement max-count lset _(ittime) 1 [expr {[lindex $_(ittime) 1] - 1}] } } {*}$_(outcmd) [set _(m) [timerate $_(c) {*}$_(ittime)]] Index: tests/aaa_exit.test ================================================================== --- tests/aaa_exit.test +++ tests/aaa_exit.test @@ -9,12 +9,12 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } test exit-1.1 {normal, quick exit} { set f [open "|[interpreter] << \"exec [interpreter] << {set ::env(TCL_FINALIZE_ON_EXIT) 0;exit}\"" r] Index: tests/all.tcl ================================================================== --- tests/all.tcl +++ tests/all.tcl @@ -8,13 +8,12 @@ # Copyright (c) 2000 by Ajuba Solutions # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package prefer latest package require Tcl 8.5- -package require tcltest 2.2 +package require tcltest 2.5 namespace import ::tcltest::* configure {*}$argv -testdir [file dirname [file dirname [file normalize [ info script]/...]]] @@ -23,6 +22,11 @@ } set ErrorOnFailures [info exists env(ERROR_ON_FAILURES)] unset -nocomplain env(ERROR_ON_FAILURES) if {[runAllTests] && $ErrorOnFailures} {exit 1} -proc exit args {} +# if calling direct only (avoid rewrite exit if inlined or interactive): +if { [info exists ::argv0] && [file tail $::argv0] eq [file tail [info script]] + && !([info exists ::tcl_interactive] && $::tcl_interactive) +} { + proc exit args {} +} Index: tests/append.test ================================================================== --- tests/append.test +++ tests/append.test @@ -9,12 +9,12 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } unset -nocomplain x test append-1.1 {append command} { @@ -30,11 +30,11 @@ append x } abcd test append-2.1 {long appends} { set x "" - for {set i 0} {$i < 1000} {set i [expr $i+1]} { + for {set i 0} {$i < 1000} {incr i} { append x "foobar " } set y "foobar" set y "$y $y $y $y $y $y $y $y $y $y" set y "$y $y $y $y $y $y $y $y $y $y" @@ -156,11 +156,11 @@ proc check {var size} { set l [llength $var] if {$l != $size} { return "length mismatch: should have been $size, was $l" } - for {set i 0} {$i < $size} {set i [expr $i+1]} { + for {set i 0} {$i < $size} {incr i} { set j [lindex $var $i] if {$j ne "item $i"} { return "element $i should have been \"item $i\", was \"$j\"" } } Index: tests/appendComp.test ================================================================== --- tests/appendComp.test +++ tests/appendComp.test @@ -9,12 +9,12 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } catch {unset x} test appendComp-1.1 {append command} -setup { @@ -39,11 +39,11 @@ } abcd test appendComp-2.1 {long appends} { proc foo {} { set x "" - for {set i 0} {$i < 1000} {set i [expr $i+1]} { + for {set i 0} {$i < 1000} {incr i} { append x "foobar " } set y "foobar" set y "$y $y $y $y $y $y $y $y $y $y" set y "$y $y $y $y $y $y $y $y $y $y" @@ -221,11 +221,11 @@ } return ok } } -body { set x "" - for {set i 0} {$i < 300} {set i [expr $i+1]} { + for {set i 0} {$i < 300} {incr i} { lappend x "item $i" } check $x 300 } -cleanup { unset -nocomplain x @@ -357,21 +357,21 @@ } bar } -result {0} test appendComp-8.1 {defer error to runtime} -setup { - interp create slave + interp create child } -body { - slave eval { + child eval { proc foo {} { proc append args {} append } foo } } -cleanup { - interp delete slave + interp delete child } -result {} # New tests for bug 3057639 to show off the more consistent behaviour of # lappend in both direct-eval and bytecompiled code paths (see append.test for # the direct-eval variants). lappend now behaves like append. 9.0/1 lappend - Index: tests/apply.test ================================================================== --- tests/apply.test +++ tests/apply.test @@ -10,12 +10,12 @@ # Copyright (c) 2005-2006 Miguel Sofer # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2.2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } if {[info commands ::apply] eq {}} { return @@ -23,11 +23,11 @@ testConstraint memory [llength [info commands memory]] # Tests for wrong number of arguments -test apply-1.1 {too few arguments} -returnCodes error -body { +test apply-1.1 {not enough arguments} -returnCodes error -body { apply } -result {wrong # args: should be "apply lambdaExpr ?arg ...?"} # Tests for malformed lambda @@ -226,11 +226,11 @@ } {{x 1} {args 2}} test apply-8.3 {args treatment} { apply [list {x args} $applyBody] 1 2 3 } {{x 1} {args {2 3}}} test apply-8.4 {default values} { - apply [list {{x 1} {y 2}} $applyBody] + apply [list {{x 1} {y 2}} $applyBody] } {{x 1} {y 2}} test apply-8.5 {default values} { apply [list {{x 1} {y 2}} $applyBody] 3 4 } {{x 3} {y 4}} test apply-8.6 {default values} { Index: tests/assemble.test ================================================================== --- tests/assemble.test +++ tests/assemble.test @@ -299,16 +299,16 @@ -returnCodes error -match glob -result {wrong # args*} } test assemble-7.2 {add} { - -body { + -body { assemble { push 2 push 2 add - } + } } -result {4} } test assemble-7.3 {appendArrayStk} { -body { @@ -347,11 +347,11 @@ } -result {8 -13 14 6} } test assemble-7.6 {div} { -body { - assemble {push 999999; push 7; div} + assemble {push 999999; push 7; div} } -result 142857 } test assemble-7.7 {dup} { -body { @@ -358,11 +358,11 @@ assemble { push 1; dup; dup; add; dup; add; dup; add; add } } -result 9 -} +} test assemble-7.8 {eq} { -body { list \ [assemble {push able; push baker; eq}] \ [assemble {push able; push able; eq}] @@ -529,10 +529,22 @@ } x } -result 12 -cleanup {rename x {}} +} +test assemble-7.17 {land/lor} { + -body { + proc x {a b} { + list \ + [assemble {load a; load b; land}] \ + [assemble {load a; load b; lor}] + } + list [x 0 0] [x 0 23] [x 35 0] [x 47 59] + } + -result {{0 0} {0 1} {0 1} {1 1}} + -cleanup {rename x {}} } test assemble-7.18 {lappendArrayStk} { -body { proc x {} { set able(baker) charlie @@ -624,11 +636,11 @@ -result {{a b} {c d} {e i} {g h}} } test assemble-7.25 {lshift} { -body { assemble {push 16; push 4; lshift} - } + } -result 256 } test assemble-7.26 {mod} { -body { assemble {push 123456; push 1000; mod} @@ -664,11 +676,11 @@ -result that } test assemble-7.31 {rshift} { -body { assemble {push 257; push 4; rshift} - } + } -result 16 } test assemble-7.32 {storeArrayStk} { -body { proc x {} { @@ -767,11 +779,11 @@ assemble { push NaN; uplus } } -returnCodes error - -result {can't use non-numeric floating-point value "NaN" as operand of "+"} + -result {can't use non-numeric floating-point value as operand of "+"} } test assemble-7.43.1 {tryCvtToNumeric} { -body { assemble { push NaN; tryCvtToNumeric @@ -838,15 +850,14 @@ } test assemble-8.5 {bad context} { -body { namespace eval assem { set x 1 - assemble {load x} + list [catch {assemble {load x}} result opts] $result [dict get $opts -errorcode] } } - -result {cannot use this instruction to create a variable in a non-proc context} - -errorCode {TCL ASSEM LVT} + -result {1 {cannot use this instruction to create a variable in a non-proc context} {TCL ASSEM LVT}} -cleanup {namespace delete assem} } test assemble-8.6 {load1} { -body { proc x {a} { @@ -1097,14 +1108,14 @@ } -result hello } test assemble-9.7 {concat} { -body { - assemble {concat 0} + list [catch {assemble {concat 0}} result] $result $::errorCode } - -result {operand must be positive} - -errorCode {TCL ASSEM POSITIVE} + -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} + -cleanup {unset result} } # assemble-10 -- eval and expr test assemble-10.1 {eval - wrong # args} { @@ -1188,11 +1199,11 @@ -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} } # assemble-11 - ASSEM_LVT4 (exist, existArray, dictAppend, dictLappend, # nsupvar, variable, upvar) - + test assemble-11.1 {exist - wrong # args} { -body { assemble {exist} } -returnCodes error @@ -1297,11 +1308,11 @@ -result 123 -cleanup {namespace delete q; rename x {}} } # assemble-12 - ASSEM_LVT1 (incr and incrArray) - + test assemble-12.1 {incr - wrong # args} { -body { assemble {incr} } -returnCodes error @@ -1522,65 +1533,39 @@ -cleanup {rename x {}} } # assemble-15 - listIndexImm -test assemble-15.1 {listIndexImm - wrong # args} { - -body { - assemble {listIndexImm} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-15.2 {listIndexImm - wrong # args} { - -body { - assemble {listIndexImm too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-15.3 {listIndexImm - bad substitution} { - -body { - list [catch {assemble {listIndexImm $foo}} result] $result $::errorCode - } - -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} - -cleanup {unset result} -} -test assemble-15.4 {listIndexImm - invalid index} { - -body { - assemble {listIndexImm rubbish} - } - -returnCodes error - -match glob - -result {bad index "rubbish"*} -} -test assemble-15.5 {listIndexImm} { - -body { - assemble {push {a b c}; listIndexImm 2} - } - -result c -} -test assemble-15.6 {listIndexImm} { - -body { - assemble {push {a b c}; listIndexImm end-1} - } - -result b -} -test assemble-15.7 {listIndexImm} { - -body { - assemble {push {a b c}; listIndexImm end} - } - -result c -} -test assemble-15.8 {listIndexImm} { +test assemble-15.1 {listIndexImm - wrong # args} -body { + assemble {listIndexImm} +} -returnCodes error -match glob -result {wrong # args*} +test assemble-15.2 {listIndexImm - wrong # args} -body { + assemble {listIndexImm too many} +} -returnCodes error -match glob -result {wrong # args*} +test assemble-15.3 {listIndexImm - bad substitution} -body { + list [catch {assemble {listIndexImm $foo}} result] $result $::errorCode +} -cleanup { + unset result +} -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} +test assemble-15.4 {listIndexImm - invalid index} -body { + assemble {listIndexImm rubbish} +} -returnCodes error -match glob -result {bad index "rubbish"*} +test assemble-15.5 {listIndexImm} -body { + assemble {push {a b c}; listIndexImm 2} +} -result c +test assemble-15.6 {listIndexImm} -body { + assemble {push {a b c}; listIndexImm end-1} +} -result b +test assemble-15.7 {listIndexImm} -body { + assemble {push {a b c}; listIndexImm end} +} -result c +test assemble-15.8 {listIndexImm} -body { assemble {push {a b c}; listIndexImm end+2} -} {} -test assemble-15.9 {listIndexImm} { +} -result {} +test assemble-15.9 {listIndexImm} -body { assemble {push {a b c}; listIndexImm -1-1} -} {} +} -result {} # assemble-16 - invokeStk test assemble-16.1 {invokeStk - wrong # args} { -body { @@ -1736,29 +1721,29 @@ proc x {} { set case 0 set result {} assemble { jump common - + label zero - pop + pop incrImm case 1 pop push a append result pop jump common - + label one pop incrImm case 1 pop push b append result pop jump common - + label common load case dup push 0 eq @@ -1773,20 +1758,20 @@ jumpTrue two dup push 3 eq jumpTrue three - + label two pop incrImm case 1 pop push c append result pop jump common - + label three pop incrImm case 1 pop push d @@ -1880,11 +1865,11 @@ } append body {label c; push -; concat 2; nop; nop; nop; jump d} \n append body {label b15; push b; concat 2; nop; nop; jump c} \n append body {label d} proc x {} [list assemble $body] - } + } -body { x } -cleanup { catch {unset body} @@ -2073,11 +2058,11 @@ -cleanup {rename x {}; unset result} } test assemble-20.6 {lsetFlat} { -body { assemble {push b; push a; lsetFlat 2} - } + } -result b } test assemble-20.7 {lsetFlat} { -body { assemble {push 1; push d; push {a b c}; lsetFlat 3} @@ -3059,16 +3044,16 @@ -body { list \ [catch { assemble { push 3 - dup - mult + dup + mult push 4 - dup - mult - pop + dup + mult + pop expon } } result] $result $::errorInfo } -result {1 {stack underflow} {stack underflow @@ -3163,43 +3148,43 @@ proc ulam {n} { assemble { load n; # max dup; # max n jump start; # max n - + label loop; # max n over 1; # max n max over 1; # max in max n ge; # man n max>=n jumpTrue skip; # max n reverse 2; # n max pop; # n dup; # n n - + label skip; # max n dup; # max n n push 2; # max n n 2 mod; # max n n%2 jumpTrue odd; # max n - + push 2; # max n 2 div; # max n/2 -> max n jump start; # max n - + label odd; # max n push 3; # max n 3 mult; # max 3*n push 1; # max 3*n 1 add; # max 3*n+1 - + label start; # max n dup; # max n n push 1; # max n n 1 neq; # max n n>1 jumpTrue loop; # max n - + pop; # max } } set result {} for {set i 1} {$i < 30} {incr i} { @@ -3225,43 +3210,43 @@ apply {{n} { assemble { load n; # max dup; # max n jump start; # max n - + label loop; # max n over 1; # max n max over 1; # max in max n ge; # man n max>=n jumpTrue skip; # max n reverse 2; # n max pop; # n dup; # n n - + label skip; # max n dup; # max n n push 2; # max n n 2 mod; # max n n%2 jumpTrue odd; # max n - + push 2; # max n 2 div; # max n/2 -> max n jump start; # max n - + label odd; # max n push 3; # max n 3 mult; # max 3*n push 1; # max 3*n 1 add; # max 3*n+1 - + label start; # max n dup; # max n n push 1; # max n n 1 neq; # max n n>1 jumpTrue loop; # max n - + pop; # max } }} 1 } } 0 @@ -3290,11 +3275,11 @@ label @badLabel push 1; # should be pushReturnCode label @okLabel endCatch pop - + beginCatch @badLabel2 push error push testing invokeStk 2 pop @@ -3303,11 +3288,11 @@ label @badLabel2 push 1; # should be pushReturnCode label @okLabel2 endCatch pop - + beginCatch @badLabel3 push error push testing invokeStk 2 pop @@ -3316,11 +3301,11 @@ label @badLabel3 push 1; # should be pushReturnCode label @okLabel3 endCatch pop - + beginCatch @badLabel4 push error push testing invokeStk 2 pop @@ -3329,11 +3314,11 @@ label @badLabel4 push 1; # should be pushReturnCode label @okLabel4 endCatch pop - + beginCatch @badLabel5 push error push testing invokeStk 2 pop @@ -3342,11 +3327,11 @@ label @badLabel5 push 1; # should be pushReturnCode label @okLabel5 endCatch pop - + beginCatch @badLabel6 push error push testing invokeStk 2 pop Index: tests/assemble1.bench ================================================================== --- tests/assemble1.bench +++ tests/assemble1.bench @@ -18,67 +18,68 @@ proc ulam2 {n} { tcl::unsupported::assemble { load n; # max dup; # max n jump start; # max n - + label loop; # max n over 1; # max n max over 1; # max in max n ge; # man n max>=n jumpTrue skip; # max n reverse 2; # n max pop; # n dup; # n n - + label skip; # max n dup; # max n n push 2; # max n n 2 mod; # max n n%2 jumpTrue odd; # max n - + push 2; # max n 2 div; # max n/2 -> max n jump start; # max n - + label odd; # max n push 3; # max n 3 mult; # max 3*n push 1; # max 3*n 1 add; # max 3*n+1 - + label start; # max n dup; # max n n push 1; # max n n 1 neq; # max n n>1 jumpTrue loop; # max n - + pop; # max } } set tcl_traceCompile 2; ulam2 1; set tcl_traceCompile 0 proc test1 {n} { for {set i 1} {$i <= $n} {incr i} { - ulam1 $i + ulam1 $i } } proc test2 {n} { for {set i 1} {$i <= $n} {incr i} { - ulam2 $i + ulam2 $i } } for {set j 0} {$j < 10} {incr j} { test1 1 set before [clock microseconds] test1 30000 set after [clock microseconds] puts "compiled: [expr {1e-6 * ($after - $before)}]" - + test2 1 set before [clock microseconds] test2 30000 set after [clock microseconds] puts "assembled: [expr {1e-6 * ($after - $before)}]" } + Index: tests/assocd.test ================================================================== --- tests/assocd.test +++ tests/assocd.test @@ -9,11 +9,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 +package require tcltest 2.5 namespace import ::tcltest::* ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] Index: tests/async.test ================================================================== --- tests/async.test +++ tests/async.test @@ -9,19 +9,21 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] testConstraint testasync [llength [info commands testasync]] +testConstraint threaded [::tcl::pkgconfig get threaded] +testConstraint notWinCI [expr {$::tcl_platform(platform) != "windows" || ![info exists ::env(CI)]}] proc async1 {result code} { global aresult acode set aresult $result set acode $code @@ -146,11 +148,11 @@ set x {} list [catch {testasync mark $hm2 "foobar" 5} msg] $msg $x } {3 del2 {0 0 0 del1 del2}} test async-4.1 {async interrupting bytecode sequence} -constraints { - testasync + testasync threaded } -setup { set hm [testasync create async3] proc nothing {} { # empty proc } @@ -175,11 +177,11 @@ # "still reachable" cases from early thread termination after 100 testasync delete $hm } test async-4.2 {async interrupting straight bytecode sequence} -constraints { - testasync + testasync threaded } -setup { set hm [testasync create async3] } -body { apply {{handle} { global aresult @@ -200,11 +202,11 @@ # "still reachable" cases from early thread termination after 100 testasync delete $hm } test async-4.3 {async interrupting loop-less bytecode sequence} -constraints { - testasync + testasync threaded notWinCI } -setup { set hm [testasync create async3] } -body { apply [list {handle} [concat { global aresult ADDED tests/auto0/auto1/file1.tcl Index: tests/auto0/auto1/file1.tcl ================================================================== --- /dev/null +++ tests/auto0/auto1/file1.tcl @@ -0,0 +1,3 @@ +proc report1 {args} { + return ok1 +} ADDED tests/auto0/auto1/package1.tcl Index: tests/auto0/auto1/package1.tcl ================================================================== --- /dev/null +++ tests/auto0/auto1/package1.tcl @@ -0,0 +1,5 @@ +proc HeresPackage1 {args} { + return OK1 +} + +package provide SafeTestPackage1 1.2.3 ADDED tests/auto0/auto1/pkgIndex.tcl Index: tests/auto0/auto1/pkgIndex.tcl ================================================================== --- /dev/null +++ tests/auto0/auto1/pkgIndex.tcl @@ -0,0 +1,11 @@ +# Tcl package index file, version 1.1 +# This file is generated by the "pkg_mkIndex" command +# and sourced either when an application starts up or +# by a "package unknown" script. It invokes the +# "package ifneeded" command to set up package-related +# information so that packages will be loaded automatically +# in response to "package require" commands. When this +# script is sourced, the variable $dir must contain the +# full path name of this file's directory. + +package ifneeded SafeTestPackage1 1.2.3 [list source [file join $dir package1.tcl]] ADDED tests/auto0/auto1/tclIndex Index: tests/auto0/auto1/tclIndex ================================================================== --- /dev/null +++ tests/auto0/auto1/tclIndex @@ -0,0 +1,9 @@ +# Tcl autoload index file, version 2.0 +# This file is generated by the "auto_mkindex" command +# and sourced to set up indexing information for one or +# more commands. Typically each line is a command that +# sets an element in the auto_index array, where the +# element name is the name of a command and the value is +# a script that loads the command. + +set auto_index(report1) [list source [file join $dir file1.tcl]] ADDED tests/auto0/auto2/file2.tcl Index: tests/auto0/auto2/file2.tcl ================================================================== --- /dev/null +++ tests/auto0/auto2/file2.tcl @@ -0,0 +1,3 @@ +proc report2 {args} { + return ok2 +} ADDED tests/auto0/auto2/package2.tcl Index: tests/auto0/auto2/package2.tcl ================================================================== --- /dev/null +++ tests/auto0/auto2/package2.tcl @@ -0,0 +1,5 @@ +proc HeresPackage2 {args} { + return OK2 +} + +package provide SafeTestPackage2 2.3.4 ADDED tests/auto0/auto2/pkgIndex.tcl Index: tests/auto0/auto2/pkgIndex.tcl ================================================================== --- /dev/null +++ tests/auto0/auto2/pkgIndex.tcl @@ -0,0 +1,11 @@ +# Tcl package index file, version 1.1 +# This file is generated by the "pkg_mkIndex" command +# and sourced either when an application starts up or +# by a "package unknown" script. It invokes the +# "package ifneeded" command to set up package-related +# information so that packages will be loaded automatically +# in response to "package require" commands. When this +# script is sourced, the variable $dir must contain the +# full path name of this file's directory. + +package ifneeded SafeTestPackage2 2.3.4 [list source [file join $dir package2.tcl]] ADDED tests/auto0/auto2/tclIndex Index: tests/auto0/auto2/tclIndex ================================================================== --- /dev/null +++ tests/auto0/auto2/tclIndex @@ -0,0 +1,9 @@ +# Tcl autoload index file, version 2.0 +# This file is generated by the "auto_mkindex" command +# and sourced to set up indexing information for one or +# more commands. Typically each line is a command that +# sets an element in the auto_index array, where the +# element name is the name of a command and the value is +# a script that loads the command. + +set auto_index(report2) [list source [file join $dir file2.tcl]] ADDED tests/auto0/modules/mod1/test1-1.0.tm Index: tests/auto0/modules/mod1/test1-1.0.tm ================================================================== --- /dev/null +++ tests/auto0/modules/mod1/test1-1.0.tm @@ -0,0 +1,5 @@ +namespace eval mod1::test1 {} + +proc mod1::test1::try1 args { + return res1 +} ADDED tests/auto0/modules/mod2/test2-2.0.tm Index: tests/auto0/modules/mod2/test2-2.0.tm ================================================================== --- /dev/null +++ tests/auto0/modules/mod2/test2-2.0.tm @@ -0,0 +1,5 @@ +namespace eval mod2::test2 {} + +proc mod2::test2::try2 args { + return res2 +} ADDED tests/auto0/modules/test0-0.5.tm Index: tests/auto0/modules/test0-0.5.tm ================================================================== --- /dev/null +++ tests/auto0/modules/test0-0.5.tm @@ -0,0 +1,5 @@ +namespace eval test0 {} + +proc test0::try0 args { + return res0 +} Index: tests/autoMkindex.test ================================================================== --- tests/autoMkindex.test +++ tests/autoMkindex.test @@ -8,11 +8,11 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } makeFile {# Test file for: # auto_mkindex @@ -38,12 +38,12 @@ namespace import -force blt::* # Should be able to handle "proc" definitions, even if they are preceded by # white space. -proc normal {x y} {return [expr $x+$y]} - proc indented {x y} {return [expr $x+$y]} +proc normal {x y} {return [expr {$x+$y}]} + proc indented {x y} {return [expr {$x+$y}]} # # Should be able to handle proc declarations within namespaces, even if they # have explicit namespace paths. # @@ -144,24 +144,24 @@ namespace delete tcl_autoMkindex_tmp } -result "{::buried::explicit $element} {::buried::inside $element} {{::buried::my proc} $element} {::buried::mycmd1 $element} {::buried::mycmd4 $element} {::buried::myproc $element} {::buried::pub_one $element} {::buried::pub_two $element} {::buried::relative $element} {::buried::under::neath $element} {::buried::within $element} {::parent::child::test $element} {indented $element} {normal $element} {top $element}" test autoMkindex-2.1 {commands on the autoload path can be imported} -setup { file delete tclIndex - interp create slave + interp create child } -body { auto_mkindex . autoMkindex.tcl - slave eval { + child eval { namespace eval blt {} set auto_path [linsert $auto_path 0 .] set info [list [catch {namespace import buried::*} result] $result] foreach name [lsort [info commands pub_*]] { lappend info $name [namespace origin $name] } return $info } } -cleanup { - interp delete slave + interp delete child } -result "0 {} pub_one ::buried::pub_one pub_two ::buried::pub_two" # Test auto_mkindex hooks # Slave hook executes interesting code in the interp used to watch code. @@ -333,18 +333,18 @@ makeDirectory pkg makeFile { proc {[magic mojo proc]} {} {} } [file join pkg magicchar2.tcl] set result {} - interp create slave + interp create child } -body { auto_mkindex . pkg/magicchar2.tcl - # Make a slave interp to test the autoloading - slave eval {lappend auto_path [pwd]} - slave eval {catch {{[magic mojo proc]}}} + # Make a child interp to test the autoloading + child eval {lappend auto_path [pwd]} + child eval {catch {{[magic mojo proc]}}} } -cleanup { - interp delete slave + interp delete child removeFile [file join pkg magicchar2.tcl] removeDirectory pkg } -result 0 # Clean up. Index: tests/basic.test ================================================================== --- tests/basic.test +++ tests/basic.test @@ -13,12 +13,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] testConstraint testevalex [llength [info commands testevalex]] @@ -668,13 +670,13 @@ proc l3 {} { list i j k {l l} } # Do all tests once byte compiled and once with direct string evaluation -foreach noComp {0 1} { +for {set noComp 0} {$noComp <= 1} {incr noComp} { -if $noComp { +if {$noComp} { interp alias {} run {} testevalex set constraints testevalex } else { interp alias {} run {} if 1 set constraints {} @@ -891,21 +893,25 @@ unset end i tmp rename getbytes {} rename stress {} } -result 0 -test basic-48.17.$noComp {expansion: object safety} -constraints $constraints -body { +test basic-48.17.$noComp {expansion: object safety} -setup { + set old_precision $::tcl_precision + set ::tcl_precision 4 + } -constraints $constraints -body { set third [expr {1.0/3.0}] set l [list $third $third] set x [run {list $third {*}$l $third}] - set res [list] + set res [list] foreach t $x { lappend res [expr {$t * 3.0}] } set res } -cleanup { - unset res t l x third + set ::tcl_precision $old_precision + unset old_precision res t l x third } -result {1.0 1.0 1.0 1.0} test basic-48.18.$noComp {expansion: list semantics} -constraints $constraints -body { set badcmd { list a b @@ -962,11 +968,11 @@ unset -nocomplain a } -body { run {list [list {*}{ }] [list {*}[format %c 32]] [list {*}[set a { }]]} } -result [lrepeat 3 {}] -cleanup {unset -nocomplain a} -test basic-48.25.$noComp {Bug cc191552c: expansion: empty non-canonical list} -setup { +test basic-48.25.$noComp {Bug cc191552c: expansion: empty non-canonical list} -constraints $constraints -setup { unset -nocomplain ::CRLF set ::CRLF "\r\n" } -body { # Force variant that turned up in Bug 2c154a40be as that's externally # noticeable in an important downstream project. @@ -997,17 +1003,17 @@ namespace delete ns set ::context } {global} test basic-50.1 {[586e71dce4] EvalObjv level #0 exception handling} -setup { - interp create slave - interp alias {} foo slave return + interp create child + interp alias {} foo child return } -body { list [catch foo m] $m } -cleanup { unset -nocomplain m - interp delete slave + interp delete child } -result {0 {}} # Clean up after expand tests unset noComp l1 l2 constraints rename l3 {} Index: tests/binary.test ================================================================== --- tests/binary.test +++ tests/binary.test @@ -8,12 +8,12 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } testConstraint bigEndian [expr {$tcl_platform(byteOrder) eq "bigEndian"}] testConstraint littleEndian [expr {$tcl_platform(byteOrder) eq "littleEndian"}] @@ -1645,10 +1645,26 @@ } HelloTcl test binary-43.2 {Tcl_BinaryObjCmd: format wide int} {} { binary format W 7810179016327718216 } lcTolleH +test binary-44.1 {Tcl_BinaryObjCmd: scan wide int} {} { + binary scan HelloTcl W x + set x +} 5216694956358656876 +test binary-44.2 {Tcl_BinaryObjCmd: scan wide int} {} { + binary scan lcTolleH w x + set x +} 5216694956358656876 +test binary-44.3 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {} { + binary scan [binary format w [expr {wide(3) << 31}]] w x + set x +} 6442450944 +test binary-44.4 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {} { + binary scan [binary format W [expr {wide(3) << 31}]] W x + set x +} 6442450944 test binary-43.5 {Tcl_BinaryObjCmd: scan wide int} {} { unset -nocomplain arg1 list [binary scan \x80[string repeat \x00 7] W arg1] $arg1 } {1 -9223372036854775808} test binary-43.6 {Tcl_BinaryObjCmd: scan unsigned wide int} {} { @@ -1666,35 +1682,10 @@ test binary-43.9 {Tcl_BinaryObjCmd: scan unsigned wide int} {} { unset -nocomplain arg1 arg2 list [binary scan [string repeat \x00 7]\x80[string repeat \x00 7]\x80 wuw arg1 arg2] $arg1 $arg2 } {2 9223372036854775808 -9223372036854775808} -test binary-44.1 {Tcl_BinaryObjCmd: scan wide int} {} { - binary scan HelloTcl W x - set x -} 5216694956358656876 -test binary-44.2 {Tcl_BinaryObjCmd: scan wide int} {} { - binary scan lcTolleH w x - set x -} 5216694956358656876 -test binary-44.3 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {} { - binary scan [binary format w [expr {wide(3) << 31}]] w x - set x -} 6442450944 -test binary-44.4 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {} { - binary scan [binary format W [expr {wide(3) << 31}]] W x - set x -} 6442450944 -test binary-44.5 {Tcl_BinaryObjCmd: scan wide int with bit 31 and 64 set} {} { - binary scan [binary format w [expr {(wide(3) << 31) + (wide(3) << 64)}]] w x - set x -} 6442450944 -test binary-44.6 {Tcl_BinaryObjCmd: scan wide int with bit 31 and 64 set} {} { - binary scan [binary format W [expr {(wide(3) << 31) + (wide(3) << 64)}]] W x - set x -} 6442450944 - test binary-45.1 {Tcl_BinaryObjCmd: combined wide int handling} { binary scan [binary format sws 16450 -1 19521] c* x set x } {66 64 -1 -1 -1 -1 -1 -1 -1 -1 65 76} test binary-45.2 {Tcl_BinaryObjCmd: combined wide int handling} { @@ -2631,10 +2622,13 @@ binary encode base64 -maxlen 4 -wrapchar -*- abcabcabc } -result {YWJj-*-YWJj-*-YWJj} test binary-72.28 {binary encode base64} -body { binary encode base64 -maxlen 6 -wrapchar 0123456789 abcabcabc } -result {YWJjYW0123456789JjYWJj} +test binary-72.29 {binary encode base64} { + string length [binary encode base64 -maxlen 3 -wrapchar \xca abc] +} 5 test binary-73.1 {binary decode base64} -body { binary decode base64 } -returnCodes error -match glob -result "wrong # args: *" test binary-73.2 {binary decode base64} -body { @@ -2644,23 +2638,23 @@ binary decode base64 {} } -result {} test binary-73.4 {binary decode base64} -body { binary decode base64 [string repeat YWJj 20] } -result [string repeat abc 20] -test binary-73.5 {binary encode base64} -body { +test binary-73.5 {binary decode base64} -body { binary decode base64 AAECAwQAAQID } -result "\0\1\2\3\4\0\1\2\3" -test binary-73.6 {binary encode base64} -body { +test binary-73.6 {binary decode base64} -body { binary decode base64 AA== } -result "\0" -test binary-73.7 {binary encode base64} -body { +test binary-73.7 {binary decode base64} -body { binary decode base64 AAA= } -result "\0\0" -test binary-73.8 {binary encode base64} -body { +test binary-73.8 {binary decode base64} -body { binary decode base64 AAAA } -result "\0\0\0" -test binary-73.9 {binary encode base64} -body { +test binary-73.9 {binary decode base64} -body { binary decode base64 AAAAAA== } -result "\0\0\0\0" test binary-73.10 {binary decode base64} -body { set s "[string repeat YWJj 10]\n[string repeat YWJj 10]" binary decode base64 $s @@ -2716,11 +2710,11 @@ } -returnCodes error -match glob -result {invalid base64 character *} test binary-73.30 {binary decode base64} -body { list [string length [set r [binary decode base64 -strict WFla\n]]] $r } -returnCodes error -match glob -result {invalid base64 character *} test binary-73.31 {binary decode base64} -body { - list [string length [set r [binary decode base64 WA==WFla]]] $r + list [string length [set r [binary decode base64 -strict WA==WFla]]] $r } -returnCodes error -match glob -result {invalid base64 character *} test binary-73.32 {binary decode base64, bug [00d04c4f12]} -body { list \ [string length [binary decode base64 =]] \ [string length [binary decode base64 " ="]] \ @@ -2758,10 +2752,13 @@ } } } join $r \n } -result {} +test binary-73.37 {binary decode base64: Bug ffeb2097af} { + binary decode base64 [binary encode base64 -maxlen 3 -wrapchar : abc] +} abc test binary-74.1 {binary encode uuencode} -body { binary encode uuencode } -returnCodes error -match glob -result "wrong # args: *" test binary-74.2 {binary encode uuencode} -body { @@ -2795,15 +2792,21 @@ } test binary-74.10 {binary encode uuencode} -returnCodes error -body { binary encode uuencode -foo 30 abcabcabc } -result {bad option "-foo": must be -maxlen or -wrapchar} test binary-74.11 {binary encode uuencode} -returnCodes error -body { - binary encode uuencode -maxlen 1 abcabcabc + binary encode uuencode -maxlen 4 abcabcabc } -result {line length out of range} test binary-74.12 {binary encode uuencode} -body { - binary encode uuencode -maxlen 3 -wrapchar | abcabcabc -} -result {!80|!8@|!8P|!80|!8@|!8P|!80|!8@|!8P|} + binary encode uuencode -maxlen 5 -wrapchar \t abcabcabc +} -result #86)C\t#86)C\t#86)C\t +test binary-74.13 {binary encode uuencode} -body { + binary encode uuencode -maxlen 85 -wrapchar \t abcabcabc +} -result )86)C86)C86)C\t +test binary-74.14 {binary encode uuencode} -returnCodes error -body { + binary encode uuencode -maxlen 86 abcabcabc +} -result {line length out of range} test binary-75.1 {binary decode uuencode} -body { binary decode uuencode } -returnCodes error -match glob -result "wrong # args: *" test binary-75.2 {binary decode uuencode} -body { @@ -2897,28 +2900,20 @@ close $f # Append to it string length [append str [binary format a* foo]] } 3 -test binary-77.1 {string cat ops on all bytearrays} { - apply {{a b} { - return [binary format H* $a][binary format H* $b] - }} ab cd -} [binary format H* abcd] -test binary-77.2 {string cat ops on all bytearrays} { - apply {{a b} { - set one [binary format H* $a] - return $one[binary format H* $b] - }} ab cd -} [binary format H* abcd] - -test binary-78.1 {unicode (out of BMP) to byte-array conversion, bug-[bd94500678]} -body { - # just test for BO-segfault (high surrogate w/o advance source pointer for out of BMP char if TCL_UTF_MAX <= 4): - binary encode hex \U0001f415 - binary scan \U0001f415 a* v; set v - set str {} -} -result {} +testConstraint testsetbytearraylength \ + [expr {"testsetbytearraylength" in [info commands]}] + +test binary-79.1 {Tcl_SetByteArrayLength} testsetbytearraylength { + testsetbytearraylength [string cat A B C] 1 +} A +test binary-79.2 {Tcl_SetByteArrayLength} testsetbytearraylength { + testsetbytearraylength [string cat \u0141 B C] 1 +} A + # ---------------------------------------------------------------------- # cleanup ::tcltest::cleanupTests ADDED tests/case.test Index: tests/case.test ================================================================== --- /dev/null +++ tests/case.test @@ -0,0 +1,89 @@ +# Commands covered: case +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +test case-1.1 {simple pattern} { + case a in a {format 1} b {format 2} c {format 3} default {format 4} +} 1 +test case-1.2 {simple pattern} { + case b a {format 1} b {format 2} c {format 3} default {format 4} +} 2 +test case-1.3 {simple pattern} { + case x in a {format 1} b {format 2} c {format 3} default {format 4} +} 4 +test case-1.4 {simple pattern} { + case x a {format 1} b {format 2} c {format 3} +} {} +test case-1.5 {simple pattern matches many times} { + case b a {format 1} b {format 2} b {format 3} b {format 4} +} 2 +test case-1.6 {fancier pattern} { + case cx a {format 1} *c {format 2} *x {format 3} default {format 4} +} 3 +test case-1.7 {list of patterns} { + case abc in {a b c} {format 1} {def abc ghi} {format 2} +} 2 + +test case-2.1 {error in executed command} { + list [catch {case a in a {error "Just a test"} default {format 1}} msg] \ + $msg $::errorInfo +} {1 {Just a test} {Just a test + while executing +"error "Just a test"" + ("a" arm line 1) + invoked from within +"case a in a {error "Just a test"} default {format 1}"}} +test case-2.2 {error: not enough args} { + list [catch {case} msg] $msg +} {1 {wrong # args: should be "case string ?in? ?pattern body ...? ?default body?"}} +test case-2.3 {error: pattern with no body} { + list [catch {case a b} msg] $msg +} {1 {extra case pattern with no body}} +test case-2.4 {error: pattern with no body} { + list [catch {case a in b {format 1} c} msg] $msg +} {1 {extra case pattern with no body}} +test case-2.5 {error in default command} { + list [catch {case foo in a {error case1} default {error case2} \ + b {error case 3}} msg] $msg $::errorInfo +} {1 case2 {case2 + while executing +"error case2" + ("default" arm line 1) + invoked from within +"case foo in a {error case1} default {error case2} b {error case 3}"}} + +test case-3.1 {single-argument form for pattern/command pairs} { + case b in { + a {format 1} + b {format 2} + default {format 6} + } +} {2} +test case-3.2 {single-argument form for pattern/command pairs} { + case b { + a {format 1} + b {format 2} + default {format 6} + } +} {2} +test case-3.3 {single-argument form for pattern/command pairs} { + list [catch {case z in {a 2 b}} msg] $msg +} {1 {extra case pattern with no body}} + +# cleanup +::tcltest::cleanupTests +return Index: tests/chan.test ================================================================== --- tests/chan.test +++ tests/chan.test @@ -5,12 +5,12 @@ # Copyright (c) 2005 Donal K. Fellows # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } # # Note: The tests for the chan methods "create" and "postevent" @@ -133,11 +133,11 @@ } -returnCodes error -result "wrong # args: should be \"chan pending mode channelId\"" test chan-16.4 {chan command: pending subcommand} -body { chan pending {input output} stdout } -returnCodes error -result "bad mode \"input output\": must be input or output" test chan-16.5 {chan command: pending input subcommand} -body { - chan pending input stdout + chan pending input stdout } -result -1 test chan-16.6 {chan command: pending input subcommand} -body { chan pending input stdin } -result 0 test chan-16.7 {chan command: pending input subcommand} -body { @@ -171,11 +171,11 @@ set b [chan blocked $sock] set i [chan pending input $sock] lappend ::chan-16.9-data $r $l $e $b $i - if {$r != -1 || $e || $l || !$b || $i > 128} { + if {$r >= 0 || $e || $l || !$b || $i > 128} { set data [read $sock $i] lappend ::chan-16.9-data [string range $data 0 2] lappend ::chan-16.9-data [string range $data end-2 end] set ::chan-16.9-done 1 chan event $sock readable {} @@ -192,11 +192,11 @@ set ::server [socket -server chan-16.9-accept -myaddr 127.0.0.1 0] set ::client [socket 127.0.0.1 [lindex [fconfigure $::server -sockname] 2]] set ::chan-16.9-data [list] set ::chan-16.9-done 0 } -body { - after idle chan-16.9-client + after idle chan-16.9-client vwait ::chan-16.9-done set ::chan-16.9-data } -result {-1 0 0 1 36 -1 0 0 1 72 -1 0 0 1 108 -1 0 0 1 144 ABC 890} -cleanup { catch {chan close $client} catch {chan close $server} Index: tests/chanio.test ================================================================== --- tests/chanio.test +++ tests/chanio.test @@ -11,13 +11,12 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -# TODO: This test is likely worthless. Confirm and remove -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 } namespace eval ::tcl::test::io { namespace import ::tcltest::* @@ -37,14 +36,17 @@ } package require tcltests testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testchannel [llength [info commands testchannel]] - testConstraint openpipe 1 testConstraint testfevent [llength [info commands testfevent]] testConstraint testchannelevent [llength [info commands testchannelevent]] testConstraint testmainthread [llength [info commands testmainthread]] + testConstraint testservicemode [llength [info commands testservicemode]] + testConstraint notWinCI [expr { + $::tcl_platform(platform) ne "windows" || ![info exists ::env(CI)]}] + testConstraint notOSX [expr {$::tcl_platform(os) ne "Darwin"}] # You need a *very* special environment to do some tests. In particular, # many file systems do not support large-files... testConstraint largefileSupport [expr {$::tcl_platform(os) ne "Darwin"}] @@ -445,11 +447,11 @@ set f [open $path(test1)] list [chan gets $f line] $line } -cleanup { chan close $f } -result [list 256 $a] -test chan-io-6.7 {Tcl_GetsObj: error in input} -constraints {stdio openpipe} -body { +test chan-io-6.7 {Tcl_GetsObj: error in input} -constraints stdio -body { # if (FilterInputBytes(chanPtr, &gs) != 0) set f [openpipe w+ $path(cat)] chan puts -nonewline $f "hi\nwould" chan flush $f chan gets $f @@ -706,11 +708,11 @@ } -cleanup { chan close $f } -result [list 15 "123456789012345" 15] test chan-io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} -setup { set x "" -} -constraints {stdio testchannel openpipe fileevent} -body { +} -constraints {stdio testchannel fileevent} -body { # (FilterInputBytes() != 0) set f [openpipe w+ $path(cat)] chan configure $f -translation {crlf lf} -buffering none chan puts -nonewline $f "bbbbbbbbbbbbbb\r\n123456789012345\r" chan configure $f -buffersize 16 @@ -846,11 +848,11 @@ } -cleanup { chan close $f } -result {4 abcd 4 efgh 4 ijkl 4 mnop -1 {}} test chan-io-6.43 {Tcl_GetsObj: input saw cr} -setup { set x "" -} -constraints {stdio testchannel openpipe fileevent} -body { +} -constraints {stdio testchannel fileevent} -body { # if (chanPtr->flags & INPUT_SAW_CR) set f [openpipe w+ $path(cat)] chan configure $f -translation {auto lf} -buffering none chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" chan configure $f -buffersize 16 @@ -864,11 +866,11 @@ } -cleanup { chan close $f } -result {bbbbbbbbbbbbbbb 15 123456789abcdef 1 4 abcd 0 3 efg} test chan-io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} -setup { set x "" -} -constraints {stdio testchannel openpipe fileevent} -body { +} -constraints {stdio testchannel fileevent} -body { # not (*eol == '\n') set f [openpipe w+ $path(cat)] chan configure $f -translation {auto lf} -buffering none chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" chan configure $f -buffersize 16 @@ -882,11 +884,11 @@ } -cleanup { chan close $f } -result {bbbbbbbbbbbbbbb 15 123456789abcdef 1 4 abcd 0 3 efg} test chan-io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} -setup { set x "" -} -constraints {stdio testchannel openpipe fileevent} -body { +} -constraints {stdio testchannel fileevent} -body { # Tcl_ExternalToUtf() set f [openpipe w+ $path(cat)] chan configure $f -translation {auto lf} -buffering none chan configure $f -encoding unicode chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" @@ -900,11 +902,11 @@ } -cleanup { chan close $f } -result {15 123456789abcdef 1 4 abcd 0} test chan-io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} -setup { set x "" -} -constraints {stdio testchannel openpipe fileevent} -body { +} -constraints {stdio testchannel fileevent} -body { # memmove() set f [openpipe w+ $path(cat)] chan configure $f -translation {auto lf} -buffering none chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" chan configure $f -buffersize 16 @@ -1018,11 +1020,11 @@ chan close $f } -result [list 8 "there\u4e00ok" 11 "\u4e01more bytes" 4 "here"] test chan-io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} -setup { update variable x {} -} -constraints {stdio openpipe fileevent} -body { +} -constraints {stdio fileevent} -body { set f [openpipe w+ $path(cat)] chan configure $f -buffering none chan puts -nonewline $f "foobar" chan configure $f -blocking 0 after 500 [namespace code { @@ -1085,11 +1087,11 @@ } -cleanup { chan close $f } -result [list 15 "1234567890123\uff10\uff11" 18 0 1 -1 ""] test chan-io-7.4 {FilterInputBytes: recover from split up character} -setup { variable x "" -} -constraints {stdio openpipe fileevent} -body { +} -constraints {stdio fileevent} -body { set f [openpipe w+ $path(cat)] chan configure $f -encoding binary -buffering none chan puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82" chan configure $f -encoding shiftjis -blocking 0 chan event $f read [namespace code { @@ -1119,11 +1121,11 @@ } -cleanup { chan close $f } -result 7 test chan-io-8.2 {PeekAhead: only go to device if no more cached data} -setup { variable x {} -} -constraints {stdio testchannel openpipe fileevent} -body { +} -constraints {stdio testchannel fileevent} -body { # not (bufPtr->nextPtr == NULL) set f [openpipe w+ $path(cat)] chan configure $f -translation lf -encoding ascii -buffering none chan puts -nonewline $f "123456789012345\r\nbcdefghijklmnopqrstuvwxyz" chan event $f read [namespace code { @@ -1136,11 +1138,11 @@ vwait [namespace which -variable x] return $x } -cleanup { chan close $f } -result {-1 {} 42 15 123456789012345 25} -test chan-io-8.3 {PeekAhead: no cached data available} -constraints {stdio testchannel openpipe fileevent} -body { +test chan-io-8.3 {PeekAhead: no cached data available} -constraints {stdio testchannel fileevent} -body { # (bytesLeft == 0) set f [openpipe w+ $path(cat)] chan configure $f -translation {auto binary} chan puts -nonewline $f "abcdefghijklmno\r" chan flush $f @@ -1165,11 +1167,11 @@ chan gets $f } -cleanup { chan close $f } -result $a unset a -test chan-io-8.5 {PeekAhead: don't peek if last read was short} -constraints {stdio testchannel openpipe fileevent} -body { +test chan-io-8.5 {PeekAhead: don't peek if last read was short} -constraints {stdio testchannel fileevent} -body { # (bufPtr->nextAdded < bufPtr->length) set f [openpipe w+ $path(cat)] chan configure $f -translation {auto binary} chan puts -nonewline $f "abcdefghijklmno\r" chan flush $f @@ -1176,11 +1178,11 @@ # here list [chan gets $f line] $line [testchannel queuedcr $f] } -cleanup { chan close $f } -result {15 abcdefghijklmno 1} -test chan-io-8.6 {PeekAhead: change to non-blocking mode} -constraints {stdio testchannel openpipe fileevent} -body { +test chan-io-8.6 {PeekAhead: change to non-blocking mode} -constraints {stdio testchannel fileevent} -body { # ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0) set f [openpipe w+ $path(cat)] chan configure $f -translation {auto binary} -buffersize 16 chan puts -nonewline $f "abcdefghijklmno\r" chan flush $f @@ -1189,11 +1191,11 @@ } -cleanup { chan close $f } -result {15 abcdefghijklmno 1} test chan-io-8.7 {PeekAhead: cleanup} -setup { set x "" -} -constraints {stdio testchannel openpipe fileevent} -body { +} -constraints {stdio testchannel fileevent} -body { # Make sure bytes are removed from buffer. set f [openpipe w+ $path(cat)] chan configure $f -translation {auto binary} -buffering none chan puts -nonewline $f "abcdefghijklmno\r" # here @@ -1340,11 +1342,11 @@ } -cleanup { chan close $f } -result {abcdefghijklmnopqrstuvwxyz} test chan-io-12.4 {ReadChars: split-up char} -setup { variable x {} -} -constraints {stdio testchannel openpipe fileevent} -body { +} -constraints {stdio testchannel fileevent} -body { # (srcRead == 0) set f [openpipe w+ $path(cat)] chan configure $f -encoding binary -buffering none -buffersize 16 chan puts -nonewline $f "123456789012345\x96" chan configure $f -encoding shiftjis -blocking 0 @@ -1362,11 +1364,11 @@ } -cleanup { chan close $f } -result [list "123456789012345" 1 "\u672c" 0] test chan-io-12.5 {ReadChars: chan events on partial characters} -setup { variable x {} -} -constraints {stdio openpipe fileevent} -body { +} -constraints {stdio fileevent} -body { set path(test1) [makeFile { chan configure stdout -encoding binary -buffering none chan gets stdin; chan puts -nonewline "\xe7" chan gets stdin; chan puts -nonewline "\x89" chan gets stdin; chan puts -nonewline "\xa6" @@ -1455,11 +1457,11 @@ chan close $f } -result "abcd\ndef\nfgh" test chan-io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} -setup { variable x {} variable y {} -} -constraints {stdio testchannel openpipe fileevent} -body { +} -constraints {stdio testchannel fileevent} -body { # (chanPtr->flags & INPUT_SAW_CR) # This test may fail on slower machines. set f [openpipe w+ $path(cat)] chan configure $f -blocking 0 -buffering none -translation {auto lf} chan event $f read [namespace code { @@ -1473,11 +1475,11 @@ vwait [namespace which -variable y] return $x } -cleanup { chan close $f } -result [list "abcdefghj\n" 1 "01234" 0] -test chan-io-13.7 {TranslateInputEOL: auto mode: naked \r} -constraints {testchannel openpipe} -body { +test chan-io-13.7 {TranslateInputEOL: auto mode: naked \r} -constraints testchannel -body { # (src >= srcMax) set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "abcd\r" chan close $f @@ -1574,11 +1576,11 @@ lappend result [x eval {chan configure stderr -buffering}] } -cleanup { interp delete x } -result {line line none} set path(test3) [makeFile {} test3] -test chan-io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} -constraints {exec openpipe} -body { +test chan-io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} -constraints exec -body { set f [open $path(test1) w] chan puts -nonewline $f { chan close stdin chan close stdout chan close stderr @@ -1671,11 +1673,11 @@ } -result {{} {} {can not find channel named "stderr"}} set path(script) [makeFile {} script] test chan-io-14.8 {reuse of stdio special channels} -setup { file delete $path(script) file delete $path(test1) -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f [open $path(script) w] chan puts -nonewline $f { chan close stderr set f [} chan puts $f [list open $path(test1) w]] @@ -1694,11 +1696,11 @@ chan close $f } -result hello test chan-io-14.9 {reuse of stdio special channels} -setup { file delete $path(script) file delete $path(test1) -} -constraints {stdio openpipe fileevent} -body { +} -constraints {stdio fileevent} -body { set f [open $path(script) w] chan puts $f { array set path [lindex $argv 0] set f [open $path(test1) w] chan puts $f hello @@ -1878,11 +1880,11 @@ } -cleanup { chan close $f } -result {{{} {}} {auto lf}} test chan-io-20.5 {Tcl_CreateChannel: install channel in empty slot} -setup { set path(stdout) [makeFile {} stdout] -} -constraints {stdio openpipe} -body { +} -constraints {stdio notWinCI} -body { set f [open $path(script) w] chan puts -nonewline $f { chan close stdout set f1 [} chan puts $f [list open $path(stdout) w]] @@ -1963,11 +1965,11 @@ test chan-io-26.1 {Tcl_GetChannelInstanceData} -body { # "pid" command uses Tcl_GetChannelInstanceData # Don't care what pid is (but must be a number), just want to exercise it. set f [openpipe r << exit] pid $f -} -constraints {stdio openpipe} -cleanup { +} -constraints stdio -cleanup { chan close $f } -match regexp -result {^\d+$} # Test flushing. The functions tested here are FlushChannel. @@ -2022,11 +2024,11 @@ chan close $f } -result {0 60 72} test chan-io-27.5 {FlushChannel, implicit flush when buffer fills and on chan close} -setup { file delete $path(test1) set l "" -} -constraints {unixOrPc} -body { +} -constraints {unixOrWin} -body { set f [open $path(test1) w] chan configure $f -translation lf -buffersize 60 -eofchar {} lappend l [file size $path(test1)] for {set i 0} {$i < 12} {incr i} { chan puts $f hello @@ -2038,11 +2040,11 @@ set path(pipe) [makeFile {} pipe] set path(output) [makeFile {} output] test chan-io-27.6 {FlushChannel, async flushing, async chan close} -setup { file delete $path(pipe) file delete $path(output) -} -constraints {stdio asyncPipeChan Close openpipe} -body { +} -constraints {stdio asyncPipeChan Close} -body { set f [open $path(pipe) w] chan puts $f "set f \[[list open $path(output) w]]" chan puts $f { chan configure $f -translation lf -buffering none -eofchar {} while {![chan eof stdin]} { @@ -2108,11 +2110,11 @@ chan close $f } -result abcdef test chan-io-28.3 {Chan CloseChannel, not called before output queue is empty} -setup { file delete $path(pipe) file delete $path(output) -} -constraints {stdio asyncPipeChan Close nonPortable openpipe} -body { +} -constraints {stdio asyncPipeChan Close nonPortable} -body { set f [open $path(pipe) w] chan puts $f { # Need to not have eof char appended on chan close, because the other # side of the pipe already chan closed, so that writing would cause an # error "invalid file". @@ -2162,11 +2164,11 @@ $consoleFileNames] expr {$l eq $x ? "ok" : "{$l} != {$x}"} } -result ok test chan-io-28.5 {Tcl_Chan Close vs standard handles} -setup { file delete $path(script) -} -constraints {stdio unix testchannel openpipe} -body { +} -constraints {stdio unix testchannel} -body { set f [open $path(script) w] chan puts $f { chan close stdin chan puts [testchannel open] } @@ -2379,11 +2381,11 @@ file size $path(test1) } -result 377 test chan-io-29.12 {Tcl_WriteChars on a pipe} -setup { file delete $path(test1) file delete $path(pipe) -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [open $path(pipe) w] chan puts $f1 "set f1 \[[list open $path(longfile) r]]" chan puts $f1 { for {set x 0} {$x < 10} {incr x} { chan puts [chan gets $f1] @@ -2406,11 +2408,11 @@ chan close $f2 } -result ok test chan-io-29.13 {Tcl_WriteChars to a pipe, line buffered} -setup { file delete $path(test1) file delete $path(pipe) -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [open $path(pipe) w] chan puts $f1 { chan puts [chan gets stdin] chan puts [chan gets stdin] } @@ -2459,11 +2461,11 @@ } -returnCodes error -cleanup { catch {chan close $fd} } -match glob -result {channel "*" wasn't opened for writing} test chan-io-29.16 {Tcl_Flush on pipe opened only for reading} -setup { set fd [openpipe r cat longfile] -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { chan flush $fd } -returnCodes error -cleanup { catch {chan close $fd} } -match glob -result {channel "*" wasn't opened for writing} test chan-io-29.17 {Tcl_WriteChars buffers, then Tcl_Flush flushes} -setup { @@ -2535,11 +2537,11 @@ chan close $f1 lappend z [file size $path(test1)] } -result {4096 12288 12600} test chan-io-29.21 {Tcl_Flush to pipe} -setup { file delete $path(pipe) -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [open $path(pipe) w] chan puts $f1 {set x [chan read stdin 6]} chan puts $f1 {set cnt [string length $x]} chan puts $f1 {chan puts "read $cnt characters"} chan close $f1 @@ -2550,11 +2552,11 @@ } -cleanup { catch {chan close $f1} } -result "read 6 characters" test chan-io-29.22 {Tcl_Flush called at other end of pipe} -setup { file delete $path(pipe) -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [open $path(pipe) w] chan puts $f1 { chan configure stdout -buffering full chan puts hello chan puts hello @@ -2574,11 +2576,11 @@ } -cleanup { chan close $f1 } -result {hello hello bye} test chan-io-29.23 {Tcl_Flush and line buffering at end of pipe} -setup { file delete $path(pipe) -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [open $path(pipe) w] chan puts $f1 { chan puts hello chan puts hello chan gets stdin @@ -2611,11 +2613,11 @@ chan close $f2 chan close $f } -result "{} {Line 1\nLine 2}" test chan-io-29.25 {Implicit flush with Tcl_Flush to command pipelines} -setup { file delete $path(test3) -} -constraints {stdio openpipe fileevent} -body { +} -constraints {stdio fileevent} -body { set f [openpipe w $path(cat) | [interpreter] $path(cat) > $path(test3)] chan puts $f "Line 1" chan puts $f "Line 2" chan close $f after 100 @@ -2622,11 +2624,11 @@ set f [open $path(test3) r] chan read $f } -cleanup { chan close $f } -result "Line 1\nLine 2\n" -test chan-io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} -constraints {stdio unixExecs openpipe} -body { +test chan-io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} -constraints {stdio unixExecs} -body { set f [open "|[list cat -u]" r+] chan puts $f "Line1" chan flush $f chan gets $f } -cleanup { @@ -2635,11 +2637,11 @@ test chan-io-29.27 {Tcl_Flush on chan closed pipeline} -setup { file delete $path(pipe) set f [open $path(pipe) w] chan puts $f {exit} chan close $f -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f [openpipe r+ $path(pipe)] chan gets $f chan puts $f output after 50 # @@ -2688,11 +2690,11 @@ file size $path(test1) } -result 25 test chan-io-29.31 {Tcl_WriteChars, background flush} -setup { file delete $path(pipe) file delete $path(output) -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f [open $path(pipe) w] chan puts $f "set f \[[list open $path(output) w]]" chan puts $f {chan configure $f -translation lf} set x [list while {![chan eof stdin]}] set x "$x {" @@ -2721,19 +2723,19 @@ set result "file size only [file size $path(output)]" } else { set result ok } # allow a little time for the background process to chan close. - # otherwise, the following test fails on the [file delete $path(output) + # otherwise, the following test fails on the [file delete $path(output)] # on Windows because a process still has the file open. after 100 set v 1; vwait v return $result } -result ok test chan-io-29.32 {Tcl_WriteChars, background flush to slow reader} -setup { file delete $path(pipe) file delete $path(output) -} -constraints {stdio asyncPipeChan Close openpipe} -body { +} -constraints {stdio asyncPipeChan Close} -body { set f [open $path(pipe) w] chan puts $f "set f \[[list open $path(output) w]]" chan puts $f {chan configure $f -translation lf} set x [list while {![chan eof stdin]}] set x "$x \{" @@ -2788,11 +2790,11 @@ proc writelots {s l} { for {set i 0} {$i < 2000} {incr i} { chan puts $s $l } } -} -constraints {socket tempNotMac fileevent} -body { +} -constraints {socket tempNotMac fileevent notWinCI} -body { proc accept {s a p} { variable x chan event $s readable [namespace code [list readit $s]] chan configure $s -blocking off set x accepted @@ -2814,11 +2816,11 @@ chan configure $cs -blocking off writelots $cs $l chan close $cs chan close $ss vwait [namespace which -variable x] - return $c + set c } -result 2000 test chan-io-29.35 {Tcl_Chan Close vs chan event vs multiple interpreters} -setup { catch {interp delete x} catch {interp delete y} } -constraints {socket tempNotMac fileevent} -body { @@ -3042,11 +3044,11 @@ set f [open $path(test1) r] chan configure $f -translation auto string length [chan read $f] } -cleanup { chan close $f -} -result [expr 700*15+1] +} -result [expr {700*15 + 1}] test chan-io-30.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} -setup { file delete $path(test1) } -body { set f [open $path(test1) w] chan configure $f -translation crlf @@ -3059,11 +3061,11 @@ set f [open $path(test1) r] chan configure $f -translation crlf string length [chan read $f] } -cleanup { chan close $f -} -result [expr 700*15+1] +} -result [expr {700*15 + 1}] test chan-io-30.15 {Tcl_Write mixed, Tcl_Read auto} -setup { file delete $path(test1) } -body { set f [open $path(test1) w] chan configure $f -translation lf @@ -3901,11 +3903,11 @@ while {[chan gets $f line] >= 0} { append c $line\n } chan close $f string length $c -} -result [expr 700*15+1] +} -result [expr {700*15 + 1}] test chan-io-31.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} -setup { file delete $path(test1) set c "" } -body { set f [open $path(test1) w] @@ -3921,11 +3923,11 @@ while {[chan gets $f line] >= 0} { append c $line\n } chan close $f string length $c -} -result [expr 700*15+1] +} -result [expr {700*15 + 1}] # Test Tcl_Read and buffering. test chan-io-32.1 {Tcl_Read, channel not readable} -body { read stdout @@ -4002,11 +4004,11 @@ } set x } ok test chan-io-32.10 {Tcl_Read from a pipe} -setup { file delete $path(pipe) -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [open $path(pipe) w] chan puts $f1 {chan puts [chan gets stdin]} chan close $f1 set f1 [openpipe r+ $path(pipe)] chan puts $f1 hello @@ -4016,11 +4018,11 @@ chan close $f1 } -result "hello\n" test chan-io-32.11 {Tcl_Read from a pipe} -setup { file delete $path(pipe) set x "" -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [open $path(pipe) w] chan puts $f1 {chan puts [chan gets stdin]} chan puts $f1 {chan puts [chan gets stdin]} chan close $f1 set f1 [openpipe r+ $path(pipe)] @@ -4128,11 +4130,11 @@ chan close $f1 set z } ok test chan-io-33.3 {Tcl_Gets from pipe} -setup { file delete $path(pipe) -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [open $path(pipe) w] chan puts $f1 {chan puts [chan gets stdin]} chan close $f1 set f1 [openpipe r+ $path(pipe)] chan puts $f1 hello @@ -4338,11 +4340,11 @@ } -cleanup { chan close $f1 } -result {44 rstuv 49} test chan-io-34.8 {Tcl_Seek on pipes: not supported} -setup { set pipe [openpipe] -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { chan seek $pipe 0 current } -returnCodes error -cleanup { chan close $pipe } -match glob -result {error during seek on "*": invalid argument} test chan-io-34.9 {Tcl_Seek, testing buffered input flushing} -setup { @@ -4448,17 +4450,17 @@ chan seek $f1 10 current list $c1 [chan tell $f1] } -cleanup { chan close $f1 } -result {10 20} -test chan-io-34.16 {Tcl_Tell on pipe: always -1} -constraints {stdio openpipe} -body { +test chan-io-34.16 {Tcl_Tell on pipe: always -1} -constraints stdio -body { set f1 [openpipe] chan tell $f1 } -cleanup { chan close $f1 } -result -1 -test chan-io-34.17 {Tcl_Tell on pipe: always -1} {stdio openpipe} { +test chan-io-34.17 {Tcl_Tell on pipe: always -1} stdio { set f1 [openpipe] chan puts $f1 {chan puts hello} chan flush $f1 set c [chan tell $f1] chan gets $f1 @@ -4556,11 +4558,11 @@ lappend x [chan eof $f] lappend x [chan eof $f] } -cleanup { chan close $f } -result {0 0 0 0 1 1} -test chan-io-35.2 {Tcl_Eof with pipe} -constraints {stdio openpipe} -setup { +test chan-io-35.2 {Tcl_Eof with pipe} -constraints stdio -setup { file delete $path(pipe) } -body { set f1 [open $path(pipe) w] chan puts $f1 {chan gets stdin} chan puts $f1 {chan puts hello} @@ -4575,11 +4577,11 @@ chan gets $f1 lappend x [chan eof $f1] } -cleanup { chan close $f1 } -result {0 0 0 1} -test chan-io-35.3 {Tcl_Eof with pipe} -constraints {stdio openpipe} -setup { +test chan-io-35.3 {Tcl_Eof with pipe} -constraints stdio -setup { file delete $path(pipe) } -body { set f1 [open $path(pipe) w] chan puts $f1 {chan gets stdin} chan puts $f1 {chan puts hello} @@ -4613,11 +4615,11 @@ chan close $f } -result {{} 1} test chan-io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} -setup { file delete $path(pipe) set l "" -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f [open $path(pipe) w] chan puts $f { exit } chan close $f @@ -4798,11 +4800,11 @@ # Test Tcl_InputBlocked test chan-io-36.1 {Tcl_InputBlocked on nonblocking pipe} -setup { set x "" -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [openpipe] chan puts $f1 {chan puts hello_from_pipe} chan flush $f1 chan gets $f1 chan configure $f1 -blocking off -buffering full @@ -4818,11 +4820,11 @@ } -cleanup { chan close $f1 } -result {{} 1 hello 0 {} 1} test chan-io-36.2 {Tcl_InputBlocked on blocking pipe} -setup { set x "" -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [openpipe] chan configure $f1 -buffering line chan puts $f1 {chan puts hello_from_pipe} lappend x [chan gets $f1] lappend x [chan blocked $f1] @@ -5092,11 +5094,11 @@ chan close $f1 } -result {1 0 {} {} 0 1} test chan-io-39.10 {Tcl_SetChannelOption, blocking mode} -setup { file delete $path(pipe) set x "" -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [open $path(pipe) w] chan puts $f1 { chan gets stdin after 100 chan puts hi @@ -5189,11 +5191,11 @@ } -returnCodes error -cleanup { chan close $f } -result {unknown encoding "foobar"} test chan-io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} -setup { variable x {} -} -constraints {stdio openpipe fileevent} -body { +} -constraints {stdio fileevent} -body { set f [openpipe r+ $path(cat)] chan configure $f -encoding binary chan puts -nonewline $f "\xe7" chan flush $f chan configure $f -encoding utf-8 -blocking 0 @@ -5332,26 +5334,26 @@ test chan-io-40.2 {POSIX open access modes: CREAT} -setup { file delete $path(test3) } -constraints {unix} -body { set f [open $path(test3) {WRONLY CREAT} 0600] file stat $path(test3) stats - set x [format "%#o" [expr $stats(mode)&0o777]] + set x [format "%#o" [expr {$stats(mode) & 0o777}]] chan puts $f "line 1" chan close $f set f [open $path(test3) r] lappend x [chan gets $f] } -cleanup { chan close $f -} -result {0o600 {line 1}} +} -result {0600 {line 1}} test chan-io-40.3 {POSIX open access modes: CREAT} -setup { file delete $path(test3) } -constraints {unix umask} -body { # This test only works if your umask is 2, like ouster's. chan close [open $path(test3) {WRONLY CREAT}] file stat $path(test3) stats - format "%#o" [expr $stats(mode)&0o777] -} -result [format %#5o [expr {0o666 & ~ $umaskValue}]] + format "%#o" [expr {$stats(mode) & 0o777}] +} -result [format %#4o [expr {0o666 & ~ $umaskValue}]] test chan-io-40.4 {POSIX open access modes: CREAT} -setup { file delete $path(test3) } -body { set f [open $path(test3) w] chan configure $f -eofchar {} @@ -5549,11 +5551,11 @@ } {{script 1} {} {script 1} {write script} {} {write script} {} {}} test chan-io-43.2 {Tcl_FileeventCmd: deleting when many present} -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] set result {} -} -constraints {stdio unixExecs fileevent openpipe} -body { +} -constraints {stdio unixExecs fileevent} -body { lappend result [chan event $f r] [chan event $f2 r] [chan event $f3 r] chan event $f r "chan read f" chan event $f2 r "chan read f2" chan event $f3 r "chan read f3" lappend result [chan event $f r] [chan event $f2 r] [chan event $f3 r] @@ -5569,11 +5571,11 @@ } -result {{} {} {} {chan read f} {chan read f2} {chan read f3} {chan read f} {} {chan read f3} {chan read f} {} {} {} {} {}} test chan-io-44.1 {FileEventProc procedure: normal read event} -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] -} -constraints {stdio unixExecs fileevent openpipe} -body { +} -constraints {stdio unixExecs fileevent} -body { chan event $f2 readable [namespace code { set x [chan gets $f2]; chan event $f2 readable {} }] chan puts $f2 text; chan flush $f2 variable x initial @@ -5589,11 +5591,11 @@ proc myHandler {msg options} { variable x $msg } set handler [interp bgerror {}] interp bgerror {} [namespace which myHandler] -} -constraints {stdio unixExecs fileevent openpipe} -body { +} -constraints {stdio unixExecs fileevent} -body { chan event $f2 readable {error bogus} chan puts $f2 text; chan flush $f2 variable x initial vwait [namespace which -variable x] list $x [chan event $f2 readable] @@ -5603,11 +5605,11 @@ catch {chan close $f3} } -result {bogus {}} test chan-io-44.3 {FileEventProc procedure: normal write event} -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] -} -constraints {stdio unixExecs fileevent openpipe} -body { +} -constraints {stdio unixExecs fileevent} -body { chan event $f2 writable [namespace code { lappend x "triggered" incr count -1 if {$count <= 0} { chan event $f2 writable {} @@ -5629,21 +5631,23 @@ proc myHandler {msg options} { variable x $msg } set handler [interp bgerror {}] interp bgerror {} [namespace which myHandler] -} -constraints {stdio unixExecs fileevent openpipe} -body { +} -constraints {stdio unixExecs fileevent} -body { chan event $f2 writable {error bad-write} variable x initial vwait [namespace which -variable x] list $x [chan event $f2 writable] } -cleanup { interp bgerror {} $handler catch {chan close $f2} catch {chan close $f3} } -result {bad-write {}} -test chan-io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs openpipe fileevent} { +test chan-io-44.5 {FileEventProc procedure: end of file} -constraints { + stdio unixExecs fileevent +} -body { set f4 [openpipe r $path(cat) << foo] chan event $f4 readable [namespace code { if {[chan gets $f4 line] < 0} { lappend x eof chan event $f4 readable {} @@ -5652,13 +5656,14 @@ } }] variable x initial vwait [namespace which -variable x] vwait [namespace which -variable x] - chan close $f4 set x -} {initial foo eof} +} -cleanup { + chan close $f4 +} -result {initial foo eof} chan close $f makeFile "foo bar" foo test chan-io-45.1 {DeleteFileEvent, cleanup on chan close} {fileevent} { @@ -5715,23 +5720,24 @@ [catch {chan event $f3 readable}] } {0 {f script} 1 0 {f3 script} 0 {f script} 1 1 1 1 1} # Execute these tests only if the "testfevent" command is present. -test chan-io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent} { +test chan-io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent notOSX} { testfevent create set script "set f \[[list open $path(foo) r]]\n" append script { set x "no event" chan event $f readable [namespace code { set x "f triggered: [chan gets $f]" chan event $f readable {} }] } + set timer [after 10 lappend x timeout] testfevent cmd $script - after 1 ;# We must delay because Windows takes a little time to notice - update + vwait x + after cancel $timer testfevent cmd {chan close $f} list [testfevent cmd {set x}] [testfevent cmd {info commands after}] } {{f triggered: foo bar} after} test chan-io-46.2 {Tcl event loop vs multiple interpreters} testfevent { testfevent create @@ -5915,11 +5921,11 @@ list $x $l } {done {called called called called called called called}} set path(my_script) [makeFile {} my_script] test chan-io-48.3 {testing readability conditions} -setup { set l "" -} -constraints {stdio unix nonBlockFiles openpipe fileevent} -body { +} -constraints {stdio unix nonBlockFiles fileevent} -body { set f [open $path(bar) w] chan puts $f abcdefg chan puts $f abcdefg chan puts $f abcdefg chan puts $f abcdefg @@ -6369,51 +6375,56 @@ chan close $f } -result [list 7 a\rb\rc 7 {} 7 1] test chan-io-50.1 {testing handler deletion} -setup { file delete $path(test1) -} -constraints {testchannelevent} -body { +} -constraints testchannelevent -body { set f [open $path(test1) w] chan close $f set f [open $path(test1) r] + variable z not_called + set timer [after 50 lappend z timeout] + testservicemode 0 testchannelevent $f add readable [namespace code { variable z called testchannelevent $f delete 0 }] - variable z not_called - update - return $z + testservicemode 1 + vwait z + after cancel $timer + set z } -cleanup { chan close $f } -result called test chan-io-50.2 {testing handler deletion with multiple handlers} -setup { file delete $path(test1) chan close [open $path(test1) w] set z "" -} -constraints {testchannelevent} -body { - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list delhandler $f 1]] - testchannelevent $f add readable [namespace code [list delhandler $f 0]] +} -constraints {testchannelevent testservicemode} -body { proc delhandler {f i} { variable z lappend z "called delhandler $f $i" testchannelevent $f delete 0 } - update + set z "" + set timer [after 50 lappend z timeout] + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list delhandler $f 1]] + testchannelevent $f add readable [namespace code [list delhandler $f 0]] + testservicemode 1 + vwait z + after cancel $timer string equal $z \ [list [list called delhandler $f 0] [list called delhandler $f 1]] } -cleanup { chan close $f } -result 1 test chan-io-50.3 {testing handler deletion with multiple handlers} -setup { file delete $path(test1) chan close [open $path(test1) w] - set z "" -} -constraints {testchannelevent} -body { - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list notcalled $f 1]] - testchannelevent $f add readable [namespace code [list delhandler $f 0]] +} -constraints {testchannelevent testservicemode} -body { proc notcalled {f i} { variable z lappend z "notcalled was called!! $f $i" } proc delhandler {f i} { @@ -6421,11 +6432,19 @@ testchannelevent $f delete 1 lappend z "delhandler $f $i called" testchannelevent $f delete 0 lappend z "delhandler $f $i deleted myself" } - update + set z "" + set timer [after 50 lappend z timeout] + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list notcalled $f 1]] + testchannelevent $f add readable [namespace code [list delhandler $f 0]] + testservicemode 1 + vwait z + after cancel $timer string equal $z \ [list [list delhandler $f 0 called] \ [list delhandler $f 0 deleted myself]] } -cleanup { chan close $f @@ -6432,11 +6451,11 @@ } -result 1 test chan-io-50.4 {testing handler deletion vs reentrant calls} -setup { file delete $path(test1) set f [open $path(test1) w] chan close $f -} -constraints {testchannelevent} -body { +} -constraints testchannelevent -body { set f [open $path(test1) r] testchannelevent $f add readable [namespace code { if {$u eq "recursive"} { testchannelevent $f delete 0 lappend z "delrecursive deleting recursive" @@ -6446,23 +6465,24 @@ update } }] variable u toplevel variable z "" - update - return $z + set timer [after 50 lappend z timeout] + vwait z + after cancel $timer + set z } -cleanup { chan close $f + update } -result {{delrecursive calling recursive} {delrecursive deleting recursive}} test chan-io-50.5 {testing handler deletion vs reentrant calls} -setup { file delete $path(test1) set f [open $path(test1) w] chan close $f -} -constraints {testchannelevent} -body { - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list notcalled $f]] - testchannelevent $f add readable [namespace code [list del $f]] + update +} -constraints {testchannelevent testservicemode notOSX} -body { proc notcalled {f} { variable z lappend z "notcalled was called!! $f" } proc del {f} { @@ -6474,37 +6494,50 @@ lappend z "del deleted notcalled" lappend z "del deleted myself" } else { set u recursive lappend z "del calling recursive" - update + set timer [after 50 lappend z timeout] + set mode [test servicemode 1] + vwait z + after cancel $timer + test servicemode $mode lappend z "del after update" } } set z "" set u toplevel - update - return $z + set timer [after 50 lappend z timeout] + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list notcalled $f]] + testchannelevent $f add readable [namespace code [list del $f]] + testservicemode 1 + vwait z + after cancel $timer + set z } -cleanup { chan close $f + update } -result [list {del calling recursive} {del deleted notcalled} \ {del deleted myself} {del after update}] test chan-io-50.6 {testing handler deletion vs reentrant calls} -setup { file delete $path(test1) set f [open $path(test1) w] chan close $f -} -constraints {testchannelevent} -body { - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list second $f]] - testchannelevent $f add readable [namespace code [list first $f]] +} -constraints {testchannelevent testservicemode} -body { proc first {f} { variable u variable z if {$u eq "toplevel"} { lappend z "first called" + set mode [testservicemode 1] + set timer [after 50 lappend z timeout] set u first - update + vwait z + after cancel $timer + testservicemode $mode lappend z "first after update" } else { lappend z "first called not toplevel" } } @@ -6523,12 +6556,19 @@ testchannelevent $f removeall } } set z "" set u toplevel - update - return $z + set timer [after 50 lappend z timeout] + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list second $f]] + testchannelevent $f add readable [namespace code [list first $f]] + testservicemode 1 + vwait z + after cancel $timer + set z } -cleanup { chan close $f } -result [list {first called} {first called not toplevel} \ {second called, first time} {second called, second time} \ {first after update}] @@ -6675,11 +6715,11 @@ } -constraints {fcopy} -body { set f1 [open $thisScript] set f2 [open $path(test1) w] chan configure $f1 -translation lf -blocking 0 chan configure $f2 -translation lf -blocking 0 - set s0 [chan copy $f1 $f2 -size [expr [file size $thisScript] + 5]] + set s0 [chan copy $f1 $f2 -size [expr {[file size $thisScript] + 5}]] set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] chan close $f1 chan close $f2 set s1 [file size $thisScript] set s2 [file size $path(test1)] @@ -6706,11 +6746,11 @@ chan close $f2 } -result {0 0 ok} test chan-io-52.8 {TclCopyChannel} -setup { file delete $path(test1) file delete $path(pipe) -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { set f1 [open $path(pipe) w] chan configure $f1 -translation lf chan puts $f1 " chan puts ready chan gets stdin @@ -6827,11 +6867,11 @@ return $result } -result {0 0 ok} test chan-io-53.3 {CopyData: background read underflow} -setup { file delete $path(test1) file delete $path(pipe) -} -constraints {stdio unix openpipe fcopy} -body { +} -constraints {stdio unix fcopy} -body { set f1 [open $path(pipe) w] chan puts -nonewline $f1 { chan puts ready chan flush stdout ;# Don't assume line buffered! chan copy stdin stdout -command { set x } @@ -6865,11 +6905,11 @@ for {set x 0} {$x < 12} {incr x} { append big $big } file delete $path(test1) file delete $path(pipe) -} -constraints {stdio unix openpipe fileevent fcopy} -body { +} -constraints {stdio unix fileevent fcopy} -body { set f1 [open $path(pipe) w] chan puts $f1 { chan puts ready chan copy stdin stdout -command { set x } vwait x @@ -6917,11 +6957,11 @@ set out [socket 127.0.0.1 [lindex [chan configure $listen -sockname] 2]] catch {unset fcopyTestDone} chan close $listen ;# This means the socket open never really succeeds chan copy $in $out -command [namespace code FcopyTestDone] variable fcopyTestDone - if ![info exists fcopyTestDone] { + if {![info exists fcopyTestDone]} { vwait [namespace which -variable fcopyTestDone] ;# The error occurs here in the b.g. } chan close $in chan close $out set fcopyTestDone ;# 1 for error condition @@ -6929,19 +6969,19 @@ test chan-io-53.6 {CopyData: error during chan copy} -setup { variable fcopyTestDone file delete $path(pipe) file delete $path(test1) catch {unset fcopyTestDone} -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { set f1 [open $path(pipe) w] chan puts $f1 "exit 1" chan close $f1 set in [openpipe r+ $path(pipe)] set out [open $path(test1) w] chan copy $in $out -command [namespace code FcopyTestDone] variable fcopyTestDone - if ![info exists fcopyTestDone] { + if {![info exists fcopyTestDone]} { vwait [namespace which -variable fcopyTestDone] } return $fcopyTestDone ;# 0 for plain end of file } -cleanup { catch {chan close $in} @@ -6963,11 +7003,11 @@ } test chan-io-53.7 {CopyData: Flooding chan copy from pipe} -setup { variable fcopyTestDone file delete $path(pipe) catch {unset fcopyTestDone} -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { set fcopyTestCount 0 set f1 [open $path(pipe) w] chan puts $f1 { # Write 10 bytes / 10 msec proc Write {count} { @@ -6990,11 +7030,11 @@ variable fcopyTestDone if {![info exists fcopyTestDone]} { vwait [namespace which -variable fcopyTestDone] } # -1=error 0=script error N=number of bytes - expr ($fcopyTestDone == 0) ? $fcopyTestCount : -1 + expr {($fcopyTestDone == 0) ? $fcopyTestCount : -1} } -cleanup { catch {chan close $in} chan close $out } -result {3450} test chan-io-53.8 {CopyData: async callback and error handling, Bug 1932639} -setup { @@ -7013,11 +7053,11 @@ set foo [makeFile ashgdfashdgfasdhgfasdhgf foo] set bar [makeFile {} bar] # Channels to copy between set f [open $foo r] ; fconfigure $f -translation binary set g [open $bar w] ; fconfigure $g -translation binary -buffering none -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { # Record input size, so that result is always defined lappend ::RES [file size $bar] # Run the copy. Should not invoke -command now. chan copy $f $g -size 2 -command [namespace code cmd] # Check that -command was not called synchronously @@ -7030,11 +7070,11 @@ set ::forever has-been-reached }] vwait ::forever catch {after cancel $token} # Report - return $::RES + set ::RES } -cleanup { chan close $f chan close $g catch {unset ::RES} catch {unset ::forever} @@ -7053,11 +7093,11 @@ set foo [makeFile ashgdfashdgfasdhgfasdhgf foo] set bar [makeFile {} bar] # Channels to copy between set f [open $foo r] ; chan configure $f -translation binary set g [open $bar w] ; chan configure $g -translation binary -buffering none -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { # Initialize and force eof on the input. chan seek $f 0 end ; chan read $f 1 set ::RES [chan eof $f] # Run the copy. Should not invoke -command now. chan copy $f $g -size 2 -command [namespace code cmd] @@ -7111,11 +7151,11 @@ set ::forever OK return } set ::forever {} set out [open $out w] -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { chan copy $pipe $out -size 6 -command ::done set token [after 5000 { set ::forever {fcopy hangs} }] vwait ::forever @@ -7184,11 +7224,11 @@ set b [socket 127.0.0.1 9999] chan configure $a -translation binary -buffering none chan configure $b -translation binary -buffering none chan event $a readable [namespace code "done $a"] chan event $b readable [namespace code "done $b"] -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { # Now pass data through the server in both directions. set ::forever {} chan puts $a AB vwait ::forever chan puts $b BA @@ -7230,11 +7270,11 @@ # completes. set done 0 for {set i 0} {$i < 10} {incr i} { if {![catch { set cs [socket 127.0.0.1 [lindex [chan configure $ss -sockname] 2]] - }]} then { + }]} { set done 1 break } after 100 } @@ -7302,11 +7342,11 @@ producer vwait [namespace which -variable done] chan close $writer chan close $s after cancel $after - return $counter + set counter } -cleanup { if {$accept ne {}} {chan close $accept} } -result 1 set path(fooBar) [makeFile {} fooBar] @@ -7329,11 +7369,11 @@ } -body { set f [open $path(fooBar) w] chan event $f writable [namespace code [list eventScript $f]] variable x not_done vwait [namespace which -variable x] - return $x + set x } -cleanup { interp bgerror {} $handler } -result {got_error} test chan-io-56.1 {ChannelTimerProc} {testchannelevent} { @@ -7374,11 +7414,11 @@ variable result [chan gets $s2] after 1000 [namespace code {lappend result timer}] vwait [namespace which -variable result] lappend result [chan gets $s2] vwait [namespace which -variable result] - return $result + set result } -cleanup { chan close $s chan close $s2 chan close $server } -result {12 readable 34567890 timer} @@ -7399,18 +7439,18 @@ variable result [chan read $s2 1] after 1000 [namespace code {lappend result timer}] vwait [namespace which -variable result] lappend result [chan read $s2 9] vwait [namespace which -variable result] - return $result + set result } -cleanup { chan close $s chan close $s2 chan close $server } -result {1 readable 234567890 timer} -test chan-io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrPc openpipe fileevent} { +test chan-io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrWin fileevent} { set out [open $path(script) w] chan puts $out { chan puts "normal message from pipe" chan puts stderr "error message from pipe" exit 1 @@ -7444,11 +7484,11 @@ set result [testchannel mthread $f] chan close $f string equal $result [testmainthread] } {1} -test chan-io-60.1 {writing illegal utf sequences} {openpipe fileevent testbytestring} { +test chan-io-60.1 {writing illegal utf sequences} {fileevent testbytestring} { # This test will hang in older revisions of the core. set out [open $path(script) w] chan puts $out "catch {load $::tcltestlib Tcltest}" chan puts $out { chan puts [testbytestring \xe2] Index: tests/clock.test ================================================================== --- tests/clock.test +++ tests/clock.test @@ -9,12 +9,12 @@ # Copyright (c) 2004 by Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } if {[testConstraint win]} { if {[catch { @@ -29,10 +29,14 @@ testConstraint detroit \ [expr {![catch {clock format 0 -timezone :America/Detroit -format %z}]}] testConstraint y2038 \ [expr {[clock format 2158894800 -format %z -timezone :America/Detroit] eq {-0400}}] + +if {[namespace which -command ::tcl::unsupported::timerate] ne ""} { + namespace import ::tcl::unsupported::timerate +} # TEST PLAN # clock-1: # [clock format] - tests of bad and empty arguments @@ -247,22 +251,10 @@ if { ![dict exists $reg $path $key] } { return -code error "test case attempts to read unknown registry entry $path $key" } return [dict get $reg $path $key] } - -proc timeWithinDuration {duration start end} { - regexp {([\d.]+)(s|ms|us)} $duration -> duration unit - if {[llength $start] > 1} { set start [expr "([join $start +])/[llength $start]"] } - if {[llength $end] > 1} { set end [expr "([join $end +])/[llength $end]"] } - set delta [expr {$end - $start}] - expr { - ($delta > 0) && ($delta <= $duration) ? - "ok" : - "test should have taken 0-$duration $unit, actually took $delta"} -} - # Test some of the basics of [clock format] test clock-1.0 "clock format - wrong # args" { list [catch {clock format} msg] $msg $::errorCode @@ -35034,10 +35026,28 @@ set x2 [clock format $f2 -format %Y-%m-%d -timezone :UTC] set x3 [clock format $f3 -format %Y-%m-%d -timezone :UTC] set x4 [clock format $f4 -format %Y-%m-%d -timezone :UTC] list $x1 $x2 $x3 $x4 } {2000-02-29 2000-01-31 1999-12-31 1999-11-30} +test clock-30.8a {clock add months, negative, over threshold of a year} { + set t [clock scan 2019-01-31 -format %Y-%m-%d -gmt 1] + list [clock format [clock add $t -1 month -gmt 1] -format %Y-%m-%d -gmt 1] \ + [clock format [clock add $t -2 month -gmt 1] -format %Y-%m-%d -gmt 1] \ + [clock format [clock add $t -3 month -gmt 1] -format %Y-%m-%d -gmt 1] \ + [clock format [clock add $t -4 month -gmt 1] -format %Y-%m-%d -gmt 1] +} {2018-12-31 2018-11-30 2018-10-31 2018-09-30} +test clock-30.8b {clock add months, negative, over threshold of a year} { + set t [clock scan 2000-01-28 -format %Y-%m-%d -gmt 1] + for {set i 1} {$i < 24} {incr i 1} { + set f1 [clock add $t -$i month -gmt 1] + set f2 [clock add $f1 $i month -gmt 1] + if {$f2 != $t} { + error "\[clock add $t -$i month -gmt 1\] does not consider\ + \[clock add $f1 $i month -gmt 1\] != $t" + } + } +} {} test clock-30.9 {clock add days} { set t [clock scan {2000-01-01 12:34:56} -format {%Y-%m-%d %H:%M:%S} \ -timezone :UTC] set f1 [clock add $t 1 day -timezone :UTC] set f2 [clock add $t -1 day -timezone :UTC] @@ -35428,11 +35438,11 @@ # Legacy tests # clock clicks test clock-33.1 {clock clicks tests} { - expr [clock clicks]+1 + expr {[clock clicks] + 1} concat {} } {} test clock-33.2 {clock clicks tests} { set start [clock clicks] after 10 @@ -35441,60 +35451,80 @@ } {1} test clock-33.3 {clock clicks tests} { list [catch {clock clicks foo} msg] $msg } {1 {bad option "foo": must be -milliseconds or -microseconds}} test clock-33.4 {clock clicks tests} { - expr [clock clicks -milliseconds]+1 + expr {[clock clicks -milliseconds] + 1} concat {} } {} test clock-33.4a {clock milliseconds} { expr { [clock milliseconds] + 1 } concat {} } {} test clock-33.5 {clock clicks tests, millisecond timing test} { - set start [set end {}] - lassign [time { - lappend start [clock clicks -milli] - after 1 {lappend end [clock clicks -milli]} - vwait end - } 5] tm - timeWithinDuration [expr {int($tm/1000 + 1)}]ms $start $end + # This test can fail on a system that is so heavily loaded that + # the test takes >60 ms to run. + if {[lindex [timerate { + set start [clock clicks -milli] + timerate {} 10; # short but precise busy wait + set end [clock clicks -milli] + } 1 1] 0] > 60000} { + ::tcltest::Skip "timing issue" + } + # 60 msecs seems to be the max time slice under Windows 95/98 + expr { + ($end > $start) && (($end - $start) <= 60) ? + "ok" : + "test should have taken 0-60 ms, actually took [expr $end - $start]"} } {ok} test clock-33.5a {clock tests, millisecond timing test} { - set start [set end {}] - lassign [time { - lappend start [clock milliseconds] - after 1 {lappend end [clock milliseconds]} - vwait end - } 5] tm - timeWithinDuration [expr {int($tm/1000 + 1)}]ms $start $end + # This test can fail on a system that is so heavily loaded that + # the test takes >60 ms to run. + if {[lindex [timerate { + set start [clock milliseconds] + timerate {} 10; # short but precise busy wait + set end [clock milliseconds] + } 1 1] 0] > 60000} { + ::tcltest::Skip "timing issue" + } + # 60 msecs seems to be the max time slice under Windows 95/98 + expr { + ($end > $start) && (($end - $start) <= 60) ? + "ok" : + "test should have taken 0-60 ms, actually took [expr $end - $start]"} } {ok} test clock-33.6 {clock clicks, milli with too much abbreviation} { list [catch { clock clicks ? } msg] $msg } {1 {bad option "?": must be -milliseconds or -microseconds}} test clock-33.7 {clock clicks, milli with too much abbreviation} { list [catch { clock clicks - } msg] $msg } {1 {ambiguous option "-": must be -milliseconds or -microseconds}} test clock-33.8 {clock clicks test, microsecond timing test} { - set start [set end {}] - lassign [time { - lappend start [clock clicks -micro] - after 1 {lappend end [clock clicks -micro]} - vwait end - } 5] tm - timeWithinDuration [expr {int($tm + 10)}]us $start $end -} {ok} + # This test can fail on a system that is so heavily loaded that + # the test takes >60 ms to run. + if {[lindex [timerate { + set start [clock clicks -micro] + timerate {} 10; # short but precise busy wait + set end [clock clicks -micro] + } 1 1] 0] > 60000} { + ::tcltest::Skip "timing issue" + } + expr {($end > $start) && (($end - $start) <= 60000)} +} {1} test clock-33.8a {clock test, microsecond timing test} { - set start [set end {}] - lassign [time { - lappend start [clock microseconds] - after 1 {lappend end [clock microseconds]} - vwait end - } 5] tm - timeWithinDuration [expr {int($tm + 10)}]us $start $end -} {ok} + # This test can fail on a system that is so heavily loaded that + # the test takes >60 ms to run. + if {[lindex [timerate { + set start [clock microseconds] + timerate {} 10; # short but precise busy wait + set end [clock microseconds] + } 1 1] 0] > 60000} { + ::tcltest::Skip "timing issue" + } + expr {($end > $start) && (($end - $start) <= 60000)} +} {1} test clock-33.9 {clock clicks test, millis align with seconds} { set t1 [clock seconds] while { 1 } { set t2 [clock clicks -millis] @@ -35602,11 +35632,10 @@ } {Jan 01,1971 00:00 GMT} test clock-34.11 {clock scan tests} { set time [clock scan "1/1/37" -gmt true] clock format $time -format {%b %d,%Y %H:%M GMT} -gmt true } {Jan 01,2037 00:00 GMT} - test clock-34.12 {clock scan, relative times} { set time [clock scan "Oct 23, 1992 -1 day"] clock format $time -format {%b %d, %Y} } "Oct 22, 1992" test clock-34.13 {clock scan, ISO 8601 base date format} { @@ -35754,11 +35783,10 @@ set monday [clock scan "monday 1 week ago" -base $dec1th] lappend res [clock format $monday -format %Y-%m-%d] } set res } {1991-11-25 1992-11-30 1993-11-29 1994-11-28 1995-11-27 1996-11-25} - test clock-34.44 {2nd monday in november} { set res {} foreach i {91 92 93 94 95 96} { set nov8th [clock scan 11/8/$i -gmt 1] set monday [clock scan monday -base $nov8th -gmt 1] @@ -35787,46 +35815,103 @@ test clock-34.47 {ago with multiple relative units} { set base [clock scan "12/31/1999 00:00:00"] set res [clock scan "2 days 2 hours ago" -base $base] expr {$base - $res} } 180000 - test clock-34.48 {more than one ToD} {*}{ -body {clock scan {10:00 11:00}} -returnCodes error -result {unable to convert date-time string "10:00 11:00": more than one time of day in string} } - test clock-34.49 {more than one date} {*}{ -body {clock scan {1/1/2001 2/2/2002}} -returnCodes error -result {unable to convert date-time string "1/1/2001 2/2/2002": more than one date in string} } - test clock-34.50 {more than one time zone} {*}{ -body {clock scan {10:00 EST CST}} -returnCodes error -result {unable to convert date-time string "10:00 EST CST": more than one time zone in string} } - test clock-34.51 {more than one weekday} {*}{ -body {clock scan {Monday Tuesday}} -returnCodes error -result {unable to convert date-time string "Monday Tuesday": more than one weekday in string} } - test clock-34.52 {more than one ordinal month} {*}{ -body {clock scan {next January next March}} -returnCodes error -result {unable to convert date-time string "next January next March": more than one ordinal month in string} } - - +test clock-34.53 {clock scan, ISO 8601 point in time format} { + set time [clock scan "19921023T00:00:00"] + clock format $time -format {%b %d, %Y %H:%M:%S} +} "Oct 23, 1992 00:00:00" +test clock-34.54 {clock scan, ISO 8601 point in time format} { + set time [clock scan "1992-10-23T00:00:00"] + clock format $time -format {%b %d, %Y %H:%M:%S} +} "Oct 23, 1992 00:00:00" +test clock-34.55 {clock scan, ISO 8601 invalid TZ} -body { + set time [clock scan "19921023MST000000"] + clock format $time -format {%b %d, %Y %H:%M:%S} +} -returnCodes error -match glob -result {unable to convert date-time string*} +test clock-34.56 {clock scan, ISO 8601 invalid TZ} -body { + set time [clock scan "19921023M000000"] + clock format $time -format {%b %d, %Y %H:%M:%S} +} -returnCodes error -match glob -result {unable to convert date-time string*} +test clock-34.57 {clock scan, ISO 8601 invalid TZ} -body { + set time [clock scan "1992-10-23M00:00:00"] + clock format $time -format {%b %d, %Y %H:%M:%S} +} -returnCodes error -match glob -result {unable to convert date-time string*} +test clock-34.58 {clock scan, ISO 8601 invalid TZ} -body { + set time [clock scan "1992-10-23MST00:00:00"] + clock format $time -format {%b %d, %Y %H:%M:%S} +} -returnCodes error -match glob -result {unable to convert date-time string*} +test clock-34.59 {clock scan tests (-TZ)} { + set time [clock scan "31 Jan 14 23:59:59 -0100"] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Feb 01,2014 00:59:59 GMT} +test clock-34.60 {clock scan tests (+TZ)} { + set time [clock scan "31 Jan 14 23:59:59 +0100"] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Jan 31,2014 22:59:59 GMT} +test clock-34.61 {clock scan tests (-TZ)} { + set time [clock scan "23:59:59 -0100" -base 0 -gmt true] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Jan 02,1970 00:59:59 GMT} +test clock-34.62 {clock scan tests (+TZ)} { + set time [clock scan "23:59:59 +0100" -base 0 -gmt true] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Jan 01,1970 22:59:59 GMT} +test clock-34.63 {clock scan tests (TZ)} { + set time [clock scan "Mon, 30 Jun 2014 23:59:59 CEST"] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Jun 30,2014 21:59:59 GMT} +test clock-34.64 {clock scan tests (TZ)} { + set time [clock scan "Fri, 31 Jan 2014 23:59:59 CET"] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Jan 31,2014 22:59:59 GMT} +test clock-34.65 {clock scan tests (relspec, day unit not TZ)} { + set time [clock scan "23:59:59 +15 day" -base 2000000 -gmt true] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Feb 08,1970 23:59:59 GMT} +test clock-34.66 {clock scan tests (relspec, day unit not TZ)} { + set time [clock scan "23:59:59 -15 day" -base 2000000 -gmt true] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Jan 09,1970 23:59:59 GMT} +test clock-34.67 {clock scan tests (merid and TZ)} { + set time [clock scan "10:59 pm CET" -base 2000000 -gmt true] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Jan 24,1970 21:59:00 GMT} +test clock-34.68 {clock scan tests (merid and TZ)} { + set time [clock scan "10:59 pm +0100" -base 2000000 -gmt true] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Jan 24,1970 21:59:00 GMT} # clock seconds test clock-35.1 {clock seconds tests} { - expr [clock seconds]+1 + expr {[clock seconds] + 1} concat {} } {} test clock-35.2 {clock seconds tests} { list [catch {clock seconds foo} msg] $msg } {1 {wrong # args: should be "clock seconds"}} @@ -36918,16 +37003,14 @@ test clock-67.2 {Bug d19a30db57} -body { # error, not segfault tcl::clock::GetJulianDayFromEraYearMonthDay {} 2361222 } -returnCodes error -match glob -result * - test clock-67.3 {Bug d19a30db57} -body { # error, not segfault tcl::clock::GetJulianDayFromEraYearWeekDay {} 2361222 } -returnCodes error -match glob -result * - test clock-67.4 {Change format %x output on global locale change [Bug 4a0c163d24]} -setup { package require msgcat set current [msgcat::mclocale] } -body { msgcat::mclocale de_de @@ -36935,11 +37018,10 @@ msgcat::mclocale en_uk lappend res [regexp {^\d{2}/\d{2}/\d{4}$} [clock format 1 -locale current -format %x]] } -cleanup { msgcat::mclocale $current } -result {1 1} - test clock-67.5 {Change scan %x output on global locale change [Bug 4a0c163d24]} -setup { package require msgcat set current [msgcat::mclocale] } -body { msgcat::mclocale de_de Index: tests/cmdAH.test ================================================================== --- tests/cmdAH.test +++ tests/cmdAH.test @@ -19,10 +19,14 @@ catch [list package require -exact Tcltest [info patchlevel]] testConstraint testchmod [llength [info commands testchmod]] testConstraint testsetplatform [llength [info commands testsetplatform]] testConstraint testvolumetype [llength [info commands testvolumetype]] +testConstraint time64bit [expr { + $::tcl_platform(pointerSize) >= 8 || + [llength [info command testsize]] && [testsize st_mtime] >= 8 +}] testConstraint linkDirectory [expr { ![testConstraint win] || ($::tcl_platform(osVersion) >= 5.0 && [lindex [file system [temporaryDirectory]] 1] eq "NTFS") }] @@ -56,10 +60,12 @@ break foo } -returnCodes error -result {wrong # args: should be "break"} test cmdAH-0.2 {Tcl_BreakObjCmd, success} { list [catch {break} msg] $msg } {3 {}} + +# Tcl_CaseObjCmd is tested in case.test test cmdAH-1.1 {Tcl_CatchObjCmd, errors} -returnCodes error -body { catch } -result {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"} test cmdAH-1.2 {Tcl_CatchObjCmd, errors} { @@ -231,11 +237,11 @@ test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body { file } -result {wrong # args: should be "file subcommand ?arg ...?"} test cmdAH-5.2 {Tcl_FileObjCmd} -returnCodes error -body { file x -} -result {unknown or ambiguous subcommand "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, type, volumes, or writable} +} -result {unknown or ambiguous subcommand "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempfile, type, volumes, or writable} test cmdAH-5.3 {Tcl_FileObjCmd} -returnCodes error -body { file exists } -result {wrong # args: should be "file exists name"} test cmdAH-5.4 {Tcl_FileObjCmd} { file exists "" @@ -884,11 +890,11 @@ # file to be executable. testchmod 0o775 $gorpfile file exe $gorpfile } 1 test cmdAH-18.5 {Tcl_FileObjCmd: executable} -constraints {win} -body { - # On pc, must be a .exe, .com, etc. + # On windows, must be a .exe, .com, etc. set x {} set gorpexes {} foreach ext {exe com cmd bat} { lappend x [file exe nosuchfile.$ext] set gorpexe [makeFile foo gorp.$ext] @@ -1084,11 +1090,11 @@ } -result {atime ctime dev gid ino mode mtime nlink size type uid} test cmdAH-23.4 {Tcl_FileObjCmd: lstat} -setup { unset -nocomplain stat } -constraints {unix nonPortable} -body { file lstat $linkfile stat - list $stat(nlink) [expr $stat(mode)&0777] $stat(type) + list $stat(nlink) [expr {$stat(mode) & 0o777}] $stat(type) } -result {1 511 link} test cmdAH-23.5 {Tcl_FileObjCmd: lstat errors} {nonPortable} { list [catch {file lstat _bogus_ stat} msg] [string tolower $msg] \ $errorCode } {1 {could not read "_bogus_": no such file or directory} {POSIX ENOENT {no such file or directory}}} @@ -1286,16 +1292,52 @@ Tcl_FileObjCmd: mtime (built-in Windows names with dir path and extension) } -constraints {win} -body { file mtime [file join [temporaryDirectory] CON.txt] } -match regexp -result {could not (?:get modification time|read)} -returnCodes error +# 3155760000 is 64-bit unix time, Wed Jan 01 00:00:00 GMT 2070: +test cmdAH-24.20.1 {Tcl_FileObjCmd: atime 64-bit time_t, bug [4718b41c56]} -constraints {time64bit} -setup { + set filename [makeFile "" foo.text] +} -body { + list [file atime $filename 3155760000] [file atime $filename] +} -cleanup { + removeFile $filename +} -result {3155760000 3155760000} +test cmdAH-24.20.2 {Tcl_FileObjCmd: mtime 64-bit time_t, bug [4718b41c56]} -constraints {time64bit} -setup { + set filename [makeFile "" foo.text] +} -body { + list [file mtime $filename 3155760000] [file mtime $filename] +} -cleanup { + file delete -force $filename +} -result {3155760000 3155760000} + # owned test cmdAH-25.1 {Tcl_FileObjCmd: owned} -returnCodes error -body { file owned a b } -result {wrong # args: should be "file owned name"} -test cmdAH-25.2 {Tcl_FileObjCmd: owned} -constraints win -body { - file owned $gorpfile +test cmdAH-25.2 {Tcl_FileObjCmd: owned} -constraints win -setup { + set fn $gorpfile + # prefer temp file to check owner (try to avoid bug [7de2d722bd]): + if { + [info exists ::env(TEMP)] && [file isdirectory $::env(TEMP)] && + [file dirname $fn] ne [file normalize $::env(TEMP)] + } { + set fn [file join $::env(TEMP)/test-owner-from-tcl.txt] + set fn [makeFile "data" test-owner-from-tcl.txt $::env(TEMP)] + } + # be sure we have really owned this file before trying to check that + # (avoid dependency on admin with UAC and the setting "System objects: + # Default owner for objects created by members of the Administrators group"): + catch { + exec takeown /F [file nativename $fn] + } +} -body { + file owned $fn +} -cleanup { + if {$fn ne $gorpfile} { + removeFile $fn + } } -result 1 test cmdAH-25.2.1 {Tcl_FileObjCmd: owned} -constraints unix -setup { # Avoid problems with AFS set tmpfile [makeFile "data" touch.me /tmp] } -body { @@ -1305,11 +1347,15 @@ } -result 1 test cmdAH-25.3 {Tcl_FileObjCmd: owned} {unix notRoot} { file owned / } 0 test cmdAH-25.3.1 {Tcl_FileObjCmd: owned} -constraints win -body { - file owned $env(windir) + if {[info exists env(SystemRoot)]} { + file owned $env(SystemRoot) + } else { + file owned $env(windir) + } } -result 0 test cmdAH-25.4 {Tcl_FileObjCmd: owned} -body { file owned nosuchfile } -result 0 @@ -1522,11 +1568,11 @@ } -result "characterSpecial" # Error conditions test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file gorp x -} -result {unknown or ambiguous subcommand "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, type, volumes, or writable} +} -result {unknown or ambiguous subcommand "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempfile, type, volumes, or writable} test cmdAH-30.2 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file ex x } -match glob -result {unknown or ambiguous subcommand "ex": must be *} test cmdAH-30.3 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file is x @@ -1590,11 +1636,11 @@ } [list $newFileId $newFileId] test cmdAH-31.9 {Tcl_FileObjCmd: channels in other interp} { lsort [safeInterp eval [list file channels]] } [lsort [list stdout $newFileId]] test cmdAH-31.10 {Tcl_FileObjCmd: channels in other interp} { - # we can now write to $newFileId from slave + # we can now write to $newFileId from child safeInterp eval [list puts $newFileId "hello"] } {} interp transfer {} $newFileId safeInterp test cmdAH-31.11 {Tcl_FileObjCmd: channels in other interp} { # $newFileId should now be visible only in safeInterp @@ -1654,66 +1700,10 @@ expr {[string match $template*.bar $name] ? "ok" : "$template.bar produced $name"} } -constraints {unix nonPortable} -cleanup { catch {file delete $name} } -result ok - -test cmdAH-33.1 {file tempdir} -body { - file tempdir a b -} -returnCodes error -result {wrong # args: should be "file tempdir ?template?"} -test cmdAH-33.2 {file tempdir} -body { - set d [file tempdir] - list [file tail $d] [file exists $d] [file type $d] \ - [glob -nocomplain -directory $d *] -} -match glob -result {tcl_* 1 directory {}} -cleanup { - catch {file delete $d} -} -test cmdAH-33.3 {file tempdir} -body { - set d [file tempdir gorp] - list [file tail $d] [file exists $d] [file type $d] \ - [glob -nocomplain -directory $d *] -} -match glob -result {gorp_* 1 directory {}} -cleanup { - catch {file delete $d} -} -test cmdAH-33.4 {file tempdir} -setup { - set base [file join [temporaryDirectory] gorp] - file mkdir $base -} -body { - set pre [glob -nocomplain -directory $base *] - set d [file normalize [file tempdir $base/]] - list [string map [list $base GORP:] $d] [file exists $d] [file type $d] \ - $pre [glob -nocomplain -directory $d *] -} -match glob -result {GORP:/tcl_* 1 directory {} {}} -cleanup { - catch {file delete -force $base} -} -test cmdAH-33.5 {file tempdir} -setup { - set base [file join [temporaryDirectory] gorp] - file mkdir $base -} -body { - set pre [glob -nocomplain -directory $base *] - set d [file normalize [file tempdir $base/gorp]] - list [string map [list $base GORP:] $d] [file exists $d] [file type $d] \ - $pre [glob -nocomplain -directory $d *] -} -match glob -result {GORP:/gorp_* 1 directory {} {}} -cleanup { - catch {file delete -force $base} -} -test cmdAH-33.6 {file tempdir: missing parent dir} -setup { - set base [file join [temporaryDirectory] gorp] - file mkdir $base -} -returnCodes error -body { - file tempdir $base/quux/ -} -cleanup { - catch {file delete -force $base} -} -result {can't create temporary directory: no such file or directory} -test cmdAH-33.7 {file tempdir: missing parent dir} -setup { - set base [file join [temporaryDirectory] gorp] - file mkdir $base -} -returnCodes error -body { - file tempdir $base/quux/foobar -} -cleanup { - catch {file delete -force $base} -} -result {can't create temporary directory: no such file or directory} # This shouldn't work, but just in case a test above failed... catch {close $newFileId} interp delete safeInterp Index: tests/cmdIL.test ================================================================== --- tests/cmdIL.test +++ tests/cmdIL.test @@ -6,22 +6,24 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] testConstraint testobj [llength [info commands testobj]] - +source [file join [file dirname [info script]] internals.tcl] +namespace import -force ::tcltest::internals::* + test cmdIL-1.1 {Tcl_LsortObjCmd procedure} -returnCodes error -body { lsort } -result {wrong # args: should be "lsort ?-option value ...? list"} test cmdIL-1.2 {Tcl_LsortObjCmd procedure} -returnCodes error -body { lsort -foo {1 3 2 5} @@ -145,22 +147,10 @@ lsort -stride 2 -index {0 1} { {{c o d e} 54321} {{b l a h} 94729} {{b i g} 12345} {{d e m o} 34512} } } {{{b i g} 12345} {{d e m o} 34512} {{c o d e} 54321} {{b l a h} 94729}} -test cmdIL-1.37 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} { - lsort -ascii [list \0 \x7f \x80 \uffff] -} [list \0 \x7f \x80 \uffff] -test cmdIL-1.38 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} { - lsort -ascii -nocase [list \0 \x7f \x80 \uffff] -} [list \0 \x7f \x80 \uffff] -test cmdIL-1.39 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} { - lsort -ascii [list \0 \x7f \x80 \U01ffff \uffff] -} [list \0 \x7f \x80 \uffff \U01ffff] -test cmdIL-1.40 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} { - lsort -ascii -nocase [list \0 \x7f \x80 \U01ffff \uffff] -} [list \0 \x7f \x80 \uffff \U01ffff] test cmdIL-1.41 {lsort -stride and -index} -body { lsort -stride 2 -index -2 {a 2 b 1} } -returnCodes error -result {index "-2" cannot select an element from any list} test cmdIL-1.42 {lsort -stride and-index} -body { lsort -stride 2 -index -1-1 {a 2 b 1} @@ -230,11 +220,11 @@ test cmdIL-3.5.3 {SortCompare procedure, -index option (out of range, calculated index)} -body { lsort -index -2 {{1 . c} {2 . b} {3 . a}} } -returnCodes error -result {index "-2" cannot select an element from any list} test cmdIL-3.5.4 {SortCompare procedure, -index option (out of range, calculated index)} -body { lsort -index end-4 {{1 . c} {2 . b} {3 . a}} -} -returnCodes error -result {element end-4 missing from sublist "1 . c"} +} -returnCodes error -result {element -2 missing from sublist "1 . c"} test cmdIL-3.5.5 {SortCompare procedure, -index option} { lsort -index {} {a b} } {a b} test cmdIL-3.5.6 {SortCompare procedure, -index option} { lsort -index {} [list a \{] @@ -246,13 +236,10 @@ lsort -index end+1 {{1 . c} {2 . b} {3 . a}} } -returnCodes error -result {index "end+1" cannot select an element from any list} test cmdIL-3.5.9 {SortCompare procedure, -index option (out of range, calculated index)} -body { lsort -index end+2 {{1 . c} {2 . b} {3 . a}} } -returnCodes error -result {index "end+2" cannot select an element from any list} -test cmdIL-3.5.10 {SortCompare procedure, -index option (out of range, calculated index)} -body { - lsort -index 0 {{}} -} -returnCodes error -result {element 0 missing from sublist ""} test cmdIL-3.6 {SortCompare procedure, -index option} { lsort -integer -index 2 {{1 15 30} {2 5 25} {3 25 20}} } {{3 25 20} {2 5 25} {1 15 30}} test cmdIL-3.7 {SortCompare procedure, -ascii option} { lsort -ascii {d e c b a d35 d300 100 20} @@ -265,12 +252,12 @@ } -returnCodes error -result {expected integer but got "x"} test cmdIL-3.10 {SortCompare procedure, -integer option} -body { lsort -integer {3 q} } -returnCodes error -result {expected integer but got "q"} test cmdIL-3.11 {SortCompare procedure, -integer option} { - lsort -integer {35 21 0x20 0d30 0o23 100 8} -} {8 0o23 21 0d30 0x20 35 100} + lsort -integer {35 21 0x20 30 0o23 100 8} +} {8 0o23 21 30 0x20 35 100} test cmdIL-3.12 {SortCompare procedure, -real option} -body { lsort -real {6...4 3} } -returnCodes error -result {expected floating-point number but got "6...4"} test cmdIL-3.13 {SortCompare procedure, -real option} -body { lsort -real {3 1x7} @@ -509,18 +496,33 @@ proc test_lsort {l} { set n $l foreach e $l {lappend n [list [expr {rand()}] $e]} lindex [lsort -real -index $l $n] 1 1 } - expr srand(1) + expr {srand(1)} test_lsort 0 } -result 0 -cleanup { rename test_lsort "" } test cmdIL-5.6 {lsort with multiple list-style index options} { lsort -index {1 2 3} -index 0 {{a b} {c d} {b e}} } {{a b} {b e} {c d}} +test cmdIL-5.7 {lsort memory exhaustion} -constraints {testWithLimit} -body { + # test it in child process (with limited address space) ca. 80MB extra memory + # on x64 system it would be not enough to sort 4M items (the half 2M only), + # warn and skip if no error (enough memory) or error by list creation: + testWithLimit \ + -warn-on-code 0 -warn-on-alloc-error 1 \ + -addmem [expr {$tcl_platform(pointerSize)*4000000 + $tcl_platform(pointerSize)*3*2000000}] \ + { + # create list and get length (avoid too long output in interactive shells): + llength [set l [lrepeat 4000000 ""]] + # test OOM: + llength [lsort $l] + } + # expecting error no memory by sort +} -returnCodes 1 -result {no enough memory to proccess sort of 4000000 items} # Compiled version test cmdIL-6.1 {lassign command syntax} -returnCodes error -body { apply {{} { lassign }} } -result {wrong # args: should be "lassign list ?varName ...?"} @@ -772,67 +774,22 @@ } -cleanup { unset -nocomplain x y rename K {} } -result 1 -test cmdIL-8.1 {lremove command: error path} -returnCodes error -body { - lremove -} -result {wrong # args: should be "lremove list ?index ...?"} -test cmdIL-8.2 {lremove command: error path} -returnCodes error -body { - lremove {{}{}} -} -result {list element in braces followed by "{}" instead of space} -test cmdIL-8.3 {lremove command: error path} -returnCodes error -body { - lremove {a b c} gorp -} -result {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?} -test cmdIL-8.4 {lremove command: no indices} -body { - lremove {a b c} -} -result {a b c} -test cmdIL-8.5 {lremove command: before start} -body { - lremove {a b c} -1 -} -result {a b c} -test cmdIL-8.6 {lremove command: after end} -body { - lremove {a b c} 3 -} -result {a b c} -test cmdIL-8.7 {lremove command} -body { - lremove {a b c} 0 -} -result {b c} -test cmdIL-8.8 {lremove command} -body { - lremove {a b c} 1 -} -result {a c} -test cmdIL-8.9 {lremove command} -body { - lremove {a b c} end -} -result {a b} -test cmdIL-8.10 {lremove command} -body { - lremove {a b c} end-1 -} -result {a c} -test cmdIL-8.11 {lremove command} -body { - lremove {a b c d e} 1 3 -} -result {a c e} -test cmdIL-8.12 {lremove command} -body { - lremove {a b c d e} 3 1 -} -result {a c e} -test cmdIL-8.13 {lremove command: same index twice} -body { - lremove {a b c d e} 2 2 -} -result {a b d e} -test cmdIL-8.14 {lremove command: same index twice} -body { - lremove {a b c d e} 3 end-1 -} -result {a b c e} -test cmdIL-8.15 {lremove command: many indices} -body { - lremove {a b c d e} 1 3 1 4 0 -} -result {c} - # This belongs in info test, but adding tests there breaks tests # that compute source file line numbers. test info-20.6 {Bug 3587651} -setup { namespace eval my {namespace eval tcl {namespace eval mathfunc { proc demo x {return 42} }}}} -body { namespace eval my {expr {"demo" in [info functions]}}} -cleanup { namespace delete my } -result 1 - + + # cleanup ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: Index: tests/cmdInfo.test ================================================================== --- tests/cmdInfo.test +++ tests/cmdInfo.test @@ -11,12 +11,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] testConstraint testcmdinfo [llength [info commands testcmdinfo]] Index: tests/cmdMZ.test ================================================================== --- tests/cmdMZ.test +++ tests/cmdMZ.test @@ -20,11 +20,16 @@ namespace import ::tcltest::cleanupTests namespace import ::tcltest::customMatch namespace import ::tcltest::makeFile namespace import ::tcltest::removeFile namespace import ::tcltest::temporaryDirectory + namespace import ::tcltest::testConstraint namespace import ::tcltest::test + + if {[namespace which -command ::tcl::unsupported::timerate] ne ""} { + namespace import ::tcl::unsupported::timerate + } proc ListGlobMatch {expected actual} { if {[llength $expected] != [llength $actual]} { return 0 } @@ -225,18 +230,18 @@ # Tcl_SourceObjCmd # More tests of Tcl_SourceObjCmd are in source.test test cmdMZ-3.3 {Tcl_SourceObjCmd: error conditions} -constraints { - unixOrPc + unixOrWin } -returnCodes error -body { source } -match glob -result {wrong # args: should be "source*fileName"} test cmdMZ-3.4 {Tcl_SourceObjCmd: error conditions} -constraints { - unixOrPc + unixOrWin } -returnCodes error -body { - source a b c d e f + source a b } -match glob -result {wrong # args: should be "source*fileName"} test cmdMZ-3.5 {Tcl_SourceObjCmd: error in script} -body { set file [makeFile { set x 146 error "error in sourced file" @@ -314,17 +319,21 @@ # The tests for Tcl_StringObjCmd are in string.test # The tests for Tcl_SubstObjCmd are in subst.test # The tests for Tcl_SwitchObjCmd are in switch.test -# todo: rewrite this if monotonic clock is provided resp. command "after" +# todo: rewrite this if monotonic clock is provided resp. command "after" # gets microsecond accuracy (RFE [fdfbd5e10] gets merged): proc _nrt_sleep {msec} { set usec [expr {$msec * 1000}] set stime [clock microseconds] - while {abs([clock microseconds] - $stime) < $usec} {after 0} + while {abs([clock microseconds] - $stime) < $usec} { + # don't use after 0 unless it's NRT-capable, so yes - busy-wait (but it's more precise): + # after 0 + } } +_nrt_sleep 0; # warm up (clock, compile, etc) test cmdMZ-5.1 {Tcl_TimeObjCmd: basic format of command} -body { time } -returnCodes error -result {wrong # args: should be "time command ?count?"} test cmdMZ-5.2 {Tcl_TimeObjCmd: basic format of command} -body { @@ -337,20 +346,42 @@ time bogusCmd -12456 } {0 microseconds per iteration} test cmdMZ-5.5 {Tcl_TimeObjCmd: result format} -body { time {format 1} } -match regexp -result {^\d+ microseconds per iteration} -test cmdMZ-5.6 {Tcl_TimeObjCmd: slower commands take longer} { - expr {[lindex [time {_nrt_sleep 1}] 0] < [lindex [time {_nrt_sleep 20}] 0]} -} 1 +test cmdMZ-5.6 {Tcl_TimeObjCmd: slower commands take longer} -body { + set m1 [lindex [time {_nrt_sleep 0.01}] 0] + set m2 [lindex [time {_nrt_sleep 10.0}] 0] + list \ + [expr {$m1 < $m2}] \ + $m1 $m2; # interesting only in error case. +} -match glob -result [list 1 *] test cmdMZ-5.7 {Tcl_TimeObjCmd: errors generate right trace} { list [catch {time {error foo}} msg] $msg $::errorInfo } {1 foo {foo while executing "error foo" invoked from within "time {error foo}"}} +test cmdMZ-5.7.1 {Tcl_TimeObjCmd: return from time} { + set x 0 + proc r1 {} {upvar x x; time {incr x; return "r1"; incr x} 10} + list [r1] $x +} {r1 1} +test cmdMZ-5.8 {Tcl_TimeObjCmd: done optimization: nested call of self inside time (if compiled)} { + set x [set y 0] + set m1 { + if {[incr x] <= 5} { + # nested call should return result, so covering that: + if {![string is integer -strict [eval $m1]]} {error unexpected} + } + # increase again (no "continue" from nested call): + incr x + } + time {incr y; eval $m1} 5 + list $y $x +} {5 20} test cmdMZ-6.1 {Tcl_TimeRateObjCmd: basic format of command} { list [catch {timerate} msg] $msg } {1 {wrong # args: should be "timerate ?-direct? ?-calibrate? ?-overhead double? command ?time ?max-count??"}} test cmdMZ-6.2.1 {Tcl_TimeRateObjCmd: basic format of command} { @@ -372,83 +403,87 @@ regexp {^\d+(?:\.\d+)? \ws/# 1 # \d+(?:\.\d+)? #/sec \d+(?:\.\d+)? net-ms$} [timerate {} 0] } 1 test cmdMZ-6.5b {Tcl_TimeRateObjCmd: result format without iterations} { regexp {^0 \ws/# 0 # 0 #/sec 0 net-ms$} [timerate {} 0 0] } 1 -test cmdMZ-6.6 {Tcl_TimeRateObjCmd: slower commands take longer, but it remains almost the same time of measument} { - set m1 [timerate {_nrt_sleep 0} 20] - set m2 [timerate {_nrt_sleep 0.2} 20] - list \ +test cmdMZ-6.6 {Tcl_TimeRateObjCmd: slower commands take longer, but it remains almost the same time of measument} -body { + set m1 [timerate {_nrt_sleep 0.01} 50] + set m2 [timerate {_nrt_sleep 1.00} 50] + list [list \ [expr {[lindex $m1 0] < [lindex $m2 0]}] \ [expr {[lindex $m1 0] < 100}] \ [expr {[lindex $m2 0] > 100}] \ - [expr {[lindex $m1 2] > 1000}] \ - [expr {[lindex $m2 2] < 1000}] \ - [expr {[lindex $m1 4] > 50000}] \ - [expr {[lindex $m2 4] < 50000}] \ - [expr {[lindex $m1 6] > 10 && [lindex $m1 6] < 100}] \ - [expr {[lindex $m2 6] > 10 && [lindex $m2 6] < 100}] -} [lrepeat 9 1] + [expr {[lindex $m1 2] > 500}] \ + [expr {[lindex $m2 2] < 500}] \ + [expr {[lindex $m1 4] > 10000}] \ + [expr {[lindex $m2 4] < 10000}] \ + [expr {[lindex $m1 6] > 5 && [lindex $m1 6] < 100}] \ + [expr {[lindex $m2 6] > 5 && [lindex $m2 6] < 100}] \ + ] $m1 $m2; # interesting only in error case. +} -match glob -result [list [lrepeat 9 1] *] test cmdMZ-6.7 {Tcl_TimeRateObjCmd: errors generate right trace} { list [catch {timerate {error foo} 1} msg] $msg $::errorInfo } {1 foo {foo while executing "error foo" invoked from within "timerate {error foo} 1"}} -test cmdMZ-6.8 {Tcl_TimeRateObjCmd: allow (conditional) break from timerate} { +test cmdMZ-6.7.1 {Tcl_TimeRateObjCmd: return from timerate} { + set x 0 + proc r1 {} {upvar x x; timerate {incr x; return "r1"; incr x} 1000 10} + list [r1] $x +} {r1 1} +test cmdMZ-6.8 {Tcl_TimeRateObjCmd: allow (conditional) break from timerate} -body { set m1 [timerate {break}] - list \ + list [list \ [expr {[lindex $m1 0] < 1000}] \ [expr {[lindex $m1 2] == 1}] \ [expr {[lindex $m1 4] > 1000}] \ - [expr {[lindex $m1 6] < 10}] -} {1 1 1 1} -test cmdMZ-6.8.1 {Tcl_TimeRateObjCmd: allow (conditional) continue in timerate} { + [expr {[lindex $m1 6] < 10}] \ + ] $m1; # interesting only in error case. +} -match glob -result [list {1 1 1 1} *] +test cmdMZ-6.8.1 {Tcl_TimeRateObjCmd: allow (conditional) continue in timerate} -body { set m1 [timerate {continue; return -code error "unexpected"} 1000 10] - list \ - [expr {[lindex $m1 0] < 1000}] \ - [expr {[lindex $m1 2] == 10}] \ - [expr {[lindex $m1 4] > 1000}] \ - [expr {[lindex $m1 6] < 100}] -} {1 1 1 1} + list [list \ + [expr {[lindex $m1 0] < 1000}] \ + [expr {[lindex $m1 2] == 10}] \ + [expr {[lindex $m1 4] > 1000}] \ + [expr {[lindex $m1 6] < 100}] \ + ] $m1; # interesting only in error case. +} -match glob -result [list {1 1 1 1} *] test cmdMZ-6.9 {Tcl_TimeRateObjCmd: max count of iterations} { set m1 [timerate {} 1000 5]; # max-count wins set m2 [timerate {_nrt_sleep 20} 1 5]; # max-time wins list [lindex $m1 2] [lindex $m2 2] } {5 1} -test cmdMZ-6.10 {Tcl_TimeRateObjCmd: huge overhead cause 0us result} { +test cmdMZ-6.10 {Tcl_TimeRateObjCmd: huge overhead cause 0us result} -body { set m1 [timerate -overhead 1e6 {_nrt_sleep 10} 100 1] - list \ + list [list \ [expr {[lindex $m1 0] == 0.0}] \ [expr {[lindex $m1 2] == 1}] \ [expr {[lindex $m1 4] == 1000000}] \ - [expr {[lindex $m1 6] <= 0.001}] -} {1 1 1 1} + [expr {[lindex $m1 6] <= 0.001}] \ + ] $m1; # interesting only in error case. +} -match glob -result [list {1 1 1 1} *] test cmdMZ-6.11 {Tcl_TimeRateObjCmd: done/continue optimization rollback} { set m1 {set m2 ok} if 1 $m1 timerate $m1 1000 10 if 1 $m1; # if rollback is missing throws an error: invoked "continue" outside of a loop } ok - -test cmdMZ-try-1.0 { - - fix for issue 45b9faf103f2 - - [try] interaction with local variable names produces segmentation violation - -} -body { - ::apply {{} { - set cmd try - $cmd { - lindex 5 - } on ok res {} - set res - }} -} -result 5 - +test cmdMZ-6.12 {Tcl_TimeRateObjCmd: done optimization: nested call of self inside timerate} { + set x 0 + set m1 { + if {[incr x] <= 5} { + # nested call should return result, so covering that: + if {![string is integer -strict [eval $m1]]} {error unexpected} + } + # increase again (no "continue" from nested call): + incr x + } + list [lindex [timerate $m1 1000 5] 2] $x +} {5 20} # The tests for Tcl_WhileObjCmd are in while.test # cleanup cleanupTests Index: tests/compExpr-old.test ================================================================== --- tests/compExpr-old.test +++ tests/compExpr-old.test @@ -10,16 +10,23 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + +if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} { + testConstraint testmathfunctions 0 +} else { + testConstraint testmathfunctions 1 +} # Big test for correct ordering of data in [expr] proc testIEEE {} { variable ieeeValues @@ -75,12 +82,12 @@ } } } testConstraint ieeeFloatingPoint [testIEEE] -testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] -testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}] +testConstraint longIs32bit [expr {int(0x80000000) < 0}] +testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] # procedures used below proc put_hello_char {c} { global a @@ -276,14 +283,14 @@ test compExpr-old-6.8 {CompileBitXorExpr: error compiling bitxor arm} -body { expr 2^x } -returnCodes error -match glob -result * test compExpr-old-6.9 {CompileBitXorExpr: runtime error in bitxor arm} { list [catch {expr {24.0^3}} msg] $msg -} {1 {can't use floating-point value "24.0" as operand of "^"}} +} {1 {can't use floating-point value as operand of "^"}} test compExpr-old-6.10 {CompileBitXorExpr: runtime error in bitxor arm} { list [catch {expr {"a"^"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "^"}} +} {1 {can't use non-numeric string as operand of "^"}} test compExpr-old-7.1 {CompileBitAndExpr: just equality expr} {expr 3==2} 0 test compExpr-old-7.2 {CompileBitAndExpr: just equality expr} {expr 2.0==2} 1 test compExpr-old-7.3 {CompileBitAndExpr: just equality expr} {expr 3.2!=2.2} 1 test compExpr-old-7.4 {CompileBitAndExpr: just equality expr} {expr {"abc" == "abd"}} 0 @@ -300,14 +307,14 @@ test compExpr-old-7.11 {CompileBitAndExpr: error compiling bitand arm} -body { expr 2&x } -returnCodes error -match glob -result * test compExpr-old-7.12 {CompileBitAndExpr: runtime error in bitand arm} { list [catch {expr {24.0&3}} msg] $msg -} {1 {can't use floating-point value "24.0" as operand of "&"}} +} {1 {can't use floating-point value as operand of "&"}} test compExpr-old-7.13 {CompileBitAndExpr: runtime error in bitand arm} { list [catch {expr {"a"&"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "&"}} +} {1 {can't use non-numeric string as operand of "&"}} test compExpr-old-8.1 {CompileEqualityExpr: just relational expr} {expr 3>=2} 1 test compExpr-old-8.2 {CompileEqualityExpr: just relational expr} {expr 2<=2.1} 1 test compExpr-old-8.3 {CompileEqualityExpr: just relational expr} {expr 3.2>"2.2"} 1 test compExpr-old-8.4 {CompileEqualityExpr: just relational expr} {expr {"0y"<"0x12"}} 0 @@ -328,13 +335,20 @@ test compExpr-old-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12 test compExpr-old-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63 test compExpr-old-9.3 {CompileRelationalExpr: just shift expr} {expr -1>>2} -1 test compExpr-old-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8 -test compExpr-old-9.5 {CompileRelationalExpr: large shift expr} { + +# The following test is different for 32-bit versus 64-bit +# architectures because LONG_MIN is different + +test compExpr-old-9.5a {CompileRelationalExpr: shift expr producing LONG_MIN} longIs64bit { expr {int(1<<63)} -} 9223372036854775808 +} -9223372036854775808 +test compExpr-old-9.5b {CompileRelationalExpr: shift expr producing LONG_MIN} longIs32bit { + expr {int(1<<31)} +} -2147483648 test compExpr-old-9.6 {CompileRelationalExpr: error in shift expr} -body { expr x>>3 } -returnCodes error -match glob -result * test compExpr-old-9.7 {CompileRelationalExpr: simple relational exprs} {expr 0xff>=+0x3} 1 @@ -361,14 +375,14 @@ test compExpr-old-10.9 {CompileShiftExpr: error compiling shift arm} -body { expr 2<>43}} msg] $msg -} {1 {can't use floating-point value "24.0" as operand of ">>"}} +} {1 {can't use floating-point value as operand of ">>"}} test compExpr-old-10.11 {CompileShiftExpr: runtime error} { list [catch {expr {"a"<<"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "<<"}} +} {1 {can't use non-numeric string as operand of "<<"}} test compExpr-old-11.1 {CompileAddExpr: just multiply expr} {expr 4*-2} -8 test compExpr-old-11.2 {CompileAddExpr: just multiply expr} {expr 0xff%2} 1 test compExpr-old-11.3 {CompileAddExpr: just multiply expr} {expr -1/2} -1 test compExpr-old-11.4 {CompileAddExpr: just multiply expr} {expr 7891%0o123} 6 @@ -383,14 +397,14 @@ test compExpr-old-11.9 {CompileAddExpr: error compiling add arm} -body { expr 2-x } -returnCodes error -match glob -result * test compExpr-old-11.10 {CompileAddExpr: runtime error} { list [catch {expr {24.0+"xx"}} msg] $msg -} {1 {can't use non-numeric string "xx" as operand of "+"}} +} {1 {can't use non-numeric string as operand of "+"}} test compExpr-old-11.11 {CompileAddExpr: runtime error} { list [catch {expr {"a"-"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "-"}} +} {1 {can't use non-numeric string as operand of "-"}} test compExpr-old-11.12 {CompileAddExpr: runtime error} { list [catch {expr {3/0}} msg] $msg } {1 {divide by zero}} test compExpr-old-11.13a {CompileAddExpr: runtime error} ieeeFloatingPoint { list [catch {expr {2.3/0.0}} msg] $msg @@ -414,14 +428,14 @@ test compExpr-old-12.9 {CompileMultiplyExpr: error compiling multiply arm} -body { expr 2*x } -returnCodes error -match glob -result * test compExpr-old-12.10 {CompileMultiplyExpr: runtime error} { list [catch {expr {24.0*"xx"}} msg] $msg -} {1 {can't use non-numeric string "xx" as operand of "*"}} +} {1 {can't use non-numeric string as operand of "*"}} test compExpr-old-12.11 {CompileMultiplyExpr: runtime error} { list [catch {expr {"a"/"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "/"}} +} {1 {can't use non-numeric string as operand of "/"}} test compExpr-old-13.1 {CompileUnaryExpr: unary exprs} {expr -0xff} -255 test compExpr-old-13.2 {CompileUnaryExpr: unary exprs} {expr +0o00123} 83 test compExpr-old-13.3 {CompileUnaryExpr: unary exprs} {expr +--++36} 36 test compExpr-old-13.4 {CompileUnaryExpr: unary exprs} {expr !2} 0 @@ -435,14 +449,14 @@ expr !1.x set msg } -returnCodes error -match glob -result * test compExpr-old-13.10 {CompileUnaryExpr: runtime error} { list [catch {expr {~"xx"}} msg] $msg -} {1 {can't use non-numeric string "xx" as operand of "~"}} +} {1 {can't use non-numeric string as operand of "~"}} test compExpr-old-13.11 {CompileUnaryExpr: runtime error} { list [catch {expr ~4.0} msg] $msg -} {1 {can't use floating-point value "4.0" as operand of "~"}} +} {1 {can't use floating-point value as operand of "~"}} test compExpr-old-13.12 {CompileUnaryExpr: just primary expr} {expr 0x123} 291 test compExpr-old-13.13 {CompileUnaryExpr: just primary expr} { set a 27 expr $a } 27 @@ -574,22 +588,37 @@ while *ing "expr sin(1,2,3)"} test compExpr-old-15.4 {CompileMathFuncCall: ')' found before last required arg} -body { catch {expr sin()} msg set ::errorInfo -} -match glob -result {too few arguments for math function* +} -match glob -result {not enough arguments for math function* while *ing "expr sin()"} -test compExpr-old-15.5 {CompileMathFuncCall: too few arguments} -body { +test compExpr-old-15.5 {CompileMathFuncCall: not enough arguments} -body { catch {expr pow(1)} msg set ::errorInfo -} -match glob -result {too few arguments for math function* +} -match glob -result {not enough arguments for math function* while *ing "expr pow(1)"} test compExpr-old-15.6 {CompileMathFuncCall: missing ')'} -body { expr sin(1 } -returnCodes error -match glob -result * +test compExpr-old-15.7 {CompileMathFuncCall: call registered math function} testmathfunctions { + expr 2*T1() +} 246 +test compExpr-old-15.8 {CompileMathFuncCall: call registered math function} testmathfunctions { + expr T2()*3 +} 1035 +test compExpr-old-15.9 {CompileMathFuncCall: call registered math function} testmathfunctions { + expr T3(21, 37) +} 37 +test compExpr-old-15.10 {CompileMathFuncCall: call registered math function} testmathfunctions { + expr T3(21.2, 37) +} 37.0 +test compExpr-old-15.11 {CompileMathFuncCall: call registered math function} testmathfunctions { + expr T3(-21.2, -17.5) +} -17.5 test compExpr-old-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} { catch {unset a} set a(VALUE) ff15 set i 123 Index: tests/compExpr.test ================================================================== --- tests/compExpr.test +++ tests/compExpr.test @@ -7,15 +7,22 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + +if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} { + testConstraint testmathfunctions 0 +} else { + testConstraint testmathfunctions 1 +} # Constrain memory leak tests testConstraint memory [llength [info commands memory]] catch {unset a} @@ -305,20 +312,26 @@ test compExpr-4.9 {CompileCondExpr procedure, error in "false" clause} { list [catch {expr {1? 15 : [expr *2]}} msg] $msg } {0 15} test compExpr-5.1 {CompileMathFuncCall procedure, math function found} { - format %.6g [expr atan2(1.0, 2.0)] + format %.6g [expr {atan2(1.0, 2.0)}] } 0.463648 test compExpr-5.2 {CompileMathFuncCall procedure, math function not found} -body { expr {do_it()} } -returnCodes error -match glob -result {* "*do_it"} -test compExpr-5.5 {CompileMathFuncCall procedure, too few arguments} -body { +test compExpr-5.3 {CompileMathFuncCall: call registered math function} testmathfunctions { + expr 3*T1()-1 +} 368 +test compExpr-5.4 {CompileMathFuncCall: call registered math function} testmathfunctions { + expr T2()*3 +} 1035 +test compExpr-5.5 {CompileMathFuncCall procedure, not enough arguments} -body { expr {atan2(1.0)} -} -returnCodes error -match glob -result {too few arguments for math function*} +} -returnCodes error -match glob -result {not enough arguments for math function*} test compExpr-5.6 {CompileMathFuncCall procedure, complex argument} { - format %.6g [expr pow(2.1, 27.5-(24.4*(5%2)))] + format %.6g [expr {pow(2.1, 27.5-(24.4*(5%2)))}] } 9.97424 test compExpr-5.7 {CompileMathFuncCall procedure, error in argument} -body { expr {sinh(2.*)} } -returnCodes error -match glob -result * test compExpr-5.8 {CompileMathFuncCall procedure, too many arguments} -body { @@ -338,13 +351,13 @@ lindex $lines 3 3 } } -body { set end [getbytes] for {set i 0} {$i < 5} {incr i} { - interp create slave - slave eval expr 1+2+3+4+5+6+7+8+9+10+11+12+13 - interp delete slave + interp create child + child eval expr 1+2+3+4+5+6+7+8+9+10+11+12+13 + interp delete child set tmp $end set end [getbytes] } set leakedBytes [expr {$end - $tmp}] } -cleanup { Index: tests/compile.test ================================================================== --- tests/compile.test +++ tests/compile.test @@ -9,12 +9,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] testConstraint exec [llength [info commands exec]] @@ -199,11 +201,11 @@ test compile-4.1 {TclCompileForCmd: command substituted test expression} { set i 0 set j 0 # Should be "forever" - for {} [expr $i < 3] {} { + for {} [expr {$i < 3}] {} { set j [incr i] if {$j > 3} break } set j } {4} @@ -273,11 +275,11 @@ test compile-7.1 {TclCompileWhileCmd: command substituted test expression} { set i 0 set j 0 # Should be "forever" - while [expr $i < 3] { + while [expr {$i < 3}] { set j [incr i] if {$j > 3} break } set j } {4} @@ -321,11 +323,11 @@ test compile-11.2 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { apply {{} { set r [list foobar] ; string index a bogus }} } -returnCodes error -result {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?} test compile-11.3 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { apply {{} { set r [list foobar] ; string index a 0o9 }} -} -returnCodes error -match glob -result {*} +} -returnCodes error -match glob -result {*invalid octal number*} test compile-11.4 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { apply {{} { set r [list foobar] ; array set var {one two many} }} } -returnCodes error -result {list must have an even number of elements} test compile-11.5 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { apply {{} { set r [list foobar] ; incr foo bar baz}} @@ -332,11 +334,11 @@ } -returnCodes error -result {wrong # args: should be "incr varName ?increment?"} test compile-11.6 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { apply {{} { set r [list foobar] ; incr}} } -returnCodes error -result {wrong # args: should be "incr varName ?increment?"} test compile-11.7 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { - apply {{} { set r [list foobar] ; expr !a }} + apply {{} { set r [list foobar] ; expr [concat !a] }} } -returnCodes error -match glob -result * test compile-11.8 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { apply {{} { set r [list foobar] ; expr {!a} }} } -returnCodes error -match glob -result * test compile-11.9 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { @@ -463,10 +465,71 @@ } append body {]; puts OK} regsub BODY {proc crash {} {BODY}; crash} $body script list [catch {exec [interpreter] << $script} msg] $msg } {0 OK} + +# Tests of nested compile (body in body compilation), should not generate stack overflow +# (with abnormal program termination), bug [fec0c17d39]: +proc _ti_gencode {} { + # creates test interpreter on demand with [gencode] generator: + if {[interp exists ti]} { + return + } + interp create ti + ti eval {proc gencode {nr {cmd eval} {nl 0}} { + set code "" + set e ""; if {$nl} {set e "\n"} + for {set i 0} {$i < $nr} {incr i} { + append code "$cmd \{$e" + } + append code "lappend result 1$e" + for {set i 0} {$i < $nr} {incr i} { + append code "\}$e" + } + #puts [format "%% %.40s ... %d bytes" $code [string length $code]] + return $code + }} +} +test compile-13.2 {TclCompileScript: testing expected nested scripts compilation} -setup { + _ti_gencode + interp recursionlimit ti [expr {10000+50}] + ti eval {set result {}} +} -body { + # Test different compilation variants (instructions evalStk, invokeStk, etc), + # with 1500 (1000 in debug) nested scripts (bodies). If you get SO/SF exceptions on some low-stack + # boxes or systems, please don't decrease it (either provide a constraint) + ti eval {foreach cmd {eval "if 1" try catch} { + set c [gencode [expr {![::tcl::pkgconfig get debug] ? 1500 : 1000}] $cmd] + if 1 $c + }} + ti eval {set result} +} -result {1 1 1 1} +test compile-13.3 {TclCompileScript: testing check of max depth by nested scripts compilation} -setup { + _ti_gencode + interp recursionlimit ti 100 + ti eval {set result {}} +} -body { + # Test different compilation variants (instructions evalStk, invokeStk, etc), + # with 500 nested scripts (bodies). It must generate "too many nested compilations" + # error for any variant we're testing here: + ti eval {foreach cmd {eval "if 1" try catch} { + set c [gencode 500 $cmd] + lappend errors [catch $c e] $e + }} + #puts $errors + # all of nested calls exceed the limit, so must end with "too many nested compilations" + # (or evaluations, depending on compile method/instruction and "mixed" compile within + # evaliation), so no one succeeds, the result must be empty: + ti eval {set result} +} -result {} +# +# clean up: +if {[interp exists ti]} { + interp delete ti +} +rename _ti_gencode {} # Tests compile-14.* for [Bug 599788] [Bug 0c043a175a47da8c2342] test compile-14.1 {testing errors in element name; segfault?} {} { catch {set a([error])} msg1 catch {set bubba([join $abba $jubba]) $vol} msg2 @@ -497,14 +560,13 @@ } 2 test compile-15.5 {proper TCL_RETURN code from [return]} { apply {{} {catch {set a 1}; return}} } "" -# Do all tests once byte compiled and once with direct string evaluation -foreach noComp {0 1} { +for {set noComp 0} {$noComp <= 1} {incr noComp} { -if $noComp { +if {$noComp} { interp alias {} run {} testevalex set constraints testevalex } else { interp alias {} run {} if 1 set constraints {} Index: tests/concat.test ================================================================== --- tests/concat.test +++ tests/concat.test @@ -10,11 +10,11 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } test concat-1.1 {simple concatenation} { concat a b c d e f g Index: tests/config.test ================================================================== --- tests/config.test +++ tests/config.test @@ -10,18 +10,18 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } test pkgconfig-1.1 {query keys} { lsort [::tcl::pkgconfig list] -} {64bit bindir,install bindir,runtime compile_debug compile_stats debug dllfile,runtime docdir,install docdir,runtime includedir,install includedir,runtime libdir,install libdir,runtime mem_debug optimized profiled scriptdir,install scriptdir,runtime threaded zipfile,runtime} +} {64bit bindir,install bindir,runtime compile_debug compile_stats debug docdir,install docdir,runtime includedir,install includedir,runtime libdir,install libdir,runtime mem_debug optimized profiled scriptdir,install scriptdir,runtime threaded} test pkgconfig-1.2 {query keys multiple times} { string compare [::tcl::pkgconfig list] [::tcl::pkgconfig list] } 0 test pkgconfig-1.3 {query value multiple times} { string compare \ Index: tests/coroutine.test ================================================================== --- tests/coroutine.test +++ tests/coroutine.test @@ -7,12 +7,12 @@ # Copyright (c) 2008 by Miguel Sofer. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -769,200 +769,55 @@ set ::result none tcl::unsupported::inject demo set ::result inject-executed lappend ::result [catch {demo} err] $err } -result {inject-executed 1 test} test coroutine-8.1.1 {coro inject, ticket 42202ba1e5ff566e} -body { - interp create slave - slave eval { - coroutine demo apply {{} { while {1} yield }} - demo - tcl::unsupported::inject demo set ::result inject-executed - } - interp delete slave -} -result {} -test coroutine-8.1.2 {coro inject with result, ticket 42202ba1e5ff566e} -body { - interp create slave - slave eval { - coroutine demo apply {{} { while {1} yield }} - demo - tcl::unsupported::inject demo set ::result inject-executed - } - slave eval demo - set result [slave eval {set ::result}] - - interp delete slave - set result -} -result {inject-executed} - -test coroutine-9.1 {coroprobe with yield} -body { - coroutine demo apply {{} { foreach i {1 2} yield }} - list [coroprobe demo set i] [demo] [coroprobe demo set i] [demo] -} -cleanup { - catch {rename demo {}} -} -result {1 {} 2 {}} -test coroutine-9.2 {coroprobe with yieldto} -body { - coroutine demo apply {{} { lmap i {1 2} {yieldto string cat} }} - list [coroprobe demo set i] [demo a b] [coroprobe demo set i] [demo c d] -} -cleanup { - catch {rename demo {}} -} -result {1 {} 2 {{a b} {c d}}} -test coroutine-9.3 {coroprobe errors} -setup { - catch {rename demo {}} -} -body { - coroprobe demo set i -} -returnCodes error -result {can only inject a probe command into a coroutine} -test coroutine-9.4 {coroprobe errors} -body { - proc demo {} { foreach i {1 2} yield } - coroprobe demo set i -} -returnCodes error -cleanup { - catch {rename demo {}} -} -result {can only inject a probe command into a coroutine} -test coroutine-9.5 {coroprobe errors} -body { - coroutine demo apply {{} { foreach i {1 2} yield }} - coroprobe -} -returnCodes error -cleanup { - catch {rename demo {}} -} -result {wrong # args: should be "coroprobe coroName cmd ?arg1 arg2 ...?"} -test coroutine-9.6 {coroprobe errors} -body { - coroutine demo apply {{} { foreach i {1 2} yield }} - coroprobe demo -} -returnCodes error -cleanup { - catch {rename demo {}} -} -result {wrong # args: should be "coroprobe coroName cmd ?arg1 arg2 ...?"} -test coroutine-9.7 {coroprobe errors in probe command} -body { - coroutine demo apply {{} { foreach i {1 2} yield }} - coroprobe demo set -} -returnCodes error -cleanup { - catch {rename demo {}} -} -result {wrong # args: should be "set varName ?newValue?"} -test coroutine-9.8 {coroprobe errors in probe command} -body { - coroutine demo apply {{} { foreach i {1 2} yield }} - list [catch {coroprobe demo set}] [demo] [coroprobe demo set i] -} -cleanup { - catch {rename demo {}} -} -result {1 {} 2} -test coroutine-9.9 {coroprobe: advanced features} -setup { - set i [interp create] -} -body { - $i eval { - coroutine demo apply {{} { - set f [info level],[info frame] - foreach i {1 2} yield - }} - coroprobe demo apply {{} { - upvar 1 f f - list [info coroutine] [info level] [info frame] $f - }} - } -} -cleanup { - interp delete $i -} -result {::demo 2 3 1,2} - -test coroutine-10.1 {coroinject with yield} -setup { - set result {} -} -body { - coroutine demo apply {{} { lmap i {1 2} yield }} - coroinject demo apply {{op val} {lappend ::result $op $val}} - list $result [demo x] [demo y] $result -} -cleanup { - catch {rename demo {}} -} -result {{} {} {{yield x} y} {yield x}} -test coroutine-10.2 {coroinject stacking} -setup { - set result {} -} -body { - coroutine demo apply {{} { lmap i {1 2} yield }} - coroinject demo apply {{op val} {lappend ::result $op $val A;return $val}} - coroinject demo apply {{op val} {lappend ::result $op $val B;return $val}} - list $result [demo x] [demo y] $result -} -cleanup { - catch {rename demo {}} -} -result {{} {} {x y} {yield x B yield x A}} -test coroutine-10.3 {coroinject with yieldto} -setup { - set result {} -} -body { - coroutine demo apply {{} { lmap i {1 2} {yieldto string cat} }} - coroinject demo apply {{op val} {lappend ::result $op $val;return $val}} - list $result [demo x mp] [demo y le] $result -} -cleanup { - catch {rename demo {}} -} -result {{} {} {{x mp} {y le}} {yieldto {x mp}}} -test coroutine-10.4 {coroinject errors} -setup { - catch {rename demo {}} -} -body { - coroinject demo set i -} -returnCodes error -result {can only inject a command into a coroutine} -test coroutine-10.5 {coroinject errors} -body { - proc demo {} { foreach i {1 2} yield } - coroinject demo set i -} -returnCodes error -cleanup { - catch {rename demo {}} -} -result {can only inject a command into a coroutine} -test coroutine-10.6 {coroinject errors} -body { - coroutine demo apply {{} { foreach i {1 2} yield }} - coroinject -} -returnCodes error -cleanup { - catch {rename demo {}} -} -result {wrong # args: should be "coroinject coroName cmd ?arg1 arg2 ...?"} -test coroutine-10.7 {coroinject errors} -body { - coroutine demo apply {{} { foreach i {1 2} yield }} - coroinject demo -} -returnCodes error -cleanup { - catch {rename demo {}} -} -result {wrong # args: should be "coroinject coroName cmd ?arg1 arg2 ...?"} -test coroutine-10.8 {coroinject errors in injected command} -body { - coroutine demo apply {{} { foreach i {1 2} yield }} - coroinject demo apply {args {error "ERR: $args"}} - list [catch demo msg] $msg [catch demo msg] $msg -} -cleanup { - catch {rename demo {}} -} -result {1 {ERR: yield {}} 1 {invalid command name "demo"}} -test coroutine-10.9 {coroinject: advanced features} -setup { - set i [interp create] -} -body { - $i eval { - coroutine demo apply {{} { - set l [info level] - set f [info frame] - lmap i {1 2} yield - }} - coroinject demo apply {{arg op val} { - global result - upvar 1 f f l l - lappend result [info coroutine] $arg $op $val - lappend result [info level] $l [info frame] $f - lappend result [yield $arg] - return [string toupper $val] - }} grill - list [demo ABC] [demo pqr] [demo def] $result - } -} -cleanup { - interp delete $i -} -result {grill {} {ABC def} {::demo grill yield ABC 2 1 3 2 pqr}} - -test coroutine-11.1 {coro type} { + interp create child + child eval { + coroutine demo apply {{} { while {1} yield }} + demo + tcl::unsupported::inject demo set ::result inject-executed + } + interp delete child +} -result {} +test coroutine-8.1.2 {coro inject with result, ticket 42202ba1e5ff566e} -body { + interp create child + child eval { + coroutine demo apply {{} { while {1} yield }} + demo + tcl::unsupported::inject demo set ::result inject-executed + } + child eval demo + set result [child eval {set ::result}] + + interp delete child + set result +} -result {inject-executed} + +test coroutine-9.1 {coro type} { coroutine demo eval { yield yield "PHASE 1" yieldto string cat "PHASE 2" ::tcl::unsupported::corotype [info coroutine] } list [demo] [::tcl::unsupported::corotype demo] \ [demo] [::tcl::unsupported::corotype demo] [demo] } {{PHASE 1} yield {PHASE 2} yieldto active} -test coroutine-11.2 {coro type} -setup { +test coroutine-9.2 {coro type} -setup { catch {rename nosuchcommand ""} } -returnCodes error -body { ::tcl::unsupported::corotype nosuchcommand } -result {can only get coroutine type of a coroutine} -test coroutine-11.3 {coro type} -returnCodes error -body { +test coroutine-9.3 {coro type} -returnCodes error -body { proc notacoroutine {} {} ::tcl::unsupported::corotype notacoroutine } -returnCodes error -cleanup { rename notacoroutine {} } -result {can only get coroutine type of a coroutine} -test coroutine-12.1 {coroutine general introspection} -setup { +test coroutine-10.1 {coroutine general introspection} -setup { set i [interp create] } -body { $i eval { # Make the introspection code namespace path tcl::unsupported Index: tests/dcall.test ================================================================== --- tests/dcall.test +++ tests/dcall.test @@ -9,12 +9,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] testConstraint testdcall [llength [info commands testdcall]] Index: tests/dict.test ================================================================== --- tests/dict.test +++ tests/dict.test @@ -7,11 +7,11 @@ # # Copyright (c) 2003-2009 Donal K. Fellows # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } # Used for constraining memory leak tests @@ -173,11 +173,15 @@ test dict-4.12 {dict replace command: canonicality is forced} { dict replace {a b c d a e} } {a e c d} test dict-4.13 {dict replace command: type check is mandatory} -body { dict replace { a b c d e } -} -errorCode {TCL VALUE DICTIONARY} -result {missing value to go with key} +} -returnCodes error -result {missing value to go with key} +test dict-4.13a {dict replace command: type check is mandatory} { + catch {dict replace { a b c d e }} -> opt + dict get $opt -errorcode +} {TCL VALUE DICTIONARY} test dict-4.14 {dict replace command: type check is mandatory} -body { dict replace { a b {}c d } } -returnCodes error -result {dict element in braces followed by "c" instead of space} test dict-4.14a {dict replace command: type check is mandatory} { catch {dict replace { a b {}c d }} -> opt @@ -197,11 +201,15 @@ catch {dict replace " a b \"c d "} -> opt dict get $opt -errorcode } {TCL VALUE DICTIONARY QUOTE} test dict-4.17 {dict replace command: type check is mandatory} -body { dict replace " a b \{c d " -} -errorCode {TCL VALUE DICTIONARY BRACE} -result {unmatched open brace in dict} +} -returnCodes error -result {unmatched open brace in dict} +test dict-4.17a {dict replace command: type check is mandatory} { + catch {dict replace " a b \{c d "} -> opt + dict get $opt -errorcode +} {TCL VALUE DICTIONARY BRACE} test dict-4.18 {dict replace command: canonicality forcing doesn't leak} { set example { a b c d } list $example [dict replace $example] } {{ a b c d } {a b c d}} @@ -2045,118 +2053,13 @@ apply {{} { lassign {} item dict update item item item two two {} }} } {} - -set dict dict; # Used to force interpretation, not compilation -test dict-26.1 {dict getdef command} -body { - dict getdef {a b} a c -} -result b -test dict-26.2 {dict getdef command} -body { - dict getdef {a b} b c -} -result c -test dict-26.3 {dict getdef command} -body { - dict getdef {a {b c}} a b d -} -result c -test dict-26.4 {dict getdef command} -body { - dict getdef {a {b c}} a c d -} -result d -test dict-26.5 {dict getdef command} -body { - dict getdef {a {b c}} b c d -} -result d -test dict-26.6 {dict getdef command} -returnCodes error -body { - dict getdef {a {b c d}} a b d -} -result {missing value to go with key} -test dict-26.7 {dict getdef command} -returnCodes error -body { - dict getdef -} -result {wrong # args: should be "dict getdef dictionary ?key ...? key default"} -test dict-26.8 {dict getdef command} -returnCodes error -body { - dict getdef {} -} -result {wrong # args: should be "dict getdef dictionary ?key ...? key default"} -test dict-26.9 {dict getdef command} -returnCodes error -body { - dict getdef {} {} -} -result {wrong # args: should be "dict getdef dictionary ?key ...? key default"} -test dict-26.10 {dict getdef command} -returnCodes error -body { - dict getdef {a b c} d e -} -result {missing value to go with key} -test dict-26.11 {dict getdef command} -body { - $dict getdef {a b} a c -} -result b -test dict-26.12 {dict getdef command} -body { - $dict getdef {a b} b c -} -result c -test dict-26.13 {dict getdef command} -body { - $dict getdef {a {b c}} a b d -} -result c -test dict-26.14 {dict getdef command} -body { - $dict getdef {a {b c}} a c d -} -result d -test dict-26.15 {dict getdef command} -body { - $dict getdef {a {b c}} b c d -} -result d -test dict-26.16 {dict getdef command} -returnCodes error -body { - $dict getdef {a {b c d}} a b d -} -result {missing value to go with key} -test dict-26.17 {dict getdef command} -returnCodes error -body { - $dict getdef {a b c} d e -} -result {missing value to go with key} - -test dict-27.1 {dict getwithdefault command} -body { - dict getwithdefault {a b} a c -} -result b -test dict-27.2 {dict getwithdefault command} -body { - dict getwithdefault {a b} b c -} -result c -test dict-27.3 {dict getwithdefault command} -body { - dict getwithdefault {a {b c}} a b d -} -result c -test dict-27.4 {dict getwithdefault command} -body { - dict getwithdefault {a {b c}} a c d -} -result d -test dict-27.5 {dict getwithdefault command} -body { - dict getwithdefault {a {b c}} b c d -} -result d -test dict-27.6 {dict getwithdefault command} -returnCodes error -body { - dict getwithdefault {a {b c d}} a b d -} -result {missing value to go with key} -test dict-27.7 {dict getwithdefault command} -returnCodes error -body { - dict getwithdefault -} -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"} -test dict-27.8 {dict getwithdefault command} -returnCodes error -body { - dict getwithdefault {} -} -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"} -test dict-27.9 {dict getwithdefault command} -returnCodes error -body { - dict getwithdefault {} {} -} -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"} -test dict-27.10 {dict getdef command} -returnCodes error -body { - dict getwithdefault {a b c} d e -} -result {missing value to go with key} -test dict-27.11 {dict getwithdefault command} -body { - $dict getwithdefault {a b} a c -} -result b -test dict-27.12 {dict getwithdefault command} -body { - $dict getwithdefault {a b} b c -} -result c -test dict-27.13 {dict getwithdefault command} -body { - $dict getwithdefault {a {b c}} a b d -} -result c -test dict-27.14 {dict getwithdefault command} -body { - $dict getwithdefault {a {b c}} a c d -} -result d -test dict-27.15 {dict getwithdefault command} -body { - $dict getwithdefault {a {b c}} b c d -} -result d -test dict-27.16 {dict getwithdefault command} -returnCodes error -body { - $dict getwithdefault {a {b c d}} a b d -} -result {missing value to go with key} -test dict-27.17 {dict getdef command} -returnCodes error -body { - $dict getwithdefault {a b c} d e -} -result {missing value to go with key} # cleanup ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: Index: tests/dstring.test ================================================================== --- tests/dstring.test +++ tests/dstring.test @@ -10,11 +10,11 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -178,20 +178,41 @@ testdstring element # testdstring get } -cleanup { testdstring free } -result {x #} -test dstring-2.13 {appending list elements} -constraints testdstring -body { - # This test shows lack of sophistication in Tcl_DStringAppendElement's - # decision about whether #-quoting can be disabled. +test dstring-2.13 {appending list elements} -constraints testdstring -setup { testdstring free +} -body { + # This test checks the sophistication in Tcl_DStringAppendElement's + # decision about whether #-quoting can be disabled. testdstring append "x " -1 testdstring element # testdstring get } -cleanup { testdstring free -} -result {x {#}} +} -result {x #} +test dstring-2.14 {appending list elements} -constraints testdstring -setup { + testdstring free +} -body { + testdstring append " " -1 + testdstring element # + testdstring get +} -cleanup { + testdstring free +} -result { {#}} +test dstring-2.15 {appending list elements} -constraints testdstring -setup { + testdstring free +} -body { + # This test checks the sophistication in Tcl_DStringAppendElement's + # decision about whether #-quoting can be disabled. + testdstring append "x " -1 + testdstring element # + testdstring get +} -cleanup { + testdstring free +} -result {x #} test dstring-3.1 {nested sublists} -constraints testdstring -setup { testdstring free } -body { testdstring start @@ -304,23 +325,50 @@ testdstring end testdstring get } -cleanup { testdstring free } -result {x {x #}} -test dstring-3.10 {appending list elements} -constraints testdstring -body { - # This test shows lack of sophistication in Tcl_DStringAppendElement's - # decision about whether #-quoting can be disabled. +test dstring-3.10 {appending list elements} -constraints testdstring -setup { testdstring free +} -body { + # This test checks the sophistication in Tcl_DStringAppendElement's + # decision about whether #-quoting can be disabled. testdstring append x -1 testdstring start testdstring append "x " -1 testdstring element # testdstring end testdstring get } -cleanup { testdstring free -} -result {x {x {#}}} +} -result {x {x #}} +test dstring-3.11 {appending list elements} -constraints testdstring -setup { + testdstring free +} -body { + testdstring append x -1 + testdstring start + testdstring append " " -1 + testdstring element # + testdstring end + testdstring get +} -cleanup { + testdstring free +} -result {x { {#}}} +test dstring-3.12 {appending list elements} -constraints testdstring -setup { + testdstring free +} -body { + # This test checks the sophistication in Tcl_DStringAppendElement's + # decision about whether #-quoting can be disabled. + testdstring append x -1 + testdstring start + testdstring append "x " -1 + testdstring element # + testdstring end + testdstring get +} -cleanup { + testdstring free +} -result {x {x #}} test dstring-4.1 {truncation} -constraints testdstring -setup { testdstring free } -body { testdstring append "abcdefg" -1 Index: tests/encoding.test ================================================================== --- tests/encoding.test +++ tests/encoding.test @@ -6,17 +6,18 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} namespace eval ::tcl::test::encoding { variable x -namespace import -force ::tcltest::* - catch { ::tcltest::loadTestedCommands package require -exact Tcltest [info patchlevel] } @@ -34,12 +35,14 @@ # Some tests require the testencoding command testConstraint testencoding [llength [info commands testencoding]] testConstraint testbytestring [llength [info commands testbytestring]] testConstraint teststringbytes [llength [info commands teststringbytes]] +testConstraint ucs2 [expr {[format %c 0x010000] eq "\uFFFD"}] +testConstraint fullutf [expr {[format %c 0x010000] ne "\uFFFD"}] testConstraint exec [llength [info commands exec]] -testConstraint testgetencpath [llength [info commands testgetencpath]] +testConstraint testgetdefenc [llength [info commands testgetdefenc]] # TclInitEncodingSubsystem is tested by the rest of this file # TclFinalizeEncodingSubsystem is not currently tested test encoding-1.1 {Tcl_GetEncoding: system encoding} -setup { @@ -281,20 +284,20 @@ } -result {invalid encoding file "splat"} # OpenEncodingFile is fully tested by the rest of the tests in this file. test encoding-12.1 {LoadTableEncoding: normal encoding} { - set x [encoding convertto iso8859-3 \u120] - append x [encoding convertto iso8859-3 \ud5] - append x [encoding convertfrom iso8859-3 \xd5] + set x [encoding convertto iso8859-3 \u0120] + append x [encoding convertto iso8859-3 \xD5] + append x [encoding convertfrom iso8859-3 \xD5] } "\xd5?\u120" test encoding-12.2 {LoadTableEncoding: single-byte encoding} { set x [encoding convertto iso8859-3 ab\u0120g] - append x [encoding convertfrom iso8859-3 ab\xd5g] + append x [encoding convertfrom iso8859-3 ab\xD5g] } "ab\xd5gab\u120g" test encoding-12.3 {LoadTableEncoding: multi-byte encoding} { - set x [encoding convertto shiftjis ab\u4e4eg] + set x [encoding convertto shiftjis ab\u4E4Eg] append x [encoding convertfrom shiftjis ab\x8c\xc1g] } "ab\x8c\xc1gab\u4e4eg" test encoding-12.4 {LoadTableEncoding: double-byte encoding} { set x [encoding convertto jis0208 \u4e4e\u3b1] append x [encoding convertfrom jis0208 8C&A] @@ -302,14 +305,21 @@ test encoding-12.5 {LoadTableEncoding: symbol encoding} { set x [encoding convertto symbol \u3b3] append x [encoding convertto symbol \u67] append x [encoding convertfrom symbol \x67] } "\x67\x67\u3b3" +test encoding-12.6 {LoadTableEncoding: overflow in char value} ucs2 { + encoding convertto iso8859-3 \U010000 +} "?" test encoding-13.1 {LoadEscapeTable} { viewable [set x [encoding convertto iso2022 ab\u4e4e\u68d9g]] } [viewable "ab\x1b\$B8C\x1b\$\(DD%\x1b(Bg"] + +test encoding-14.1 {BinaryProc} { + encoding convertto identity \x12\x34\x56\xff\x69 +} "\x12\x34\x56\xc3\xbf\x69" test encoding-15.1 {UtfToUtfProc} { encoding convertto utf-8 \xa3 } "\xc2\xa3" test encoding-15.2 {UtfToUtfProc null character output} testbytestring { @@ -319,23 +329,108 @@ test encoding-15.3 {UtfToUtfProc null character input} teststringbytes { set y [encoding convertfrom utf-8 [encoding convertto utf-8 \u0000]] binary scan [teststringbytes $y] H* z set z } c080 +test encoding-15.4 {UtfToUtfProc emoji character input} -body { + set x \xED\xA0\xBD\xED\xB8\x82 + set y [encoding convertfrom utf-8 \xED\xA0\xBD\xED\xB8\x82] + list [string length $x] $y +} -result "6 \uD83D\uDE02" +test encoding-15.5 {UtfToUtfProc emoji character input} { + set x \xF0\x9F\x98\x82 + set y [encoding convertfrom utf-8 \xF0\x9F\x98\x82] + list [string length $x] $y +} "4 \uD83D\uDE02" +test encoding-15.6 {UtfToUtfProc emoji character output} { + set x \uDE02\uD83D\uDE02\uD83D + set y [encoding convertto utf-8 \uDE02\uD83D\uDE02\uD83D] + binary scan $y H* z + list [string length $y] $z +} {10 edb882f09f9882eda0bd} +test encoding-15.7 {UtfToUtfProc emoji character output} { + set x \uDE02\uD83D\uD83D + set y [encoding convertto utf-8 \uDE02\uD83D\uD83D] + binary scan $y H* z + list [string length $x] [string length $y] $z +} {3 9 edb882eda0bdeda0bd} +test encoding-15.8 {UtfToUtfProc emoji character output} { + set x \uDE02\uD83D\xE9 + set y [encoding convertto utf-8 \uDE02\uD83D\xE9] + binary scan $y H* z + list [string length $x] [string length $y] $z +} {3 8 edb882eda0bdc3a9} +test encoding-15.9 {UtfToUtfProc emoji character output} { + set x \uDE02\uD83DX + set y [encoding convertto utf-8 \uDE02\uD83DX] + binary scan $y H* z + list [string length $x] [string length $y] $z +} {3 7 edb882eda0bd58} +test encoding-15.10 {UtfToUtfProc high surrogate character output} { + set x \uDE02\xE9 + set y [encoding convertto utf-8 \uDE02\xE9] + binary scan $y H* z + list [string length $x] [string length $y] $z +} {2 5 edb882c3a9} +test encoding-15.11 {UtfToUtfProc low surrogate character output} { + set x \uDA02\xE9 + set y [encoding convertto utf-8 \uDA02\xE9] + binary scan $y H* z + list [string length $x] [string length $y] $z +} {2 5 eda882c3a9} +test encoding-15.12 {UtfToUtfProc high surrogate character output} { + set x \uDE02Y + set y [encoding convertto utf-8 \uDE02Y] + binary scan $y H* z + list [string length $x] [string length $y] $z +} {2 4 edb88259} +test encoding-15.13 {UtfToUtfProc low surrogate character output} { + set x \uDA02Y + set y [encoding convertto utf-8 \uDA02Y] + binary scan $y H* z + list [string length $x] [string length $y] $z +} {2 4 eda88259} +test encoding-15.14 {UtfToUtfProc high surrogate character output} { + set x \uDE02 + set y [encoding convertto utf-8 \uDE02] + binary scan $y H* z + list [string length $x] [string length $y] $z +} {1 3 edb882} +test encoding-15.15 {UtfToUtfProc low surrogate character output} { + set x \uDA02 + set y [encoding convertto utf-8 \uDA02] + binary scan $y H* z + list [string length $x] [string length $y] $z +} {1 3 eda882} +test encoding-15.16 {UtfToUtfProc: Invalid 4-byte UTF-8, see [ed29806ba]} { + set x \xF0\xA0\xA1\xC2 + set y [encoding convertfrom utf-8 \xF0\xA0\xA1\xC2] + list [string length $x] $y +} "4 \xF0\xA0\xA1\xC2" -test encoding-16.1 {UnicodeToUtfProc} -body { +test encoding-16.1 {UnicodeToUtfProc} { set val [encoding convertfrom unicode NN] list $val [format %x [scan $val %c]] -} -result "\u4e4e 4e4e" -test encoding-16.2 {UnicodeToUtfProc} -body { - set val [encoding convertfrom unicode "\xd8\xd8\xdc\xdc"] +} "\u4e4e 4e4e" +test encoding-16.2 {UnicodeToUtfProc} -constraints fullutf -body { + set val [encoding convertfrom unicode "\xD8\xD8\xDC\xDC"] + list $val [format %x [scan $val %c]] +} -result "\U460DC 460dc" +test encoding-16.3 {UnicodeToUtfProc} -body { + set val [encoding convertfrom unicode "\xDC\xDC"] list $val [format %x [scan $val %c]] -} -result "\U460dc 460dc" +} -result "\uDCDC dcdc" -test encoding-17.1 {UtfToUnicodeProc} -body { - encoding convertto unicode "\U460dc" -} -result "\xd8\xd8\xdc\xdc" +test encoding-17.1 {UtfToUnicodeProc} -constraints fullutf -body { + encoding convertto unicode "\U460DC" +} -result "\xD8\xD8\xDC\xDC" +test encoding-17.2 {UtfToUnicodeProc} -body { + encoding convertto unicode "\uDCDC" +} -result "\xDC\xDC" +test encoding-17.3 {UtfToUnicodeProc} -body { + encoding convertto unicode "\uD8D8" +} -result "\xD8\xD8" test encoding-18.1 {TableToUtfProc} { } {} test encoding-19.1 {TableFromUtfProc} { @@ -592,19 +687,19 @@ close $fb } -result {} } } -test encoding-26.0 {Tcl_GetEncodingSearchPath} -constraints { - testgetencpath +test encoding-26.0 {Tcl_GetDefaultEncodingDir} -constraints { + testgetdefenc } -setup { - set origPath [testgetencpath] - testsetencpath slappy + set origDir [testgetdefenc] + testsetdefenc slappy } -body { - testgetencpath + testgetdefenc } -cleanup { - testsetencpath $origPath + testsetdefenc $origDir } -result slappy file delete {*}[glob -directory [temporaryDirectory] *.chars *.tcltestout] # ===> Cut here <=== @@ -618,10 +713,25 @@ 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\"" } + + +test encoding-28.0 {all encodings load} -body { + set string hello + foreach name [encoding names] { + incr count + encoding convertto $name $string + + # discard the cached internal representation of Tcl_Encoding + # Unfortunately, without this, encoding 2-1 fails. + llength $name + } + return $count +} -result 81 + runtests } # cleanup Index: tests/env.test ================================================================== --- tests/env.test +++ tests/env.test @@ -9,17 +9,15 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } -loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] package require tcltests # [exec] is required here to see the actual environment received by child # processes. proc getenv {} { @@ -217,10 +215,30 @@ } -cleanup { cleanup1 } -result {NAME1=test string NAME2=more XYZZY=garbage} +test env-2.5 {different encoding (wide chars)} -constraints {win exec} -setup { + # be sure set of (unicode) environment occurs if single-byte encoding is used: + encodingswitch cp1252 + # german (cp1252) and russian (cp1251) characters together encoded as utf-8: + set val 2d2dc3a4c3b6c3bcc39f2dd182d0b5d181d1822d2d + set env(XYZZY) [encoding convertfrom utf-8 [binary decode hex $val]] + # now switch to utf-8 (to see correct values from test): + encoding system utf-8 +} -body { + exec [interpreter] << [string map [list \$val $val] { + encoding system utf-8; fconfigure stdout -encoding utf-8 + set test [encoding convertfrom utf-8 [binary decode hex $val]] + puts "[expr {$env(XYZZY) eq $test}] \ngot:\t\ + $env(XYZZY) ([binary encode hex [encoding convertto $env(XYZZY)]]) \nexp:\t\ + $test ([binary encode hex [encoding convertto $test]])" + }] +} -cleanup { + encodingrestore + unset -nocomplain val f env(XYZZY) +} -match glob -result {1 *} test env-3.1 { changing environment variables } -constraints exec -setup setup2 -body { set result [getenv] @@ -304,15 +322,15 @@ } -cleanup { interp delete i } -result {0} -test env-5.3 {corner cases: unset the env in master should unset child} -setup { +test env-5.3 {corner cases: unset the env in parent should unset child} -setup { setup1 interp create i } -body { - # Variables deleted in a master interp should be deleted in child interp + # Variables deleted in a parent interp should be deleted in child interp # too. i eval {set env(THIS_SHOULD_EXIST) a} set result [set env(THIS_SHOULD_EXIST)] unset env(THIS_SHOULD_EXIST) lappend result [i eval {catch {set env(THIS_SHOULD_EXIST)}}] @@ -399,12 +417,12 @@ } -result {i'm with dummy} # cleanup -rename getenv {} -rename envrestore {} +rename getenv {} +rename envrestore {} rename envprep {} rename encodingrestore {} rename encodingswitch {} removeFile $printenvScript Index: tests/error.test ================================================================== --- tests/error.test +++ tests/error.test @@ -9,12 +9,12 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } testConstraint memory [llength [info commands memory]] customMatch pairwise {apply {{a b} { Index: tests/eval.test ================================================================== --- tests/eval.test +++ tests/eval.test @@ -10,11 +10,11 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } test eval-1.1 {single argument} { eval {format 22} Index: tests/event.test ================================================================== --- tests/event.test +++ tests/event.test @@ -7,12 +7,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} catch { ::tcltest::loadTestedCommands package require -exact Tcltest [info patchlevel] set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1] @@ -21,20 +23,22 @@ testConstraint testfilehandler [llength [info commands testfilehandler]] testConstraint testexithandler [llength [info commands testexithandler]] testConstraint testfilewait [llength [info commands testfilewait]] testConstraint exec [llength [info commands exec]] - +testConstraint notOSX [expr {$::tcl_platform(os) ne "Darwin"}] + test event-1.1 {Tcl_CreateFileHandler, reading} -setup { testfilehandler close set result "" -} -constraints {testfilehandler} -body { +} -constraints {testfilehandler notOSX} -body { testfilehandler create 0 readable off testfilehandler clear 0 testfilehandler oneevent lappend result [testfilehandler counts 0] testfilehandler fillpartial 0 + update idletasks testfilehandler oneevent lappend result [testfilehandler counts 0] testfilehandler oneevent lappend result [testfilehandler counts 0] } -cleanup { Index: tests/exec.test ================================================================== --- tests/exec.test +++ tests/exec.test @@ -12,20 +12,23 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. # There is no point in running Valgrind on cases where [exec] forks but then # fails and the child process doesn't go through full cleanup. -package require tcltest 2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} -loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] package require tcltests # All tests require the "exec" command. # Skip them if exec is not defined. testConstraint exec [llength [info commands exec]] +# Some skips when running in a macOS CI environment +testConstraint noosxCI [expr {![info exists ::env(MAC_CI)]}] + unset -nocomplain path # Utilities that are like bourne shell stalwarts, but cross-platform. set path(echo) [makeFile { puts -nonewline [lindex $argv 0] @@ -667,11 +670,13 @@ } -result contents # Note that this test cannot be adapted to work on Windows; that platform has # no kernel support for an analog of O_APPEND. OTOH, that means we can assume # that there is a POSIX shell... -test exec-19.1 {exec >> uses O_APPEND} -constraints {exec unix notValgrind} -setup { +# +# This test also fails in some cases when building with macOS +test exec-19.1 {exec >> uses O_APPEND} -constraints {exec unix notValgrind noosxCI} -setup { set tmpfile [makeFile {0} tmpfile.exec-19.1] } -body { # Note that we have to allow for the current contents of the temporary # file, which is why the result is 14 and not 12 exec /bin/sh -c \ Index: tests/execute.test ================================================================== --- tests/execute.test +++ tests/execute.test @@ -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. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -32,13 +32,18 @@ [llength [info commands testobj]] && [llength [info commands testdoubleobj]] && [llength [info commands teststringobj]] }] -testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] +testConstraint longIs32bit [expr {int(0x80000000) < 0}] testConstraint testexprlongobj [llength [info commands testexprlongobj]] + +if {[namespace which -command testbumpinterpepoch] eq ""} { + proc testbumpinterpepoch {} { rename ::set ::dummy; rename ::dummy ::set } +} + # Tests for the omnibus TclExecuteByteCode function: # INST_DONE not tested # INST_PUSH1 not tested # INST_PUSH4 not tested @@ -172,11 +177,11 @@ expr {$x + 1} } 2.0 test execute-3.6 {TclExecuteByteCode, INST_ADD, op1 is non-numeric} {testobj} { set x [teststringobj set 0 foo] list [catch {expr {$x + 1}} msg] $msg -} {1 {can't use non-numeric string "foo" as operand of "+"}} +} {1 {can't use non-numeric string as operand of "+"}} test execute-3.7 {TclExecuteByteCode, INST_ADD, op2 is int} {testobj} { set x [testintobj set 0 1] expr {1 + $x} } 2 test execute-3.8 {TclExecuteByteCode, INST_ADD, op2 is double} {testobj} { @@ -197,11 +202,11 @@ expr {1 + $x} } 2.0 test execute-3.12 {TclExecuteByteCode, INST_ADD, op2 is non-numeric} {testobj} { set x [teststringobj set 0 foo] list [catch {expr {1 + $x}} msg] $msg -} {1 {can't use non-numeric string "foo" as operand of "+"}} +} {1 {can't use non-numeric string as operand of "+"}} # INST_SUB is partially tested: test execute-3.13 {TclExecuteByteCode, INST_SUB, op1 is int} {testobj} { set x [testintobj set 0 1] expr {$x - 1} @@ -224,11 +229,11 @@ expr {$x - 1} } 0.0 test execute-3.18 {TclExecuteByteCode, INST_SUB, op1 is non-numeric} {testobj} { set x [teststringobj set 0 foo] list [catch {expr {$x - 1}} msg] $msg -} {1 {can't use non-numeric string "foo" as operand of "-"}} +} {1 {can't use non-numeric string as operand of "-"}} test execute-3.19 {TclExecuteByteCode, INST_SUB, op2 is int} {testobj} { set x [testintobj set 0 1] expr {1 - $x} } 0 test execute-3.20 {TclExecuteByteCode, INST_SUB, op2 is double} {testobj} { @@ -249,11 +254,11 @@ expr {1 - $x} } 0.0 test execute-3.24 {TclExecuteByteCode, INST_SUB, op2 is non-numeric} {testobj} { set x [teststringobj set 0 foo] list [catch {expr {1 - $x}} msg] $msg -} {1 {can't use non-numeric string "foo" as operand of "-"}} +} {1 {can't use non-numeric string as operand of "-"}} # INST_MULT is partially tested: test execute-3.25 {TclExecuteByteCode, INST_MULT, op1 is int} {testobj} { set x [testintobj set 1 1] expr {$x * 1} @@ -276,11 +281,11 @@ expr {$x * 1} } 1.0 test execute-3.30 {TclExecuteByteCode, INST_MULT, op1 is non-numeric} {testobj} { set x [teststringobj set 1 foo] list [catch {expr {$x * 1}} msg] $msg -} {1 {can't use non-numeric string "foo" as operand of "*"}} +} {1 {can't use non-numeric string as operand of "*"}} test execute-3.31 {TclExecuteByteCode, INST_MULT, op2 is int} {testobj} { set x [testintobj set 1 1] expr {1 * $x} } 1 test execute-3.32 {TclExecuteByteCode, INST_MULT, op2 is double} {testobj} { @@ -301,11 +306,11 @@ expr {1 * $x} } 1.0 test execute-3.36 {TclExecuteByteCode, INST_MULT, op2 is non-numeric} {testobj} { set x [teststringobj set 1 foo] list [catch {expr {1 * $x}} msg] $msg -} {1 {can't use non-numeric string "foo" as operand of "*"}} +} {1 {can't use non-numeric string as operand of "*"}} # INST_DIV is partially tested: test execute-3.37 {TclExecuteByteCode, INST_DIV, op1 is int} {testobj} { set x [testintobj set 1 1] expr {$x / 1} @@ -328,11 +333,11 @@ expr {$x / 1} } 1.0 test execute-3.42 {TclExecuteByteCode, INST_DIV, op1 is non-numeric} {testobj} { set x [teststringobj set 1 foo] list [catch {expr {$x / 1}} msg] $msg -} {1 {can't use non-numeric string "foo" as operand of "/"}} +} {1 {can't use non-numeric string as operand of "/"}} test execute-3.43 {TclExecuteByteCode, INST_DIV, op2 is int} {testobj} { set x [testintobj set 1 1] expr {2 / $x} } 2 test execute-3.44 {TclExecuteByteCode, INST_DIV, op2 is double} {testobj} { @@ -353,11 +358,11 @@ expr {2 / $x} } 2.0 test execute-3.48 {TclExecuteByteCode, INST_DIV, op2 is non-numeric} {testobj} { set x [teststringobj set 1 foo] list [catch {expr {1 / $x}} msg] $msg -} {1 {can't use non-numeric string "foo" as operand of "/"}} +} {1 {can't use non-numeric string as operand of "/"}} # INST_UPLUS is partially tested: test execute-3.49 {TclExecuteByteCode, INST_UPLUS, op is int} {testobj} { set x [testintobj set 1 1] expr {+ $x} @@ -380,11 +385,11 @@ expr {+ $x} } 1.0 test execute-3.54 {TclExecuteByteCode, INST_UPLUS, op is non-numeric} {testobj} { set x [teststringobj set 1 foo] list [catch {expr {+ $x}} msg] $msg -} {1 {can't use non-numeric string "foo" as operand of "+"}} +} {1 {can't use non-numeric string as operand of "+"}} # INST_UMINUS is partially tested: test execute-3.55 {TclExecuteByteCode, INST_UMINUS, op is int} {testobj} { set x [testintobj set 1 1] expr {- $x} @@ -407,11 +412,11 @@ expr {- $x} } -1.0 test execute-3.60 {TclExecuteByteCode, INST_UMINUS, op is non-numeric} {testobj} { set x [teststringobj set 1 foo] list [catch {expr {- $x}} msg] $msg -} {1 {can't use non-numeric string "foo" as operand of "-"}} +} {1 {can't use non-numeric string as operand of "-"}} # INST_LNOT is partially tested: test execute-3.61 {TclExecuteByteCode, INST_LNOT, op is int} {testobj} { set x [testintobj set 1 2] expr {! $x} @@ -455,11 +460,15 @@ expr {! $x} } 1 test execute-3.71 {TclExecuteByteCode, INST_LNOT, op is non-numeric} {testobj} { set x [teststringobj set 1 foo] list [catch {expr {! $x}} msg] $msg -} {1 {can't use non-numeric string "foo" as operand of "!"}} +} {1 {can't use non-numeric string as operand of "!"}} + +# INST_BITNOT not tested +# INST_CALL_BUILTIN_FUNC1 not tested +# INST_CALL_FUNC1 not tested # INST_TRY_CVT_TO_NUMERIC is partially tested: test execute-3.72 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is int} {testobj} { set x [testintobj set 1 1] expr {$x} @@ -646,60 +655,60 @@ lappend result [namespace eval foo $script] } -cleanup { namespace delete foo } -result {0 AHA!} test execute-6.9 {TclCompEvalObj: bytecode interp validation} -setup { - interp create slave + interp create child } -body { set script { llength {} } - slave eval {proc llength args {return AHA!}} + child eval {proc llength args {return AHA!}} set result {} lappend result [if 1 $script] - lappend result [slave eval $script] + lappend result [child eval $script] } -cleanup { - interp delete slave + interp delete child } -result {0 AHA!} test execute-6.10 {TclCompEvalObj: bytecode interp validation} -body { set script { llength {} } - interp create slave + interp create child set result {} - lappend result [slave eval $script] - interp delete slave - interp create slave - lappend result [slave eval $script] + lappend result [child eval $script] + interp delete child + interp create child + lappend result [child eval $script] } -cleanup { - catch {interp delete slave} + catch {interp delete child} } -result {0 0} test execute-6.11 {Tcl_ExprObj: exprcode interp validation} -setup { - interp create slave + interp create child } -constraints testexprlongobj -body { set e { [llength {}]+1 } set result {} - load {} Tcltest slave - interp alias {} e slave testexprlongobj + load {} Tcltest child + interp alias {} e child testexprlongobj lappend result [e $e] - interp delete slave - interp create slave - load {} Tcltest slave - interp alias {} e slave testexprlongobj + interp delete child + interp create child + load {} Tcltest child + interp alias {} e child testexprlongobj lappend result [e $e] } -cleanup { - interp delete slave + interp delete child } -result {{This is a result: 1} {This is a result: 1}} test execute-6.12 {Tcl_ExprObj: exprcode interp validation} -setup { - interp create slave + interp create child } -body { set e { [llength {}]+1 } set result {} - interp alias {} e slave expr + interp alias {} e child expr lappend result [e $e] - interp delete slave - interp create slave - interp alias {} e slave expr + interp delete child + interp create child + interp alias {} e child expr lappend result [e $e] } -cleanup { - interp delete slave + interp delete child } -result {1 1} test execute-6.13 {Tcl_ExprObj: exprcode epoch validation} -body { set e { [llength {}]+1 } set result {} lappend result [expr $e] @@ -736,20 +745,20 @@ lappend result [namespace eval foo [list expr $e]] } -cleanup { namespace delete foo } -result {1 2} test execute-6.16 {Tcl_ExprObj: exprcode interp validation} -setup { - interp create slave + interp create child } -body { set e { [llength {}]+1 } - interp alias {} e slave expr - slave eval {proc llength args {return 1}} + interp alias {} e child expr + child eval {proc llength args {return 1}} set result {} lappend result [expr $e] lappend result [e $e] } -cleanup { - interp delete slave + interp delete child } -result {1 2} test execute-6.17 {Tcl_ExprObj: exprcode context validation} -body { proc foo e {set v 0; expr $e} proc bar e {set v 1; expr $e} set e { $v } @@ -799,64 +808,64 @@ test execute-7.7 {Wide int handling in INST_EQ and [incr]} { set x [expr {wide(1)<<62}] set y [expr {$x+1}] expr {double($x) == double($y)} } 1 -test execute-7.8 {Wide int conversions can change sign} { - set x 0x8000000000000000 - expr {wide($x) < 0} +test execute-7.8 {Wide int conversions can change sign} longIs32bit { + set x 0x80000000 + expr {int($x) < wide($x)} } 1 test execute-7.9 {Wide int handling in INST_MOD} { expr {(wide(1)<<60) % ((wide(47)<<45)-1)} } 316659348800185 test execute-7.10 {Wide int handling in INST_MOD} { expr {((wide(1)<<60)-1) % 0x400000000} } 17179869183 test execute-7.11 {Wide int handling in INST_LSHIFT} { - expr wide(42)<<30 + expr {wide(42) << 30} } 45097156608 test execute-7.12 {Wide int handling in INST_LSHIFT} { - expr 12345678901<<3 + expr {12345678901 << 3} } 98765431208 test execute-7.13 {Wide int handling in INST_RSHIFT} { - expr 0x543210febcda9876>>7 + expr {0x543210febcda9876 >> 7} } 47397893236700464 test execute-7.14 {Wide int handling in INST_RSHIFT} { - expr wide(0x9876543210febcda)>>7 + expr {wide(0x9876543210febcda) >> 7} } -58286587177206407 test execute-7.15 {Wide int handling in INST_BITOR} { - expr wide(0x9876543210febcda) | 0x543210febcda9876 + expr {wide(0x9876543210febcda) | 0x543210febcda9876} } -2560765885044310786 test execute-7.16 {Wide int handling in INST_BITXOR} { - expr wide(0x9876543210febcda) ^ 0x543210febcda9876 + expr {wide(0x9876543210febcda) ^ 0x543210febcda9876} } -3727778945703861076 test execute-7.17 {Wide int handling in INST_BITAND} { - expr wide(0x9876543210febcda) & 0x543210febcda9876 + expr {wide(0x9876543210febcda) & 0x543210febcda9876} } 1167013060659550290 test execute-7.18 {Wide int handling in INST_ADD} { - expr wide(0x7fffffff)+wide(0x7fffffff) + expr {wide(0x7fffffff) + wide(0x7fffffff)} } 4294967294 test execute-7.19 {Wide int handling in INST_ADD} { - expr 0x7fffffff+wide(0x7fffffff) + expr {0x7fffffff + wide(0x7fffffff)} } 4294967294 test execute-7.20 {Wide int handling in INST_ADD} { - expr wide(0x7fffffff)+0x7fffffff + expr {wide(0x7fffffff) + 0x7fffffff} } 4294967294 test execute-7.21 {Wide int handling in INST_ADD} { - expr double(0x7fffffff)+wide(0x7fffffff) + expr {double(0x7fffffff) + wide(0x7fffffff)} } 4294967294.0 test execute-7.22 {Wide int handling in INST_ADD} { - expr wide(0x7fffffff)+double(0x7fffffff) + expr {wide(0x7fffffff) + double(0x7fffffff)} } 4294967294.0 test execute-7.23 {Wide int handling in INST_SUB} { - expr 0x123456789a-0x20406080a + expr {0x123456789a - 0x20406080a} } 69530054800 test execute-7.24 {Wide int handling in INST_MULT} { - expr 0x123456789a*193 + expr {0x123456789a * 193} } 15090186251290 test execute-7.25 {Wide int handling in INST_DIV} { - expr 0x123456789a/193 + expr {0x123456789a / 193} } 405116546 test execute-7.26 {Wide int handling in INST_UPLUS} { set x 0x123456871234568 expr {+ $x} } 81985533099853160 @@ -881,16 +890,16 @@ set x 0xa23456871234568 incr x set y 0x123456871234568 concat [expr {abs($x)}] [expr {abs($y)}] } {730503879441204585 81985533099853160} -test execute-7.32 {Wide int handling} { +test execute-7.32 {Wide int handling} longIs32bit { expr {int(1024 * 1024 * 1024 * 1024)} -} 1099511627776 -test execute-7.33 {Wide int handling} { +} 0 +test execute-7.33 {Wide int handling} longIs32bit { expr {int(0x1 * 1024 * 1024 * 1024 * 1024)} -} 1099511627776 +} 0 test execute-7.34 {Wide int handling} { expr {wide(0x1) * 1024 * 1024 * 1024 * 1024} } 1099511627776 test execute-8.1 {Stack protection} -setup { @@ -927,12 +936,11 @@ # evaluation set arglst [string repeat "a " 1000] proc f {args} "f $arglst" proc run {} { # bump the interp's epoch - rename ::set ::dummy - rename ::dummy ::set + testbumpinterpepoch catch f msg set msg } run } -cleanup { @@ -942,12 +950,11 @@ proc foo {} { error bar } proc FOO {} { catch {error bar} m o - rename ::set ::dummy - rename ::dummy ::set + testbumpinterpepoch return -options $o $m } } -body { catch foo m o set stack1 [dict get $o -errorinfo] @@ -972,14 +979,84 @@ while executing "error FOO" invoked from within "catch \[list error FOO\] m o"} -errorline 2} +test execute-8.6 {Compile epoch bump in global level (bug [fa6bf38d07])} -setup { + interp create child + child eval { + package require tcltest 2.5 + catch [list package require -exact Tcltest [info patchlevel]] + ::tcltest::loadTestedCommands + if {[namespace which -command testbumpinterpepoch] eq ""} { + proc testbumpinterpepoch {} { rename ::set ::dummy; rename ::dummy ::set } + } + } +} -body { + child eval { + lappend res A; testbumpinterpepoch; lappend res B; return; lappend res C; + } + child eval { + set i 0; while {[incr i] < 3} { + lappend res A; testbumpinterpepoch; lappend res B; return; lappend res C; + } + } + child eval { + set i 0; while {[incr i] < 3} { + lappend res A; testbumpinterpepoch; lappend res B; break; lappend res C; + } + } + child eval { + catch { + lappend res A; testbumpinterpepoch; lappend res B; error test; lappend res C; + } + } + child eval {set res} +} -cleanup { + interp delete child +} -result [lrepeat 4 A B] +test execute-8.7 {Compile epoch bump in global level (bug [fa6bf38d07]), exception case} -setup { + interp create child + child eval { + package require tcltest 2.5 + catch [list package require -exact Tcltest [info patchlevel]] + ::tcltest::loadTestedCommands + if {[namespace which -command testbumpinterpepoch] eq ""} { + proc testbumpinterpepoch {} { rename ::set ::dummy; rename ::dummy ::set } + } + } +} -body { + set res {} + lappend res [catch { + child eval { + lappend res A; testbumpinterpepoch; lappend res B; return -code error test; lappend res C; + } + } e] $e + lappend res [catch { + child eval { + lappend res A; testbumpinterpepoch; lappend res B; error test; lappend res C; + } + } e] $e + lappend res [catch { + child eval { + lappend res A; testbumpinterpepoch; lappend res B; return -code return test; lappend res C; + } + } e] $e + lappend res [catch { + child eval { + lappend res A; testbumpinterpepoch; lappend res B; break; lappend res C; + } + } e] $e + list $res [child eval {set res}] +} -cleanup { + interp delete child +} -result [list {1 test 1 test 2 test 3 {}} [lrepeat 4 A B]] + test execute-9.1 {Interp result resetting [Bug 1522803]} { set c 0 catch { - catch {set foo} + catch {error foo} expr {1/$c} } if {[string match *foo* $::errorInfo]} { set result "Bad errorInfo: $::errorInfo" } else { @@ -990,20 +1067,20 @@ test execute-10.1 {TclExecuteByteCode, INST_CONCAT1, bytearrays} { apply {s {binary scan $s c x; list $x [scan $s$s %c%c]}} \u0130 } {48 {304 304}} test execute-10.2 {Bug 2802881} -setup { - interp create slave + interp create child } -body { # If [Bug 2802881] is not fixed, this will segfault - slave eval { + child eval { trace add variable ::errorInfo write {expr {$foo} ;#} proc demo {} {a {}{}} demo } } -cleanup { - interp delete slave + interp delete child } -returnCodes error -match glob -result * test execute-10.3 {Bug 3072640} -setup { proc generate {n} { for {set i 0} {$i < $n} {incr i} { yield $i @@ -1010,10 +1087,11 @@ } } proc t {args} { incr ::foo } + set ::foo 0 trace add execution ::generate enterstep ::t } -body { coroutine coro generate 5 trace remove execution ::generate enterstep ::t set ::foo @@ -1023,23 +1101,23 @@ rename t {} rename coro {} } -result 4 test execute-11.1 {Bug 3142026: GrowEvaluationStack off-by-one} -setup { - interp create slave + interp create child } -body { - slave eval { + child eval { set x [lrepeat 1320 199] for {set i 0} {$i < 20} {incr i} { lappend x $i lsort -integer $x } # Crashes on failure return ok } } -cleanup { - interp delete slave + interp delete child } -result ok test execute-11.2 {Bug 268b23df11} -setup { proc zero {} {return 0} proc crash {} {expr {abs([zero])}} Index: tests/expr-old.test ================================================================== --- tests/expr-old.test +++ tests/expr-old.test @@ -20,12 +20,17 @@ catch [list package require -exact Tcltest [info patchlevel]] testConstraint testexprlong [llength [info commands testexprlong]] testConstraint testexprdouble [llength [info commands testexprdouble]] testConstraint testexprstring [llength [info commands testexprstring]] -testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] -testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}] +testConstraint longIs32bit [expr {int(0x80000000) < 0}] + +if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} { + testConstraint testmathfunctions 0 +} else { + testConstraint testmathfunctions 1 +} # Big test for correct ordering of data in [expr] proc testIEEE {} { variable ieeeValues @@ -190,38 +195,38 @@ # Operators that aren't legal on floating-point numbers test expr-old-3.1 {illegal floating-point operations} { list [catch {expr ~4.0} msg] $msg -} {1 {can't use floating-point value "4.0" as operand of "~"}} +} {1 {can't use floating-point value as operand of "~"}} test expr-old-3.2 {illegal floating-point operations} { list [catch {expr 27%4.0} msg] $msg -} {1 {can't use floating-point value "4.0" as operand of "%"}} +} {1 {can't use floating-point value as operand of "%"}} test expr-old-3.3 {illegal floating-point operations} { list [catch {expr 27.0%4} msg] $msg -} {1 {can't use floating-point value "27.0" as operand of "%"}} +} {1 {can't use floating-point value as operand of "%"}} test expr-old-3.4 {illegal floating-point operations} { list [catch {expr 1.0<<3} msg] $msg -} {1 {can't use floating-point value "1.0" as operand of "<<"}} +} {1 {can't use floating-point value as operand of "<<"}} test expr-old-3.5 {illegal floating-point operations} { list [catch {expr 3<<1.0} msg] $msg -} {1 {can't use floating-point value "1.0" as operand of "<<"}} +} {1 {can't use floating-point value as operand of "<<"}} test expr-old-3.6 {illegal floating-point operations} { list [catch {expr 24.0>>3} msg] $msg -} {1 {can't use floating-point value "24.0" as operand of ">>"}} +} {1 {can't use floating-point value as operand of ">>"}} test expr-old-3.7 {illegal floating-point operations} { list [catch {expr 24>>3.0} msg] $msg -} {1 {can't use floating-point value "3.0" as operand of ">>"}} +} {1 {can't use floating-point value as operand of ">>"}} test expr-old-3.8 {illegal floating-point operations} { list [catch {expr 24&3.0} msg] $msg -} {1 {can't use floating-point value "3.0" as operand of "&"}} +} {1 {can't use floating-point value as operand of "&"}} test expr-old-3.9 {illegal floating-point operations} { list [catch {expr 24.0|3} msg] $msg -} {1 {can't use floating-point value "24.0" as operand of "|"}} +} {1 {can't use floating-point value as operand of "|"}} test expr-old-3.10 {illegal floating-point operations} { list [catch {expr 24.0^3} msg] $msg -} {1 {can't use floating-point value "24.0" as operand of "^"}} +} {1 {can't use floating-point value as operand of "^"}} # Check the string operators individually. test expr-old-4.1 {string operators} {expr {"abc" > "def"}} 0 test expr-old-4.2 {string operators} {expr {"def" > "def"}} 0 @@ -258,50 +263,50 @@ # Operators that aren't legal on string operands. test expr-old-5.1 {illegal string operations} { list [catch {expr {-"a"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "-"}} +} {1 {can't use non-numeric string as operand of "-"}} test expr-old-5.2 {illegal string operations} { list [catch {expr {+"a"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "+"}} +} {1 {can't use non-numeric string as operand of "+"}} test expr-old-5.3 {illegal string operations} { list [catch {expr {~"a"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "~"}} +} {1 {can't use non-numeric string as operand of "~"}} test expr-old-5.4 {illegal string operations} { list [catch {expr {!"a"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "!"}} +} {1 {can't use non-numeric string as operand of "!"}} test expr-old-5.5 {illegal string operations} { list [catch {expr {"a"*"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "*"}} +} {1 {can't use non-numeric string as operand of "*"}} test expr-old-5.6 {illegal string operations} { list [catch {expr {"a"/"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "/"}} +} {1 {can't use non-numeric string as operand of "/"}} test expr-old-5.7 {illegal string operations} { list [catch {expr {"a"%"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "%"}} +} {1 {can't use non-numeric string as operand of "%"}} test expr-old-5.8 {illegal string operations} { list [catch {expr {"a"+"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "+"}} +} {1 {can't use non-numeric string as operand of "+"}} test expr-old-5.9 {illegal string operations} { list [catch {expr {"a"-"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "-"}} +} {1 {can't use non-numeric string as operand of "-"}} test expr-old-5.10 {illegal string operations} { list [catch {expr {"a"<<"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "<<"}} +} {1 {can't use non-numeric string as operand of "<<"}} test expr-old-5.11 {illegal string operations} { list [catch {expr {"a">>"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of ">>"}} +} {1 {can't use non-numeric string as operand of ">>"}} test expr-old-5.12 {illegal string operations} { list [catch {expr {"a"&"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "&"}} +} {1 {can't use non-numeric string as operand of "&"}} test expr-old-5.13 {illegal string operations} { list [catch {expr {"a"^"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "^"}} +} {1 {can't use non-numeric string as operand of "^"}} test expr-old-5.14 {illegal string operations} { list [catch {expr {"a"|"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "|"}} +} {1 {can't use non-numeric string as operand of "|"}} test expr-old-5.15 {illegal string operations} { list [catch {expr {"a"&&"b"}} msg] $msg } {1 {expected boolean value but got "a"}} test expr-old-5.16 {illegal string operations} { list [catch {expr {"a"||"b"}} msg] $msg @@ -413,17 +418,17 @@ test expr-old-21.2 {parenthesization} {expr (1?0:4)||1} 1 test expr-old-21.3 {parenthesization} {expr +(3-4)} -1 # Embedded commands and variable names. -set a 16 -test expr-old-22.1 {embedded variables} {expr {2*$a}} 32 +set a 16 +test expr-old-22.1 {embedded variables} {expr {2*$a}} 32 test expr-old-22.2 {embedded variables} { set x -5 set y 10 expr {$x + $y} -} {5} +} {5} test expr-old-22.3 {embedded variables} { set x " -5" set y " +10" expr {$x + $y} } {5} @@ -486,11 +491,11 @@ # Various error conditions. test expr-old-26.1 {error conditions} { list [catch {expr 2+"a"} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "+"}} +} {1 {can't use non-numeric string as operand of "+"}} test expr-old-26.2 {error conditions} -body { expr 2+4* } -returnCodes error -match glob -result * test expr-old-26.3 {error conditions} -body { expr 2+4*( @@ -500,14 +505,14 @@ list [catch {expr 2+$_non_existent_} msg] $msg } {1 {can't read "_non_existent_": no such variable}} set a xx test expr-old-26.5 {error conditions} { list [catch {expr {2+$a}} msg] $msg -} {1 {can't use non-numeric string "xx" as operand of "+"}} +} {1 {can't use non-numeric string as operand of "+"}} test expr-old-26.6 {error conditions} { list [catch {expr {2+[set a]}} msg] $msg -} {1 {can't use non-numeric string "xx" as operand of "+"}} +} {1 {can't use non-numeric string as operand of "+"}} test expr-old-26.7 {error conditions} -body { expr {2+(4} } -returnCodes error -match glob -result * test expr-old-26.8 {error conditions} { list [catch {expr 2/0} msg] $msg $errorCode @@ -527,11 +532,11 @@ test expr-old-26.12 {error conditions} -body { expr a.b } -returnCodes error -match glob -result * test expr-old-26.13 {error conditions} { list [catch {expr {"a"/"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "/"}} +} {1 {can't use non-numeric string as operand of "/"}} test expr-old-26.14 {error conditions} -body { expr 2:3 } -returnCodes error -match glob -result * test expr-old-26.15 {error conditions} -body { expr a@b @@ -812,14 +817,14 @@ test expr-old-32.32 {math functions in expressions} { expr int(-1.6) } {-1} test expr-old-32.33 {math functions in expressions} { expr int(1e60) -} 999999999999999949387135297074018866963645011013410073083904 +} 0 test expr-old-32.34 {math functions in expressions} { expr int(-1e60) -} -999999999999999949387135297074018866963645011013410073083904 +} 0 test expr-old-32.35 {math functions in expressions} { expr round(1.49) } {1} test expr-old-32.36 {math functions in expressions} { expr round(1.51) @@ -840,19 +845,25 @@ list [catch {expr pow(1.0 + 3.0 - 2, .8 * 5)} msg] $msg } {0 16.0} test expr-old-32.42 {math functions in expressions} { list [catch {expr hypot(5*.8,3)} msg] $msg } {0 5.0} +test expr-old-32.43 {math functions in expressions} testmathfunctions { + expr 2*T1() +} 246 +test expr-old-32.44 {math functions in expressions} testmathfunctions { + expr T2()*3 +} 1035 test expr-old-32.45 {math functions in expressions} { expr (0 <= rand()) && (rand() < 1) } {1} test expr-old-32.46 {math functions in expressions} -body { list [catch {expr rand(24)} msg] $msg } -match glob -result {1 {too many arguments for math function*}} test expr-old-32.47 {math functions in expressions} -body { list [catch {expr srand()} msg] $msg -} -match glob -result {1 {too few arguments for math function*}} +} -match glob -result {1 {not enough arguments for math function*}} test expr-old-32.48 {math functions in expressions} -body { expr srand(3.79) } -returnCodes error -match glob -result * test expr-old-32.49 {math functions in expressions} -body { expr srand("") @@ -905,11 +916,11 @@ test expr-old-34.6 {errors in math functions} -body { expr hypot(1.0 , } -returnCodes error -match glob -result * test expr-old-34.7 {errors in math functions} -body { list [catch {expr hypot(1.0)} msg] $msg -} -match glob -result {1 {too few arguments for math function*}} +} -match glob -result {1 {not enough arguments for math function*}} test expr-old-34.8 {errors in math functions} -body { list [catch {expr hypot(1.0, 2.0, 3.0)} msg] $msg } -match glob -result {1 {too many arguments for math function*}} test expr-old-34.9 {errors in math functions} { list [catch {expr acos(-2.0)} msg] $msg $errorCode @@ -939,18 +950,22 @@ expr round(1.0e30) } 1000000000000000019884624838656 test expr-old-34.16 {errors in math functions} { expr round(-1.0e30) } -1000000000000000019884624838656 +test expr-old-34.17 {errors in math functions} -constraints testmathfunctions \ + -body { + list [catch {expr T1(4)} msg] $msg + } -match glob -result {1 {too many arguments for math function*}} test expr-old-36.1 {ExprLooksLikeInt procedure} -body { expr 0o289 } -returnCodes error -match glob -result {*invalid octal number*} test expr-old-36.2 {ExprLooksLikeInt procedure} { set x 0o289 list [catch {expr {$x+1}} msg] $msg -} {1 {can't use non-numeric string "0o289" as operand of "+"}} +} {1 {can't use invalid octal number as operand of "+"}} test expr-old-36.3 {ExprLooksLikeInt procedure} { list [catch {expr 0289.1} msg] $msg } {0 289.1} test expr-old-36.4 {ExprLooksLikeInt procedure} { set x 0289.1 @@ -986,23 +1001,23 @@ # tests for [Bug #587140] test expr-old-36.12 {ExprLooksLikeInt procedure} { set x "10;" list [catch {expr {$x+1}} msg] $msg -} {1 {can't use non-numeric string "10;" as operand of "+"}} +} {1 {can't use non-numeric string as operand of "+"}} test expr-old-36.13 {ExprLooksLikeInt procedure} { set x " +" list [catch {expr {$x+1}} msg] $msg -} {1 {can't use non-numeric string " +" as operand of "+"}} +} {1 {can't use non-numeric string as operand of "+"}} test expr-old-36.14 {ExprLooksLikeInt procedure} { set x "123456789012345678901234567890 " expr {$x+1} } 123456789012345678901234567891 test expr-old-36.15 {ExprLooksLikeInt procedure} { set x "0o99 " list [catch {expr {$x+1}} msg] $msg -} {1 {can't use non-numeric string "0o99 " as operand of "+"}} +} {1 {can't use invalid octal number as operand of "+"}} test expr-old-36.16 {ExprLooksLikeInt procedure} { set x " 0xffffffffffffffffffffffffffffffffffffff " expr {$x+1} } [expr 0x100000000000000000000000000000000000000] @@ -1035,12 +1050,12 @@ -result {1 {integer value too large to represent*}} test expr-old-37.8 {Tcl_ExprLong handles overflows} testexprlong { testexprlong -0x80000000 } {This is a result: -2147483648} test expr-old-37.9 {Tcl_ExprLong handles overflows} {testexprlong longIs32bit} { - testexprlong -0x7fffffff -} {This is a result: -2147483647} + testexprlong -0xffffffff +} {This is a result: 1} test expr-old-37.10 {Tcl_ExprLong handles overflows} \ -constraints {testexprlong longIs32bit} \ -match glob \ -body { list [catch {testexprlong -0x100000000} result] $result @@ -1060,17 +1075,13 @@ } \ -result {1 {integer value too large to represent*}} test expr-old-37.14 {Tcl_ExprLong handles overflows} testexprlong { testexprlong -2147483648. } {This is a result: -2147483648} -test expr-old-37.15 {Tcl_ExprLong handles overflows} \ - -constraints {testexprlong longIs32bit} \ - -match glob \ - -body { - list [catch {testexprlong -2147483649.} result] $result - } \ - -result {1 {integer value too large to represent*}} +test expr-old-37.15 {Tcl_ExprLong handles overflows} {testexprlong longIs32bit} { + testexprlong -4294967295. +} {This is a result: 1} test expr-old-37.16 {Tcl_ExprLong handles overflows} \ -constraints {testexprlong longIs32bit} \ -match glob \ -body { list [catch {testexprlong 4294967296.} result] $result @@ -1107,11 +1118,11 @@ } {This is a result: Inf} test expr-old-37.25 {Tcl_ExprDouble and NaN} \ {ieeeFloatingPoint testexprdouble} { list [catch {testexprdouble 0.0/0.0} result] $result } {1 {domain error: argument not in valid range}} - + test expr-old-38.1 {Verify Tcl_ExprString's basic operation} -constraints {testexprstring} -body { list [testexprstring "1+4"] [testexprstring "2*3+4.2"] \ [catch {testexprstring "1+"} msg] $msg } -match glob -result {5 10.2 1 *} test expr-old-38.2 {Tcl_ExprString} testexprstring { @@ -1146,52 +1157,40 @@ } -result 0 test expr-old-40.2 {min math function} -body { expr {min(0.0)} } -result 0.0 test expr-old-40.3 {min math function} -body { - expr {min()} -} -returnCodes error -result {too few arguments for math function "min"} + list [catch {expr {min()}} msg] $msg +} -result {1 {not enough arguments to math function "min"}} test expr-old-40.4 {min math function} -body { expr {min(wide(-1) << 30, 4.5, -10)} } -result [expr {wide(-1) << 30}] test expr-old-40.5 {min math function} -body { expr {min("a", 0)} } -returnCodes error -match glob -result * test expr-old-40.6 {min math function} -body { expr {min(300, "0xFF")} } -result 255 -test expr-old-40.7 {min math function} -body { - expr min(1[string repeat 0 10000], 1e300) -} -result 1e+300 -test expr-old-40.8 {min math function} -body { - expr {min(0, "a")} -} -returnCodes error -match glob -result * test expr-old-41.1 {max math function} -body { expr {max(0)} } -result 0 test expr-old-41.2 {max math function} -body { expr {max(0.0)} } -result 0.0 test expr-old-41.3 {max math function} -body { - expr {max()} -} -returnCodes error -result {too few arguments for math function "max"} + list [catch {expr {max()}} msg] $msg +} -result {1 {not enough arguments to math function "max"}} test expr-old-41.4 {max math function} -body { expr {max(wide(1) << 30, 4.5, -10)} } -result [expr {wide(1) << 30}] test expr-old-41.5 {max math function} -body { expr {max("a", 0)} } -returnCodes error -match glob -result * test expr-old-41.6 {max math function} -body { expr {max(200, "0xFF")} } -result 255 -test expr-old-41.7 {max math function} -body { - expr max(1[string repeat 0 10000], 1e300) -} -result 1[string repeat 0 10000] -test expr-old-41.8 {max math function} -body { - expr {max(0, "a")} -} -returnCodes error -match glob -result * # Special test for Pentium arithmetic bug of 1994: if {(4195835.0 - (4195835.0/3145727.0)*3145727.0) == 256.0} { puts "Warning: this machine contains a defective Pentium processor" Index: tests/expr.test ================================================================== --- tests/expr.test +++ tests/expr.test @@ -8,23 +8,29 @@ # Copyright (c) 1998-2000 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2.1 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + +testConstraint testmathfunctions [expr { + ([catch {expr T1()} msg] != 1) || ($msg ne {invalid command name "tcl::mathfunc::T1"}) +}] # Determine if "long int" type is a 32 bit number and if the wide # type is a 64 bit number on this machine. -testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] -testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}] -testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}] +testConstraint longIs32bit [expr {int(0x80000000) < 0}] +testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] +testConstraint wideIs64bit \ + [expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}] # Big test for correct ordering of data in [expr] proc testIEEE {} { variable ieeeValues @@ -130,11 +136,11 @@ 12days 1 1 1 set result [string length $xxx] unset xxx return $result } - + # start of tests catch {unset a b i x} test expr-1.1 {TclCompileExprCmd: no expression} { @@ -249,11 +255,11 @@ set i 7 expr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} } 1 test expr-4.10 {CompileLorExpr: error compiling ! operand} { list [catch {expr {!"a"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "!"}} +} {1 {can't use non-numeric string as operand of "!"}} test expr-4.11 {CompileLorExpr: error compiling land arms} { list [catch {expr {"a"||0}} msg] $msg } {1 {expected boolean value but got "a"}} test expr-4.12 {CompileLorExpr: error compiling land arms} { list [catch {expr {0||"a"}} msg] $msg @@ -296,14 +302,14 @@ test expr-6.8 {CompileBitXorExpr: error compiling bitxor arm} -body { expr 2^x } -returnCodes error -match glob -result * test expr-6.9 {CompileBitXorExpr: runtime error in bitxor arm} { list [catch {expr {24.0^3}} msg] $msg -} {1 {can't use floating-point value "24.0" as operand of "^"}} +} {1 {can't use floating-point value as operand of "^"}} test expr-6.10 {CompileBitXorExpr: runtime error in bitxor arm} { list [catch {expr {"a"^"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "^"}} +} {1 {can't use non-numeric string as operand of "^"}} test expr-7.1 {CompileBitAndExpr: just equality expr} {expr 3==2} 0 test expr-7.2 {CompileBitAndExpr: just equality expr} {expr 2.0==2} 1 test expr-7.3 {CompileBitAndExpr: just equality expr} {expr 3.2!=2.2} 1 test expr-7.4 {CompileBitAndExpr: just equality expr} {expr {"abc" == "abd"}} 0 @@ -320,14 +326,14 @@ test expr-7.11 {CompileBitAndExpr: error compiling bitand arm} -body { expr 2&x } -returnCodes error -match glob -result * test expr-7.12 {CompileBitAndExpr: runtime error in bitand arm} { list [catch {expr {24.0&3}} msg] $msg -} {1 {can't use floating-point value "24.0" as operand of "&"}} +} {1 {can't use floating-point value as operand of "&"}} test expr-7.13 {CompileBitAndExpr: runtime error in bitand arm} { list [catch {expr {"a"&"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "&"}} +} {1 {can't use non-numeric string as operand of "&"}} test expr-7.14 {CompileBitAndExpr: equality expr} {expr 3eq2} 0 test expr-7.18 {CompileBitAndExpr: equality expr} {expr {"abc" eq "abd"}} 0 test expr-7.20 {CompileBitAndExpr: error in equality expr} -body { expr xne3 } -returnCodes error -match glob -result * @@ -408,38 +414,21 @@ expr {1E+} } -returnCodes error -match glob -result * test expr-8.35 {expr edge cases} -body { expr {1ea} } -returnCodes error -match glob -result * -test expr-8.36 {CompileEqualtyExpr: string comparison ops} { - set x 012 - set y 0x0 - list [expr {$x < $y}] [expr {$x lt $y}] [expr {$x lt $x}] -} {0 1 0} -test expr-8.37 {CompileEqualtyExpr: string comparison ops} { - set x 012 - set y 0x0 - list [expr {$x <= $y}] [expr {$x le $y}] [expr {$x le $x}] -} {0 1 1} -test expr-8.38 {CompileEqualtyExpr: string comparison ops} { - set x 012 - set y 0x0 - list [expr {$x > $y}] [expr {$x gt $y}] [expr {$x gt $x}] -} {1 0 0} -test expr-8.39 {CompileEqualtyExpr: string comparison ops} { - set x 012 - set y 0x0 - list [expr {$x >= $y}] [expr {$x ge $y}] [expr {$x ge $x}] -} {1 0 1} test expr-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12 test expr-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63 test expr-9.3 {CompileRelationalExpr: just shift expr} {expr -1>>2} -1 test expr-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8 -test expr-9.5 {CompileRelationalExpr: shift expr producing LONG_MIN} { +test expr-9.5a {CompileRelationalExpr: shift expr producing LONG_MIN} longIs64bit { expr {int(1<<63)} -} 9223372036854775808 +} -9223372036854775808 +test expr-9.5b {CompileRelationalExpr: shift expr producing LONG_MIN} longIs32bit { + expr {int(1<<31)} +} -2147483648 test expr-9.6 {CompileRelationalExpr: error in shift expr} -body { expr x>>3 } -returnCodes error -match glob -result * test expr-9.7 {CompileRelationalExpr: simple relational exprs} {expr 0xff>=+0x3} 1 test expr-9.8 {CompileRelationalExpr: simple relational exprs} {expr -0xf2<0x3} 1 @@ -465,14 +454,14 @@ test expr-10.9 {CompileShiftExpr: error compiling shift arm} -body { expr 2<>43}} msg] $msg -} {1 {can't use floating-point value "24.0" as operand of ">>"}} +} {1 {can't use floating-point value as operand of ">>"}} test expr-10.11 {CompileShiftExpr: runtime error} { list [catch {expr {"a"<<"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "<<"}} +} {1 {can't use non-numeric string as operand of "<<"}} test expr-11.1 {CompileAddExpr: just multiply expr} {expr 4*-2} -8 test expr-11.2 {CompileAddExpr: just multiply expr} {expr 0xff%2} 1 test expr-11.3 {CompileAddExpr: just multiply expr} {expr -1/2} -1 test expr-11.4 {CompileAddExpr: just multiply expr} {expr 7891%0o123} 6 @@ -487,14 +476,14 @@ test expr-11.9 {CompileAddExpr: error compiling add arm} -body { expr 2-x } -returnCodes error -match glob -result * test expr-11.10 {CompileAddExpr: runtime error} { list [catch {expr {24.0+"xx"}} msg] $msg -} {1 {can't use non-numeric string "xx" as operand of "+"}} +} {1 {can't use non-numeric string as operand of "+"}} test expr-11.11 {CompileAddExpr: runtime error} { list [catch {expr {"a"-"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "-"}} +} {1 {can't use non-numeric string as operand of "-"}} test expr-11.12 {CompileAddExpr: runtime error} { list [catch {expr {3/0}} msg] $msg } {1 {divide by zero}} test expr-11.13a {CompileAddExpr: runtime error} !ieeeFloatingPoint { list [catch {expr {2.3/0.0}} msg] $msg @@ -518,14 +507,14 @@ test expr-12.9 {CompileMultiplyExpr: error compiling multiply arm} -body { expr 2*x } -returnCodes error -match glob -result * test expr-12.10 {CompileMultiplyExpr: runtime error} { list [catch {expr {24.0*"xx"}} msg] $msg -} {1 {can't use non-numeric string "xx" as operand of "*"}} +} {1 {can't use non-numeric string as operand of "*"}} test expr-12.11 {CompileMultiplyExpr: runtime error} { list [catch {expr {"a"/"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "/"}} +} {1 {can't use non-numeric string as operand of "/"}} test expr-13.1 {CompileUnaryExpr: unary exprs} {expr -0xff} -255 test expr-13.2 {CompileUnaryExpr: unary exprs} {expr +0o00123} 83 test expr-13.3 {CompileUnaryExpr: unary exprs} {expr +--++36} 36 test expr-13.4 {CompileUnaryExpr: unary exprs} {expr !2} 0 @@ -538,14 +527,14 @@ test expr-13.9 {CompileUnaryExpr: error compiling unary expr} -body { expr !1.x } -returnCodes error -match glob -result * test expr-13.10 {CompileUnaryExpr: runtime error} { list [catch {expr {~"xx"}} msg] $msg -} {1 {can't use non-numeric string "xx" as operand of "~"}} +} {1 {can't use non-numeric string as operand of "~"}} test expr-13.11 {CompileUnaryExpr: runtime error} { list [catch {expr ~4.0} msg] $msg -} {1 {can't use floating-point value "4.0" as operand of "~"}} +} {1 {can't use floating-point value as operand of "~"}} test expr-13.12 {CompileUnaryExpr: just primary expr} {expr 0x123} 291 test expr-13.13 {CompileUnaryExpr: just primary expr} { set a 27 expr $a } 27 @@ -682,22 +671,57 @@ while *ing "expr sin(1,2,3)"} test expr-15.4 {CompileMathFuncCall: ')' found before last required arg} -body { catch {expr sin()} msg set ::errorInfo -} -match glob -result {too few arguments for math function* +} -match glob -result {not enough arguments for math function* while *ing "expr sin()"} -test expr-15.5 {CompileMathFuncCall: too few arguments} -body { +test expr-15.5 {CompileMathFuncCall: not enough arguments} -body { catch {expr pow(1)} msg set ::errorInfo -} -match glob -result {too few arguments for math function* +} -match glob -result {not enough arguments for math function* while *ing "expr pow(1)"} test expr-15.6 {CompileMathFuncCall: missing ')'} -body { expr sin(1 } -returnCodes error -match glob -result * +test expr-15.7 {CompileMathFuncCall: call registered math function} {testmathfunctions} { + expr 2*T1() +} 246 +test expr-15.8 {CompileMathFuncCall: call registered math function} {testmathfunctions} { + expr T2()*3 +} 1035 +test expr-15.9 {CompileMathFuncCall: call registered math function} {testmathfunctions} { + expr T3(21, 37) +} 37 +test expr-15.10 {CompileMathFuncCall: call registered math function} {testmathfunctions} { + expr T3(21.2, 37) +} 37.0 +test expr-15.11 {CompileMathFuncCall: call registered math function} {testmathfunctions} { + expr T3(-21.2, -17.5) +} -17.5 +test expr-15.12 {ExprCallMathFunc: call registered math function} {testmathfunctions} { + expr T3(21, wide(37)) +} 37 +test expr=15.13 {ExprCallMathFunc: call registered math function} {testmathfunctions} { + expr T3(wide(21), 37) +} 37 +test expr=15.14 {ExprCallMathFunc: call registered math function} {testmathfunctions} { + expr T3(wide(21), wide(37)) +} 37 +test expr-15.15 {ExprCallMathFunc: call registered math function} {testmathfunctions} { + expr T3(21.0, wide(37)) +} 37.0 +test expr-15.16 {ExprCallMathFunc: call registered math function} {testmathfunctions} { + expr T3(wide(21), 37.0) +} 37.0 +test expr-15.17 {ExprCallMathFunc: non-numeric arg} -constraints { + testmathfunctions +} -body { + expr T3(0,"a") +} -returnCodes error -result {argument to math function didn't have numeric value} test expr-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} { catch {unset a} set a(VALUE) ff15 @@ -818,19 +842,19 @@ test expr-21.13 {non-numeric boolean literals} -body { expr !truef } -returnCodes error -match glob -result * test expr-21.14 {non-numeric boolean literals} { list [catch {expr !"truef"} err] $err -} {1 {can't use non-numeric string "truef" as operand of "!"}} +} {1 {can't use non-numeric string as operand of "!"}} test expr-21.15 {non-numeric boolean variables} { set v truef list [catch {expr {!$v}} err] $err -} {1 {can't use non-numeric string "truef" as operand of "!"}} +} {1 {can't use non-numeric string as operand of "!"}} test expr-21.16 {non-numeric boolean variables} { set v "true " list [catch {expr {!$v}} err] $err -} {1 {can't use non-numeric string "true " as operand of "!"}} +} {1 {can't use non-numeric string as operand of "!"}} test expr-21.17 {non-numeric boolean variables} { set v "tru" list [catch {expr {!$v}} err] $err } {0 0} test expr-21.18 {non-numeric boolean variables} { @@ -846,27 +870,27 @@ list [catch {expr {!$v}} err] $err } {0 1} test expr-21.21 {non-numeric boolean variables} { set v "o" list [catch {expr {!$v}} err] $err -} {1 {can't use non-numeric string "o" as operand of "!"}} +} {1 {can't use non-numeric string as operand of "!"}} test expr-21.22 {non-numeric boolean variables} { set v "" list [catch {expr {!$v}} err] $err -} {1 {can't use non-numeric string "" as operand of "!"}} +} {1 {can't use empty string as operand of "!"}} # Test for non-numeric float handling. test expr-22.1 {non-numeric floats} { list [catch {expr {NaN + 1}} msg] $msg -} {1 {can't use non-numeric floating-point value "NaN" as operand of "+"}} +} {1 {can't use non-numeric floating-point value as operand of "+"}} test expr-22.2 {non-numeric floats} !ieeeFloatingPoint { list [catch {expr {Inf + 1}} msg] $msg } {1 {can't use infinite floating-point value as operand of "+"}} test expr-22.3 {non-numeric floats} { set nan NaN list [catch {expr {$nan + 1}} msg] $msg -} {1 {can't use non-numeric floating-point value "NaN" as operand of "+"}} +} {1 {can't use non-numeric floating-point value as operand of "+"}} test expr-22.4 {non-numeric floats} !ieeeFloatingPoint { set inf Inf list [catch {expr {$inf + 1}} msg] $msg } {1 {can't use infinite floating-point value as operand of "+"}} test expr-22.5 {non-numeric floats} { @@ -875,11 +899,11 @@ test expr-22.6 {non-numeric floats} !ieeeFloatingPoint { list [catch {expr Inf} msg] $msg } {1 {floating-point value too large to represent}} test expr-22.7 {non-numeric floats} { list [catch {expr {1 / NaN}} msg] $msg -} {1 {can't use non-numeric floating-point value "NaN" as operand of "/"}} +} {1 {can't use non-numeric floating-point value as operand of "/"}} test expr-22.8 {non-numeric floats} !ieeeFloatingPoint { list [catch {expr {1 / Inf}} msg] $msg } {1 {can't use infinite floating-point value as operand of "/"}} # Make sure [Bug 761471] stays fixed. test expr-22.9 {non-numeric floats: shared object equality and NaN} { @@ -911,14 +935,14 @@ test expr-23.8 {CompileExponentialExpr: error compiling expo arm} -body { expr 2**x } -returnCodes error -match glob -result * test expr-23.9 {CompileExponentialExpr: runtime error} { list [catch {expr {24.0**"xx"}} msg] $msg -} {1 {can't use non-numeric string "xx" as operand of "**"}} +} {1 {can't use non-numeric string as operand of "**"}} test expr-23.10 {CompileExponentialExpr: runtime error} { list [catch {expr {"a"**2}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "**"}} +} {1 {can't use non-numeric string as operand of "**"}} test expr-23.11 {CompileExponentialExpr: runtime error} { list [catch {expr {0**-1}} msg] $msg } {1 {exponentiation of zero by negative power}} test expr-23.12 {CompileExponentialExpr: runtime error} { list [catch {expr {0.0**-1.0}} msg] $msg @@ -1412,18 +1436,18 @@ } -returnCodes error -result {exponent too large} test expr-23.74.3 {INST_EXPON: Bug 2798543} { expr {(-14)**17 == (-14)**65553} } 0 - + # Some compilers get this wrong; ensure that we work around it correctly test expr-24.1 {expr edge cases; shifting} {expr int(5)>>32} 0 test expr-24.2 {expr edge cases; shifting} {expr int(5)>>63} 0 test expr-24.3 {expr edge cases; shifting} {expr wide(5)>>32} 0 test expr-24.4 {expr edge cases; shifting} {expr wide(5)>>63} 0 -test expr-24.5 {expr edge cases; shifting} {expr int(5<<32)} 21474836480 -test expr-24.6 {expr edge cases; shifting} {expr int(5<<63)} 46116860184273879040 +test expr-24.5 {expr edge cases; shifting} longIs32bit {expr int(5<<32)} 0 +test expr-24.6 {expr edge cases; shifting} longIs32bit {expr int(5<<63)} 0 test expr-24.7 {expr edge cases; shifting} {expr wide(5)<<32} 21474836480 test expr-24.8 {expr edge cases; shifting} {expr wide(10<<63)} 0 test expr-24.9 {expr edge cases; shifting} {expr 5>>32} 0 test expr-24.10 {INST_LSHIFT: Bug 1567222} {expr 500000000000000<<28} 134217728000000000000000 @@ -5760,11 +5784,11 @@ 0 0 2 2 2 \ 0 0 -1 -2 -3 \ 0 1 0 3 3 \ 0 -1 0 -1 -2 \ ] - + test expr-32.2 {expr div basics} { set mod_nums [list \ {-3 1} {-3 2} {-3 3} {-3 4} {-3 5} \ {-3 -1} {-3 -2} {-3 -3} {-3 -4} {-3 -5} \ {-2 1} {-2 2} {-2 3} {-2 4} {-2 5} \ @@ -5822,11 +5846,11 @@ } 0 test expr-32.9 {bignum regression} { expr {0%-(1+(1<<63))} } 0 -test expr-33.1 {parse largest long value} { +test expr-33.1 {parse largest long value} longIs32bit { set max_long_str 2147483647 set max_long_hex "0x7FFFFFFF " # Convert to integer (long, not wide) internal rep set max_long 2147483647 @@ -5836,11 +5860,11 @@ [expr {" $max_long_str "}] \ [expr {$max_long_str + 0}] \ [expr {$max_long + 0}] \ [expr {2147483647 + 0}] \ [expr {$max_long == $max_long_hex}] \ - [expr {int(2147483647 + 1) > 0}] \ + [expr {int(2147483647 + 1) < 0}] \ } {2147483647 2147483647 2147483647 2147483647 1 1} test expr-33.2 {parse smallest long value} longIs32bit { set min_long_str -2147483648 set min_long_hex "-0x80000000 " @@ -5856,11 +5880,11 @@ [expr {" $min_long_str "}] \ [expr {$min_long_str + 0}] \ [expr {$min_long + 0}] \ [expr {-2147483648 + 0}] \ [expr {$min_long == $min_long_hex}] \ - [expr {int(-2147483648 - 1) == -0x80000001}] \ + [expr {int(-2147483648 - 1) == 0x7FFFFFFF}] \ } {-2147483648 -2147483648 -2147483648 -2147483648 1 1} test expr-33.3 {parse largest wide value} wideIs64bit { set max_wide_str 9223372036854775807 set max_wide_hex "0x7FFFFFFFFFFFFFFF " @@ -5936,21 +5960,21 @@ expr {$min / -2} } {1073741824} test expr-34.12 {expr edge cases} { expr {$min % -2} } {0} -test expr-34.13 {expr edge cases} { +test expr-34.13 {expr edge cases} longIs32bit { expr {int($min / -1)} -} {2147483648} +} {-2147483648} test expr-34.14 {expr edge cases} { expr {$min % -1} } {0} -test expr-34.15 {expr edge cases} { - expr {-int($min * -1)} +test expr-34.15 {expr edge cases} longIs32bit { + expr {int($min * -1)} } $min -test expr-34.16 {expr edge cases} { - expr {-int(-$min)} +test expr-34.16 {expr edge cases} longIs32bit { + expr {int(-$min)} } $min test expr-34.17 {expr edge cases} { expr {$min / 1} } $min test expr-34.18 {expr edge cases} { @@ -6733,12 +6757,12 @@ -result {1 {integer value too large to represent*}} test expr-39.8 {Tcl_ExprLongObj handles overflows} testexprlongobj { testexprlongobj -0x80000000 } {This is a result: -2147483648} test expr-39.9 {Tcl_ExprLongObj handles overflows} {testexprlongobj longIs32bit} { - testexprlongobj -0x7fffffff -} {This is a result: -2147483647} + testexprlongobj -0xffffffff +} {This is a result: 1} test expr-39.10 {Tcl_ExprLongObj handles overflows} \ -constraints {testexprlongobj longIs32bit} \ -match glob \ -body { list [catch {testexprlongobj -0x100000000} result] $result @@ -6759,20 +6783,20 @@ -result {1 {integer value too large to represent*}} test expr-39.14 {Tcl_ExprLongObj handles overflows} testexprlongobj { testexprlongobj -2147483648. } {This is a result: -2147483648} test expr-39.15 {Tcl_ExprLongObj handles overflows} {testexprlongobj longIs32bit} { - testexprlongobj -2147483648. -} {This is a result: -2147483648} + testexprlongobj -4294967295. +} {This is a result: 1} test expr-39.16 {Tcl_ExprLongObj handles overflows} \ -constraints {testexprlongobj longIs32bit} \ -match glob \ -body { list [catch {testexprlongobj 4294967296.} result] $result } \ -result {1 {integer value too large to represent*}} - + test expr-39.17 {Check that Tcl_ExprDoubleObj doesn't modify interpreter result if no error} testexprdoubleobj { testexprdoubleobj 4.+1. } {This is a result: 5.0} #Check for [Bug 1109484] test expr-39.18 {Tcl_ExprDoubleObj on the empty string} \ @@ -6818,10 +6842,76 @@ expr 1.0e2147483630 } Inf test expr-41.2 {exponent underflow} { expr 1.0e-2147483630 } 0.0 + +test expr-41.3 {exponent overflow} { + expr 1e2147483647 +} Inf +test expr-41.4 {exponent overflow} { + expr 1e2147483648 +} Inf +test expr-41.5 {exponent overflow} { + expr 100e2147483645 +} Inf +test expr-41.6 {exponent overflow} { + expr 100e2147483646 +} Inf +test expr-41.7 {exponent overflow} { + expr 1.0e2147483647 +} Inf +test expr-41.8 {exponent overflow} { + expr 1.0e2147483648 +} Inf +test expr-41.9 {exponent overflow} { + expr 1.2e2147483647 +} Inf +test expr-41.10 {exponent overflow} { + expr 1.2e2147483648 +} Inf + +test expr-41.11 {exponent overflow} { + expr 1e-2147483648 +} 0.0 +test expr-41.12 {exponent overflow} { + expr 1e-2147483649 +} 0.0 +test expr-41.13 {exponent overflow} { + expr 100e-2147483650 +} 0.0 +test expr-41.14 {exponent overflow} { + expr 100e-2147483651 +} 0.0 +test expr-41.15 {exponent overflow} { + expr 1.0e-2147483648 +} 0.0 +test expr-41.16 {exponent overflow} { + expr 1.0e-2147483649 +} 0.0 +test expr-41.17 {exponent overflow} { + expr 1.23e-2147483646 +} 0.0 +test expr-41.18 {exponent overflow} { + expr 1.23e-2147483647 +} 0.0 + +test expr-41.19 {numSigDigs == 0} { + expr 0e309 +} 0.0 +test expr-41.20 {numSigDigs == 0} { + expr 0e310 +} 0.0 +test expr-41.21 {negative zero, large exponent} { + expr -0e309 +} -0.0 +test expr-41.22 {negative zero, large exponent} { + expr -0e310 +} -0.0 +test expr-41.23 {floating point overflow on significand (Bug 1de6b0629e)} { + expr 123[string repeat 0 309]1e-310 +} 123.0 test expr-42.1 {denormals} ieeeFloatingPoint { expr 7e-324 } 5e-324 @@ -7177,154 +7267,21 @@ } { set a [list one two three] list [expr {$a eq {}}] [expr {$a < {}}] [expr {$a > {}}] [ string match {*no string representation*} [ ::tcl::unsupported::representation $a]] -} {0 0 1 1} - -foreach func {isfinite isinf isnan isnormal issubnormal} { - test expr-53.1.$func {float classification: basic arg handling} -body { - expr ${func}() - } -returnCodes error -result "too few arguments for math function \"$func\"" - test expr-53.2.$func {float classification: basic arg handling} -body { - expr ${func}(1,2) - } -returnCodes error -result "too many arguments for math function \"$func\"" - test expr-53.3.$func {float classification: basic arg handling} -body { - expr ${func}(true) - } -returnCodes error -result {expected number but got "true"} - test expr-53.4.$func {float classification: basic arg handling} -body { - expr ${func}("gorp") - } -returnCodes error -result {expected number but got "gorp"} - test expr-53.5.$func {float classification: basic arg handling} -body { - expr ${func}(1.0) - } -match glob -result * - test expr-53.6.$func {float classification: basic arg handling} -body { - expr ${func}(0x123) - } -match glob -result * -} - -test expr-54.0 {float classification: isfinite} {expr {isfinite(1.0)}} 1 -test expr-54.1 {float classification: isfinite} {expr {isfinite(-1.0)}} 1 -test expr-54.2 {float classification: isfinite} {expr {isfinite(0.0)}} 1 -test expr-54.3 {float classification: isfinite} {expr {isfinite(-0.0)}} 1 -test expr-54.4 {float classification: isfinite} {expr {isfinite(1/Inf)}} 1 -test expr-54.5 {float classification: isfinite} {expr {isfinite(-1/Inf)}} 1 -test expr-54.6 {float classification: isfinite} {expr {isfinite(1e-314)}} 1 -test expr-54.7 {float classification: isfinite} {expr {isfinite(inf)}} 0 -test expr-54.8 {float classification: isfinite} {expr {isfinite(-inf)}} 0 -test expr-54.9 {float classification: isfinite} {expr {isfinite(NaN)}} 0 - -test expr-55.0 {float classification: isinf} {expr {isinf(1.0)}} 0 -test expr-55.1 {float classification: isinf} {expr {isinf(-1.0)}} 0 -test expr-55.2 {float classification: isinf} {expr {isinf(0.0)}} 0 -test expr-55.3 {float classification: isinf} {expr {isinf(-0.0)}} 0 -test expr-55.4 {float classification: isinf} {expr {isinf(1/Inf)}} 0 -test expr-55.5 {float classification: isinf} {expr {isinf(-1/Inf)}} 0 -test expr-55.6 {float classification: isinf} {expr {isinf(1e-314)}} 0 -test expr-55.7 {float classification: isinf} {expr {isinf(inf)}} 1 -test expr-55.8 {float classification: isinf} {expr {isinf(-inf)}} 1 -test expr-55.9 {float classification: isinf} {expr {isinf(NaN)}} 0 - -test expr-56.0 {float classification: isnan} {expr {isnan(1.0)}} 0 -test expr-56.1 {float classification: isnan} {expr {isnan(-1.0)}} 0 -test expr-56.2 {float classification: isnan} {expr {isnan(0.0)}} 0 -test expr-56.3 {float classification: isnan} {expr {isnan(-0.0)}} 0 -test expr-56.4 {float classification: isnan} {expr {isnan(1/Inf)}} 0 -test expr-56.5 {float classification: isnan} {expr {isnan(-1/Inf)}} 0 -test expr-56.6 {float classification: isnan} {expr {isnan(1e-314)}} 0 -test expr-56.7 {float classification: isnan} {expr {isnan(inf)}} 0 -test expr-56.8 {float classification: isnan} {expr {isnan(-inf)}} 0 -test expr-56.9 {float classification: isnan} {expr {isnan(NaN)}} 1 - -test expr-57.0 {float classification: isnormal} {expr {isnormal(1.0)}} 1 -test expr-57.1 {float classification: isnormal} {expr {isnormal(-1.0)}} 1 -test expr-57.2 {float classification: isnormal} {expr {isnormal(0.0)}} 0 -test expr-57.3 {float classification: isnormal} {expr {isnormal(-0.0)}} 0 -test expr-57.4 {float classification: isnormal} {expr {isnormal(1/Inf)}} 0 -test expr-57.5 {float classification: isnormal} {expr {isnormal(-1/Inf)}} 0 -test expr-57.6 {float classification: isnormal} {expr {isnormal(1e-314)}} 0 -test expr-57.7 {float classification: isnormal} {expr {isnormal(inf)}} 0 -test expr-57.8 {float classification: isnormal} {expr {isnormal(-inf)}} 0 -test expr-57.9 {float classification: isnormal} {expr {isnormal(NaN)}} 0 - -test expr-58.0 {float classification: issubnormal} {expr {issubnormal(1.0)}} 0 -test expr-58.1 {float classification: issubnormal} {expr {issubnormal(-1.0)}} 0 -test expr-58.2 {float classification: issubnormal} {expr {issubnormal(0.0)}} 0 -test expr-58.3 {float classification: issubnormal} {expr {issubnormal(-0.0)}} 0 -test expr-58.4 {float classification: issubnormal} {expr {issubnormal(1/Inf)}} 0 -test expr-58.5 {float classification: issubnormal} {expr {issubnormal(-1/Inf)}} 0 -test expr-58.6 {float classification: issubnormal} {expr {issubnormal(1e-314)}} 1 -test expr-58.7 {float classification: issubnormal} {expr {issubnormal(inf)}} 0 -test expr-58.8 {float classification: issubnormal} {expr {issubnormal(-inf)}} 0 -test expr-58.9 {float classification: issubnormal} {expr {issubnormal(NaN)}} 0 - -test expr-59.0 {float classification: fpclassify} {fpclassify 1.0} normal -test expr-59.1 {float classification: fpclassify} {fpclassify -1.0} normal -test expr-59.2 {float classification: fpclassify} {fpclassify 0.0} zero -test expr-59.3 {float classification: fpclassify} {fpclassify -0.0} zero -test expr-59.4 {float classification: fpclassify} {fpclassify [expr 1/Inf]} zero -test expr-59.5 {float classification: fpclassify} {fpclassify [expr -1/Inf]} zero -test expr-59.6 {float classification: fpclassify} {fpclassify 1e-314} subnormal -test expr-59.7 {float classification: fpclassify} {fpclassify inf} infinite -test expr-59.8 {float classification: fpclassify} {fpclassify -inf} infinite -test expr-59.9 {float classification: fpclassify} {fpclassify NaN} nan -test expr-59.10 {float classification: fpclassify} -returnCodes error -body { - fpclassify -} -result {wrong # args: should be "fpclassify floatValue"} -test expr-59.11 {float classification: fpclassify} -returnCodes error -body { - fpclassify a b -} -result {wrong # args: should be "fpclassify floatValue"} -test expr-59.12 {float classification: fpclassify} -returnCodes error -body { - fpclassify gorp -} -result {expected number but got "gorp"} - -test expr-60.1 {float classification: basic arg handling} -body { - expr isunordered() -} -returnCodes error -result {too few arguments for math function "isunordered"} -test expr-60.2 {float classification: basic arg handling} -body { - expr isunordered(1) -} -returnCodes error -result {too few arguments for math function "isunordered"} -test expr-60.3 {float classification: basic arg handling} -body { - expr {isunordered(1, 2, 3)} -} -returnCodes error -result {too many arguments for math function "isunordered"} -test expr-60.4 {float classification: basic arg handling} -body { - expr {isunordered(true, 1.0)} -} -returnCodes error -result {expected number but got "true"} -test expr-60.5 {float classification: basic arg handling} -body { - expr {isunordered("gorp", 1.0)} -} -returnCodes error -result {expected number but got "gorp"} -test expr-60.6 {float classification: basic arg handling} -body { - expr {isunordered(0x123, 1.0)} -} -match glob -result * -test expr-60.7 {float classification: basic arg handling} -body { - expr {isunordered(1.0, true)} -} -returnCodes error -result {expected number but got "true"} -test expr-60.8 {float classification: basic arg handling} -body { - expr {isunordered(1.0, "gorp")} -} -returnCodes error -result {expected number but got "gorp"} -test expr-60.9 {float classification: basic arg handling} -body { - expr {isunordered(1.0, 0x123)} -} -match glob -result * - -# Big matrix of comparisons, but it's just a binary isinf() -set values {1.0 -1.0 0.0 -0.0 1e-314 Inf -Inf NaN} -set results {0 0 0 0 0 0 0 1} -set ctr 0 -foreach v1 $values r1 $results { - foreach v2 $values r2 $results { - test expr-61.[incr ctr] "float classification: isunordered($v1,$v2)" { - expr {isunordered($v1, $v2)} - } [expr {$r1 || $r2}] - } -} -unset -nocomplain values results ctr - -# cleanup -unset -nocomplain a -unset -nocomplain min -unset -nocomplain max +} {0 0 1 1} + + + +# cleanup +if {[info exists a]} { + unset a +} +catch {unset min} +catch {unset max} ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: Index: tests/fCmd.test ================================================================== --- tests/fCmd.test +++ tests/fCmd.test @@ -9,11 +9,11 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -21,11 +21,11 @@ cd [temporaryDirectory] testConstraint testsetplatform [llength [info commands testsetplatform]] testConstraint testchmod [llength [info commands testchmod]] testConstraint winVista 0 -testConstraint winXP 0 +testConstraint win2000orXP 0 # Don't know how to determine this constraint correctly testConstraint notNetworkFilesystem 0 testConstraint reg 0 if {[testConstraint win]} { catch { @@ -63,23 +63,26 @@ } } # Also used in winFCmd... if {[testConstraint win]} { - if {$::tcl_platform(osVersion) >= 5.0} { - testConstraint winVista 1 - } else { - testConstraint winXP 1 + if {[testConstraint nt] && $::tcl_platform(osVersion) >= 5.0} { + if {$::tcl_platform(osVersion) >= 6.0} { + testConstraint winVista 1 + } else { + testConstraint win2000orXP 1 + } } } testConstraint darwin9 [expr { [testConstraint unix] && $tcl_platform(os) eq "Darwin" && [package vsatisfies 1.$::tcl_platform(osVersion) 1.9] }] testConstraint notDarwin9 [expr {![testConstraint darwin9]}] +testConstraint notContinuousIntegration [expr {![info exists ::env(CI)]}] testConstraint fileSharing 0 testConstraint notFileSharing 1 testConstraint linkFile 1 testConstraint linkDirectory 1 @@ -274,11 +277,11 @@ file mkdir td1 file rename ~_totally_bogus_user td1 } -result {user "_totally_bogus_user" doesn't exist} test fCmd-3.15 {FileCopyRename: source[0] == '\0'} -setup { cleanup -} -constraints {notRoot unixOrPc} -returnCodes error -body { +} -constraints {notRoot unixOrWin} -returnCodes error -body { file mkdir td1 file rename / td1 } -result {error renaming "/" to "td1": file already exists} test fCmd-3.16 {FileCopyRename: break on first error} -setup { cleanup @@ -414,11 +417,11 @@ file delete tf1 td1 tf2 lappend x [file exists tf1] [file exists tf2] [file exists tf3] } -cleanup {cleanup} -result {1 1 1 0 0 0} test fCmd-5.5 {TclFileDeleteCmd: stop at first error} -setup { cleanup -} -constraints {notRoot unixOrPc} -body { +} -constraints {notRoot unixOrWin} -body { createfile tf1 createfile tf2 file mkdir td1 catch {file delete tf1 td1 $root tf2} list [file exists tf1] [file exists tf2] [file exists td1] @@ -787,11 +790,11 @@ file rename tf2 tf4 list [lsort [glob tf*]] [file writable tf3] [file writable tf4] } -result {{tf3 tf4} 1 0} test fCmd-9.4.a {file rename: comprehensive: dir to new name} -setup { cleanup -} -constraints {win winXP testchmod} -body { +} -constraints {win win2000orXP testchmod} -body { file mkdir td1 td2 testchmod 0o555 td2 file rename td1 td3 file rename td2 td4 list [lsort [glob td*]] [file writable td3] [file writable td4] @@ -819,11 +822,11 @@ file rename -force tf2 tf2 list [contents tf1] [contents tf2] [file writable tf1] [file writable tf2] } -result {tf1 tf2 1 0} test fCmd-9.6.a {file rename: comprehensive: dir to self} -setup { cleanup -} -constraints {win winXP testchmod} -body { +} -constraints {win win2000orXP testchmod} -body { file mkdir td1 file mkdir td2 testchmod 0o555 td2 file rename -force td1 . file rename -force td2 . @@ -1114,11 +1117,11 @@ set a5 [catch {file copy -force tds4 tdd4}] list [lsort [glob td*]] $a1 $a2 $a3 $a4 $a5 } -result [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4 tds1 tds2 tds3 tds4} {1 {error copying "td1" to "[file join td2 td1]": file already exists}} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} 1 1 1}] test fCmd-10.6 {file copy: comprehensive: dir to non-empty dir} -setup { cleanup -} -constraints {notRoot unixOrPc testchmod} -body { +} -constraints {notRoot unixOrWin testchmod} -body { file mkdir tds1 file mkdir tds2 file mkdir [file join tdd1 tds1 xxx] file mkdir [file join tdd2 tds2 xxx] testchmod 0o555 tds2 @@ -2578,11 +2581,15 @@ test fCmd-30.2 {file readable on 'NTUSER.DAT'} -constraints {win} -body { expr {[info exists env(USERPROFILE)] && [file exists $env(USERPROFILE)/NTUSER.DAT] && [file readable $env(USERPROFILE)/NTUSER.DAT]} } -result {1} -test fCmd-30.3 {file readable on 'pagefile.sys'} -constraints {win} -body { +# At least one CI environment (GitHub Actions) is set up with the page file in +# an unusual location; skip the test if that is so. +test fCmd-30.3 {file readable on 'pagefile.sys'} -constraints { + win notContinuousIntegration +} -body { set r {} if {[info exists env(SystemDrive)]} { set path $env(SystemDrive)/pagefile.sys lappend r exists [file exists $path] lappend r readable [file readable $path] Index: tests/fileName.test ================================================================== --- tests/fileName.test +++ tests/fileName.test @@ -9,11 +9,11 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -1081,23 +1081,29 @@ glob -types abcde -dir foo -join * * } -result {bad argument to "-types": abcde} test filename-11.49 {Tcl_GlobCmd} -returnCodes error -body { glob -types abcde -path foo -join * * } -result {bad argument to "-types": abcde} +test filename-11.50 {Tcl_GlobCmd} -returnCodes error -body { + glob -path hello -path salut * +} -result {"-path" may only be used once} +test filename-11.51 {Tcl_GlobCmd} -returnCodes error -body { + glob -dir hello -dir salut * +} -result {"-directory" may only be used once} file rename $horribleglobname globTest file delete -force $tildeglobname set globname globTest unset horribleglobname tildeglobname -test filename-12.1 {simple globbing} {unixOrPc} { +test filename-12.1 {simple globbing} {unixOrWin} { glob {} } {.} -test filename-12.1.1 {simple globbing} -constraints {unixOrPc} -body { +test filename-12.1.1 {simple globbing} -constraints {unixOrWin} -body { glob -types f {} } -returnCodes error -result {no files matched glob pattern ""} -test filename-12.1.2 {simple globbing} {unixOrPc} { +test filename-12.1.2 {simple globbing} {unixOrWin} { glob -types d {} } {.} test filename-12.1.3 {simple globbing} {unix} { glob -types hidden {} } {.} @@ -1114,11 +1120,11 @@ glob -nocomplain \{a1,a2\} } {} set globPreResult globTest/ set x1 x1.c set y1 y1.c -test filename-12.4 {simple globbing} {unixOrPc} { +test filename-12.4 {simple globbing} {unixOrWin} { lsort [glob globTest/x1.c globTest/y1.c globTest/foo] } "$globPreResult$x1 $globPreResult$y1" test filename-12.5 {simple globbing} { glob globTest\\/x1.c } "$globPreResult$x1" @@ -1176,46 +1182,46 @@ lsort [glob globTest/\{x,y\}1.c] } [list $globPreResult$x1 $globPreResult$y1] test filename-13.10 {globbing with brace substitution} { lsort [glob globTest/\{x,,y\}1.c] } [list $globPreResult$x1 $globPreResult$y1] -test filename-13.11 {globbing with brace substitution} {unixOrPc} { +test filename-13.11 {globbing with brace substitution} {unixOrWin} { lsort [glob globTest/\{x,x\\,z,z\}1.c] } [lsort {globTest/x1.c globTest/x,z1.c globTest/z1.c}] test filename-13.13 {globbing with brace substitution} { lsort [glob globTest/{a,b,x,y}1.c] } [list $globPreResult$x1 $globPreResult$y1] -test filename-13.14 {globbing with brace substitution} {unixOrPc} { +test filename-13.14 {globbing with brace substitution} {unixOrWin} { lsort [glob {globTest/{x1,y2,weird name}.c}] } {{globTest/weird name.c} globTest/x1.c} -test filename-13.16 {globbing with brace substitution} {unixOrPc} { +test filename-13.16 {globbing with brace substitution} {unixOrWin} { lsort [glob globTest/{x1.c,a1/*}] } {globTest/a1/b1 globTest/a1/b2 globTest/x1.c} -test filename-13.18 {globbing with brace substitution} {unixOrPc} { +test filename-13.18 {globbing with brace substitution} {unixOrWin} { lsort [glob globTest/{x1.c,{a},a1/*}] } {globTest/a1/b1 globTest/a1/b2 globTest/x1.c} -test filename-13.20 {globbing with brace substitution} {unixOrPc} { +test filename-13.20 {globbing with brace substitution} {unixOrWin} { lsort [glob globTest/{a,x}1/*/{x,y}*] } {globTest/a1/b1/x2.c globTest/a1/b2/y2.c} test filename-13.22 {globbing with brace substitution} -body { glob globTest/\{a,x\}1/*/\{ } -returnCodes error -result {unmatched open-brace in file name} -test filename-14.1 {asterisks, question marks, and brackets} {unixOrPc} { +test filename-14.1 {asterisks, question marks, and brackets} {unixOrWin} { lsort [glob glo*/*.c] } {{globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c} -test filename-14.3 {asterisks, question marks, and brackets} {unixOrPc} { +test filename-14.3 {asterisks, question marks, and brackets} {unixOrWin} { lsort [glob globTest/?1.c] } {globTest/x1.c globTest/y1.c globTest/z1.c} test filename-14.5 {asterisks, question marks, and brackets} -setup { # The current directory could be anywhere; do this to stop spurious # matches file mkdir globTestContext file rename globTest [file join globTestContext globTest] set savepwd [pwd] cd globTestContext -} -constraints {unixOrPc} -body { +} -constraints {unixOrWin} -body { lsort [glob */*/*/*.c] } -cleanup { # Reset to where we were cd $savepwd file rename [file join globTestContext globTest] globTest @@ -1225,20 +1231,20 @@ lsort [glob globTest/*] } {globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c} test filename-14.7.1 {asterisks, question marks, and brackets} {win} { lsort [glob globTest/*] } {globTest/.1 globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c} -test filename-14.9 {asterisks, question marks, and brackets} {unixOrPc} { +test filename-14.9 {asterisks, question marks, and brackets} {unixOrWin} { lsort [glob globTest/.*] } {globTest/. globTest/.. globTest/.1} -test filename-14.11 {asterisks, question marks, and brackets} {unixOrPc} { +test filename-14.11 {asterisks, question marks, and brackets} {unixOrWin} { lsort [glob globTest/*/*] } {globTest/a1/b1 globTest/a1/b2 globTest/a2/b3} -test filename-14.13 {asterisks, question marks, and brackets} {unixOrPc} { +test filename-14.13 {asterisks, question marks, and brackets} {unixOrWin} { lsort [glob {globTest/[xyab]1.*}] } {globTest/x1.c globTest/y1.c} -test filename-14.15 {asterisks, question marks, and brackets} {unixOrPc} { +test filename-14.15 {asterisks, question marks, and brackets} {unixOrWin} { lsort [glob globTest/*/] } {globTest/a1/ globTest/a2/ globTest/a3/} test filename-14.17 {asterisks, question marks, and brackets} -setup { global env set temp $env(HOME) @@ -1246,11 +1252,11 @@ set env(HOME) [file join $env(HOME) globTest] glob ~/z* } -cleanup { set env(HOME) $temp } -result [list [file join $env(HOME) globTest z1.c]] -test filename-14.18 {asterisks, question marks, and brackets} {unixOrPc} { +test filename-14.18 {asterisks, question marks, and brackets} {unixOrWin} { lsort [glob globTest/*.c goo/*] } {{globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c} test filename-14.20 {asterisks, question marks, and brackets} { glob -nocomplain goo/* } {} @@ -1285,20 +1291,20 @@ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]] test filename-14.26 {type specific globbing} { glob -nocomplain -dir globTest -types {readonly} * } {} -test filename-14.27 {Bug 2710920} {unixOrPc} { +test filename-14.27 {Bug 2710920} {unixOrWin} { file tail [lindex [lsort [glob globTest/*/]] 0] } a1 -test filename-14.28 {Bug 2710920} {unixOrPc} { +test filename-14.28 {Bug 2710920} {unixOrWin} { file dirname [lindex [lsort [glob globTest/*/]] 0] } globTest -test filename-14.29 {Bug 2710920} {unixOrPc} { +test filename-14.29 {Bug 2710920} {unixOrWin} { file extension [lindex [lsort [glob globTest/*/]] 0] } {} -test filename-14.30 {Bug 2710920} {unixOrPc} { +test filename-14.30 {Bug 2710920} {unixOrWin} { file rootname [lindex [lsort [glob globTest/*/]] 0] } globTest/a1/ test filename-14.31 {Bug 2918610} -setup { set d [makeDirectory foo] Index: tests/fileSystem.test ================================================================== --- tests/fileSystem.test +++ tests/fileSystem.test @@ -7,11 +7,15 @@ # Copyright (c) 2002 Vincent Darley. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + namespace eval ::tcl::test::fileSystem { namespace import ::tcltest::* catch { file delete -force link.file @@ -32,10 +36,13 @@ # Test for commands defined in Tcltest executable testConstraint testfilesystem [llength [info commands ::testfilesystem]] testConstraint testsetplatform [llength [info commands ::testsetplatform]] testConstraint testsimplefilesystem [llength [info commands ::testsimplefilesystem]] +# Some things fail under all Continuous Integration systems for subtle reasons +# such as CI often running with elevated privileges in a container. +testConstraint notInCIenv [expr {![info exists ::env(CI)]}] cd [tcltest::temporaryDirectory] makeFile "test file" gorp.file makeDirectory dir.dir makeDirectory [file join dir.dir dirinside.dir] @@ -144,11 +151,11 @@ file link dir2.link dir.link testPathEqual [file normalize [file join dir.dir linkinside.file foo]] \ [file normalize [file join dir2.link inside.file foo]] } -cleanup { file delete dir2.link -} -result ok +} -result ok makeDirectory dir2.file test filesystem-1.11 {link normalisation: double link, back in tree} {unix hasLinks} { file link dir2.link dir.link file link [file join dir2.file dir2.link] [file join .. dir2.link] testPathEqual [file normalize [file join dir.dir linkinside.file foo]] \ @@ -310,11 +317,11 @@ set fname "/abc/./def/./ghi/./asda/.././.././asd/x/../../../../....." file norm $fname } -match regexp -result {^(?:[^/]|/(?:[^/]|$))+$} test filesystem-1.38 {file normalisation with volume relative} -setup { set dir [pwd] -} -constraints {win moreThanOneDrive} -body { +} -constraints {win moreThanOneDrive notInCIenv} -body { set path "[string range [lindex $drives 0] 0 1]foo" cd [lindex $drives 1] file norm $path } -cleanup { cd $dir @@ -559,11 +566,11 @@ } -constraints {win testsimplefilesystem loaddll} -body { # This may cause a crash on exit cd [file dirname $::ddelib] testsimplefilesystem 1 # This loads dde via a complex copy-to-temp operation - load simplefs:/[file tail $::ddelib] dde + load simplefs:/[file tail $::ddelib] Dde testsimplefilesystem 0 return ok # The real result of this test is what happens when Tcl exits. } -cleanup { cd $dir @@ -904,11 +911,11 @@ set absolute [file join [pwd] $relative] set res [list [file tail $absolute] "test"] } return $res } -cleanup { - file delete -force dgp + file delete -force dgp cd $origdir } -result {test test} test filesystem-9.6 {path objects and file tail and object rep} win { set res {} set p "C:\\toto" ADDED tests/fileSystemEncoding.test Index: tests/fileSystemEncoding.test ================================================================== --- /dev/null +++ tests/fileSystemEncoding.test @@ -0,0 +1,55 @@ +#! /usr/bin/env tclsh + +# Copyright (c) 2019 Poor Yorick + +if {[string equal $::tcl_platform(os) "Windows NT"]} { + return +} + +namespace eval ::tcl::test::fileSystemEncoding { + + if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* + } + + variable fname1 \u767b\u9e1b\u9d72\u6a13 + + proc autopath {} { + global auto_path + set scriptpath [info script] + set scriptpathnorm [file dirname [file normalize $scriptpath/...]] + set dirnorm [file dirname $scriptpathnorm] + set idx [lsearch -exact $auto_path $dirnorm] + if {$idx >= 0} { + set auto_path [lreplace $auto_path[set auto_path {}] $idx $idx {}] + } + set auto_path [linsert $auto_path[set auto_path {}] 0 0 $dirnorm] + } + autopath + + package require tcltests + + test filesystemEncoding-1.0 { + issue bcd100410465 + } -body { + set dir [tcltests::tempdir] + set saved [encoding system] + encoding system iso8859-1 + set fname1a $dir/$fname1 + set utf8name [encoding convertto utf-8 $fname1a] + makeFile {} $utf8name + set globbed [lindex [glob -directory $dir *] 0] + encoding system utf-8 + set res [file exists $globbed] + encoding system iso8859-1 + lappend res [file exists $globbed] + return $res + } -cleanup { + removeFile $utf8name + file delete -force $dir + encoding system $saved + } -result {0 1} + + cleanupTests +} Index: tests/for-old.test ================================================================== --- tests/for-old.test +++ tests/for-old.test @@ -10,37 +10,37 @@ # Copyright (c) 1994-1996 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } # Check "for" and its use of continue and break. catch {unset a i} test for-old-1.1 {for tests} { set a {} - for {set i 1} {$i<6} {set i [expr $i+1]} { + for {set i 1} {$i<6} {incr i} { set a [concat $a $i] } set a } {1 2 3 4 5} test for-old-1.2 {for tests} { set a {} - for {set i 1} {$i<6} {set i [expr $i+1]} { - if $i==4 continue + for {set i 1} {$i<6} {incr i} { + if {$i==4} continue set a [concat $a $i] } set a } {1 2 3 5} test for-old-1.3 {for tests} { set a {} - for {set i 1} {$i<6} {set i [expr $i+1]} { - if $i==4 break + for {set i 1} {$i<6} {incr i} { + if {$i==4} break set a [concat $a $i] } set a } {1 2 3} test for-old-1.4 {for tests} {catch {for 1 2 3} msg} 1 @@ -53,19 +53,19 @@ catch {for 1 2 3 4 5} msg set msg } {wrong # args: should be "for start test next command"} test for-old-1.8 {for tests} { set a {xyz} - for {set i 1} {$i<6} {set i [expr $i+1]} {} + for {set i 1} {$i<6} {incr i} {} set a } xyz test for-old-1.9 {for tests} { set a {} - for {set i 1} {$i<6} {set i [expr $i+1]; if $i==4 break} { + for {set i 1} {$i<6} {incr i; if {$i==4} break} { set a [concat $a $i] } set a } {1 2 3} # cleanup ::tcltest::cleanupTests return Index: tests/for.test ================================================================== --- tests/for.test +++ tests/for.test @@ -7,12 +7,12 @@ # Copyright (c) 1996 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] @@ -60,19 +60,19 @@ while *ing "set"*} catch {unset a} test for-1.9 {TclCompileForCmd: simple command body} { set a {} - for {set i 1} {$i<6} {set i [expr $i+1]} { - if $i==4 break + for {set i 1} {$i<6} {incr i} { + if {$i==4} break set a [concat $a $i] } set a } {1 2 3} test for-1.10 {TclCompileForCmd: command body in quotes} { set a {} - for {set i 1} {$i<6} {set i [expr $i+1]} "append a x" + for {set i 1} {$i<6} {incr i} "append a x" set a } {xxxxx} test for-1.11 {TclCompileForCmd: computed command body} { catch {unset x1} catch {unset bb} @@ -79,11 +79,11 @@ catch {unset x2} set x1 {append a x1; } set bb {break} set x2 {; append a x2} set a {} - for {set i 1} {$i<6} {set i [expr $i+1]} $x1$bb$x2 + for {set i 1} {$i<6} {incr i} $x1$bb$x2 set a } {x1} test for-1.12 {TclCompileForCmd: error in "next" command} -body { catch {for {set i 0} {$i < 5} {set} {format $i}} msg set ::errorInfo @@ -90,13 +90,13 @@ } -match glob -result {wrong # args: should be "set varName ?newValue?" while *ing "set"*} test for-1.13 {TclCompileForCmd: long command body} { set a {} - for {set i 1} {$i<6} {set i [expr $i+1]} { - if $i==4 break - if $i>5 continue + for {set i 1} {$i<6} {incr i} { + if {$i==4} break + if {$i>5} continue if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } @@ -127,11 +127,11 @@ test for-1.14 {TclCompileForCmd: for command result} { set a [for {set i 0} {$i < 5} {incr i} {}] set a } {} test for-1.15 {TclCompileForCmd: for command result} { - set a [for {set i 0} {$i < 5} {incr i} {if $i==3 break}] + set a [for {set i 0} {$i < 5} {incr i} {if {$i==3} break}] set a } {} # Check "for" and "continue". @@ -142,19 +142,19 @@ test for-2.2 {TclCompileContinueCmd: continue result} { catch continue } 4 test for-2.3 {continue tests} { set a {} - for {set i 1} {$i <= 4} {set i [expr $i+1]} { + for {set i 1} {$i <= 4} {incr i} { if {$i == 2} continue set a [concat $a $i] } set a } {1 3 4} test for-2.4 {continue tests} { set a {} - for {set i 1} {$i <= 4} {set i [expr $i+1]} { + for {set i 1} {$i <= 4} {incr i} { if {$i != 2} continue set a [concat $a $i] } set a } {2} @@ -168,14 +168,14 @@ } set msg } {1.1 1.2 2.1 3.1 4.1} test for-2.6 {continue tests, long command body} { set a {} - for {set i 1} {$i<6} {set i [expr $i+1]} { - if $i==2 continue - if $i==4 break - if $i>5 continue + for {set i 1} {$i<6} {incr i} { + if {$i==2} continue + if {$i==4} break + if {$i>5} continue if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } @@ -244,14 +244,14 @@ } set msg } {1.1 1.2 2.1 3.1 4.1} test for-3.5 {break tests, long command body} { set a {} - for {set i 1} {$i<6} {set i [expr $i+1]} { - if $i==2 continue - if $i==5 break - if $i>5 continue + for {set i 1} {$i<6} {incr i} { + if {$i==2} continue + if {$i==5} break + if {$i>5} continue if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } @@ -263,11 +263,11 @@ if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if $i==4 break + if {$i==4} break if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } @@ -384,11 +384,11 @@ } if {[regexp -nocase {^x-mailer:} $line]} { continue } } - if $inheaders { + if {$inheaders} { set limit 55 } else { set limit 55 # Decide whether or not to break the body line if {$plen > 0} { @@ -428,16 +428,16 @@ set F1 -1 } continue } } - set climit [expr $limit-1] + set climit [expr {$limit-1}] set cutoff 50 set continuation 0 while {[string length $line] > $limit} { - for {set c [expr $limit-1]} {$c >= $cutoff} {incr c -1} { + for {set c [expr {$limit-1}]} {$c >= $cutoff} {incr c -1} { set char [string index $line $c] if {$char == " " || $char == "\t"} { break } if {$char == ">"} { ;# Hack for enriched formatting @@ -444,11 +444,11 @@ break } } if {$c < $cutoff} { if {! $inheaders} { - set c [expr $limit-1] + set c [expr {$limit-1}] } else { set c [string length $line] } } set newline [string trimright [string range $line 0 $c]] @@ -583,11 +583,11 @@ # Check that "break" resets the interpreter's result test for-4.1 {break must reset the interp result} { catch { set z GLOBTESTDIR/dir2/file2.c - if [string match GLOBTESTDIR/dir2/* $z] { + if {[string match GLOBTESTDIR/dir2/* $z]} { break } } j set j } {} @@ -694,20 +694,20 @@ invoked from within "$z {set i 0} {$i < 5} {incr i} {set}"} test for-6.10 {Tcl_ForObjCmd: simple command body} { set z for set a {} - $z {set i 1} {$i<6} {set i [expr $i+1]} { - if $i==4 break + $z {set i 1} {$i<6} {incr i} { + if {$i==4} break set a [concat $a $i] } set a } {1 2 3} test for-6.11 {Tcl_ForObjCmd: command body in quotes} { set z for set a {} - $z {set i 1} {$i<6} {set i [expr $i+1]} "append a x" + $z {set i 1} {$i<6} {incr i} "append a x" set a } {xxxxx} test for-6.12 {Tcl_ForObjCmd: computed command body} { set z for catch {unset x1} @@ -715,11 +715,11 @@ catch {unset x2} set x1 {append a x1; } set bb {break} set x2 {; append a x2} set a {} - $z {set i 1} {$i<6} {set i [expr $i+1]} $x1$bb$x2 + $z {set i 1} {$i<6} {incr i} $x1$bb$x2 set a } {x1} test for-6.13 {Tcl_ForObjCmd: error in "next" command} -body { set z for catch {$z {set i 0} {$i < 5} {set} {set j 4}} msg @@ -731,13 +731,13 @@ invoked from within "$z {set i 0} {$i < 5} {set} {set j 4}"} test for-6.14 {Tcl_ForObjCmd: long command body} { set z for set a {} - $z {set i 1} {$i<6} {set i [expr $i+1]} { - if $i==4 break - if $i>5 continue + $z {set i 1} {$i<6} {incr i} { + if {$i==4} break + if {$i>5} continue if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } Index: tests/foreach.test ================================================================== --- tests/foreach.test +++ tests/foreach.test @@ -8,12 +8,12 @@ # Copyright (c) 1994-1997 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } catch {unset a} catch {unset x} Index: tests/format.test ================================================================== --- tests/format.test +++ tests/format.test @@ -8,27 +8,33 @@ # Copyright (c) 1994-1998 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } # %u output depends on word length, so this test is not portable. -testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] -testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}] -testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}] -testConstraint pointerIs64bit [expr {$tcl_platform(pointerSize) >= 8}] +testConstraint longIs32bit [expr {int(0x80000000) < 0}] +testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] +testConstraint wideIs64bit [expr { + (wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}] +testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}] +# 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 notWinCI [expr { + ($::tcl_platform(platform) ne "windows") || ![info exists ::env(CI)]}] 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} { format "%4d %4d %4d %4d %d %#x %#X" 6 34 16923 -12 -1 14 12 -} { 6 34 16923 -12 -1 0xe 0xC} +} { 6 34 16923 -12 -1 0xe 0XC} test format-1.3 {integer formatting} longIs32bit { format "%4u %4u %4u %4u %d %#o" 6 34 16923 -12 -1 0 } { 6 34 16923 4294967284 -1 0} test format-1.3.1 {integer formatting} longIs64bit { format "%4u %4u %4u %4u %d %#o" 6 34 16923 -12 -1 0 @@ -50,44 +56,53 @@ test format-1.7.1 {integer formatting} longIs64bit { format "%4x %4x %4x %4x" 6 34 16923 -12 -1 } { 6 22 421b fffffffffffffff4} test format-1.8 {integer formatting} longIs32bit { format "%#x %#x %#X %#X %#x" 0 6 34 16923 -12 -1 -} {0 0x6 0x22 0x421B 0xfffffff4} +} {0x0 0x6 0X22 0X421B 0xfffffff4} test format-1.8.1 {integer formatting} longIs64bit { format "%#x %#x %#X %#X %#x" 0 6 34 16923 -12 -1 -} {0 0x6 0x22 0x421B 0xfffffffffffffff4} +} {0x0 0x6 0X22 0X421B 0xfffffffffffffff4} test format-1.9 {integer formatting} longIs32bit { format "%#5x %#20x %#20x %#20x %#20x" 0 6 34 16923 -12 -1 -} { 0 0x6 0x22 0x421b 0xfffffff4} +} { 0x0 0x6 0x22 0x421b 0xfffffff4} test format-1.9.1 {integer formatting} longIs64bit { format "%#5x %#20x %#20x %#20x %#20x" 0 6 34 16923 -12 -1 -} { 0 0x6 0x22 0x421b 0xfffffffffffffff4} +} { 0x0 0x6 0x22 0x421b 0xfffffffffffffff4} test format-1.10 {integer formatting} longIs32bit { format "%-#5x %-#20x %-#20x %-#20x %-#20x" 0 6 34 16923 -12 -1 -} {0 0x6 0x22 0x421b 0xfffffff4 } +} {0x0 0x6 0x22 0x421b 0xfffffff4 } test format-1.10.1 {integer formatting} longIs64bit { format "%-#5x %-#20x %-#20x %-#20x %-#20x" 0 6 34 16923 -12 -1 -} {0 0x6 0x22 0x421b 0xfffffffffffffff4 } +} {0x0 0x6 0x22 0x421b 0xfffffffffffffff4 } test format-1.11 {integer formatting} longIs32bit { format "%-#5o %-#20o %#-20o %#-20o %#-20o" 0 6 34 16923 -12 -1 -} {0 0o6 0o42 0o41033 0o37777777764 } +} {0 06 042 041033 037777777764 } test format-1.11.1 {integer formatting} longIs64bit { format "%-#5o %-#20o %#-20o %#-20o %#-20o" 0 6 34 16923 -12 -1 -} {0 0o6 0o42 0o41033 0o1777777777777777777764} +} {0 06 042 041033 01777777777777777777764} test format-1.12 {integer formatting} { format "%b %#b %#b %llb" 5 0 5 [expr {2**100}] -} {101 0 0b101 10000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000} -test format-1.13 {integer formatting} { - format "%#0d %#0d %#0d %#0d %#0d" 0 6 34 16923 -12 -1 +} {101 0b0 0b101 10000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000} +test format-1.13 {integer formatting} longIs32bit { + format "%#d %#d %#d %#d %#d" 0 6 34 16923 -12 -1 +} {0 6 34 16923 -12} +test format-1.13.1 {integer formatting} longIs64bit { + format "%#d %#d %#d %#d %#d" 0 6 34 16923 -12 -1 } {0 6 34 16923 -12} -test format-1.14 {integer formatting} { - format "%#05d %#020d %#020d %#020d %#020d" 0 6 34 16923 -12 -1 -} {00000 00000000000000000006 00000000000000000034 00000000000000016923 -0000000000000000012} -test format-1.15 {integer formatting} { - format "%-#05d %-#020d %-#020d %-#020d %-#020d" 0 6 34 16923 -12 -1 -} {00000 00000000000000000006 00000000000000000034 00000000000000016923 -0000000000000000012} +test format-1.14 {integer formatting} longIs32bit { + format "%#5d %#20d %#20d %#20d %#20d" 0 6 34 16923 -12 -1 +} { 0 6 34 16923 -12} +test format-1.14.1 {integer formatting} longIs64bit { + format "%#5d %#20d %#20d %#20d %#20d" 0 6 34 16923 -12 -1 +} { 0 6 34 16923 -12} +test format-1.15 {integer formatting} longIs32bit { + format "%-#5d %-#20d %-#20d %-#20d %-#20d" 0 6 34 16923 -12 -1 +} {0 6 34 16923 -12 } +test format-1.15.1 {integer formatting} longIs64bit { + format "%-#5d %-#20d %-#20d %-#20d %-#20d" 0 6 34 16923 -12 -1 +} {0 6 34 16923 -12 } test format-2.1 {string formatting} { format "%s %s %c %s" abcd {This is a very long test string.} 120 x } {abcd This is a very long test string. x x} @@ -261,17 +276,17 @@ format "%e %f %g" 0.0 0.0 0.0 0.0 } {0.000000e+00 0.000000 0} test format-6.2 {floating-point zeroes} {eformat} { format "%.4e %.4f %.4g" 0.0 0.0 0.0 0.0 } {0.0000e+00 0.0000 0} -test format-6.3 {floating-point zeroes} {eformat} { +test format-6.3 {floating-point zeroes} {eformat notWinCI} { format "%#.4e %#.4f %#.4g" 0.0 0.0 0.0 0.0 } {0.0000e+00 0.0000 0.000} test format-6.4 {floating-point zeroes} {eformat} { format "%.0e %.0f %.0g" 0.0 0.0 0.0 0.0 } {0e+00 0 0} -test format-6.5 {floating-point zeroes} {eformat} { +test format-6.5 {floating-point zeroes} {eformat notWinCI} { format "%#.0e %#.0f %#.0g" 0.0 0.0 0.0 0.0 } {0.e+00 0. 0.} test format-6.6 {floating-point zeroes} { format "%3.0f %3.0f %3.0f %3.0f" 0.0 0.0 0.0 0.0 } { 0 0 0 0} @@ -356,13 +371,13 @@ } {format string ended in middle of field specifier} test format-8.19 {error conditions} { catch {format %q x} } 1 test format-8.20 {error conditions} { - catch {format %r x} msg + catch {format %q x} msg set msg -} {bad field specifier "r"} +} {bad field specifier "q"} test format-8.21 {error conditions} { catch {format %d} } 1 test format-8.22 {error conditions} { catch {format %d} msg @@ -370,30 +385,10 @@ } {not enough arguments for all format specifiers} test format-8.23 {error conditions} { catch {format "%d %d" 24 xyz} msg set msg } {expected integer but got "xyz"} -# Since "%zd" and "%td" are equivalent to "%lld" in 64-bit platforms and -# equivalent to "%d" in 32-bit platforms, they are really not useful in -# scripts, therefore they are not documented. It's intended use is through -# the function Tcl_AppendPrintfToObj (et al). -test format-8.24 {Undocumented formats} -body { - format "%zd %td %d" [expr 2**30] [expr 2**30] [expr 2**30] -} -result {1073741824 1073741824 1073741824} -test format-8.25 {Undocumented formats} -constraints pointerIs64bit -body { - format "%zd %td %lld" [expr 2**33] [expr 2**33] [expr 2**33] -} -result {8589934592 8589934592 8589934592} -# Since "%p" is equivalent to "%#llx" in 64-bit platforms and equivalent -# to "%#x" in 32-bit platforms, it are really not useful in scripts, -# therefore they are not documented. It's intended use is through the -# function Tcl_AppendPrintfToObj (et al). -test format-8.26 {Undocumented formats} -body { - format "%p %#x" [expr 2**31] [expr 2**31] -} -result {0x80000000 0x80000000} -test format-8.27 {Undocumented formats} -constraints pointerIs64bit -body { - format "%p %#llx" [expr 2**33] [expr 2**33] -} -result {0x200000000 0x200000000} test format-9.1 {long result} { set a {1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} format {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG %s %s} $a $a } {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} @@ -543,11 +538,11 @@ format {%s} $b } $b append b "x" } -test format-17.1 {testing %d with wide} {longIs32bit wideIs64bit} { +test format-17.1 {testing %d with wide} {wideIs64bit wideBiggerThanInt} { format %d 7810179016327718216 } 1819043144 test format-17.2 {testing %ld with wide} {wideIs64bit} { format %ld 7810179016327718216 } 7810179016327718216 @@ -557,11 +552,11 @@ test format-17.4 {testing %l with non-integer} { format %lf 1 } 1.000000 test format-17.5 {testing %llu with positive bignum} -body { format %llu 0xabcdef0123456789abcdef -} -result 207698809136909011942886895 +} -returnCodes 1 -result {unsigned bignum format is invalid} test format-17.6 {testing %llu with negative number} -body { format %llu -1 } -returnCodes 1 -result {unsigned bignum format is invalid} test format-18.1 {do not demote existing numeric values} { @@ -576,11 +571,11 @@ append b aaaa lappend result [expr {$a == $b}] format %08x $b lappend result [expr {$a == $b}] } {1 1 1 1} -test format-18.2 {do not demote existing numeric values} {longIs32bit wideIs64bit} { +test format-18.2 {do not demote existing numeric values} {wideBiggerThanInt} { set a [expr {0xaaaaaaaaaa + 1}] set b 0xaaaaaaaaab list [format %08x $a] [expr {$a == $b}] } {aaaaaaab 1} Index: tests/get.test ================================================================== --- tests/get.test +++ tests/get.test @@ -8,22 +8,22 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] testConstraint testgetint [llength [info commands testgetint]] testConstraint testdoubleobj [llength [info commands testdoubleobj]] -testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] -testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}] +testConstraint longIs32bit [expr {int(0x80000000) < 0}] +testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] test get-1.1 {Tcl_GetInt procedure} testgetint { testgetint 44 { 22} } {66} test get-1.2 {Tcl_GetInt procedure} testgetint { @@ -43,18 +43,18 @@ } {1 {expected integer but got "16 x"}} test get-1.7 {Tcl_GetInt procedure} {testgetint longIs64bit} { list [catch {testgetint 44 18446744073709551616} msg] $msg $errorCode } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} test get-1.8 {Tcl_GetInt procedure} {testgetint longIs64bit} { - testgetint 18446744073709551614 -} {-2} + list [catch {testgetint 18446744073709551614} msg] $msg +} {0 -2} test get-1.9 {Tcl_GetInt procedure} {testgetint longIs64bit} { - testgetint +18446744073709551614 -} {-2} + list [catch {testgetint +18446744073709551614} msg] $msg +} {0 -2} test get-1.10 {Tcl_GetInt procedure} {testgetint longIs64bit} { - list [catch {testgetint -18446744073709551614} msg] $msg $errorCode -} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} + list [catch {testgetint -18446744073709551614} msg] $msg +} {0 2} test get-1.11 {Tcl_GetInt procedure} {testgetint longIs32bit} { list [catch {testgetint 44 4294967296} msg] $msg $errorCode } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} test get-1.12 {Tcl_GetInt procedure} {testgetint longIs32bit} { list [catch {testgetint 4294967294} msg] $msg @@ -62,11 +62,11 @@ test get-1.13 {Tcl_GetInt procedure} {testgetint longIs32bit} { list [catch {testgetint +4294967294} msg] $msg } {0 -2} test get-1.14 {Tcl_GetInt procedure} {testgetint longIs32bit} { list [catch {testgetint -4294967294} msg] $msg -} {1 {integer value too large to represent}} +} {0 2} test get-2.1 {Tcl_GetInt procedure} { format %g 1.23 } {1.23} test get-2.2 {Tcl_GetInt procedure} { @@ -100,20 +100,20 @@ test get-3.3 {tcl_GetInt with iffy numbers} testgetint { lmap x {0 " 0" "0 " " 0 " " 0xa " " 010 " " 0o10 " " 0b10 "} { catch {testgetint 44 $x} x set x } -} {44 44 44 44 54 54 52 46} +} {44 44 44 44 54 52 52 46} test get-3.4 {Tcl_GetDouble with iffy numbers} testdoubleobj { lmap x {0 0.0 " .0" ".0 " " 0e0 " "09" "- 0" "-0" "0o12" "0b10"} { catch {testdoubleobj set 1 $x} x set x } -} {0.0 0.0 0.0 0.0 0.0 9.0 {expected floating-point number but got "- 0"} 0.0 10.0 2.0} +} {0.0 0.0 0.0 0.0 0.0 {expected floating-point number but got "09" (looks like invalid octal number)} {expected floating-point number but got "- 0"} 0.0 10.0 2.0} # cleanup ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: Index: tests/history.test ================================================================== --- tests/history.test +++ tests/history.test @@ -8,13 +8,13 @@ # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. - + if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } # The history command might be autoloaded... if {[catch {history}]} { @@ -38,11 +38,11 @@ test history-1.1 {event option} history {history event -1} \ {set b [format {A test %s} string]} test history-1.2 {event option} history {history event $num} \ {set a 12345} -test history-1.3 {event option} history {history event [expr $num+2]} \ +test history-1.3 {event option} history {history event [expr {$num+2}]} \ {Another test} test history-1.4 {event option} history {history event set} \ {set b [format {A test %s} string]} test history-1.5 {event option} history {history e "* a*"} \ {set a 12345} @@ -147,15 +147,15 @@ test history-5.1 {info option} history {history info} [format {%6d set a {b c d e} %6d set b 1234 %6d set c {a b - c}} $num [expr $num+1] [expr $num+2]] + c}} $num [expr {$num+1}] [expr {$num+2}]] test history-5.2 {info option} history {history i 2} [format {%6d set b 1234 %6d set c {a b - c}} [expr $num+1] [expr $num+2]] + c}} [expr {$num+1}] [expr {$num+2}]] test history-5.3 {info option} history {catch {history i 2 3}} 1 test history-5.4 {info option} history { catch {history i 2 3} msg set msg } {wrong # args: should be "history info ?count?"} @@ -162,21 +162,23 @@ test history-5.5 {info option} history {history} [format {%6d set a {b c d e} %6d set b 1234 %6d set c {a b - c}} $num [expr $num+1] [expr $num+2]] + c}} $num [expr {$num+1}] [expr {$num+2}]] # "history keep" if {[testConstraint history]} { history add "foo1" history add "foo2" history add "foo3" history keep 2 } -test history-6.1 {keep option} history {history event [expr [history n]-1]} foo3 +test history-6.1 {keep option} history { + history event [expr {[history n]-1}] +} foo3 test history-6.2 {keep option} history {history event -1} foo2 test history-6.3 {keep option} history {catch {history event -3}} 1 test history-6.4 {keep option} history { catch {history event -3} msg set msg @@ -214,11 +216,11 @@ set num [history n] history add "Testing" history add "Testing2" } test history-7.1 {nextid option} history {history event} "Testing" -test history-7.2 {nextid option} history {history next} [expr $num+2] +test history-7.2 {nextid option} history {history next} [expr {$num+2}] test history-7.3 {nextid option} history {catch {history nextid garbage}} 1 test history-7.4 {nextid option} history { catch {history nextid garbage} msg set msg } {wrong # args: should be "history nextid"} @@ -260,11 +262,11 @@ } } } -body { histtest eval { # A fresh object, refcount 1 from the variable we write it to - set obj [expr rand()] + set obj [expr {rand()}] set baseline [refcount $obj] lappend result [refcount $obj] history add [list list $obj] lappend result [refcount $obj] history clear @@ -286,11 +288,11 @@ } } } -body { histtest eval { # A fresh object, refcount 1 from the variable we write it to - set obj [expr rand()] + set obj [expr {rand()}] set baseline [refcount $obj] lappend result [refcount $obj] history add [list list $obj] lappend result [refcount $obj] rename history {} Index: tests/http.test ================================================================== --- tests/http.test +++ tests/http.test @@ -9,19 +9,21 @@ # Copyright (c) 1998-2000 by Ajuba Solutions. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} if {[catch {package require http 2} version]} { if {[info exists http2]} { catch {puts "Cannot load http 2.* package"} return } else { - catch {puts "Running http 2.* tests in slave interp"} + catch {puts "Running http 2.* tests in child interp"} set interp [interp create http2] $interp eval [list set http2 "running"] $interp eval [list set argv $argv] $interp eval [list source [info script]] interp delete $interp @@ -41,10 +43,11 @@ set HOST localhost } else { set HOST [info hostname] } +set port 8010 set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null" catch {unset data} # Ensure httpd file exists @@ -59,12 +62,13 @@ catch {package require Thread 2.7-} if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} { set httpthread [thread::create -preserved] thread::send $httpthread [list source $httpdFile] + thread::send $httpthread [list set port $port] thread::send $httpthread [list set bindata $bindata] - thread::send $httpthread {httpd_init 0; set port} port + thread::send $httpthread {httpd_init $port} puts "Running httpd in thread $httpthread" } else { if {![file exists $httpdFile]} { puts "Cannot read $httpdFile script, http test skipped" unset port @@ -72,19 +76,21 @@ } source $httpdFile # Let the OS pick the port; that's much more flexible if {[catch {httpd_init 0} listen]} { puts "Cannot start http server, http test skipped" - catch {unset port} + unset port return + } else { + set port [lindex [fconfigure $listen -sockname] 2] } } test http-1.1 {http::config} { http::config -useragent UserAgent http::config -} [list -accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -repost 0 -urlencoding utf-8 -useragent UserAgent -zip 1] +} [list -accept */* -pipeline 1 -postfresh 0 -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -repost 0 -urlencoding utf-8 -useragent UserAgent -zip 1] test http-1.2 {http::config} { http::config -proxyfilter } http::ProxyRequired test http-1.3 {http::config} { catch {http::config -junk} @@ -95,14 +101,14 @@ -proxyfilter myFilter -useragent "Tcl Test Suite" \ -urlencoding iso8859-1 set x [http::config] http::config {*}$savedconf set x -} {-accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -repost 0 -urlencoding iso8859-1 -useragent {Tcl Test Suite} -zip 1} +} {-accept */* -pipeline 1 -postfresh 0 -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -repost 0 -urlencoding iso8859-1 -useragent {Tcl Test Suite} -zip 1} test http-1.5 {http::config} -returnCodes error -body { http::config -proxyhost {} -junk 8080 -} -result {Unknown option -junk, must be: -accept, -cookiejar, -pipeline, -postfresh, -proxyfilter, -proxyhost, -proxyport, -repost, -urlencoding, -useragent, -zip} +} -result {Unknown option -junk, must be: -accept, -pipeline, -postfresh, -proxyfilter, -proxyhost, -proxyport, -repost, -urlencoding, -useragent, -zip} test http-1.6 {http::config} -setup { set oldenc [http::config -urlencoding] } -body { set enc [list [http::config -urlencoding]] http::config -urlencoding iso8859-1 @@ -120,11 +126,11 @@ } -result {Unknown option flag, can be: -binary, -blocksize, -channel, -command, -handler, -headers, -keepalive, -method, -myaddr, -progress, -protocol, -query, -queryblocksize, -querychannel, -queryprogress, -strict, -timeout, -type, -validate} test http-3.2 {http::geturl} -returnCodes error -body { http::geturl http:junk } -result {Unsupported URL: http:junk} set url //${::HOST}:$port -set badurl //${::HOST}:[expr $port+1] +set badurl //${::HOST}:[expr {$port+1}] test http-3.3 {http::geturl} -body { set token [http::geturl $url] http::data $token } -cleanup { http::cleanup $token @@ -184,11 +190,11 @@ } -result "HTTP/1.0 TEST

Hello, World!

GET $tail

" test http-3.8 {http::geturl} -body { - set token [http::geturl $url -query Name=Value&Foo=Bar -timeout 2000] + set token [http::geturl $url -query Name=Value&Foo=Bar -timeout 3000] http::data $token } -cleanup { http::cleanup $token } -result "HTTP/1.0 TEST

Hello, World!

@@ -350,21 +356,21 @@ http::geturl http://somewhere/path?%query } -returnCodes error -result {Illegal encoding character usage "%qu" in URL path} test http-3.25 {http::meta} -setup { unset -nocomplain m token } -body { - set token [http::geturl $url -timeout 2000] + set token [http::geturl $url -timeout 3000] array set m [http::meta $token] lsort [array names m] } -cleanup { http::cleanup $token unset -nocomplain m token } -result {Content-Length Content-Type Date} test http-3.26 {http::meta} -setup { unset -nocomplain m token } -body { - set token [http::geturl $url -headers {X-Check 1} -timeout 2000] + set token [http::geturl $url -headers {X-Check 1} -timeout 3000] array set m [http::meta $token] lsort [array names m] } -cleanup { http::cleanup $token unset -nocomplain m token @@ -440,10 +446,13 @@ set token [http::geturl "$xmlurl"] scan [http::data $token] "<%\[^>]>%c<%\[^>]>" } -cleanup { catch { http::cleanup $token } } -result {test 4660 /test} +test http-3.34 {http::geturl -headers not a dict} -returnCodes error -body { + http::geturl http://test/t -headers NoDict +} -result {Bad value for -headers (NoDict), must be dict} test http-4.1 {http::Event} -body { set token [http::geturl $url -keepalive 0] upvar #0 $token data array set meta $data(meta) @@ -586,11 +595,11 @@ } -result {connect failed connection refused} # Bogus host test http-4.15 {http::Event} -body { # This test may fail if you use a proxy server. That is to be # expected and is not a problem with Tcl. - set token [http::geturl //not_a_host.tcl.tk -timeout 1000 -command \#] + set token [http::geturl //not_a_host.tcl.tk -timeout 3000 -command \#] http::wait $token http::status $token # error codes vary among platforms. } -cleanup { catch {http::cleanup $token} @@ -668,455 +677,10 @@ http::mapReply "\u2208" } -cleanup { http::config -urlencoding $enc } -result {%3F} -package require -exact tcl::idna 1.0 - -test http-idna-1.1 {IDNA package: basics} -returnCodes error -body { - ::tcl::idna -} -result {wrong # args: should be "::tcl::idna subcommand ?arg ...?"} -test http-idna-1.2 {IDNA package: basics} -returnCodes error -body { - ::tcl::idna ? -} -result {unknown or ambiguous subcommand "?": must be decode, encode, puny, or version} -test http-idna-1.3 {IDNA package: basics} -body { - ::tcl::idna version -} -result 1.0 -test http-idna-1.4 {IDNA package: basics} -returnCodes error -body { - ::tcl::idna version what -} -result {wrong # args: should be "::tcl::idna version"} -test http-idna-1.5 {IDNA package: basics} -returnCodes error -body { - ::tcl::idna puny -} -result {wrong # args: should be "::tcl::idna puny subcommand ?arg ...?"} -test http-idna-1.6 {IDNA package: basics} -returnCodes error -body { - ::tcl::idna puny ? -} -result {unknown or ambiguous subcommand "?": must be decode, or encode} -test http-idna-1.7 {IDNA package: basics} -returnCodes error -body { - ::tcl::idna puny encode -} -result {wrong # args: should be "::tcl::idna puny encode string ?case?"} -test http-idna-1.8 {IDNA package: basics} -returnCodes error -body { - ::tcl::idna puny encode a b c -} -result {wrong # args: should be "::tcl::idna puny encode string ?case?"} -test http-idna-1.9 {IDNA package: basics} -returnCodes error -body { - ::tcl::idna puny decode -} -result {wrong # args: should be "::tcl::idna puny decode string ?case?"} -test http-idna-1.10 {IDNA package: basics} -returnCodes error -body { - ::tcl::idna puny decode a b c -} -result {wrong # args: should be "::tcl::idna puny decode string ?case?"} -test http-idna-1.11 {IDNA package: basics} -returnCodes error -body { - ::tcl::idna decode -} -result {wrong # args: should be "::tcl::idna decode hostname"} -test http-idna-1.12 {IDNA package: basics} -returnCodes error -body { - ::tcl::idna encode -} -result {wrong # args: should be "::tcl::idna encode hostname"} - -test http-idna-2.1 {puny encode: functional test} { - ::tcl::idna puny encode abc -} abc- -test http-idna-2.2 {puny encode: functional test} { - ::tcl::idna puny encode a\u20acb\u20acc -} abc-k50ab -test http-idna-2.3 {puny encode: functional test} { - ::tcl::idna puny encode ABC -} ABC- -test http-idna-2.4 {puny encode: functional test} { - ::tcl::idna puny encode A\u20ACB\u20ACC -} ABC-k50ab -test http-idna-2.5 {puny encode: functional test} { - ::tcl::idna puny encode ABC 0 -} abc- -test http-idna-2.6 {puny encode: functional test} { - ::tcl::idna puny encode A\u20ACB\u20ACC 0 -} abc-k50ab -test http-idna-2.7 {puny encode: functional test} { - ::tcl::idna puny encode ABC 1 -} ABC- -test http-idna-2.8 {puny encode: functional test} { - ::tcl::idna puny encode A\u20ACB\u20ACC 1 -} ABC-k50ab -test http-idna-2.9 {puny encode: functional test} { - ::tcl::idna puny encode abc 0 -} abc- -test http-idna-2.10 {puny encode: functional test} { - ::tcl::idna puny encode a\u20ACb\u20ACc 0 -} abc-k50ab -test http-idna-2.11 {puny encode: functional test} { - ::tcl::idna puny encode abc 1 -} ABC- -test http-idna-2.12 {puny encode: functional test} { - ::tcl::idna puny encode a\u20ACb\u20ACc 1 -} ABC-k50ab -test http-idna-2.13 {puny encode: edge cases} { - ::tcl::idna puny encode "" -} "" -test http-idna-2.14-A {puny encode: examples from RFC 3492} { - ::tcl::idna puny encode [join [subst [string map {u+ \\u} { - u+0644 u+064A u+0647 u+0645 u+0627 u+0628 u+062A u+0643 u+0644 - u+0645 u+0648 u+0634 u+0639 u+0631 u+0628 u+064A u+061F - }]] ""] -} egbpdaj6bu4bxfgehfvwxn -test http-idna-2.14-B {puny encode: examples from RFC 3492} { - ::tcl::idna puny encode [join [subst [string map {u+ \\u} { - u+4ED6 u+4EEC u+4E3A u+4EC0 u+4E48 u+4E0D u+8BF4 u+4E2D u+6587 - }]] ""] -} ihqwcrb4cv8a8dqg056pqjye -test http-idna-2.14-C {puny encode: examples from RFC 3492} { - ::tcl::idna puny encode [join [subst [string map {u+ \\u} { - u+4ED6 u+5011 u+7232 u+4EC0 u+9EBD u+4E0D u+8AAA u+4E2D u+6587 - }]] ""] -} ihqwctvzc91f659drss3x8bo0yb -test http-idna-2.14-D {puny encode: examples from RFC 3492} { - ::tcl::idna puny encode [join [subst [string map {u+ \\u} { - u+0050 u+0072 u+006F u+010D u+0070 u+0072 u+006F u+0073 u+0074 - u+011B u+006E u+0065 u+006D u+006C u+0075 u+0076 u+00ED u+010D - u+0065 u+0073 u+006B u+0079 - }]] ""] -} Proprostnemluvesky-uyb24dma41a -test http-idna-2.14-E {puny encode: examples from RFC 3492} { - ::tcl::idna puny encode [join [subst [string map {u+ \\u} { - u+05DC u+05DE u+05D4 u+05D4 u+05DD u+05E4 u+05E9 u+05D5 u+05D8 - u+05DC u+05D0 u+05DE u+05D3 u+05D1 u+05E8 u+05D9 u+05DD u+05E2 - u+05D1 u+05E8 u+05D9 u+05EA - }]] ""] -} 4dbcagdahymbxekheh6e0a7fei0b -test http-idna-2.14-F {puny encode: examples from RFC 3492} { - ::tcl::idna puny encode [join [subst [string map {u+ \\u} { - u+092F u+0939 u+0932 u+094B u+0917 u+0939 u+093F u+0928 u+094D - u+0926 u+0940 u+0915 u+094D u+092F u+094B u+0902 u+0928 u+0939 - u+0940 u+0902 u+092C u+094B u+0932 u+0938 u+0915 u+0924 u+0947 - u+0939 u+0948 u+0902 - }]] ""] -} i1baa7eci9glrd9b2ae1bj0hfcgg6iyaf8o0a1dig0cd -test http-idna-2.14-G {puny encode: examples from RFC 3492} { - ::tcl::idna puny encode [join [subst [string map {u+ \\u} { - u+306A u+305C u+307F u+3093 u+306A u+65E5 u+672C u+8A9E u+3092 - u+8A71 u+3057 u+3066 u+304F u+308C u+306A u+3044 u+306E u+304B - }]] ""] -} n8jok5ay5dzabd5bym9f0cm5685rrjetr6pdxa -test http-idna-2.14-H {puny encode: examples from RFC 3492} { - ::tcl::idna puny encode [join [subst [string map {u+ \\u} { - u+C138 u+ACC4 u+C758 u+BAA8 u+B4E0 u+C0AC u+B78C u+B4E4 u+C774 - u+D55C u+AD6D u+C5B4 u+B97C u+C774 u+D574 u+D55C u+B2E4 u+BA74 - u+C5BC u+B9C8 u+B098 u+C88B u+C744 u+AE4C - }]] ""] -} 989aomsvi5e83db1d2a355cv1e0vak1dwrv93d5xbh15a0dt30a5jpsd879ccm6fea98c -test http-idna-2.14-I {puny encode: examples from RFC 3492} { - ::tcl::idna puny encode [join [subst [string map {u+ \\u} { - u+043F u+043E u+0447 u+0435 u+043C u+0443 u+0436 u+0435 u+043E - u+043D u+0438 u+043D u+0435 u+0433 u+043E u+0432 u+043E u+0440 - u+044F u+0442 u+043F u+043E u+0440 u+0443 u+0441 u+0441 u+043A - u+0438 - }]] ""] -} b1abfaaepdrnnbgefbadotcwatmq2g4l -test http-idna-2.14-J {puny encode: examples from RFC 3492} { - ::tcl::idna puny encode [join [subst [string map {u+ \\u} { - u+0050 u+006F u+0072 u+0071 u+0075 u+00E9 u+006E u+006F u+0070 - u+0075 u+0065 u+0064 u+0065 u+006E u+0073 u+0069 u+006D u+0070 - u+006C u+0065 u+006D u+0065 u+006E u+0074 u+0065 u+0068 u+0061 - u+0062 u+006C u+0061 u+0072 u+0065 u+006E u+0045 u+0073 u+0070 - u+0061 u+00F1 u+006F u+006C - }]] ""] -} PorqunopuedensimplementehablarenEspaol-fmd56a -test http-idna-2.14-K {puny encode: examples from RFC 3492} { - ::tcl::idna puny encode [join [subst [string map {u+ \\u} { - u+0054 u+1EA1 u+0069 u+0073 u+0061 u+006F u+0068 u+1ECD u+006B - u+0068 u+00F4 u+006E u+0067 u+0074 u+0068 u+1EC3 u+0063 u+0068 - u+1EC9 u+006E u+00F3 u+0069 u+0074 u+0069 u+1EBF u+006E u+0067 - u+0056 u+0069 u+1EC7 u+0074 - }]] ""] -} TisaohkhngthchnitingVit-kjcr8268qyxafd2f1b9g -test http-idna-2.14-L {puny encode: examples from RFC 3492} { - ::tcl::idna puny encode [join [subst [string map {u+ \\u} { - u+0033 u+5E74 u+0042 u+7D44 u+91D1 u+516B u+5148 u+751F - }]] ""] -} 3B-ww4c5e180e575a65lsy2b -test http-idna-2.14-M {puny encode: examples from RFC 3492} { - ::tcl::idna puny encode [join [subst [string map {u+ \\u} { - u+5B89 u+5BA4 u+5948 u+7F8E u+6075 u+002D u+0077 u+0069 u+0074 - u+0068 u+002D u+0053 u+0055 u+0050 u+0045 u+0052 u+002D u+004D - u+004F u+004E u+004B u+0045 u+0059 u+0053 - }]] ""] -} -with-SUPER-MONKEYS-pc58ag80a8qai00g7n9n -test http-idna-2.14-N {puny encode: examples from RFC 3492} { - ::tcl::idna puny encode [join [subst [string map {u+ \\u} { - u+0048 u+0065 u+006C u+006C u+006F u+002D u+0041 u+006E u+006F - u+0074 u+0068 u+0065 u+0072 u+002D u+0057 u+0061 u+0079 u+002D - u+305D u+308C u+305E u+308C u+306E u+5834 u+6240 - }]] ""] -} Hello-Another-Way--fc4qua05auwb3674vfr0b -test http-idna-2.14-O {puny encode: examples from RFC 3492} { - ::tcl::idna puny encode [join [subst [string map {u+ \\u} { - u+3072 u+3068 u+3064 u+5C4B u+6839 u+306E u+4E0B u+0032 - }]] ""] -} 2-u9tlzr9756bt3uc0v -test http-idna-2.14-P {puny encode: examples from RFC 3492} { - ::tcl::idna puny encode [join [subst [string map {u+ \\u} { - u+004D u+0061 u+006A u+0069 u+3067 u+004B u+006F u+0069 u+3059 - u+308B u+0035 u+79D2 u+524D - }]] ""] -} MajiKoi5-783gue6qz075azm5e -test http-idna-2.14-Q {puny encode: examples from RFC 3492} { - ::tcl::idna puny encode [join [subst [string map {u+ \\u} { - u+30D1 u+30D5 u+30A3 u+30FC u+0064 u+0065 u+30EB u+30F3 u+30D0 - }]] ""] -} de-jg4avhby1noc0d -test http-idna-2.14-R {puny encode: examples from RFC 3492} { - ::tcl::idna puny encode [join [subst [string map {u+ \\u} { - u+305D u+306E u+30B9 u+30D4 u+30FC u+30C9 u+3067 - }]] ""] -} d9juau41awczczp -test http-idna-2.14-S {puny encode: examples from RFC 3492} { - ::tcl::idna puny encode {-> $1.00 <-} -} {-> $1.00 <--} - -test http-idna-3.1 {puny decode: functional test} { - ::tcl::idna puny decode abc- -} abc -test http-idna-3.2 {puny decode: functional test} { - ::tcl::idna puny decode abc-k50ab -} a\u20acb\u20acc -test http-idna-3.3 {puny decode: functional test} { - ::tcl::idna puny decode ABC- -} ABC -test http-idna-3.4 {puny decode: functional test} { - ::tcl::idna puny decode ABC-k50ab -} A\u20ACB\u20ACC -test http-idna-3.5 {puny decode: functional test} { - ::tcl::idna puny decode ABC-K50AB -} A\u20ACB\u20ACC -test http-idna-3.6 {puny decode: functional test} { - ::tcl::idna puny decode abc-K50AB -} a\u20ACb\u20ACc -test http-idna-3.7 {puny decode: functional test} { - ::tcl::idna puny decode ABC- 0 -} abc -test http-idna-3.8 {puny decode: functional test} { - ::tcl::idna puny decode ABC-K50AB 0 -} a\u20ACb\u20ACc -test http-idna-3.9 {puny decode: functional test} { - ::tcl::idna puny decode ABC- 1 -} ABC -test http-idna-3.10 {puny decode: functional test} { - ::tcl::idna puny decode ABC-K50AB 1 -} A\u20ACB\u20ACC -test http-idna-3.11 {puny decode: functional test} { - ::tcl::idna puny decode abc- 0 -} abc -test http-idna-3.12 {puny decode: functional test} { - ::tcl::idna puny decode abc-k50ab 0 -} a\u20ACb\u20ACc -test http-idna-3.13 {puny decode: functional test} { - ::tcl::idna puny decode abc- 1 -} ABC -test http-idna-3.14 {puny decode: functional test} { - ::tcl::idna puny decode abc-k50ab 1 -} A\u20ACB\u20ACC -test http-idna-3.15 {puny decode: edge cases and errors} { - # Is this case actually correct? - binary encode hex [encoding convertto utf-8 [::tcl::idna puny decode abc]] -} c282c281c280 -test http-idna-3.16 {puny decode: edge cases and errors} -returnCodes error -body { - ::tcl::idna puny decode abc! -} -result {bad decode character "!"} -test http-idna-3.17 {puny decode: edge cases and errors} { - catch {::tcl::idna puny decode abc!} -> opt - dict get $opt -errorcode -} {PUNYCODE BAD_INPUT CHAR} -test http-idna-3.18 {puny decode: edge cases and errors} { - ::tcl::idna puny decode "" -} {} -# A helper so we don't get lots of crap in failures -proc hexify s {lmap c [split $s ""] {format u+%04X [scan $c %c]}} -test http-idna-3.19-A {puny decode: examples from RFC 3492} { - hexify [::tcl::idna puny decode egbpdaj6bu4bxfgehfvwxn] -} [list {*}{ - u+0644 u+064A u+0647 u+0645 u+0627 u+0628 u+062A u+0643 u+0644 - u+0645 u+0648 u+0634 u+0639 u+0631 u+0628 u+064A u+061F -}] -test http-idna-3.19-B {puny decode: examples from RFC 3492} { - hexify [::tcl::idna puny decode ihqwcrb4cv8a8dqg056pqjye] -} {u+4ED6 u+4EEC u+4E3A u+4EC0 u+4E48 u+4E0D u+8BF4 u+4E2D u+6587} -test http-idna-3.19-C {puny decode: examples from RFC 3492} { - hexify [::tcl::idna puny decode ihqwctvzc91f659drss3x8bo0yb] -} {u+4ED6 u+5011 u+7232 u+4EC0 u+9EBD u+4E0D u+8AAA u+4E2D u+6587} -test http-idna-3.19-D {puny decode: examples from RFC 3492} { - hexify [::tcl::idna puny decode Proprostnemluvesky-uyb24dma41a] -} [list {*}{ - u+0050 u+0072 u+006F u+010D u+0070 u+0072 u+006F u+0073 u+0074 - u+011B u+006E u+0065 u+006D u+006C u+0075 u+0076 u+00ED u+010D - u+0065 u+0073 u+006B u+0079 -}] -test http-idna-3.19-E {puny decode: examples from RFC 3492} { - hexify [::tcl::idna puny decode 4dbcagdahymbxekheh6e0a7fei0b] -} [list {*}{ - u+05DC u+05DE u+05D4 u+05D4 u+05DD u+05E4 u+05E9 u+05D5 u+05D8 - u+05DC u+05D0 u+05DE u+05D3 u+05D1 u+05E8 u+05D9 u+05DD u+05E2 - u+05D1 u+05E8 u+05D9 u+05EA -}] -test http-idna-3.19-F {puny decode: examples from RFC 3492} { - hexify [::tcl::idna puny decode \ - i1baa7eci9glrd9b2ae1bj0hfcgg6iyaf8o0a1dig0cd] -} [list {*}{ - u+092F u+0939 u+0932 u+094B u+0917 u+0939 u+093F u+0928 u+094D - u+0926 u+0940 u+0915 u+094D u+092F u+094B u+0902 u+0928 u+0939 - u+0940 u+0902 u+092C u+094B u+0932 u+0938 u+0915 u+0924 u+0947 - u+0939 u+0948 u+0902 -}] -test http-idna-3.19-G {puny decode: examples from RFC 3492} { - hexify [::tcl::idna puny decode n8jok5ay5dzabd5bym9f0cm5685rrjetr6pdxa] -} [list {*}{ - u+306A u+305C u+307F u+3093 u+306A u+65E5 u+672C u+8A9E u+3092 - u+8A71 u+3057 u+3066 u+304F u+308C u+306A u+3044 u+306E u+304B -}] -test http-idna-3.19-H {puny decode: examples from RFC 3492} { - hexify [::tcl::idna puny decode \ - 989aomsvi5e83db1d2a355cv1e0vak1dwrv93d5xbh15a0dt30a5jpsd879ccm6fea98c] -} [list {*}{ - u+C138 u+ACC4 u+C758 u+BAA8 u+B4E0 u+C0AC u+B78C u+B4E4 u+C774 - u+D55C u+AD6D u+C5B4 u+B97C u+C774 u+D574 u+D55C u+B2E4 u+BA74 - u+C5BC u+B9C8 u+B098 u+C88B u+C744 u+AE4C -}] -test http-idna-3.19-I {puny decode: examples from RFC 3492} { - hexify [::tcl::idna puny decode b1abfaaepdrnnbgefbadotcwatmq2g4l] -} [list {*}{ - u+043F u+043E u+0447 u+0435 u+043C u+0443 u+0436 u+0435 u+043E - u+043D u+0438 u+043D u+0435 u+0433 u+043E u+0432 u+043E u+0440 - u+044F u+0442 u+043F u+043E u+0440 u+0443 u+0441 u+0441 u+043A - u+0438 -}] -test http-idna-3.19-J {puny decode: examples from RFC 3492} { - hexify [::tcl::idna puny decode \ - PorqunopuedensimplementehablarenEspaol-fmd56a] -} [list {*}{ - u+0050 u+006F u+0072 u+0071 u+0075 u+00E9 u+006E u+006F u+0070 - u+0075 u+0065 u+0064 u+0065 u+006E u+0073 u+0069 u+006D u+0070 - u+006C u+0065 u+006D u+0065 u+006E u+0074 u+0065 u+0068 u+0061 - u+0062 u+006C u+0061 u+0072 u+0065 u+006E u+0045 u+0073 u+0070 - u+0061 u+00F1 u+006F u+006C -}] -test http-idna-3.19-K {puny decode: examples from RFC 3492} { - hexify [::tcl::idna puny decode \ - TisaohkhngthchnitingVit-kjcr8268qyxafd2f1b9g] -} [list {*}{ - u+0054 u+1EA1 u+0069 u+0073 u+0061 u+006F u+0068 u+1ECD u+006B - u+0068 u+00F4 u+006E u+0067 u+0074 u+0068 u+1EC3 u+0063 u+0068 - u+1EC9 u+006E u+00F3 u+0069 u+0074 u+0069 u+1EBF u+006E u+0067 - u+0056 u+0069 u+1EC7 u+0074 -}] -test http-idna-3.19-L {puny decode: examples from RFC 3492} { - hexify [::tcl::idna puny decode 3B-ww4c5e180e575a65lsy2b] -} {u+0033 u+5E74 u+0042 u+7D44 u+91D1 u+516B u+5148 u+751F} -test http-idna-3.19-M {puny decode: examples from RFC 3492} { - hexify [::tcl::idna puny decode -with-SUPER-MONKEYS-pc58ag80a8qai00g7n9n] -} [list {*}{ - u+5B89 u+5BA4 u+5948 u+7F8E u+6075 u+002D u+0077 u+0069 u+0074 - u+0068 u+002D u+0053 u+0055 u+0050 u+0045 u+0052 u+002D u+004D - u+004F u+004E u+004B u+0045 u+0059 u+0053 -}] -test http-idna-3.19-N {puny decode: examples from RFC 3492} { - hexify [::tcl::idna puny decode Hello-Another-Way--fc4qua05auwb3674vfr0b] -} [list {*}{ - u+0048 u+0065 u+006C u+006C u+006F u+002D u+0041 u+006E u+006F - u+0074 u+0068 u+0065 u+0072 u+002D u+0057 u+0061 u+0079 u+002D - u+305D u+308C u+305E u+308C u+306E u+5834 u+6240 -}] -test http-idna-3.19-O {puny decode: examples from RFC 3492} { - hexify [::tcl::idna puny decode 2-u9tlzr9756bt3uc0v] -} {u+3072 u+3068 u+3064 u+5C4B u+6839 u+306E u+4E0B u+0032} -test http-idna-3.19-P {puny decode: examples from RFC 3492} { - hexify [::tcl::idna puny decode MajiKoi5-783gue6qz075azm5e] -} [list {*}{ - u+004D u+0061 u+006A u+0069 u+3067 u+004B u+006F u+0069 u+3059 - u+308B u+0035 u+79D2 u+524D -}] -test http-idna-3.19-Q {puny decode: examples from RFC 3492} { - hexify [::tcl::idna puny decode de-jg4avhby1noc0d] -} {u+30D1 u+30D5 u+30A3 u+30FC u+0064 u+0065 u+30EB u+30F3 u+30D0} -test http-idna-3.19-R {puny decode: examples from RFC 3492} { - hexify [::tcl::idna puny decode d9juau41awczczp] -} {u+305D u+306E u+30B9 u+30D4 u+30FC u+30C9 u+3067} -test http-idna-3.19-S {puny decode: examples from RFC 3492} { - ::tcl::idna puny decode {-> $1.00 <--} -} {-> $1.00 <-} -rename hexify "" - -test http-idna-4.1 {IDNA encoding} { - ::tcl::idna encode abc.def -} abc.def -test http-idna-4.2 {IDNA encoding} { - ::tcl::idna encode a\u20acb\u20acc.def -} xn--abc-k50ab.def -test http-idna-4.3 {IDNA encoding} { - ::tcl::idna encode def.a\u20acb\u20acc -} def.xn--abc-k50ab -test http-idna-4.4 {IDNA encoding} { - ::tcl::idna encode ABC.DEF -} ABC.DEF -test http-idna-4.5 {IDNA encoding} { - ::tcl::idna encode A\u20acB\u20acC.def -} xn--ABC-k50ab.def -test http-idna-4.6 {IDNA encoding: invalid edge case} { - # Should this be an error? - ::tcl::idna encode abc..def -} abc..def -test http-idna-4.7 {IDNA encoding: invalid char} -returnCodes error -body { - ::tcl::idna encode abc.$.def -} -result {bad character "$" in DNS name} -test http-idna-4.7.1 {IDNA encoding: invalid char} { - catch {::tcl::idna encode abc.$.def} -> opt - dict get $opt -errorcode -} {IDNA INVALID_NAME_CHARACTER {$}} -test http-idna-4.8 {IDNA encoding: empty} { - ::tcl::idna encode "" -} {} -set overlong www.[join [subst [string map {u+ \\u} { - u+C138 u+ACC4 u+C758 u+BAA8 u+B4E0 u+C0AC u+B78C u+B4E4 u+C774 - u+D55C u+AD6D u+C5B4 u+B97C u+C774 u+D574 u+D55C u+B2E4 u+BA74 - u+C5BC u+B9C8 u+B098 u+C88B u+C744 u+AE4C -}]] ""].com -test http-idna-4.9 {IDNA encoding: max lengths from RFC 5890} -body { - ::tcl::idna encode $overlong -} -returnCodes error -result "hostname part too long" -test http-idna-4.9.1 {IDNA encoding: max lengths from RFC 5890} { - catch {::tcl::idna encode $overlong} -> opt - dict get $opt -errorcode -} {IDNA OVERLONG_PART xn--989aomsvi5e83db1d2a355cv1e0vak1dwrv93d5xbh15a0dt30a5jpsd879ccm6fea98c} -unset overlong -test http-idna-4.10 {IDNA encoding: edge cases} { - ::tcl::idna encode pass\u00e9.example.com -} xn--pass-epa.example.com - -test http-idna-5.1 {IDNA decoding} { - ::tcl::idna decode abc.def -} abc.def -test http-idna-5.2 {IDNA decoding} { - # Invalid entry that's just a wrapper - ::tcl::idna decode xn--abc-.def -} abc.def -test http-idna-5.3 {IDNA decoding} { - # Invalid entry that's just a wrapper - ::tcl::idna decode xn--abc-.xn--def- -} abc.def -test http-idna-5.4 {IDNA decoding} { - # Invalid entry that's just a wrapper - ::tcl::idna decode XN--abc-.XN--def- -} abc.def -test http-idna-5.5 {IDNA decoding: error cases} -returnCodes error -body { - ::tcl::idna decode xn--$$$.example.com -} -result {bad decode character "$"} -test http-idna-5.5.1 {IDNA decoding: error cases} { - catch {::tcl::idna decode xn--$$$.example.com} -> opt - dict get $opt -errorcode -} {PUNYCODE BAD_INPUT CHAR} -test http-idna-5.6 {IDNA decoding: error cases} -returnCodes error -body { - ::tcl::idna decode xn--a-zzzzzzzzzzzzzzzzzzzzzzzzzzzzzz.def -} -result {exceeded input data} -test http-idna-5.6.1 {IDNA decoding: error cases} { - catch {::tcl::idna decode xn--a-zzzzzzzzzzzzzzzzzzzzzzzzzzzzzz.def} -> opt - dict get $opt -errorcode -} {PUNYCODE BAD_INPUT LENGTH} - # cleanup catch {unset url} catch {unset badurl} catch {unset port} catch {unset data} Index: tests/http11.test ================================================================== --- tests/http11.test +++ tests/http11.test @@ -5,21 +5,23 @@ # Copyright (C) 2009 Pat Thoyts # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} -package require http 2.8 +package require http 2.9 # start the server variable httpd_output proc create_httpd {} { proc httpd_read {chan} { variable httpd_output - if {[gets $chan line] != -1} { + if {[gets $chan line] >= 0} { #puts stderr "read '$line'" set httpd_output $line } if {[eof $chan]} { puts stderr "eof from httpd" @@ -57,10 +59,24 @@ return "" } } return $meta } + +proc state {tok {key ""}} { + upvar 1 $tok state + if {$key ne ""} { + if {[array names state -exact $key] ne {}} { + return $state($key) + } else { + return "" + } + } + set res [array get state] + dict set res body + return $res +} proc check_crc {tok args} { set crc [meta $tok x-crc32] set data [expr {[llength $args] ? [lindex $args 0] : [http::data $tok]}] set chk [format %x [zlib crc32 $data]] @@ -239,11 +255,48 @@ } -cleanup { http::cleanup $tok halt_httpd } -result {ok {HTTP/1.1 200 OK} ok {} chunked} +test http11-1.13 "normal, 1.1 and keepalive as server default, no zip" -setup { + variable httpd [create_httpd] + set zipTmp [http::config -zip] + http::config -zip 0 +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?transfer= \ + -protocol 1.1 -keepalive 1 -timeout 10000] + http::wait $tok + set res1 [list [http::status $tok] [http::code $tok] [check_crc $tok] \ + [meta $tok connection] [meta $tok transfer-encoding] [state $tok reusing] [state $tok connection]] + set toj [http::geturl http://localhost:$httpd_port/testdoc.html?transfer= \ + -protocol 1.1 -keepalive 1 -timeout 10000] + http::wait $toj + set res2 [list [http::status $toj] [http::code $toj] [check_crc $toj] \ + [meta $toj connection] [meta $toj transfer-encoding] [state $toj reusing] [state $toj connection]] + concat $res1 -- $res2 +} -cleanup { + http::cleanup $tok + http::cleanup $toj + halt_httpd + http::config -zip $zipTmp +} -result {ok {HTTP/1.1 200 OK} ok {} {} 0 keep-alive -- ok {HTTP/1.1 200 OK} ok {} {} 1 keep-alive} + # ------------------------------------------------------------------------- + +proc progress {var token total current} { + upvar #0 $var log + set log [list $current $total] + return +} + +proc progressPause {var token total current} { + upvar #0 $var log + set log [list $current $total] + after 100 set ::WaitHere 0 + vwait ::WaitHere + return +} test http11-2.0 "-channel" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { @@ -336,10 +389,62 @@ http::cleanup $tok close $chan removeFile testfile.tmp halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close {} chunked} + +test http11-2.4.1 "-channel,encoding identity with -progress" -setup { + variable httpd [create_httpd] + set chan [open [makeFile {} testfile.tmp] wb+] + set logdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ + -timeout 5000 -channel $chan \ + -headers {accept-encoding identity} \ + -progress [namespace code [list progress logdata]]] + + http::wait $tok + seek $chan 0 + set data [read $chan] + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ + [meta $tok connection] [meta $tok content-encoding]\ + [meta $tok transfer-encoding] \ + [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ + [expr {[lindex $logdata 0] - [string length $data]}] +} -cleanup { + http::cleanup $tok + close $chan + removeFile testfile.tmp + halt_httpd + unset -nocomplain logdata data +} -result {ok {HTTP/1.1 200 OK} ok close {} chunked 0 0} + +test http11-2.4.2 "-channel,encoding identity with -progress progressPause enters event loop" -constraints knownBug -setup { + variable httpd [create_httpd] + set chan [open [makeFile {} testfile.tmp] wb+] + set logdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ + -timeout 5000 -channel $chan \ + -headers {accept-encoding identity} \ + -progress [namespace code [list progressPause logdata]]] + + http::wait $tok + seek $chan 0 + set data [read $chan] + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ + [meta $tok connection] [meta $tok content-encoding]\ + [meta $tok transfer-encoding] \ + [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ + [expr {[lindex $logdata 0] - [string length $data]}] +} -cleanup { + http::cleanup $tok + close $chan + removeFile testfile.tmp + halt_httpd + unset -nocomplain logdata data ::WaitHere +} -result {ok {HTTP/1.1 200 OK} ok close {} chunked 0 0} test http11-2.5 "-channel,encoding unsupported" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { @@ -515,10 +620,20 @@ set chunk [read $sock] append data $chunk #::http::Log "handler read [string length $chunk] ([chan configure $sock -buffersize])" return [string length $chunk] } + +proc handlerPause {var sock token} { + upvar #0 $var data + set chunk [read $sock] + append data $chunk + #::http::Log "handler read [string length $chunk] ([chan configure $sock -buffersize])" + after 100 set ::WaitHere 0 + vwait ::WaitHere + return [string length $chunk] +} test http11-3.0 "-handler,close,identity" -setup { variable httpd [create_httpd] set testdata "" } -body { @@ -587,10 +702,139 @@ http::cleanup $tok unset -nocomplain testdata halt_httpd } -result {ok {HTTP/1.0 200 OK} ok close {} {} 0} +# http11-3.4 +# This test is a blatant attempt to confuse the client by instructing the server +# to send neither "Connection: close" nor "Content-Length" when in non-chunked +# mode. +# The client has no way to know the response-body is complete unless the +# server signals this by closing the connection. +# In an HTTP/1.1 response the absence of "Connection: close" means +# "Connection: keep-alive", i.e. the server will keep the connection +# open. In HTTP/1.0 this is not the case, and this is a test that +# the Tcl client assumes "Connection: close" by default in HTTP/1.0. +test http11-3.4 "-handler,close,identity; HTTP/1.0 server does not send Connection: close header or Content-Length" -setup { + variable httpd [create_httpd] + set testdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1&nosendclose=any \ + -timeout 10000 -handler [namespace code [list handler testdata]]] + http::wait $tok + list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\ + [meta $tok connection] [meta $tok content-encoding] \ + [meta $tok transfer-encoding] \ + [expr {[file size testdoc.html]-[string length $testdata]}] +} -cleanup { + http::cleanup $tok + unset -nocomplain testdata + halt_httpd +} -result {ok {HTTP/1.0 200 OK} ok {} {} {} 0} + +# It is not forbidden for a handler to enter the event loop. +test http11-3.5 "-handler,close,identity as http11-3.0 but handlerPause enters event loop" -setup { + variable httpd [create_httpd] + set testdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ + -timeout 10000 -handler [namespace code [list handlerPause testdata]]] + http::wait $tok + list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\ + [meta $tok connection] [meta $tok content-encoding] \ + [meta $tok transfer-encoding] \ + [expr {[file size testdoc.html]-[string length $testdata]}] +} -cleanup { + http::cleanup $tok + unset -nocomplain testdata ::WaitHere + halt_httpd +} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0} + +test http11-3.6 "-handler,close,identity as http11-3.0 but with -progress" -setup { + variable httpd [create_httpd] + set testdata "" + set logdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ + -timeout 10000 -handler [namespace code [list handler testdata]] \ + -progress [namespace code [list progress logdata]]] + http::wait $tok + list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\ + [meta $tok connection] [meta $tok content-encoding] \ + [meta $tok transfer-encoding] \ + [expr {[file size testdoc.html]-[string length $testdata]}] \ + [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ + [expr {[lindex $logdata 0] - [string length $testdata]}] +} -cleanup { + http::cleanup $tok + unset -nocomplain testdata logdata ::WaitHere + halt_httpd +} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0 0 0} + +test http11-3.7 "-handler,close,identity as http11-3.0 but with -progress progressPause enters event loop" -setup { + variable httpd [create_httpd] + set testdata "" + set logdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ + -timeout 10000 -handler [namespace code [list handler testdata]] \ + -progress [namespace code [list progressPause logdata]]] + http::wait $tok + list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\ + [meta $tok connection] [meta $tok content-encoding] \ + [meta $tok transfer-encoding] \ + [expr {[file size testdoc.html]-[string length $testdata]}] \ + [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ + [expr {[lindex $logdata 0] - [string length $testdata]}] +} -cleanup { + http::cleanup $tok + unset -nocomplain testdata logdata ::WaitHere + halt_httpd +} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0 0 0} + +test http11-3.8 "close,identity no -handler but with -progress" -setup { + variable httpd [create_httpd] + set logdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ + -timeout 10000 \ + -progress [namespace code [list progress logdata]] \ + -headers {accept-encoding {}}] + http::wait $tok + list [http::status $tok] [http::code $tok] [check_crc $tok]\ + [meta $tok connection] [meta $tok content-encoding] \ + [meta $tok transfer-encoding] \ + [expr {[file size testdoc.html]-[string length [http::data $tok]]}] \ + [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ + [expr {[lindex $logdata 0] - [string length [http::data $tok]]}] +} -cleanup { + http::cleanup $tok + unset -nocomplain logdata ::WaitHere + halt_httpd +} -result {ok {HTTP/1.1 200 OK} ok close {} {} 0 0 0} + +test http11-3.9 "close,identity no -handler but with -progress progressPause enters event loop" -setup { + variable httpd [create_httpd] + set logdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ + -timeout 10000 \ + -progress [namespace code [list progressPause logdata]] \ + -headers {accept-encoding {}}] + http::wait $tok + list [http::status $tok] [http::code $tok] [check_crc $tok]\ + [meta $tok connection] [meta $tok content-encoding] \ + [meta $tok transfer-encoding] \ + [expr {[file size testdoc.html]-[string length [http::data $tok]]}] \ + [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ + [expr {[lindex $logdata 0] - [string length [http::data $tok]]}] +} -cleanup { + http::cleanup $tok + unset -nocomplain logdata ::WaitHere + halt_httpd +} -result {ok {HTTP/1.1 200 OK} ok close {} {} 0 0 0} + test http11-4.0 "normal post request" -setup { variable httpd [create_httpd] } -body { set query [http::formatQuery q 1 z 2] set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ Index: tests/httpPipeline.test ================================================================== --- tests/httpPipeline.test +++ tests/httpPipeline.test @@ -6,14 +6,16 @@ # Copyright (C) 2018 Keith Nash # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} -package require http 2.8 +package require http 2.9 set sourcedir [file normalize [file dirname [info script]]] source [file join $sourcedir httpTest.tcl] source [file join $sourcedir httpTestScript.tcl] Index: tests/httpTest.tcl ================================================================== --- tests/httpTest.tcl +++ tests/httpTest.tcl @@ -58,23 +58,19 @@ proc http::Log {args} { variable TestStartTimeInMs set time [expr {[clock milliseconds] - $TestStartTimeInMs}] set txt [list $time {*}$args] - if {[string first ^ $txt] != -1} { + if {[string first ^ $txt] >= 0} { ::httpTest::LogRecord $txt ::httpTest::Puts $txt } elseif {$::httpTest::testOptions(-verbose) > 1} { ::httpTest::Puts $txt } return } -# The http::Log routine above needs the variable ::httpTest::testOptions -# Set up to destroy it when that variable goes away. -trace add variable ::httpTest::testOptions unset {apply {args { - proc ::http::Log args {} -}}} + # Called by http::Log (the "testing" version) to record logs for later analysis. proc httpTest::LogRecord {txt} { variable testResults @@ -84,11 +80,11 @@ if {$pos > $len - 3} { puts stdout "Logging Error: $txt" puts stdout "Fix this call to Log in http-*.tm so it has ^ then\ a letter then a numeral." flush stdout - } elseif {$pos == -1} { + } elseif {$pos < 0} { # Called by mistake. } else { set letter [string index $txt [incr pos]] set number [string index $txt [incr pos]] # Max 9 requests! @@ -151,11 +147,11 @@ continue } set myStart [lsearch -exact $someResults [list B $i]] set myEnd [lsearch -exact $someResults [list $term $i]] - if {($myStart == -1 || $myEnd == -1)} { + if {($myStart < 0 || $myEnd < 0)} { set res "Cannot find positions of transaction $i" append msg $res \n Puts $res } @@ -372,11 +368,11 @@ proc httpTest::ProcessRetries {someResults n msg skipOverlaps notIncluded notPiped} { variable testOptions set nextRetry [lsearch -glob -index 0 $someResults {[PQR]}] - if {$nextRetry == -1} { + if {$nextRetry < 0} { return [MostAnalysis $someResults $n $msg $skipOverlaps $notIncluded $notPiped] } set badTrans $notIncluded set tryCount 0 set try $nextRetry @@ -389,20 +385,20 @@ set dummyTry {} for {set i 1} {$i <= $n} {incr i} { set first [lsearch -exact $beforeTry [list A $i]] set last [lsearch -exact $beforeTry [list F $i]] - if {$first == -1} { + if {$first < 0} { set res "Transaction $i was not started in connection number $tryCount" # So lappend it to badTrans and don't include it in the call below of MostAnalysis. # append msg $res \n Puts $res if {$i ni $badTrans} { lappend badTrans $i } else { } - } elseif {$last == -1} { + } elseif {$last < 0} { set res "Transaction $i was started but unfinished in connection number $tryCount" # So lappend it to badTrans and don't include it in the call below of MostAnalysis. # append msg $res \n Puts $res lappend badTrans $i DELETED tests/httpcookie.test Index: tests/httpcookie.test ================================================================== --- tests/httpcookie.test +++ /dev/null @@ -1,876 +0,0 @@ -# Commands covered: http::cookiejar -# -# This file contains a collection of tests for the cookiejar package. -# Sourcing this file into Tcl runs the tests and generates output for errors. -# No output means no errors were found. -# -# Copyright (c) 2014 Donal K. Fellows. -# -# See the file "license.terms" for information on usage and redistribution of -# this file, and for a DISCLAIMER OF ALL WARRANTIES. - -package require tcltest 2 -namespace import -force ::tcltest::* - -::tcltest::loadTestedCommands - -testConstraint notOSXtravis [apply {{} { - upvar 1 env(TRAVIS_OSX_IMAGE) travis - return [expr {![info exists travis] || ![string match xcode* $travis]}] -}}] -testConstraint sqlite3 [expr {[testConstraint notOSXtravis] && ![catch { - package require sqlite3 -}]}] -testConstraint cookiejar [expr {[testConstraint sqlite3] && ![catch { - package require cookiejar -}]}] - -set COOKIEJAR_VERSION 0.1 -test http-cookiejar-1.1 "cookie storage: packaging" {notOSXtravis sqlite3 cookiejar} { - package require cookiejar -} $COOKIEJAR_VERSION -test http-cookiejar-1.2 "cookie storage: packaging" {notOSXtravis sqlite3 cookiejar} { - package require cookiejar - package require cookiejar -} $COOKIEJAR_VERSION - -test http-cookiejar-2.1 "cookie storage: basics" -constraints { - notOSXtravis sqlite3 cookiejar -} -returnCodes error -body { - http::cookiejar -} -result {wrong # args: should be "http::cookiejar method ?arg ...?"} -test http-cookiejar-2.2 "cookie storage: basics" -constraints { - notOSXtravis sqlite3 cookiejar -} -returnCodes error -body { - http::cookiejar ? -} -result {unknown method "?": must be configure, create, destroy or new} -test http-cookiejar-2.3 "cookie storage: basics" -constraints { - notOSXtravis sqlite3 cookiejar -} -body { - http::cookiejar configure -} -result {-domainfile -domainlist -domainrefresh -loglevel -offline -purgeold -retain -vacuumtrigger} -test http-cookiejar-2.4 "cookie storage: basics" -constraints { - notOSXtravis sqlite3 cookiejar -} -returnCodes error -body { - http::cookiejar configure a b c d e -} -result {wrong # args: should be "http::cookiejar configure ?optionName? ?optionValue?"} -test http-cookiejar-2.5 "cookie storage: basics" -constraints { - notOSXtravis sqlite3 cookiejar -} -returnCodes error -body { - http::cookiejar configure a -} -result {bad option "a": must be -domainfile, -domainlist, -domainrefresh, -loglevel, -offline, -purgeold, -retain, or -vacuumtrigger} -test http-cookiejar-2.6 "cookie storage: basics" -constraints { - notOSXtravis sqlite3 cookiejar -} -returnCodes error -body { - http::cookiejar configure -d -} -result {ambiguous option "-d": must be -domainfile, -domainlist, -domainrefresh, -loglevel, -offline, -purgeold, -retain, or -vacuumtrigger} -test http-cookiejar-2.7 "cookie storage: basics" -setup { - set old [http::cookiejar configure -loglevel] -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - list [http::cookiejar configure -loglevel] \ - [http::cookiejar configure -loglevel debug] \ - [http::cookiejar configure -loglevel] \ - [http::cookiejar configure -loglevel error] \ - [http::cookiejar configure -loglevel] -} -cleanup { - http::cookiejar configure -loglevel $old -} -result {info debug debug error error} -test http-cookiejar-2.8 "cookie storage: basics" -setup { - set old [http::cookiejar configure -loglevel] -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - list [http::cookiejar configure -loglevel] \ - [http::cookiejar configure -loglevel d] \ - [http::cookiejar configure -loglevel i] \ - [http::cookiejar configure -loglevel w] \ - [http::cookiejar configure -loglevel e] -} -cleanup { - http::cookiejar configure -loglevel $old -} -result {info debug info warn error} -test http-cookiejar-2.9 "cookie storage: basics" -body { - http::cookiejar configure -off -} -constraints {notOSXtravis sqlite3 cookiejar} -match glob -result * -test http-cookiejar-2.10 "cookie storage: basics" -setup { - set oldval [http::cookiejar configure -offline] -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - http::cookiejar configure -offline true -} -cleanup { - catch {http::cookiejar configure -offline $oldval} -} -result 1 -test http-cookiejar-2.11 "cookie storage: basics" -setup { - set oldval [http::cookiejar configure -offline] -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - http::cookiejar configure -offline nonbool -} -cleanup { - catch {http::cookiejar configure -offline $oldval} -} -returnCodes error -result {expected boolean value but got "nonbool"} -test http-cookiejar-2.12 "cookie storage: basics" -setup { - set oldval [http::cookiejar configure -purgeold] -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - http::cookiejar configure -purge nonint -} -cleanup { - catch {http::cookiejar configure -purgeold $oldval} -} -returnCodes error -result {expected positive integer but got "nonint"} -test http-cookiejar-2.13 "cookie storage: basics" -setup { - set oldval [http::cookiejar configure -domainrefresh] -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - http::cookiejar configure -domainref nonint -} -cleanup { - catch {http::cookiejar configure -domainrefresh $oldval} -} -returnCodes error -result {expected positive integer but got "nonint"} -test http-cookiejar-2.14 "cookie storage: basics" -setup { - set oldval [http::cookiejar configure -domainrefresh] -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - http::cookiejar configure -domainref -42 -} -cleanup { - catch {http::cookiejar configure -domainrefresh $oldval} -} -returnCodes error -result {expected positive integer but got "-42"} -test http-cookiejar-2.15 "cookie storage: basics" -setup { - set oldval [http::cookiejar configure -domainrefresh] - set result unset - set tracer [http::cookiejar create tracer] -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - oo::objdefine $tracer method PostponeRefresh {} { - set ::result set - next - } - http::cookiejar configure -domainref 12345 - return $result -} -cleanup { - $tracer destroy - catch {http::cookiejar configure -domainrefresh $oldval} -} -result set - -test http-cookiejar-3.1 "cookie storage: class" {notOSXtravis sqlite3 cookiejar} { - info object isa object http::cookiejar -} 1 -test http-cookiejar-3.2 "cookie storage: class" {notOSXtravis sqlite3 cookiejar} { - info object isa class http::cookiejar -} 1 -test http-cookiejar-3.3 "cookie storage: class" {notOSXtravis sqlite3 cookiejar} { - lsort [info object methods http::cookiejar] -} {configure} -test http-cookiejar-3.4 "cookie storage: class" {notOSXtravis sqlite3 cookiejar} { - lsort [info object methods http::cookiejar -all] -} {configure create destroy new} -test http-cookiejar-3.5 "cookie storage: class" -setup { - catch {rename ::cookiejar ""} -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - namespace eval :: {http::cookiejar create cookiejar} -} -cleanup { - catch {rename ::cookiejar ""} -} -result ::cookiejar -test http-cookiejar-3.6 "cookie storage: class" -setup { - catch {rename ::cookiejar ""} -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - list [http::cookiejar create ::cookiejar] [info commands ::cookiejar] \ - [::cookiejar destroy] [info commands ::cookiejar] -} -cleanup { - catch {rename ::cookiejar ""} -} -result {::cookiejar ::cookiejar {} {}} -test http-cookiejar-3.7 "cookie storage: class" -setup { - catch {rename ::cookiejar ""} -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - http::cookiejar create ::cookiejar foo bar -} -returnCodes error -cleanup { - catch {rename ::cookiejar ""} -} -result {wrong # args: should be "http::cookiejar create ::cookiejar ?path?"} -test http-cookiejar-3.8 "cookie storage: class" -setup { - catch {rename ::cookiejar ""} - set f [makeFile "" cookiejar] - file delete $f -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - list [file exists $f] [http::cookiejar create ::cookiejar $f] \ - [file exists $f] -} -cleanup { - catch {rename ::cookiejar ""} - removeFile $f -} -result {0 ::cookiejar 1} -test http-cookiejar-3.9 "cookie storage: class" -setup { - catch {rename ::cookiejar ""} - set f [makeFile "bogus content for a database" cookiejar] -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - http::cookiejar create ::cookiejar $f -} -returnCodes error -cleanup { - catch {rename ::cookiejar ""} - removeFile $f -} -match glob -result * -test http-cookiejar-3.10 "cookie storage: class" -setup { - catch {rename ::cookiejar ""} - set dir [makeDirectory cookiejar] -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - http::cookiejar create ::cookiejar $dir -} -returnCodes error -cleanup { - catch {rename ::cookiejar ""} - removeDirectory $dir -} -match glob -result * - -test http-cookiejar-4.1 "cookie storage: instance" -setup { - http::cookiejar create ::cookiejar -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - cookiejar -} -returnCodes error -cleanup { - ::cookiejar destroy -} -result {wrong # args: should be "cookiejar method ?arg ...?"} -test http-cookiejar-4.2 "cookie storage: instance" -setup { - http::cookiejar create ::cookiejar -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - cookiejar ? -} -returnCodes error -cleanup { - ::cookiejar destroy -} -result {unknown method "?": must be destroy, forceLoadDomainData, getCookies, lookup, policyAllow or storeCookie} -test http-cookiejar-4.3 "cookie storage: instance" -setup { - http::cookiejar create ::cookiejar -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - lsort [info object methods cookiejar -all] -} -cleanup { - ::cookiejar destroy -} -result {destroy forceLoadDomainData getCookies lookup policyAllow storeCookie} -test http-cookiejar-4.4 "cookie storage: instance" -setup { - http::cookiejar create ::cookiejar -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - cookiejar getCookies -} -returnCodes error -cleanup { - ::cookiejar destroy -} -result {wrong # args: should be "cookiejar getCookies proto host path"} -test http-cookiejar-4.5 "cookie storage" -setup { - http::cookiejar create ::cookiejar -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - cookiejar getCookies http www.example.com / -} -cleanup { - ::cookiejar destroy -} -result {} -test http-cookiejar-4.6 "cookie storage: instance" -setup { - http::cookiejar create ::cookiejar -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - cookiejar storeCookie -} -returnCodes error -cleanup { - ::cookiejar destroy -} -result {wrong # args: should be "cookiejar storeCookie options"} -test http-cookiejar-4.7 "cookie storage: instance" -setup { - http::cookiejar create ::cookiejar -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - cookiejar storeCookie { - key foo - value bar - secure 0 - domain www.example.com - origin www.example.com - path / - hostonly 1 - } -} -cleanup { - ::cookiejar destroy -} -result {} -test http-cookiejar-4.8 "cookie storage: instance" -setup { - http::cookiejar create ::cookiejar - oo::objdefine ::cookiejar export Database -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - cookiejar storeCookie { - key foo - value bar - secure 0 - domain www.example.com - origin www.example.com - path / - hostonly 1 - } - # Poke inside implementation! - cookiejar Database eval {SELECT count(*) FROM sessionCookies} -} -cleanup { - ::cookiejar destroy -} -result 1 -test http-cookiejar-4.9 "cookie storage: instance" -setup { - http::cookiejar create ::cookiejar - oo::objdefine ::cookiejar export Database -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - cookiejar storeCookie { - key foo - value bar - secure 0 - domain www.example.com - origin www.example.com - path / - hostonly 1 - } - # Poke inside implementation! - cookiejar Database eval {SELECT count(*) FROM persistentCookies} -} -cleanup { - ::cookiejar destroy -} -result 0 -test http-cookiejar-4.10 "cookie storage: instance" -setup { - http::cookiejar create ::cookiejar -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - cookiejar storeCookie [dict replace { - key foo - value bar - secure 0 - domain www.example.com - origin www.example.com - path / - hostonly 1 - } expires [expr {[clock seconds]+5}]] -} -cleanup { - ::cookiejar destroy -} -result {} -test http-cookiejar-4.11 "cookie storage: instance" -setup { - http::cookiejar create ::cookiejar - oo::objdefine ::cookiejar export Database -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - cookiejar storeCookie [dict replace { - key foo - value bar - secure 0 - domain www.example.com - origin www.example.com - path / - hostonly 1 - } expires [expr {[clock seconds]+5}]] - # Poke inside implementation! - cookiejar Database eval {SELECT count(*) FROM sessionCookies} -} -cleanup { - ::cookiejar destroy -} -result 0 -test http-cookiejar-4.12 "cookie storage: instance" -setup { - http::cookiejar create ::cookiejar - oo::objdefine ::cookiejar export Database -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - cookiejar storeCookie [dict replace { - key foo - value bar - secure 0 - domain www.example.com - origin www.example.com - path / - hostonly 1 - } expires [expr {[clock seconds]+5}]] - # Poke inside implementation! - cookiejar Database eval {SELECT count(*) FROM persistentCookies} -} -cleanup { - ::cookiejar destroy -} -result 1 -test http-cookiejar-4.13 "cookie storage: instance" -setup { - http::cookiejar create ::cookiejar - set result {} -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - lappend result [cookiejar getCookies http www.example.com /] - cookiejar storeCookie { - key foo - value bar - secure 0 - domain www.example.com - origin www.example.com - path / - hostonly 1 - } - lappend result [cookiejar getCookies http www.example.com /] -} -cleanup { - ::cookiejar destroy -} -result {{} {foo bar}} -test http-cookiejar-4.14 "cookie storage: instance" -setup { - http::cookiejar create ::cookiejar - set result {} -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - lappend result [cookiejar getCookies http www.example.com /] - cookiejar storeCookie [dict replace { - key foo - value bar - secure 0 - domain www.example.com - origin www.example.com - path / - hostonly 1 - } expires [expr {[clock seconds]+5}]] - lappend result [cookiejar getCookies http www.example.com /] -} -cleanup { - ::cookiejar destroy -} -result {{} {foo bar}} -test http-cookiejar-4.15 "cookie storage: instance" -setup { - http::cookiejar create ::cookiejar - set result {} -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - lappend result [cookiejar getCookies http www.example.com /] - cookiejar storeCookie { - key foo - value bar - secure 0 - domain www.example.com - origin www.example.com - path / - hostonly 1 - } - cookiejar storeCookie [dict replace { - key foo - value bar - secure 0 - domain www.example.com - origin www.example.com - path / - hostonly 1 - } expires [expr {[clock seconds]+5}]] - lappend result [cookiejar getCookies http www.example.com /] -} -cleanup { - ::cookiejar destroy -} -result {{} {foo bar}} -test http-cookiejar-4.16 "cookie storage: instance" -setup { - http::cookiejar create ::cookiejar - set result {} -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - lappend result [cookiejar getCookies http www.example.com /] - cookiejar storeCookie { - key foo1 - value bar - secure 0 - domain www.example.com - origin www.example.com - path / - hostonly 1 - } - cookiejar storeCookie [dict replace { - key foo2 - value bar - secure 0 - domain www.example.com - origin www.example.com - path / - hostonly 1 - } expires [expr {[clock seconds]+5}]] - lappend result [lsort -stride 2 [cookiejar getCookies http www.example.com /]] -} -cleanup { - ::cookiejar destroy -} -result {{} {foo1 bar foo2 bar}} -test http-cookiejar-4.17 "cookie storage: instance" -setup { - http::cookiejar create ::cookiejar -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - cookiejar lookup a b c d -} -returnCodes error -cleanup { - ::cookiejar destroy -} -result {wrong # args: should be "cookiejar lookup ?host? ?key?"} -test http-cookiejar-4.18 "cookie storage: instance" -setup { - http::cookiejar create ::cookiejar - set result {} -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - lappend result [cookiejar lookup] - lappend result [cookiejar lookup www.example.com] - lappend result [catch {cookiejar lookup www.example.com foo} value] $value - cookiejar storeCookie { - key foo - value bar - secure 0 - domain www.example.com - origin www.example.com - path / - hostonly 1 - } - lappend result [cookiejar lookup] - lappend result [cookiejar lookup www.example.com] - lappend result [cookiejar lookup www.example.com foo] -} -cleanup { - ::cookiejar destroy -} -result {{} {} 1 {no such key for that host} www.example.com foo bar} -test http-cookiejar-4.19 "cookie storage: instance" -setup { - http::cookiejar create ::cookiejar - set result {} -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - cookiejar storeCookie { - key foo - value bar - secure 0 - domain www.example.com - origin www.example.com - path / - hostonly 1 - } - cookiejar storeCookie { - key bar - value foo - secure 0 - domain www.example.org - origin www.example.org - path / - hostonly 1 - } - lappend result [lsort [cookiejar lookup]] - lappend result [cookiejar lookup www.example.com] - lappend result [cookiejar lookup www.example.com foo] - lappend result [cookiejar lookup www.example.org] - lappend result [cookiejar lookup www.example.org bar] -} -cleanup { - ::cookiejar destroy -} -result {{www.example.com www.example.org} foo bar bar foo} -test http-cookiejar-4.20 "cookie storage: instance" -setup { - http::cookiejar create ::cookiejar - set result {} -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - cookiejar storeCookie { - key foo1 - value bar1 - secure 0 - domain www.example.com - origin www.example.com - path / - hostonly 1 - } - cookiejar storeCookie [dict replace { - key foo2 - value bar2 - secure 0 - domain www.example.com - origin www.example.com - path / - hostonly 1 - } expires [expr {[clock seconds]+5}]] - lappend result [cookiejar lookup] - lappend result [lsort [cookiejar lookup www.example.com]] - lappend result [cookiejar lookup www.example.com foo1] - lappend result [cookiejar lookup www.example.com foo2] -} -cleanup { - ::cookiejar destroy -} -result {www.example.com {foo1 foo2} bar1 bar2} -test http-cookiejar-4.21 "cookie storage: instance" -setup { - http::cookiejar create ::cookiejar - set result {} -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - cookiejar storeCookie { - key foo1 - value bar1 - secure 0 - domain www.example.com - origin www.example.com - path / - hostonly 1 - } - cookiejar storeCookie { - key foo2 - value bar2 - secure 0 - domain www.example.com - origin www.example.com - path / - hostonly 1 - } - lappend result [cookiejar lookup] - lappend result [lsort [cookiejar lookup www.example.com]] - lappend result [cookiejar lookup www.example.com foo1] - lappend result [cookiejar lookup www.example.com foo2] -} -cleanup { - ::cookiejar destroy -} -result {www.example.com {foo1 foo2} bar1 bar2} -test http-cookiejar-4.22 "cookie storage: instance" -setup { - http::cookiejar create ::cookiejar - set result {} -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - cookiejar forceLoadDomainData x y z -} -returnCodes error -cleanup { - ::cookiejar destroy -} -result {wrong # args: should be "cookiejar forceLoadDomainData"} -test http-cookiejar-4.23 "cookie storage: instance" -setup { - http::cookiejar create ::cookiejar - set result {} -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - cookiejar forceLoadDomainData -} -cleanup { - ::cookiejar destroy -} -result {} -test http-cookiejar-4.23.a {cookie storage: instance} -setup { - set off [http::cookiejar configure -offline] -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - http::cookiejar configure -offline 1 - [http::cookiejar create ::cookiejar] destroy -} -cleanup { - catch {::cookiejar destroy} - http::cookiejar configure -offline $off -} -result {} -test http-cookiejar-4.23.b {cookie storage: instance} -setup { - set off [http::cookiejar configure -offline] -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - http::cookiejar configure -offline 0 - [http::cookiejar create ::cookiejar] destroy -} -cleanup { - catch {::cookiejar destroy} - http::cookiejar configure -offline $off -} -result {} - -test http-cookiejar-5.1 "cookie storage: constraints" -setup { - http::cookiejar create ::cookiejar - cookiejar forceLoadDomainData -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - cookiejar storeCookie { - key foo - value bar - secure 0 - domain com - origin com - path / - hostonly 1 - } - cookiejar lookup -} -cleanup { - ::cookiejar destroy -} -result {} -test http-cookiejar-5.2 "cookie storage: constraints" -setup { - http::cookiejar create ::cookiejar - cookiejar forceLoadDomainData -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - cookiejar storeCookie { - key foo - value bar - secure 0 - domain foo.example.com - origin bar.example.org - path / - hostonly 1 - } - cookiejar lookup -} -cleanup { - ::cookiejar destroy -} -result {} -test http-cookiejar-5.3 "cookie storage: constraints" -setup { - http::cookiejar create ::cookiejar - cookiejar forceLoadDomainData -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - cookiejar storeCookie { - key foo1 - value bar - secure 0 - domain com - origin www.example.com - path / - hostonly 1 - } - cookiejar storeCookie { - key foo2 - value bar - secure 0 - domain example.com - origin www.example.com - path / - hostonly 1 - } - cookiejar lookup -} -cleanup { - ::cookiejar destroy -} -result {example.com} -test http-cookiejar-5.4 "cookie storage: constraints" -setup { - http::cookiejar create ::cookiejar - cookiejar forceLoadDomainData -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - cookiejar storeCookie { - key foo - value bar1 - secure 0 - domain www.example.com - origin www.example.com - path / - hostonly 1 - } - cookiejar storeCookie { - key foo - value bar2 - secure 0 - domain example.com - origin www.example.com - path / - hostonly 1 - } - lsort [cookiejar lookup] -} -cleanup { - ::cookiejar destroy -} -result {example.com www.example.com} -test http-cookiejar-5.5 "cookie storage: constraints" -setup { - http::cookiejar create ::cookiejar - cookiejar forceLoadDomainData -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - cookiejar storeCookie { - key foo1 - value 1 - secure 0 - domain com - origin www.example.com - path / - hostonly 0 - } - cookiejar storeCookie { - key foo2 - value 2 - secure 0 - domain com - origin www.example.com - path / - hostonly 1 - } - cookiejar storeCookie { - key foo3 - value 3 - secure 0 - domain example.com - origin www.example.com - path / - hostonly 0 - } - cookiejar storeCookie { - key foo4 - value 4 - secure 0 - domain example.com - origin www.example.com - path / - hostonly 1 - } - cookiejar storeCookie { - key foo5 - value 5 - secure 0 - domain www.example.com - origin www.example.com - path / - hostonly 0 - } - cookiejar storeCookie { - key foo6 - value 6 - secure 0 - domain www.example.com - origin www.example.com - path / - hostonly 1 - } - cookiejar storeCookie { - key foo7 - value 7 - secure 1 - domain www.example.com - origin www.example.com - path / - hostonly 0 - } - cookiejar storeCookie { - key foo8 - value 8 - secure 1 - domain www.example.com - origin www.example.com - path / - hostonly 1 - } - cookiejar storeCookie { - key foo9 - value 9 - secure 0 - domain sub.www.example.com - origin www.example.com - path / - hostonly 1 - } - list [cookiejar getCookies http www.example.com /] \ - [cookiejar getCookies http www2.example.com /] \ - [cookiejar getCookies https www.example.com /] \ - [cookiejar getCookies http sub.www.example.com /] -} -cleanup { - ::cookiejar destroy -} -result {{foo3 3 foo6 6} {foo3 3} {foo3 3 foo6 6 foo8 8} {foo3 3 foo5 5}} - -test http-cookiejar-6.1 "cookie storage: expiry and lookup" -setup { - http::cookiejar create ::cookiejar - oo::objdefine cookiejar export PurgeCookies - set result {} - proc values cookies { - global result - lappend result [lsort [lmap {k v} $cookies {set v}]] - } -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - values [cookiejar getCookies http www.example.com /] - cookiejar storeCookie { - key foo - value session - secure 0 - domain www.example.com - origin www.example.com - path / - hostonly 1 - } - values [cookiejar getCookies http www.example.com /] - cookiejar storeCookie [dict replace { - key foo - value cookie - secure 0 - domain www.example.com - origin www.example.com - path / - hostonly 1 - } expires [expr {[clock seconds]+1}]] - values [cookiejar getCookies http www.example.com /] - cookiejar storeCookie { - key foo - value session-global - secure 0 - domain example.com - origin www.example.com - path / - hostonly 0 - } - values [cookiejar getCookies http www.example.com /] - after 2500 - update - values [cookiejar getCookies http www.example.com /] - cookiejar PurgeCookies - values [cookiejar getCookies http www.example.com /] - cookiejar storeCookie { - key foo - value go-away - secure 0 - domain example.com - origin www.example.com - path / - hostonly 0 - expires 0 - } - values [cookiejar getCookies http www.example.com /] -} -cleanup { - ::cookiejar destroy -} -result {{} session cookie {cookie session-global} {cookie session-global} session-global {}} - -test http-cookiejar-7.1 "cookie storage: persistence of persistent cookies" -setup { - catch {rename ::cookiejar ""} - set f [makeFile "" cookiejar] - file delete $f -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - http::cookiejar create ::cookiejar $f - ::cookiejar destroy - http::cookiejar create ::cookiejar $f -} -cleanup { - catch {rename ::cookiejar ""} - removeFile $f -} -result ::cookiejar -test http-cookiejar-7.2 "cookie storage: persistence of persistent cookies" -setup { - catch {rename ::cookiejar ""} - set f [makeFile "" cookiejar] - file delete $f - set result {} -} -constraints {notOSXtravis sqlite3 cookiejar} -body { - http::cookiejar create ::cookiejar $f - cookiejar storeCookie [dict replace { - key foo - value cookie - secure 0 - domain www.example.com - origin www.example.com - path / - hostonly 1 - } expires [expr {[clock seconds]+1}]] - lappend result [::cookiejar getCookies http www.example.com /] - ::cookiejar destroy - http::cookiejar create ::cookiejar - lappend result [::cookiejar getCookies http www.example.com /] - ::cookiejar destroy - http::cookiejar create ::cookiejar $f - lappend result [::cookiejar getCookies http www.example.com /] -} -cleanup { - catch {rename ::cookiejar ""} - removeFile $f -} -result {{foo cookie} {} {foo cookie}} - -::tcltest::cleanupTests - -# Local variables: -# mode: tcl -# End: Index: tests/httpd ================================================================== --- tests/httpd +++ tests/httpd @@ -16,16 +16,11 @@ } else { set HOST [info hostname] } proc httpd_init {{port 8015}} { - set s [socket -server httpdAccept $port] - # Save the actual port number in a global variable. - # This is important when we're called with port 0 - # for picking an unused port at random. - set ::port [lindex [chan configure $s -sockname] 2] - return $s + socket -server httpdAccept $port } proc httpd_log {args} { global httpLog if {[info exists httpLog] && $httpLog} { puts stderr "httpd: [join $args { }]" @@ -219,11 +214,11 @@ append html } } # Catch errors from premature client closes - + catch { if {$data(proto) == "HEAD"} { puts $sock "HTTP/1.0 200 OK" } else { # Split the response to test for [Bug 26245326] Index: tests/httpd11.tcl ================================================================== --- tests/httpd11.tcl +++ tests/httpd11.tcl @@ -168,32 +168,41 @@ set transfer chunked } else { set close 1 } + set nosendclose 0 foreach pair [split $query &] { if {[scan $pair {%[^=]=%s} key val] != 2} {set val ""} switch -exact -- $key { + nosendclose {set nosendclose 1} close {set close 1 ; set transfer 0} transfer {set transfer $val} content-type {set type $val} } + } + if {$protocol eq "HTTP/1.1"} { + set nosendclose 0 } chan configure $chan -buffering line -encoding iso8859-1 -translation crlf Puts $chan "$protocol $code" Puts $chan "content-type: $type" Puts $chan [format "x-crc32: %08x" [zlib crc32 $data]] if {$req eq "POST"} { Puts $chan [format "x-query-length: %d" [string length $query]] } - if {$close} { + if {$close && (!$nosendclose)} { Puts $chan "connection: close" } Puts $chan "x-requested-encodings: [dict get? $meta accept-encoding]" - if {$encoding eq "identity"} { + if {$encoding eq "identity" && (!$nosendclose)} { Puts $chan "content-length: [string length $data]" + } elseif {$encoding eq "identity"} { + # This is a blatant attempt to confuse the client by sending neither + # "Connection: close" nor "Content-Length" when in non-chunked mode. + # See test http11-3.4. } else { Puts $chan "content-encoding: $encoding" } if {$transfer eq "chunked"} { Puts $chan "transfer-encoding: chunked" @@ -226,11 +235,11 @@ coroutine client$chan Service $chan $addr $port return } proc Control {chan} { - if {[gets $chan line] != -1} { + if {[gets $chan line] >= 0} { if {[string trim $line] eq "quit"} { set ::forever 1 } } if {[eof $chan]} { ADDED tests/httpold.test Index: tests/httpold.test ================================================================== --- /dev/null +++ tests/httpold.test @@ -0,0 +1,300 @@ +# Commands covered: http_config, http_get, http_wait, http_reset +# +# This file contains a collection of tests for the http script library. +# Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +if {[catch {package require http 1.0}]} { + if {[info exists httpold]} { + catch {puts "Cannot load http 1.0 package"} + ::tcltest::cleanupTests + return + } else { + catch {puts "Running http 1.0 tests in child interp"} + set interp [interp create httpold] + $interp eval [list set httpold "running"] + $interp eval [list set argv $argv] + $interp eval [list source [info script]] + interp delete $interp + ::tcltest::cleanupTests + return + } +} + +if {$::tcl_platform(os) eq "Darwin"} { + # Name resolution often a problem on OSX; not focus of HTTP package anyway + set HOST localhost +} else { + set HOST [info hostname] +} + +set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null" +catch {unset data} + +## +## The httpd script implement a stub http server +## +source [file join [file dirname [info script]] httpd] + +set port 8010 +if {[catch {httpd_init $port} listen]} { + puts "Cannot start http server, http test skipped" + unset port + ::tcltest::cleanupTests + return +} + +test httpold-1.1 {http_config} { + http_config +} {-accept */* -proxyfilter httpProxyRequired -proxyhost {} -proxyport {} -useragent {Tcl http client package 1.0}} + +test httpold-1.2 {http_config} { + http_config -proxyfilter +} httpProxyRequired + +test httpold-1.3 {http_config} { + catch {http_config -junk} +} 1 + +test httpold-1.4 {http_config} { + http_config -proxyhost nowhere.come -proxyport 8080 -proxyfilter myFilter -useragent "Tcl Test Suite" + set x [http_config] + http_config -proxyhost {} -proxyport {} -proxyfilter httpProxyRequired \ + -useragent "Tcl http client package 1.0" + set x +} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -useragent {Tcl Test Suite}} + +test httpold-1.5 {http_config} { + catch {http_config -proxyhost {} -junk 8080} +} 1 + +test httpold-2.1 {http_reset} { + catch {http_reset http#1} +} 0 + +test httpold-3.1 {http_get} { + catch {http_get -bogus flag} +} 1 +test httpold-3.2 {http_get} { + catch {http_get http:junk} err + set err +} {Unsupported URL: http:junk} + +set url ${::HOST}:$port +test httpold-3.3 {http_get} { + set token [http_get $url] + http_data $token +} "HTTP/1.0 TEST +

Hello, World!

+

GET /

+" + +set tail /a/b/c +set url ${::HOST}:$port/a/b/c +set binurl ${::HOST}:$port/binary + +test httpold-3.4 {http_get} { + set token [http_get $url] + http_data $token +} "HTTP/1.0 TEST +

Hello, World!

+

GET $tail

+" + +proc selfproxy {host} { + global port + return [list ${::HOST} $port] +} +test httpold-3.5 {http_get} { + http_config -proxyfilter selfproxy + set token [http_get $url] + http_config -proxyfilter httpProxyRequired + http_data $token +} "HTTP/1.0 TEST +

Hello, World!

+

GET http://$url

+" + +test httpold-3.6 {http_get} { + http_config -proxyfilter bogus + set token [http_get $url] + http_config -proxyfilter httpProxyRequired + http_data $token +} "HTTP/1.0 TEST +

Hello, World!

+

GET $tail

+" + +test httpold-3.7 {http_get} { + set token [http_get $url -headers {Pragma no-cache}] + http_data $token +} "HTTP/1.0 TEST +

Hello, World!

+

GET $tail

+" + +test httpold-3.8 {http_get} { + set token [http_get $url -query Name=Value&Foo=Bar] + http_data $token +} "HTTP/1.0 TEST +

Hello, World!

+

POST $tail

+

Query

+
+
Name
Value +
Foo
Bar +
+" + +test httpold-3.9 {http_get} { + set token [http_get $url -validate 1] + http_code $token +} "HTTP/1.0 200 OK" + + +test httpold-4.1 {httpEvent} { + set token [http_get $url] + upvar #0 $token data + array set meta $data(meta) + expr ($data(totalsize) == $meta(Content-Length)) +} 1 + +test httpold-4.2 {httpEvent} { + set token [http_get $url] + upvar #0 $token data + array set meta $data(meta) + string compare $data(type) [string trim $meta(Content-Type)] +} 0 + +test httpold-4.3 {httpEvent} { + set token [http_get $url] + http_code $token +} {HTTP/1.0 200 Data follows} + +test httpold-4.4 {httpEvent} { + set testfile [makeFile "" testfile] + set out [open $testfile w] + set token [http_get $url -channel $out] + close $out + set in [open $testfile] + set x [read $in] + close $in + removeFile $testfile + set x +} "HTTP/1.0 TEST +

Hello, World!

+

GET $tail

+" + +test httpold-4.5 {httpEvent} { + set testfile [makeFile "" testfile] + set out [open $testfile w] + set token [http_get $url -channel $out] + close $out + upvar #0 $token data + removeFile $testfile + expr $data(currentsize) == $data(totalsize) +} 1 + +test httpold-4.6 {httpEvent} { + set testfile [makeFile "" testfile] + set out [open $testfile w] + set token [http_get $binurl -channel $out] + close $out + set in [open $testfile] + fconfigure $in -translation binary + set x [read $in] + close $in + removeFile $testfile + set x +} "$bindata$binurl" + +proc myProgress {token total current} { + global progress httpLog + if {[info exists httpLog] && $httpLog} { + puts "progress $total $current" + } + set progress [list $total $current] +} +if 0 { + # This test hangs on Windows95 because the client never gets EOF + set httpLog 1 + test httpold-4.6 {httpEvent} { + set token [http_get $url -blocksize 50 -progress myProgress] + set progress + } {111 111} +} +test httpold-4.7 {httpEvent} { + set token [http_get $url -progress myProgress] + set progress +} {111 111} +test httpold-4.8 {httpEvent} { + set token [http_get $url] + http_status $token +} {ok} +test httpold-4.9 {httpEvent} { + set token [http_get $url -progress myProgress] + http_code $token +} {HTTP/1.0 200 Data follows} +test httpold-4.10 {httpEvent} { + set token [http_get $url -progress myProgress] + http_size $token +} {111} +test httpold-4.11 {httpEvent} { + set token [http_get $url -timeout 1 -command {#}] + http_reset $token + http_status $token +} {reset} +test httpold-4.12 {httpEvent} { + update + set x {} + after 500 {lappend x ok} + set token [http_get $url -timeout 1 -command {lappend x fail}] + vwait x + list [http_status $token] $x +} {timeout ok} + +test httpold-5.1 {http_formatQuery} { + http_formatQuery name1 value1 name2 "value two" +} {name1=value1&name2=value+two} + +test httpold-5.2 {http_formatQuery} { + http_formatQuery name1 ~bwelch name2 \xa1\xa2\xa2 +} {name1=%7ebwelch&name2=%a1%a2%a2} + +test httpold-5.3 {http_formatQuery} { + http_formatQuery lines "line1\nline2\nline3" +} {lines=line1%0d%0aline2%0d%0aline3} + +test httpold-6.1 {httpProxyRequired} { + update + http_config -proxyhost ${::HOST} -proxyport $port + set token [http_get $url] + http_wait $token + http_config -proxyhost {} -proxyport {} + upvar #0 $token data + set data(body) +} "HTTP/1.0 TEST +

Hello, World!

+

GET http://$url

+" + +# cleanup +catch {unset url} +catch {unset port} +catch {unset data} +close $listen +::tcltest::cleanupTests +return Index: tests/if-old.test ================================================================== --- tests/if-old.test +++ tests/if-old.test @@ -11,12 +11,12 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } test if-old-1.1 {taking proper branch} { set a {} Index: tests/if.test ================================================================== --- tests/if.test +++ tests/if.test @@ -8,12 +8,12 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } # Basic "if" operation. @@ -140,11 +140,11 @@ } if {[string compare $a "bar"] < 0} { set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 2 while {$a != "xxx"} { break; @@ -163,11 +163,11 @@ } if {[string compare $a "bar"] < 0} { set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 3 } return $a @@ -237,11 +237,11 @@ } if {[string compare $a "bar"] < 0} { set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 2 while {$a != "xxx"} { break; @@ -260,11 +260,11 @@ } if {[string compare $a "bar"] < 0} { set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 3 } elseif 1<2 then { #; this if arm should be taken set a 4 @@ -285,11 +285,11 @@ } if {[string compare $a "bar"] < 0} { set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 5 while {$a != "xxx"} { break; @@ -308,11 +308,11 @@ } if {[string compare $a "bar"] < 0} { set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 6 } return $a @@ -387,11 +387,11 @@ } if {[string compare $a "bar"] < 0} { set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 2 while {$a != "xxx"} { break; @@ -410,11 +410,11 @@ } if {[string compare $a "bar"] < 0} { set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 3 } elseif 1==2 then { #; this if arm should be taken set a 4 @@ -435,11 +435,11 @@ } if {[string compare $a "bar"] < 0} { set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 5 while {$a != "xxx"} { break; @@ -458,11 +458,11 @@ } if {[string compare $a "bar"] < 0} { set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 6 } else { set a 7 @@ -483,11 +483,11 @@ } if {[string compare $a "bar"] < 0} { set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 8 while {$a != "xxx"} { break; @@ -506,11 +506,11 @@ } if {[string compare $a "bar"] < 0} { set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 9 } return $a @@ -711,11 +711,11 @@ } $z {[string compare $a "bar"] < 0} { set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 2 while {$a != "xxx"} { break; @@ -734,11 +734,11 @@ } $z {[string compare $a "bar"] < 0} { set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 3 } return $a @@ -814,11 +814,11 @@ } $z {[string compare $a "bar"] < 0} { set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 2 while {$a != "xxx"} { break; @@ -837,11 +837,11 @@ } $z {[string compare $a "bar"] < 0} { set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 3 } elseif 1<2 then { #; this if arm should be taken set a 4 @@ -862,11 +862,11 @@ } $z {[string compare $a "bar"] < 0} { set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 5 while {$a != "xxx"} { break; @@ -885,11 +885,11 @@ } $z {[string compare $a "bar"] < 0} { set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 6 } return $a @@ -973,11 +973,11 @@ } $z {[string compare $a "bar"] < 0} { set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 2 while {$a != "xxx"} { break; @@ -996,11 +996,11 @@ } $z {[string compare $a "bar"] < 0} { set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 3 } elseif 1==2 then { #; this if arm should be taken set a 4 @@ -1021,11 +1021,11 @@ } $z {[string compare $a "bar"] < 0} { set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 5 while {$a != "xxx"} { break; @@ -1044,11 +1044,11 @@ } $z {[string compare $a "bar"] < 0} { set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 6 } else { set a 7 @@ -1069,11 +1069,11 @@ } $z {[string compare $a "bar"] < 0} { set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 8 while {$a != "xxx"} { break; @@ -1092,11 +1092,11 @@ } $z {[string compare $a "bar"] < 0} { set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 9 } return $a Index: tests/incr-old.test ================================================================== --- tests/incr-old.test +++ tests/incr-old.test @@ -11,12 +11,12 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } catch {unset x} Index: tests/incr.test ================================================================== --- tests/incr.test +++ tests/incr.test @@ -9,11 +9,11 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } unset -nocomplain x i proc readonly varName { @@ -492,22 +492,10 @@ list [catch {incr x 1a} msg] $msg $::errorInfo } {1 {expected integer but got "1a"} {expected integer but got "1a" (reading increment) invoked from within "incr x 1a"}} -test incr-2.32 {incr command (compiled): bad pure list increment} { - list [catch {incr x [list 1 2]} msg] $msg $::errorInfo -} {1 {expected integer but got "1 2"} {expected integer but got "1 2" - (reading increment) - invoked from within -"incr x [list 1 2]"}} -test incr-2.33 {incr command (compiled): bad pure dict increment} { - list [catch {incr x [dict create 1 2]} msg] $msg $::errorInfo -} {1 {expected integer but got "1 2"} {expected integer but got "1 2" - (reading increment) - invoked from within -"incr x [dict create 1 2]"}} test incr-3.1 {increment by wide amount: bytecode route} { set x 0 incr x 123123123123 } 123123123123 Index: tests/indexObj.test ================================================================== --- tests/indexObj.test +++ tests/indexObj.test @@ -6,12 +6,12 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -107,11 +107,11 @@ test indexObj-5.6 {Tcl_WrongNumArgs} testindexobj { testwrongnumargs 2 "" mycmd foo } "wrong # args: should be \"mycmd foo\"" # Contrast this with test proc-3.6; they have to be like this because # of [Bug 1066837] so Itcl won't break. -test indexObj-5.7 {Tcl_WrongNumArgs} {testindexobj obsolete} { +test indexObj-5.7 {Tcl_WrongNumArgs} testindexobj { testwrongnumargs 2 "fee fi" "fo fum" foo bar } "wrong # args: should be \"fo fum foo fee fi\"" test indexObj-6.1 {Tcl_GetIndexFromObjStruct} testindexobj { set x a Index: tests/info.test ================================================================== --- tests/info.test +++ tests/info.test @@ -14,16 +14,16 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # DO NOT DELETE THIS LINE if {{::tcltest} ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } + ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] -testConstraint zlib [llength [info commands zlib]] # Set up namespaces needed to test operation of "info args", "info body", # "info default", and "info procs" with imported procedures. catch {namespace delete test_ns_info1 test_ns_info2} @@ -31,11 +31,11 @@ namespace eval test_ns_info1 { namespace export * proc p {x} {return "x=$x"} proc q {{y 27} {z {}}} {return "y=$y"} } - + test info-1.1 {info args option} { proc t1 {a bbb c} {return foo} info args t1 } {a bbb c} test info-1.2 {info args option} { @@ -108,20 +108,20 @@ } {9 9} proc testinfocmdcount {} { set x [info cmdcount] set y 12345 - set z [info cmdc] + set z [info cm] expr {$z-$x} } test info-3.1 {info cmdcount compiled} { testinfocmdcount } 4 test info-3.2 {info cmdcount evaled} -body { set x [info cmdcount] set y 12345 - set z [info cmdc] + set z [info cm] expr {$z-$x} } -cleanup {unset x y z} -result 4 test info-3.3 {info cmdcount evaled} -body [info body testinfocmdcount] -cleanup {unset x y z} -result 4 test info-3.4 {info cmdcount option} -body { info cmdcount 1 @@ -323,11 +323,11 @@ } t1 146 testString } {1 {t1 146 testString}} test info-9.3 {info level option} { proc t1 {a b} { - t2 [expr $a*2] $b + t2 [expr {$a*2}] $b } proc t2 {x y} { list [info level] [info level 1] [info level 2] [info level -1] \ [info level 0] } @@ -395,12 +395,12 @@ info library } -returnCodes error -result {no library has been specified for Tcl} set tcl_library $savedLibrary; unset savedLibrary test info-11.1 {info loaded option} -body { - info loaded a b c -} -returnCodes error -result {wrong # args: should be "info loaded ?interp? ?packageName?"} + info loaded a b +} -returnCodes error -result {wrong # args: should be "info loaded ?interp?"} test info-11.2 {info loaded option} -body { info loaded {}; info loaded gorp } -returnCodes error -result {could not find interpreter "gorp"} test info-12.1 {info locals option} -body { @@ -653,11 +653,11 @@ namespace eval x info vars foo } -cleanup { namespace delete x } -result {} -set functions {abs acos asin atan atan2 bool ceil cos cosh double entier exp floor fmod hypot int isfinite isinf isnan isnormal isqrt issubnormal isunordered log log10 max min pow rand round sin sinh sqrt srand tan tanh wide} +set functions {abs acos asin atan atan2 bool ceil cos cosh double entier exp floor fmod hypot int isqrt log log10 max min pow rand round sin sinh sqrt srand tan tanh wide} # Check whether the extra testing functions are defined... if {!([catch {expr T1()} msg] && ($msg eq {invalid command name "tcl::mathfunc::T1"}))} { set functions "T1 T2 T3 $functions" ;# A lazy way of prepending! } test info-20.1 {info functions option} {info functions sin} sin @@ -676,20 +676,20 @@ test info-21.1 {miscellaneous error conditions} -returnCodes error -body { info } -result {wrong # args: should be "info subcommand ?arg ...?"} test info-21.2 {miscellaneous error conditions} -returnCodes error -body { info gorp -} -result {unknown or ambiguous subcommand "gorp": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "gorp": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} test info-21.3 {miscellaneous error conditions} -returnCodes error -body { info c -} -result {unknown or ambiguous subcommand "c": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "c": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} test info-21.4 {miscellaneous error conditions} -returnCodes error -body { info l -} -result {unknown or ambiguous subcommand "l": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "l": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} test info-21.5 {miscellaneous error conditions} -returnCodes error -body { info s -} -result {unknown or ambiguous subcommand "s": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "s": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} ## # ### ### ### ######### ######### ######### ## info frame @@ -1839,11 +1839,11 @@ # ------------------------------------------------------------------------- # literal sharing 2, bug 2933089 -test info-39.1 {location information not confused by literal sharing, bug 2933089} -setup { +test info-40.1 {location information not confused by literal sharing, bug 2933089} -setup { set result {} proc print_one {} {} proc test_info_frame {} { set x 1 @@ -2393,178 +2393,10 @@ reduce [foo::bar] } -cleanup { namespace delete foo } -result {type source line 2389 file info.test cmd {info frame 0} proc ::foo::bar level 0} -# ------------------------------------------------------------------------- -namespace eval ::testinfocmdtype { - apply {cmds { - foreach c $cmds {rename $c {}} - } ::testinfocmdtype} [info commands ::testinfocmdtype::*] -} -test info-40.1 {info cmdtype: syntax} -body { - info cmdtype -} -returnCodes error -result {wrong # args: should be "info cmdtype commandName"} -test info-40.2 {info cmdtype: syntax} -body { - info cmdtype foo bar -} -returnCodes error -result {wrong # args: should be "info cmdtype commandName"} -test info-40.3 {info cmdtype: no such command} -body { - info cmdtype ::testinfocmdtype::foo -} -returnCodes error -result {unknown command "::testinfocmdtype::foo"} -test info-40.4 {info cmdtype: native commands} -body { - info cmdtype ::if -} -result native -test info-40.5 {info cmdtype: native commands} -body { - info cmdtype ::puts -} -result native -test info-40.6 {info cmdtype: native commands} -body { - info cmdtype ::yield -} -result native -test info-40.7 {info cmdtype: procedures} -setup { - proc ::testinfocmdtype::someproc {} {} -} -body { - info cmdtype ::testinfocmdtype::someproc -} -cleanup { - rename ::testinfocmdtype::someproc {} -} -result proc -test info-40.8 {info cmdtype: aliases} -setup { - interp alias {} ::testinfocmdtype::somealias {} ::puts -} -body { - info cmdtype ::testinfocmdtype::somealias -} -cleanup { - rename ::testinfocmdtype::somealias {} -} -result alias -test info-40.9 {info cmdtype: imports} -setup { - namespace eval ::testinfocmdtype { - namespace eval foo { - proc bar {} {} - namespace export bar - } - namespace import foo::bar - } -} -body { - info cmdtype ::testinfocmdtype::bar -} -cleanup { - rename ::testinfocmdtype::bar {} - namespace delete ::testinfocmdtype::foo -} -result import -test info-40.10 {info cmdtype: slaves} -setup { - apply {i { - rename $i ::testinfocmdtype::slave - variable ::testinfocmdtype::slave $i - }} [interp create] -} -body { - info cmdtype ::testinfocmdtype::slave -} -cleanup { - interp delete $::testinfocmdtype::slave -} -result slave -test info-40.11 {info cmdtype: objects} -setup { - apply {{} { - oo::object create obj - } ::testinfocmdtype} -} -body { - info cmdtype ::testinfocmdtype::obj -} -cleanup { - ::testinfocmdtype::obj destroy -} -result object -test info-40.12 {info cmdtype: objects} -setup { - apply {{} { - oo::object create obj - } ::testinfocmdtype} -} -body { - info cmdtype [info object namespace ::testinfocmdtype::obj]::my -} -cleanup { - ::testinfocmdtype::obj destroy -} -result privateObject -test info-40.13 {info cmdtype: ensembles} -setup { - namespace eval ::testinfocmdtype { - namespace eval ensmbl { - proc bar {} {} - namespace export * - namespace ensemble create - } - } -} -body { - info cmdtype ::testinfocmdtype::ensmbl -} -cleanup { - namespace delete ::testinfocmdtype::ensmbl -} -result ensemble -test info-40.14 {info cmdtype: zlib streams} -constraints zlib -setup { - namespace eval ::testinfocmdtype { - rename [zlib stream gzip] zstream - } -} -body { - info cmdtype ::testinfocmdtype::zstream -} -cleanup { - ::testinfocmdtype::zstream close -} -result zlibStream -test info-40.15 {info cmdtype: coroutines} -setup { - coroutine ::testinfocmdtype::coro eval yield -} -body { - info cmdtype ::testinfocmdtype::coro -} -cleanup { - ::testinfocmdtype::coro -} -result coroutine -test info-40.16 {info cmdtype: dynamic behavior} -setup { - proc ::testinfocmdtype::foo {} {} -} -body { - namespace eval ::testinfocmdtype { - list [catch {info cmdtype foo}] [catch {info cmdtype bar}] \ - [namespace which foo] [rename foo bar] [namespace which bar] \ - [catch {info cmdtype foo}] [catch {info cmdtype bar}] - } -} -cleanup { - namespace eval ::testinfocmdtype { - catch {rename foo {}} - catch {rename bar {}} - } -} -result {0 1 ::testinfocmdtype::foo {} ::testinfocmdtype::bar 1 0} -test info-40.17 {info cmdtype: aliases in slave interpreters} -setup { - set i [interp create] -} -body { - $i alias foo gorp - $i eval { - info cmdtype foo - } -} -cleanup { - interp delete $i -} -result alias -test info-40.18 {info cmdtype: aliases in slave interpreters} -setup { - set safe [interp create -safe] -} -body { - $safe alias foo gorp - $safe eval { - info cmdtype foo - } -} -returnCodes error -cleanup { - interp delete $safe -} -result {not allowed to invoke subcommand cmdtype of info} -test info-40.19 {info cmdtype: aliases in slave interpreters} -setup { - set safe [interp create -safe] -} -body { - set inner [interp create [list $safe bar]] - interp alias $inner foo $safe gorp - $safe eval { - bar eval { - info cmdtype foo - } - } -} -returnCodes error -cleanup { - interp delete $safe -} -result {not allowed to invoke subcommand cmdtype of info} -test info-40.20 {info cmdtype: aliases in slave interpreters} -setup { - set safe [interp create -safe] -} -body { - $safe eval { - interp alias {} foo {} gorp - info cmdtype foo - } -} -returnCodes error -cleanup { - interp delete $safe -} -result {not allowed to invoke subcommand cmdtype of info} -namespace delete ::testinfocmdtype - # ------------------------------------------------------------------------- unset -nocomplain res test info-39.2 {Bug 4b61afd660} -setup { proc probe {} { Index: tests/init.test ================================================================== --- tests/init.test +++ tests/init.test @@ -16,10 +16,23 @@ } # Clear out any namespaces called test_ns_* catch {namespace delete {*}[namespace children :: test_ns_*]} +test init-0.1 {no error on initialization phase (init.tcl)} -setup { + interp create child +} -body { + child eval { + list [set v [info exists ::errorInfo]] \ + [if {$v} {set ::errorInfo}] \ + [set v [info exists ::errorCode]] \ + [if {$v} {set ::errorCode}] + } +} -cleanup { + interp delete child +} -result {0 {} 0 {}} + # Six cases - white box testing test init-1.1 {auto_qualify - absolute cmd - namespace} { auto_qualify ::foo::bar ::blue } ::foo::bar @@ -26,11 +39,11 @@ test init-1.2 {auto_qualify - absolute cmd - global} { auto_qualify ::global ::sub } global test init-1.3 {auto_qualify - no colons cmd - global} { auto_qualify nocolons :: -} nocolons +} nocolons test init-1.4 {auto_qualify - no colons cmd - namespace} { auto_qualify nocolons ::sub } {::sub::nocolons nocolons} test init-1.5 {auto_qualify - colons in cmd - global} { auto_qualify foo::bar :: @@ -44,15 +57,15 @@ } ::foo::bar test init-1.8 {auto_qualify - multiple colons 2} { auto_qualify :::foo ::bar } foo -# We use a sub-interp and auto_reset and double the tests because there is 2 +# We use a child interp and auto_reset and double the tests because there is 2 # places where auto_loading occur (before loading the indexes files and after) set testInterp [interp create] -tcltest::loadIntoSlaveInterpreter $testInterp {*}$argv +tcltest::loadIntoChildInterpreter $testInterp {*}$argv interp eval $testInterp { namespace import -force ::tcltest::* customMatch pairwise {apply {{mode pair} { if {[llength $pair] != 2} {error "need a pair of values to check"} string $mode [lindex $pair 0] [lindex $pair 1] @@ -91,15 +104,15 @@ rename ::safe::setLogCmd {} ;# should not fail } {} auto_reset catch {rename ::safe::setLogCmd {}} test init-2.6 {load setLogCmd from safe:: - stage 1} { - namespace eval safe setLogCmd + namespace eval safe setLogCmd rename ::safe::setLogCmd {} ;# should not fail } {} test init-2.7 {oad setLogCmd from safe:: - stage 2} { - namespace eval safe setLogCmd + namespace eval safe setLogCmd rename ::safe::setLogCmd {} ;# should not fail } {} test init-2.8 {load tcl::HistAdd} -setup { auto_reset catch {rename ::tcl::HistAdd {}} @@ -130,16 +143,16 @@ {argument which is all on one line but which is of such great length that the Tcl C library will truncate it when appending it onto the global error stack} {argument which spans multiple lines and is long enough to be truncated and " <- includes a false lead in the prune point search and must be longer still to force truncation} - {contrived example: rare circumstance + {contrived example: rare circumstance where the point at which to prune the error stack cannot be uniquely determined. foo bar foo "} - {contrived example: rare circumstance + {contrived example: rare circumstance where the point at which to prune the error stack cannot be uniquely determined. foo bar "} {argument that contains non-ASCII character, \u20ac, and which is of such great length that it will be longer than 150 bytes so it will be truncated by the Tcl C library} ADDED tests/internals.tcl Index: tests/internals.tcl ================================================================== --- /dev/null +++ tests/internals.tcl @@ -0,0 +1,96 @@ +# This file contains internal facilities for Tcl tests. +# +# Source this file in the related tests to include from tcl-tests: +# +# source [file join [file dirname [info script]] internals.tcl] +# +# Copyright (c) 2020 Sergey G. Brester (sebres). +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {[namespace which -command ::tcltest::internals::scriptpath] eq ""} {namespace eval ::tcltest::internals { + +namespace path ::tcltest + +::tcltest::ConstraintInitializer testWithLimit { expr {[testConstraint macOrUnix] && ![catch { exec prlimit --version }]} } + +# test-with-limit -- +# +# Usage: test-with-limit ?-addmem bytes? ?-maxmem bytes? command +# Options: +# -addmem - set additional memory limit (in bytes) as difference (extra memory needed to run a test) +# -maxmem - set absolute maximum address space limit (in bytes) +# +proc testWithLimit args { + set body [lindex $args end] + array set in [lrange $args 0 end-1] + # test in child process (with limits): + set pipe {} + if {[catch { + # start new process: + set pipe [open |[list [interpreter]] r+] + set ppid [pid $pipe] + # create prlimit args: + set args {} + # with limited address space: + if {[info exists in(-addmem)] || [info exists in(-maxmem)]} { + if {[info exists in(-addmem)]} { + # as differnce to normal usage, so try to retrieve current memory usage: + if {[catch { + # using ps (vsz is in KB): + incr in(-addmem) [expr {[lindex [exec ps -hq $ppid -o vsz] end] * 1024}] + }]} { + # ps failed, use default size 20MB: + incr in(-addmem) 20000000 + # + size of locale-archive (may be up to 100MB): + incr in(-addmem) [expr { + [file exists /usr/lib/locale/locale-archive] ? + [file size /usr/lib/locale/locale-archive] : 0 + }] + } + if {![info exists in(-maxmem)]} { + set in(-maxmem) $in(-addmem) + } + set in(-maxmem) [expr { max($in(-addmem), $in(-maxmem)) }] + } + append args --as=$in(-maxmem) + } + # apply limits: + exec prlimit -p $ppid {*}$args + } msg opt]} { + catch {close $pipe} + tcltest::Warn "testWithLimit: error - [regsub {^\s*([^\n]*).*$} $msg {\1}]" + tcltest::Skip testWithLimit + } + # execute body, close process and return: + set ret [catch { + chan configure $pipe -buffering line + puts $pipe "puts \[$body\]" + puts $pipe exit + set result [read $pipe] + close $pipe + set pipe {} + set result + } result opt] + if {$pipe ne ""} { catch { close $pipe } } + if {$ret && [dict get $opt -errorcode] eq "BYPASS-SKIPPED-TEST"} { + return {*}$opt $result + } + if { ( [info exists in(-warn-on-code)] && $ret in $in(-warn-on-code) ) + || ( $ret && [info exists in(-warn-on-alloc-error)] && $in(-warn-on-alloc-error) + && [regexp {\munable to (?:re)?alloc\M} $result] ) + } { + tcltest::Warn "testWithLimit: wrong limit, result: $result" + tcltest::Skip testWithLimit + } + return {*}$opt $result +} + +# export all routines starting with test +namespace export test* + +# for script path & as mark for loaded +proc scriptpath {} [list return [info script]] + +}}; # end of internals. Index: tests/interp.test ================================================================== --- tests/interp.test +++ tests/interp.test @@ -18,23 +18,23 @@ ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] testConstraint testinterpdelete [llength [info commands testinterpdelete]] -set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs tcl:encoding:system tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempdir tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable tcl:info:cmdtype tcl:info:nameofexecutable tcl:process:autopurge tcl:process:list tcl:process:purge tcl:process:status tcl:zipfs:lmkimg tcl:zipfs:lmkzip tcl:zipfs:mkimg tcl:zipfs:mkkey tcl:zipfs:mkzip tcl:zipfs:mount tcl:zipfs:mount_data tcl:zipfs:unmount unload} +set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable unload} -foreach i [interp slaves] { +foreach i [interp children] { interp delete $i } # Part 0: Check out options for interp command test interp-1.1 {options for interp command} -returnCodes error -body { interp } -result {wrong # args: should be "interp cmd ?arg ...?"} test interp-1.2 {options for interp command} -returnCodes error -body { interp frobox -} -result {bad option "frobox": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} +} -result {bad option "frobox": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} test interp-1.3 {options for interp command} { interp delete } "" test interp-1.4 {options for interp command} -returnCodes error -body { interp delete foo bar @@ -44,21 +44,21 @@ } -result {wrong # args: should be "interp exists ?path?"} # # test interp-0.6 was removed # test interp-1.6 {options for interp command} -returnCodes error -body { - interp slaves foo bar zop -} -result {wrong # args: should be "interp slaves ?path?"} + interp children foo bar zop +} -result {wrong # args: should be "interp children ?path?"} test interp-1.7 {options for interp command} -returnCodes error -body { interp hello -} -result {bad option "hello": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} +} -result {bad option "hello": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} test interp-1.8 {options for interp command} -returnCodes error -body { interp -froboz -} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} +} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} test interp-1.9 {options for interp command} -returnCodes error -body { interp -froboz -safe -} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} +} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} test interp-1.10 {options for interp command} -returnCodes error -body { interp target } -result {wrong # args: should be "interp target path alias"} # Part 1: Basic interpreter creation tests: @@ -103,64 +103,64 @@ regexp "interp(\[0-9]+)" $x dummy thenum interp delete $x proc interp$thenum {} {} set x [interp create] regexp "interp(\[0-9]+)" $x dummy anothernum - expr $anothernum > $thenum + expr {$anothernum > $thenum} } 1 test interp-2.12 {anonymous interps vs existing procs} { set x [interp create -safe] regexp "interp(\[0-9]+)" $x dummy thenum interp delete $x proc interp$thenum {} {} set x [interp create -safe] regexp "interp(\[0-9]+)" $x dummy anothernum - expr $anothernum - $thenum + expr {$anothernum - $thenum} } 1 test interp-2.13 {correct default when no $path arg is given} -body { interp create -- } -match regexp -result {interp[0-9]+} -foreach i [interp slaves] { +foreach i [interp children] { interp delete $i } -# Part 2: Testing "interp slaves" and "interp exists" -test interp-3.1 {testing interp exists and interp slaves} { - interp slaves +# Part 2: Testing "interp children" and "interp exists" +test interp-3.1 {testing interp exists and interp children} { + interp children } "" -test interp-3.2 {testing interp exists and interp slaves} { +test interp-3.2 {testing interp exists and interp children} { interp create a interp exists a } 1 -test interp-3.3 {testing interp exists and interp slaves} { +test interp-3.3 {testing interp exists and interp children} { interp exists nonexistent } 0 -test interp-3.4 {testing interp exists and interp slaves} -body { - interp slaves a b c -} -returnCodes error -result {wrong # args: should be "interp slaves ?path?"} -test interp-3.5 {testing interp exists and interp slaves} -body { +test interp-3.4 {testing interp exists and interp children} -body { + interp children a b c +} -returnCodes error -result {wrong # args: should be "interp children ?path?"} +test interp-3.5 {testing interp exists and interp children} -body { interp exists a b c } -returnCodes error -result {wrong # args: should be "interp exists ?path?"} -test interp-3.6 {testing interp exists and interp slaves} { +test interp-3.6 {testing interp exists and interp children} { interp exists } 1 -test interp-3.7 {testing interp exists and interp slaves} -setup { +test interp-3.7 {testing interp exists and interp children} -setup { catch {interp create a} } -body { - interp slaves + interp children } -result a -test interp-3.8 {testing interp exists and interp slaves} -body { - interp slaves a b c -} -returnCodes error -result {wrong # args: should be "interp slaves ?path?"} -test interp-3.9 {testing interp exists and interp slaves} -setup { +test interp-3.8 {testing interp exists and interp children} -body { + interp children a b c +} -returnCodes error -result {wrong # args: should be "interp children ?path?"} +test interp-3.9 {testing interp exists and interp children} -setup { catch {interp create a} } -body { interp create {a a2} -safe - expr {"a2" in [interp slaves a]} + expr {"a2" in [interp children a]} } -result 1 -test interp-3.10 {testing interp exists and interp slaves} -setup { +test interp-3.10 {testing interp exists and interp children} -setup { catch {interp create a} catch {interp create {a a2}} } -body { interp exists {a a2} } -result 1 @@ -184,11 +184,11 @@ } "" test interp-4.5 {testing interp delete} { interp create a interp create {a x1} interp delete {a x1} - expr {"x1" in [interp slaves a]} + expr {"x1" in [interp children a]} } 0 test interp-4.6 {testing interp delete} { interp create c1 interp create c2 interp create c3 @@ -201,18 +201,18 @@ } -result {could not find interpreter "c3"} test interp-4.8 {testing interp delete} -returnCodes error -body { interp delete {} } -result {cannot delete the current interpreter} -foreach i [interp slaves] { +foreach i [interp children] { interp delete $i } # Part 4: Consistency checking - all nondeleted interpreters should be # there: test interp-5.1 {testing consistency} { - interp slaves + interp children } "" test interp-5.2 {testing consistency} { interp exists a } 0 test interp-5.3 {testing consistency} { @@ -222,54 +222,54 @@ # Recreate interpreter "a" interp create a # Part 5: Testing eval in interpreter object command and with interp command test interp-6.1 {testing eval} { - a eval expr 3 + 5 + a eval expr {{3 + 5}} } 8 test interp-6.2 {testing eval} -returnCodes error -body { a eval foo } -result {invalid command name "foo"} test interp-6.3 {testing eval} { - a eval {proc foo {} {expr 3 + 5}} + a eval {proc foo {} {expr {3 + 5}}} a eval foo } 8 -catch {a eval {proc foo {} {expr 3 + 5}}} +catch {a eval {proc foo {} {expr {3 + 5}}}} test interp-6.4 {testing eval} { interp eval a foo } 8 test interp-6.5 {testing eval} { interp create {a x2} - interp eval {a x2} {proc frob {} {expr 4 * 9}} + interp eval {a x2} {proc frob {} {expr {4 * 9}}} interp eval {a x2} frob } 36 catch {interp create {a x2}} test interp-6.6 {testing eval} -returnCodes error -body { interp eval {a x2} foo } -result {invalid command name "foo"} -# UTILITY PROCEDURE RUNNING IN MASTER INTERPRETER: -proc in_master {args} { - return [list seen in master: $args] +# UTILITY PROCEDURE RUNNING IN PARENT INTERPRETER: +proc in_parent {args} { + return [list seen in parent: $args] } # Part 6: Testing basic alias creation test interp-7.1 {testing basic alias creation} { - a alias foo in_master + a alias foo in_parent } foo -catch {a alias foo in_master} +catch {a alias foo in_parent} test interp-7.2 {testing basic alias creation} { - a alias bar in_master a1 a2 a3 + a alias bar in_parent a1 a2 a3 } bar -catch {a alias bar in_master a1 a2 a3} +catch {a alias bar in_parent a1 a2 a3} # Test 6.3 has been deleted. test interp-7.3 {testing basic alias creation} { a alias foo -} in_master +} in_parent test interp-7.4 {testing basic alias creation} { a alias bar -} {in_master a1 a2 a3} +} {in_parent a1 a2 a3} test interp-7.5 {testing basic alias creation} { lsort [a aliases] } {bar foo} test interp-7.6 {testing basic aliases arg checking} -returnCodes error -body { a aliases too many args @@ -276,33 +276,33 @@ } -result {wrong # args: should be "a aliases"} # Part 7: testing basic alias invocation test interp-8.1 {testing basic alias invocation} { catch {interp create a} - a alias foo in_master + a alias foo in_parent a eval foo s1 s2 s3 -} {seen in master: {s1 s2 s3}} +} {seen in parent: {s1 s2 s3}} test interp-8.2 {testing basic alias invocation} { catch {interp create a} - a alias bar in_master a1 a2 a3 + a alias bar in_parent a1 a2 a3 a eval bar s1 s2 s3 -} {seen in master: {a1 a2 a3 s1 s2 s3}} +} {seen in parent: {a1 a2 a3 s1 s2 s3}} test interp-8.3 {testing basic alias invocation} -returnCodes error -body { catch {interp create a} a alias } -result {wrong # args: should be "a alias aliasName ?targetName? ?arg ...?"} # Part 8: Testing aliases for non-existent or hidden targets test interp-9.1 {testing aliases for non-existent targets} { catch {interp create a} - a alias zop nonexistent-command-in-master + a alias zop nonexistent-command-in-parent list [catch {a eval zop} msg] $msg -} {1 {invalid command name "nonexistent-command-in-master"}} +} {1 {invalid command name "nonexistent-command-in-parent"}} test interp-9.2 {testing aliases for non-existent targets} { catch {interp create a} - a alias zop nonexistent-command-in-master - proc nonexistent-command-in-master {} {return i_exist!} + a alias zop nonexistent-command-in-parent + proc nonexistent-command-in-parent {} {return i_exist!} a eval zop } i_exist! test interp-9.3 {testing aliases for hidden commands} { catch {interp create a} a eval {proc p {} {return ENTER_A}} @@ -327,12 +327,12 @@ rename a {} namespace delete tst set res } {GLOBAL GLOBAL} -if {[info command nonexistent-command-in-master] != ""} { - rename nonexistent-command-in-master {} +if {[info command nonexistent-command-in-parent] != ""} { + rename nonexistent-command-in-parent {} } # Part 9: Aliasing between interpreters test interp-10.1 {testing aliasing between interpreters} { catch {interp delete a} @@ -378,13 +378,13 @@ catch {interp delete a} catch {interp delete b} interp create a interp create b interp alias a a_command b b_command a1 a2 a3 - b alias b_command in_master b1 b2 b3 + b alias b_command in_parent b1 b2 b3 a eval a_command m1 m2 m3 -} {seen in master: {b1 b2 b3 a1 a2 a3 m1 m2 m3}} +} {seen in parent: {b1 b2 b3 a1 a2 a3 m1 m2 m3}} test interp-10.7 {testing aliases between interpreters} { catch {interp delete a} interp create a interp alias "" foo a zoppo a eval {proc zoppo {x} {list $x $x $x}} @@ -511,11 +511,11 @@ interp create a interp create {a x3} interp alias {a x3} froboz "" puts interp aliases {a x3} } froboz -test interp-14.4 {testing interp alias - alias over master} { +test interp-14.4 {testing interp alias - alias over parent} { # SF Bug 641195 catch {interp delete a} interp create a list [catch {interp alias "" a a eval} msg] $msg [info commands a] } {1 {cannot define or rename alias "a": interpreter deleted} {}} @@ -744,11 +744,11 @@ catch {interp delete xxx} interp create xxx xxx eval {proc bgerror {args} {exit}} xxx alias exit kill xxx proc kill {i} {interp delete $i} - xxx eval after 100 expr a + b + xxx eval after 100 expr {a + b} after 200 update interp exists xxx } 0 @@ -791,44 +791,44 @@ x eval rename a c list [catch {x eval rename c b} msg] $msg } {1 {cannot define or rename alias "b": would create a loop}} # -# Test robustness of Tcl_DeleteInterp when applied to a slave interpreter. +# Test robustness of Tcl_DeleteInterp when applied to a child interpreter. # If there are bugs in the implementation these tests are likely to expose # the bugs as a core dump. # -test interp-18.1 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { +test interp-18.1 {testing Tcl_DeleteInterp vs children} testinterpdelete { list [catch {testinterpdelete} msg] $msg } {1 {wrong # args: should be "testinterpdelete path"}} -test interp-18.2 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { +test interp-18.2 {testing Tcl_DeleteInterp vs children} testinterpdelete { catch {interp delete a} interp create a testinterpdelete a } "" -test interp-18.3 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { +test interp-18.3 {testing Tcl_DeleteInterp vs children} testinterpdelete { catch {interp delete a} interp create a interp create {a b} testinterpdelete {a b} } "" -test interp-18.4 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { +test interp-18.4 {testing Tcl_DeleteInterp vs children} testinterpdelete { catch {interp delete a} interp create a interp create {a b} testinterpdelete a } "" -test interp-18.5 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { +test interp-18.5 {testing Tcl_DeleteInterp vs children} testinterpdelete { catch {interp delete a} interp create a interp create {a b} interp alias {a b} dodel {} dodel proc dodel {x} {testinterpdelete $x} list [catch {interp eval {a b} {dodel {a b}}} msg] $msg } {0 {}} -test interp-18.6 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { +test interp-18.6 {testing Tcl_DeleteInterp vs children} testinterpdelete { catch {interp delete a} interp create a interp create {a b} interp alias {a b} dodel {} dodel proc dodel {x} {testinterpdelete $x} @@ -964,11 +964,11 @@ test interp-19.9 {alias deletion, renaming} { catch {interp delete a} interp create a interp alias a foo a bar interp eval a rename foo blotz - interp eval a {proc foo {} {expr 34 * 34}} + interp eval a {proc foo {} {expr {34 * 34}}} interp alias a foo {} set l [interp eval a foo] interp delete a set l } 1156 @@ -1613,40 +1613,40 @@ } {1 {cannot use namespace qualifiers in hidden command token (rename)}} test interp-20.49 {interp invokehidden -namespace} -setup { set script [makeFile { set x [namespace current] } script] - interp create -safe slave + interp create -safe child } -body { - slave invokehidden -namespace ::foo source $script - slave eval {set ::foo::x} + child invokehidden -namespace ::foo source $script + child eval {set ::foo::x} } -cleanup { - interp delete slave + interp delete child removeFile script } -result ::foo test interp-20.50 {Bug 2486550} -setup { - interp create slave + interp create child } -body { - slave hide coroutine - slave invokehidden coroutine + child hide coroutine + child invokehidden coroutine } -cleanup { - interp delete slave + interp delete child } -returnCodes error -match glob -result * test interp-20.50.1 {Bug 2486550} -setup { - interp create slave + interp create child } -body { - slave hide coroutine - catch {slave invokehidden coroutine} m o + child hide coroutine + catch {child invokehidden coroutine} m o dict get $o -errorinfo } -cleanup { unset -nocomplain m 0 - interp delete slave + interp delete child } -returnCodes ok -result {wrong # args: should be "coroutine name cmd ?arg ...?" while executing "coroutine" invoked from within -"slave invokehidden coroutine"} +"child invokehidden coroutine"} test interp-21.1 {interp hidden} { interp hidden {} } "" test interp-21.2 {interp hidden} { @@ -1834,11 +1834,11 @@ interp delete a } -result {{} bar {} bar bar {} {}} test interp-23.2 {testing hiding vs aliases: safe interp} -setup { catch {interp delete a} set l "" -} -constraints {unixOrPc} -body { +} -constraints {unixOrWin} -body { interp create a -safe lappend l [lsort [interp hidden a]] a alias bar bar lappend l [lsort [interp aliases a]] [lsort [interp hidden a]] a hide bar @@ -1845,11 +1845,11 @@ lappend l [lsort [interp aliases a]] [lsort [interp hidden a]] a alias bar {} lappend l [lsort [interp aliases a]] [lsort [interp hidden a]] } -cleanup { interp delete a -} -result [list $hidden_cmds {bar clock} $hidden_cmds {bar clock} [lsort [concat $hidden_cmds bar]] {clock} $hidden_cmds] +} -result [list $hidden_cmds {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} $hidden_cmds {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} [lsort [concat $hidden_cmds bar]] {::tcl::mathfunc::max ::tcl::mathfunc::min clock} $hidden_cmds] test interp-24.1 {result resetting on error} -setup { catch {interp delete a} } -body { interp create a @@ -2056,12 +2056,12 @@ # Interps result transmission # test interp-26.1 {result code transmission : interp eval direct} { # Test that all the possibles error codes from Tcl get passed up - # from the slave interp's context to the master, even though the - # slave nominally thinks the command is running at the root level. + # from the child interp's context to the parent, even though the + # child nominally thinks the command is running at the root level. catch {interp delete a} interp create a set res {} # use a for so if a return -code break 'escapes' we would notice for {set code -1} {$code<=5} {incr code} { @@ -2083,11 +2083,11 @@ interp delete a set res } {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5} test interp-26.3 {result code transmission : aliases} { # Test that all the possibles error codes from Tcl get passed up from the - # slave interp's context to the master, even though the slave nominally + # child interp's context to the parent, even though the child nominally # thinks the command is running at the root level. catch {interp delete a} interp create a set res {} proc MyTestAlias {code} { @@ -2178,11 +2178,11 @@ test interp-26.8 {errorInfo transmission: safe interps--bug 1637} -setup { set interp [interp create -safe] } -constraints knownBug -body { # this test fails because the errorInfo is fully transmitted whether the # interp is safe or not. The errorInfo should never report data from the - # master interpreter because it could contain sensitive information. + # parent interpreter because it could contain sensitive information. proc MyError {secret} { return -code error "msg" } proc MyTestAlias {interp args} { MyError "some secret" @@ -2273,66 +2273,66 @@ interp delete $i } -result {{bar called (::foo) (test1)} {1 {invalid command name "bar"}}} test interp-27.6 {interp hidden & aliases & namespaces} -setup { set i [interp create] } -constraints knownBug -body { - set v root-master + set v root-parent namespace eval foo { - variable v foo-master + variable v foo-parent proc bar {interp args} { variable v - list "master bar called ($v) ([namespace current]) ($args)"\ + list "parent bar called ($v) ([namespace current]) ($args)"\ [interp invokehidden $interp foo::bar $args] } } interp eval $i { namespace eval foo { namespace export * - variable v foo-slave + variable v foo-child proc bar {args} { variable v - return "slave bar called ($v) ([namespace current]) ($args)" + return "child bar called ($v) ([namespace current]) ($args)" } } } set res [list [interp eval $i {namespace eval foo {bar test1}}]] $i hide foo::bar $i alias foo::bar foo::bar $i set res [concat $res [interp eval $i { - set v root-slave + set v root-child namespace eval test { variable v foo-test namespace import ::foo::* bar test2 } }]] } -cleanup { namespace delete foo interp delete $i -} -result {{slave bar called (foo-slave) (::foo) (test1)} {master bar called (foo-master) (::foo) (test2)} {slave bar called (foo-slave) (::foo) (test2)}} +} -result {{child bar called (foo-child) (::foo) (test1)} {parent bar called (foo-parent) (::foo) (test2)} {child bar called (foo-child) (::foo) (test2)}} test interp-27.7 {interp hidden & aliases & imports & namespaces} -setup { set i [interp create] } -constraints knownBug -body { - set v root-master + set v root-parent namespace eval mfoo { - variable v foo-master + variable v foo-parent proc bar {interp args} { variable v - list "master bar called ($v) ([namespace current]) ($args)"\ + list "parent bar called ($v) ([namespace current]) ($args)"\ [interp invokehidden $interp test::bar $args] } } interp eval $i { namespace eval foo { namespace export * - variable v foo-slave + variable v foo-child proc bar {args} { variable v - return "slave bar called ($v) ([info level 0]) ([uplevel namespace current]) ([namespace current]) ($args)" + return "child bar called ($v) ([info level 0]) ([uplevel namespace current]) ([namespace current]) ($args)" } } - set v root-slave + set v root-child namespace eval test { variable v foo-test namespace import ::foo::* } } @@ -2341,11 +2341,11 @@ $i alias test::bar mfoo::bar $i set res [concat $res [interp eval $i {test::bar test2}]] } -cleanup { namespace delete mfoo interp delete $i -} -result {{slave bar called (foo-slave) (bar test1) (::tcltest) (::foo) (test1)} {master bar called (foo-master) (::mfoo) (test2)} {slave bar called (foo-slave) (test::bar test2) (::) (::foo) (test2)}} +} -result {{child bar called (foo-child) (bar test1) (::tcltest) (::foo) (test1)} {parent bar called (foo-parent) (::mfoo) (test2)} {child bar called (foo-child) (test::bar test2) (::) (::foo) (test2)}} test interp-27.8 {hiding, namespaces and integrity} knownBug { namespace eval foo { variable v 3 proc bar {} {variable v; set v} # next command would currently generate an unknown command "bar" error. @@ -2353,29 +2353,29 @@ } namespace delete foo list [catch {interp invokehidden {} foo::bar} msg] $msg } {1 {invalid hidden command name "foo"}} -test interp-28.1 {getting fooled by slave's namespace ?} -setup { +test interp-28.1 {getting fooled by child's namespace ?} -setup { set i [interp create -safe] - proc master {interp args} {interp hide $interp list} + proc parent {interp args} {interp hide $interp list} } -body { - $i alias master master $i + $i alias parent parent $i set r [interp eval $i { namespace eval foo { proc list {args} { return "dummy foo::list" } - master + parent } info commands list }] } -cleanup { - rename master {} + rename parent {} interp delete $i } -result {} -test interp-28.2 {master's nsName cache should not cross} -setup { +test interp-28.2 {parent's nsName cache should not cross} -setup { set i [interp create] $i eval {proc filter lst {lsearch -all -inline -not $lst "::tcl"}} } -body { $i eval { set x {namespace children ::} @@ -2430,35 +2430,35 @@ interp create moo set result [catch {interp recursionlimit moo [expr {wide(1)<<32}]} msg] interp delete moo list $result [string range $msg 0 35] } {1 {integer value too large to represent}} -test interp-29.1.8 {slave recursionlimit argument checking} { +test interp-29.1.8 {child recursionlimit argument checking} { interp create moo set result [catch {moo recursionlimit foo bar} msg] interp delete moo list $result $msg } {1 {wrong # args: should be "moo recursionlimit ?newlimit?"}} -test interp-29.1.9 {slave recursionlimit argument checking} { +test interp-29.1.9 {child recursionlimit argument checking} { interp create moo set result [catch {moo recursionlimit foo} msg] interp delete moo list $result $msg } {1 {expected integer but got "foo"}} -test interp-29.1.10 {slave recursionlimit argument checking} { +test interp-29.1.10 {child recursionlimit argument checking} { interp create moo set result [catch {moo recursionlimit 0} msg] interp delete moo list $result $msg } {1 {recursion limit must be > 0}} -test interp-29.1.11 {slave recursionlimit argument checking} { +test interp-29.1.11 {child recursionlimit argument checking} { interp create moo set result [catch {moo recursionlimit -1} msg] interp delete moo list $result $msg } {1 {recursion limit must be > 0}} -test interp-29.1.12 {slave recursionlimit argument checking} { +test interp-29.1.12 {child recursionlimit argument checking} { interp create moo set result [catch {moo recursionlimit [expr {wide(1)<<32}]} msg] interp delete moo list $result [string range $msg 0 35] } {1 {integer value too large to represent}} @@ -2547,12 +2547,12 @@ }] interp delete $i set r } {1 {too many nested evaluations (infinite loop?)} 49} test interp-29.3.4 {recursion limit error reporting} { - interp create slave - set r1 [slave eval { + interp create child + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 eval { # 4 eval { # 5 @@ -2562,17 +2562,17 @@ } } } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {1 {falling back due to new recursion limit}} test interp-29.3.5 {recursion limit error reporting} { - interp create slave - set r1 [slave eval { + interp create child + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 eval { # 4 eval { # 5 @@ -2582,17 +2582,17 @@ } } } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {1 {falling back due to new recursion limit}} test interp-29.3.6 {recursion limit error reporting} { - interp create slave - set r1 [slave eval { + interp create child + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 eval { # 4 eval { # 5 @@ -2602,22 +2602,128 @@ } } } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} # # Note that TEBC does not verify the interp's nesting level itself; the nesting # level will only be verified when it invokes a non-bcc'd command. # test interp-29.3.7a {recursion limit error reporting} { - interp create slave - after 0 {interp recursionlimit slave 5} - set r1 [slave eval { + interp create child + after 0 {interp recursionlimit child 5} + set r1 [child eval { + catch { # nesting level 1 + eval { # 2 + eval { # 3 + eval { # 4 + eval { # 5 + update + set x ok + } + } + } + } + } msg + }] + set r2 [child eval { set msg }] + interp delete child + list $r1 $r2 +} {0 ok} +test interp-29.3.7b {recursion limit error reporting} { + interp create child + after 0 {interp recursionlimit child 5} + set r1 [child eval { + catch { # nesting level 1 + eval { # 2 + eval { # 3 + eval { # 4 + update + eval { # 5 + set x ok + } + } + } + } + } msg + }] + set r2 [child eval { set msg }] + interp delete child + list $r1 $r2 +} {0 ok} +test interp-29.3.7c {recursion limit error reporting} { + interp create child + after 0 {interp recursionlimit child 5} + set r1 [child eval { + catch { # nesting level 1 + eval { # 2 + eval { # 3 + eval { # 4 + eval { # 5 + update + set set set + $set x ok + } + } + } + } + } msg + }] + set r2 [child eval { set msg }] + interp delete child + list $r1 $r2 +} {1 {too many nested evaluations (infinite loop?)}} +test interp-29.3.8a {recursion limit error reporting} { + interp create child + after 0 {interp recursionlimit child 4} + set r1 [child eval { + catch { # nesting level 1 + eval { # 2 + eval { # 3 + eval { # 4 + eval { # 5 + update + set x ok + } + } + } + } + } msg + }] + set r2 [child eval { set msg }] + interp delete child + list $r1 $r2 +} {0 ok} +test interp-29.3.8b {recursion limit error reporting} { + interp create child + after 0 {interp recursionlimit child 4} + set r1 [child eval { + catch { # nesting level 1 + eval { # 2 + eval { # 3 + eval { # 4 + update + eval { # 5 + set x ok + } + } + } + } + } msg + }] + set r2 [child eval { set msg }] + interp delete child + list $r1 $r2 +} {1 {too many nested evaluations (infinite loop?)}} +test interp-29.3.9a {recursion limit error reporting} { + interp create child + after 0 {interp recursionlimit child 6} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 eval { # 4 eval { # 5 @@ -2627,18 +2733,60 @@ } } } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child + list $r1 $r2 +} {0 ok} +test interp-29.3.9b {recursion limit error reporting} { + interp create child + after 0 {interp recursionlimit child 6} + set r1 [child eval { + catch { # nesting level 1 + eval { # 2 + eval { # 3 + eval { # 4 + eval { # 5 + set set set + $set x ok + } + } + } + } + } msg + }] + set r2 [child eval { set msg }] + interp delete child + list $r1 $r2 +} {0 ok} +test interp-29.3.10a {recursion limit error reporting} { + interp create child + after 0 {child recursionlimit 4} + set r1 [child eval { + catch { # nesting level 1 + eval { # 2 + eval { # 3 + eval { # 4 + eval { # 5 + update + set x ok + } + } + } + } + } msg + }] + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} -test interp-29.3.7b {recursion limit error reporting} { - interp create slave - after 0 {interp recursionlimit slave 5} - set r1 [slave eval { +test interp-29.3.10b {recursion limit error reporting} { + interp create child + after 0 {child recursionlimit 4} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 eval { # 4 update @@ -2648,18 +2796,39 @@ } } } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child + list $r1 $r2 +} {1 {too many nested evaluations (infinite loop?)}} +test interp-29.3.11a {recursion limit error reporting} { + interp create child + after 0 {child recursionlimit 5} + set r1 [child eval { + catch { # nesting level 1 + eval { # 2 + eval { # 3 + eval { # 4 + eval { # 5 + update + set x ok + } + } + } + } + } msg + }] + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} -test interp-29.3.7c {recursion limit error reporting} { - interp create slave - after 0 {interp recursionlimit slave 5} - set r1 [slave eval { +test interp-29.3.11b {recursion limit error reporting} { + interp create child + after 0 {child recursionlimit 5} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 eval { # 4 eval { # 5 @@ -2670,18 +2839,18 @@ } } } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {1 {too many nested evaluations (infinite loop?)}} -test interp-29.3.8a {recursion limit error reporting} { - interp create slave - after 0 {interp recursionlimit slave 4} - set r1 [slave eval { +test interp-29.3.12a {recursion limit error reporting} { + interp create child + after 0 {child recursionlimit 6} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 eval { # 4 eval { # 5 @@ -2691,144 +2860,18 @@ } } } } msg }] - set r2 [slave eval { set msg }] - interp delete slave - list $r1 $r2 -} {0 ok} -test interp-29.3.8b {recursion limit error reporting} { - interp create slave - after 0 {interp recursionlimit slave 4} - set r1 [slave eval { - catch { # nesting level 1 - eval { # 2 - eval { # 3 - eval { # 4 - update - eval { # 5 - set x ok - } - } - } - } - } msg - }] - set r2 [slave eval { set msg }] - interp delete slave - list $r1 $r2 -} {1 {too many nested evaluations (infinite loop?)}} -test interp-29.3.9a {recursion limit error reporting} { - interp create slave - after 0 {interp recursionlimit slave 6} - set r1 [slave eval { - catch { # nesting level 1 - eval { # 2 - eval { # 3 - eval { # 4 - eval { # 5 - update - set x ok - } - } - } - } - } msg - }] - set r2 [slave eval { set msg }] - interp delete slave - list $r1 $r2 -} {0 ok} -test interp-29.3.9b {recursion limit error reporting} { - interp create slave - after 0 {interp recursionlimit slave 6} - set r1 [slave eval { - catch { # nesting level 1 - eval { # 2 - eval { # 3 - eval { # 4 - eval { # 5 - set set set - $set x ok - } - } - } - } - } msg - }] - set r2 [slave eval { set msg }] - interp delete slave - list $r1 $r2 -} {0 ok} -test interp-29.3.10a {recursion limit error reporting} { - interp create slave - after 0 {slave recursionlimit 4} - set r1 [slave eval { - catch { # nesting level 1 - eval { # 2 - eval { # 3 - eval { # 4 - eval { # 5 - update - set x ok - } - } - } - } - } msg - }] - set r2 [slave eval { set msg }] - interp delete slave - list $r1 $r2 -} {0 ok} -test interp-29.3.10b {recursion limit error reporting} { - interp create slave - after 0 {slave recursionlimit 4} - set r1 [slave eval { - catch { # nesting level 1 - eval { # 2 - eval { # 3 - eval { # 4 - update - eval { # 5 - set x ok - } - } - } - } - } msg - }] - set r2 [slave eval { set msg }] - interp delete slave - list $r1 $r2 -} {1 {too many nested evaluations (infinite loop?)}} -test interp-29.3.11a {recursion limit error reporting} { - interp create slave - after 0 {slave recursionlimit 5} - set r1 [slave eval { - catch { # nesting level 1 - eval { # 2 - eval { # 3 - eval { # 4 - eval { # 5 - update - set x ok - } - } - } - } - } msg - }] - set r2 [slave eval { set msg }] - interp delete slave - list $r1 $r2 -} {0 ok} -test interp-29.3.11b {recursion limit error reporting} { - interp create slave - after 0 {slave recursionlimit 5} - set r1 [slave eval { + set r2 [child eval { set msg }] + interp delete child + list $r1 $r2 +} {0 ok} +test interp-29.3.12b {recursion limit error reporting} { + interp create child + after 0 {child recursionlimit 6} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 eval { # 4 eval { # 5 @@ -2839,55 +2882,12 @@ } } } } msg }] - set r2 [slave eval { set msg }] - interp delete slave - list $r1 $r2 -} {1 {too many nested evaluations (infinite loop?)}} -test interp-29.3.12a {recursion limit error reporting} { - interp create slave - after 0 {slave recursionlimit 6} - set r1 [slave eval { - catch { # nesting level 1 - eval { # 2 - eval { # 3 - eval { # 4 - eval { # 5 - update - set x ok - } - } - } - } - } msg - }] - set r2 [slave eval { set msg }] - interp delete slave - list $r1 $r2 -} {0 ok} -test interp-29.3.12b {recursion limit error reporting} { - interp create slave - after 0 {slave recursionlimit 6} - set r1 [slave eval { - catch { # nesting level 1 - eval { # 2 - eval { # 3 - eval { # 4 - eval { # 5 - update - set set set - $set x ok - } - } - } - } - } msg - }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} test interp-29.4.1 {recursion limit inheritance} { set i [interp create] set ii [interp eval $i { @@ -2914,125 +2914,125 @@ set i }] interp delete $i set r } 50 -test interp-29.5.1 {does slave recursion limit affect master?} { - set before [interp recursionlimit {}] - set i [interp create] - interp recursionlimit $i 20000 - set after [interp recursionlimit {}] - set slavelimit [interp recursionlimit $i] - interp delete $i - list [expr {$before == $after}] $slavelimit -} {1 20000} -test interp-29.5.2 {does slave recursion limit affect master?} { - set before [interp recursionlimit {}] - set i [interp create] - interp recursionlimit $i 20000 - set after [interp recursionlimit {}] - set slavelimit [$i recursionlimit] - interp delete $i - list [expr {$before == $after}] $slavelimit -} {1 20000} -test interp-29.5.3 {does slave recursion limit affect master?} { - set before [interp recursionlimit {}] - set i [interp create] - $i recursionlimit 20000 - set after [interp recursionlimit {}] - set slavelimit [interp recursionlimit $i] - interp delete $i - list [expr {$before == $after}] $slavelimit -} {1 20000} -test interp-29.5.4 {does slave recursion limit affect master?} { - set before [interp recursionlimit {}] - set i [interp create] - $i recursionlimit 20000 - set after [interp recursionlimit {}] - set slavelimit [$i recursionlimit] - interp delete $i - list [expr {$before == $after}] $slavelimit -} {1 20000} -test interp-29.6.1 {safe interpreter recursion limit} { - interp create slave -safe - set n [interp recursionlimit slave] - interp delete slave - set n -} 1000 -test interp-29.6.2 {safe interpreter recursion limit} { - interp create slave -safe - set n [slave recursionlimit] - interp delete slave - set n -} 1000 -test interp-29.6.3 {safe interpreter recursion limit} { - interp create slave -safe - set n1 [interp recursionlimit slave 42] - set n2 [interp recursionlimit slave] - interp delete slave - list $n1 $n2 -} {42 42} -test interp-29.6.4 {safe interpreter recursion limit} { - interp create slave -safe - set n1 [slave recursionlimit 42] - set n2 [interp recursionlimit slave] - interp delete slave - list $n1 $n2 -} {42 42} -test interp-29.6.5 {safe interpreter recursion limit} { - interp create slave -safe - set n1 [interp recursionlimit slave 42] - set n2 [slave recursionlimit] - interp delete slave - list $n1 $n2 -} {42 42} -test interp-29.6.6 {safe interpreter recursion limit} { - interp create slave -safe - set n1 [slave recursionlimit 42] - set n2 [slave recursionlimit] - interp delete slave - list $n1 $n2 -} {42 42} -test interp-29.6.7 {safe interpreter recursion limit} { - interp create slave -safe - set n1 [slave recursionlimit 42] - set n2 [slave recursionlimit] - interp delete slave - list $n1 $n2 -} {42 42} -test interp-29.6.8 {safe interpreter recursion limit} { - interp create slave -safe - set n [catch {slave eval {interp recursionlimit {} 42}} msg] - interp delete slave - list $n $msg -} {1 {permission denied: safe interpreters cannot change recursion limit}} -test interp-29.6.9 {safe interpreter recursion limit} { - interp create slave -safe - set result [ - slave eval { - interp create slave2 -safe - set n [catch { - interp recursionlimit slave2 42 - } msg] - list $n $msg - } - ] - interp delete slave - set result -} {1 {permission denied: safe interpreters cannot change recursion limit}} -test interp-29.6.10 {safe interpreter recursion limit} { - interp create slave -safe - set result [ - slave eval { - interp create slave2 -safe - set n [catch { - slave2 recursionlimit 42 - } msg] - list $n $msg - } - ] - interp delete slave +test interp-29.5.1 {does child recursion limit affect parent?} { + set before [interp recursionlimit {}] + set i [interp create] + interp recursionlimit $i 20000 + set after [interp recursionlimit {}] + set childlimit [interp recursionlimit $i] + interp delete $i + list [expr {$before == $after}] $childlimit +} {1 20000} +test interp-29.5.2 {does child recursion limit affect parent?} { + set before [interp recursionlimit {}] + set i [interp create] + interp recursionlimit $i 20000 + set after [interp recursionlimit {}] + set childlimit [$i recursionlimit] + interp delete $i + list [expr {$before == $after}] $childlimit +} {1 20000} +test interp-29.5.3 {does child recursion limit affect parent?} { + set before [interp recursionlimit {}] + set i [interp create] + $i recursionlimit 20000 + set after [interp recursionlimit {}] + set childlimit [interp recursionlimit $i] + interp delete $i + list [expr {$before == $after}] $childlimit +} {1 20000} +test interp-29.5.4 {does child recursion limit affect parent?} { + set before [interp recursionlimit {}] + set i [interp create] + $i recursionlimit 20000 + set after [interp recursionlimit {}] + set childlimit [$i recursionlimit] + interp delete $i + list [expr {$before == $after}] $childlimit +} {1 20000} +test interp-29.6.1 {safe interpreter recursion limit} { + interp create child -safe + set n [interp recursionlimit child] + interp delete child + set n +} 1000 +test interp-29.6.2 {safe interpreter recursion limit} { + interp create child -safe + set n [child recursionlimit] + interp delete child + set n +} 1000 +test interp-29.6.3 {safe interpreter recursion limit} { + interp create child -safe + set n1 [interp recursionlimit child 42] + set n2 [interp recursionlimit child] + interp delete child + list $n1 $n2 +} {42 42} +test interp-29.6.4 {safe interpreter recursion limit} { + interp create child -safe + set n1 [child recursionlimit 42] + set n2 [interp recursionlimit child] + interp delete child + list $n1 $n2 +} {42 42} +test interp-29.6.5 {safe interpreter recursion limit} { + interp create child -safe + set n1 [interp recursionlimit child 42] + set n2 [child recursionlimit] + interp delete child + list $n1 $n2 +} {42 42} +test interp-29.6.6 {safe interpreter recursion limit} { + interp create child -safe + set n1 [child recursionlimit 42] + set n2 [child recursionlimit] + interp delete child + list $n1 $n2 +} {42 42} +test interp-29.6.7 {safe interpreter recursion limit} { + interp create child -safe + set n1 [child recursionlimit 42] + set n2 [child recursionlimit] + interp delete child + list $n1 $n2 +} {42 42} +test interp-29.6.8 {safe interpreter recursion limit} { + interp create child -safe + set n [catch {child eval {interp recursionlimit {} 42}} msg] + interp delete child + list $n $msg +} {1 {permission denied: safe interpreters cannot change recursion limit}} +test interp-29.6.9 {safe interpreter recursion limit} { + interp create child -safe + set result [ + child eval { + interp create child2 -safe + set n [catch { + interp recursionlimit child2 42 + } msg] + list $n $msg + } + ] + interp delete child + set result +} {1 {permission denied: safe interpreters cannot change recursion limit}} +test interp-29.6.10 {safe interpreter recursion limit} { + interp create child -safe + set result [ + child eval { + interp create child2 -safe + set n [catch { + child2 recursionlimit 42 + } msg] + list $n $msg + } + ] + interp delete child set result } {1 {permission denied: safe interpreters cannot change recursion limit}} # # Deep recursion (into interps when the regular one fails): @@ -3169,11 +3169,11 @@ # No bytecode at all here... } } } # We use a time limit here; command limits don't trap this case - $i limit time -seconds [expr {[clock seconds]+2}] + $i limit time -seconds [expr {[clock seconds] + 2}] $i eval foobar } -returnCodes error -result {time limit exceeded} -cleanup { interp delete $i } test interp-34.4 {limits with callbacks: extending limits} -setup { @@ -3191,12 +3191,12 @@ $i limit command -value $newlimit } } -body { interp alias $i foo {} cb1 set curlim [$i eval info cmdcount] - $i limit command -command "cb2 [expr $curlim+100]" \ - -value [expr {$curlim+10}] + $i limit command -command "cb2 [expr {$curlim + 100}]" \ + -value [expr {$curlim + 10}] $i eval {for {set i 0} {$i<10} {incr i} {foo}} list $a $b $c } -result {6 4 b} -cleanup { interp delete $i rename cb1 {} @@ -3220,11 +3220,11 @@ $i limit command -value $newlimit } } -body { interp alias $i foo {} cb1 set curlim [$i eval info cmdcount] - $i limit command -command "cb2 {}" -value [expr {$curlim+10}] + $i limit command -command "cb2 {}" -value [expr {$curlim + 10}] $i eval {for {set i 0} {$i<10} {incr i} {foo}} list $a $b $c } -result {6 4 b} -cleanup { interp delete $i rename cb1 {} @@ -3245,11 +3245,11 @@ $i limit command -value {} -command {} } } -body { interp alias $i foo {} cb1 set curlim [$i eval info cmdcount] - $i limit command -command cb2 -value [expr {$curlim+10}] + $i limit command -command cb2 -value [expr {$curlim + 10}] $i eval {for {set i 0} {$i<10} {incr i} {foo}} list $a $b $c } -result {6 4 b} -cleanup { interp delete $i rename cb1 {} @@ -3264,11 +3264,11 @@ incr ::$c } proc cb2 {args} { global c i curlim set c b - $i limit command -value [expr {$curlim+1000}] + $i limit command -value [expr {$curlim + 1000}] trapToParent } } proc cb3 {} { global i subi @@ -3287,11 +3287,11 @@ set a 0 set b 0 set c a interp alias $i foo {} cb1 set curlim [$i eval info cmdcount] - $i limit command -command cb2 -value [expr {$curlim+10}] + $i limit command -command cb2 -value [expr {$curlim + 10}] } $i eval { $i eval { for {set i 0} {$i<10} {incr i} {foo} } @@ -3302,11 +3302,11 @@ rename cb4 {} } # Bug 1085023 test interp-34.8 {time limits trigger in vwaits} -body { set i [interp create] - interp limit $i time -seconds [expr {[clock seconds]+1}] -granularity 1 + interp limit $i time -seconds [expr {[clock seconds] + 1}] -granularity 1 $i eval { set x {} vwait x } } -cleanup { @@ -3350,12 +3350,12 @@ lappend result cb2 } } -body { set i [interp create] set t0 [clock seconds] - $i limit time -seconds [expr {$t0+1}] -granularity 1 \ - -command "cb1 $i [expr {$t0+2}]" + $i limit time -seconds [expr {$t0 + 1}] -granularity 1 \ + -command "cb1 $i [expr {$t0 + 2}]" set ::result {} lappend ::result [catch { $i eval { for {set i 0} {$i<30} {incr i} { after 100 @@ -3378,12 +3378,12 @@ $i limit time -seconds $t } } -body { set i [interp create] set t0 [clock seconds] - set ::times "[expr {$t0+2}] [expr {$t0+100}]" - $i limit time -seconds [expr {$t0+1}] -granularity 1 -command "cb1 $i" + set ::times "[expr {$t0 + 2}] [expr {$t0 + 100}]" + $i limit time -seconds [expr {$t0 + 1}] -granularity 1 -command "cb1 $i" set ::result {} lappend ::result [catch { $i eval { for {set i 0} {$i<30} {incr i} { after 100 @@ -3557,68 +3557,68 @@ } -returnCodes error -result {wrong # args: should be "interp bgerror path ?cmdPrefix?"} test interp-36.2 {interp bgerror syntax} -body { interp bgerror x y z } -returnCodes error -result {wrong # args: should be "interp bgerror path ?cmdPrefix?"} test interp-36.3 {interp bgerror syntax} -setup { - interp create slave -} -body { - slave bgerror x y -} -cleanup { - interp delete slave -} -returnCodes error -result {wrong # args: should be "slave bgerror ?cmdPrefix?"} -test interp-36.4 {SlaveBgerror syntax} -setup { - interp create slave -} -body { - slave bgerror \{ -} -cleanup { - interp delete slave -} -returnCodes error -result {cmdPrefix must be list of length >= 1} -test interp-36.5 {SlaveBgerror syntax} -setup { - interp create slave -} -body { - slave bgerror {} -} -cleanup { - interp delete slave -} -returnCodes error -result {cmdPrefix must be list of length >= 1} -test interp-36.6 {SlaveBgerror returns handler} -setup { - interp create slave -} -body { - slave bgerror {foo bar soom} -} -cleanup { - interp delete slave -} -result {foo bar soom} -test interp-36.7 {SlaveBgerror sets error handler of slave [1999035]} -setup { - interp create slave - slave alias handler handler - slave bgerror handler + interp create child +} -body { + child bgerror x y +} -cleanup { + interp delete child +} -returnCodes error -result {wrong # args: should be "child bgerror ?cmdPrefix?"} +test interp-36.4 {ChildBgerror syntax} -setup { + interp create child +} -body { + child bgerror \{ +} -cleanup { + interp delete child +} -returnCodes error -result {cmdPrefix must be list of length >= 1} +test interp-36.5 {ChildBgerror syntax} -setup { + interp create child +} -body { + child bgerror {} +} -cleanup { + interp delete child +} -returnCodes error -result {cmdPrefix must be list of length >= 1} +test interp-36.6 {ChildBgerror returns handler} -setup { + interp create child +} -body { + child bgerror {foo bar soom} +} -cleanup { + interp delete child +} -result {foo bar soom} +test interp-36.7 {ChildBgerror sets error handler of child [1999035]} -setup { + interp create child + child alias handler handler + child bgerror handler variable result {untouched} proc handler {args} { variable result set result [lindex $args 0] } } -body { - slave eval { + child eval { variable done {} after 0 error foo after 10 [list ::set [namespace which -variable done] {}] vwait [namespace which -variable done] } set result } -cleanup { variable result {} unset -nocomplain result - interp delete slave + interp delete child } -result foo test interp-37.1 {safe interps and min() and max(): Bug 2895741} -setup { catch {interp delete a} interp create a set result {} } -body { interp create {a b} -safe - lappend result [interp eval a {expr min(5,2,3)*max(7,13,11)}] - lappend result [interp eval {a b} {expr min(5,2,3)*max(7,13,11)}] + lappend result [interp eval a {expr {min(5,2,3)*max(7,13,11)}}] + lappend result [interp eval {a b} {expr {min(5,2,3)*max(7,13,11)}}] } -cleanup { unset -nocomplain result interp delete a } -result {26 26} @@ -3665,15 +3665,15 @@ error } -result {wrong # args: should be "interp debug path ?-frame ?bool??"} # cleanup unset -nocomplain hidden_cmds -foreach i [interp slaves] { +foreach i [interp children] { interp delete $i } ::tcltest::cleanupTests return # Local Variables: # mode: tcl # fill-column: 78 # End: Index: tests/io.test ================================================================== --- tests/io.test +++ tests/io.test @@ -11,16 +11,16 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 -} - namespace eval ::tcl::test::io { - namespace import ::tcltest::* + + if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* + } variable umaskValue variable path variable f variable i @@ -36,15 +36,20 @@ } package require tcltests testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testchannel [llength [info commands testchannel]] -testConstraint openpipe 1 testConstraint testfevent [llength [info commands testfevent]] testConstraint testchannelevent [llength [info commands testchannelevent]] testConstraint testmainthread [llength [info commands testmainthread]] testConstraint testobj [llength [info commands testobj]] +testConstraint testservicemode [llength [info commands testservicemode]] +# Some things fail under Windows in Continuous Integration systems for subtle +# reasons such as CI often running with elevated privileges in a container. +testConstraint notWinCI [expr { + $::tcl_platform(platform) ne "windows" || ![info exists ::env(CI)]}] +testConstraint notOSX [expr {$::tcl_platform(os) ne "Darwin"}] # You need a *very* special environment to do some tests. In # particular, many file systems do not support large-files... testConstraint largefileSupport [expr {$::tcl_platform(os) ne "Darwin"}] @@ -478,11 +483,11 @@ set f [open $path(test1)] set x [list [gets $f line] $line] close $f set x } [list 256 $a] -test io-6.7 {Tcl_GetsObj: error in input} {stdio openpipe} { +test io-6.7 {Tcl_GetsObj: error in input} stdio { # if (FilterInputBytes(chanPtr, &gs) != 0) set f [open "|[list [interpreter] $path(cat)]" w+] puts -nonewline $f "hi\nwould" flush $f @@ -738,11 +743,11 @@ fconfigure $f -translation crlf -buffersize 16 set x [list [gets $f line] $line [testchannel inputbuffered $f]] close $f set x } [list 15 "123456789012345" 15] -test io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} {stdio testchannel openpipe fileevent} { +test io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} {stdio testchannel fileevent} { # (FilterInputBytes() != 0) set f [open "|[list [interpreter] $path(cat)]" w+] fconfigure $f -translation {crlf lf} -buffering none puts -nonewline $f "bbbbbbbbbbbbbb\r\n123456789012345\r" @@ -877,11 +882,11 @@ set x [list [gets $f line] $line [gets $f line] $line] lappend x [gets $f line] $line [gets $f line] $line [gets $f line] $line close $f set x } [list 4 "abcd" 4 "efgh" 4 "ijkl" 4 "mnop" -1 ""] -test io-6.43 {Tcl_GetsObj: input saw cr} {stdio testchannel openpipe fileevent} { +test io-6.43 {Tcl_GetsObj: input saw cr} {stdio testchannel fileevent} { # if (chanPtr->flags & INPUT_SAW_CR) set f [open "|[list [interpreter] $path(cat)]" w+] fconfigure $f -translation {auto lf} -buffering none puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" @@ -894,11 +899,11 @@ lappend x [gets $f line] $line [testchannel queuedcr $f] lappend x [gets $f line] $line close $f set x } [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"] -test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio testchannel openpipe fileevent} { +test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio testchannel fileevent} { # not (*eol == '\n') set f [open "|[list [interpreter] $path(cat)]" w+] fconfigure $f -translation {auto lf} -buffering none puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" @@ -911,11 +916,11 @@ lappend x [gets $f line] $line [testchannel queuedcr $f] lappend x [gets $f line] $line close $f set x } [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"] -test io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio testchannel openpipe fileevent} { +test io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio testchannel fileevent} { # Tcl_ExternalToUtf() set f [open "|[list [interpreter] $path(cat)]" w+] fconfigure $f -translation {auto lf} -buffering none fconfigure $f -encoding unicode @@ -928,11 +933,11 @@ puts -nonewline $f "\nabcd\refg" lappend x [gets $f line] $line [testchannel queuedcr $f] close $f set x } [list 15 "123456789abcdef" 1 4 "abcd" 0] -test io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} {stdio testchannel openpipe fileevent} { +test io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} {stdio testchannel fileevent} { # memmove() set f [open "|[list [interpreter] $path(cat)]" w+] fconfigure $f -translation {auto lf} -buffering none puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" @@ -1053,11 +1058,11 @@ fconfigure $f -encoding iso2022-jp set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line] close $f set x } [list 8 "there\u4e00ok" 11 "\u4e01more bytes" 4 "here"] -test io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} {stdio openpipe fileevent} { +test io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} {stdio fileevent} { update set f [open "|[list [interpreter] $path(cat)]" w+] fconfigure $f -buffering none puts -nonewline $f "foobar" fconfigure $f -blocking 0 @@ -1113,11 +1118,11 @@ lappend x [tell $f] [testchannel inputbuffered $f] [eof $f] lappend x [gets $f line] $line close $f set x } [list 15 "1234567890123\uff10\uff11" 18 0 1 -1 ""] -test io-7.4 {FilterInputBytes: recover from split up character} {stdio openpipe fileevent} { +test io-7.4 {FilterInputBytes: recover from split up character} {stdio fileevent} { set f [open "|[list [interpreter] $path(cat)]" w+] fconfigure $f -encoding binary -buffering none puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82" fconfigure $f -encoding shiftjis -blocking 0 fileevent $f read [namespace code "ready $f"] @@ -1148,11 +1153,11 @@ gets $f set x [testchannel inputbuffered $f] close $f set x } "7" -test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio testchannel openpipe fileevent} { +test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio testchannel fileevent} { # not (bufPtr->nextPtr == NULL) set f [open "|[list [interpreter] $path(cat)]" w+] fconfigure $f -translation lf -encoding ascii -buffering none puts -nonewline $f "123456789012345\r\nbcdefghijklmnopqrstuvwxyz" @@ -1168,11 +1173,11 @@ # here vwait [namespace which -variable x] close $f set x } [list -1 "" 42 15 "123456789012345" 25] -test io-8.3 {PeekAhead: no cached data available} {stdio testchannel openpipe fileevent} { +test io-8.3 {PeekAhead: no cached data available} {stdio testchannel fileevent} { # (bytesLeft == 0) set f [open "|[list [interpreter] $path(cat)]" w+] fconfigure $f -translation {auto binary} puts -nonewline $f "abcdefghijklmno\r" @@ -1201,11 +1206,11 @@ set x [gets $f] close $f set x } $a unset a -test io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel openpipe fileevent} { +test io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel fileevent} { # (bufPtr->nextAdded < bufPtr->length) set f [open "|[list [interpreter] $path(cat)]" w+] fconfigure $f -translation {auto binary} puts -nonewline $f "abcdefghijklmno\r" @@ -1213,11 +1218,11 @@ # here set x [list [gets $f line] $line [testchannel queuedcr $f]] close $f set x } {15 abcdefghijklmno 1} -test io-8.6 {PeekAhead: change to non-blocking mode} {stdio testchannel openpipe fileevent} { +test io-8.6 {PeekAhead: change to non-blocking mode} {stdio testchannel fileevent} { # ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0) set f [open "|[list [interpreter] $path(cat)]" w+] fconfigure $f -translation {auto binary} -buffersize 16 puts -nonewline $f "abcdefghijklmno\r" @@ -1225,11 +1230,11 @@ # here set x [list [gets $f line] $line [testchannel queuedcr $f]] close $f set x } {15 abcdefghijklmno 1} -test io-8.7 {PeekAhead: cleanup} {stdio testchannel openpipe fileevent} { +test io-8.7 {PeekAhead: cleanup} {stdio testchannel fileevent} { # Make sure bytes are removed from buffer. set f [open "|[list [interpreter] $path(cat)]" w+] fconfigure $f -translation {auto binary} -buffering none puts -nonewline $f "abcdefghijklmno\r" @@ -1390,11 +1395,11 @@ # here set x [read $f] close $f set x } {abcdefghijklmnopqrstuvwxyz} -test io-12.4 {ReadChars: split-up char} {stdio testchannel openpipe fileevent} { +test io-12.4 {ReadChars: split-up char} {stdio testchannel fileevent} { # (srcRead == 0) set f [open "|[list [interpreter] $path(cat)]" w+] fconfigure $f -encoding binary -buffering none -buffersize 16 puts -nonewline $f "123456789012345\x96" @@ -1415,11 +1420,11 @@ fconfigure $f -encoding shiftjis -blocking 0 vwait [namespace which -variable x] close $f set x } [list "123456789012345" 1 "\u672c" 0] -test io-12.5 {ReadChars: fileevents on partial characters} {stdio openpipe fileevent} { +test io-12.5 {ReadChars: fileevents on partial characters} {stdio fileevent} { set path(test1) [makeFile { fconfigure stdout -encoding binary -buffering none gets stdin; puts -nonewline "\xe7" gets stdin; puts -nonewline "\x89" gets stdin; puts -nonewline "\xa6" @@ -1609,11 +1614,11 @@ fconfigure $f -translation crlf set x [read $f] close $f set x } "abcd\ndef\nfgh" -test io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio testchannel openpipe fileevent} { +test io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio testchannel fileevent} { # (chanPtr->flags & INPUT_SAW_CR) # This test may fail on slower machines. set f [open "|[list [interpreter] $path(cat)]" w+] fconfigure $f -blocking 0 -buffering none -translation {auto lf} @@ -1635,11 +1640,11 @@ vwait [namespace which -variable y] close $f set x } [list "abcdefghj\n" 1 "01234" 0] -test io-13.7 {TranslateInputEOL: auto mode: naked \r} {testchannel openpipe} { +test io-13.7 {TranslateInputEOL: auto mode: naked \r} testchannel { # (src >= srcMax) set f [open $path(test1) w] fconfigure $f -translation lf puts -nonewline $f "abcd\r" @@ -1780,11 +1785,11 @@ lappend l [x eval {fconfigure stderr -buffering}] interp delete x set l } {line line none} set path(test3) [makeFile {} test3] -test io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec openpipe} { +test io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} exec { set f [open $path(test1) w] puts -nonewline $f { close stdin close stdout close stderr @@ -1870,11 +1875,11 @@ set result [list $msg1 $msg2 $msg3] interp delete z set result } {{} {} {can not find channel named "stderr"}} set path(script) [makeFile {} script] -test io-14.8 {reuse of stdio special channels} {stdio openpipe} { +test io-14.8 {reuse of stdio special channels} stdio { file delete $path(script) file delete $path(test1) set f [open $path(script) w] puts -nonewline $f { close stderr @@ -1892,11 +1897,11 @@ set f [open "|[list [interpreter] $path(script)]" r] set c [gets $f] close $f set c } hello -test io-14.9 {reuse of stdio special channels} {stdio openpipe fileevent} { +test io-14.9 {reuse of stdio special channels} {stdio fileevent} { file delete $path(script) file delete $path(test1) set f [open $path(script) w] puts $f { array set path [lindex $argv 0] @@ -2075,11 +2080,11 @@ set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]] close $f set x } {{{} {}} {auto lf}} set path(stdout) [makeFile {} stdout] -test io-20.5 {Tcl_CreateChannel: install channel in empty slot} {stdio openpipe} { +test io-20.5 {Tcl_CreateChannel: install channel in empty slot} stdio { set f [open $path(script) w] puts -nonewline $f { close stdout set f1 [} puts $f [list open $path(stdout) w]] @@ -2149,11 +2154,11 @@ close $f file delete $path(test1) set l } {6 6 0 6} -test io-26.1 {Tcl_GetChannelInstanceData} {stdio openpipe} { +test io-26.1 {Tcl_GetChannelInstanceData} stdio { # "pid" command uses Tcl_GetChannelInstanceData # Don't care what pid is (but must be a number), just want to exercise it. set f [open "|[list [interpreter] << exit]"] expr [pid $f] @@ -2209,11 +2214,11 @@ lappend l [file size $path(test1)] close $f set l } {0 60 72} test io-27.5 {FlushChannel, implicit flush when buffer fills and on close} \ - {unixOrPc} { + {unixOrWin} { file delete $path(test1) set f [open $path(test1) w] fconfigure $f -translation lf -buffersize 60 -eofchar {} set l "" lappend l [file size $path(test1)] @@ -2226,11 +2231,11 @@ set l } {0 60 72} set path(pipe) [makeFile {} pipe] set path(output) [makeFile {} output] test io-27.6 {FlushChannel, async flushing, async close} \ - {stdio asyncPipeClose openpipe} { + {stdio asyncPipeClose notWinCI} { # This test may fail on old Unix systems (seen on IRIX64 6.5) with # obsolete gettimeofday() calls. See Tcl Bugs 3530533, 1942197. file delete $path(pipe) file delete $path(output) set f [open $path(pipe) w] @@ -2295,11 +2300,11 @@ set l [gets $f] close $f set l } abcdef test io-28.3 {CloseChannel, not called before output queue is empty} \ - {stdio asyncPipeClose nonPortable openpipe} { + {stdio asyncPipeClose nonPortable} { file delete $path(pipe) file delete $path(output) set f [open $path(pipe) w] puts $f { @@ -2352,11 +2357,11 @@ set x [list $consoleFileNames \ [lsort [list {*}$consoleFileNames $f]] \ $consoleFileNames] string compare $l $x } 0 -test io-28.5 {Tcl_Close vs standard handles} {stdio unix testchannel openpipe} { +test io-28.5 {Tcl_Close vs standard handles} {stdio unix testchannel} { file delete $path(script) set f [open $path(script) w] puts $f { close stdin puts [testchannel open] @@ -2491,11 +2496,11 @@ } close $f1 close $f2 file size $path(test1) } 377 -test io-29.12 {Tcl_WriteChars on a pipe} {stdio openpipe} { +test io-29.12 {Tcl_WriteChars on a pipe} stdio { file delete $path(test1) file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 "set f1 \[[list open $path(longfile) r]]" puts $f1 { @@ -2516,11 +2521,11 @@ } close $f1 close $f2 set y } ok -test io-29.13 {Tcl_WriteChars to a pipe, line buffered} {stdio openpipe} { +test io-29.13 {Tcl_WriteChars to a pipe, line buffered} stdio { file delete $path(test1) file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 { puts [gets stdin] @@ -2567,11 +2572,11 @@ set x [list [catch {flush $fd} msg] $msg] close $fd string compare $x \ [list 1 "channel \"$fd\" wasn't opened for writing"] } 0 -test io-29.16 {Tcl_Flush on pipe opened only for reading} {stdio openpipe} { +test io-29.16 {Tcl_Flush on pipe opened only for reading} stdio { set fd [open "|[list [interpreter] cat longfile]" r] set x [list [catch {flush $fd} msg] $msg] catch {close $fd} string compare $x \ [list 1 "channel \"$fd\" wasn't opened for writing"] @@ -2641,11 +2646,11 @@ lappend z [file size $path(test1)] close $f1 lappend z [file size $path(test1)] set z } {4096 12288 12600} -test io-29.21 {Tcl_Flush to pipe} {stdio openpipe} { +test io-29.21 {Tcl_Flush to pipe} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 {set x [read stdin 6]} puts $f1 {set cnt [string length $x]} puts $f1 {puts "read $cnt characters"} @@ -2655,11 +2660,11 @@ flush $f1 set x [gets $f1] catch {close $f1} set x } "read 6 characters" -test io-29.22 {Tcl_Flush called at other end of pipe} {stdio openpipe} { +test io-29.22 {Tcl_Flush called at other end of pipe} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 { fconfigure stdout -buffering full puts hello @@ -2678,11 +2683,11 @@ flush $f1 lappend x [gets $f1] close $f1 set x } {hello hello bye} -test io-29.23 {Tcl_Flush and line buffering at end of pipe} {stdio openpipe} { +test io-29.23 {Tcl_Flush and line buffering at end of pipe} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 { puts hello puts hello @@ -2713,11 +2718,11 @@ lappend x [read -nonewline $f2] close $f2 close $f set x } "{} {Line 1\nLine 2}" -test io-29.25 {Implicit flush with Tcl_Flush to command pipelines} {stdio openpipe fileevent} { +test io-29.25 {Implicit flush with Tcl_Flush to command pipelines} {stdio fileevent} { file delete $path(test3) set f [open "|[list [interpreter] $path(cat) | [interpreter] $path(cat) > $path(test3)]" w] puts $f "Line 1" puts $f "Line 2" close $f @@ -2725,19 +2730,19 @@ set f [open $path(test3) r] set x [read $f] close $f set x } "Line 1\nLine 2\n" -test io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {stdio unixExecs openpipe} { +test io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {stdio unixExecs} { set f [open "|[list cat -u]" r+] puts $f "Line1" flush $f set x [gets $f] close $f set x } {Line1} -test io-29.27 {Tcl_Flush on closed pipeline} {stdio openpipe} { +test io-29.27 {Tcl_Flush on closed pipeline} stdio { file delete $path(pipe) set f [open $path(pipe) w] puts $f {exit} close $f set f [open "|[list [interpreter] $path(pipe)]" r+] @@ -2787,11 +2792,11 @@ fconfigure $f -translation crlf -eofchar {} puts $f hello\nthere\nand\nhere close $f file size $path(test1) } 25 -test io-29.31 {Tcl_WriteChars, background flush} {stdio openpipe} { +test io-29.31 {Tcl_WriteChars, background flush} stdio { # This test may fail on old Unix systems (seen on IRIX64 6.5) with # obsolete gettimeofday() calls. See Tcl Bugs 3530533, 1942197. file delete $path(pipe) file delete $path(output) set f [open $path(pipe) w] @@ -2824,17 +2829,17 @@ set result "file size only [file size $path(output)]" } else { set result ok } # allow a little time for the background process to close. - # otherwise, the following test fails on the [file delete $path(output) + # otherwise, the following test fails on the [file delete $path(output)] # on Windows because a process still has the file open. after 100 set v 1; vwait v set result } ok test io-29.32 {Tcl_WriteChars, background flush to slow reader} \ - {stdio asyncPipeClose openpipe} { + {stdio asyncPipeClose notWinCI} { # This test may fail on old Unix systems (seen on IRIX64 6.5) with # obsolete gettimeofday() calls. See Tcl Bugs 3530533, 1942197. file delete $path(pipe) file delete $path(output) set f [open $path(pipe) w] @@ -4090,11 +4095,11 @@ if {$z != $l} { set x broken } set x } ok -test io-32.10 {Tcl_Read from a pipe} {stdio openpipe} { +test io-32.10 {Tcl_Read from a pipe} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 {puts [gets stdin]} close $f1 set f1 [open "|[list [interpreter] $path(pipe)]" r+] @@ -4102,11 +4107,11 @@ flush $f1 set x [read $f1] close $f1 set x } "hello\n" -test io-32.11 {Tcl_Read from a pipe} {stdio openpipe} { +test io-32.11 {Tcl_Read from a pipe} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 {puts [gets stdin]} puts $f1 {puts [gets stdin]} close $f1 @@ -4121,11 +4126,11 @@ close $f1 set x } {{hello } {hello }} -test io-32.11.1 {Tcl_Read from a pipe} {stdio openpipe} { +test io-32.11.1 {Tcl_Read from a pipe} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 {chan configure stdout -translation crlf} puts $f1 {puts [gets stdin]} puts $f1 {puts [gets stdin]} @@ -4141,11 +4146,11 @@ close $f1 set x } {{hello } {hello }} -test io-32.11.2 {Tcl_Read from a pipe} {stdio openpipe} { +test io-32.11.2 {Tcl_Read from a pipe} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 {chan configure stdout -translation crlf} puts $f1 {puts [gets stdin]} puts $f1 {puts [gets stdin]} @@ -4252,11 +4257,11 @@ set z broken } close $f1 set z } ok -test io-33.3 {Tcl_Gets from pipe} {stdio openpipe} { +test io-33.3 {Tcl_Gets from pipe} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 {puts [gets stdin]} close $f1 set f1 [open "|[list [interpreter] $path(pipe)]" r+] @@ -4560,11 +4565,11 @@ seek $f1 0 current set c2 [tell $f1] close $f1 list $c1 $r1 $c2 } {44 rstuv 49} -test io-34.8 {Tcl_Seek on pipes: not supported} {stdio openpipe} { +test io-34.8 {Tcl_Seek on pipes: not supported} stdio { set f1 [open "|[list [interpreter]]" r+] set x [list [catch {seek $f1 0 current} msg] $msg] close $f1 regsub {".*":} $x {"":} x string tolower $x @@ -4668,17 +4673,17 @@ seek $f1 10 current set c2 [tell $f1] close $f1 list $c1 $c2 } {10 20} -test io-34.16 {Tcl_Tell on pipe: always -1} {stdio openpipe} { +test io-34.16 {Tcl_Tell on pipe: always -1} stdio { set f1 [open "|[list [interpreter]]" r+] set c [tell $f1] close $f1 set c } -1 -test io-34.17 {Tcl_Tell on pipe: always -1} {stdio openpipe} { +test io-34.17 {Tcl_Tell on pipe: always -1} stdio { set f1 [open "|[list [interpreter]]" r+] puts $f1 {puts hello} flush $f1 set c [tell $f1] gets $f1 @@ -4773,11 +4778,11 @@ lappend x [eof $f] lappend x [eof $f] close $f set x } {0 0 0 0 1 1} -test io-35.2 {Tcl_Eof with pipe} {stdio openpipe} { +test io-35.2 {Tcl_Eof with pipe} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 {gets stdin} puts $f1 {puts hello} close $f1 @@ -4791,11 +4796,11 @@ gets $f1 lappend x [eof $f1] close $f1 set x } {0 0 0 1} -test io-35.3 {Tcl_Eof with pipe} {stdio openpipe} { +test io-35.3 {Tcl_Eof with pipe} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 {gets stdin} puts $f1 {puts hello} close $f1 @@ -4825,11 +4830,11 @@ lappend l [gets $f] lappend l [eof $f] close $f set l } {{} 1} -test io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} {stdio openpipe} { +test io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} stdio { file delete $path(pipe) set f [open $path(pipe) w] puts $f { exit } @@ -5102,11 +5107,11 @@ list $c $l $e [scan [string index $in end] %c] } {9 1 1 13} # Test Tcl_InputBlocked -test io-36.1 {Tcl_InputBlocked on nonblocking pipe} {stdio openpipe} { +test io-36.1 {Tcl_InputBlocked on nonblocking pipe} stdio { set f1 [open "|[list [interpreter]]" r+] puts $f1 {puts hello_from_pipe} flush $f1 gets $f1 fconfigure $f1 -blocking off -buffering full @@ -5121,11 +5126,11 @@ lappend x [gets $f1] lappend x [fblocked $f1] close $f1 set x } {{} 1 hello 0 {} 1} -test io-36.1.1 {Tcl_InputBlocked on nonblocking binary pipe} {stdio openpipe} { +test io-36.1.1 {Tcl_InputBlocked on nonblocking binary pipe} stdio { set f1 [open "|[list [interpreter]]" r+] chan configure $f1 -encoding binary -translation lf -eofchar {} puts $f1 { chan configure stdout -encoding binary -translation lf -eofchar {} puts hello_from_pipe @@ -5144,11 +5149,11 @@ lappend x [gets $f1] lappend x [fblocked $f1] close $f1 set x } {{} 1 hello 0 {} 1} -test io-36.2 {Tcl_InputBlocked on blocking pipe} {stdio openpipe} { +test io-36.2 {Tcl_InputBlocked on blocking pipe} stdio { set f1 [open "|[list [interpreter]]" r+] fconfigure $f1 -buffering line puts $f1 {puts hello_from_pipe} set x "" lappend x [gets $f1] @@ -5408,11 +5413,11 @@ lappend x [fblocked $f1] lappend x [eof $f1] close $f1 set x } {1 0 {} {} 0 1} -test io-39.10 {Tcl_SetChannelOption, blocking mode} {stdio openpipe} { +test io-39.10 {Tcl_SetChannelOption, blocking mode} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 { gets stdin after 100 @@ -5499,11 +5504,11 @@ set f [open $path(test1) w] set result [list [catch {fconfigure $f -encoding foobar} msg] $msg] close $f set result } {1 {unknown encoding "foobar"}} -test io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} {stdio openpipe fileevent} { +test io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} {stdio fileevent} { set f [open "|[list [interpreter] $path(cat)]" r+] fconfigure $f -encoding binary puts -nonewline $f "\xe7" flush $f fconfigure $f -encoding utf-8 -blocking 0 @@ -5634,11 +5639,11 @@ } {zzy abzzy} test io-40.2 {POSIX open access modes: CREAT} {unix} { file delete $path(test3) set f [open $path(test3) {WRONLY CREAT} 0o600] file stat $path(test3) stats - set x [format "%#o" [expr $stats(mode)&0o777]] + set x [format "0o%o" [expr $stats(mode)&0o777]] puts $f "line 1" close $f set f [open $path(test3) r] lappend x [gets $f] close $f @@ -5649,11 +5654,11 @@ file delete $path(test3) set f [open $path(test3) {WRONLY CREAT}] close $f file stat $path(test3) stats format "%#o" [expr $stats(mode)&0o777] -} [format %#5o [expr {0o666 & ~ $umaskValue}]] +} [format %#4o [expr {0o666 & ~ $umaskValue}]] test io-40.4 {POSIX open access modes: CREAT} { file delete $path(test3) set f [open $path(test3) w] fconfigure $f -eofchar {} puts $f xyzzy @@ -5848,11 +5853,11 @@ lappend result [fileevent $f readable] [fileevent $f writable] } {{script 1} {} {script 1} {write script} {} {write script} {} {}} test io-43.2 {Tcl_FileeventCmd: deleting when many present} -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] -} -constraints {stdio unixExecs fileevent openpipe} -body { +} -constraints {stdio unixExecs fileevent} -body { set result {} lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r] fileevent $f r "read f" fileevent $f2 r "read f2" fileevent $f3 r "read f3" @@ -5869,11 +5874,11 @@ } -result {{} {} {} {read f} {read f2} {read f3} {read f} {} {read f3} {read f} {} {} {} {} {}} test io-44.1 {FileEventProc procedure: normal read event} -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] -} -constraints {stdio unixExecs fileevent openpipe} -body { +} -constraints {stdio unixExecs fileevent} -body { fileevent $f2 readable [namespace code { set x [gets $f2]; fileevent $f2 readable {} }] puts $f2 text; flush $f2 variable x initial @@ -5882,11 +5887,11 @@ } -cleanup { catch {close $f2} catch {close $f3} } -result {text} test io-44.2 {FileEventProc procedure: error in read event} -constraints { - stdio unixExecs fileevent openpipe + stdio unixExecs fileevent } -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] proc myHandler {msg options} { variable x $msg @@ -5905,11 +5910,11 @@ catch {close $f3} } -result {bogus {}} test io-44.3 {FileEventProc procedure: normal write event} -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] -} -constraints {stdio unixExecs fileevent openpipe} -body { +} -constraints {stdio unixExecs fileevent} -body { fileevent $f2 writable [namespace code { lappend x "triggered" incr count -1 if {$count <= 0} { fileevent $f2 writable {} @@ -5924,11 +5929,11 @@ } -cleanup { catch {close $f2} catch {close $f3} } -result {initial triggered triggered triggered} test io-44.4 {FileEventProc procedure: eror in write event} -constraints { - stdio unixExecs fileevent openpipe + stdio unixExecs fileevent } -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] proc myHandler {msg options} { variable x $msg @@ -5943,11 +5948,13 @@ } -cleanup { interp bgerror {} $handler catch {close $f2} catch {close $f3} } -result {bad-write {}} -test io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs openpipe fileevent} { +test io-44.5 {FileEventProc procedure: end of file} -constraints { + stdio unixExecs fileevent +} -body { set f4 [open "|[list [interpreter] $path(cat) << foo]" r] fileevent $f4 readable [namespace code { if {[gets $f4 line] < 0} { lappend x eof fileevent $f4 readable {} @@ -5956,78 +5963,16 @@ } }] variable x initial vwait [namespace which -variable x] vwait [namespace which -variable x] + set x +} -cleanup { close $f4 - set x -} {initial foo eof} +} -result {initial foo eof} close $f - -test chan-io-44.6 {FileEventProc procedure: write-only non-blocking channel} -setup { -} -constraints {stdio unixExecs fileevent openpipe} -body { - - namespace eval refchan { - namespace ensemble create - namespace export * - - - proc finalize {chan args} { - namespace delete c_$chan - } - - proc initialize {chan args} { - namespace eval c_$chan {} - namespace upvar c_$chan watching watching - set watching {} - list finalize initialize seek watch write - } - - - proc watch {chan args} { - namespace upvar c_$chan watching watching - foreach arg $args { - switch $arg { - write { - if {$arg ni $watching} { - lappend watching $arg - } - chan postevent $chan $arg - } - } - } - } - - - proc write {chan args} { - chan postevent $chan write - return 1 - } - } - set f [chan create w [namespace which refchan]] - chan configure $f -blocking 0 - set data "some data" - set x 0 - chan event $f writable [namespace code { - puts $f $data - incr count [string length $data] - if {$count > 262144} { - chan event $f writable {} - set x done - } - }] - after 10000 [namespace code { - set x timeout - }] - vwait [namespace which -variable x] - return $x -} -cleanup { - catch {chan close $f} -} -result done - - makeFile "foo bar" foo test io-45.1 {DeleteFileEvent, cleanup on close} {fileevent} { set f [open $path(foo) r] fileevent $f readable [namespace code { @@ -6080,23 +6025,24 @@ [catch {fileevent $f3 readable}] } {0 {f script} 1 0 {f3 script} 0 {f script} 1 1 1 1 1} # Execute these tests only if the "testfevent" command is present. -test io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent} { +test io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent notOSX} { testfevent create set script "set f \[[list open $path(foo) r]]\n" append script { set x "no event" fileevent $f readable [namespace code { set x "f triggered: [gets $f]" fileevent $f readable {} }] } + set timer [after 10 lappend x timeout] testfevent cmd $script - after 1 ;# We must delay because Windows takes a little time to notice - update + vwait x + after cancel $timer testfevent cmd {close $f} list [testfevent cmd {set x}] [testfevent cmd {info commands after}] } {{f triggered: foo bar} after} test io-46.2 {Tcl event loop vs multiple interpreters} testfevent { testfevent create @@ -6281,11 +6227,11 @@ variable x not_done vwait [namespace which -variable x] list $x $l } {done {called called called called called called called}} set path(my_script) [makeFile {} my_script] -test io-48.3 {testing readability conditions} {stdio unix nonBlockFiles openpipe fileevent} { +test io-48.3 {testing readability conditions} {stdio unix nonBlockFiles fileevent} { set f [open $path(bar) w] puts $f abcdefg puts $f abcdefg puts $f abcdefg puts $f abcdefg @@ -6779,76 +6725,93 @@ lappend l [eof $f] close $f set l } [list 7 a\rb\rc 7 {} 7 1] -test io-50.1 {testing handler deletion} {testchannelevent} { +test io-50.1 {testing handler deletion} -constraints {testchannelevent testservicemode} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] close $f - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list delhandler $f]] + update proc delhandler {f} { variable z set z called testchannelevent $f delete 0 } set z not_called - update - close $f + set timer [after 50 lappend z timeout] + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list delhandler $f]] + testservicemode 1 + vwait z + after cancel $timer set z -} called -test io-50.2 {testing handler deletion with multiple handlers} {testchannelevent} { +} -cleanup { + close $f +} -result called +test io-50.2 {testing handler deletion with multiple handlers} -constraints {testchannelevent testservicemode} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] close $f - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list delhandler $f 1]] - testchannelevent $f add readable [namespace code [list delhandler $f 0]] proc delhandler {f i} { variable z - lappend z "called delhandler $f $i" + lappend z "called delhandler $i" testchannelevent $f delete 0 } set z "" - update + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list delhandler $f 1]] + testchannelevent $f add readable [namespace code [list delhandler $f 0]] + testservicemode 1 + set timer [after 50 lappend z timeout] + vwait z + after cancel $timer + set z +} -cleanup { close $f - string compare [string tolower $z] \ - [list [list called delhandler $f 0] [list called delhandler $f 1]] -} 0 -test io-50.3 {testing handler deletion with multiple handlers} {testchannelevent} { +} -result {{called delhandler 0} {called delhandler 1}} +test io-50.3 {testing handler deletion with multiple handlers} -constraints {testchannelevent testservicemode} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] close $f - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list notcalled $f 1]] - testchannelevent $f add readable [namespace code [list delhandler $f 0]] set z "" proc notcalled {f i} { variable z lappend z "notcalled was called!! $f $i" } proc delhandler {f i} { variable z testchannelevent $f delete 1 - lappend z "delhandler $f $i called" + lappend z "delhandler $i called" testchannelevent $f delete 0 - lappend z "delhandler $f $i deleted myself" + lappend z "delhandler $i deleted myself" } set z "" + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list notcalled $f 1]] + testchannelevent $f add readable [namespace code [list delhandler $f 0]] + testservicemode 1 + set timer [after 50 lappend z timeout] + vwait z + after cancel $timer + set z +} -cleanup { + close $f +} -result {{delhandler 0 called} {delhandler 0 deleted myself}} +test io-50.4 {testing handler deletion vs reentrant calls} -constraints {testchannelevent testservicemode} -setup { + file delete $path(test1) update - close $f - string compare [string tolower $z] \ - [list [list delhandler $f 0 called] \ - [list delhandler $f 0 deleted myself]] -} 0 -test io-50.4 {testing handler deletion vs reentrant calls} {testchannelevent} { - file delete $path(test1) +} -body { set f [open $path(test1) w] close $f - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list delrecursive $f]] + update proc delrecursive {f} { variable z variable u if {"$u" == "recursive"} { testchannelevent $f delete 0 @@ -6859,64 +6822,79 @@ update } } variable u toplevel variable z "" - update + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list delrecursive $f]] + testservicemode 1 + set timer [after 50 lappend z timeout] + vwait z + after cancel $timer + set z +} -cleanup { close $f - string compare [string tolower $z] \ - {{delrecursive calling recursive} {delrecursive deleting recursive}} -} 0 -test io-50.5 {testing handler deletion vs reentrant calls} {testchannelevent} { +} -result {{delrecursive calling recursive} {delrecursive deleting recursive}} +test io-50.5 {testing handler deletion vs reentrant calls} -constraints {testchannelevent testservicemode notOSX} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] close $f - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list notcalled $f]] - testchannelevent $f add readable [namespace code [list del $f]] proc notcalled {f} { variable z lappend z "notcalled was called!! $f" } proc del {f} { variable u variable z if {"$u" == "recursive"} { testchannelevent $f delete 1 - testchannelevent $f delete 0 lappend z "del deleted notcalled" + testchannelevent $f delete 0 lappend z "del deleted myself" } else { set u recursive lappend z "del calling recursive" - update - lappend z "del after update" + set timer [after 50 lappend z timeout] + vwait z + after cancel $timer + lappend z "del after recursive" } } set z "" set u toplevel - update + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list notcalled $f]] + testchannelevent $f add readable [namespace code [list del $f]] + testservicemode 1 + set timer [after 50 set z timeout] + vwait z + after cancel $timer + set z +} -cleanup { close $f - string compare [string tolower $z] \ - [list {del calling recursive} {del deleted notcalled} \ - {del deleted myself} {del after update}] -} 0 -test io-50.6 {testing handler deletion vs reentrant calls} {testchannelevent} { +} -result [list {del calling recursive} {del deleted notcalled} \ + {del deleted myself} {del after recursive}] +test io-50.6 {testing handler deletion vs reentrant calls} -constraints {testchannelevent testservicemode} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] close $f - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list second $f]] - testchannelevent $f add readable [namespace code [list first $f]] proc first {f} { variable u variable z + variable done if {"$u" == "toplevel"} { lappend z "first called" set u first - update - lappend z "first after update" + set timer [after 50 lappend z timeout] + vwait z + after cancel $timer + lappend z "first after toplevel" + set done 1 } else { lappend z "first called not toplevel" } } proc second {f} { @@ -6934,18 +6912,28 @@ testchannelevent $f removeall } } set z "" set u toplevel + set done 0 + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list second $f]] + testchannelevent $f add readable [namespace code [list first $f]] + testservicemode 1 update + if {!$done} { + set timer2 [after 200 set done 1] + vwait done + after cancel $timer2 + } + set z +} -cleanup { close $f - string compare [string tolower $z] \ - [list {first called} {first called not toplevel} \ - {second called, first time} {second called, second time} \ - {first after update}] -} 0 - +} -result [list {first called} {first called not toplevel} \ + {second called, first time} {second called, second time} \ + {first after toplevel}] test io-51.1 {Test old socket deletion on Macintosh} {socket} { set x 0 set result "" proc accept {s a p} { variable x @@ -7131,11 +7119,11 @@ if {"$s1" == "$s2"} { lappend result ok } set result } {0 0 ok} -test io-52.8 {TclCopyChannel} {stdio openpipe fcopy} { +test io-52.8 {TclCopyChannel} {stdio fcopy} { file delete $path(test1) file delete $path(pipe) set f1 [open $path(pipe) w] fconfigure $f1 -translation lf puts $f1 " @@ -7411,11 +7399,11 @@ if {("$s1" == "$s2") && ($s0 == $s1)} { lappend result ok } set result } {0 0 ok} -test io-53.3 {CopyData: background read underflow} {stdio unix openpipe fcopy} { +test io-53.3 {CopyData: background read underflow} {stdio unix fcopy} { file delete $path(test1) file delete $path(pipe) set f1 [open $path(pipe) w] puts -nonewline $f1 { puts ready @@ -7443,11 +7431,11 @@ set f [open $path(test1)] lappend result [read $f] close $f set result } "ready line1 line2 {done\n}" -test io-53.4 {CopyData: background write overflow} {stdio unix openpipe fileevent fcopy} { +test io-53.4 {CopyData: background write overflow} {stdio fileevent fcopy} { set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n variable x for {set x 0} {$x < 12} {incr x} { append big $big } @@ -7527,18 +7515,18 @@ set out [socket 127.0.0.1 [lindex [fconfigure $listen -sockname] 2]] catch {unset fcopyTestDone} close $listen ;# This means the socket open never really succeeds fcopy $in $out -command [namespace code FcopyTestDone] variable fcopyTestDone - if ![info exists fcopyTestDone] { + if {![info exists fcopyTestDone]} { vwait [namespace which -variable fcopyTestDone] ;# The error occurs here in the b.g. } close $in close $out set fcopyTestDone ;# 1 for error condition } 1 -test io-53.6 {CopyData: error during fcopy} {stdio openpipe fcopy} { +test io-53.6 {CopyData: error during fcopy} {stdio fcopy} { variable fcopyTestDone file delete $path(pipe) file delete $path(test1) catch {unset fcopyTestDone} set f1 [open $path(pipe) w] @@ -7546,11 +7534,11 @@ close $f1 set in [open "|[list [interpreter] $path(pipe)]" r+] set out [open $path(test1) w] fcopy $in $out -command [namespace code FcopyTestDone] variable fcopyTestDone - if ![info exists fcopyTestDone] { + if {![info exists fcopyTestDone]} { vwait [namespace which -variable fcopyTestDone] } catch {close $in} close $out set fcopyTestDone ;# 0 for plain end of file @@ -7567,11 +7555,11 @@ # Delay next fcopy to wait for size>0 input bytes after 100 [list fcopy $in $out -size 1000 \ -command [namespace code [list doFcopy $in $out]]] } } -test io-53.7 {CopyData: Flooding fcopy from pipe} {stdio openpipe fcopy} { +test io-53.7 {CopyData: Flooding fcopy from pipe} {stdio fcopy} { variable fcopyTestDone file delete $path(pipe) catch {unset fcopyTestDone} set fcopyTestCount 0 set f1 [open $path(pipe) w] @@ -7593,11 +7581,11 @@ close $f1 set in [open "|[list [interpreter] $path(pipe) &]" r+] set out [open $path(test1) w] doFcopy $in $out variable fcopyTestDone - if ![info exists fcopyTestDone] { + if {![info exists fcopyTestDone]} { vwait [namespace which -variable fcopyTestDone] } catch {close $in} close $out # -1=error 0=script error N=number of bytes @@ -7619,11 +7607,11 @@ set foo [makeFile ashgdfashdgfasdhgfasdhgf foo] set bar [makeFile {} bar] # Channels to copy between set f [open $foo r] ; fconfigure $f -translation binary set g [open $bar w] ; fconfigure $g -translation binary -buffering none -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { # Record input size, so that result is always defined lappend ::RES [file size $bar] # Run the copy. Should not invoke -command now. fcopy $f $g -size 2 -command ::cmd # Check that -command was not called synchronously @@ -7660,11 +7648,11 @@ set foo [makeFile ashgdfashdgfasdhgfasdhgf foo] set bar [makeFile {} bar] # Channels to copy between set f [open $foo r] ; fconfigure $f -translation binary set g [open $bar w] ; fconfigure $g -translation binary -buffering none -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { # Initialize and force eof on the input. seek $f 0 end ; read $f 1 set ::RES [eof $f] # Run the copy. Should not invoke -command now. fcopy $f $g -size 2 -command ::cmd @@ -7700,11 +7688,11 @@ set foo [makeFile ashgdfashdgfasdhgfasdhgf foo] set bar [makeFile {} bar] # Channels to copy between set f [open $foo r] ; fconfigure $f -translation binary set g [open $bar w] ; fconfigure $g -translation binary -buffering none -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { set ::RES {} # Run the copy. Should not invoke -command now. fcopy $f $g -size 0 -command ::cmd # Check that -command was not called synchronously lappend ::RES [expr {([llength $::RES] > 1) ? "sync/FAIL" : "sync/OK"}] @@ -7757,11 +7745,11 @@ set ::forever OK return } set ::forever {} set out [open $out w] -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { fcopy $pipe $out -size 6 -command ::done set token [after 5000 { set ::forever {fcopy hangs} }] vwait ::forever @@ -7827,11 +7815,11 @@ set b [socket 127.0.0.1 9999] fconfigure $a -translation binary -buffering none fconfigure $b -translation binary -buffering none fileevent $a readable [list ::done $a] fileevent $b readable [list ::done $b] -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { # Now pass data through the server in both directions. set ::forever {} puts $a AB vwait ::forever puts $b BA @@ -7875,11 +7863,11 @@ close $outChan close $inChan removeFile out removeFile in } -result {40 bytes copied} -test io-53.12 {CopyData: foreground short reads, aka bug 3096275} {stdio unix openpipe fcopy} { +test io-53.12 {CopyData: foreground short reads, aka bug 3096275} {stdio unix fcopy} { file delete $path(pipe) set f1 [open $path(pipe) w] puts -nonewline $f1 { fconfigure stdin -translation binary -blocking 0 fconfigure stdout -buffering none -translation binary @@ -8081,11 +8069,11 @@ close $outChan close $c removeFile out } -result {line 100 line} -test io-54.1 {Recursive channel events} {socket fileevent} { +test io-54.1 {Recursive channel events} {socket fileevent notWinCI} { # This test checks to see if file events are delivered during recursive # event loops when there is buffered data on the channel. proc accept {s a p} { variable as @@ -8290,11 +8278,11 @@ close $s2 close $server set result } {1 readable 234567890 timer} -test io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrPc openpipe fileevent} { +test io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrWin fileevent} { set out [open $path(script) w] puts $out { puts "normal message from pipe" puts stderr "error message from pipe" exit 1 @@ -8330,11 +8318,11 @@ set result [testchannel mthread $f] close $f string equal $result [testmainthread] } {1} -test io-60.1 {writing illegal utf sequences} {openpipe fileevent testbytestring} { +test io-60.1 {writing illegal utf sequences} {fileevent testbytestring} { # This test will hang in older revisions of the core. set out [open $path(script) w] puts $out "catch {load $::tcltestlib Tcltest}" puts $out { @@ -8708,20 +8696,20 @@ test io-74.1 {[104f2885bb] improper cache validity check} -setup { set fn [makeFile {} io-74.1] set rfd [open $fn r] testobj freeallvars - interp create slave + interp create child } -constraints testobj -body { teststringobj set 1 [string range $rfd 0 end] read [teststringobj get 1] testobj duplicate 1 2 - interp transfer {} $rfd slave + interp transfer {} $rfd child catch {read [teststringobj get 1]} read [teststringobj get 2] } -cleanup { - interp delete slave + interp delete child testobj freeallvars removeFile io-74.1 } -returnCodes error -match glob -result {can not find channel named "*"} # ### ### ### ######### ######### ######### Index: tests/ioCmd.test ================================================================== --- tests/ioCmd.test +++ tests/ioCmd.test @@ -11,11 +11,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands @@ -152,14 +152,14 @@ [list 1 [format "channel \"%s\" wasn't opened for reading" $f] none] } 0 test iocmd-4.12 {read command} -setup { set f [open $path(test1)] } -body { - read $f 12z + list [catch {read $f 12z} msg] $msg $::errorCode } -cleanup { close $f -} -result {expected non-negative integer but got "12z"} -errorCode {TCL VALUE NUMBER} +} -result {1 {expected non-negative integer but got "12z"} {TCL VALUE NUMBER}} test iocmd-5.1 {seek command} -returnCodes error -body { seek } -result {wrong # args: should be "seek channelId offset ?origin?"} test iocmd-5.2 {seek command} -returnCodes error -body { @@ -204,99 +204,87 @@ chan close $chan write } -cleanup { close $chan } -returnCodes error -result "Half-close of write-side not possible, side not opened or already closed" -proc expectedOpts {got extra} { - set basicOpts { - -blocking -buffering -buffersize -encoding -eofchar -translation - } - set opts [list {*}$basicOpts {*}$extra] - lset opts end [string cat "or " [lindex $opts end]] - return [format {bad option "%s": should be one of %s} $got [join $opts ", "]] -} -test iocmd-8.1 {fconfigure command} -returnCodes error -body { - fconfigure -} -result {wrong # args: should be "fconfigure channelId ?-option value ...?"} -test iocmd-8.2 {fconfigure command} -returnCodes error -body { - fconfigure a b c d e f -} -result {wrong # args: should be "fconfigure channelId ?-option value ...?"} -test iocmd-8.3 {fconfigure command} -returnCodes error -body { - fconfigure a b -} -result {can not find channel named "a"} -test iocmd-8.4 {fconfigure command} -setup { - file delete $path(test1) - set f1 [open $path(test1) w] -} -body { - fconfigure $f1 froboz -} -returnCodes error -cleanup { - close $f1 -} -result [expectedOpts "froboz" {}] -test iocmd-8.5 {fconfigure command} -returnCodes error -body { - fconfigure stdin -buffering froboz -} -result {bad value for -buffering: must be one of full, line, or none} -test iocmd-8.6 {fconfigure command} -returnCodes error -body { - fconfigure stdin -translation froboz -} -result {bad value for -translation: must be one of auto, binary, cr, lf, crlf, or platform} -test iocmd-8.7 {fconfigure command} -setup { - file delete $path(test1) -} -body { - set f1 [open $path(test1) w] - fconfigure $f1 -translation lf -eofchar {} -encoding unicode - fconfigure $f1 -} -cleanup { - catch {close $f1} -} -result {-blocking 1 -buffering full -buffersize 4096 -encoding unicode -eofchar {} -translation lf} -test iocmd-8.8 {fconfigure command} -setup { - file delete $path(test1) - set x {} -} -body { +test iocmd-8.1 {fconfigure command} { + list [catch {fconfigure} msg] $msg +} {1 {wrong # args: should be "fconfigure channelId ?-option value ...?"}} +test iocmd-8.2 {fconfigure command} { + list [catch {fconfigure a b c d e f} msg] $msg +} {1 {wrong # args: should be "fconfigure channelId ?-option value ...?"}} +test iocmd-8.3 {fconfigure command} { + list [catch {fconfigure a b} msg] $msg +} {1 {can not find channel named "a"}} +test iocmd-8.4 {fconfigure command} { + file delete $path(test1) + set f1 [open $path(test1) w] + set x [list [catch {fconfigure $f1 froboz} msg] $msg] + close $f1 + set x +} {1 {bad option "froboz": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}} +test iocmd-8.5 {fconfigure command} { + list [catch {fconfigure stdin -buffering froboz} msg] $msg +} {1 {bad value for -buffering: must be one of full, line, or none}} +test iocmd-8.6 {fconfigure command} { + list [catch {fconfigure stdin -translation froboz} msg] $msg +} {1 {bad value for -translation: must be one of auto, binary, cr, lf, crlf, or platform}} +test iocmd-8.7 {fconfigure command} { + file delete $path(test1) + set f1 [open $path(test1) w] + fconfigure $f1 -translation lf -eofchar {} -encoding unicode + set x [fconfigure $f1] + close $f1 + set x +} {-blocking 1 -buffering full -buffersize 4096 -encoding unicode -eofchar {} -translation lf} +test iocmd-8.8 {fconfigure command} { + file delete $path(test1) set f1 [open $path(test1) w] fconfigure $f1 -translation lf -buffering line -buffersize 3030 \ -eofchar {} -encoding unicode + set x "" lappend x [fconfigure $f1 -buffering] lappend x [fconfigure $f1] -} -cleanup { - catch {close $f1} -} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding unicode -eofchar {} -translation lf}} -test iocmd-8.9 {fconfigure command} -setup { + close $f1 + set x +} {line {-blocking 1 -buffering line -buffersize 3030 -encoding unicode -eofchar {} -translation lf}} +test iocmd-8.9 {fconfigure command} { file delete $path(test1) -} -body { set f1 [open $path(test1) w] fconfigure $f1 -translation binary -buffering none -buffersize 4040 \ -eofchar {} -encoding binary - fconfigure $f1 -} -cleanup { - catch {close $f1} -} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -translation lf} -test iocmd-8.10 {fconfigure command} -returnCodes error -body { - fconfigure a b -} -result {can not find channel named "a"} + set x [fconfigure $f1] + close $f1 + set x +} {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -translation lf} +test iocmd-8.10 {fconfigure command} { + list [catch {fconfigure a b} msg] $msg +} {1 {can not find channel named "a"}} set path(fconfigure.dummy) [makeFile {} fconfigure.dummy] -test iocmd-8.11 {fconfigure command} -body { - set chan [open $path(fconfigure.dummy) r] - fconfigure $chan -froboz blarfo -} -returnCodes error -cleanup { - catch {close $chan} -} -result [expectedOpts "-froboz" {}] -test iocmd-8.12 {fconfigure command} -body { - set chan [open $path(fconfigure.dummy) r] - fconfigure $chan -b blarfo -} -returnCodes error -cleanup { - catch {close $chan} -} -result [expectedOpts "-b" {}] -test iocmd-8.13 {fconfigure command} -body { - set chan [open $path(fconfigure.dummy) r] - fconfigure $chan -buffer blarfo -} -returnCodes error -cleanup { - catch {close $chan} -} -result [expectedOpts "-buffer" {}] +test iocmd-8.11 {fconfigure command} { + set chan [open $path(fconfigure.dummy) r] + set res [list [catch {fconfigure $chan -froboz blarfo} msg] $msg] + close $chan + set res +} {1 {bad option "-froboz": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}} +test iocmd-8.12 {fconfigure command} { + set chan [open $path(fconfigure.dummy) r] + set res [list [catch {fconfigure $chan -b blarfo} msg] $msg] + close $chan + set res +} {1 {bad option "-b": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}} +test iocmd-8.13 {fconfigure command} { + set chan [open $path(fconfigure.dummy) r] + set res [list [catch {fconfigure $chan -buffer blarfo} msg] $msg] + close $chan + set res +} {1 {bad option "-buffer": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}} removeFile fconfigure.dummy test iocmd-8.14 {fconfigure command} { fconfigure stdin -buffers } 4096 -test iocmd-8.15.1 {fconfigure command / tcp channel} -constraints {socket unixOrPc} -setup { +test iocmd-8.15.1 {fconfigure command / tcp channel} -constraints {socket unixOrWin} -setup { set srv [socket -server iocmdSRV -myaddr 127.0.0.1 0] set port [lindex [fconfigure $srv -sockname] 2] proc iocmdSRV {sock ip port} {close $sock} set cli [socket 127.0.0.1 $port] } -body { @@ -304,11 +292,11 @@ } -cleanup { close $cli close $srv unset cli srv port rename iocmdSRV {} -} -returnCodes error -result [expectedOpts "-blah" {-connecting -peername -sockname}] +} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -connecting, -peername, or -sockname} test iocmd-8.16 {fconfigure command / tcp channel} -constraints socket -setup { set srv [socket -server iocmdSRV -myaddr 127.0.0.1 0] set port [lindex [fconfigure $srv -sockname] 2] proc iocmdSRV {sock ip port} {close $sock} set cli [socket 127.0.0.1 $port] @@ -347,11 +335,11 @@ fconfigure $tty -blah blih } -cleanup { if {$tty ne ""} { close $tty } -} -returnCodes error -result [expectedOpts "-blah" {-closemode -inputmode -mode -queue -ttystatus -xchar}] +} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -mode} test iocmd-8.19 {fconfigure command / win tty channel} -constraints {nonPortable win} -setup { set tty "" } -body { # might fail early if com1 is unavailable set tty [open com1] @@ -358,17 +346,11 @@ fconfigure $tty -blah blih } -cleanup { if {$tty ne ""} { close $tty } -} -returnCodes error -result [expectedOpts "-blah" {-closemode -mode -handshake -pollinterval -sysbuffer -timeout -ttycontrol -xchar}] -test iocmd-8.20 {fconfigure command / win console channel} -constraints {nonPortable win} -setup { - # I don't know how else to open the console, but this is non-portable - set console stdin -} -body { - fconfigure $console -blah blih -} -returnCodes error -result [expectedOpts "-blah" {-inputmode}] +} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -mode, -handshake, -pollinterval, -sysbuffer, -timeout, -ttycontrol, or -xchar} # TODO: Test parsing of serial channel options (nonPortable, since requires an # open channel to work with). test iocmd-9.1 {eof command} { list [catch {eof} msg] $msg $::errorCode @@ -400,22 +382,22 @@ } 0 set path(test4) [makeFile {} test4] set path(test5) [makeFile {} test5] -test iocmd-11.1 {I/O to command pipelines} {unixOrPc unixExecs} { +test iocmd-11.1 {I/O to command pipelines} {unixOrWin unixExecs} { set f [open $path(test4) w] close $f list [catch {open "| cat < \"$path(test4)\" > \"$path(test5)\"" w} msg] $msg $::errorCode } {1 {can't write input to command: standard input was redirected} {TCL OPERATION EXEC BADREDIRECT}} -test iocmd-11.2 {I/O to command pipelines} {unixOrPc unixExecs} { +test iocmd-11.2 {I/O to command pipelines} {unixOrWin unixExecs} { list [catch {open "| echo > \"$path(test5)\"" r} msg] $msg $::errorCode } {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}} -test iocmd-11.3 {I/O to command pipelines} {unixOrPc unixExecs} { +test iocmd-11.3 {I/O to command pipelines} {unixOrWin unixExecs} { list [catch {open "| echo > \"$path(test5)\"" r+} msg] $msg $::errorCode } {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}} -test iocmd-11.4 {I/O to command pipelines} {notValgrind unixOrPc} { +test iocmd-11.4 {I/O to command pipelines} {notValgrind unixOrWin} { list [catch {open "| no_such_command_exists" rb} msg] $msg $::errorCode } {1 {couldn't execute "no_such_command_exists": no such file or directory} {POSIX ENOENT {no such file or directory}}} test iocmd-12.1 {POSIX open access modes: RDONLY} { file delete $path(test1) @@ -822,15 +804,15 @@ return } } set ch [chan create {read write} foo] } -body { - list [catch {chan configure $ch -blocking 0} m] $m + chan configure $ch -blocking 0 } -cleanup { close $ch rename foo {} -} -match glob -result {1 {*nested eval*}} +} -match glob -returnCodes 1 -result {*(infinite loop?)*} test iocmd-21.21 {[close] in [read] segfaults} -setup { proc foo {method chan args} { switch -- $method initialize { return {initialize finalize watch read} } finalize {} watch {} read { @@ -928,21 +910,10 @@ proc onfinal {} { upvar args hargs if {[lindex $hargs 0] ne "finalize"} {return} return -code return "" } - -proc onwatch {} { - upvar args hargs - lassign $hargs watch chan eventspec - if {$watch ne "watch"} return - foreach spec $eventspec { - chan postevent $chan $spec - } - return -} - } # Set everything up in the main thread. eval $helperscript @@ -2011,33 +1982,32 @@ } -result {{unmatched open brace in list}} test iocmd-31.6 {chan postevent, posted events do happen} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return} set c [chan create {r w} foo] - set tock {} - note [fileevent $c readable {lappend res TOCK; set tock 1}] - set stop [after 10000 {lappend res TIMEOUT; set tock 1}] + note [fileevent $c readable {note TOCK}] + set stop [after 15000 {note TIMEOUT}] after 1000 {note [chan postevent $c r]} - vwait ::tock + vwait ::res catch {after cancel $stop} close $c rename foo {} set res -} -result {{watch rc* read} {} {} TOCK {watch rc* {}}} +} -result {{watch rc* read} {} TOCK {} {watch rc* {}}} test iocmd-31.7 {chan postevent, posted events do happen} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return} set c [chan create {r w} foo] - note [fileevent $c writable {lappend res TOCK; set tock 1}] - set stop [after 10000 {lappend res TIMEOUT; set tock 1}] + note [fileevent $c writable {note TOCK}] + set stop [after 15000 {note TIMEOUT}] after 1000 {note [chan postevent $c w]} - vwait ::tock + vwait ::res catch {after cancel $stop} close $c rename foo {} set res -} -result {{watch rc* write} {} {} TOCK {watch rc* {}}} +} -result {{watch rc* write} {} TOCK {} {watch rc* {}}} test iocmd-31.8 {chan postevent after close throws error} -match glob -setup { proc foo {args} {oninit; onfinal; track; return} proc dummy args { return } set c [chan create {r w} foo] fileevent $c readable dummy @@ -2046,35 +2016,10 @@ chan postevent $c read } -cleanup { rename foo {} rename dummy {} } -returnCodes error -result {can not find reflected channel named "rc*"} -test iocmd-31.9 { - chan postevent - - call to current coroutine - - see 67a5eabbd3d1 -} -match glob -body { - set res {} - proc foo {args} {oninit; onwatch; onfinal; track; return} - set c [chan create {r w} foo] - after 0 [list ::apply [list c { - coroutine c1 ::apply [list c { - chan event $c readable [list [info coroutine]] - yield - set ::done READING - } [namespace current]] $c - } [namespace current]] $c] - set stop [after 10000 {set done TIMEOUT}] - vwait ::done - catch {after cancel $stop} - lappend res $done - close $c - rename foo {} - set res -} -result {{watch rc* read} READING {watch rc* {}}} # --- === *** ########################### # 'Pull the rug' tests. Create channel in a interpreter A, move to # other interpreter B, destroy the origin interpreter (A) before or # during access from B. Must not crash, must return proper errors. @@ -2082,11 +2027,11 @@ test iocmd-32.0 {origin interpreter of moved channel gone} -match glob -body { set ida [interp create];#puts <<$ida>> set idb [interp create];#puts <<$idb>> - # Magic to get the test* commands in the slaves + # Magic to get the test* commands in the children load {} Tcltest $ida load {} Tcltest $idb # Set up channel in interpreter interp eval $ida $helperscript @@ -2120,11 +2065,11 @@ test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -match glob -body { set ida [interp create];#puts <<$ida>> set idb [interp create];#puts <<$idb>> - # Magic to get the test* commands in the slaves + # Magic to get the test* commands in the children load {} Tcltest $ida load {} Tcltest $idb # Set up channel in thread set chan [interp eval $ida $helperscript] @@ -2162,17 +2107,17 @@ test iocmd-32.2 {delete interp of reflected chan} { # Bug 3034840 # Run this test in an interp with memory debugging to panic # on the double free - interp create slave - slave eval { + interp create child + child eval { proc no-op args {} proc driver {sub args} {return {initialize finalize watch read}} chan event [chan create read driver] readable no-op } - interp delete slave + interp delete child } {} # ### ### ### ######### ######### ######### ## Same tests as above, but exercising the code forwarding and ## receiving driver operations to the originator thread. Index: tests/ioTrans.test ================================================================== --- tests/ioTrans.test +++ tests/ioTrans.test @@ -9,12 +9,12 @@ # # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -34,12 +34,12 @@ # Helper commands to record the arguments to handler methods. Stored in a # script so that the tests needing this code do not need their own copy but # can access this variable. set helperscript { - if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 + if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } # This forces the return options to be in the order that the test expects! variable optorder { @@ -1160,11 +1160,11 @@ # interpreter B, destroy the origin interpreter (A) before or during access # from B. Must not crash, must return proper errors. test iortrans-11.0 {origin interpreter of moved transform gone} -setup { set ida [interp create]; #puts <<$ida>> set idb [interp create]; #puts <<$idb>> - # Magic to get the test* commands in the slaves + # Magic to get the test* commands in the children load {} Tcltest $ida load {} Tcltest $idb } -constraints {testchannel} -match glob -body { # Set up channel and transform in interpreter interp eval $ida $helperscript @@ -1203,11 +1203,11 @@ interp delete $idb } -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}} test iortrans-11.1 {origin interpreter of moved transform destroyed during access} -setup { set ida [interp create]; #puts <<$ida>> set idb [interp create]; #puts <<$idb>> - # Magic to get the test* commands in the slaves + # Magic to get the test* commands in the children load {} Tcltest $ida load {} Tcltest $idb } -constraints {testchannel} -match glob -body { # Set up channel in thread set chan [interp eval $ida $helperscript] @@ -1242,28 +1242,28 @@ } -cleanup { interp delete $idb tempdone } -result {Owner lost} test iortrans-11.2 {delete interp of reflected transform} -setup { - interp create slave - # Magic to get the test* commands into the slave - load {} Tcltest slave + interp create child + # Magic to get the test* commands into the child + load {} Tcltest child } -constraints {testchannel} -body { - # Get base channel into the slave + # Get base channel into the child set c [tempchan] testchannel cut $c - interp eval slave [list testchannel splice $c] - interp eval slave [list set c $c] - slave eval { + interp eval child [list testchannel splice $c] + interp eval child [list set c $c] + child eval { proc no-op args {} proc driver {c sub args} { return {initialize finalize read write} } set t [chan push $c [list driver $c]] chan event $c readable no-op } - interp delete slave + interp delete child } -cleanup { tempdone } -result {} # ### ### ### ######### ######### ######### Index: tests/iogt.test ================================================================== --- tests/iogt.test +++ tests/iogt.test @@ -3,11 +3,11 @@ # # This file contains a collection of tests for Giot # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -# +# # Copyright (c) 2000 Ajuba Solutions. # Copyright (c) 2000 Andreas Kupries. # All rights reserved. if {[catch {package require tcltest 2.1}]} { Index: tests/join.test ================================================================== --- tests/join.test +++ tests/join.test @@ -9,12 +9,12 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } test join-1.1 {basic join commands} { join {a b c} xyz Index: tests/lindex.test ================================================================== --- tests/lindex.test +++ tests/lindex.test @@ -10,12 +10,12 @@ # Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2.2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -68,15 +68,15 @@ list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}] } {{} {}} test lindex-3.5 {bad octal} -constraints testevalex -body { set x 0o8 list [catch { testevalex {lindex {a b c} $x} } result] $result -} -match glob -result {1 {*}} +} -match glob -result {1 {*invalid octal number*}} test lindex-3.6 {bad octal} -constraints testevalex -body { set x -0o9 list [catch { testevalex {lindex {a b c} $x} } result] $result -} -match glob -result {1 {*}} +} -match glob -result {1 {*invalid octal number*}} test lindex-3.7 {indexes don't shimmer wide ints} { set x [expr {(wide(1)<<31) - 2}] list $x [lindex {1 2 3} $x] [incr x] [incr x] } {2147483646 {} 2147483647 2147483648} test lindex-3.8 {compiled with static indices out of range, negative} { @@ -112,15 +112,15 @@ list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}] } {{} {}} test lindex-4.6 {bad octal} -constraints testevalex -body { set x end-0o8 list [catch { testevalex {lindex {a b c} $x} } result] $result -} -match glob -result {1 {*}} +} -match glob -result {1 {*invalid octal number*}} test lindex-4.7 {bad octal} -constraints testevalex -body { set x end--0o9 list [catch { testevalex {lindex {a b c} $x} } result] $result -} -match glob -result {1 {*}} +} -match glob -result {1 {*invalid octal number*}} test lindex-4.8 {bad integer, not octal} testevalex { set x end-0a2 list [catch { testevalex {lindex {a b c} $x} } result] $result } {1 {bad index "end-0a2": must be integer?[+-]integer? or end?[+-]integer?}} test lindex-4.9 {obsolete test} testevalex { @@ -268,15 +268,15 @@ set result } {{} {}} test lindex-11.5 {bad octal} -body { set x 0o8 list [catch { lindex {a b c} $x } result] $result -} -match glob -result {1 {*}} +} -match glob -result {1 {*invalid octal number*}} test lindex-11.6 {bad octal} -body { set x -0o9 list [catch { lindex {a b c} $x } result] $result -} -match glob -result {1 {*}} +} -match glob -result {1 {*invalid octal number*}} # Indices relative to end test lindex-12.1 {index = end} { set x end @@ -314,15 +314,15 @@ set result } {{} {}} test lindex-12.6 {bad octal} -body { set x end-0o8 list [catch { lindex {a b c} $x } result] $result -} -match glob -result {1 {*}} +} -match glob -result {1 {*invalid octal number*}} test lindex-12.7 {bad octal} -body { set x end--0o9 list [catch { lindex {a b c} $x } result] $result -} -match glob -result {1 {*}} +} -match glob -result {1 {*invalid octal number*}} test lindex-12.8 {bad integer, not octal} { set x end-0a2 list [catch { lindex {a b c} $x } result] $result } {1 {bad index "end-0a2": must be integer?[+-]integer? or end?[+-]integer?}} test lindex-12.9 {obsolete test} { @@ -439,20 +439,20 @@ } {} test lindex-17.0 {Bug 1718580} {*}{ -body { lindex {} end foo - } + } -match glob -result {bad index "foo"*} -returnCodes 1 } test lindex-17.1 {Bug 1718580} {*}{ -body { lindex a end foo - } + } -match glob -result {bad index "foo"*} -returnCodes 1 } Index: tests/link.test ================================================================== --- tests/link.test +++ tests/link.test @@ -10,19 +10,18 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] testConstraint testlink [llength [info commands testlink]] -testConstraint testlinkarray [llength [info commands testlinkarray]] foreach i {int real bool string} { unset -nocomplain $i } @@ -97,11 +96,11 @@ testlink delete } -constraints {testlink} -body { testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 list [catch {set wide gorp} msg] $msg $bool -} -result {1 {can't set "wide": variable must have wide integer value} 1} +} -result {1 {can't set "wide": variable must have integer value} 1} test link-2.6 {writing C variables from Tcl} -constraints {testlink} -setup { testlink delete } -body { testlink set 43 1.21 4 - 56785678 64 250 30000 60000 0xbaadbeef 12321 32123 3.25 1231231234 testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 @@ -182,31 +181,10 @@ set ulong 0 set float -60.00e+ set uwide 0 concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide } -result {0 5000.0 0 0 0 0 0 0 0 0 0 0 -60.0 0 | 0 5000e 0 0 0 0 0 0 0 0 0 0 -60.00e+ 0} -test link-2.10 {writing C variables from Tcl} -constraints {testlink} -setup { - testlink delete -} -body { - testlink set 43 1.21 4 - 56785678 64 250 30000 60000 0xbaadbeef 12321 32123 3.25 1231231234 - testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 - set int "0x" - set real "0b" - set bool 0 - set string "0" - set wide "0D" - set char "0X" - set uchar "0B" - set short "0D" - set ushort "0x" - set uint "0b" - set long "0d" - set ulong "0X" - set float "0B" - set uwide "0D" - concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide -} -result {0 0.0 0 0 0 0 0 0 0 0 0 0 0.0 0 | 0x 0b 0 0 0D 0X 0B 0D 0x 0b 0d 0X 0B 0D} test link-3.1 {read-only variables} -constraints {testlink} -setup { testlink delete } -body { testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 @@ -372,11 +350,11 @@ set y abc } testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 testlink set -4 16.3 1 {} 778899 {} {} {} {} {} {} {} {} {} list [catch x msg] $msg $wide -} -result {1 {can't set "y": variable must have wide integer value} 778899} +} -result {1 {can't set "y": variable must have integer value} 778899} test link-8.1 {Tcl_UpdateLinkedVar procedure} {testlink} { proc x args { global x int real bool string wide lappend x $args $int $real $bool $string $wide @@ -407,481 +385,10 @@ testlink create 0 0 0 0 0 0 0 0 0 0 0 0 0 0 list [catch { testlink update 47 {} {} {} {} {} {} {} {} {} {} {} {} {} } msg] $msg $int } {0 {} 47} - -test link-9.1 {linkarray usage messages} -returnCodes error -body { - testlinkarray -} -result {wrong # args: should be "testlinkarray option args"} -test link-9.2 {linkarray usage messages} -returnCodes error -body { - testlinkarray x -} -result {bad option "x": must be update, remove, or create} -test link-9.3 {linkarray usage messages} -body { - testlinkarray update -} -result {} -test link-9.4 {linkarray usage messages} -body { - testlinkarray remove -} -result {} -test link-9.5 {linkarray usage messages} -returnCodes error -body { - testlinkarray create -} -result {wrong # args: should be "testlinkarray create ?-readonly? type size name ?address?"} -test link-9.6 {linkarray usage messages} -returnCodes error -body { - testlinkarray create xx 1 my -} -result {bad type "xx": must be char, uchar, short, ushort, int, uint, long, ulong, wide, uwide, float, double, string, char*, or binary} -test link-9.7 {linkarray usage messages} -returnCodes error -body { - testlinkarray create char* 0 my -} -result {wrong array size given} - -test link-10.1 {linkarray char*} -setup { - set mylist [list] -} -body { - testlinkarray create char* 1 ::my(var) - lappend mylist [set ::my(var) ""] - catch {set ::my(var) x} msg - lappend mylist $msg -} -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {{} {can't set "::my(var)": wrong size of char* value}} -test link-10.2 {linkarray char*} -body { - testlinkarray create char* 4 ::my(var) - set ::my(var) x - catch {set ::my(var) xyzz} msg - return $msg -} -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {can't set "::my(var)": wrong size of char* value} -test link-10.3 {linkarray char*} -body { - testlinkarray create -r char* 4 ::my(var) - catch {set ::my(var) x} msg - return $msg -} -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {can't set "::my(var)": linked variable is read-only} - -test link-11.1 {linkarray char} -setup { - set mylist [list] -} -body { - testlinkarray create char 1 ::my(var) - catch {set ::my(var) x} msg - lappend mylist $msg - lappend mylist [set ::my(var) 120] - catch {set ::my(var) 1234} msg - lappend mylist $msg -} -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {{can't set "::my(var)": variable must have char value} 120 {can't set "::my(var)": variable must have char value}} -test link-11.2 {linkarray char} -setup { - set mylist [list] -} -body { - testlinkarray create char 4 ::my(var) - catch {set ::my(var) {1 2 3}} msg - lappend mylist $msg - set ::my(var) {1 2 3 4} - lappend mylist $my(var) -} -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} -test link-11.3 {linkarray char} -body { - testlinkarray create -r char 2 ::my(var) - catch {set ::my(var) {1 2}} msg - return $msg -} -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {can't set "::my(var)": linked variable is read-only} - -test link-12.1 {linkarray unsigned char} -setup { - set mylist [list] -} -body { - testlinkarray create uchar 1 ::my(var) - catch {set ::my(var) x} msg - lappend mylist $msg - lappend mylist [set ::my(var) 120] - catch {set ::my(var) 1234} msg - lappend mylist $msg - catch {set ::my(var) -1} msg - lappend mylist $msg -} -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {{can't set "::my(var)": variable must have unsigned char value} 120 {can't set "::my(var)": variable must have unsigned char value} {can't set "::my(var)": variable must have unsigned char value}} -test link-12.2 {linkarray unsigned char} -setup { - set mylist [list] -} -body { - testlinkarray create uchar 4 ::my(var) - catch {set ::my(var) {1 2 3}} msg - lappend mylist $msg - set ::my(var) {1 2 3 4} - lappend mylist $my(var) -} -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} -test link-12.3 {linkarray unsigned char} -body { - testlinkarray create -r uchar 2 ::my(var) - catch {set ::my(var) {1 2}} msg - return $msg -} -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {can't set "::my(var)": linked variable is read-only} - -test link-13.1 {linkarray short} -setup { - set mylist [list] -} -body { - testlinkarray create short 1 ::my(var) - catch {set ::my(var) x} msg - lappend mylist $msg - lappend mylist [set ::my(var) 120] - catch {set ::my(var) 123456} msg - lappend mylist $msg -} -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {{can't set "::my(var)": variable must have short value} 120 {can't set "::my(var)": variable must have short value}} -test link-13.2 {linkarray short} -setup { - set mylist [list] -} -body { - testlinkarray create short 4 ::my(var) - catch {set ::my(var) {1 2 3}} msg - lappend mylist $msg - set ::my(var) {1 2 3 4} - lappend mylist $my(var) -} -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} -test link-13.3 {linkarray short} -body { - testlinkarray create -r short 2 ::my(var) - catch {set ::my(var) {1 2}} msg - return $msg -} -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {can't set "::my(var)": linked variable is read-only} - -test link-14.1 {linkarray unsigned short} -setup { - set mylist [list] -} -body { - testlinkarray create ushort 1 ::my(var) - catch {set ::my(var) x} msg - lappend mylist $msg - lappend mylist [set ::my(var) 120] - catch {set ::my(var) 123456} msg - lappend mylist $msg - catch {set ::my(var) -1} msg - lappend mylist $msg -} -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {{can't set "::my(var)": variable must have unsigned short value} 120 {can't set "::my(var)": variable must have unsigned short value} {can't set "::my(var)": variable must have unsigned short value}} -test link-14.2 {linkarray unsigned short} -setup { - set mylist [list] -} -body { - testlinkarray create ushort 4 ::my(var) - catch {set ::my(var) {1 2 3}} msg - lappend mylist $msg - set ::my(var) {1 2 3 4} - lappend mylist $my(var) -} -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} -test link-14.3 {linkarray unsigned short} -body { - testlinkarray create -r ushort 2 ::my(var) - catch {set ::my(var) {1 2}} msg - return $msg -} -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {can't set "::my(var)": linked variable is read-only} - -test link-15.1 {linkarray int} -setup { - set mylist [list] -} -body { - testlinkarray create int 1 ::my(var) - catch {set ::my(var) x} msg - lappend mylist $msg - lappend mylist [set ::my(var) 120] - catch {set ::my(var) 1e3} msg - lappend mylist $msg -} -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {{can't set "::my(var)": variable must have integer value} 120 {can't set "::my(var)": variable must have integer value}} -test link-15.2 {linkarray int} -setup { - set mylist [list] -} -body { - testlinkarray create int 4 ::my(var) - catch {set ::my(var) {1 2 3}} msg - lappend mylist $msg - set ::my(var) {1 2 3 4} - lappend mylist $my(var) -} -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} -test link-15.3 {linkarray int} -body { - testlinkarray create -r int 2 ::my(var) - catch {set ::my(var) {1 2}} msg - return $msg -} -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {can't set "::my(var)": linked variable is read-only} - -test link-16.1 {linkarray unsigned int} -setup { - set mylist [list] -} -body { - testlinkarray create uint 1 ::my(var) - catch {set ::my(var) x} msg - lappend mylist $msg - lappend mylist [set ::my(var) 120] - catch {set ::my(var) 1e33} msg - lappend mylist $msg - catch {set ::my(var) -1} msg - lappend mylist $msg -} -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain ::my -} -result {{can't set "::my(var)": variable must have unsigned int value} 120 {can't set "::my(var)": variable must have unsigned int value} {can't set "::my(var)": variable must have unsigned int value}} -test link-16.2 {linkarray unsigned int} -setup { - set mylist [list] -} -body { - testlinkarray create uint 4 ::my(var) - catch {set ::my(var) {1 2 3}} msg - lappend mylist $msg - set ::my(var) {1 2 3 4} - lappend mylist $my(var) -} -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain ::my -} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} -test link-16.3 {linkarray unsigned int} -body { - testlinkarray create -r uint 2 ::my(var) - catch {set ::my(var) {1 2}} msg - return $msg -} -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {can't set "::my(var)": linked variable is read-only} - -test link-17.1 {linkarray long} -setup { - set mylist [list] -} -body { - testlinkarray create long 1 ::my(var) - catch {set ::my(var) x} msg - lappend mylist $msg - lappend mylist [set ::my(var) 120] - catch {set ::my(var) 1e33} msg - lappend mylist $msg -} -match glob -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {{can't set "::my(var)": variable must have * value} 120 {can't set "::my(var)": variable must have * value}} -test link-17.2 {linkarray long} -setup { - set mylist [list] -} -body { - testlinkarray create long 4 ::my(var) - catch {set ::my(var) {1 2 3}} msg - lappend mylist $msg - set ::my(var) {1 2 3 4} - lappend mylist $my(var) -} -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} -test link-17.3 {linkarray long} -body { - testlinkarray create -r long 2 ::my(var) - catch {set ::my(var) {1 2}} msg - return $msg -} -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {can't set "::my(var)": linked variable is read-only} - -test link-18.1 {linkarray unsigned long} -setup { - set mylist [list] -} -body { - testlinkarray create ulong 1 ::my(var) - catch {set ::my(var) x} msg - lappend mylist $msg - lappend mylist [set ::my(var) 120] - catch {set ::my(var) 1e33} msg - lappend mylist $msg -} -match glob -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {{can't set "::my(var)": variable must have unsigned * value} 120 {can't set "::my(var)": variable must have unsigned * value}} -test link-18.2 {linkarray unsigned long} -body { - testlinkarray create ulong 1 ::my(var) - set ::my(var) 120 - catch {set ::my(var) -1} msg - return $msg -} -match glob -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {can't set "::my(var)": variable must have unsigned * value} -test link-18.3 {linkarray unsigned long} -setup { - set mylist [list] -} -body { - testlinkarray create ulong 4 ::my(var) - catch {set ::my(var) {1 2 3}} msg - lappend mylist $msg - set ::my(var) {1 2 3 4} - lappend mylist $my(var) -} -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} -test link-18.4 {linkarray unsigned long} -body { - testlinkarray create -r ulong 2 ::my(var) - catch {set ::my(var) {1 2}} msg - return $msg -} -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {can't set "::my(var)": linked variable is read-only} - -test link-19.1 {linkarray wide} -setup { - set mylist [list] -} -body { - testlinkarray create wide 1 ::my(var) - catch {set ::my(var) x} msg - lappend mylist $msg - lappend mylist [set ::my(var) 120] - catch {set ::my(var) 1e33} msg - lappend mylist $msg -} -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {{can't set "::my(var)": variable must have wide integer value} 120 {can't set "::my(var)": variable must have wide integer value}} -test link-19.2 {linkarray wide} -setup { - set mylist [list] -} -body { - testlinkarray create wide 4 ::my(var) - catch {set ::my(var) {1 2 3}} msg - lappend mylist $msg - set ::my(var) {1 2 3 4} - lappend mylist $my(var) -} -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} -test link-19.3 {linkarray wide} -body { - testlinkarray create -r wide 2 ::my(var) - catch {set ::my(var) {1 2}} msg - return $msg -} -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {can't set "::my(var)": linked variable is read-only} - -test link-20.1 {linkarray unsigned wide} -setup { - set mylist [list] -} -body { - testlinkarray create uwide 1 ::my(var) - catch {set ::my(var) x} msg - lappend mylist $msg - lappend mylist [set ::my(var) 120] - catch {set ::my(var) 1e33} msg - lappend mylist $msg - lappend mylist [set ::my(var) 0xbabed00dbabed00d] -} -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {{can't set "::my(var)": variable must have unsigned wide int value} 120 {can't set "::my(var)": variable must have unsigned wide int value} 0xbabed00dbabed00d} -test link-20.2 {linkarray unsigned wide} -body { - testlinkarray create uwide 1 ::my(var) - set ::my(var) 120 - catch {set ::my(var) -1} msg - return $msg -} -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {can't set "::my(var)": variable must have unsigned wide int value} -test link-20.3 {linkarray unsigned wide} -setup { - set mylist [list] -} -body { - testlinkarray create uwide 4 ::my(var) - catch {set ::my(var) {1 2 3}} msg - lappend mylist $msg - set ::my(var) {1 2 3 4} - lappend mylist $my(var) -} -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} -test link-20.4 {linkarray unsigned wide} -body { - testlinkarray create -r uwide 2 ::my(var) - catch {set ::my(var) {1 2}} msg - return $msg -} -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {can't set "::my(var)": linked variable is read-only} - -test link-21.1 {linkarray string} -setup { - set mylist [list] -} -body { - testlinkarray create string 1 ::my(var) - lappend mylist [set ::my(var) ""] - lappend mylist [set ::my(var) "xyz"] - lappend mylist $::my(var) -} -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {{} xyz xyz} -test link-21.2 {linkarray string} -body { - testlinkarray create -r string 4 ::my(var) - catch {set ::my(var) x} msg - return $msg -} -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {can't set "::my(var)": linked variable is read-only} - -test link-22.1 {linkarray binary} -setup { - set mylist [list] -} -body { - testlinkarray create binary 1 ::my(var) - set ::my(var) x - catch {set ::my(var) xy} msg - lappend mylist $msg - lappend mylist $::my(var) -} -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {{can't set "::my(var)": wrong size of binary value} x} -test link-22.2 {linkarray binary} -setup { - set mylist [list] -} -body { - testlinkarray create binary 4 ::my(var) - catch {set ::my(var) abc} msg - lappend mylist $msg - catch {set ::my(var) abcde} msg - lappend mylist $msg - set ::my(var) abcd - lappend mylist $::my(var) -} -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {{can't set "::my(var)": wrong size of binary value} {can't set "::my(var)": wrong size of binary value} abcd} -test link-22.3 {linkarray binary} -body { - testlinkarray create -r binary 4 ::my(var) - catch {set ::my(var) xyzv} msg - return $msg -} -cleanup { - testlinkarray remove ::my(var) - unset -nocomplain my -} -result {can't set "::my(var)": linked variable is read-only} catch {testlink set 0 0 0 - 0 0 0 0 0 0 0 0 0 0} catch {testlink delete} foreach i {int real bool string wide} { unset -nocomplain $i Index: tests/linsert.test ================================================================== --- tests/linsert.test +++ tests/linsert.test @@ -9,12 +9,12 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } catch {unset lis} catch {rename p ""} Index: tests/list.test ================================================================== --- tests/list.test +++ tests/list.test @@ -9,12 +9,12 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } # First, a bunch of individual tests @@ -96,30 +96,30 @@ # Check that tclListObj.c's SetListFromAny handles possible overlarge # string rep lengths in the source object. proc slowsort list { set result {} - set last [expr [llength $list] - 1] + set last [expr {[llength $list] - 1}] while {$last > 0} { - set minIndex [expr [llength $list] - 1] + set minIndex [expr {[llength $list] - 1}] set min [lindex $list $last] - set i [expr $minIndex-1] + set i [expr {$minIndex - 1}] while {$i >= 0} { if {[string compare [lindex $list $i] $min] < 0} { set minIndex $i set min [lindex $list $i] } - set i [expr $i-1] + incr i -1 } set result [concat $result [list $min]] if {$minIndex == 0} { set list [lrange $list 1 end] } else { - set list [concat [lrange $list 0 [expr $minIndex-1]] \ - [lrange $list [expr $minIndex+1] end]] + set list [concat [lrange $list 0 [expr {$minIndex - 1}]] \ + [lrange $list [expr {$minIndex + 1}] end]] } - set last [expr $last-1] + set last [expr {$last - 1}] } return [concat $result $list] } test list-3.1 {SetListFromAny and lrange/concat results} { slowsort {fred julie alex carol bill annie} Index: tests/listObj.test ================================================================== --- tests/listObj.test +++ tests/listObj.test @@ -9,12 +9,12 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] Index: tests/llength.test ================================================================== --- tests/llength.test +++ tests/llength.test @@ -9,12 +9,12 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } test llength-1.1 {length of list} { llength {a b c d} Index: tests/lmap.test ================================================================== --- tests/lmap.test +++ tests/lmap.test @@ -12,11 +12,11 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: $ if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } unset -nocomplain a b i x @@ -218,14 +218,14 @@ test lmap-4.14 {lmap errors} -returnCodes error -body { apply {{} { lmap a {{1 2}3} {} }} } -result {list element in braces followed by "3" instead of space} unset -nocomplain a test lmap-4.15 {lmap errors} { - apply {{} { + apply {{} { set a(0) 44 - list [catch {lmap a {1 2 3} {}} msg o] $msg $::errorInfo - }} + list [catch {lmap a {1 2 3} {}} msg o] $msg $::errorInfo + }} } {1 {can't set "a": variable is array} {can't set "a": variable is array while executing "lmap a {1 2 3} {}"}} test lmap-4.16 {lmap errors} -returnCodes error -body { apply {{} { Index: tests/load.test ================================================================== --- tests/load.test +++ tests/load.test @@ -8,12 +8,12 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -43,34 +43,34 @@ # Test load-10.1 requires the 'testsimplefilesystem' command from tcltest testConstraint testsimplefilesystem \ [llength [info commands testsimplefilesystem]] -test load-1.1 {basic errors} {} { - list [catch {load} msg] $msg -} "1 {wrong \# args: should be \"load ?-global? ?-lazy? ?--? fileName ?packageName? ?interp?\"}" -test load-1.2 {basic errors} {} { - list [catch {load a b c d} msg] $msg -} "1 {wrong \# args: should be \"load ?-global? ?-lazy? ?--? fileName ?packageName? ?interp?\"}" -test load-1.3 {basic errors} {} { - list [catch {load a b foobar} msg] $msg -} {1 {could not find interpreter "foobar"}} -test load-1.4 {basic errors} {} { - list [catch {load -global {}} msg] $msg -} {1 {must specify either file name or package name}} -test load-1.5 {basic errors} {} { - list [catch {load -lazy {} {}} msg] $msg -} {1 {must specify either file name or package name}} -test load-1.6 {basic errors} {} { - list [catch {load {} Unknown} msg] $msg -} {1 {package "Unknown" isn't loaded statically}} -test load-1.7 {basic errors} {} { - list [catch {load -abc foo} msg] $msg -} "1 {bad option \"-abc\": must be -global, -lazy, or --}" -test load-1.8 {basic errors} {} { - list [catch {load -global} msg] $msg -} "1 {couldn't figure out package name for -global}" +test load-1.1 {basic errors} -returnCodes error -body { + load +} -result {wrong # args: should be "load ?-global? ?-lazy? ?--? fileName ?packageName? ?interp?"} +test load-1.2 {basic errors} -returnCodes error -body { + load a b c d +} -result {wrong # args: should be "load ?-global? ?-lazy? ?--? fileName ?packageName? ?interp?"} +test load-1.3 {basic errors} -returnCodes error -body { + load a b foobar +} -result {could not find interpreter "foobar"} +test load-1.4 {basic errors} -returnCodes error -body { + load -global {} +} -result {must specify either file name or package name} +test load-1.5 {basic errors} -returnCodes error -body { + load -lazy {} {} +} -result {must specify either file name or package name} +test load-1.6 {basic errors} -returnCodes error -body { + load {} Unknown +} -result {package "Unknown" isn't loaded statically} +test load-1.7 {basic errors} -returnCodes error -body { + load -abc foo +} -result {bad option "-abc": must be -global, -lazy, or --} +test load-1.8 {basic errors} -returnCodes error -body { + load -global +} -result {couldn't figure out package name for -global} test load-2.1 {basic loading, with guess for package name} \ [list $dll $loaded] { load -global [file join $testDir pkga$ext] list [pkga_eq abc def] [lsort [info commands pkga_*]] @@ -101,11 +101,11 @@ "open non_existent" invoked from within "if 44 {open non_existent}" invoked from within "load [file join $testDir pkge$ext] pkge"} {POSIX ENOENT {no such file or directory}}} -test load-3.2 {error in _Init procedure, slave interpreter} \ +test load-3.2 {error in _Init procedure, child interpreter} \ [list $dll $loaded] { catch {interp delete x} interp create x set ::errorCode foo set ::errorInfo bar @@ -128,20 +128,20 @@ catch {load [file join $testDir pkga$ext] pkga} } -constraints [list $dll $loaded] -returnCodes error -body { load [file join $testDir pkga$ext] pkgb } -result "file \"[file join $testDir pkga$ext]\" is already loaded for package \"Pkga\"" -test load-5.1 {file name not specified and no static package: pick default} \ - [list $dll $loaded] { +test load-5.1 {file name not specified and no static package: pick default} -setup { catch {interp delete x} interp create x +} -constraints [list $dll $loaded] -body { load -global [file join $testDir pkga$ext] pkga load {} pkga x - set result [info loaded x] + info loaded x +} -cleanup { interp delete x - set result -} [list [list [file join $testDir pkga$ext] Pkga]] +} -result [list [list [file join $testDir pkga$ext] Pkga]] # On some platforms, like SunOS 4.1.3, these tests can't be run because # they cause the process to exit. # # As of 2005, such ancient broken systems no longer matter. @@ -183,20 +183,20 @@ teststaticpkg Double 0 1 teststaticpkg Double 0 1 info loaded } -result [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealPackages {*}$alreadyTotalLoaded] -testConstraint teststaticpkg_8.x \ - [if {[testConstraint teststaticpkg]} { +testConstraint teststaticpkg_8.x 0 +if {[testConstraint teststaticpkg]} { + catch { teststaticpkg Test 1 1 teststaticpkg Another 0 1 teststaticpkg More 0 1 teststaticpkg Double 0 1 - expr 1 - } else { - expr 0 - }] + testConstraint teststaticpkg_8.x 1 + } +} test load-8.1 {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { lsort -index 1 [info loaded] } [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealPackages {*}$alreadyTotalLoaded]] test load-8.2 {TclGetLoadedPackages procedure} -constraints {teststaticpkg_8.x} -body { @@ -212,34 +212,36 @@ load [file join $testDir pkgb$ext] pkgb list [lsort -index 1 [info loaded {}]] [lsort [info commands pkgb_*]] } [list [lsort -index 1 [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded]] {pkgb_demo pkgb_sub pkgb_unsafe}] interp delete child -test load-9.1 {Tcl_StaticPackage, load already-loaded package into another interp} \ - -constraints {teststaticpkg} \ - -setup { - interp create child1 - interp create child2 - load {} Tcltest child1 - load {} Tcltest child2 - } \ - -body { - child1 eval { teststaticpkg Loadninepointone 0 1 } - child2 eval { teststaticpkg Loadninepointone 0 1 } - list \ - [child1 eval { info loaded {} }] \ - [child2 eval { info loaded {} }] - } \ - -match glob -result {{{{} Loadninepointone} {* Tcltest}} {{{} Loadninepointone} {* Tcltest}}} \ - -cleanup { interp delete child1 ; interp delete child2 } - -test load-10.1 {load from vfs} \ - -constraints [list $dll $loaded testsimplefilesystem] \ - -setup {set dir [pwd]; cd $testDir; testsimplefilesystem 1} \ - -body {list [catch {load simplefs:/pkgd$ext pkgd} msg] $msg} \ - -result {0 {}} \ - -cleanup {testsimplefilesystem 0; cd $dir; unset dir} +test load-9.1 {Tcl_StaticPackage, load already-loaded package into another interp} -setup { + interp create child1 + interp create child2 + load {} Tcltest child1 + load {} Tcltest child2 +} -constraints {teststaticpkg} -body { + child1 eval { teststaticpkg Loadninepointone 0 1 } + child2 eval { teststaticpkg Loadninepointone 0 1 } + list [child1 eval { info loaded {} }] \ + [child2 eval { info loaded {} }] +} -match glob -cleanup { + interp delete child1 + interp delete child2 +} -result {{{{} Loadninepointone} {* Tcltest}} {{{} Loadninepointone} {* Tcltest}}} + +test load-10.1 {load from vfs} -setup { + set dir [pwd] + cd $testDir + testsimplefilesystem 1 +} -constraints [list $dll $loaded testsimplefilesystem] -body { + list [catch {load simplefs:/pkgd$ext pkgd} msg] $msg +} -result {0 {}} -cleanup { + testsimplefilesystem 0 + cd $dir + unset dir +} test load-11.1 {Load TclOO extension using Stubs (Bug [f51efe99a7])} \ [list $dll $loaded] { load [file join $testDir pkgooa$ext] list [pkgooa_stubsok] [lsort [info commands pkgooa_*]] DELETED tests/lpop.test Index: tests/lpop.test ================================================================== --- tests/lpop.test +++ /dev/null @@ -1,140 +0,0 @@ -# Commands covered: lpop -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import -force ::tcltest::* -} - -test lpop-1.1 {error conditions} -returnCodes error -body { - lpop no -} -result {can't read "no": no such variable} -test lpop-1.2 {error conditions} -returnCodes error -body { - lpop no 0 -} -result {can't read "no": no such variable} -test lpop-1.3 {error conditions} -returnCodes error -body { - set no "x {}x" - lpop no -} -result {list element in braces followed by "x" instead of space} -test lpop-1.4 {error conditions} -returnCodes error -body { - set no "x y" - lpop no -1 -} -result {list index out of range} -test lpop-1.5 {error conditions} -returnCodes error -body { - set no "x y z" - lpop no 3 -} -result {list index out of range} ;#-errorCode {TCL OPERATION LPOP BADINDEX} -test lpop-1.6 {error conditions} -returnCodes error -body { - set no "x y" - lpop no end+1 -} -result {list index out of range} -test lpop-1.7 {error conditions} -returnCodes error -body { - set no "x y" - lpop no {} -} -match glob -result {bad index *} -test lpop-1.8 {error conditions} -returnCodes error -body { - set no "x y" - lpop no 0 0 0 0 1 -} -result {list index out of range} -test lpop-1.9 {error conditions} -returnCodes error -body { - set no "x y" - lpop no {1 0} -} -match glob -result {bad index *} - -test lpop-2.1 {basic functionality} -body { - set l "x y z" - list [lpop l 0] $l -} -result {x {y z}} -test lpop-2.2 {basic functionality} -body { - set l "x y z" - list [lpop l 1] $l -} -result {y {x z}} -test lpop-2.3 {basic functionality} -body { - set l "x y z" - list [lpop l] $l -} -result {z {x y}} -test lpop-2.4 {basic functionality} -body { - set l "x y z" - set l2 $l - list [lpop l] $l $l2 -} -result {z {x y} {x y z}} - -test lpop-3.1 {nested} -body { - set l "x y" - set l2 $l - list [lpop l 0 0 0 0] $l $l2 -} -result {x {{{{}}} y} {x y}} -test lpop-3.2 {nested} -body { - set l "{x y} {a b}" - list [lpop l 0 1] $l -} -result {y {x {a b}}} -test lpop-3.3 {nested} -body { - set l "{x y} {a b}" - list [lpop l 1 0] $l -} -result {a {{x y} b}} - - - - - -test lpop-99.1 {performance} -constraints perf -body { - set l [lrepeat 10000 x] - set l2 $l - set t1 [time { - while {[llength $l] >= 2} { - lpop l end - } - }] - set l [lrepeat 30000 x] - set l2 $l - set t2 [time { - while {[llength $l] >= 2} { - lpop l end - } - }] - regexp {\d+} $t1 ms1 - regexp {\d+} $t2 ms2 - set ratio [expr {double($ms2)/$ms1}] - # Deleting from end should have linear performance - expr {$ratio > 4 ? $ratio : 4} -} -result {4} - -test lpop-99.2 {performance} -constraints perf -body { - set l [lrepeat 10000 x] - set l2 $l - set t1 [time { - while {[llength $l] >= 2} { - lpop l 1 - } - }] - set l [lrepeat 30000 x] - set l2 $l - set t2 [time { - while {[llength $l] >= 2} { - lpop l 1 - } - }] - regexp {\d+} $t1 ms1 - regexp {\d+} $t2 ms2 - set ratio [expr {double($ms2)/$ms1}] - expr {$ratio > 10 ? $ratio : 10} -} -result {10} - - -# cleanup -::tcltest::cleanupTests -return - -# Local Variables: -# mode: tcl -# End: Index: tests/lrange.test ================================================================== --- tests/lrange.test +++ tests/lrange.test @@ -9,12 +9,12 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -67,11 +67,11 @@ test lrange-1.15 {range of list elements} { concat \"[lrange {a b \{\ } 0 2]" } {"a b \{\ "} # emacs highlighting bug workaround --> " test lrange-1.16 {list element quoting} { - lrange {[append a .b]} 0 end + lrange {[append a .b]} 0 end } {{[append} a .b\]} test lrange-2.1 {error conditions} { list [catch {lrange a b} msg] $msg } {1 {wrong # args: should be "lrange list first last"}} @@ -94,10 +94,11 @@ test lrange-3.1 {Bug 3588366: end-offsets before start} { apply {l { lrange $l 0 end-5 }} {1 2 3 4 5} } {} + test lrange-3.2 {compiled with static indices out of range, negative} { list [lrange {a b c} -1 -2] [lrange {a b c} -2 -1] [lrange {a b c} -3 -2] [lrange {a b c} -2 -3] } [lrepeat 4 {}] test lrange-3.3 {compiled with calculated indices out of range, negative constant} { list [lrange {a b c} 0-1 -1-1] [lrange {a b c} -2+0 0-1] [lrange {a b c} -2-1 -2+1] [lrange {a b c} -2+1 -2-1] @@ -131,124 +132,27 @@ test lrange-3.7b.2 {not compiled on empty not list object, 2nd regression test, bug [cc1e91552c]} { set cmd lrange list [$cmd {} 0 1] [$cmd [lindex a -1] 0 1] [$cmd [set a {}] 0 1] \ [$cmd {} 0-1 end+1] [$cmd [lindex a -1] 0-1 end+1] [$cmd $a 0-1 end+1] } [lrepeat 6 {}] -test lrange-3.7c.2 {compiled on empty pure bytes object, 2nd regression test, bug [cc1e91552c]} { +test lrange-3.7c.2 {compiled on empty pure bytes object, 2nd regression test, bug [cc1e91552c]} -constraints { + testpurebytesobj +} -body { list [lrange [testpurebytesobj] 0 1] [lrange [testpurebytesobj { }] 0 1] [lrange [set a [testpurebytesobj {}]] 0 1] \ [lrange [testpurebytesobj] 0-1 end+1] [lrange [testpurebytesobj { }] 0-1 end+1] [lrange $a 0-1 end+1] -} [lrepeat 6 {}] -test lrange-3.7d.2 {not compiled on empty pure bytes object, 2nd regression test, bug [cc1e91552c]} { +} -result [lrepeat 6 {}] +test lrange-3.7d.2 {not compiled on empty pure bytes object, 2nd regression test, bug [cc1e91552c]} -constraints { + testpurebytesobj +} -body { set cmd lrange list [$cmd [testpurebytesobj] 0 1] [$cmd [testpurebytesobj { }] 0 1] [$cmd [set a [testpurebytesobj {}]] 0 1] \ [$cmd [testpurebytesobj] 0-1 end+1] [$cmd [testpurebytesobj { }] 0-1 end+1] [$cmd $a 0-1 end+1] -} [lrepeat 6 {}] - -test lrange-4.1 {lrange pure promise} -body { - set ll1 [list $tcl_version 2 3 4] - # Shared - set ll2 $ll1 - # With string rep - string length $ll1 - set rep1 [tcl::unsupported::representation $ll1] - # Get new pure object - set x [lrange $ll1 0 end] - set rep2 [tcl::unsupported::representation $x] - regexp {object pointer at (\S+)} $rep1 -> obj1 - regexp {object pointer at (\S+)} $rep2 -> obj2 - list $rep1 $rep2 [string equal $obj1 $obj2] - # Check for a new clean object -} -match glob -result {*value is *refcount of 3,*, string rep*value is*refcount of 2,* no string rep* 0} - -test lrange-4.2 {lrange pure promise} -body { - set ll1 [list $tcl_version 2 3 4] - # Shared - set ll2 $ll1 - # With string rep - string length $ll1 - set rep1 [tcl::unsupported::representation $ll1] - # Get new pure object, not compiled - set x [[string cat l range] $ll1 0 end] - set rep2 [tcl::unsupported::representation $x] - regexp {object pointer at (\S+)} $rep1 -> obj1 - regexp {object pointer at (\S+)} $rep2 -> obj2 - list $rep1 $rep2 [string equal $obj1 $obj2] - # Check for a new clean object -} -match glob -result {*value is *refcount of 3,*, string rep*value is*refcount of 2,* no string rep* 0} - -test lrange-4.3 {lrange pure promise} -body { - set ll1 [list $tcl_version 2 3 4] - # With string rep - string length $ll1 - set rep1 [tcl::unsupported::representation $ll1] - # Get pure object, unshared - set ll2 [lrange $ll1[set ll1 {}] 0 end] - set rep2 [tcl::unsupported::representation $ll2] - regexp {object pointer at (\S+)} $rep1 -> obj1 - regexp {object pointer at (\S+)} $rep2 -> obj2 - list $rep1 $rep2 [string equal $obj1 $obj2] - # Internal optimisations should keep the same object -} -match glob -result {*value is *refcount of 2,*, string rep*value is*refcount of 2,* no string rep* 1} - -test lrange-4.4 {lrange pure promise} -body { - set ll1 [list $tcl_version 2 3 4] - # With string rep - string length $ll1 - set rep1 [tcl::unsupported::representation $ll1] - # Get pure object, unshared, not compiled - set ll2 [[string cat l range] $ll1[set ll1 {}] 0 end] - set rep2 [tcl::unsupported::representation $ll2] - regexp {object pointer at (\S+)} $rep1 -> obj1 - regexp {object pointer at (\S+)} $rep2 -> obj2 - list $rep1 $rep2 [string equal $obj1 $obj2] - # Internal optimisations should keep the same object -} -match glob -result {*value is *refcount of 2,*, string rep*value is*refcount of 2,* no string rep* 1} - -# Testing for compiled vs non-compiled behaviour, and shared vs non-shared. -# Far too many variations to check with spelt-out tests. -# Note that this *just* checks whether the different versions are the same -# not whether any of them is correct. -apply {{} { - set lss {{} {a} {a b c} {a b c d}} - set idxs {-2 -1 0 1 2 3 end-3 end-2 end-1 end end+1 end+2} - set lrange lrange - - foreach ls $lss { - foreach a $idxs { - foreach b $idxs { - # Shared, uncompiled - set ls2 $ls - set expected [list [catch {$lrange $ls $a $b} m] $m] - # Shared, compiled - set tester [list lrange $ls $a $b] - set script [list catch $tester m] - set script "list \[$script\] \$m" - test lrange-5.[incr n].1 {lrange shared compiled} \ - [list apply [list {} $script]] $expected - # Unshared, uncompiled - set tester [string map [list %l [list $ls] %a $a %b $b] { - [string cat l range] [lrange %l 0 end] %a %b - }] - set script [list catch $tester m] - set script "list \[$script\] \$m" - test lrange-5.$n.2 {lrange unshared uncompiled} \ - [list apply [list {} $script]] $expected - # Unshared, compiled - set tester [string map [list %l [list $ls] %a $a %b $b] { - lrange [lrange %l 0 end] %a %b - }] - set script [list catch $tester m] - set script "list \[$script\] \$m" - test lrange-5.$n.3 {lrange unshared compiled} \ - [list apply [list {} $script]] $expected - } - } - } -}} +} -result [lrepeat 6 {}] + # cleanup ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: Index: tests/lrepeat.test ================================================================== --- tests/lrepeat.test +++ tests/lrepeat.test @@ -7,12 +7,12 @@ # Copyright (c) 2003 by Simon Geard. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ## Arg errors test lrepeat-1.1 {error cases} { @@ -38,11 +38,11 @@ test lrepeat-1.4 {error cases} { -body { lrepeat -3 1 } -returnCodes 1 - -result {bad count "-3": must be integer >= 0} + -result {bad count "-3": must be integer >= 0} } test lrepeat-1.5 {Accept zero repetitions (TIP 323)} { -body { lrepeat 0 } @@ -51,11 +51,11 @@ test lrepeat-1.6 {error cases} { -body { lrepeat 3.5 1 } -returnCodes 1 - -result {expected integer but got "3.5"} + -result {expected integer but got "3.5"} } test lrepeat-1.7 {Accept zero repetitions (TIP 323)} { -body { lrepeat 0 a b c } Index: tests/lreplace.test ================================================================== --- tests/lreplace.test +++ tests/lreplace.test @@ -9,12 +9,12 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } test lreplace-1.1 {lreplace command} { lreplace {1 2 3 4 5} 0 0 a Index: tests/lsearch.test ================================================================== --- tests/lsearch.test +++ tests/lsearch.test @@ -10,11 +10,11 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } set x {abcd bbcd 123 234 345} test lsearch-1.1 {lsearch command} { @@ -57,11 +57,11 @@ test lsearch-2.9 {search modes} { lsearch -glob {b.x ^bc xy bcx} ^bc } 1 test lsearch-2.10 {search modes} -returnCodes error -body { lsearch -glib {b.x bx xy bcx} b.x -} -result {bad option "-glib": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, -stride, or -subindices} +} -result {bad option "-glib": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices} test lsearch-2.11 {search modes with -nocase} { lsearch -exact -nocase {a b c A B C} A } 0 test lsearch-2.12 {search modes with -nocase} { lsearch -glob -nocase {a b c A B C} A* @@ -85,14 +85,14 @@ test lsearch-3.2 {lsearch errors} -returnCodes error -body { lsearch a } -result {wrong # args: should be "lsearch ?-option value ...? list pattern"} test lsearch-3.3 {lsearch errors} -returnCodes error -body { lsearch a b c -} -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, -stride, or -subindices} +} -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices} test lsearch-3.4 {lsearch errors} -returnCodes error -body { lsearch a b c d -} -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, -stride, or -subindices} +} -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices} test lsearch-3.5 {lsearch errors} -returnCodes error -body { lsearch "\{" b } -result {unmatched open brace in list} test lsearch-3.6 {lsearch errors} -returnCodes error -body { lsearch -index a b @@ -147,18 +147,18 @@ lappend res [lsearch -integer -decreasing -sorted \ $decreasingIntegers $i] } set res } $decreasingIntegers -test lsearch-5.3 {binary search finds leftmost occurances} { +test lsearch-5.3 {binary search finds leftmost occurrences} { set res {} for {set i 0} {$i < 10} {incr i} { lappend res [lsearch -integer -sorted $repeatingIncreasingIntegers $i] } set res } [list 0 5 10 15 20 25 30 35 40 45] -test lsearch-5.4 {binary search -decreasing finds leftmost occurances} { +test lsearch-5.4 {binary search -decreasing finds leftmost occurrences} { set res {} for {set i 9} {$i >= 0} {incr i -1} { lappend res [lsearch -sorted -integer -decreasing \ $repeatingDecreasingIntegers $i] } @@ -382,11 +382,11 @@ test lsearch-14.8 {combinations: -start, -inline and -not} { lsearch -start 2 -inline -not -glob {a1 b2 a3 c4 a5 d6} a* } {c4} test lsearch-15.1 {make sure no shimmering occurs} { - set x [expr int(sin(0))] + set x [expr {int(sin(0))}] lsearch -start $x $x $x } 0 test lsearch-16.1 {lsearch -regexp shared object} { set str a @@ -476,13 +476,10 @@ lsearch -subindices -index {0 1} -regexp {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} {[cb]b} } {0 0 1} test lsearch-19.5 {lsearch -subindices option} { lsearch -subindices -all -index {0 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a } {{0 0 0} {1 0 0}} -test lsearch-19.6 {lsearch -subindices option} { - lsearch -subindices -all -index {1 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a -} {{0 1 0} {1 1 0}} test lsearch-19.7 {lsearch -subindices option} { lsearch -subindices -index end {{1 a}} a } {0 1} test lsearch-19.8 {lsearch -subindices option} { lsearch -subindices -all -index end {{1 a}} a @@ -544,153 +541,10 @@ lsearch -bisect -integer {5 5 5 5} 5 } {3} test lsearch-22.6 {lsearch -sorted, all equal} { lsearch -sorted -integer {5 5 5 5} 5 } {0} - -test lsearch-23.1 {lsearch -stride option, errors} -body { - lsearch -stride {a b} a -} -returnCodes error -result {"-stride" option must be followed by stride length} -test lsearch-23.2 {lsearch -stride option, errors} -body { - lsearch -stride 0 {a b} a -} -returnCodes error -result {stride length must be at least 1} -test lsearch-23.3 {lsearch -stride option, errors} -body { - lsearch -stride 2 {a b c} a -} -returnCodes error -result {list size must be a multiple of the stride length} -test lsearch-23.4 {lsearch -stride option, errors} -body { - lsearch -stride 5 {a b c} a -} -returnCodes error -result {list size must be a multiple of the stride length} -test lsearch-23.5 {lsearch -stride option, errors} -body { - # Stride equal to length is ok - lsearch -stride 3 {a b c} a -} -result 0 - -test lsearch-24.1 {lsearch -stride option} -body { - lsearch -stride 2 {a b c d e f g h} d -} -result -1 -test lsearch-24.2 {lsearch -stride option} -body { - lsearch -stride 2 {a b c d e f g h} e -} -result 4 -test lsearch-24.3 {lsearch -stride option} -body { - lsearch -stride 3 {a b c d e f g h i} e -} -result -1 -test lsearch-24.4 {lsearch -stride option} -body { - # Result points first in group - lsearch -stride 3 -index 1 {a b c d e f g h i} e -} -result 3 -test lsearch-24.5 {lsearch -stride option} -body { - lsearch -inline -stride 2 {a b c d e f g h} d -} -result {} -test lsearch-24.6 {lsearch -stride option} -body { - # Inline result is a "single element" strided list - lsearch -inline -stride 2 {a b c d e f g h} e -} -result "e f" -test lsearch-24.7 {lsearch -stride option} -body { - lsearch -inline -stride 3 {a b c d e f g h i} e -} -result {} -test lsearch-24.8 {lsearch -stride option} -body { - lsearch -inline -stride 3 -index 1 {a b c d e f g h i} e -} -result "d e f" -test lsearch-24.9 {lsearch -stride option} -body { - lsearch -all -inline -stride 3 -index 1 {a b c d e f g e i} e -} -result "d e f g e i" -test lsearch-24.10 {lsearch -stride option} -body { - lsearch -all -inline -stride 3 -index 0 {a b c d e f a e i} a -} -result "a b c a e i" -test lsearch-24.11 {lsearch -stride option} -body { - # Stride 1 is same as no stride - lsearch -stride 1 {a b c d e f g h} d -} -result 3 - -# 25* mimics 19* but with -inline added to -subindices -test lsearch-25.1 {lsearch -subindices option} { - lsearch -inline -subindices -index {0 0} {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a -} {a} -test lsearch-25.2 {lsearch -subindices option} { - lsearch -inline -subindices -index {2 0} -exact {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a -} {a} -test lsearch-25.3 {lsearch -subindices option} { - lsearch -inline -subindices -index {1 1} -glob {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} b* -} {bb} -test lsearch-25.4 {lsearch -subindices option} { - lsearch -inline -subindices -index {0 1} -regexp {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} {[cb]b} -} {cb} -test lsearch-25.5 {lsearch -subindices option} { - lsearch -inline -subindices -all -index {0 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a -} {a a} -test lsearch-25.6 {lsearch -subindices option} { - lsearch -inline -subindices -all -index {1 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a -} {a a} - -# 26* mimics 19* but with -stride added -test lsearch-26.1 {lsearch -stride + -subindices option} { - lsearch -stride 3 -subindices -index {0 0} {{x x} {x b} {a d} {a c} {a b} {a a}} a -} {3 0} -test lsearch-26.2 {lsearch -stride + -subindices option} { - lsearch -stride 3 -subindices -index {2 0} -exact {{x x} {x b} {a d} {a c} {a b} {a a}} a -} {2 0} -test lsearch-26.3 {lsearch -stride + -subindices option} { - lsearch -stride 3 -subindices -index {1 1} -glob {{ab cb} {ab bb} {ab ab} {ab cb} {ab bb} {ab ab}} b* -} {1 1} -test lsearch-26.4 {lsearch -stride + -subindices option} { - lsearch -stride 3 -subindices -index {0 1} -regexp {{ab cb} {ab bb} {ab ab} {ab cb} {ab bb} {ab ab}} {[cb]b} -} {0 1} -test lsearch-26.5 {lsearch -stride + -subindices option} { - lsearch -stride 3 -subindices -all -index {0 0} -exact {{a c} {a b} {d a} {a c} {a b} {d a}} a -} {{0 0} {3 0}} -test lsearch-26.6 {lsearch -stride + -subindices option} { - lsearch -stride 3 -subindices -all -index {1 0} -exact {{a c} {a b} {d a} {x c} {a b} {d a}} a -} {{1 0} {4 0}} - -# 27* mimics 25* but with -stride added -test lsearch-27.1 {lsearch -stride + -subindices option} { - lsearch -inline -stride 3 -subindices -index {0 0} {{x x} {x b} {a d} {a c} {a b} {a a}} a -} {a} -test lsearch-27.2 {lsearch -stride + -subindices option} { - lsearch -inline -stride 3 -subindices -index {2 0} -exact {{x x} {x b} {a d} {a c} {a b} {a a}} a -} {a} -test lsearch-27.3 {lsearch -stride + -subindices option} { - lsearch -inline -stride 3 -subindices -index {1 1} -glob {{ab cb} {ab bb} {ab ab} {ab cb} {ab bb} {ab ab}} b* -} {bb} -test lsearch-27.4 {lsearch -stride + -subindices option} { - lsearch -inline -stride 3 -subindices -index {0 1} -regexp {{ab cb} {ab bb} {ab ab} {ab cb} {ab bb} {ab ab}} {[cb]b} -} {cb} -test lsearch-27.5 {lsearch -stride + -subindices option} { - lsearch -inline -stride 3 -subindices -all -index {0 0} -exact {{a c} {a b} {d a} {a c} {a b} {d a}} a -} {a a} -test lsearch-27.6 {lsearch -stride + -subindices option} { - lsearch -inline -stride 3 -subindices -all -index {1 0} -exact {{a c} {a b} {d a} {x c} {a b} {d a}} a -} {a a} - -test lsearch-28.1 {lsearch -sorted with -stride} -body { - lsearch -sorted -stride 2 {5 3 7 8 9 2} 5 -} -result 0 -test lsearch-28.2 {lsearch -sorted with -stride} -body { - lsearch -sorted -stride 2 {5 3 7 8 9 2} 3 -} -result -1 -test lsearch-28.3 {lsearch -sorted with -stride} -body { - lsearch -sorted -stride 2 {5 3 7 8 9 2} 7 -} -result 2 -test lsearch-28.4 {lsearch -sorted with -stride} -body { - lsearch -sorted -stride 2 {5 3 7 8 9 2} 8 -} -result -1 -test lsearch-28.5 {lsearch -sorted with -stride} -body { - lsearch -sorted -stride 2 {5 3 7 8 9 2} 9 -} -result 4 -test lsearch-28.6 {lsearch -sorted with -stride} -body { - lsearch -sorted -stride 2 {5 3 7 8 9 2} 2 -} -result -1 -test lsearch-28.7 {lsearch -sorted with -stride} -body { - lsearch -sorted -stride 2 -index 0 -subindices {5 3 7 8 9 2} 9 -} -result 4 -test lsearch-28.8 {lsearch -sorted with -stride} -body { - lsearch -sorted -stride 2 -index 1 -subindices {3 5 8 7 2 9} 9 -} -result 5 -test lsearch-28.9 {lsearch -sorted with -stride} -body { - lsearch -sorted -stride 2 -index 1 -subindices -inline {3 5 8 7 2 9} 9 -} -result 9 - # cleanup catch {unset res} catch {unset increasingIntegers} catch {unset decreasingIntegers} Index: tests/lset.test ================================================================== --- tests/lset.test +++ tests/lset.test @@ -9,12 +9,12 @@ # Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] Index: tests/lsetComp.test ================================================================== --- tests/lsetComp.test +++ tests/lsetComp.test @@ -9,12 +9,12 @@ # Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } # Procedure to evaluate a script within a proc, to test compilation # functionality Index: tests/macOSXFCmd.test ================================================================== --- tests/macOSXFCmd.test +++ tests/macOSXFCmd.test @@ -7,12 +7,12 @@ # Copyright (c) 2003 Tcl Core Team. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } # These tests really need to be run from a writable directory, which # it is assumed [temporaryDirectory] is. Index: tests/macOSXLoad.test ================================================================== --- tests/macOSXLoad.test +++ tests/macOSXLoad.test @@ -8,14 +8,15 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } + set oldTSF $::tcltest::testSingleFile set ::tcltest::testSingleFile false if {[testConstraint unix] && $tcl_platform(os) eq "Darwin" && ![string match *pkga* [info loaded]]} { Index: tests/main.test ================================================================== --- tests/main.test +++ tests/main.test @@ -14,11 +14,11 @@ # Is the Tcltest package loaded? # - that is, the special C-coded testing commands in tclTest.c # - tests use testing commands introduced in Tcltest 8.4 testConstraint Tcltest [expr { [llength [package provide Tcltest]] - && [package vsatisfies [package provide Tcltest] 8.5-]}] + && [package vsatisfies [package provide Tcltest] 8.4]}] # Procedure to simulate interactive typing of commands, line by line proc type {chan script} { foreach line [split $script \n] { if {[catch { @@ -611,11 +611,11 @@ type $f "chan configure stdin -eofchar \\032 if 1 \{\n\032" variable wait chan event $f readable \ [list set [namespace which -variable wait] "child exit"] - set id [after 2000 [list set [namespace which -variable wait] timeout]] + set id [after 5000 [list set [namespace which -variable wait] timeout]] vwait [namespace which -variable wait] after cancel $id set wait } -cleanup { if {$wait eq "timeout" && [testConstraint unix]} { @@ -634,11 +634,11 @@ catch {chan configure $f -blocking 0} } -body { variable wait chan event $f readable \ [list set [namespace which -variable wait] "child exit"] - set id [after 2000 [list set [namespace which -variable wait] timeout]] + set id [after 5000 [list set [namespace which -variable wait] timeout]] vwait [namespace which -variable wait] after cancel $id set wait } -cleanup { if {$wait eq "timeout" && [testConstraint unix]} { Index: tests/mathop.test ================================================================== --- tests/mathop.test +++ tests/mathop.test @@ -8,11 +8,11 @@ # Copyright (c) 2006 Peter Spjuth # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2.1 namespace import -force ::tcltest::* } # A namespace to test that operators are exported and that they @@ -93,11 +93,11 @@ return "$i:($res1 != $res2)" } } return [lindex $results 0] } - + # start of tests namespace eval ::testmathop { namespace path ::tcl::mathop variable op ;# stop surprises! @@ -112,26 +112,26 @@ test mathop-1.8 {compiled +} { + 1 2 300000000000 } 300000000003 test mathop-1.9 {compiled +} { + 1000000000000000000000 2 3 } 1000000000000000000005 test mathop-1.10 {compiled +} { + 1 2 3000000000000000000000 } 3000000000000000000003 test mathop-1.11 {compiled +: errors} -returnCodes error -body { + x 0 - } -result {can't use non-numeric string "x" as operand of "+"} + } -result {can't use non-numeric string as operand of "+"} test mathop-1.12 {compiled +: errors} -returnCodes error -body { + nan 0 - } -result {can't use non-numeric floating-point value "nan" as operand of "+"} + } -result {can't use non-numeric floating-point value as operand of "+"} test mathop-1.13 {compiled +: errors} -returnCodes error -body { + 0 x - } -result {can't use non-numeric string "x" as operand of "+"} + } -result {can't use non-numeric string as operand of "+"} test mathop-1.14 {compiled +: errors} -returnCodes error -body { + 0 nan - } -result {can't use non-numeric floating-point value "nan" as operand of "+"} + } -result {can't use non-numeric floating-point value as operand of "+"} test mathop-1.15 {compiled +: errors} -returnCodes error -body { + 0o8 0 - } -result {can't use non-numeric string "0o8" as operand of "+"} + } -result {can't use invalid octal number as operand of "+"} test mathop-1.16 {compiled +: errors} -returnCodes error -body { + 0 0o8 - } -result {can't use non-numeric string "0o8" as operand of "+"} + } -result {can't use invalid octal number as operand of "+"} test mathop-1.17 {compiled +: errors} -returnCodes error -body { + 0 [error expectedError] } -result expectedError test mathop-1.18 {compiled +: argument processing order} -body { # Bytecode compilation known hard for 3+ arguments @@ -150,26 +150,26 @@ test mathop-1.26 {interpreted +} { $op 1 2 300000000000 } 300000000003 test mathop-1.27 {interpreted +} { $op 1000000000000000000000 2 3 } 1000000000000000000005 test mathop-1.28 {interpreted +} { $op 1 2 3000000000000000000000 } 3000000000000000000003 test mathop-1.29 {interpreted +: errors} -returnCodes error -body { $op x 0 - } -result {can't use non-numeric string "x" as operand of "+"} + } -result {can't use non-numeric string as operand of "+"} test mathop-1.30 {interpreted +: errors} -returnCodes error -body { $op nan 0 - } -result {can't use non-numeric floating-point value "nan" as operand of "+"} + } -result {can't use non-numeric floating-point value as operand of "+"} test mathop-1.31 {interpreted +: errors} -returnCodes error -body { $op 0 x - } -result {can't use non-numeric string "x" as operand of "+"} + } -result {can't use non-numeric string as operand of "+"} test mathop-1.32 {interpreted +: errors} -returnCodes error -body { $op 0 nan - } -result {can't use non-numeric floating-point value "nan" as operand of "+"} + } -result {can't use non-numeric floating-point value as operand of "+"} test mathop-1.33 {interpreted +: errors} -returnCodes error -body { $op 0o8 0 - } -result {can't use non-numeric string "0o8" as operand of "+"} + } -result {can't use invalid octal number as operand of "+"} test mathop-1.34 {interpreted +: errors} -returnCodes error -body { $op 0 0o8 - } -result {can't use non-numeric string "0o8" as operand of "+"} + } -result {can't use invalid octal number as operand of "+"} test mathop-1.35 {interpreted +: errors} -returnCodes error -body { $op 0 [error expectedError] } -result expectedError test mathop-1.36 {interpreted +: argument processing order} -body { list [catch { @@ -187,26 +187,26 @@ test mathop-2.8 {compiled *} { * 1 2 300000000000 } 600000000000 test mathop-2.9 {compiled *} { * 1000000000000000000000 2 3 } 6000000000000000000000 test mathop-2.10 {compiled *} { * 1 2 3000000000000000000000 } 6000000000000000000000 test mathop-2.11 {compiled *: errors} -returnCodes error -body { * x 0 - } -result {can't use non-numeric string "x" as operand of "*"} + } -result {can't use non-numeric string as operand of "*"} test mathop-2.12 {compiled *: errors} -returnCodes error -body { * nan 0 - } -result {can't use non-numeric floating-point value "nan" as operand of "*"} + } -result {can't use non-numeric floating-point value as operand of "*"} test mathop-2.13 {compiled *: errors} -returnCodes error -body { * 0 x - } -result {can't use non-numeric string "x" as operand of "*"} + } -result {can't use non-numeric string as operand of "*"} test mathop-2.14 {compiled *: errors} -returnCodes error -body { * 0 nan - } -result {can't use non-numeric floating-point value "nan" as operand of "*"} + } -result {can't use non-numeric floating-point value as operand of "*"} test mathop-2.15 {compiled *: errors} -returnCodes error -body { * 0o8 0 - } -result {can't use non-numeric string "0o8" as operand of "*"} + } -result {can't use invalid octal number as operand of "*"} test mathop-2.16 {compiled *: errors} -returnCodes error -body { * 0 0o8 - } -result {can't use non-numeric string "0o8" as operand of "*"} + } -result {can't use invalid octal number as operand of "*"} test mathop-2.17 {compiled *: errors} -returnCodes error -body { * 0 [error expectedError] } -result expectedError test mathop-2.18 {compiled *: argument processing order} -body { # Bytecode compilation known hard for 3+ arguments @@ -225,26 +225,26 @@ test mathop-2.26 {interpreted *} { $op 1 2 300000000000 } 600000000000 test mathop-2.27 {interpreted *} { $op 1000000000000000000000 2 3 } 6000000000000000000000 test mathop-2.28 {interpreted *} { $op 1 2 3000000000000000000000 } 6000000000000000000000 test mathop-2.29 {interpreted *: errors} -returnCodes error -body { $op x 0 - } -result {can't use non-numeric string "x" as operand of "*"} + } -result {can't use non-numeric string as operand of "*"} test mathop-2.30 {interpreted *: errors} -returnCodes error -body { $op nan 0 - } -result {can't use non-numeric floating-point value "nan" as operand of "*"} + } -result {can't use non-numeric floating-point value as operand of "*"} test mathop-2.31 {interpreted *: errors} -returnCodes error -body { $op 0 x - } -result {can't use non-numeric string "x" as operand of "*"} + } -result {can't use non-numeric string as operand of "*"} test mathop-2.32 {interpreted *: errors} -returnCodes error -body { $op 0 nan - } -result {can't use non-numeric floating-point value "nan" as operand of "*"} + } -result {can't use non-numeric floating-point value as operand of "*"} test mathop-2.33 {interpreted *: errors} -returnCodes error -body { $op 0o8 0 - } -result {can't use non-numeric string "0o8" as operand of "*"} + } -result {can't use invalid octal number as operand of "*"} test mathop-2.34 {interpreted *: errors} -returnCodes error -body { $op 0 0o8 - } -result {can't use non-numeric string "0o8" as operand of "*"} + } -result {can't use invalid octal number as operand of "*"} test mathop-2.35 {interpreted *: errors} -returnCodes error -body { $op 0 [error expectedError] } -result expectedError test mathop-2.36 {interpreted *: argument processing order} -body { list [catch { @@ -259,11 +259,11 @@ test mathop-3.5 {compiled !} {! 0.0} 1 test mathop-3.6 {compiled !} {! 10000000000} 0 test mathop-3.7 {compiled !} {! 10000000000000000000000000} 0 test mathop-3.8 {compiled !: errors} -body { ! foobar - } -returnCodes error -result {can't use non-numeric string "foobar" as operand of "!"} + } -returnCodes error -result {can't use non-numeric string as operand of "!"} test mathop-3.9 {compiled !: errors} -body { ! 0 0 } -returnCodes error -result "wrong # args: should be \"! boolean\"" test mathop-3.10 {compiled !: errors} -body { ! @@ -276,23 +276,23 @@ test mathop-3.15 {interpreted !} {$op 0.0} 1 test mathop-3.16 {interpreted !} {$op 10000000000} 0 test mathop-3.17 {interpreted !} {$op 10000000000000000000000000} 0 test mathop-3.18 {interpreted !: errors} -body { $op foobar - } -returnCodes error -result {can't use non-numeric string "foobar" as operand of "!"} + } -returnCodes error -result {can't use non-numeric string as operand of "!"} test mathop-3.19 {interpreted !: errors} -body { $op 0 0 } -returnCodes error -result "wrong # args: should be \"! boolean\"" test mathop-3.20 {interpreted !: errors} -body { $op } -returnCodes error -result "wrong # args: should be \"! boolean\"" test mathop-3.21 {compiled !: error} -returnCodes error -body { ! NaN - } -result {can't use non-numeric floating-point value "NaN" as operand of "!"} + } -result {can't use non-numeric floating-point value as operand of "!"} test mathop-3.22 {interpreted !: error} -returnCodes error -body { $op NaN - } -result {can't use non-numeric floating-point value "NaN" as operand of "!"} + } -result {can't use non-numeric floating-point value as operand of "!"} test mathop-4.1 {compiled ~} {~ 0} -1 test mathop-4.2 {compiled ~} {~ 1} -2 test mathop-4.3 {compiled ~} {~ 31} -32 test mathop-4.4 {compiled ~} {~ -127} 126 @@ -299,23 +299,23 @@ test mathop-4.5 {compiled ~} {~ -0} -1 test mathop-4.6 {compiled ~} {~ 10000000000} -10000000001 test mathop-4.7 {compiled ~} {~ 10000000000000000000000000} -10000000000000000000000001 test mathop-4.8 {compiled ~: errors} -body { ~ foobar - } -returnCodes error -result {can't use non-numeric string "foobar" as operand of "~"} + } -returnCodes error -result {can't use non-numeric string as operand of "~"} test mathop-4.9 {compiled ~: errors} -body { ~ 0 0 } -returnCodes error -result "wrong # args: should be \"~ integer\"" test mathop-4.10 {compiled ~: errors} -body { ~ } -returnCodes error -result "wrong # args: should be \"~ integer\"" test mathop-4.11 {compiled ~: errors} -returnCodes error -body { ~ 0.0 - } -result {can't use floating-point value "0.0" as operand of "~"} + } -result {can't use floating-point value as operand of "~"} test mathop-4.12 {compiled ~: errors} -returnCodes error -body { ~ NaN - } -result {can't use non-numeric floating-point value "NaN" as operand of "~"} + } -result {can't use non-numeric floating-point value as operand of "~"} set op ~ test mathop-4.13 {interpreted ~} {$op 0} -1 test mathop-4.14 {interpreted ~} {$op 1} -2 test mathop-4.15 {interpreted ~} {$op 31} -32 test mathop-4.16 {interpreted ~} {$op -127} 126 @@ -322,23 +322,23 @@ test mathop-4.17 {interpreted ~} {$op -0} -1 test mathop-4.18 {interpreted ~} {$op 10000000000} -10000000001 test mathop-4.19 {interpreted ~} {$op 10000000000000000000000000} -10000000000000000000000001 test mathop-4.20 {interpreted ~: errors} -body { $op foobar - } -returnCodes error -result {can't use non-numeric string "foobar" as operand of "~"} + } -returnCodes error -result {can't use non-numeric string as operand of "~"} test mathop-4.21 {interpreted ~: errors} -body { $op 0 0 } -returnCodes error -result "wrong # args: should be \"~ integer\"" test mathop-4.22 {interpreted ~: errors} -body { $op } -returnCodes error -result "wrong # args: should be \"~ integer\"" test mathop-4.23 {interpreted ~: errors} -returnCodes error -body { $op 0.0 - } -result {can't use floating-point value "0.0" as operand of "~"} + } -result {can't use floating-point value as operand of "~"} test mathop-4.24 {interpreted ~: errors} -returnCodes error -body { $op NaN - } -result {can't use non-numeric floating-point value "NaN" as operand of "~"} + } -result {can't use non-numeric floating-point value as operand of "~"} test mathop-5.1 {compiled eq} {eq {} a} 0 test mathop-5.2 {compiled eq} {eq a a} 1 test mathop-5.3 {compiled eq} {eq a {}} 0 test mathop-5.4 {compiled eq} {eq a b} 0 @@ -375,36 +375,36 @@ test mathop-6.2 {compiled &} { & 1 } 1 test mathop-6.3 {compiled &} { & 1 2 } 0 test mathop-6.4 {compiled &} { & 3 7 6 } 2 test mathop-6.5 {compiled &} -returnCodes error -body { & 1.0 2 3 - } -result {can't use floating-point value "1.0" as operand of "&"} + } -result {can't use floating-point value as operand of "&"} test mathop-6.6 {compiled &} -returnCodes error -body { & 1 2 3.0 - } -result {can't use floating-point value "3.0" as operand of "&"} + } -result {can't use floating-point value as operand of "&"} test mathop-6.7 {compiled &} { & 100000000002 18 -126 } 2 test mathop-6.8 {compiled &} { & 0xff 0o377 333333333333 } 85 test mathop-6.9 {compiled &} { & 1000000000000000000002 18 -126 } 2 test mathop-6.10 {compiled &} { & 0xff 0o377 3333333333333333333333 } 85 test mathop-6.11 {compiled &: errors} -returnCodes error -body { & x 0 - } -result {can't use non-numeric string "x" as operand of "&"} + } -result {can't use non-numeric string as operand of "&"} test mathop-6.12 {compiled &: errors} -returnCodes error -body { & nan 0 - } -result {can't use non-numeric floating-point value "nan" as operand of "&"} + } -result {can't use non-numeric floating-point value as operand of "&"} test mathop-6.13 {compiled &: errors} -returnCodes error -body { & 0 x - } -result {can't use non-numeric string "x" as operand of "&"} + } -result {can't use non-numeric string as operand of "&"} test mathop-6.14 {compiled &: errors} -returnCodes error -body { & 0 nan - } -result {can't use non-numeric floating-point value "nan" as operand of "&"} + } -result {can't use non-numeric floating-point value as operand of "&"} test mathop-6.15 {compiled &: errors} -returnCodes error -body { & 0o8 0 - } -result {can't use non-numeric string "0o8" as operand of "&"} + } -result {can't use invalid octal number as operand of "&"} test mathop-6.16 {compiled &: errors} -returnCodes error -body { & 0 0o8 - } -result {can't use non-numeric string "0o8" as operand of "&"} + } -result {can't use invalid octal number as operand of "&"} test mathop-6.17 {compiled &: errors} -returnCodes error -body { & 0 [error expectedError] } -result expectedError test mathop-6.18 {compiled &: argument processing order} -body { # Bytecode compilation known hard for 3+ arguments @@ -417,36 +417,36 @@ test mathop-6.20 {interpreted &} { $op 1 } 1 test mathop-6.21 {interpreted &} { $op 1 2 } 0 test mathop-6.22 {interpreted &} { $op 3 7 6 } 2 test mathop-6.23 {interpreted &} -returnCodes error -body { $op 1.0 2 3 - } -result {can't use floating-point value "1.0" as operand of "&"} + } -result {can't use floating-point value as operand of "&"} test mathop-6.24 {interpreted &} -returnCodes error -body { $op 1 2 3.0 - } -result {can't use floating-point value "3.0" as operand of "&"} + } -result {can't use floating-point value as operand of "&"} test mathop-6.25 {interpreted &} { $op 100000000002 18 -126 } 2 test mathop-6.26 {interpreted &} { $op 0xff 0o377 333333333333 } 85 test mathop-6.27 {interpreted &} { $op 1000000000000000000002 18 -126 } 2 test mathop-6.28 {interpreted &} { $op 0xff 0o377 3333333333333333333333 } 85 test mathop-6.29 {interpreted &: errors} -returnCodes error -body { $op x 0 - } -result {can't use non-numeric string "x" as operand of "&"} + } -result {can't use non-numeric string as operand of "&"} test mathop-6.30 {interpreted &: errors} -returnCodes error -body { $op nan 0 - } -result {can't use non-numeric floating-point value "nan" as operand of "&"} + } -result {can't use non-numeric floating-point value as operand of "&"} test mathop-6.31 {interpreted &: errors} -returnCodes error -body { $op 0 x - } -result {can't use non-numeric string "x" as operand of "&"} + } -result {can't use non-numeric string as operand of "&"} test mathop-6.32 {interpreted &: errors} -returnCodes error -body { $op 0 nan - } -result {can't use non-numeric floating-point value "nan" as operand of "&"} + } -result {can't use non-numeric floating-point value as operand of "&"} test mathop-6.33 {interpreted &: errors} -returnCodes error -body { $op 0o8 0 - } -result {can't use non-numeric string "0o8" as operand of "&"} + } -result {can't use invalid octal number as operand of "&"} test mathop-6.34 {interpreted &: errors} -returnCodes error -body { $op 0 0o8 - } -result {can't use non-numeric string "0o8" as operand of "&"} + } -result {can't use invalid octal number as operand of "&"} test mathop-6.35 {interpreted &: errors} -returnCodes error -body { $op 0 [error expectedError] } -result expectedError test mathop-6.36 {interpreted &: argument processing order} -body { list [catch { @@ -485,36 +485,36 @@ test mathop-7.2 {compiled |} { | 1 } 1 test mathop-7.3 {compiled |} { | 1 2 } 3 test mathop-7.4 {compiled |} { | 3 7 6 } 7 test mathop-7.5 {compiled |} -returnCodes error -body { | 1.0 2 3 - } -result {can't use floating-point value "1.0" as operand of "|"} + } -result {can't use floating-point value as operand of "|"} test mathop-7.6 {compiled |} -returnCodes error -body { | 1 2 3.0 - } -result {can't use floating-point value "3.0" as operand of "|"} + } -result {can't use floating-point value as operand of "|"} test mathop-7.7 {compiled |} { | 100000000002 18 -126 } -110 test mathop-7.8 {compiled |} { | 0xff 0o377 333333333333 } 333333333503 test mathop-7.9 {compiled |} { | 1000000000000000000002 18 -126 } -110 test mathop-7.10 {compiled |} { | 0xff 0o377 3333333333333333333333 } 3333333333333333333503 test mathop-7.11 {compiled |: errors} -returnCodes error -body { | x 0 - } -result {can't use non-numeric string "x" as operand of "|"} + } -result {can't use non-numeric string as operand of "|"} test mathop-7.12 {compiled |: errors} -returnCodes error -body { | nan 0 - } -result {can't use non-numeric floating-point value "nan" as operand of "|"} + } -result {can't use non-numeric floating-point value as operand of "|"} test mathop-7.13 {compiled |: errors} -returnCodes error -body { | 0 x - } -result {can't use non-numeric string "x" as operand of "|"} + } -result {can't use non-numeric string as operand of "|"} test mathop-7.14 {compiled |: errors} -returnCodes error -body { | 0 nan - } -result {can't use non-numeric floating-point value "nan" as operand of "|"} + } -result {can't use non-numeric floating-point value as operand of "|"} test mathop-7.15 {compiled |: errors} -returnCodes error -body { | 0o8 0 - } -result {can't use non-numeric string "0o8" as operand of "|"} + } -result {can't use invalid octal number as operand of "|"} test mathop-7.16 {compiled |: errors} -returnCodes error -body { | 0 0o8 - } -result {can't use non-numeric string "0o8" as operand of "|"} + } -result {can't use invalid octal number as operand of "|"} test mathop-7.17 {compiled |: errors} -returnCodes error -body { | 0 [error expectedError] } -result expectedError test mathop-7.18 {compiled |: argument processing order} -body { # Bytecode compilation known hard for 3+ arguments @@ -527,36 +527,36 @@ test mathop-7.20 {interpreted |} { $op 1 } 1 test mathop-7.21 {interpreted |} { $op 1 2 } 3 test mathop-7.22 {interpreted |} { $op 3 7 6 } 7 test mathop-7.23 {interpreted |} -returnCodes error -body { $op 1.0 2 3 - } -result {can't use floating-point value "1.0" as operand of "|"} + } -result {can't use floating-point value as operand of "|"} test mathop-7.24 {interpreted |} -returnCodes error -body { $op 1 2 3.0 - } -result {can't use floating-point value "3.0" as operand of "|"} + } -result {can't use floating-point value as operand of "|"} test mathop-7.25 {interpreted |} { $op 100000000002 18 -126 } -110 test mathop-7.26 {interpreted |} { $op 0xff 0o377 333333333333 } 333333333503 test mathop-7.27 {interpreted |} { $op 1000000000000000000002 18 -126 } -110 test mathop-7.28 {interpreted |} { $op 0xff 0o377 3333333333333333333333 } 3333333333333333333503 test mathop-7.29 {interpreted |: errors} -returnCodes error -body { $op x 0 - } -result {can't use non-numeric string "x" as operand of "|"} + } -result {can't use non-numeric string as operand of "|"} test mathop-7.30 {interpreted |: errors} -returnCodes error -body { $op nan 0 - } -result {can't use non-numeric floating-point value "nan" as operand of "|"} + } -result {can't use non-numeric floating-point value as operand of "|"} test mathop-7.31 {interpreted |: errors} -returnCodes error -body { $op 0 x - } -result {can't use non-numeric string "x" as operand of "|"} + } -result {can't use non-numeric string as operand of "|"} test mathop-7.32 {interpreted |: errors} -returnCodes error -body { $op 0 nan - } -result {can't use non-numeric floating-point value "nan" as operand of "|"} + } -result {can't use non-numeric floating-point value as operand of "|"} test mathop-7.33 {interpreted |: errors} -returnCodes error -body { $op 0o8 0 - } -result {can't use non-numeric string "0o8" as operand of "|"} + } -result {can't use invalid octal number as operand of "|"} test mathop-7.34 {interpreted |: errors} -returnCodes error -body { $op 0 0o8 - } -result {can't use non-numeric string "0o8" as operand of "|"} + } -result {can't use invalid octal number as operand of "|"} test mathop-7.35 {interpreted |: errors} -returnCodes error -body { $op 0 [error expectedError] } -result expectedError test mathop-7.36 {interpreted |: argument processing order} -body { list [catch { @@ -595,36 +595,36 @@ test mathop-8.2 {compiled ^} { ^ 1 } 1 test mathop-8.3 {compiled ^} { ^ 1 2 } 3 test mathop-8.4 {compiled ^} { ^ 3 7 6 } 2 test mathop-8.5 {compiled ^} -returnCodes error -body { ^ 1.0 2 3 - } -result {can't use floating-point value "1.0" as operand of "^"} + } -result {can't use floating-point value as operand of "^"} test mathop-8.6 {compiled ^} -returnCodes error -body { ^ 1 2 3.0 - } -result {can't use floating-point value "3.0" as operand of "^"} + } -result {can't use floating-point value as operand of "^"} test mathop-8.7 {compiled ^} { ^ 100000000002 18 -126 } -100000000110 test mathop-8.8 {compiled ^} { ^ 0xff 0o377 333333333333 } 333333333333 test mathop-8.9 {compiled ^} { ^ 1000000000000000000002 18 -126 } -1000000000000000000110 test mathop-8.10 {compiled ^} { ^ 0xff 0o377 3333333333333333333333 } 3333333333333333333333 test mathop-8.11 {compiled ^: errors} -returnCodes error -body { ^ x 0 - } -result {can't use non-numeric string "x" as operand of "^"} + } -result {can't use non-numeric string as operand of "^"} test mathop-8.12 {compiled ^: errors} -returnCodes error -body { ^ nan 0 - } -result {can't use non-numeric floating-point value "nan" as operand of "^"} + } -result {can't use non-numeric floating-point value as operand of "^"} test mathop-8.13 {compiled ^: errors} -returnCodes error -body { ^ 0 x - } -result {can't use non-numeric string "x" as operand of "^"} + } -result {can't use non-numeric string as operand of "^"} test mathop-8.14 {compiled ^: errors} -returnCodes error -body { ^ 0 nan - } -result {can't use non-numeric floating-point value "nan" as operand of "^"} + } -result {can't use non-numeric floating-point value as operand of "^"} test mathop-8.15 {compiled ^: errors} -returnCodes error -body { ^ 0o8 0 - } -result {can't use non-numeric string "0o8" as operand of "^"} + } -result {can't use invalid octal number as operand of "^"} test mathop-8.16 {compiled ^: errors} -returnCodes error -body { ^ 0 0o8 - } -result {can't use non-numeric string "0o8" as operand of "^"} + } -result {can't use invalid octal number as operand of "^"} test mathop-8.17 {compiled ^: errors} -returnCodes error -body { ^ 0 [error expectedError] } -result expectedError test mathop-8.18 {compiled ^: argument processing order} -body { # Bytecode compilation known hard for 3+ arguments @@ -637,36 +637,36 @@ test mathop-8.20 {interpreted ^} { $op 1 } 1 test mathop-8.21 {interpreted ^} { $op 1 2 } 3 test mathop-8.22 {interpreted ^} { $op 3 7 6 } 2 test mathop-8.23 {interpreted ^} -returnCodes error -body { $op 1.0 2 3 - } -result {can't use floating-point value "1.0" as operand of "^"} + } -result {can't use floating-point value as operand of "^"} test mathop-8.24 {interpreted ^} -returnCodes error -body { $op 1 2 3.0 - } -result {can't use floating-point value "3.0" as operand of "^"} + } -result {can't use floating-point value as operand of "^"} test mathop-8.25 {interpreted ^} { $op 100000000002 18 -126 } -100000000110 test mathop-8.26 {interpreted ^} { $op 0xff 0o377 333333333333 } 333333333333 test mathop-8.27 {interpreted ^} { $op 1000000000000000000002 18 -126 } -1000000000000000000110 test mathop-8.28 {interpreted ^} { $op 0xff 0o377 3333333333333333333333 } 3333333333333333333333 test mathop-8.29 {interpreted ^: errors} -returnCodes error -body { $op x 0 - } -result {can't use non-numeric string "x" as operand of "^"} + } -result {can't use non-numeric string as operand of "^"} test mathop-8.30 {interpreted ^: errors} -returnCodes error -body { $op nan 0 - } -result {can't use non-numeric floating-point value "nan" as operand of "^"} + } -result {can't use non-numeric floating-point value as operand of "^"} test mathop-8.31 {interpreted ^: errors} -returnCodes error -body { $op 0 x - } -result {can't use non-numeric string "x" as operand of "^"} + } -result {can't use non-numeric string as operand of "^"} test mathop-8.32 {interpreted ^: errors} -returnCodes error -body { $op 0 nan - } -result {can't use non-numeric floating-point value "nan" as operand of "^"} + } -result {can't use non-numeric floating-point value as operand of "^"} test mathop-8.33 {interpreted ^: errors} -returnCodes error -body { $op 0o8 0 - } -result {can't use non-numeric string "0o8" as operand of "^"} + } -result {can't use invalid octal number as operand of "^"} test mathop-8.34 {interpreted ^: errors} -returnCodes error -body { $op 0 0o8 - } -result {can't use non-numeric string "0o8" as operand of "^"} + } -result {can't use invalid octal number as operand of "^"} test mathop-8.35 {interpreted ^: errors} -returnCodes error -body { $op 0 [error expectedError] } -result expectedError test mathop-8.36 {interpreted ^: argument processing order} -body { list [catch { @@ -773,17 +773,17 @@ set exp {} foreach vals {x {1 x} {1 1 x} {1 x 1}} { # skipping - for now, knownbug... foreach op {+ * / & | ^ **} { lappend res [TestOp $op {*}$vals] - lappend exp "can't use non-numeric string \"x\" as operand of \"$op\"\ + lappend exp "can't use non-numeric string as operand of \"$op\"\ ARITH DOMAIN {non-numeric string}" } } foreach op {+ * / & | ^ **} { lappend res [TestOp $op NaN 1] - lappend exp "can't use non-numeric floating-point value \"NaN\" as operand of \"$op\"\ + lappend exp "can't use non-numeric floating-point value as operand of \"$op\"\ ARITH DOMAIN {non-numeric floating-point value}" } expr {$res eq $exp ? 0 : $res} } 0 test mathop-20.7 { multi arg } { @@ -848,19 +848,19 @@ 2.8196218755553604e-15 8.10000006561e-27] test mathop-21.5 { unary ops, bad values } { set res {} set exp {} lappend res [TestOp / x] - lappend exp "can't use non-numeric string \"x\" as operand of \"/\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string as operand of \"/\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp - x] - lappend exp "can't use non-numeric string \"x\" as operand of \"-\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string as operand of \"-\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp ~ x] - lappend exp "can't use non-numeric string \"x\" as operand of \"~\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string as operand of \"~\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp ! x] - lappend exp "can't use non-numeric string \"x\" as operand of \"!\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string as operand of \"!\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp ~ 5.0] - lappend exp "can't use floating-point value \"5.0\" as operand of \"~\" ARITH DOMAIN {floating-point value}" + lappend exp "can't use floating-point value as operand of \"~\" ARITH DOMAIN {floating-point value}" expr {$res eq $exp ? 0 : $res} } 0 test mathop-21.6 { unary ops, too many } { set exp {} foreach op {~ !} { @@ -899,14 +899,14 @@ } } set exp {} foreach d {5 7 2 1 D C 1 F E 0 -D -D 8 -9 -1 -0 -E E} { if {[string match "-*" $d]} { - set d [format %X [expr 15-0x[string range $d 1 end]]] - set val [expr -0x[string repeat $d $dig]-1] + set d [format %X [expr {15-"0x[string range $d 1 end]"}]] + set val [expr {-"0x[string repeat $d $dig]"-1}] } else { - set val [expr 0x[string repeat $d $dig]] + set val [expr {"0x[string repeat $d $dig]"}] } lappend exp $val } expr {$exp eq $res ? 1 : "($res != $exp"} } 1 @@ -963,13 +963,13 @@ test mathop-22.4 { unary ops, bad values } { set res {} set exp {} foreach op {& | ^} { lappend res [TestOp $op x 5] - lappend exp "can't use non-numeric string \"x\" as operand of \"$op\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string as operand of \"$op\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp $op 5 x] - lappend exp "can't use non-numeric string \"x\" as operand of \"$op\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string as operand of \"$op\" ARITH DOMAIN {non-numeric string}" } expr {$res eq $exp ? 0 : $res} } 0 test mathop-23.1 { comparison ops, numerical } { @@ -1078,19 +1078,19 @@ test mathop-24.3 { binary ops, bad values } { set res {} set exp {} foreach op {% << >>} { lappend res [TestOp $op x 1] - lappend exp "can't use non-numeric string \"x\" as operand of \"$op\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string as operand of \"$op\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp $op 1 x] - lappend exp "can't use non-numeric string \"x\" as operand of \"$op\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string as operand of \"$op\" ARITH DOMAIN {non-numeric string}" } foreach op {% << >>} { lappend res [TestOp $op 5.0 1] - lappend exp "can't use floating-point value \"5.0\" as operand of \"$op\" ARITH DOMAIN {floating-point value}" + lappend exp "can't use floating-point value as operand of \"$op\" ARITH DOMAIN {floating-point value}" lappend res [TestOp $op 1 5.0] - lappend exp "can't use floating-point value \"5.0\" as operand of \"$op\" ARITH DOMAIN {floating-point value}" + lappend exp "can't use floating-point value as operand of \"$op\" ARITH DOMAIN {floating-point value}" } foreach op {in ni} { lappend res [TestOp $op 5 "a b \{ c"] lappend exp "unmatched open brace in list TCL VALUE LIST BRACE" } @@ -1264,13 +1264,13 @@ lappend res [TestOp ** 2 $big] lappend exp "exponent too large NONE" lappend res [TestOp ** $huge 2.1] lappend exp "Inf" lappend res [TestOp ** 2 foo] - lappend exp "can't use non-numeric string \"foo\" as operand of \"**\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string as operand of \"**\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp ** foo 2] - lappend exp "can't use non-numeric string \"foo\" as operand of \"**\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string as operand of \"**\" ARITH DOMAIN {non-numeric string}" expr {$res eq $exp ? 0 : $res} } 0 test mathop-26.1 { misc ops, size combinations } { @@ -1340,50 +1340,10 @@ lappend res [TestOp * 2147483648 2] lappend res [TestOp * 9223372036854775808 2] set res } [list 2147483648 9223372036854775808 9223372036854775808 4294967296 18446744073709551616] -test mathop-27.1 {lt operator} {::tcl::mathop::lt} 1 -test mathop-27.2 {lt operator} {::tcl::mathop::lt a} 1 -test mathop-27.3 {lt operator} {::tcl::mathop::lt a b} 1 -test mathop-27.4 {lt operator} {::tcl::mathop::lt b a} 0 -test mathop-27.5 {lt operator} {::tcl::mathop::lt a a} 0 -test mathop-27.6 {lt operator} {::tcl::mathop::lt a b c} 1 -test mathop-27.7 {lt operator} {::tcl::mathop::lt b a c} 0 -test mathop-27.8 {lt operator} {::tcl::mathop::lt a c b} 0 -test mathop-27.9 {lt operator} {::tcl::mathop::lt 012 0x0} 1 - -test mathop-28.1 {le operator} {::tcl::mathop::le} 1 -test mathop-28.2 {le operator} {::tcl::mathop::le a} 1 -test mathop-28.3 {le operator} {::tcl::mathop::le a b} 1 -test mathop-28.4 {le operator} {::tcl::mathop::le b a} 0 -test mathop-28.5 {le operator} {::tcl::mathop::le a a} 1 -test mathop-28.6 {le operator} {::tcl::mathop::le a b c} 1 -test mathop-28.7 {le operator} {::tcl::mathop::le b a c} 0 -test mathop-28.8 {le operator} {::tcl::mathop::le a c b} 0 -test mathop-28.9 {le operator} {::tcl::mathop::le 012 0x0} 1 - -test mathop-29.1 {gt operator} {::tcl::mathop::gt} 1 -test mathop-29.2 {gt operator} {::tcl::mathop::gt a} 1 -test mathop-29.3 {gt operator} {::tcl::mathop::gt a b} 0 -test mathop-29.4 {gt operator} {::tcl::mathop::gt b a} 1 -test mathop-29.5 {gt operator} {::tcl::mathop::gt a a} 0 -test mathop-29.6 {gt operator} {::tcl::mathop::gt c b a} 1 -test mathop-29.7 {gt operator} {::tcl::mathop::gt b a c} 0 -test mathop-29.8 {gt operator} {::tcl::mathop::gt a c b} 0 -test mathop-29.9 {gt operator} {::tcl::mathop::gt 0x0 012} 1 - -test mathop-30.1 {ge operator} {::tcl::mathop::ge} 1 -test mathop-30.2 {ge operator} {::tcl::mathop::ge a} 1 -test mathop-30.3 {ge operator} {::tcl::mathop::ge a b} 0 -test mathop-30.4 {ge operator} {::tcl::mathop::ge b a} 1 -test mathop-30.5 {ge operator} {::tcl::mathop::ge a a} 1 -test mathop-30.6 {ge operator} {::tcl::mathop::ge c b a} 1 -test mathop-30.7 {ge operator} {::tcl::mathop::ge b a c} 0 -test mathop-30.8 {ge operator} {::tcl::mathop::ge a c b} 0 -test mathop-30.9 {ge operator} {::tcl::mathop::ge 0x0 012} 1 - if 0 { # Compare ops to expr bytecodes namespace import ::tcl::mathop::* proc _X {a b c} { set x [+ $a [- $b $c]] @@ -1392,15 +1352,15 @@ } set ::tcl_traceCompile 2 _X 3 4 5 set ::tcl_traceCompile 0 } - + # cleanup namespace delete ::testmathop namespace delete ::testmathop2 ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: Index: tests/misc.test ================================================================== --- tests/misc.test +++ tests/misc.test @@ -10,12 +10,12 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -23,11 +23,11 @@ testConstraint testhashsystemhash [llength [info commands testhashsystemhash]] test misc-1.1 {error in variable ref. in command in array reference} { proc tstProc {} { global a - + set tst $a([winfo name $zz]) # this is a bogus comment # this is a bogus comment # this is a bogus comment # this is a bogus comment @@ -40,11 +40,11 @@ list [catch tstProc msg] $msg } {1 {can't read "zz": no such variable}} test misc-1.2 {error in variable ref. in command in array reference} { proc tstProc {} " global a - + set tst \$a(\[winfo name \$\{zz) # this is a bogus comment # this is a bogus comment # this is a bogus comment # this is a bogus comment Index: tests/msgcat.test ================================================================== --- tests/msgcat.test +++ tests/msgcat.test @@ -10,15 +10,15 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Note that after running these tests, entries will be left behind in the # message catalogs for locales foo, foo_BAR, and foo_BAR_baz. -package require Tcl 8.5- -if {[catch {package require tcltest 2}]} { - puts stderr "Skipping tests in [info script]. tcltest 2 required." - return +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* } + if {[catch {package require msgcat 1.6}]} { puts stderr "Skipping tests in [info script]. No msgcat 1.6 found to test." return } @@ -53,17 +53,12 @@ variable setVars foreach setVars [PowerSet $envVars] { set result [string tolower [lindex $setVars 0]] if {[string length $result] == 0} { if {[info exists ::tcl::mac::locale]} { -if {[package vsatisfies [package provide msgcat] 1.7]} { - set result [string tolower \ - [msgcat::mcutil::ConvertLocale $::tcl::mac::locale]] -} else { set result [string tolower \ [msgcat::ConvertLocale $::tcl::mac::locale]] -} } else { if {([info sharedlibextension] eq ".dll") && ![catch {package require registry}]} { # Windows and Cygwin have other ways to determine the # locale when the environment variables are missing @@ -196,32 +191,10 @@ } -cleanup { mclocale $locale } -body { mclocale looks/ok/../../../../but/is/path/to/evil/code } -returnCodes error -match glob -result {invalid newLocale value *} - - test msgcat-1.14 {mcpreferences, custom locale preferences} -setup { - variable locale [mclocale] - mclocale en - mcpreferences fr en {} - } -cleanup { - mclocale $locale - } -body { - mcpreferences - } -result {fr en {}} - - test msgcat-1.15 {mcpreferences, overwrite custom locale preferences}\ - -setup { - variable locale [mclocale] - mcpreferences fr en {} - mclocale en - } -cleanup { - mclocale $locale - } -body { - mcpreferences - } -result {en {}} - # Tests msgcat-2.*: [mcset], [mcmset], namespace partitioning test msgcat-2.1 {mcset, global scope} { namespace eval :: ::msgcat::mcset foo_BAR text1 text2 @@ -691,22 +664,22 @@ set msgdir2 [makeDirectory msgdir2] set msgdir3 [makeDirectory msgdir3] makeFile "::msgcat::mcflset k2 v2 ; ::msgcat::mcload [list $msgdir3]"\ l2.msg $msgdir2 - makeFile {::msgcat::mcflset k3 v3 ; ::msgcat::mcflmset {k4 v4 k5 v5}} l2.msg $msgdir3 + makeFile {::msgcat::mcflset k3 v3} l2.msg $msgdir3 # chained mcload - test msgcat-8.2 {mcflset/mcflmset} -setup { + test msgcat-8.2 {mcflset} -setup { variable locale [mclocale] mclocale l2 mcload $msgdir2 } -cleanup { mclocale $locale } -body { - return [mc k2][mc k3]--[mc k4][mc k5] - } -result v2v3--v4v5 + return [mc k2][mc k3] + } -result v2v3 removeFile l2.msg $msgdir2 removeDirectory msgdir2 removeDirectory msgdir3 @@ -713,11 +686,11 @@ # Tests msgcat-9.*: [mcexists] test msgcat-9.1 {mcexists no parameter} -body { mcexists } -returnCodes 1\ - -result {wrong # args: should be "mcexists ?-exactnamespace? ?-exactlocale? ?-namespace ns? src"} + -result {wrong # args: should be "mcexists ?-exactnamespace? ?-exactlocale? src"} test msgcat-9.2 {mcexists unknown option} -body { mcexists -unknown src } -returnCodes 1\ -result {unknown option "-unknown"} @@ -749,38 +722,16 @@ variable locale [mclocale] mclocale foo_bar mcset foo k1 v1 } -cleanup { mclocale $locale - namespace delete ::foo - } -body { - namespace eval ::foo { - list [::msgcat::mcexists k1]\ - [::msgcat::mcexists -namespace ::msgcat::test k1] - } - } -result {0 1} - - test msgcat-9.6 {mcexists -namespace ns parameter} -setup { - mcforgetpackage - variable locale [mclocale] - mclocale foo_bar - mcset foo k1 v1 - } -cleanup { - mclocale $locale - namespace delete ::foo - } -body { - namespace eval ::foo { - list [::msgcat::mcexists k1]\ - [::msgcat::mcexists -namespace ::msgcat::test k1] - } - } -result {0 1} - - test msgcat-9.7 {mcexists -namespace - ns argument missing} -body { - mcexists -namespace src - } -returnCodes 1\ - -result {Argument missing for switch "-namespace"} - + } -body { + namespace eval ::msgcat::test::sub { + list [::msgcat::mcexists k1]\ + [::msgcat::mcexists -exactnamespace k1] + } + } -result {1 0} # Tests msgcat-10.*: [mcloadedlocales] test msgcat-10.1 {mcloadedlocales no arg} -body { mcloadedlocales @@ -858,22 +809,17 @@ # Tests msgcat-12.*: [mcpackagelocale] test msgcat-12.1 {mcpackagelocale no subcommand} -body { mcpackagelocale } -returnCodes 1\ - -result {wrong # args: should be "mcpackagelocale subcommand ?arg ...?"} + -result {wrong # args: should be "mcpackagelocale subcommand ?locale?"} test msgcat-12.2 {mclpackagelocale wrong subcommand} -body { mcpackagelocale junk } -returnCodes 1\ -result {unknown subcommand "junk": must be clear, get, isset, loaded, present, set, or unset} - test msgcat-12.2.1 {mclpackagelocale set multiple args} -body { - mcpackagelocale set a b - } -returnCodes 1\ - -result {wrong # args: should be "mcpackagelocale set ?locale?"} - test msgcat-12.3 {mcpackagelocale set} -setup { variable locale [mclocale] } -cleanup { mclocale $locale mcforgetpackage @@ -973,34 +919,10 @@ mclocale foo mcpackagelocale set bar mcpackagelocale clear list [mcpackagelocale present foo] [mcpackagelocale present bar] } -result {0 1} - - test msgcat-12.11 {mcpackagelocale custom preferences} -setup { - variable locale [mclocale] - } -cleanup { - mclocale $locale - mcforgetpackage - } -body { - mclocale foo - set res [list [mcpackagelocale preferences]] - mcpackagelocale preferences bar {} - lappend res [mcpackagelocale preferences] - } -result {{foo {}} {bar {}}} - - test msgcat-12.12 {mcpackagelocale preferences -> no isset} -setup { - variable locale [mclocale] - } -cleanup { - mclocale $locale - mcforgetpackage - } -body { - mclocale foo - mcpackagelocale preferences - mcpackagelocale isset - } -result {0} - # Tests msgcat-13.*: [mcpackageconfig subcmds] test msgcat-13.1 {mcpackageconfig no subcommand} -body { mcpackageconfig @@ -1149,219 +1071,15 @@ mclocale foo_bar mc k1 } -returnCodes 1\ -result {fail} - - # Tests msgcat-15.*: tcloo coverage - - # There are 4 use-cases, where 3 must be tested now: - # - namespace defined, in class definition, class defined oo, classless - - test msgcat-15.1 {mc in class setup} -setup { - # full namespace is ::msgcat::test:bar - namespace eval bar { - ::msgcat::mcset foo_BAR con2 con2bar - oo::class create ClassCur - } - variable locale [mclocale] - mclocale foo_BAR - } -cleanup { - mclocale $locale - namespace eval bar {::msgcat::mcforgetpackage} - namespace delete bar - } -body { - oo::define bar::ClassCur msgcat::mc con2 - } -result con2bar - - test msgcat-15.2 {mc in class} -setup { - # full namespace is ::msgcat::test:bar - namespace eval bar { - ::msgcat::mcset foo_BAR con2 con2bar - oo::class create ClassCur - oo::define ClassCur method method1 {} {::msgcat::mc con2} - } - # full namespace is ::msgcat::test:baz - namespace eval baz { - set ObjCur [::msgcat::test::bar::ClassCur new] - } - variable locale [mclocale] - mclocale foo_BAR - } -cleanup { - mclocale $locale - namespace eval bar {::msgcat::mcforgetpackage} - namespace delete bar baz - } -body { - $baz::ObjCur method1 - } -result con2bar - - test msgcat-15.3 {mc in classless object} -setup { - # full namespace is ::msgcat::test:bar - namespace eval bar { - ::msgcat::mcset foo_BAR con2 con2bar - oo::object create ObjCur - oo::objdefine ObjCur method method1 {} {::msgcat::mc con2} - } - variable locale [mclocale] - mclocale foo_BAR - } -cleanup { - mclocale $locale - namespace eval bar {::msgcat::mcforgetpackage} - namespace delete bar - } -body { - bar::ObjCur method1 - } -result con2bar - - test msgcat-15.4 {mc in classless object with explicite namespace eval}\ - -setup { - # full namespace is ::msgcat::test:bar - namespace eval bar { - ::msgcat::mcset foo_BAR con2 con2bar - oo::object create ObjCur - oo::objdefine ObjCur method method1 {} { - namespace eval ::msgcat::test::baz { - ::msgcat::mc con2 - } - } - } - namespace eval baz { - ::msgcat::mcset foo_BAR con2 con2baz - } - variable locale [mclocale] - mclocale foo_BAR - } -cleanup { - mclocale $locale - namespace eval bar {::msgcat::mcforgetpackage} - namespace eval baz {::msgcat::mcforgetpackage} - namespace delete bar baz - } -body { - bar::ObjCur method1 - } -result con2baz - - # Test msgcat-16.*: command mcpackagenamespaceget - - test msgcat-16.1 {mcpackagenamespaceget in namespace procedure} -body { - namespace eval baz {msgcat::mcpackagenamespaceget} - } -result ::msgcat::test::baz - - test msgcat-16.2 {mcpackagenamespaceget in class setup} -setup { - namespace eval bar { - oo::class create ClassCur - oo::define ClassCur variable a - } - } -cleanup { - namespace delete bar - } -body { - oo::define bar::ClassCur msgcat::mcpackagenamespaceget - } -result ::msgcat::test::bar - - test msgcat-16.3 {mcpackagenamespaceget in class} -setup { - namespace eval bar { - oo::class create ClassCur - oo::define ClassCur method method1 {} {msgcat::mcpackagenamespaceget} - } - namespace eval baz { - set ObjCur [::msgcat::test::bar::ClassCur new] - } - } -cleanup { - namespace delete bar baz - } -body { - $baz::ObjCur method1 - } -result ::msgcat::test::bar - - test msgcat-16.4 {mcpackagenamespaceget in classless object} -setup { - namespace eval bar { - oo::object create ObjCur - oo::objdefine ObjCur method method1 {} {msgcat::mcpackagenamespaceget} - } - } -cleanup { - namespace delete bar - } -body { - bar::ObjCur method1 - } -result ::msgcat::test::bar - - test msgcat-16.5\ - {mcpackagenamespaceget in classless object with explicite namespace eval}\ - -setup { - namespace eval bar { - oo::object create ObjCur - oo::objdefine ObjCur method method1 {} { - namespace eval ::msgcat::test::baz { - msgcat::mcpackagenamespaceget - } - } - } - } -cleanup { - namespace delete bar baz - } -body { - bar::ObjCur method1 - } -result ::msgcat::test::baz - - - # Test msgcat-17.*: mcn command - - test msgcat-17.1 {mcn no parameters} -body { - mcn - } -returnCodes 1\ - -result {wrong # args: should be "mcn ns src ?arg ...?"} - - test msgcat-17.2 {mcn} -setup { - namespace eval bar {::msgcat::mcset foo_BAR con1 con1bar} - variable locale [mclocale] - mclocale foo_BAR - } -cleanup { - mclocale $locale - } -body { - ::msgcat::mcn [namespace current]::bar con1 - } -result con1bar - - interp bgerror {} $bgerrorsaved - - # Tests msgcat-18.*: [mcutil] - - test msgcat-18.1 {mcutil - no argument} -body { - mcutil - } -returnCodes 1\ - -result {wrong # args: should be "mcutil subcommand ?arg ...?"} - - test msgcat-18.2 {mcutil - wrong argument} -body { - mcutil junk - } -returnCodes 1\ - -result {unknown subcommand "junk": must be getpreferences, or getsystemlocale} - - test msgcat-18.3 {mcutil - partial argument} -body { - mcutil getsystem - } -returnCodes 1\ - -result {unknown subcommand "getsystem": must be getpreferences, or getsystemlocale} - - test msgcat-18.4 {mcutil getpreferences - no argument} -body { - mcutil getpreferences - } -returnCodes 1\ - -result {wrong # args: should be "mcutil getpreferences locale"} - - test msgcat-18.5 {mcutil getpreferences - DE_de} -body { - mcutil getpreferences DE_de - } -result {de_de de {}} - - test msgcat-18.6 {mcutil getsystemlocale - wrong argument} -body { - mcutil getsystemlocale DE_de - } -returnCodes 1\ - -result {wrong # args: should be "mcutil getsystemlocale"} - - # The result is system dependent - # So just test if it runs - # The environment variable version was test with test 0.x - test msgcat-18.7 {mcutil getsystemlocale} -body { - mcutil getsystemlocale - set ok ok - } -result {ok} - cleanupTests } namespace delete ::msgcat::test return # Local Variables: # mode: tcl # End: Index: tests/namespace-old.test ================================================================== --- tests/namespace-old.test +++ tests/namespace-old.test @@ -291,17 +291,16 @@ namespace eval test_ns_hier3b {} } namespace eval test_ns_hier2a {} namespace eval test_ns_hier2b {} } -# TIP 278: secondary lookup disabled for vars, tests disabled with # test namespace-old-5.4 {nested namespaces can access global namespace} { - list [namespace eval test_ns_hier1 {#set test_ns_var_global}] \ + list [namespace eval test_ns_hier1 {set test_ns_var_global}] \ [namespace eval test_ns_hier1 {test_ns_cmd_global}] \ - [namespace eval test_ns_hier1::test_ns_hier2 {#set test_ns_var_global}] \ + [namespace eval test_ns_hier1::test_ns_hier2 {set test_ns_var_global}] \ [namespace eval test_ns_hier1::test_ns_hier2 {test_ns_cmd_global}] -} {{} {cmd in ::} {} {cmd in ::}} +} {{var in ::} {cmd in ::} {var in ::} {cmd in ::}} test namespace-old-5.5 {variables in different namespaces don't conflict} { list [set test_ns_hier1::test_ns_level] \ [set test_ns_hier1::test_ns_hier2::test_ns_level] } {1 2} test namespace-old-5.6 {commands in different namespaces don't conflict} { @@ -467,42 +466,39 @@ proc test_ns_cache1::test_ns_cache2::test_ns_cache_cmd {} { return "cache2 version" } list [test_ns_cache1::trigger] [test_ns_cache1::test_ns_cache2::trigger] } {{cache2 version} {cache2 version}} -# TIP 278: secondary lookup disabled, catch added, result changed from {global version} test namespace-old-6.12 {define test variables} { variable test_ns_cache_var "global version" set trigger {set test_ns_cache_var} - list [catch {namespace eval test_ns_cache1 $trigger} msg] $msg -} {1 {can't read "test_ns_cache_var": no such variable}} + namespace eval test_ns_cache1 $trigger +} {global version} set trigger {set test_ns_cache_var} test namespace-old-6.13 {one-level check for variable shadowing} { namespace eval test_ns_cache1 { variable test_ns_cache_var "cache1 version" } namespace eval test_ns_cache1 $trigger } {cache1 version} variable ::test_ns_cache_var "global version" -# TIP 278: secondary lookup disabled, catch added, result changed from {global version} test namespace-old-6.14 {deleting variables changes variable epoch} { namespace eval test_ns_cache1 { variable test_ns_cache_var "cache1 version" } list [namespace eval test_ns_cache1 $trigger] \ [namespace eval test_ns_cache1 {unset test_ns_cache_var}] \ - [catch {namespace eval test_ns_cache1 $trigger}] -} {{cache1 version} {} 1} -# TIP 278: secondary lookup disabled, catch added, result changed + [namespace eval test_ns_cache1 $trigger] +} {{cache1 version} {} {global version}} test namespace-old-6.15 {define test namespaces} { namespace eval test_ns_cache2 { variable test_ns_cache_var "global cache2 version" } set trigger2 {set test_ns_cache2::test_ns_cache_var} - catch {list [namespace eval test_ns_cache1 $trigger2] \ - [namespace eval test_ns_cache1::test_ns_cache2 $trigger]} -} 1 + list [namespace eval test_ns_cache1 $trigger2] \ + [namespace eval test_ns_cache1::test_ns_cache2 $trigger] +} {{global cache2 version} {global version}} set trigger2 {set test_ns_cache2::test_ns_cache_var} test namespace-old-6.16 {public variables affect all parent namespaces} { variable test_ns_cache1::test_ns_cache2::test_ns_cache_var "cache2 version" list [namespace eval test_ns_cache1 $trigger2] \ [namespace eval test_ns_cache1::test_ns_cache2 $trigger] @@ -751,17 +747,17 @@ list [lsort [info commands cmd?]] \ [catch {cmd1 another test} msg] $msg } {{} 1 {invalid command name "cmd1"}} test namespace-old-9.15 {existing commands can't be overwritten} { proc cmd1 {x y} { - return [expr $x+$y] + return [expr {$x+$y}] } list [catch {namespace import test_ns_import::cmd?} msg] $msg \ [cmd1 3 5] } {1 {can't import command "cmd1": already exists} 8} test namespace-old-9.16 {use "-force" option to override existing commands} { - proc cmd1 {x y} { return [expr $x+$y] } + proc cmd1 {x y} { return [expr {$x+$y}] } list [cmd1 3 5] \ [namespace import -force test_ns_import::cmd?] \ [cmd1 3 5] } {8 {} {cmd1: 3 5}} test namespace-old-9.17 {commands can be imported into many namespaces} { Index: tests/namespace.test ================================================================== --- tests/namespace.test +++ tests/namespace.test @@ -10,12 +10,14 @@ # Copyright (c) 1998-2000 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} testConstraint memory [llength [info commands memory]] ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -44,13 +46,13 @@ } {:: :: ::} test namespace-2.2 {Tcl_GetCurrentNamespace} { set l {} lappend l [namespace current] namespace eval test_ns_1 { - lappend ::l [namespace current] + lappend l [namespace current] namespace eval foo { - lappend ::l [namespace current] + lappend l [namespace current] } } lappend l [namespace current] } {:: ::test_ns_1 ::test_ns_1::foo ::} @@ -177,25 +179,25 @@ trace add command x delete "namespace delete [namespace current];#" } namespace delete test_ns_2 } {} test namespace-7.7 {Bug 1655305} -setup { - interp create slave + interp create child # Can't invoke through the ensemble, since deleting the global namespace # (indirectly, via deleting ::tcl) deletes the ensemble. - slave eval {rename ::tcl::info::commands ::infocommands} - slave hide infocommands - slave eval { + child eval {rename ::tcl::info::commands ::infocommands} + child hide infocommands + child eval { proc foo {} { namespace delete :: } } } -body { - slave eval foo - slave invokehidden infocommands + child eval foo + child invokehidden infocommands } -cleanup { - interp delete slave + interp delete child } -result {} test namespace-7.8 {Bug ba1419303b4c} -setup { namespace eval ns1 { namespace ensemble create @@ -267,32 +269,32 @@ list [lsort [info commands test_ns_import::*]] \ [namespace delete test_ns_export] \ [info commands test_ns_import::*] } [list [lsort {::test_ns_import::p ::test_ns_import::cmd1 ::test_ns_import::cmd2}] {} ::test_ns_import::p] test namespace-8.5 {TclTeardownNamespace: preserve errorInfo; errorCode values} { - interp create slave - slave eval {trace add execution error leave {namespace delete :: ;#}} - catch {slave eval error foo bar baz} - interp delete slave - set ::errorInfo -} {bar - invoked from within -"slave eval error foo bar baz"} -test namespace-8.6 {TclTeardownNamespace: preserve errorInfo; errorCode values} { - interp create slave - slave eval {trace add variable errorCode write {namespace delete :: ;#}} - catch {slave eval error foo bar baz} - interp delete slave - set ::errorInfo -} {bar - invoked from within -"slave eval error foo bar baz"} -test namespace-8.7 {TclTeardownNamespace: preserve errorInfo; errorCode values} { - interp create slave - slave eval {trace add execution error leave {namespace delete :: ;#}} - catch {slave eval error foo bar baz} - interp delete slave + interp create child + child eval {trace add execution error leave {namespace delete :: ;#}} + catch {child eval error foo bar baz} + interp delete child + set ::errorInfo +} {bar + invoked from within +"child eval error foo bar baz"} +test namespace-8.6 {TclTeardownNamespace: preserve errorInfo; errorCode values} { + interp create child + child eval {trace add variable errorCode write {namespace delete :: ;#}} + catch {child eval error foo bar baz} + interp delete child + set ::errorInfo +} {bar + invoked from within +"child eval error foo bar baz"} +test namespace-8.7 {TclTeardownNamespace: preserve errorInfo; errorCode values} { + interp create child + child eval {trace add execution error leave {namespace delete :: ;#}} + catch {child eval error foo bar baz} + interp delete child set ::errorCode } baz test namespace-9.1 {Tcl_Import, empty import pattern} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -644,12 +646,10 @@ namespace eval test_ns_1 { list [catch {set ::test_ns_777::v} msg] $msg \ [catch {namespace children test_ns_777} msg] $msg } } -result {1 {can't read "::test_ns_777::v": no such variable} 1 {namespace "test_ns_777" not found in "::test_ns_1"}} - -# TIP 278: secondary lookup disabled, results changed from {10 20} test namespace-14.3 {TclGetNamespaceForQualName, relative names} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} variable v 10 namespace eval test_ns_1::test_ns_2 { variable v 20 @@ -657,15 +657,13 @@ namespace eval test_ns_2 { variable v 30 } } -body { namespace eval test_ns_1 { - # list $v $test_ns_2::v - list [catch {set v} msg] $msg [catch {set test_ns_2::v} msg] $msg + list $v $test_ns_2::v } -} -result {1 {can't read "v": no such variable} 0 20} - +} -result {10 20} test namespace-14.4 {TclGetNamespaceForQualName, relative ns names looked up only in current ns} { namespace eval test_ns_1::test_ns_2 { namespace eval foo {} } namespace eval test_ns_1 { @@ -722,21 +720,19 @@ } -body { lappend l [catch {test_ns_1::test_ns_2:: hello} msg] $msg proc test_ns_1::test_ns_2:: {args} {return "\{\}: $args"} lappend l [test_ns_1::test_ns_2:: hello] } -result {1 {invalid command name "test_ns_1::test_ns_2::"} {{}: hello}} - -# TIP 278: secondary lookup disabled, added catch, result changed from y test namespace-14.12 {TclGetNamespaceForQualName, extra ::s are significant for vars} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} } -body { namespace eval test_ns_1 { variable {} - catch {set test_ns_1::(x) y} ::msg + set test_ns_1::(x) y } - list $::msg [catch {set test_ns_1::(x)} msg] $msg -} -result {{can't set "test_ns_1::(x)": parent namespace doesn't exist} 1 {can't read "test_ns_1::(x)": no such variable}} + set test_ns_1::(x) +} -result y test namespace-14.13 {TclGetNamespaceForQualName, namespace other than global ns can't have empty name} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} } -returnCodes error -body { namespace eval test_ns_1 { proc {} {} {} @@ -905,19 +901,17 @@ } -body { namespace eval test_ns_1 { set x } } -result {777} - -# TIP 278: secondary lookup disabled, catch added, result changed from 314159 test namespace-17.7 {Tcl_FindNamespaceVar, relative name found} { namespace eval test_ns_1 { variable x 777 unset x - list [catch {set x} msg] $msg ;# must not be global x now + set x ;# must be global x now } -} {1 {can't read "x": no such variable}} +} {314159} test namespace-17.8 {Tcl_FindNamespaceVar, relative name not found} -body { namespace eval test_ns_1 { set wuzzat } } -returnCodes error -result {can't read "wuzzat": no such variable} @@ -925,12 +919,10 @@ namespace eval test_ns_1 { variable a hello } set test_ns_1::a } {hello} - -# TIP 278: secondary lookup disabled, result changed from 1 test namespace-17.10 {Tcl_FindNamespaceVar, interference with cached varNames} -setup { namespace eval test_ns_1 {} } -body { proc test_ns {} { set ::test_ns_1::a 0 @@ -940,11 +932,11 @@ namespace eval test_ns_1 unset a set a 0 namespace eval test_ns_1 set a 1 namespace delete test_ns_1 return $a -} -result 0 +} -result 1 catch {unset a} catch {unset x} catch {unset l} catch {rename foo {}} @@ -1561,12 +1553,10 @@ [namespace which p] \ [namespace which cmd1] \ [namespace which ::test_ns_2::cmd2] } } -result {::foreach ::test_ns_3::p ::test_ns_3::cmd1 ::test_ns_2::cmd2} - -# TIP 278: secondary lookup disabled, catch added, result changed test namespace-34.7 {NamespaceWhichCmd, variable lookup} -setup { catch {namespace delete {*}[namespace children test_ns_*]} namespace eval test_ns_1 { namespace export cmd* proc cmd1 {args} {return "cmd1: $args"} @@ -1582,16 +1572,16 @@ variable v3 333 namespace import ::test_ns_2::* } } -body { namespace eval test_ns_3 { - list [catch {namespace which -variable env } msg] $msg \ + list [namespace which -variable env] \ [namespace which -variable v3] \ [namespace which -variable ::test_ns_2::v2] \ [catch {namespace which -variable ::test_ns_2::noSuchVar} msg] $msg } -} -result {0 {} ::test_ns_3::v3 ::test_ns_2::v2 0 {}} +} -result {::env ::test_ns_3::v3 ::test_ns_2::v2 0 {}} test namespace-35.1 {FreeNsNameInternalRep, resulting ref count > 0} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} } -body { namespace eval test_ns_1 { @@ -2634,10 +2624,11 @@ lappend result [::test_ns_1::test_ns_2::pathtestA] } -result "1,2,1,::test_ns_1 {global,2,global,:: ::test_ns_1} {global,1,global,:: ::test_ns_1} {global,global,global,:: ::test_ns_1}" -cleanup { namespace delete ::test_ns_1 catch {rename ::pathtestB {}} catch {rename ::pathtestD {}} + catch {rename ::pathtestC {}} } test namespace-51.7 {name resolution path control} -body { namespace eval ::test_ns_1 { } namespace eval ::test_ns_2 { @@ -2806,13 +2797,13 @@ } -result 1_2 -cleanup { namespace delete ::test_ns_1 namespace delete ::test_ns_2 } test namespace-51.16 {Bug 1566526} { - interp create slave - slave eval namespace eval demo namespace path :: - interp delete slave + interp create child + child eval namespace eval demo namespace path :: + interp delete child } {} test namespace-51.17 {resolution epoch handling: Bug 2898722} -setup { set result {} catch {namespace delete ::a} } -body { @@ -3009,23 +3000,23 @@ proc unknown args { return SUCCESS } } catch {rename ::noSuchCommand {}} - set ::slave [interp create] + set ::child [interp create] } -body { - $::slave alias bar noSuchCommand + $::child alias bar noSuchCommand namespace eval test_ns_1 { namespace unknown unknown proc unknown args { return FAIL } - $::slave eval bar + $::child eval bar } } -cleanup { - interp delete $::slave - unset ::slave + interp delete $::child + unset ::child namespace delete test_ns_1 rename ::unknown {} rename unknown.save ::unknown namespace eval :: [list namespace unknown $handler] } -result SUCCESS @@ -3345,10 +3336,53 @@ } -body { namespace-56.5 cmd } -cleanup { namespace delete namespace-56.5 } -result 1 + + + +test namespace-57.0 { + an imported alias should be usable in the deletion trace for the alias + + see 29e8848eb976 +} -body { + variable res {} + namespace eval ns2 { + namespace export * + proc p1 {oldname newname op} { + return success + } + + interp alias {} [namespace current]::p2 {} [namespace which p1] + } + + + namespace eval ns3 { + namespace import ::ns2::p2 + } + + + set ondelete [list apply [list {oldname newname op} { + variable res + catch { + ns3::p2 $oldname $newname $op + } cres + lappend res $cres + } [namespace current]]] + + + trace add command ::ns2::p2 delete $ondelete + rename ns2::p2 {} + return $res +} -cleanup { + unset res + namespace delete ns2 + namespace delete ns3 +} -result success + + # cleanup catch {rename cmd1 {}} catch {unset l} Index: tests/notify.test ================================================================== --- tests/notify.test +++ tests/notify.test @@ -11,12 +11,12 @@ # Copyright (c) 2003 by Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] Index: tests/nre.test ================================================================== --- tests/nre.test +++ tests/nre.test @@ -7,12 +7,12 @@ # Copyright (c) 2008 by Miguel Sofer. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -27,13 +27,13 @@ if {[testConstraint testnrelevels]} { namespace eval testnre { namespace path ::tcl::mathop # # [testnrelevels] returns a 6-list with: C-stack depth, iPtr->numlevels, - # cmdFrame level, callFrame level, tosPtr and callback depth + # cmdFrame level, callFrame level, tosPtr and callback depth # - variable last [testnrelevels] + variable last [testnrelevels] proc depthDiff {} { variable last set depth [testnrelevels] set res {} foreach t $depth l $last { @@ -327,11 +327,11 @@ proc outer {} inner lrange [outer] 0 2 } -cleanup { rename inner {} rename outer {} -} -result {1 1 1} +} -result {1 1 1} test nre-8.2 {nre and {*}, [Bug 2415422]} -body { # force an expansion that grows the evaluation stack, check that nre # adapts the bcFramePtr. This causes an NRE assertion to fail if it is not # done properly. proc nop {} {} Index: tests/obj.test ================================================================== --- tests/obj.test +++ tests/obj.test @@ -9,34 +9,36 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] testConstraint testobj [llength [info commands testobj]] -testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] -testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}] +testConstraint longIs32bit [expr {int(0x80000000) < 0}] +testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}] test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} testobj { set r 1 foreach {t} { + {array search} bytearray bytecode cmdName dict + end-offset regexp string } { set first [string first $t [testobj types]] - set r [expr {$r && ($first != -1)}] + set r [expr {$r && ($first >= 0)}] } set result $r } {1} test obj-2.1 {Tcl_GetObjType error} testobj { @@ -49,10 +51,19 @@ lappend result [testobj convert 1 bytearray] lappend result [testobj type 1] lappend result [testobj refcount 1] } {{} 12 12 bytearray 3} +test obj-3.1 {Tcl_ConvertToType error} testobj { + list [testdoubleobj set 1 12.34] \ + [catch {testobj convert 1 end-offset} msg] \ + $msg +} {12.34 1 {bad index "12.34": must be end?[+-]integer?}} +test obj-3.2 {Tcl_ConvertToType error, "empty string" object} testobj { + list [testobj newobj 1] [catch {testobj convert 1 end-offset} msg] $msg +} {{} 1 {bad index "": must be end?[+-]integer?}} + test obj-4.1 {Tcl_NewObj and AllocateFreeObjects} testobj { set result "" lappend result [testobj freeallvars] lappend result [testobj newobj 1] lappend result [testobj type 1] @@ -69,20 +80,20 @@ test obj-6.1 {Tcl_DuplicateObj, object has internal rep} testobj { set result "" lappend result [testobj freeallvars] lappend result [testintobj set 1 47] - lappend result [testobj duplicate 1 2] + lappend result [testobj duplicate 1 2] lappend result [testintobj get 2] lappend result [testobj refcount 1] lappend result [testobj refcount 2] } {{} 47 47 47 2 3} test obj-6.2 {Tcl_DuplicateObj, "empty string" object} testobj { set result "" lappend result [testobj freeallvars] lappend result [testobj newobj 1] - lappend result [testobj duplicate 1 2] + lappend result [testobj duplicate 1 2] lappend result [testintobj get 2] lappend result [testobj refcount 1] lappend result [testobj refcount 2] } {{} {} {} {} 2 3} @@ -474,57 +485,57 @@ lappend result [testintobj set 1 512] lappend result [testintobj mult10 1] lappend result [testintobj get 1] ;# must update string rep } {512 5120 5120} -test obj-27.1 {Tcl_NewWideObj} testobj { +test obj-27.1 {Tcl_NewLongObj} testobj { set result "" lappend result [testobj freeallvars] - testintobj setmax 1 - lappend result [testintobj ismax 1] + testintobj setmaxlong 1 + lappend result [testintobj ismaxlong 1] lappend result [testobj type 1] lappend result [testobj refcount 1] } {{} 1 int 1} test obj-28.1 {Tcl_SetLongObj, existing "empty string" object} testobj { set result "" lappend result [testobj freeallvars] lappend result [testobj newobj 1] - lappend result [testintobj setint 1 77] ;# makes existing obj int + lappend result [testintobj setlong 1 77] ;# makes existing obj long int lappend result [testobj type 1] lappend result [testobj refcount 1] } {{} {} 77 int 2} test obj-28.2 {Tcl_SetLongObj, existing non-"empty string" object} testobj { set result "" lappend result [testobj freeallvars] lappend result [testdoubleobj set 1 12.34] - lappend result [testintobj setint 1 77] ;# makes existing obj int + lappend result [testintobj setlong 1 77] ;# makes existing obj long int lappend result [testobj type 1] lappend result [testobj refcount 1] } {{} 12.34 77 int 2} -test obj-29.1 {Tcl_GetWideIntFromObj, existing int object} testobj { +test obj-29.1 {Tcl_GetLongFromObj, existing long integer object} testobj { set result "" - lappend result [testintobj setint 1 22] - lappend result [testintobj mult10 1] ;# gets existingint rep + lappend result [testintobj setlong 1 22] + lappend result [testintobj mult10 1] ;# gets existing long int rep } {22 220} -test obj-29.2 {Tcl_GetWideIntFromObj, convert to int} testobj { +test obj-29.2 {Tcl_GetLongFromObj, convert to long} testobj { set result "" - lappend result [testintobj setint 1 477] + lappend result [testintobj setlong 1 477] lappend result [testintobj div10 1] ;# must convert to bool lappend result [testobj type 1] } {477 47 int} -test obj-29.3 {Tcl_GetWideIntFromObj, error converting to int} testobj { +test obj-29.3 {Tcl_GetLongFromObj, error converting to long integer} testobj { set result "" lappend result [teststringobj set 1 abc] - lappend result [catch {testintobj ismax 1} msg] ;# cvts to long int + lappend result [catch {testintobj ismaxlong 1} msg] ;# cvts to long int lappend result $msg } {abc 1 {expected integer but got "abc"}} -test obj-29.4 {Tcl_GetWideIntFromObj, error converting from "empty string"} testobj { +test obj-29.4 {Tcl_GetLongFromObj, error converting from "empty string"} testobj { set result "" lappend result [testobj newobj 1] - lappend result [catch {testintobj ismax 1} msg] ;# cvts to long int + lappend result [catch {testintobj ismaxlong 1} msg] ;# cvts to long int lappend result $msg } {{} 1 {expected integer but got ""}} test obj-30.1 {Ref counting and object deletion, simple types} testobj { set result "" @@ -538,46 +549,84 @@ lappend result [testobj type 2] lappend result [testobj refcount 1] lappend result [testobj refcount 2] } {{} 1024 1024 int 4 4 0 int 3 2} + +test obj-31.1 {regenerate string rep of "end"} testobj { + testobj freeallvars + teststringobj set 1 end + testobj convert 1 end-offset + testobj invalidateStringRep 1 +} end +test obj-31.2 {regenerate string rep of "end-1"} testobj { + testobj freeallvars + teststringobj set 1 end-0x1 + testobj convert 1 end-offset + testobj invalidateStringRep 1 +} end-1 +test obj-31.3 {regenerate string rep of "end--1"} testobj { + testobj freeallvars + teststringobj set 1 end--0x1 + testobj convert 1 end-offset + testobj invalidateStringRep 1 +} end--1 +test obj-31.4 {regenerate string rep of "end-bigInteger"} testobj { + testobj freeallvars + teststringobj set 1 end-0x7fffffff + testobj convert 1 end-offset + testobj invalidateStringRep 1 +} end-2147483647 +test obj-31.5 {regenerate string rep of "end--bigInteger"} testobj { + testobj freeallvars + teststringobj set 1 end--0x7fffffff + testobj convert 1 end-offset + testobj invalidateStringRep 1 +} end--2147483647 +test obj-31.6 {regenerate string rep of "end--bigInteger"} {testobj longIs32bit} { + testobj freeallvars + teststringobj set 1 end--0x80000000 + testobj convert 1 end-offset + testobj invalidateStringRep 1 +} end--2147483648 + test obj-32.1 {freeing very large object trees} { set x {} for {set i 0} {$i<100000} {incr i} { set x [list $x {}] } unset x } {} -test obj-33.1 {integer overflow on input} {longIs32bit wideIs64bit} { +test obj-33.1 {integer overflow on input} {longIs32bit wideBiggerThanInt} { set x 0x8000; append x 0000 list [string is integer $x] [expr { wide($x) }] } {1 2147483648} -test obj-33.2 {integer overflow on input} {longIs32bit wideIs64bit} { +test obj-33.2 {integer overflow on input} {longIs32bit wideBiggerThanInt} { set x 0xffff; append x ffff list [string is integer $x] [expr { wide($x) }] } {1 4294967295} test obj-33.3 {integer overflow on input} { set x 0x10000; append x 0000 list [string is integer $x] [expr { wide($x) }] -} {1 4294967296} -test obj-33.4 {integer overflow on input} {longIs32bit wideIs64bit} { +} {0 4294967296} +test obj-33.4 {integer overflow on input} {longIs32bit wideBiggerThanInt} { set x -0x8000; append x 0000 list [string is integer $x] [expr { wide($x) }] } {1 -2147483648} -test obj-33.5 {integer overflow on input} {longIs32bit wideIs64bit} { +test obj-33.5 {integer overflow on input} {longIs32bit wideBiggerThanInt} { set x -0x8000; append x 0001 list [string is integer $x] [expr { wide($x) }] } {1 -2147483649} -test obj-33.6 {integer overflow on input} {longIs32bit wideIs64bit} { +test obj-33.6 {integer overflow on input} {longIs32bit wideBiggerThanInt} { set x -0xffff; append x ffff list [string is integer $x] [expr { wide($x) }] } {1 -4294967295} test obj-33.7 {integer overflow on input} { set x -0x10000; append x 0000 list [string is integer $x] [expr { wide($x) }] -} {1 -4294967296} +} {0 -4294967296} test obj-34.1 {mp_iseven} testobj { set result "" lappend result [testbignumobj set 1 0] lappend result [testbignumobj iseven 1] ; Index: tests/oo.test ================================================================== --- tests/oo.test +++ tests/oo.test @@ -6,19 +6,21 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. package require TclOO 1.0.3 -package require tcltest 2 -if {"::tcltest" in [namespace children]} { +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } + # The foundational objects oo::object and oo::class are sensitive to reference # counting errors and are deallocated only when an interp is deleted, so in # this test suite, interp creation and interp deletion are often used in # leaktests in order to leverage this sensitivity. + testConstraint memory [llength [info commands memory]] if {[testConstraint memory]} { proc getbytes {} { set lines [split [memory info] \n] @@ -109,12 +111,12 @@ } -cleanup { foo destroy } -result 0 test oo-0.9 {various types of presence of the TclOO package} { list [lsearch -nocase -all -inline [package names] tcloo] \ - [package present TclOO] [package versions TclOO] -} [list TclOO $::oo::patchlevel $::oo::patchlevel] + [package present TclOO] [expr {$::oo::patchlevel in [package versions TclOO]}] +} [list TclOO $::oo::patchlevel 1] test oo-1.1 {basic test of OO functionality: no classes} { set result {} lappend result [oo::object create foo] lappend result [oo::objdefine foo { @@ -127,15 +129,15 @@ lappend result [foo bar a b c] lappend result [foo destroy] [info commands foo] } {::foo {} a b c 3 {} {}} test oo-1.2 {basic test of OO functionality: no classes} -body { oo::define oo::object method missingArgs -} -returnCodes 1 -result "wrong # args: should be \"oo::define oo::object method name ?option? args body\"" +} -returnCodes 1 -result "wrong # args: should be \"oo::define oo::object method name args body\"" test oo-1.3 {basic test of OO functionality: no classes} { catch {oo::define oo::object method missingArgs} set errorInfo -} "wrong # args: should be \"oo::define oo::object method name ?option? args body\" +} "wrong # args: should be \"oo::define oo::object method name args body\" while executing \"oo::define oo::object method missingArgs\"" test oo-1.4 {basic test of OO functionality} -body { oo::object create {} } -returnCodes 1 -result {object name must not be empty} @@ -302,19 +304,53 @@ } } -cleanup { rename test-oo-1.18 {} } -result 0 test oo-1.18.3 {Bug 21c144f0f5} -setup { - interp create slave + interp create child } -body { - slave eval { + child eval { oo::define [oo::class create foo] superclass oo::class oo::class destroy } } -cleanup { - interp delete slave + interp delete child } +test oo-1.18.4 {correct handling of cleanup in superclass set error} -setup { + interp create child +} -body { + child eval { + oo::class create A + oo::class create B { + superclass oo::class + constructor {} { + next {superclass A} + next {superclass -append A} + } + } + [B create C] create d + } +} -returnCodes error -cleanup { + interp delete child +} -result {class should only be a direct superclass once} +test oo-1.18.5 {correct handling of cleanup in superclass set error} -setup { + interp create child +} -body { + child eval { + oo::class create A + oo::class create B { + superclass oo::class + constructor {c} { + next {superclass A} + next [list superclass -append {*}$c] + } + } + [B create C {B C}] create d + } +} -returnCodes error -cleanup { + interp delete child +} -result {attempt to form circular dependency graph} test oo-1.19 {basic test of OO functionality: teardown order} -body { oo::object create o namespace delete [info object namespace o] o destroy # Crashes on error @@ -327,24 +363,23 @@ } -result {} test oo-1.21 {basic test of OO functionality: default relations} -setup { set fresh [interp create] } -body { lmap x [$fresh eval { - set initials {::oo::object ::oo::class ::oo::Slot} foreach cmd {instances subclasses mixins superclass} { - foreach initial $initials { - lappend x [info class $cmd $initial] + foreach initial {object class Slot} { + lappend x [info class $cmd ::oo::$initial] } } - foreach initial $initials { - lappend x [info object class $initial] + foreach initial {object class Slot} { + lappend x [info object class ::oo::$initial] } return $x - }] {lsort [lsearch -all -not -inline $x *::delegate]} + }] {lsort $x} } -cleanup { interp delete $fresh -} -result {{} {::oo::Slot ::oo::abstract ::oo::class ::oo::object ::oo::singleton} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class} {::oo::abstract ::oo::singleton} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class} +} -result {{} {::oo::Slot ::oo::class ::oo::object} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class} {} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class} test oo-2.1 {basic test of OO functionality: constructor} -setup { # This is a bit complex because it needs to run in a sub-interp as # we're modifying the root object class's constructor interp create subinterp @@ -777,80 +812,10 @@ } [testClass new] foo } -cleanup { testClass destroy } -result ok -test oo-4.7 {basic test of OO functionality: method -export flag} -setup { - set o [oo::object new] - unset -nocomplain result -} -body { - oo::objdefine $o { - method Foo {} { - lappend ::result Foo - return foo - } - method Bar -export {} { - lappend ::result Bar - return bar - } - } - lappend result [catch {$o Foo} msg] $msg - lappend result [$o Bar] -} -cleanup { - $o destroy -} -result {1 {unknown method "Foo": must be Bar or destroy} Bar bar} -test oo-4.8 {basic test of OO functionality: method -unexport flag} -setup { - set o [oo::object new] - unset -nocomplain result -} -body { - oo::objdefine $o { - method foo {} { - lappend ::result foo - return Foo - } - method bar -unexport {} { - lappend ::result bar - return Bar - } - } - lappend result [$o foo] - lappend result [catch {$o bar} msg] $msg -} -cleanup { - $o destroy -} -result {foo Foo 1 {unknown method "bar": must be destroy or foo}} -test oo-4.9 {basic test of OO functionality: method -private flag} -setup { - set o [oo::object new] - unset -nocomplain result -} -body { - oo::objdefine $o { - method foo {} { - lappend ::result foo - return Foo - } - method bar -private {} { - lappend ::result bar - return Bar - } - export eval - method gorp {} { - my bar - } - } - lappend result [$o foo] - lappend result [catch {$o bar} msg] $msg - lappend result [catch {$o eval my bar} msg] $msg - lappend result [$o gorp] -} -cleanup { - $o destroy -} -result {foo Foo 1 {unknown method "bar": must be destroy, eval, foo or gorp} 1 {unknown method "bar": must be , destroy, eval, foo, gorp, unknown, variable or varname} bar Bar} -test oo-4.10 {basic test of OO functionality: method flag parsing} -setup { - set o [oo::object new] -} -body { - oo::objdefine $o method foo -gorp xyz {return Foo} -} -returnCodes error -cleanup { - $o destroy -} -result {bad export flag "-gorp": must be -export, -private, or -unexport} test oo-5.1 {OO: manipulation of classes as objects} -setup { set obj [oo::object new] } -body { oo::objdefine oo::object method foo {} { return "in object" } @@ -1403,27 +1368,56 @@ } lappend result [catch {[foo2 new] bar} msg] $msg } -result {foo2 foo 1 {no next method implementation}} test oo-7.9 {OO: defining inheritance in namespaces} -setup { set ::result {} - oo::class create ::master + oo::class create ::parent namespace eval ::foo { - oo::class create mixin {superclass ::master} + oo::class create mixin {superclass ::parent} } } -cleanup { - ::master destroy + ::parent destroy namespace delete ::foo } -body { namespace eval ::foo { - oo::class create bar {superclass master} + oo::class create bar {superclass parent} oo::class create boo oo::define boo {superclass bar} oo::define boo {mixin mixin} oo::class create spong {superclass boo} return } } -result {} +test oo-7.10 {OO: next after object deletion, bug [135804138e]} -setup { + set ::result "" + oo::class create c1 { + method m1 {} { + lappend ::result c1::m1 + } + } + oo::class create c2 { + superclass c1 + destructor { + lappend ::result c2::destructor + my m1 + lappend ::result /c2::destructor + } + method m1 {} { + lappend ::result c2::m1 + rename [self] {} + lappend ::result no-self + next + lappend ::result /c2::m1 + } + } +} -body { + c2 create o + lappend ::result [catch {o m1} msg] $msg +} -cleanup { + c1 destroy + unset ::result +} -result {c2::m1 c2::destructor c2::m1 no-self c1::m1 /c2::m1 /c2::destructor no-self 1 {no next method implementation}} test oo-8.1 {OO: global must work in methods} { oo::object create foo oo::objdefine foo method bar x {global result; lappend result $x} set result {} @@ -1674,14 +1668,14 @@ test oo-11.6.4 { OO: cleanup ReleaseClassContents() where class is mixed into one of its instances } -body { oo::class create obj1 - ::oo::define obj1 {self mixin [self]} + ::oo::define obj1 {self mixin [uplevel 1 {namespace which obj1}]} ::oo::copy obj1 obj2 - ::oo::objdefine obj2 {mixin [self]} + ::oo::objdefine obj2 {mixin [uplevel 1 {namespace which obj2}]} ::oo::copy obj2 obj3 rename obj3 {} rename obj2 {} @@ -1902,11 +1896,11 @@ } -body { oo::objdefine fooObj { class oo::class } oo::define fooObj { - method x {} {expr 1+2+3} + method x {} {expr {1+2+3}} } [fooObj new] x } -cleanup { fooObj destroy } -result 6 @@ -1914,11 +1908,11 @@ oo::class create foo unset -nocomplain ::result } -body { set result dangling oo::define foo { - method x {} {expr 1+2+3} + method x {} {expr {1+2+3}} } oo::class create boo { superclass foo destructor {set ::result "ok"} } @@ -1937,11 +1931,11 @@ oo::class create bar unset -nocomplain result } -body { oo::define bar method x {} {return ok} oo::define foo { - method x {} {expr 1+2+3} + method x {} {expr {1+2+3}} self mixin foo } lappend result [foo x] oo::objdefine foo class bar lappend result [foo x] @@ -1951,11 +1945,11 @@ } -result {6 ok} test oo-13.8 {OO: changing an object's class to itself} -setup { oo::class create foo } -body { oo::define foo { - method x {} {expr 1+2+3} + method x {} {expr {1+2+3}} } oo::objdefine foo class foo } -cleanup { foo destroy } -returnCodes error -result {may not change classes into an instance of themselves} @@ -2070,45 +2064,45 @@ } -cleanup { c destroy mix destroy } -result >>foobar<< test oo-14.6 {OO and mixins of mixins - Bug 1960703} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create A { - superclass master + superclass parent method egg {} { return chicken } } oo::class create B { - superclass master + superclass parent mixin A method bar {} { # mixin from A my egg } } oo::class create C { - superclass master + superclass parent mixin B method foo {} { # mixin from B my bar } } [C new] foo } -result chicken test oo-14.7 {OO and filters from mixins of mixins} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create A { - superclass master + superclass parent method egg {} { return chicken } filter f method f args { @@ -2115,20 +2109,20 @@ set m [lindex [self target] 1] return "($m) [next {*}$args] ($m)" } } oo::class create B { - superclass master + superclass parent mixin A filter f method bar {} { # mixin from A my egg } } oo::class create C { - superclass master + superclass parent mixin B filter f method foo {} { # mixin from B my bar @@ -2136,22 +2130,22 @@ } [C new] foo } -result {(foo) (bar) (egg) chicken (egg) (bar) (foo)} test oo-14.8 {OO: class mixin order - Bug 1998221} -setup { set ::result {} - oo::class create master { + oo::class create parent { method test {} {} } } -cleanup { - master destroy + parent destroy } -body { oo::class create mix { - superclass master + superclass parent method test {} {lappend ::result mix; next; return $::result} } oo::class create cls { - superclass master + superclass parent mixin mix method test {} {lappend ::result cls; next; return $::result} } [cls new] test } -result {mix cls} @@ -2393,11 +2387,11 @@ test oo-16.2 {OO: object introspection} -body { info object class NOTANOBJECT } -returnCodes 1 -result {NOTANOBJECT does not refer to an object} test oo-16.3 {OO: object introspection} -body { info object gorp oo::object -} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, class, creationid, definition, filters, forward, isa, methods, methodtype, mixins, namespace, variables, or vars} +} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, class, definition, filters, forward, isa, methods, methodtype, mixins, namespace, variables, or vars} test oo-16.4 {OO: object introspection} -setup { oo::class create meta { superclass oo::class } [meta create instance1] create instance2 } -body { list [list [info object class oo::object] \ @@ -2523,77 +2517,10 @@ [info object isa mixin oo::object list] \ [info object isa mixin list oo::object]] } -cleanup { meta destroy } -result {class {0 0} meta {0 0 0} type {0 0 0 0 0 0} mix {0 0 0 0 0 0}} -test oo-16.15 {OO: object introspection: creationid #500} -setup { - oo::class create cls -} -body { - info object creationid [cls new] -} -cleanup { - cls destroy -} -result {^\d+$} -match regexp -test oo-16.16 {OO: object introspection: creationid #500} -setup { - oo::class create cls -} -body { - set obj [cls new] - set id [info object creationid $obj] - rename $obj gorp - set id2 [info object creationid gorp] - list $id $id2 -} -cleanup { - cls destroy -} -result {^(\d+) \1$} -match regexp -test oo-16.17 {OO: object introspection: creationid #500} -body { - info object creationid nosuchobject -} -returnCodes error -result {nosuchobject does not refer to an object} -test oo-16.18 {OO: object introspection: creationid #500} -body { - info object creationid -} -returnCodes error -result {wrong # args: should be "info object creationid objName"} -test oo-16.18.1 {OO: object introspection: creationid #500} -body { - info object creationid oo::object gorp -} -returnCodes error -result {wrong # args: should be "info object creationid objName"} -test oo-16.19 {OO: object introspection: creationid #500} -setup { - oo::class create cls -} -body { - set id1 [info object creationid [set o1 [cls new]]] - set id2 [info object creationid [set o2 [cls new]]] - if {$id1 == $id2} { - format "objects %s and %s have same creation id: %d" $o1 $o2 $id1 - } else { - string cat not-equal - } -} -cleanup { - cls destroy -} -result not-equal -test oo-16.20 {OO: object introspection: creationid #500} -setup { - oo::class create cls -} -body { - set id1 [info object creationid [set o1 [cls new]]] - $o1 destroy - set id2 [info object creationid [set o2 [cls new]]] - if {$id1 == $id2} { - format "objects %s and %s have same creation id: %d" $o1 $o2 $id1 - } else { - string cat not-equal - } -} -cleanup { - cls destroy -} -result not-equal -test oo-16.21 {OO: object introspection: creationid #500} -setup { - oo::class create cls -} -body { - set id1 [info object creationid [set o1 [cls new]]] - set id2 [info object creationid [set o2 [oo::copy $o1]]] - if {$id1 == $id2} { - format "objects %s and %s have same creation id: %d" $o1 $o2 $id1 - } else { - string cat not-equal - } -} -cleanup { - cls destroy -} -result not-equal test oo-17.1 {OO: class introspection} -body { info class } -returnCodes 1 -result "wrong \# args: should be \"info class subcommand ?arg ...?\"" test oo-17.1.1 {OO: class introspection} -body { @@ -2612,11 +2539,11 @@ } -returnCodes 1 -cleanup { foo destroy } -result {"foo" is not a class} test oo-17.4 {OO: class introspection} -body { info class gorp oo::object -} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, constructor, definition, definitionnamespace, destructor, filters, forward, instances, methods, methodtype, mixins, subclasses, superclasses, or variables} +} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, constructor, definition, destructor, filters, forward, instances, methods, methodtype, mixins, subclasses, superclasses, or variables} test oo-17.5 {OO: class introspection} -setup { oo::class create testClass } -body { testClass create foo testClass create bar @@ -2710,11 +2637,10 @@ lsort [info object methods o -all -private] } -cleanup { o destroy c destroy } -result $stdmethods - test oo-18.1 {OO: define command support} { list [catch {oo::define oo::object {error foo}} msg] $msg $errorInfo } {1 foo {foo while executing @@ -2850,17 +2776,17 @@ "error foo" (in definition script for object "::INST" line 1) invoked from within "oo::objdefine inst {rename ::inst ::INST;error foo}"}} test oo-18.8 {OO: define/self command support} -setup { - oo::class create master - oo::class create ::foo {superclass master} + oo::class create parent + oo::class create ::foo {superclass parent} } -body { catch {oo::define foo {rename ::foo ::bar; self {error foobar}}} msg opt dict get $opt -errorinfo } -cleanup { - master destroy + parent destroy } -result {foobar while executing "error foobar" (in definition script for class object "::bar" line 1) invoked from within @@ -2867,33 +2793,33 @@ "self {error foobar}" (in definition script for class "::bar" line 1) invoked from within "oo::define foo {rename ::foo ::bar; self {error foobar}}"} test oo-18.9 {OO: define/self command support} -setup { - oo::class create master + oo::class create parent set c [oo::class create now_this_is_a_very_very_long_class_name_indeed { - superclass master + superclass parent }] } -body { catch {oo::define $c {error err}} msg opt dict get $opt -errorinfo } -cleanup { - master destroy + parent destroy } -result {err while executing "error err" (in definition script for class "::now_this_is_a_very_very_long..." line 1) invoked from within "oo::define $c {error err}"} test oo-18.10 {OO: define/self command support} -setup { - oo::class create master - oo::class create ::foo {superclass master} + oo::class create parent + oo::class create ::foo {superclass parent} } -body { catch {oo::define foo {self {rename ::foo {}; error foobar}}} msg opt dict get $opt -errorinfo } -cleanup { - master destroy + parent destroy } -result {foobar while executing "error foobar" (in definition script for class object "::foo" line 1) invoked from within @@ -2900,17 +2826,17 @@ "self {rename ::foo {}; error foobar}" (in definition script for class "::foo" line 1) invoked from within "oo::define foo {self {rename ::foo {}; error foobar}}"} test oo-18.11 {OO: define/self command support} -setup { - oo::class create master - oo::class create ::foo {superclass master} + oo::class create parent + oo::class create ::foo {superclass parent} } -body { catch {oo::define foo {rename ::foo {}; self {error foobar}}} msg opt dict get $opt -errorinfo } -cleanup { - master destroy + parent destroy } -result {this command cannot be called when the object has been deleted while executing "self {error foobar}" (in definition script for class "::foo" line 1) invoked from within @@ -3529,32 +3455,32 @@ } -body { oo::objdefine foo variable a b c info object variables foo } -result {a b c} test oo-27.3 {variables declaration - basic behaviour} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x! constructor {} {set x! 1} method y {} {incr x!} } foo create bar bar y bar y } -result 3 test oo-27.4 {variables declaration - destructors too} -setup { - oo::class create master + oo::class create parent set result bad! } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x! constructor {} {set x! 1} method y {} {incr x!} destructor {set ::result ${x!}} } @@ -3575,16 +3501,16 @@ } foo y foo y } -result 2 test oo-27.6 {variables declaration - non-interference of levels} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x! constructor {} {set x! 1} method y {} {incr x!} } foo create bar @@ -3595,16 +3521,16 @@ } bar y list [bar y] [lsort [info object vars bar]] [bar eval {info vars *!}] } -result {{3 2 y! {}} {x! y!} {x! y!}} test oo-27.7 {variables declaration - one underlying variable space} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x! constructor {} {set x! 1} method y {} {incr x!} } oo::class create foo2 { @@ -3627,16 +3553,16 @@ } -returnCodes error -result {invalid declared variable name "bad::var": must not contain namespace separators} test oo-27.9 {variables declaration - error cases - arrays} -body { oo::define oo::object variable bad(var) } -returnCodes error -result {invalid declared variable name "bad(var)": must not refer to an array element} test oo-27.10 {variables declaration - no instance var leaks with class resolvers} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable clsvar constructor {} { set clsvar 0 } method step {} { @@ -3655,16 +3581,16 @@ inst2 step inst1 step list [inst1 value] [inst2 value] } -result {3 2} test oo-27.11 {variables declaration - no instance var leaks with class resolvers} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable clsvar constructor {} { set clsvar 0 } method step {} { @@ -3728,16 +3654,16 @@ [foo exists] [catch {foo get} msg] $msg } -cleanup { foo destroy } -result {0 7 1 7 {} 0 1 {can't read "x": no such variable}} test oo-27.14 {variables declaration - multiple use} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x variable y method boo {} { return [incr x],[incr y] } @@ -3744,16 +3670,16 @@ } foo create bar list [bar boo] [bar boo] } -result {1,1 2,2} test oo-27.15 {variables declaration - multiple use} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable variable x y method boo {} { return [incr x],[incr y] } @@ -3760,16 +3686,16 @@ } foo create bar list [bar boo] [bar boo] } -result {1,1 2,2} test oo-27.16 {variables declaration - multiple use} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x variable -clear variable y method boo {} { return [incr x],[incr y] @@ -3777,16 +3703,16 @@ } foo create bar list [bar boo] [bar boo] } -result {1,1 1,2} test oo-27.17 {variables declaration - multiple use} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x variable -set y method boo {} { return [incr x],[incr y] } @@ -3793,16 +3719,16 @@ } foo create bar list [bar boo] [bar boo] } -result {1,1 1,2} test oo-27.18 {variables declaration - multiple use} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x variable -? y method boo {} { return [incr x],[incr y] } @@ -3896,16 +3822,16 @@ } -cleanup { foo destroy } -result {v t} test oo-27.23 {variable resolver leakage: Bug 1493a43044} -setup { oo::class create Super - oo::class create Master { + oo::class create parent { superclass Super variable member1 member2 constructor {} { - set member1 master1 - set member2 master2 + set member1 parent1 + set member2 parent2 } method getChild {} { Child new [self] } } @@ -3922,14 +3848,14 @@ set result [list $l1 $l2 $l3 $l4 $l5 $l6 $l7 $l8] } method result {} {return $result} } } -body { - [[Master new] getChild] result + [[parent new] getChild] result } -cleanup { Super destroy -} -result {master1 master2 master1 master2 master1 master2 master1 master2} +} -result {parent1 parent2 parent1 parent2 parent1 parent2 parent1 parent2} # A feature that's not supported because the mechanism may change without # warning, but is supposed to work... test oo-28.1 {scripted extensions to oo::define} -setup { interp create foo @@ -4029,15 +3955,10 @@ variable contents $lst variable ops lappend ops [info level] Set $lst return } - method Resolve {lst} { - variable ops - lappend ops [info level] Resolve $lst - return $lst - } } } append script0 \n$script } @@ -4068,43 +3989,27 @@ }] -body { list [info level] [sampleSlot -append g h i] \ [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} -}] -result {0 {} {a b c g h i} {1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {a b c g h i}}} +}] -result {0 {} {a b c g h i} {1 Get 1 Set {a b c g h i}}} test oo-32.4 {TIP 380: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot }] -body { list [info level] [sampleSlot -set d e f] \ [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} -}] -result {0 {} {d e f} {1 Resolve d 1 Resolve e 1 Resolve f 1 Set {d e f}}} +}] -result {0 {} {d e f} {1 Set {d e f}}} test oo-32.5 {TIP 380: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot }] -body { list [info level] [sampleSlot -set d e f] [sampleSlot -append g h i] \ [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} -}] -result {0 {} {} {d e f g h i} {1 Resolve d 1 Resolve e 1 Resolve f 1 Set {d e f} 1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {d e f g h i}}} -test oo-32.6 {TIP 516: slots - class test} -setup [SampleSlotSetup { - SampleSlot create sampleSlot -}] -body { - list [info level] [sampleSlot -prepend g h i] \ - [sampleSlot contents] [sampleSlot ops] -} -cleanup [SampleSlotCleanup { - rename sampleSlot {} -}] -result {0 {} {g h i a b c} {1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {g h i a b c}}} -test oo-32.7 {TIP 516: slots - class test} -setup [SampleSlotSetup { - SampleSlot create sampleSlot -}] -body { - list [info level] [sampleSlot -remove c a] \ - [sampleSlot contents] [sampleSlot ops] -} -cleanup [SampleSlotCleanup { - rename sampleSlot {} -}] -result {0 {} b {1 Resolve c 1 Resolve a 1 Get 1 Set b}} +}] -result {0 {} {} {d e f g h i} {1 Set {d e f} 1 Get 1 Set {d e f g h i}}} test oo-33.1 {TIP 380: slots - defaulting} -setup [SampleSlotSetup { set s [SampleSlot new] }] -body { list [$s x y] [$s contents] @@ -4123,20 +4028,20 @@ }] -body { oo::objdefine $s forward --default-operation my -set list [$s destroy; $s unknown] [$s contents] [$s ops] } -cleanup [SampleSlotCleanup { rename $s {} -}] -result {{} unknown {1 Resolve destroy 1 Set destroy 1 Resolve unknown 1 Set unknown}} +}] -result {{} unknown {1 Set destroy 1 Set unknown}} test oo-33.4 {TIP 380: slots - errors} -setup [SampleSlotSetup { set s [SampleSlot new] }] -body { # Method names beginning with "-" are special to slots $s -grill q } -returnCodes error -cleanup [SampleSlotCleanup { rename $s {} }] -result \ - {unknown method "-grill": must be -append, -clear, -prepend, -remove, -set, contents or ops} + {unknown method "-grill": must be -append, -clear, -set, contents or ops} test oo-34.1 {TIP 380: slots - presence} -setup { set obj [oo::object new] set result {} } -body { @@ -4162,72 +4067,29 @@ list [lsort [info object methods $obj -all]] \ [lsort [info object methods $obj -private]] } test oo-34.3 {TIP 380: slots - presence} { getMethods oo::define::filter -} {{-append -clear -prepend -remove -set} {Get Set}} +} {{-append -clear -set} {Get Set}} test oo-34.4 {TIP 380: slots - presence} { getMethods oo::define::mixin -} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}} +} {{-append -clear -set} {--default-operation Get Set}} test oo-34.5 {TIP 380: slots - presence} { getMethods oo::define::superclass -} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}} +} {{-append -clear -set} {--default-operation Get Set}} test oo-34.6 {TIP 380: slots - presence} { getMethods oo::define::variable -} {{-append -clear -prepend -remove -set} {Get Set}} +} {{-append -clear -set} {Get Set}} test oo-34.7 {TIP 380: slots - presence} { getMethods oo::objdefine::filter -} {{-append -clear -prepend -remove -set} {Get Set}} +} {{-append -clear -set} {Get Set}} test oo-34.8 {TIP 380: slots - presence} { getMethods oo::objdefine::mixin -} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}} +} {{-append -clear -set} {--default-operation Get Set}} test oo-34.9 {TIP 380: slots - presence} { getMethods oo::objdefine::variable -} {{-append -clear -prepend -remove -set} {Get Set}} -test oo-34.10 {TIP 516: slots - resolution} -setup { - oo::class create parent - set result {} - oo::class create 516a { superclass parent } - oo::class create 516b { superclass parent } - oo::class create 516c { superclass parent } - namespace eval 516test { - oo::class create 516a { superclass parent } - oo::class create 516b { superclass parent } - oo::class create 516c { superclass parent } - } -} -body { - # Must find the right classes when making the mixin - namespace eval 516test { - oo::define 516a { - mixin 516b 516c - } - } - lappend result [info class mixin 516test::516a] - # Must not remove class with just simple name match - oo::define 516test::516a { - mixin -remove 516b - } - lappend result [info class mixin 516test::516a] - # Must remove class with resolved name match - oo::define 516test::516a { - mixin -remove 516test::516c - } - lappend result [info class mixin 516test::516a] - # Must remove class with resolved name match even after renaming, but only - # with the renamed name; it is a slot of classes, not strings! - rename 516test::516b 516test::516d - oo::define 516test::516a { - mixin -remove 516test::516b - } - lappend result [info class mixin 516test::516a] - oo::define 516test::516a { - mixin -remove 516test::516d - } - lappend result [info class mixin 516test::516a] -} -cleanup { - parent destroy -} -result {{::516test::516b ::516test::516c} {::516test::516b ::516test::516c} ::516test::516b ::516test::516d {}} +} {{-append -clear -set} {Get Set}} test oo-35.1 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup { oo::class create fruit { method eat {} {} } @@ -4295,10 +4157,12 @@ E create e1 list [lsort [info class methods E -all]] [lsort [info object methods e1 -all]] } -cleanup { base destroy } -result {{c d e} {c d e}} + + test oo-35.6 { Bug : teardown of an object that is a class that is an instance of itself } -setup { oo::class create obj @@ -4317,1112 +4181,13 @@ return done } -cleanup { rename obj {} } -result done -test oo-36.1 {TIP #470: introspection within oo::define} { - oo::define oo::object self -} ::oo::object -test oo-36.2 {TIP #470: introspection within oo::define} -setup { - oo::class create Cls -} -body { - oo::define Cls self -} -cleanup { - Cls destroy -} -result ::Cls -test oo-36.3 {TIP #470: introspection within oo::define} -setup { - oo::class create Super - set result uncalled -} -body { - oo::class create Sub { - superclass Super - ::set ::result [self] - } - return $result -} -cleanup { - Super destroy -} -result ::Sub -test oo-36.4 {TIP #470: introspection within oo::define} -setup { - oo::class create Super - set result uncalled -} -body { - oo::class create Sub { - superclass Super - ::set ::result [self {}] - } - return $result -} -cleanup { - Super destroy -} -result {} -test oo-36.5 {TIP #470: introspection within oo::define} -setup { - oo::class create Super - set result uncalled -} -body { - oo::class create Sub { - superclass Super - ::set ::result [self self] - } -} -cleanup { - Super destroy -} -result ::Sub -test oo-36.6 {TIP #470: introspection within oo::objdefine} -setup { - oo::class create Cls - set result uncalled -} -body { - Cls create obj - oo::objdefine obj { - ::set ::result [self] - } -} -cleanup { - Cls destroy -} -result ::obj -test oo-36.7 {TIP #470: introspection within oo::objdefine} -setup { - oo::class create Cls -} -body { - Cls create obj - oo::objdefine obj { - self - } -} -cleanup { - Cls destroy -} -result ::obj -test oo-36.8 {TIP #470: introspection within oo::objdefine} -setup { - oo::class create Cls -} -body { - Cls create obj - oo::objdefine obj { - self anything - } -} -returnCodes error -cleanup { - Cls destroy -} -result {wrong # args: should be "self"} -test oo-36.9 {TIP #470: introspection within oo::define} -setup { - oo::class create Cls - set result uncalled -} -body { - proc oo::define::testself {} { - global result - set result [list [catch {self} msg] $msg \ - [catch {uplevel 1 self} msg] $msg] - return - } - list [oo::define Cls testself] $result -} -cleanup { - Cls destroy - catch {rename oo::define::testself {}} -} -result {{} {1 {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} 0 ::Cls}} -test oo-36.10 {TIP #470: introspection within oo::define} -setup { - oo::class create Cls - set result uncalled -} -body { - proc oo::objdefine::testself {} { - global result - set result [list [catch {self} msg] $msg \ - [catch {uplevel 1 self} msg] $msg] - return - } - Cls create obj - list [oo::objdefine obj testself] $result -} -cleanup { - Cls destroy - catch {rename oo::objdefine::testself {}} -} -result {{} {1 {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} 0 ::obj}} - -test oo-37.1 {TIP 500: private command propagates errors} -setup { - oo::class create cls -} -body { - oo::define cls { - private ::error "this is an error" - } -} -cleanup { - cls destroy -} -returnCodes error -result {this is an error} -test oo-37.2 {TIP 500: private command propagates errors} -setup { - oo::class create cls -} -body { - oo::define cls { - private { - ::error "this is an error" - } - } -} -cleanup { - cls destroy -} -returnCodes error -result {this is an error} -test oo-37.3 {TIP 500: private command propagates errors} -setup { - oo::object create obj -} -body { - oo::objdefine obj { - private ::error "this is an error" - } -} -cleanup { - obj destroy -} -returnCodes error -result {this is an error} -test oo-37.4 {TIP 500: private command propagates errors} -setup { - oo::object create obj -} -body { - oo::objdefine obj { - private { - ::error "this is an error" - } - } -} -cleanup { - obj destroy -} -returnCodes error -result {this is an error} -test oo-37.5 {TIP 500: private command can't be used outside definitions} -body { - oo::define::private error "xyz" -} -returnCodes error -result {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} -test oo-37.6 {TIP 500: private command can't be used outside definitions} -body { - oo::objdefine::private error "xyz" -} -returnCodes error -result {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} - -test oo-38.1 {TIP 500: private variables don't cross-interfere with each other or normal ones} -setup { - oo::class create parent -} -body { - oo::class create clsA { - superclass parent - private variable x - constructor {} { - set x 1 - } - method getA {} { - return $x - } - } - oo::class create clsB { - superclass clsA - private { - variable x - } - constructor {} { - set x 2 - next - } - method getB {} { - return $x - } - } - oo::class create clsC { - superclass clsB - variable x - constructor {} { - set x 3 - next - } - method getC {} { - return $x - } - } - clsC create obj - oo::objdefine obj { - private { - variable x - } - method setup {} { - set x 4 - } - method getO {} { - return $x - } - } - obj setup - list [obj getA] [obj getB] [obj getC] [obj getO] \ - [lsort [string map [list [info object creationid clsA] CLASS-A \ - [info object creationid clsB] CLASS-B \ - [info object creationid obj] OBJ] \ - [info object vars obj]]] -} -cleanup { - parent destroy -} -result {1 2 3 4 {{CLASS-A : x} {CLASS-B : x} {OBJ : x} x}} -test oo-38.2 {TIP 500: private variables introspection} -setup { - oo::class create parent -} -body { - oo::class create cls { - superclass parent - private { - variable x1 - variable x2 - } - variable y1 y2 - } - cls create obj - oo::objdefine obj { - private variable a1 a2 - variable b1 b2 - } - list [lsort [info class variables cls]] \ - [lsort [info class variables cls -private]] \ - [lsort [info object variables obj]] \ - [lsort [info object variables obj -private]] -} -cleanup { - parent destroy -} -result {{y1 y2} {x1 x2} {b1 b2} {a1 a2}} -test oo-38.3 {TIP 500: private variables and oo::object·varname} -setup { - oo::class create parent -} -body { - oo::class create clsA { - superclass parent - private { - variable x - } - method getx {} { - set x 1 - my varname x - } - method readx {} { - return $x - } - } - oo::class create clsB { - superclass clsA - variable x - method gety {} { - set x 1 - my varname x - } - method ready {} { - return $x - } - } - clsB create obj - set [obj getx] 2 - set [obj gety] 3 - list [obj readx] [obj ready] -} -cleanup { - parent destroy -} -result {2 3} -test oo-38.4 {TIP 500: private variables introspection} -setup { - oo::class create parent -} -body { - oo::class create cls { - superclass parent - private { - variable x1 x2 - } - variable y1 y2 - constructor {} { - variable z boo - set x1 a - set y1 c - } - method list {} { - variable z - set ok 1 - list [info locals] [lsort [info vars]] [info exist x2] - } - } - cls create obj - oo::objdefine obj { - private variable a1 a2 - variable b1 b2 - method init {} { - # Because we don't have a constructor to do this setup for us - set a1 p - set b1 r - } - method list {} { - variable z - set yes 1 - list {*}[next] [info locals] [lsort [info vars]] [info exist a2] - } - } - obj init - obj list -} -cleanup { - parent destroy -} -result {ok {ok x1 x2 y1 y2 z} 0 yes {a1 a2 b1 b2 yes z} 0} -test oo-38.5 {TIP 500: private variables and oo::object·variable} -setup { - oo::class create parent -} -body { - oo::class create cls1 { - superclass parent - private variable x - method abc val { - my variable x - set x $val - } - method def val { - my variable y - set y $val - } - method get1 {} { - my variable x y - return [list $x $y] - } - } - oo::class create cls2 { - superclass cls1 - private variable x - method x-exists {} { - return [info exists x],[uplevel 1 {info exists x}] - } - method ghi x { - # Additional instrumentation to show that we're not using the - # resolved variable until we ask for it; the argument nixed that - # happening by default. - set val $x - set before [my x-exists] - unset x - set x $val - set mid [my x-exists] - unset x - set mid2 [my x-exists] - my variable x - set x $val - set after [my x-exists] - return "$before;$mid;$mid2;$after" - } - method jkl val { - my variable y - set y $val - } - method get2 {} { - my variable x y - return [list $x $y] - } - } - cls2 create a - a abc 123 - a def 234 - set tmp [a ghi 345] - a jkl 456 - list $tmp [a get1] [a get2] -} -cleanup { - parent destroy -} -result {{0,1;0,1;0,0;1,1} {123 456} {345 456}} - -test oo-39.1 {TIP 500: private methods internal call; class private} -setup { - oo::class create parent -} -body { - oo::class create clsA { - superclass parent - variable x - constructor {} { - set x 1 - } - method act {} { - my step - my step - my step - return - } - private { - method step {} { - incr x 2 - } - } - method x {} { - return $x - } - } - clsA create obj - obj act - list [obj x] [catch {obj step} msg] $msg -} -cleanup { - parent destroy -} -result {7 1 {unknown method "step": must be act, destroy or x}} -test oo-39.2 {TIP 500: private methods internal call; class private} -setup { - oo::class create parent -} -body { - oo::class create clsA { - superclass parent - variable x - constructor {} { - set x 1 - } - method act {} { - my step - my step - my step - return - } - private { - method step {} { - incr x 2 - } - } - method x {} { - return $x - } - } - oo::class create clsB { - superclass clsA - variable x - method step {} { - incr x 5 - } - } - clsB create obj - obj act - list [obj x] [obj step] -} -cleanup { - parent destroy -} -result {7 12} -test oo-39.3 {TIP 500: private methods internal call; class private} -setup { - oo::class create parent -} -body { - oo::class create clsA { - superclass parent - variable x - constructor {} { - set x 1 - } - method act {} { - my Step - my Step - my Step - return - } - method x {} { - return $x - } - } - oo::class create clsB { - superclass clsA - variable x - method Step {} { - incr x 5 - } - } - clsB create obj - obj act - set result [obj x] - oo::define clsA { - private { - method Step {} { - incr x 2 - } - } - } - obj act - lappend result [obj x] -} -cleanup { - parent destroy -} -result {16 22} -test oo-39.4 {TIP 500: private methods internal call; instance private} -setup { - oo::class create parent -} -body { - oo::class create clsA { - superclass parent - variable x - constructor {} { - set x 1 - } - method act {} { - my step - return - } - method step {} { - incr x - } - method x {} { - return $x - } - } - clsA create obj - obj act - set result [obj x] - oo::objdefine obj { - variable x - private { - method step {} { - incr x 2 - } - } - } - obj act - lappend result [obj x] - oo::objdefine obj { - method act {} { - my step - next - } - } - obj act - lappend result [obj x] -} -cleanup { - parent destroy -} -result {2 3 6} -test oo-39.5 {TIP 500: private methods internal call; cross object} -setup { - oo::class create parent -} -body { - oo::class create cls { - superclass parent - variable x - constructor {val} { - set x $val - } - private method x {} { - return $x - } - method equal {other} { - expr {$x == [$other x]} - } - } - cls create a 1 - cls create b 2 - cls create c 1 - list [a equal b] [b equal c] [c equal a] [catch {a x} msg] $msg -} -cleanup { - parent destroy -} -result {0 0 1 1 {unknown method "x": must be destroy or equal}} -test oo-39.6 {TIP 500: private methods internal call; error reporting} -setup { - oo::class create parent -} -body { - oo::class create cls { - superclass parent - variable x - constructor {val} { - set x $val - } - private method x {} { - return $x - } - method equal {other} { - expr {$x == [$other y]} - } - } - cls create a 1 - cls create b 2 - a equal b -} -returnCodes error -cleanup { - parent destroy -} -result {unknown method "y": must be destroy, equal or x} -test oo-39.7 {TIP 500: private methods internal call; error reporting} -setup { - oo::class create parent -} -body { - oo::class create cls { - superclass parent - variable x - constructor {val} { - set x $val - } - private method x {} { - return $x - } - method equal {other} { - expr {[[self] y] == [$other x]} - } - } - cls create a 1 - cls create b 2 - a equal b -} -returnCodes error -cleanup { - parent destroy -} -result {unknown method "y": must be destroy, equal or x} -test oo-39.8 {TIP 500: private methods internal call; error reporting} -setup { - oo::class create parent -} -body { - oo::class create cls { - superclass parent - variable x - constructor {val} { - set x $val - } - private method x {} { - return $x - } - method equal {other} { - expr {[my y] == [$other x]} - } - } - cls create a 1 - cls create b 2 - a equal b -} -returnCodes error -cleanup { - parent destroy -} -result {unknown method "y": must be , destroy, equal, eval, unknown, variable, varname or x} -test oo-39.9 {TIP 500: private methods internal call; error reporting} -setup { - oo::class create parent -} -body { - oo::class create cls { - superclass parent - variable x - constructor {val} { - set x $val - } - private method x {} { - return $x - } - } - oo::class create cls2 { - superclass cls - method equal {other} { - expr {[my y] == [$other x]} - } - } - cls2 create a 1 - cls2 create b 2 - a equal b -} -returnCodes error -cleanup { - parent destroy -} -result {unknown method "y": must be , destroy, equal, eval, unknown, variable or varname} -test oo-39.10 {TIP 500: private methods internal call; error reporting} -setup { - oo::class create parent -} -body { - oo::class create cls { - superclass parent - variable x - constructor {val} { - set x $val - } - private method x {} { - return $x - } - } - oo::class create cls2 { - superclass cls - method equal {other} { - expr {[my x] == [$other x]} - } - } - cls2 create a 1 - cls2 create b 2 - a equal b -} -returnCodes error -cleanup { - parent destroy -} -result {unknown method "x": must be , destroy, equal, eval, unknown, variable or varname} -test oo-39.11 {TIP 500: private methods; call chain caching and reporting} -setup { - oo::class create parent -} -body { - oo::class create cls { - superclass parent - method chain {} { - return [self call] - } - } - oo::class create cls2 { - superclass cls - private method chain {} { - next - } - method chain2 {} { - my chain - } - method chain3 {} { - [self] chain - } - } - cls create a - cls2 create b - list [a chain] [b chain] [b chain2] [b chain3] -} -cleanup { - parent destroy -} -result {{{{method chain ::cls method}} 0} {{{method chain ::cls method}} 0} {{{private chain ::cls2 method} {method chain ::cls method}} 1} {{{private chain ::cls2 method} {method chain ::cls method}} 1}} -test oo-39.12 {TIP 500: private methods; introspection} -setup { - oo::class create parent -} -body { - oo::class create cls { - superclass parent - method chain {} { - return [self call] - } - private method abc {} {} - } - oo::class create cls2 { - superclass cls - method chain2 {} { - my chain - } - method chain3 {} { - [self] chain - } - private method def {} {} - unexport chain3 - } - cls create a - cls2 create b - oo::objdefine b { - private method ghi {} {} - method ABC {} {} - method foo {} {} - } - set scopes {public unexported private} - list a: [lmap s $scopes {info object methods a -scope $s}] \ - b: [lmap s $scopes {info object methods b -scope $s}] \ - cls: [lmap s $scopes {info class methods cls -scope $s}] \ - cls2: [lmap s $scopes {info class methods cls2 -scope $s}] \ -} -cleanup { - parent destroy -} -result {a: {{} {} {}} b: {foo ABC ghi} cls: {chain {} abc} cls2: {chain2 chain3 def}} - -test oo-40.1 {TIP 500: private and self} -setup { - oo::class create cls -} -body { - oo::define cls { - self { - private { - variable a - } - variable b - } - private { - self { - variable c - } - variable d - } - variable e - } - list \ - [lsort [info class variables cls]] \ - [lsort [info class variables cls -private]] \ - [lsort [info object variables cls]] \ - [lsort [info object variables cls -private]] -} -cleanup { - cls destroy -} -result {e d b {a c}} -test oo-40.2 {TIP 500: private and export} -setup { - oo::class create cls -} -body { - oo::define cls { - private method foo {} {} - } - set result [lmap s {public unexported private} { - info class methods cls -scope $s}] - oo::define cls { - export foo - } - lappend result {*}[lmap s {public unexported private} { - info class methods cls -scope $s}] -} -cleanup { - cls destroy -} -result {{} {} foo foo {} {}} -test oo-40.3 {TIP 500: private and unexport} -setup { - oo::class create cls -} -body { - oo::define cls { - private method foo {} {} - } - set result [lmap s {public unexported private} { - info class methods cls -scope $s}] - oo::define cls { - unexport foo - } - lappend result {*}[lmap s {public unexported private} { - info class methods cls -scope $s}] -} -cleanup { - cls destroy -} -result {{} {} foo {} foo {}} - -test oo-41.1 {TIP 478: myclass command, including class morphing} -setup { - oo::class create parent - set result {} -} -body { - oo::class create cls1 { - superclass parent - self method count {} { - my variable c - incr c - } - method act {} { - myclass count - } - } - cls1 create x - lappend result [x act] [x act] - cls1 create y - lappend result [y act] [y act] [x act] - oo::class create cls2 { - superclass cls1 - self method count {} { - my variable d - expr {1.0 * [incr d]} - } - } - oo::objdefine x {class cls2} - lappend result [x act] [y act] [x act] [y act] -} -cleanup { - parent destroy -} -result {1 2 3 4 5 1.0 6 2.0 7} -test oo-41.2 {TIP 478: myclass command cleanup} -setup { - oo::class create parent - set result {} -} -body { - oo::class create cls1 { - superclass parent - self method hi {} { - return "this is [self]" - } - method hi {} { - return "this is [self]" - } - } - cls1 create x - rename [info object namespace x]::my foo - rename [info object namespace x]::myclass bar - lappend result [cls1 hi] [x hi] [foo hi] [bar hi] - x destroy - lappend result [catch {foo hi}] [catch {bar hi}] -} -cleanup { - parent destroy -} -result {{this is ::cls1} {this is ::x} {this is ::x} {this is ::cls1} 1 1} -test oo-41.3 {TIP 478: myclass command calls unexported methods, via forward} -setup { - oo::class create parent - set result {} -} -body { - oo::class create cls1 { - superclass parent - self method Hi {} { - return "this is [self]" - } - forward poke myclass Hi - } - cls1 create x - lappend result [catch {cls1 Hi}] [x poke] -} -cleanup { - parent destroy -} -result {1 {this is ::cls1}} - -test oo-42.1 {TIP 524: definition namespace control: introspection} { - info class definitionnamespace oo::object -} {} -test oo-42.2 {TIP 524: definition namespace control: introspection} { - info class definitionnamespace oo::object -class -} {} -test oo-42.3 {TIP 524: definition namespace control: introspection} { - info class definitionnamespace oo::object -instance -} ::oo::objdefine -test oo-42.4 {TIP 524: definition namespace control: introspection} -body { - info class definitionnamespace oo::object -gorp -} -returnCodes error -result {bad kind "-gorp": must be -class or -instance} -test oo-42.5 {TIP 524: definition namespace control: introspection} -body { - info class definitionnamespace oo::object -class x -} -returnCodes error -result {wrong # args: should be "info class definitionnamespace className ?kind?"} -test oo-42.6 {TIP 524: definition namespace control: introspection} { - info class definitionnamespace oo::class -} ::oo::define -test oo-42.7 {TIP 524: definition namespace control: introspection} { - info class definitionnamespace oo::class -class -} ::oo::define -test oo-42.8 {TIP 524: definition namespace control: introspection} { - info class definitionnamespace oo::class -instance -} {} - -test oo-43.1 {TIP 524: definition namespace control: semantics} -setup { - oo::class create parent - namespace eval foodef {} -} -body { - namespace eval foodef { - proc sparkle {} {return ok} - } - oo::class create foocls { - superclass oo::class parent - definitionnamespace foodef - } - oo::class create foo { - superclass parent - self class foocls - } - oo::define foo { - sparkle - } -} -cleanup { - parent destroy - namespace delete foodef -} -result ok -test oo-43.2 {TIP 524: definition namespace control: semantics} -setup { - oo::class create parent - namespace eval foodef {} - unset -nocomplain ::result -} -body { - namespace eval foodef { - namespace path ::oo::define - proc sparkle {} {return ok} - } - oo::class create foocls { - superclass oo::class parent - definitionnamespace foodef - } - foocls create foo { - superclass parent - lappend ::result [sparkle] - } - return $result -} -cleanup { - parent destroy - namespace delete foodef -} -result ok -test oo-43.3 {TIP 524: definition namespace control: semantics} -setup { - oo::class create parent - namespace eval foodef {} - unset -nocomplain ::result -} -body { - namespace eval foodef { - namespace path ::oo::define - proc sparkle {} {return ok} - } - oo::class create foocls { - superclass oo::class parent - definitionnamespace -class foodef - } - foocls create foo { - superclass parent - lappend ::result [sparkle] - } - return $result -} -cleanup { - parent destroy - namespace delete foodef -} -result ok -test oo-43.4 {TIP 524: definition namespace control: semantics} -setup { - oo::class create parent - namespace eval foodef {} -} -body { - namespace eval foodef { - namespace path ::oo::objdefine - proc sparkle {} {return ok} - } - oo::class create foocls { - superclass oo::class parent - definitionnamespace -instance foodef - } - foocls create foo { - sparkle - } -} -returnCodes error -cleanup { - parent destroy - namespace delete foodef -} -result {invalid command name "sparkle"} -test oo-43.5 {TIP 524: definition namespace control: semantics} -setup { - oo::class create parent - namespace eval foodef {} -} -body { - namespace eval foodef { - namespace path ::oo::objdefine - proc sparkle {} {return ok} - } - oo::class create foocls { - superclass oo::class parent - definitionnamespace foodef - } - namespace delete foodef - foocls create foo { - sparkle - } -} -returnCodes error -cleanup { - parent destroy - catch {namespace delete foodef} -} -result {invalid command name "sparkle"} -test oo-43.6 {TIP 524: definition namespace control: semantics} -setup { - oo::class create parent - namespace eval foodef {} - unset -nocomplain result -} -body { - namespace eval foodef { - namespace path ::oo::objdefine - proc sparkle {} {return ok} - } - oo::class create foocls { - superclass oo::class parent - definitionnamespace foodef - } - foocls create foo - lappend result [catch {oo::define foo sparkle} msg] $msg - namespace delete foodef - lappend result [catch {oo::define foo sparkle} msg] $msg - namespace eval foodef { - namespace path ::oo::objdefine - proc sparkle {} {return ok} - } - lappend result [catch {oo::define foo sparkle} msg] $msg -} -cleanup { - parent destroy - catch {namespace delete foodef} -} -result {0 ok 1 {invalid command name "sparkle"} 0 ok} -test oo-43.7 {TIP 524: definition namespace control: semantics} -setup { - oo::class create parent - namespace eval foodef {} -} -body { - namespace eval foodef { - namespace path ::oo::define - proc sparkle {x} {return ok} - } - oo::class create foocls { - superclass oo::class parent - definitionnamespace foodef - } - foocls create foo { - superclass parent - } - oo::define foo spar gorp -} -cleanup { - parent destroy - namespace delete foodef -} -result ok -test oo-43.8 {TIP 524: definition namespace control: semantics} -setup { - oo::class create parent - namespace eval foodef {} -} -body { - namespace eval foodef { - namespace path ::oo::objdefine - proc sparkle {} {return ok} - } - oo::class create foo { - superclass parent - definitionnamespace -instance foodef - } - oo::objdefine [foo new] { - method x y z - sparkle - } -} -cleanup { - parent destroy - namespace delete foodef -} -result ok -test oo-43.9 {TIP 524: definition namespace control: syntax} -body { - oo::class create foo { - definitionnamespace -gorp foodef - } -} -returnCodes error -result {bad kind "-gorp": must be -class or -instance} -test oo-43.10 {TIP 524: definition namespace control: syntax} -body { - oo::class create foo { - definitionnamespace -class foodef x - } -} -returnCodes error -result {wrong # args: should be "definitionnamespace ?kind? namespace"} -test oo-43.11 {TIP 524: definition namespace control: syntax} -setup { - catch {namespace delete ::no_such_ns} -} -body { - oo::class create foo { - definitionnamespace -class ::no_such_ns - } -} -returnCodes error -result {namespace "::no_such_ns" not found} -test oo-43.12 {TIP 524: definition namespace control: user-level introspection} -setup { - oo::class create parent - namespace eval foodef {} -} -body { - namespace eval foodef {} - oo::class create foo { - superclass oo::class parent - } - list [info class definitionnamespace foo] \ - [oo::define foo definitionnamespace foodef] \ - [info class definitionnamespace foo] \ - [oo::define foo definitionnamespace {}] \ - [info class definitionnamespace foo] -} -cleanup { - parent destroy - namespace delete foodef -} -result {{} {} ::foodef {} {}} -test oo-43.13 {TIP 524: definition namespace control: user-level introspection} -setup { - oo::class create parent - namespace eval foodef {} -} -body { - namespace eval foodef {} - oo::class create foo { - superclass parent - } - list [info class definitionnamespace foo -instance] \ - [oo::define foo definitionnamespace -instance foodef] \ - [info class definitionnamespace foo -instance] \ - [oo::define foo definitionnamespace -instance {}] \ - [info class definitionnamespace foo -instance] -} -cleanup { - parent destroy - namespace delete foodef -} -result {{} {} ::foodef {} {}} + cleanupTests return # Local Variables: -# mode: tcl +# MODE: Tcl # End: Index: tests/ooNext2.test ================================================================== --- tests/ooNext2.test +++ tests/ooNext2.test @@ -6,12 +6,12 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. package require TclOO 1.0.3 -package require tcltest 2 -if {"::tcltest" in [namespace children]} { +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } testConstraint memory [llength [info commands memory]] if {[testConstraint memory]} { @@ -880,25 +880,25 @@ # Common setup: # any invocation of bar should emit "abc\nhi\n" then return to its # caller set testopts { -setup { - oo::class create Master + oo::class create Parent oo::class create Foo { - superclass Master + superclass Parent method bar {} { puts abc tailcall puts hi puts xyz } } oo::class create Foo2 { - superclass Master + superclass Parent } } -cleanup { - Master destroy + Parent destroy } } # these succeed, showing that without [next] the bug doesn't fire test next-tailcall-simple-1 "trivial case with one method" {*}$testopts -body { DELETED tests/ooUtil.test Index: tests/ooUtil.test ================================================================== --- tests/ooUtil.test +++ /dev/null @@ -1,563 +0,0 @@ -# This file contains a collection of tests for functionality originally -# sourced from the ooutil package in Tcllib. Sourcing this file into Tcl runs -# the tests and generates output for errors. No output means no errors were -# found. -# -# Copyright (c) 2014-2016 Andreas Kupries -# Copyright (c) 2018 Donal K. Fellows -# -# See the file "license.terms" for information on usage and redistribution of -# this file, and for a DISCLAIMER OF ALL WARRANTIES. - -package require TclOO 1.0.3 -package require tcltest 2 -if {"::tcltest" in [namespace children]} { - namespace import -force ::tcltest::* -} - -test ooUtil-1.1 {TIP 478: classmethod} -setup { - oo::class create parent -} -body { - oo::class create ActiveRecord { - superclass parent - classmethod find args { - return "[self] called with arguments: $args" - } - } - oo::class create Table { - superclass ActiveRecord - } - Table find foo bar -} -cleanup { - parent destroy -} -result {::Table called with arguments: foo bar} -test ooUtil-1.2 {TIP 478: classmethod in namespace} -setup { - namespace eval ::testns {} -} -body { - namespace eval ::testns { - oo::class create ActiveRecord { - classmethod find args { - return "[self] called with arguments: $args" - } - } - oo::class create Table { - superclass ActiveRecord - } - } - testns::Table find foo bar -} -cleanup { - namespace delete ::testns -} -result {::testns::Table called with arguments: foo bar} -test ooUtil-1.3 {TIP 478: classmethod must not interfere with constructor signatures} -setup { - oo::class create parent -} -body { - oo::class create TestClass { - superclass oo::class parent - self method create {name ignore body} { - next $name $body - } - } - TestClass create okay {} {} -} -cleanup { - parent destroy -} -result {::okay} -test ooUtil-1.4 {TIP 478: classmethod with several inheritance levels} -setup { - oo::class create parent -} -body { - oo::class create ActiveRecord { - superclass parent - classmethod find args { - return "[self] called with arguments: $args" - } - } - oo::class create Table { - superclass ActiveRecord - } - oo::class create SubTable { - superclass Table - } - SubTable find foo bar -} -cleanup { - parent destroy -} -result {::SubTable called with arguments: foo bar} -test ooUtil-1.5 {TIP 478: classmethod and instances} -setup { - oo::class create parent -} -body { - oo::class create ActiveRecord { - superclass parent - classmethod find args { - return "[self] called with arguments: $args" - } - } - oo::class create Table { - superclass ActiveRecord - } - set t [Table new] - $t find 1 2 3 -} -cleanup { - parent destroy -} -result {::Table called with arguments: 1 2 3} -test ooUtil-1.6 {TIP 478: classmethod and instances} -setup { - oo::class create parent -} -body { - oo::class create ActiveRecord { - superclass parent - classmethod find args { - return "[self] called with arguments: $args" - } - } - oo::class create Table { - superclass ActiveRecord - unexport find - } - set t [Table new] - $t find 1 2 3 -} -returnCodes error -cleanup { - parent destroy -} -match glob -result {unknown method "find": must be *} -test ooUtil-1.7 {} -setup { - oo::class create parent -} -body { - oo::class create Foo { - superclass parent - classmethod bar {} { - puts "This is in the class; self is [self]" - my meee - } - classmethod meee {} { - puts "This is meee" - } - } - oo::class create Grill { - superclass Foo - classmethod meee {} { - puts "This is meee 2" - } - } - list [Foo bar] [Grill bar] [[Foo new] bar] [[Grill new] bar] -} -cleanup { - parent destroy -} -result {{} {} {} {}} -output "This is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\nThis is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\n" -# Two tests to confirm that we correctly initialise the scripted part of TclOO -# in child interpreters. This is slightly tricky at the implementation level -# because we cannot count on either [source] or [open] being available. -test ooUtil-1.8 {TIP 478: classmethod in child interp} -setup { - set childinterp [interp create] -} -body { - $childinterp eval { - oo::class create ActiveRecord { - classmethod find args { - return "[self] called with arguments: $args" - } - } - oo::class create Table { - superclass ActiveRecord - } - # This is confirming that this is not the master interpreter - list [Table find foo bar] [info globals childinterp] - } -} -cleanup { - interp delete $childinterp -} -result {{::Table called with arguments: foo bar} {}} -test ooUtil-1.9 {TIP 478: classmethod in safe child interp} -setup { - set safeinterp [interp create -safe] -} -body { - $safeinterp eval { - oo::class create ActiveRecord { - classmethod find args { - return "[self] called with arguments: $args" - } - } - oo::class create Table { - superclass ActiveRecord - } - # This is confirming that this is a (basic) safe interpreter - list [Table find foo bar] [info commands source] - } -} -cleanup { - interp delete $safeinterp -} -result {{::Table called with arguments: foo bar} {}} - -test ooUtil-2.1 {TIP 478: callback generation} -setup { - oo::class create parent -} -body { - oo::class create c { - superclass parent - method CallMe {} { return ok,[self] } - method makeCall {} { - return [callback CallMe] - } - } - c create ::context - set cb [context makeCall] - {*}$cb -} -cleanup { - parent destroy -} -result {ok,::context} -test ooUtil-2.2 {TIP 478: callback generation} -setup { - oo::class create parent -} -body { - oo::class create c { - superclass parent - method CallMe {a b c} { return ok,[self],$a,$b,$c } - method makeCall {b} { - return [callback CallMe 123 $b] - } - } - c create ::context - set cb [context makeCall "a b c"] - {*}$cb PQR -} -cleanup { - parent destroy -} -result {ok,::context,123,a b c,PQR} -test ooUtil-2.3 {TIP 478: callback generation, alternate name} -setup { - oo::class create parent -} -body { - oo::class create c { - superclass parent - method CallMe {} { return ok,[self] } - method makeCall {} { - return [mymethod CallMe] - } - } - c create ::context - set cb [context makeCall] - {*}$cb -} -cleanup { - parent destroy -} -result {ok,::context} -test ooUtil-2.4 {TIP 478: callback generation, alternate name} -setup { - oo::class create parent -} -body { - oo::class create c { - superclass parent - method CallMe {a b c} { return ok,[self],$a,$b,$c } - method makeCall {b} { - return [mymethod CallMe 123 $b] - } - } - c create ::context - set cb [context makeCall "a b c"] - {*}$cb PQR -} -cleanup { - parent destroy -} -result {ok,::context,123,a b c,PQR} -test ooUtil-2.5 {TIP 478: callbacks and method lifetime} -setup { - oo::class create parent -} -body { - oo::class create c { - superclass parent - method makeCall {b} { - return [callback CallMe 123 $b] - } - } - c create ::context - set cb [context makeCall "a b c"] - set result [list [catch {{*}$cb PQR} msg] $msg] - oo::objdefine context { - method CallMe {a b c} { return ok,[self],$a,$b,$c } - } - lappend result [{*}$cb PQR] -} -cleanup { - parent destroy -} -result {1 {unknown method "CallMe": must be , destroy, eval, makeCall, unknown, variable or varname} {ok,::context,123,a b c,PQR}} -test ooUtil-2.6 {TIP 478: callback use case} -setup { - oo::class create parent - unset -nocomplain x -} -body { - oo::class create c { - superclass parent - variable count - constructor {var} { - set count 0 - upvar 1 $var v - trace add variable v write [callback TraceCallback] - } - method count {} {return $count} - method TraceCallback {name1 name2 op} { - incr count - } - } - set o [c new x] - for {set x 0} {$x < 5} {incr x} {} - $o count -} -cleanup { - unset -nocomplain x - parent destroy -} -result 6 - -test ooUtil-3.1 {TIP 478: class initialisation} -setup { - oo::class create parent - catch {rename ::foobar-3.1 {}} -} -body { - oo::class create ::cls { - superclass parent - initialise { - proc foobar-3.1 {} {return ok} - } - method calls {} { - list [catch foobar-3.1 msg] $msg \ - [namespace eval [info object namespace [self class]] foobar-3.1] - } - } - [cls new] calls -} -cleanup { - parent destroy -} -result {1 {invalid command name "foobar-3.1"} ok} -test ooUtil-3.2 {TIP 478: class variables} -setup { - oo::class create parent - catch {rename ::foobar-3.1 {}} -} -body { - oo::class create ::cls { - superclass parent - initialise { - variable x 123 - } - method call {} { - classvariable x - incr x - } - } - cls create a - cls create b - cls create c - list [a call] [b call] [c call] [a call] [b call] [c call] -} -cleanup { - parent destroy -} -result {124 125 126 127 128 129} -test ooUtil-3.3 {TIP 478: class initialisation} -setup { - oo::class create parent - catch {rename ::foobar-3.3 {}} -} -body { - oo::class create ::cls { - superclass parent - initialize { - proc foobar-3.3 {} {return ok} - } - method calls {} { - list [catch foobar-3.3 msg] $msg \ - [namespace eval [info object namespace [self class]] foobar-3.3] - } - } - [cls new] calls -} -cleanup { - parent destroy -} -result {1 {invalid command name "foobar-3.3"} ok} -test ooUtil-3.4 {TIP 478: class initialisation} -setup { - oo::class create parent - catch {rename ::appendToResultVar {}} - proc ::appendToResultVar args { - lappend ::result {*}$args - } - set result {} -} -body { - trace add execution oo::define::initialise enter appendToResultVar - oo::class create ::cls { - superclass parent - initialize {proc xyzzy {} {}} - } - return $result -} -cleanup { - catch { - trace remove execution oo::define::initialise enter appendToResultVar - } - rename ::appendToResultVar {} - parent destroy -} -result {{initialize {proc xyzzy {} {}}} enter} -test ooUtil-3.5 {TIP 478: class initialisation} -body { - oo::define oo::object { - ::list [::namespace which initialise] [::namespace which initialize] \ - [::namespace origin initialise] [::namespace origin initialize] - } -} -result {::oo::define::initialise ::oo::define::initialize ::oo::define::initialise ::oo::define::initialise} - -test ooUtil-4.1 {TIP 478: singleton} -setup { - oo::class create parent -} -body { - oo::singleton create xyz { - superclass parent - } - set x [xyz new] - set y [xyz new] - set z [xyz new] - set code [catch {$x destroy} msg] - set p [xyz new] - lappend code [catch {rename $x ""}] - set q [xyz new] - string map [list $x ONE $q TWO] [list {*}$code $x $y $z $p $q [xyz new]] -} -cleanup { - parent destroy -} -result {1 0 ONE ONE ONE ONE TWO TWO} -test ooUtil-4.2 {TIP 478: singleton errors} -setup { - oo::class create parent -} -body { - oo::singleton create xyz { - superclass parent - } - [xyz new] destroy -} -returnCodes error -cleanup { - parent destroy -} -result {may not destroy a singleton object} -test ooUtil-4.3 {TIP 478: singleton errors} -setup { - oo::class create parent -} -body { - oo::singleton create xyz { - superclass parent - } - oo::copy [xyz new] -} -returnCodes error -cleanup { - parent destroy -} -result {may not clone a singleton object} - - -test ooUtil-5.1 {TIP 478: abstract} -setup { - oo::class create parent -} -body { - oo::abstract create xyz { - superclass parent - method foo {} {return 123} - } - oo::class create pqr { - superclass xyz - method bar {} {return 456} - } - set codes [list [catch {xyz new}] [catch {xyz create x}] [catch {xyz createWithNamespace x y}]] - set x [pqr new] - set y [pqr create ::y] - lappend codes [$x foo] [$x bar] $y -} -cleanup { - parent destroy -} -result {1 1 1 123 456 ::y} - -test ooUtil-6.1 {TIP 478: classvarable} -setup { - oo::class create parent -} -body { - oo::class create xyz { - superclass parent - initialise { - variable x 1 y 2 - } - method a {} { - classvariable x - incr x - } - method b {} { - classvariable y - incr y - } - method c {} { - classvariable x y - list $x $y - } - } - set p [xyz new] - set q [xyz new] - set result [list [$p c] [$q c]] - $p a - $q b - lappend result [[xyz new] c] -} -cleanup { - parent destroy -} -result {{1 2} {1 2} {2 3}} -test ooUtil-6.2 {TIP 478: classvarable error case} -setup { - oo::class create parent -} -body { - oo::class create xyz { - superclass parent - method a {} { - classvariable x(1) - incr x(1) - } - } - set p [xyz new] - set q [xyz new] - list [$p a] [$q a] -} -returnCodes error -cleanup { - parent destroy -} -result {bad variable name "x(1)": can't create a scalar variable that looks like an array element} -test ooUtil-6.3 {TIP 478: classvarable error case} -setup { - oo::class create parent -} -body { - oo::class create xyz { - superclass parent - method a {} { - classvariable ::x - incr x - } - } - set p [xyz new] - set q [xyz new] - list [$p a] [$q a] -} -returnCodes error -cleanup { - parent destroy -} -result {bad variable name "::x": can't create a local variable with a namespace separator in it} - -test ooUtil-7.1 {TIP 478: link calling pattern} -setup { - oo::class create parent -} -body { - oo::class create cls { - superclass parent - method foo {} {return "in foo of [self]"} - method Bar {} {return "in bar of [self]"} - method Grill {} {return "in grill of [self]"} - export eval - constructor {} { - link foo - link {bar Bar} {grill Grill} - } - } - cls create o - o eval {list [foo] [bar] [grill]} -} -cleanup { - parent destroy -} -result {{in foo of ::o} {in bar of ::o} {in grill of ::o}} -test ooUtil-7.2 {TIP 478: link removed when [my] disappears} -setup { - oo::class create parent -} -body { - oo::class create cls { - superclass parent - method foo {} {return "in foo of [self]"} - constructor {cmd} { - link [list ::$cmd foo] - } - } - cls create o pqr - list [o foo] [pqr] [rename [info object namespace o]::my {}] [catch pqr msg] $msg -} -cleanup { - parent destroy -} -result {{in foo of ::o} {in foo of ::o} {} 1 {invalid command name "pqr"}} - -# Tests that verify issues detected with the tcllib version of the code -test ooUtil-tcllib-ticket-b3577ed586 {test scoping of delegation in oo::class.Delegate } -setup { - oo::class create animal {} - namespace eval ::ooutiltest { - oo::class create pet { superclass animal } - } -} -body { - namespace eval ::ooutiltest { - oo::class create dog { superclass pet } - } -} -cleanup { - namespace delete ooutiltest - rename animal {} -} -result {::ooutiltest::dog} -test ooUtil-tcllib-ticket-fe7a0e0a3a {classmethod must not interfere with constructor signatures} -setup { - oo::class create TestClass { - superclass oo::class - self method create {name ignore body} { - next $name $body - } - } -} -body { - TestClass create okay {} {} -} -cleanup { - rename TestClass {} -} -result {::okay} - -cleanupTests -return - -# Local Variables: -# fill-column: 78 -# mode: tcl -# End: Index: tests/opt.test ================================================================== --- tests/opt.test +++ tests/opt.test @@ -9,28 +9,28 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } # the package we are going to test -package require opt 0.4.6 +package require opt 0.4.8 # we are using implementation specifics to test the package #### functions tests ##### set n $::tcl::OptDescN test opt-1.1 {OptKeyRegister / check that auto allocation is skipping existing keys} { - list [::tcl::OptKeyRegister {} $n] [::tcl::OptKeyRegister {} [expr $n+1]] [::tcl::OptKeyRegister {}] -} "$n [expr $n+1] [expr $n+2]" + list [::tcl::OptKeyRegister {} $n] [::tcl::OptKeyRegister {} [expr {$n+1}]] [::tcl::OptKeyRegister {}] +} "$n [expr {$n+1}] [expr {$n+2}]" test opt-2.1 {OptKeyDelete} { list [::tcl::OptKeyRegister {} testkey] \ [info exists ::tcl::OptDesc(testkey)] \ [::tcl::OptKeyDelete testkey] \ Index: tests/package.test ================================================================== --- tests/package.test +++ tests/package.test @@ -15,26 +15,20 @@ if {"::tcltest" ni [namespace children]} { package require tcltest 2.3.3 namespace import -force ::tcltest::* } -::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] - -# Do all this in a slave interp to avoid garbaging the package list +# Do all this in a child interp to avoid garbaging the package list set i [interp create] -tcltest::loadIntoSlaveInterpreter $i {*}$argv -catch [list load {} Tcltest $i] +tcltest::loadIntoChildInterpreter $i {*}$argv interp eval $i { namespace import -force ::tcltest::* -#package forget {*}[package names] +package forget {*}[package names] set oldPkgUnknown [package unknown] package unknown {} set oldPath $auto_path set auto_path "" - -testConstraint testpreferstable [llength [info commands testpreferstable]] test package-1.1 {pkg::create gives error on insufficient args} -body { ::pkg::create } -returnCodes error -match glob -result {wrong # args: should be "*"} test package-1.2 {pkg::create gives error on bad args} -body { @@ -138,51 +132,51 @@ } -body { foreach i {1.4 3.4 2.3 2.4 2.2} { package ifneeded t $i "set x $i; package provide t $i" } package require t - set x + return $x } -result {3.4} test package-3.2 {Tcl_PkgRequire procedure, picking best version} -setup { package forget t set x xxx } -body { foreach i {1.4 3.4 2.3 2.4 2.2 3.5 3.2} { package ifneeded t $i "set x $i; package provide t $i" } package require t - set x + return $x } -result {3.5} test package-3.3 {Tcl_PkgRequire procedure, picking best version} -setup { package forget t set x xxx } -body { foreach i {3.5 2.1 2.3} { package ifneeded t $i "set x $i; package provide t $i" } package require t 2.2 - set x + return $x } -result {2.3} test package-3.4 {Tcl_PkgRequire procedure, picking best version} -setup { package forget t set x xxx } -body { foreach i {1.4 3.4 2.3 2.4 2.2} { package ifneeded t $i "set x $i; package provide t $i" } package require -exact t 2.3 - set x + return $x } -result {2.3} test package-3.5 {Tcl_PkgRequire procedure, picking best version} -setup { package forget t set x xxx } -body { foreach i {1.4 3.4 2.3 2.4 2.2} { package ifneeded t $i "set x $i; package provide t $i" } package require t 2.1 - set x + return $x } -result {2.4} test package-3.6 {Tcl_PkgRequire procedure, can't find suitable version} -setup { package forget t } -returnCodes error -body { package unknown {} @@ -237,11 +231,11 @@ package forget t set x xxx } -body { package ifneeded t 1.2 "package forget t; set x 1.2; package provide t 1.2" package require t 1.2 - set x + return $x } -result {1.2} test package-3.13 {Tcl_PkgRequire procedure, "package unknown" support} -setup { package forget t set x xxx } -body { @@ -255,11 +249,11 @@ foreach i {1.4 3.4 2.3 2.4 2.2} { package ifneeded t $i "set x $i" } package unknown pkgUnknown package require -exact t 1.5 - set x + return $x } -cleanup { package unknown {} } -result {t 1.5-1.5} test package-3.14 {Tcl_PkgRequire procedure, "package unknown" support} -setup { package forget t @@ -282,11 +276,11 @@ global x set x $args package provide [lindex $args 0] 2.0 } package require {a b} - set x + return $x } -cleanup { package unknown {} } -result {{a b} 0-} test package-3.16 {Tcl_PkgRequire procedure, "package unknown" error} -setup { package forget t @@ -573,132 +567,95 @@ } -body { package require -exact demo 1.2 } -returnCodes error -cleanup { package forget demo } -result {version conflict for package "demo": have 1.2.3, need exactly 1.2} -test package-3.50 {Tcl_PkgRequire procedure, picking best stable version} -constraints testpreferstable -setup { - interp create child - load {} Tcltest child - child eval { - testpreferstable +test package-3.50 {Tcl_PkgRequire procedure, picking best stable version} -setup { package forget t set x xxx - } } -body { - child eval { foreach i {1.4 3.4 4.0a1 2.3 2.4 2.2} { package ifneeded t $i "set x $i; package provide t $i" } package require t - set x - } -} -cleanup { - interp delete child + return $x } -result {3.4} test package-3.51 {Tcl_PkgRequire procedure, picking best stable version} -setup { package forget t set x xxx } -body { foreach i {1.2b1 1.2 1.3a2 1.3} { package ifneeded t $i "set x $i; package provide t $i" } package require t - set x + return $x } -result {1.3} test package-3.52 {Tcl_PkgRequire procedure, picking best stable version} -setup { package forget t set x xxx } -body { foreach i {1.2b1 1.2 1.3 1.3a2} { package ifneeded t $i "set x $i; package provide t $i" } package require t - set x + return $x } -result {1.3} -test pkg-3.53 {Tcl_PkgRequire procedure, picking best stable version} -constraints testpreferstable -setup { - testpreferstable +test pkg-3.53 {Tcl_PkgRequire procedure, picking best stable version} { package forget t - set x xxx -} -body { foreach i {1.2b1 1.1} { package ifneeded t $i "set x $i; package provide t $i" } + set x xxx package require t set x -} -result {1.1} +} {1.1} test package-3.54 {Tcl_PkgRequire procedure, coroutine support} -setup { package forget t } -body { coroutine coro1 apply {{} { package ifneeded t 2.1 { - yield + yield package provide t 2.1 } package require t 2.1 }} list [catch {coro1} msg] $msg -} -match glob -result {0 2.1} +} -match glob -result {0 2.1} test package-4.1 {Tcl_PackageCmd procedure} -returnCodes error -body { package } -result {wrong # args: should be "package option ?arg ...?"} -test package-4.2 {Tcl_PackageCmd procedure, "forget" option} -setup { - interp create child -} -body { - child eval { +test package-4.2 {Tcl_PackageCmd procedure, "forget" option} { package forget {*}[package names] package names - } -} -cleanup { - interp delete child -} -result {} -test package-4.3 {Tcl_PackageCmd procedure, "forget" option} -setup { - interp create child -} -body { - child eval { +} {} +test package-4.3 {Tcl_PackageCmd procedure, "forget" option} { package forget {*}[package names] package forget foo - } -} -cleanup { - interp delete child -} -result {} +} {} test package-4.4 {Tcl_PackageCmd procedure, "forget" option} -setup { - interp create child - child eval { package forget {*}[package names] set result {} - } } -body { - child eval { package ifneeded t 1.1 {first script} package ifneeded t 2.3 {second script} package ifneeded x 1.4 {x's script} lappend result [lsort [package names]] [package versions t] package forget t lappend result [lsort [package names]] [package versions t] - } -} -cleanup { - interp delete child } -result {{t x} {1.1 2.3} x {}} test package-4.5 {Tcl_PackageCmd procedure, "forget" option} -setup { - interp create child - child eval { package forget {*}[package names] - } } -body { - child eval { package ifneeded a 1.1 {first script} package ifneeded b 2.3 {second script} package ifneeded c 1.4 {third script} package forget set result [list [lsort [package names]]] package forget a c lappend result [lsort [package names]] - } -} -cleanup { - interp delete child } -result {{a b c} b} test package-4.5.1 {Tcl_PackageCmd procedure, "forget" option} -body { # Test for Bug 415273 package ifneeded a 1 "I should have been forgotten" package forget no-such-package a @@ -713,59 +670,32 @@ package ifneeded a b c d } -returnCodes error -result {wrong # args: should be "package ifneeded package version ?script?"} test package-4.8 {Tcl_PackageCmd procedure, "ifneeded" option} -body { package ifneeded t xyz } -returnCodes error -result {expected version number but got "xyz"} -test package-4.9 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { - interp create child -} -body { - child eval { +test package-4.9 {Tcl_PackageCmd procedure, "ifneeded" option} { package forget {*}[package names] list [package ifneeded foo 1.1] [package names] - } -} -cleanup { - interp delete child -} -result {{} {}} +} {{} {}} test package-4.10 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { - interp create child - child eval { - package forget {*}[package names] - } + package forget t } -body { - child eval { package ifneeded t 1.4 "script for t 1.4" list [package names] [package ifneeded t 1.4] [package versions t] - } -} -cleanup { - interp delete child } -result {t {script for t 1.4} 1.4} test package-4.11 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { - interp create child - child eval { - package forget {*}[package names] - } + package forget t } -body { - child eval { package ifneeded t 1.4 "script for t 1.4" list [package ifneeded t 1.5] [package names] [package versions t] - } -} -cleanup { - interp delete child } -result {{} t 1.4} test package-4.12 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { - interp create child - child eval { - package forget {*}[package names] - } + package forget t } -body { - child eval { package ifneeded t 1.4 "script for t 1.4" package ifneeded t 1.4 "second script for t 1.4" list [package ifneeded t 1.4] [package names] [package versions t] - } -} -cleanup { - interp delete child } -result {{second script for t 1.4} t 1.4} test package-4.13 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { package forget t } -body { package ifneeded t 1.4 "script for t 1.4" @@ -774,35 +704,22 @@ list [package ifneeded t 1.2] [package versions t] } -result {{second script} {1.4 1.2 3.1}} test package-4.14 {Tcl_PackageCmd procedure, "names" option} -body { package names a } -returnCodes error -result {wrong # args: should be "package names"} -test package-4.15 {Tcl_PackageCmd procedure, "names" option} -setup { - interp create child -} -body { - child eval { +test package-4.15 {Tcl_PackageCmd procedure, "names" option} { package forget {*}[package names] package names - } -} -cleanup { - interp delete child -} -result {} +} {} test package-4.16 {Tcl_PackageCmd procedure, "names" option} -setup { - interp create child - child eval { package forget {*}[package names] - } } -body { - child eval { package ifneeded x 1.2 {dummy} package provide x 1.3 package provide y 2.4 catch {package require z 47.16} lsort [package names] - } -} -cleanup { - interp delete child } -result {x y} test package-4.17 {Tcl_PackageCmd procedure, "provide" option} -body { package provide } -returnCodes error -result {wrong # args: should be "package provide package ?version?"} test package-4.18 {Tcl_PackageCmd procedure, "provide" option} -body { @@ -929,11 +846,11 @@ test package-4.52 {Tcl_PackageCmd procedure, "vsatisfies" option} { package vs 2.3 1.2 } {0} test package-4.53 {Tcl_PackageCmd procedure, "versions" option} -body { package foo -} -returnCodes error -result {bad option "foo": must be files, forget, ifneeded, names, prefer, present, provide, require, unknown, vcompare, versions, or vsatisfies} +} -returnCodes error -result {bad option "foo": must be forget, ifneeded, names, prefer, present, provide, require, unknown, vcompare, versions, or vsatisfies} test package-4.54 {Tcl_PackageCmd procedure, "vsatisfies" option} -body { package vsatisfies 2.1 2.1-3.2-4.5 } -returnCodes error -result {expected versionMin-versionMax but got "2.1-3.2-4.5"} test package-4.55 {Tcl_PackageCmd procedure, "vsatisfies" option} -body { package vsatisfies 2.1 3.2-x.y @@ -943,19 +860,19 @@ } -returnCodes error -result {expected version number but got "x.y"} # No tests for FindPackage; can't think up anything detectable errors. test package-5.1 {TclFreePackageInfo procedure} { - interp create slave - slave eval { + interp create child + child eval { package ifneeded t 2.3 x package ifneeded t 2.4 y package ifneeded x 3.1 z package provide q 4.3 package unknown "will this get freed?" } - interp delete slave + interp delete child } {} test package-5.2 {TclFreePackageInfo procedure} -body { interp create foo foo eval { package ifneeded t 2.3 x @@ -1336,13 +1253,13 @@ } finally { interp delete $ip } } -test package-13.0 {package prefer defaults} -body { +test package-13.0 {package prefer defaults} { prefer -} -result [expr {[string match {*[ab]*} [package provide Tcl]] ? "latest" : "stable"}] +} stable test package-13.1 {package prefer defaults} -body { set ::env(TCL_PKG_PREFER_LATEST) stable ;# value not relevant! prefer } -cleanup { unset -nocomplain ::env(TCL_PKG_PREFER_LATEST) @@ -1353,31 +1270,19 @@ } -result {wrong # args: should be "package prefer ?latest|stable?"} test package-14.1 {bogus argument} -returnCodes error -body { package prefer foo } -result {bad preference "foo": must be latest or stable} -test package-15.0 {set, keep} -constraints testpreferstable -setup { - testpreferstable -} -body {package prefer} -result stable -test package-15.1 {set stable, keep} -constraints testpreferstable -setup { - testpreferstable -} -body {package prefer stable} -result stable -test package-15.2 {set latest, change} -constraints testpreferstable -setup { - testpreferstable -} -body {package prefer latest} -result latest -test package-15.3 {set latest, keep} -constraints testpreferstable -setup { - testpreferstable -} -body { - package prefer latest - package prefer latest -} -result latest -test package-15.4 {set stable, rejected} -constraints testpreferstable -setup { - testpreferstable -} -body { - package prefer latest - package prefer stable -} -result latest +test package-15.0 {set, keep} {package prefer stable} stable +test package-15.1 {set stable, keep} {prefer stable} {stable stable} +test package-15.2 {set latest, change} {prefer latest} {stable latest} +test package-15.3 {set latest, keep} { + prefer latest latest +} {stable latest latest} +test package-15.4 {set stable, rejected} { + prefer latest stable +} {stable latest latest} rename prefer {} set auto_path $oldPath package unknown $oldPkgUnknown Index: tests/parse.test ================================================================== --- tests/parse.test +++ tests/parse.test @@ -374,16 +374,16 @@ set aresult $result set acode $code return "new result" } set handler1 [testasync create async1] - set ::aresult xxx - set ::acode yyy + set aresult xxx + set acode yyy } -cleanup { testasync delete } -body { - list [testevalobjv 0 testasync mark $handler1 original 0] $::acode $::aresult + list [testevalobjv 0 testasync mark $handler1 original 0] $acode $aresult } -result {{new result} 0 original} test parse-8.9 {Tcl_EvalObjv procedure, exceptional return} testevalobjv { list [catch {testevalobjv 0 error message} msg] $msg } {1 message} test parse-8.10 {Tcl_EvalObjv procedure, TCL_EVAL_GLOBAL} testevalobjv { @@ -403,18 +403,18 @@ test parse-8.11 {Tcl_EvalObjv procedure, TCL_EVAL_INVOKE} testevalobjv { rename ::unknown unknown.save proc ::unknown args {lappend ::info [info level]; uplevel 1 foo} proc ::foo args {lappend ::info global} catch {rename ::noSuchCommand {}} - set ::slave [interp create] - $::slave alias bar noSuchCommand + set ::child [interp create] + $::child alias bar noSuchCommand set ::info {} namespace eval test_ns_1 { proc foo args {lappend ::info namespace} - $::slave eval bar - testevalobjv 1 [list $::slave eval bar] - uplevel #0 [list $::slave eval bar] + $::child eval bar + testevalobjv 1 [list $::child eval bar] + uplevel #0 [list $::child eval bar] } namespace delete test_ns_1 rename ::foo {} rename ::unknown {} rename unknown.save ::unknown @@ -427,18 +427,18 @@ set ::auto_index(::[string trimleft [namespace current]::test_ns_1::noSuchCommand :]) [list \ proc [namespace current]::test_ns_1::noSuchCommand {} { lappend ::info ns }] catch {rename ::noSuchCommand {}} - set ::slave [interp create] - $::slave alias bar noSuchCommand + set ::child [interp create] + $::child alias bar noSuchCommand set ::info {} namespace eval test_ns_1 { - $::slave eval bar + $::child eval bar } namespace delete test_ns_1 - interp delete $::slave + interp delete $::child catch {rename ::noSuchCommand {}} set ::info } global @@ -479,11 +479,11 @@ } {test} test parse-10.2 {Tcl_EvalTokens, backslash sequences} testevalex { testevalex {concat test\063\062test} } {test32test} test parse-10.3 {Tcl_EvalTokens, nested commands} testevalex { - testevalex {concat [expr 2 + 6]} + testevalex {concat [expr {2 + 6}]} } {8} test parse-10.4 {Tcl_EvalTokens, nested commands} testevalex { unset -nocomplain a list [catch {testevalex {concat xxx[expr $a]}} msg] $msg } {1 {can't read "a": no such variable}} @@ -497,11 +497,11 @@ testevalex {concat $a(12)} } {46} test parse-10.7 {Tcl_EvalTokens, array variables} testevalex { unset -nocomplain a set a(12) 46 - testevalex {concat $a(1[expr 3 - 1])} + testevalex {concat $a(1[expr {3 - 1}])} } {46} test parse-10.8 {Tcl_EvalTokens, array variables} testevalex { unset -nocomplain a list [catch {testevalex {concat $x($a)}} msg] $msg } {1 {can't read "a": no such variable}} Index: tests/parseExpr.test ================================================================== --- tests/parseExpr.test +++ tests/parseExpr.test @@ -6,12 +6,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] # Note that the Tcl expression parser (tclCompExpr.c) does not check @@ -766,15 +768,15 @@ } -returnCodes error -match glob -result {*invalid octal number*} test parseExpr-21.8 {error messages} -body { expr {0o8x} } -returnCodes error -match glob -result {*invalid octal number*} test parseExpr-21.9 {error messages} -body { - expr {"} + expr {"} } -returnCodes error -result {missing " in expression """} test parseExpr-21.10 {error messages} -body { - expr \{ + expr \{ } -returnCodes error -result "missing close-brace in expression \"\{\"" test parseExpr-21.11 {error messages} -body { expr $ } -returnCodes error -result {invalid character "$" @@ -1042,12 +1044,13 @@ test parseExpr-22.13 {Bug 3401704} -constraints testexprparser -body { testexprparser naner() -1 } -result {- {} 0 subexpr naner() 1 operator naner 0 {}} test parseExpr-22.14 {Bug 3401704} -constraints testexprparser -body { - testexprparser 07 -1 -} -result {- {} 0 subexpr 07 1 text 07 0 {}} + catch {testexprparser 08 -1} m o + dict get $o -errorcode +} -result {TCL PARSE EXPR BADNUMBER OCTAL} test parseExpr-22.15 {Bug 3401704} -constraints testexprparser -body { catch {testexprparser 0o8 -1} m o dict get $o -errorcode } -result {TCL PARSE EXPR BADNUMBER OCTAL} test parseExpr-22.16 {Bug 3401704} -constraints testexprparser -body { Index: tests/parseOld.test ================================================================== --- tests/parseOld.test +++ tests/parseOld.test @@ -11,12 +11,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] testConstraint testwordend [llength [info commands testwordend]] @@ -131,11 +133,11 @@ ]b set a } a22b test parseOld-4.4 {command substitution} { set a 7.7 - if [catch {expr int($a)}] {set a foo} + if {[catch {expr {int($a)}}]} {set a foo} set a } 7.7 # Variable substitution. Index: tests/pid.test ================================================================== --- tests/pid.test +++ tests/pid.test @@ -9,21 +9,21 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } testConstraint pidDefined [llength [info commands pid]] test pid-1.1 {pid command} pidDefined { regexp {(^[0-9]+$)|(^0x[0-9a-fA-F]+$)} [pid] } 1 -test pid-1.2 {pid command} -constraints {unixOrPc unixExecs pidDefined} -setup { +test pid-1.2 {pid command} -constraints {unixOrWin unixExecs pidDefined} -setup { set path(test1) [makeFile {} test1] file delete $path(test1) } -body { set f [open |[list echo foo | cat >$path(test1)] w] set pids [pid $f] Index: tests/pkgIndex.tcl ================================================================== --- tests/pkgIndex.tcl +++ tests/pkgIndex.tcl Index: tests/pkgMkIndex.test ================================================================== --- tests/pkgMkIndex.test +++ tests/pkgMkIndex.test @@ -6,12 +6,14 @@ # No output means no errors were found. # # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} set fullPkgPath [makeDirectory pkg] namespace eval pkgtest { # Namespace for procs we can discard @@ -70,15 +72,15 @@ # Returns a list, in "array set/get" format, where the keys are the package # name and version (in the form "$name:$version"), and the values the rest # of the command line. proc pkgtest::parseIndex { filePath } { - # create a slave interpreter, where we override "package ifneeded" + # create a child interpreter, where we override "package ifneeded" - set slave [interp create] + set child [interp create] if {[catch { - $slave eval { + $child eval { rename package package_original proc package { args } { if {[lindex $args 0] eq "ifneeded"} { set pkg [lindex $args 1] set ver [lindex $args 2] @@ -89,21 +91,21 @@ } array set ::PKGS {} } set dir [file dirname $filePath] - $slave eval {set curdir [pwd]} - $slave eval [list cd $dir] - $slave eval [list set dir $dir] - $slave eval [list source [file tail $filePath]] - $slave eval {cd $curdir} + $child eval {set curdir [pwd]} + $child eval [list cd $dir] + $child eval [list set dir $dir] + $child eval [list source [file tail $filePath]] + $child eval {cd $curdir} # Create the list in sorted order, so that we don't get spurious # errors because the order has changed. array set P {} - foreach {k v} [$slave eval {array get ::PKGS}] { + foreach {k v} [$child eval {array get ::PKGS}] { set P($k) $v } set PKGS "" foreach k [lsort [array names P]] { @@ -111,16 +113,16 @@ } } err opts]} { set ei [dict get $opts -errorinfo] set ec [dict get $opts -errorcode] - catch {interp delete $slave} + catch {interp delete $child} error $ei $ec } - interp delete $slave + interp delete $child return $PKGS } # pkgtest::createIndex -- @@ -311,11 +313,11 @@ package provide pkg2 1.0 namespace eval pkg2 { namespace export p2-1 } proc pkg2::p2-1 { num } { - return [expr $num * 2] + return [expr {$num * 2}] } } [file join pkg pkg2_a.tcl] makeFile { # This package is required by pkg1. @@ -324,11 +326,11 @@ package provide pkg2 1.0 namespace eval pkg2 { namespace export p2-2 } proc pkg2::p2-2 { num } { - return [expr $num * 3] + return [expr {$num * 3}] } } [file join pkg pkg2_b.tcl] test pkgMkIndex-4.1 {split package} { pkgtest::runIndex -lazy $fullPkgPath pkg2_a.tcl pkg2_b.tcl @@ -405,14 +407,14 @@ package provide pkg3 1.0 namespace eval pkg3 { namespace export p3-1 p3-2 } proc pkg3::p3-1 { num } { - return {[expr $num * 2]} + return {[expr {$num * 2}]} } proc pkg3::p3-2 { num } { - return {[expr $num * 3]} + return {[expr {$num * 3}]} } } [file join pkg pkg3.tcl] test pkgMkIndex-6.1 {pkg1 requires pkg3} { pkgtest::runIndex -lazy $fullPkgPath pkg1.tcl pkg3.tcl @@ -516,14 +518,14 @@ package provide circ2 1.0 namespace eval circ2 { namespace export c2-1 c2-2 } proc circ2::c2-1 { num } { - return [expr $num * [circ3::c3-1]] + return [expr {$num * [circ3::c3-1]}] } proc circ2::c2-2 { num } { - return [expr $num * [circ3::c3-2]] + return [expr {$num * [circ3::c3-2]}] } } [file join pkg circ2.tcl] makeFile { # This package is required by circ2, and in turn requires circ1. This closes Index: tests/platform.test ================================================================== --- tests/platform.test +++ tests/platform.test @@ -7,11 +7,12 @@ # Copyright (c) 1999 by Scriptics Corporation # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 +package require tcltest 2.5 +package require tcltests namespace eval ::tcl::test::platform { namespace import ::tcltest::testConstraint namespace import ::tcltest::test namespace import ::tcltest::cleanupTests @@ -20,14 +21,12 @@ #variable ::tcl_platform namespace upvar :: tcl_platform tcl_platform ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] -package require tcltests testConstraint testCPUID [llength [info commands testcpuid]] -testConstraint testlongsize [llength [info commands testlongsize]] test platform-1.0 {tcl_platform(engine)} { set tcl_platform(engine) } {Tcl} @@ -38,24 +37,31 @@ set result [i eval {lsort [array names tcl_platform]}] interp delete i set result } {byteOrder engine machine os osVersion pathSeparator platform pointerSize user wordSize} -test platform-2.1 {tcl_platform(wordSize) indicates size of native word} testlongsize { - expr {$tcl_platform(wordSize) == [testlongsize]} -} {1} +# Test assumes twos-complement arithmetic, which is true of virtually +# everything these days. Note that this does *not* use wide(), and +# this is intentional since that could make Tcl's numbers wider than +# the machine-integer on some platforms... +test platform-2.1 {tcl_platform(wordSize) indicates size of native word} { + set result [expr {int(1 << (8 * $tcl_platform(wordSize) - 1))}] + # Result must be the largest bit in a machine word, which this checks + # without assuming how wide the word really is + list [expr {$result < 0}] [expr {$result ^ int($result - 1)}] +} {1 -1} # On Windows/UNIX, test that the CPU ID works test platform-3.1 {CPU ID on Windows/UNIX} \ -constraints testCPUID \ - -body { + -body { set cpudata [testcpuid 0] binary format iii \ [lindex $cpudata 1] \ [lindex $cpudata 3] \ - [lindex $cpudata 2] + [lindex $cpudata 2] } \ -match regexp \ -result {^(?:AuthenticAMD|CentaurHauls|CyrixInstead|GenuineIntel)$} # The platform package makes very few promises, but does promise that the Index: tests/proc-old.test ================================================================== --- tests/proc-old.test +++ tests/proc-old.test @@ -12,22 +12,22 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } catch {rename t1 ""} catch {rename foo ""} proc tproc {} {return a; return b} test proc-old-1.1 {simple procedure call and return} {tproc} a proc tproc x { - set x [expr $x+1] + set x [expr {$x + 1}] return $x } test proc-old-1.2 {simple procedure call and return} {tproc 2} 3 test proc-old-1.3 {simple procedure call and return} { proc tproc {} {return foo} @@ -47,37 +47,37 @@ list [tproc] [append x foo] } {{} foo} test proc-old-2.1 {local and global variables} { proc tproc x { - set x [expr $x+1] + set x [expr {$x + 1}] return $x } set x 42 list [tproc 6] $x } {7 42} test proc-old-2.2 {local and global variables} { proc tproc x { - set y [expr $x+1] + set y [expr {$x + 1}] return $y } set y 18 list [tproc 6] $y } {7 18} test proc-old-2.3 {local and global variables} { proc tproc x { global y - set y [expr $x+1] + set y [expr {$x + 1}] return $y } set y 189 list [tproc 6] $y } {7 7} test proc-old-2.4 {local and global variables} { proc tproc x { global y - return [expr $x+$y] + return [expr {$x + $y}] } set y 189 list [tproc 6] $y } {195 189} catch {unset _undefined_} @@ -502,11 +502,11 @@ test proc-old-10.1 {ByteCode epoch change during recursive proc execution} { proc t1 x { set y 20 rename expr expr.old rename expr.old expr - if $x then {t1 0} ;# recursive call after foo's code is invalidated + if {$x} then {t1 0} ;# recursive call after foo's code is invalidated return 20 } t1 1 } 20 Index: tests/proc.test ================================================================== --- tests/proc.test +++ tests/proc.test @@ -12,11 +12,11 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } testConstraint procbodytest [expr {![catch {package require procbodytest}]}] testConstraint memory [llength [info commands memory]] @@ -98,11 +98,11 @@ } -result {q: value:at: q: value:at: {::test_ns_1::q: ::test_ns_1::value:at:} ::test_ns_1::q: ::test_ns_1::value:at:} test proc-1.7 {Tcl_ProcObjCmd, check that formal parameter names are not array elements} -setup { catch {rename p ""} } -returnCodes error -body { proc p {a(1) a(2)} { - set z [expr $a(1)+$a(2)] + set z [expr {$a(1)+$a(2)}] puts "$z=z, $a(1)=$a(1)" } } -result {formal parameter "a(1)" is an array element} test proc-1.8 {Tcl_ProcObjCmd, check that formal parameter names are simple names} -setup { catch {rename p ""} @@ -387,13 +387,13 @@ } -result 4 test proc-7.4 {Proc struct outlives its interp: Bug 3532959} { set lambda x lappend lambda {set a 1} - interp create slave - slave eval [list apply $lambda foo] - interp delete slave + interp create child + child eval [list apply $lambda foo] + interp delete child unset lambda } {} test proc-7.5 {[631b4c45df] Crash in argument processing} { binary scan A c val DELETED tests/process.test Index: tests/process.test ================================================================== --- tests/process.test +++ /dev/null @@ -1,341 +0,0 @@ -# process.test -- -# -# This file contains a collection of tests for the tcl::process ensemble. -# Sourcing this file into Tcl runs the tests and generates output for -# errors. No output means no errors were found. -# -# Copyright (c) 2017 Frederic Bonnet -# See the file "license.terms" for information on usage and redistribution of -# this file, and for a DISCLAIMER OF ALL WARRANTIES. - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 - namespace import -force ::tcltest::* -} - -# Utilities -file delete [set path(test-signalfile) [makeFile {} test-signalfile]] -set path(test-signalfile2) [makeFile {} test-signalfile2] -# $path(sleep) time ?filename? -- sleep for time (in ms) and stop if it gets signaled (file gets deleted) -set path(sleep) [makeFile { - after [expr {[lindex $argv 0]*1000}] {set stop 1} - if {[set fn [lindex $::argv 1]] ne ""} { - close [open $fn w] - proc check {} { - if {![file exists $::fn]} { # exit signaled - after 10 {set ::stop 2} - } - after 10 check - } - after 10 check - } - vwait stop - exit -} sleep] - -proc wait_for_file {fn {timeout 10000}} { - if {![file exists $fn]} { - set toev [after $timeout {set found 0}] - proc check {fn} { - if {[file exists $fn]} { - set ::found 1 - return - } - after 10 [list check $fn] - } - after 10 [list check $fn] - vwait ::found - after cancel $toev - unset ::found - } - file exists $fn -} -proc signal_exit {fn {wait 1}} { - # wait for until file created if expected: - if {!$wait || [wait_for_file $fn]} { - # delete file to signal exit for child-process: - while {1} { - if {![catch { file delete $fn } msg opt] - || [lrange [dict get $opt -errorcode] 0 1] ne {POSIX EACCES} - } break - } - } -} - -set path(exit) [makeFile { - exit [lindex $argv 0] -} exit] - -# Basic syntax checking -test process-1.1 {tcl::process command basic syntax} -returnCodes error -body { - tcl::process -} -result {wrong # args: should be "tcl::process subcommand ?arg ...?"} -test process-1.2 {tcl::process subcommands} -returnCodes error -body { - tcl::process ? -} -match glob -result {unknown or ambiguous subcommand "?": must be autopurge, list, purge, or status} - -# Autopurge flag -# - Default state -test process-2.1 {autopurge default} -body { - tcl::process autopurge -} -result {1} -# - Enabling autopurge -test process-2.2 {enable autopurge} -body { - tcl::process autopurge true - tcl::process autopurge -} -result {1} -# - Disabling autopurge -test process-2.3 {disable autopurge} -body { - tcl::process autopurge false - tcl::process autopurge -} -result {0} -cleanup {tcl::process autopurge true} - -# Subprocess list & status -test process-3.1 {empty subprocess list} -body { - llength [tcl::process list] -} -result {0} -test process-3.2 {empty subprocess status} -body { - dict size [tcl::process status] -} -result {0} - -# Spawn subprocesses using [exec] -# - One child -test process-4.1 {exec one child} -body { - tcl::process autopurge 0 - set pid [exec [interpreter] $path(exit) 0 &] - set list [tcl::process list] - set statuses [tcl::process status -wait] - set status [lindex [tcl::process status $pid] 1] - expr { - [llength $list] eq 1 - && [lindex $list 0] eq $pid - && [dict size $statuses] eq 1 - && [dict get $statuses $pid] eq $status - && $status eq 0 - } -} -result {1} -cleanup { - tcl::process purge - tcl::process autopurge 1 -} -# - Two children -test process-4.2 {exec two children in parallel} -body { - tcl::process autopurge 0 - set pid1 [exec [interpreter] $path(exit) 0 &] - set pid2 [exec [interpreter] $path(exit) 0 &] - set list [tcl::process list] - set statuses [tcl::process status -wait] - set status1 [lindex [tcl::process status $pid1] 1] - set status2 [lindex [tcl::process status $pid2] 1] - expr { - [llength $list] eq 2 - && [lsearch $list $pid1] >= 0 - && [lsearch $list $pid2] >= 0 - && [dict size $statuses] eq 2 - && [dict get $statuses $pid1] eq $status1 - && [dict get $statuses $pid2] eq $status2 - && $status1 eq 0 - && $status2 eq 0 - } -} -result {1} -cleanup { - tcl::process purge - tcl::process autopurge 1 -} -# - 3-stage pipe -test process-4.3 {exec 3-stage pipe} -body { - tcl::process autopurge 0 - set pids [exec \ - [interpreter] $path(exit) 0 \ - | [interpreter] $path(exit) 0 \ - | [interpreter] $path(exit) 0 \ - &] - lassign $pids pid1 pid2 pid3 - set list [tcl::process list] - set statuses [tcl::process status -wait] - set status1 [lindex [tcl::process status $pid1] 1] - set status2 [lindex [tcl::process status $pid2] 1] - set status3 [lindex [tcl::process status $pid3] 1] - expr { - [llength $pids] eq 3 - && [llength $list] eq 3 - && [lsearch $list $pid1] >= 0 - && [lsearch $list $pid2] >= 0 - && [lsearch $list $pid3] >= 0 - && [dict size $statuses] eq 3 - && [dict get $statuses $pid1] eq $status1 - && [dict get $statuses $pid2] eq $status2 - && [dict get $statuses $pid3] eq $status3 - && $status1 eq 0 - && $status2 eq 0 - && $status3 eq 0 - } -} -result {1} -cleanup { - tcl::process purge - tcl::process autopurge 1 -} - -# Spawn subprocesses using [open "|"] -# - One child -test process-5.1 {exec one child} -body { - tcl::process autopurge 0 - set f [open "|\"[interpreter]\" \"$path(exit)\" 0"] - set pid [pid $f] - set list [tcl::process list] - set statuses [tcl::process status -wait] - set status [lindex [tcl::process status $pid] 1] - expr { - [llength $list] eq 1 - && [lindex $list 0] eq $pid - && [dict size $statuses] eq 1 - && [dict get $statuses $pid] eq $status - && $status eq 0 - } -} -result {1} -cleanup { - close $f - tcl::process purge - tcl::process autopurge 1 -} -# - Two children -test process-5.2 {exec two children in parallel} -body { - tcl::process autopurge 0 - set f1 [open "|\"[interpreter]\" \"$path(exit)\" 0"] - set f2 [open "|\"[interpreter]\" \"$path(exit)\" 0"] - set pid1 [pid $f1] - set pid2 [pid $f2] - set list [tcl::process list] - set statuses [tcl::process status -wait] - set status1 [lindex [tcl::process status $pid1] 1] - set status2 [lindex [tcl::process status $pid2] 1] - expr { - [llength $list] eq 2 - && [lsearch $list $pid1] >= 0 - && [lsearch $list $pid2] >= 0 - && [dict size $statuses] eq 2 - && [dict get $statuses $pid1] eq $status1 - && [dict get $statuses $pid2] eq $status2 - && $status1 eq 0 - && $status2 eq 0 - } -} -result {1} -cleanup { - close $f1 - close $f2 - tcl::process purge - tcl::process autopurge 1 -} -# - 3-stage pipe -test process-5.3 {exec 3-stage pipe} -body { - tcl::process autopurge 0 - set f [open "| - \"[interpreter]\" \"$path(exit)\" 0 - | \"[interpreter]\" \"$path(exit)\" 0 - | \"[interpreter]\" \"$path(exit)\" 0 - "] - set pids [pid $f] - lassign $pids pid1 pid2 pid3 - set list [tcl::process list] - set statuses [tcl::process status -wait] - set status1 [lindex [tcl::process status $pid1] 1] - set status2 [lindex [tcl::process status $pid2] 1] - set status3 [lindex [tcl::process status $pid3] 1] - expr { - [llength $pids] eq 3 - && [llength $list] eq 3 - && [lsearch $list $pid1] >= 0 - && [lsearch $list $pid2] >= 0 - && [lsearch $list $pid3] >= 0 - && [dict size $statuses] eq 3 - && [dict get $statuses $pid1] eq $status1 - && [dict get $statuses $pid2] eq $status2 - && [dict get $statuses $pid3] eq $status3 - && $status1 eq 0 - && $status2 eq 0 - && $status3 eq 0 - } -} -result {1} -cleanup { - close $f - tcl::process purge - tcl::process autopurge 1 -} - -# Async child status -test process-6.1 {async status} -setup { - signal_exit $path(test-signalfile) 0; # clean signal-file -} -body { - tcl::process autopurge 0 - set pid [exec [interpreter] $path(sleep) 1 $path(test-signalfile) &] - set status1 [lindex [tcl::process status $pid] 1] - signal_exit $path(test-signalfile); # signal exit (stop sleep) - set status2 [lindex [tcl::process status -wait $pid] 1] - expr { - $status1 eq {} - && $status2 eq 0 - } -} -result {1} -cleanup { - tcl::process purge - tcl::process autopurge 1 -} -test process-6.2 {selective wait} -setup { - signal_exit $path(test-signalfile) 0; # clean signal-files - signal_exit $path(test-signalfile2) 0; -} -body { - tcl::process autopurge 0 - # Child 1 sleeps 1s - set pid1 [exec [interpreter] $path(sleep) 1 $path(test-signalfile) &] - # Child 2 sleeps 1s - set pid2 [exec [interpreter] $path(sleep) 2 $path(test-signalfile2) &] - # Initial status - set status1_1 [lindex [tcl::process status $pid1] 1] - set status1_2 [lindex [tcl::process status $pid2] 1] - # Wait until child 1 termination - signal_exit $path(test-signalfile); # signal exit for pid1 (stop sleep) - set status2_1 [lindex [tcl::process status -wait $pid1] 1] - set status2_2 [lindex [tcl::process status $pid2] 1] - # Wait until child 2 termination - signal_exit $path(test-signalfile2); # signal exit for pid2 (stop sleep) - set status3_2 [lindex [tcl::process status -wait $pid2] 1] - set status3_1 [lindex [tcl::process status $pid1] 1] - expr { - $status1_1 eq {} - && $status1_2 eq {} - && $status2_1 eq 0 - && $status2_2 eq {} - && $status3_1 eq 0 - && $status3_2 eq 0 - } -} -result {1} -cleanup { - tcl::process purge - tcl::process autopurge 1 -} - -# Error codes -test process-7.1 {normal exit} -body { - tcl::process autopurge 0 - set pid [exec [interpreter] $path(exit) 0 &] - lindex [tcl::process status -wait $pid] 1 -} -result {0} -cleanup { - tcl::process purge - tcl::process autopurge 1 -} -test process-7.2 {abnormal exit} -body { - tcl::process autopurge 0 - set pid [exec [interpreter] $path(exit) 1 &] - lindex [tcl::process status -wait $pid] 1 -} -match glob -result {1 {child process exited abnormally} {CHILDSTATUS * 1}} -cleanup { - tcl::process purge - tcl::process autopurge 1 -} -test process-7.3 {child killed} -constraints {win} -body { - tcl::process autopurge 0 - set pid [exec [interpreter] $path(exit) -1 &] - lindex [tcl::process status -wait $pid] 1 -} -match glob -result {1 {child killed: unknown signal} {CHILDKILLED * {unknown signal} {unknown signal}}} -cleanup { - tcl::process purge - tcl::process autopurge 1 -} - -removeFile $path(exit) -removeFile $path(sleep) - -rename wait_for_file {} -rename signal_exit {} -::tcltest::cleanupTests -return Index: tests/pwd.test ================================================================== --- tests/pwd.test +++ tests/pwd.test @@ -9,22 +9,23 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } test pwd-1.1 {simple pwd} { catch pwd } 0 test pwd-1.2 {simple pwd} { - expr [string length pwd]>0 + expr {[string length [pwd]]>0} } 1 -test pwd-1.3 {pwd takes no args} -body { + +test pwd-2.1 {pwd takes no args} -body { pwd foobar } -returnCodes error -result "wrong \# args: should be \"pwd\"" # cleanup ::tcltest::cleanupTests Index: tests/reg.test ================================================================== --- tests/reg.test +++ tests/reg.test @@ -7,12 +7,12 @@ # and aren't using Tcl -- reg's own regression tester also knows how # to read this file, ignoring the Tcl-isms.) # # Copyright (c) 1998, 1999 Henry Spencer. All rights reserved. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -285,11 +285,11 @@ set f [TestFlags $flags] set infoflags [TestInfoFlags $flags] set ccmd [list testregexp -about {*}$f $re] set nsub [expr {[llength $args] - 1}] - if {$nsub == -1} { + if {$nsub < 0} { # didn't tell us number of subexps set ccmd "lreplace \[$ccmd\] 0 0" set info [list $infoflags] } else { set info [list $nsub $infoflags] @@ -624,10 +624,11 @@ expectMatch 13.13 P "a\\nb" "a\nb" "a\nb" expectMatch 13.14 P "a\\rb" "a\rb" "a\rb" expectMatch 13.15 P "a\\tb" "a\tb" "a\tb" expectMatch 13.16 P "a\\u0008x" "a\bx" "a\bx" expectMatch 13.17 P {a\u008x} "a\bx" "a\bx" +expectError 13.17.1 - {a\ux} EESCAPE expectMatch 13.18 P "a\\u00088x" "a\b8x" "a\b8x" expectMatch 13.19 P "a\\U00000008x" "a\bx" "a\bx" expectMatch 13.20 P {a\U0000008x} "a\bx" "a\bx" expectMatch 13.21 P "a\\vb" "a\vb" "a\vb" expectMatch 13.22 MP "a\\x08x" "a\bx" "a\bx" Index: tests/regexp.test ================================================================== --- tests/regexp.test +++ tests/regexp.test @@ -10,31 +10,17 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } unset -nocomplain foo testConstraint exec [llength [info commands exec]] - -# Used for constraining memory leak tests -testConstraint memory [llength [info commands memory]] -if {[testConstraint memory]} { - proc memtest script { - set end [lindex [split [memory info] \n] 3 3] - for {set i 0} {$i < 5} {incr i} { - uplevel 1 $script - set tmp $end - set end [lindex [split [memory info] \n] 3 3] - } - expr {$end - $tmp} - } -} test regexp-1.1 {basic regexp operation} { regexp ab*c abbbc } 1 test regexp-1.2 {basic regexp operation} { @@ -190,10 +176,21 @@ } {1 {1 1} {1 1} {-1 -1} {-1 -1}} test regexp-3.7 {getting substrings back from regexp} { set foo 1; set f2 1; set f3 1; set f4 1 list [regexp -indices (a)(b)?(c) xacy foo f2 f3 f4] $foo $f2 $f3 $f4 } {1 {1 2} {1 1} {-1 -1} {2 2}} +test regexp-3.8a {-indices by multi-byte utf-8} { + regexp -inline -indices {(\w+)-(\w+)} \ + "gr\u00FC\u00DF-\u043F\u0440\u0438\u0432\u0435\u0442" +} {{0 10} {0 3} {5 10}} +test regexp-3.8b {-indices by multi-byte utf-8, from -start position} { + list\ + [regexp -inline -indices -start 3 {(\w+)-(\w+)} \ + "gr\u00FC\u00DF-\u043F\u0440\u0438\u0432\u0435\u0442"] \ + [regexp -inline -indices -start 4 {(\w+)-(\w+)} \ + "gr\u00FC\u00DF-\u043F\u0440\u0438\u0432\u0435\u0442"] +} {{{3 10} {3 3} {5 10}} {}} test regexp-4.1 {-nocase option to regexp} { regexp -nocase foo abcFOo } 1 test regexp-4.2 {-nocase option to regexp} { @@ -465,11 +462,11 @@ test regexp-11.4 {regsub errors} { list [catch {regsub a b c d e f} msg] $msg } {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}} test regexp-11.5 {regsub errors} { list [catch {regsub -gorp a b c} msg] $msg -} {1 {bad option "-gorp": must be -all, -command, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}} +} {1 {bad option "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}} test regexp-11.6 {regsub errors} { list [catch {regsub -nocase a( b c d} msg] $msg } {1 {couldn't compile regular expression pattern: parentheses () not balanced}} test regexp-11.7 {regsub errors} -setup { unset -nocomplain f1 @@ -492,11 +489,11 @@ test regexp-11.12 {regsub without final variable name returns value} { regsub -all b(.*?)d abcdeabcfde {,&,\1,} } {a,bcd,c,ea,bcfd,cf,e} # This test crashes on the Mac unless you increase the Stack Space to about 1 -# Meg. This is probably bigger than most users want... +# Meg. This is probably bigger than most users want... # 8.2.3 regexp reduced stack space requirements, but this should be # tested again test regexp-12.1 {Tcl_RegExpExec: large number of subexpressions} {macCrash} { list [regexp (.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.) abcdefghijklmnopqrstuvwxyz all a b c d e f g h i j k l m n o p q r s t u v w x y z] $all $a $b $c $d $e $f $g $h $i $j $k $l $m $n $o $p $q $r $s $t $u $v $w $x $y $z } {1 abcdefghijklmnopqrstuvwxyz a b c d e f g h i j k l m n o p q r s t u v w x y z} @@ -754,14 +751,14 @@ string equal $result $expected } 1 test regexp-20.1 {regsub shared object shimmering} { # Bug #461322 - set a abcdefghijklmnopqurstuvwxyz - set b $a - set c abcdefghijklmnopqurstuvwxyz0123456789 - regsub $a $c $b d + set a abcdefghijklmnopqurstuvwxyz + set b $a + set c abcdefghijklmnopqurstuvwxyz0123456789 + regsub $a $c $b d list $d [string length $d] [string bytelength $d] } [list abcdefghijklmnopqurstuvwxyz0123456789 37 37] test regexp-20.2 {regsub shared object shimmering with -about} { eval regexp -about abc } {0 {}} @@ -1135,64 +1132,13 @@ regexp -all -inline -line -- {a*} "b\n" } {{} {}} test regexp-26.13 {regexp without -line option} { regexp -all -inline -- {a*} "b\n" } {{} {}} - -test regexp-27.1 {regsub -command} { - regsub -command {.x.} {abcxdef} {string length} -} ab3ef -test regexp-27.2 {regsub -command} { - regsub -command {.x.} {abcxdefxghi} {string length} -} ab3efxghi -test regexp-27.3 {regsub -command} { - set x 0 - regsub -all -command {(?=.)} abcde {apply {args {incr ::x}}} -} 1a2b3c4d5e -test regexp-27.4 {regsub -command} -body { - regsub -command {.x.} {abcxdef} error -} -returnCodes error -result cxd -test regexp-27.5 {regsub -command} { - regsub -command {(.)(.)} {abcdef} {list ,} -} {, ab a bcdef} -test regexp-27.6 {regsub -command} { - regsub -command -all {(.)(.)} {abcdef} {list ,} -} {, ab a b, cd c d, ef e f} -test regexp-27.7 {regsub -command representation smash} { - set ::s {123=456 789} - regsub -command -all {\d+} $::s {apply {n { - expr {[llength $::s] + $n} - }}} -} {125=458 791} -test regexp-27.8 {regsub -command representation smash} { - set ::t {apply {n { - expr {[llength [lindex $::t 1 1 1]] + $n} - }}} - regsub -command -all {\d+} "123=456 789" $::t -} {131=464 797} -test regexp-27.9 {regsub -command memory leak testing} memory { - set ::s "123=456 789" - set ::t {apply {n { - expr {[llength [lindex $::t 1 1 1]] + [llength $::s] + $n} - }}} - memtest { - regsub -command -all {\d+} $::s $::t - } -} 0 -test regexp-27.10 {regsub -command error cases} -returnCodes error -body { - regsub -command . abc "def \{ghi" -} -result {unmatched open brace in list} -test regexp-27.11 {regsub -command error cases} -returnCodes error -body { - regsub -command . abc {} -} -result {command prefix must be a list of at least one element} -test regexp-27.12 {regsub -command representation smash} { - set s {list (.+)} - regsub -command $s {list list} $s -} {(.+) {list list} list} # cleanup ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: Index: tests/regexpComp.test ================================================================== --- tests/regexpComp.test +++ tests/regexpComp.test @@ -9,22 +9,22 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } # Procedure to evaluate a script within a proc, to test compilation # functionality proc evalInProc { script } { proc testProc {} $script set status [catch { - testProc + testProc } result] rename testProc {} return $result #return [list $status $result] } @@ -585,11 +585,11 @@ } {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}} test regexpComp-11.5 {regsub errors} { evalInProc { list [catch {regsub -gorp a b c} msg] $msg } -} {1 {bad option "-gorp": must be -all, -command, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}} +} {1 {bad option "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}} test regexpComp-11.6 {regsub errors} { evalInProc { list [catch {regsub -nocase a( b c d} msg] $msg } } {1 {couldn't compile regular expression pattern: parentheses () not balanced}} @@ -605,11 +605,11 @@ list [catch {regsub -start bogus pattern string rep var} msg] $msg } } {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}} # This test crashes on the Mac unless you increase the Stack Space to about 1 -# Meg. This is probably bigger than most users want... +# Meg. This is probably bigger than most users want... # 8.2.3 regexp reduced stack space requirements, but this should be # tested again test regexpComp-12.1 {Tcl_RegExpExec: large number of subexpressions} {macCrash} { evalInProc { list [regexp (.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.) abcdefghijklmnopqrstuvwxyz all a b c d e f g h i j k l m n o p q r s t u v w x y z] $all $a $b $c $d $e $f $g $h $i $j $k $l $m $n $o $p $q $r $s $t $u $v $w $x $y $z @@ -792,14 +792,14 @@ } "\0a\0hel\0a\0lo\0a\0 14" test regexpComp-20.1 {regsub shared object shimmering} { evalInProc { # Bug #461322 - set a abcdefghijklmnopqurstuvwxyz - set b $a - set c abcdefghijklmnopqurstuvwxyz0123456789 - regsub $a $c $b d + set a abcdefghijklmnopqurstuvwxyz + set b $a + set c abcdefghijklmnopqurstuvwxyz0123456789 + regsub $a $c $b d list $d [string length $d] [string bytelength $d] } } [list abcdefghijklmnopqurstuvwxyz0123456789 37 37] test regexpComp-20.2 {regsub shared object shimmering with -about} { evalInProc { Index: tests/registry.test ================================================================== --- tests/registry.test +++ tests/registry.test @@ -8,20 +8,20 @@ # auto_path or the registry package must have been loaded already. # # Copyright (c) 1997 by Sun Microsystems, Inc. All rights reserved. # Copyright (c) 1998-1999 by Scriptics Corporation. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } testConstraint reg 0 if {[testConstraint win]} { if {![catch { ::tcltest::loadTestedCommands - set ::regver [package require registry 1.3.3] + set ::regver [package require registry 1.3.5] }]} { testConstraint reg 1 } } @@ -31,11 +31,11 @@ && [string match "English*" [testlocale all ""]] }] test registry-1.0 {check if we are testing the right dll} {win reg} { set ::regver -} {1.3.3} +} {1.3.5} 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/remote.tcl ================================================================== --- tests/remote.tcl +++ tests/remote.tcl @@ -89,12 +89,12 @@ } } if {![info exists serverPort]} { for {set i 0} {$i < $argc} {incr i} { if {[string compare -port [lindex $argv $i]] == 0} { - if {$i < [expr $argc - 1]} { - set serverPort [lindex $argv [expr $i + 1]] + if {$i < $argc - 1} { + set serverPort [lindex $argv [expr {$i + 1}]] } break } } } @@ -108,12 +108,12 @@ } } if {![info exists serverAddress]} { for {set i 0} {$i < $argc} {incr i} { if {[string compare -address [lindex $argv $i]] == 0} { - if {$i < [expr $argc - 1]} { - set serverAddress [lindex $argv [expr $i + 1]] + if {$i < $argc - 1} { + set serverAddress [lindex $argv [expr {$i + 1}]] } break } } } Index: tests/rename.test ================================================================== --- tests/rename.test +++ tests/rename.test @@ -9,12 +9,12 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] Index: tests/resolver.test ================================================================== --- tests/resolver.test +++ tests/resolver.test @@ -8,12 +8,12 @@ # Copyright (c) 2011 Stefan Sobernig # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -if {"::tcltest" in [namespace children]} { +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -201,11 +201,11 @@ # on a context differently, whereas the cmd literal sharing assumed that the # namespace containing the literal solely determines the resolved cmd (and is # resolver-agnostic). # # In order to make the test cases for the per-interpreter cmd literal pool -# reproducable and to minimize interactions between test cases, we use a slave +# reproducable and to minimize interactions between test cases, we use a child # interpreter per test-case. # # # Testing resolver in namespace-based context "ctx1" # Index: tests/result.test ================================================================== --- tests/result.test +++ tests/result.test @@ -8,12 +8,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] # Some tests require the testsaveresult command @@ -29,11 +31,11 @@ test result-1.2 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult append {set x 42} 0 } {append result} test result-1.3 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult dynamic {set x 42} 0 -} {dynamic result freed} +} {dynamic result notCalled present} test result-1.4 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult object {set x 42} 0 } {object result same} test result-1.5 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult small {set x 42} 1 @@ -41,11 +43,11 @@ test result-1.6 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult append {set x 42} 1 } {42} test result-1.7 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult dynamic {set x 42} 1 -} {42 freed} +} {42 called missing} test result-1.8 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult object {set x 42} 1 } {42 different} # Tcl_RestoreInterpResult is mostly tested by the previous tests except ADDED tests/safe-stock.test Index: tests/safe-stock.test ================================================================== --- /dev/null +++ tests/safe-stock.test @@ -0,0 +1,109 @@ +# safe-stock.test -- +# +# This file contains tests for safe Tcl that were previously in the file +# safe.test, and use files and packages of stock Tcl 8.6 to perform the tests. +# These files may be changed or disappear in future revisions of Tcl, +# for example package http 1.0 will be removed from Tcl 8.7. +# +# The tests are replaced in safe.tcl with tests that use files provided in the +# tests directory. Test numbering is for comparison with similar tests in +# safe.test. +# +# Sourcing this file into tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# Copyright (c) 1995-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +foreach i [interp children] { + interp delete $i +} + +set SaveAutoPath $::auto_path +set ::auto_path [info library] +set TestsDir [file normalize [file dirname [info script]]] +set PathMapp [list $tcl_library TCLLIB $TestsDir TESTSDIR] + +proc mapList {map listIn} { + set listOut {} + foreach element $listIn { + lappend listOut [string map $map $element] + } + return $listOut +} + +# Force actual loading of the safe package because we use un-exported (and +# thus un-autoindexed) APIs in this test result arguments: +catch {safe::interpConfigure} + +# high level general test +test safe-stock-7.1 {tests that everything works at high level, uses http 2} -body { + set i [safe::interpCreate] + # no error shall occur: + # (because the default access_path shall include 1st level sub dirs so + # package require in a child works like in the parent) + set v [interp eval $i {package require http 2}] + # no error shall occur: + interp eval $i {http::config} + safe::interpDelete $i + set v +} -match glob -result 2.* +test safe-stock-7.2 {tests specific path and interpFind/AddToAccessPath, uses http1.0} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p1 + set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + # an error shall occur (http is not anymore in the secure 0-level + # provided deep path) + list $token1 $token2 -- \ + [catch {interp eval $i {package require http 1}} msg] $msg -- \ + $mappA -- [safe::interpDelete $i] +} -match glob -result {{$p(:0:)} {$p(:*:)} -- 1 {can't find package http 1} --\ + {TCLLIB */dummy/unixlike/test/path} -- {}} +test safe-stock-7.4 {tests specific path and positive search, uses http1.0} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p1 + set token2 [safe::interpAddToAccessPath $i [file join [info library] http1.0]] + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + # this time, unlike test safe-stock-7.2, http should be found + list $token1 $token2 -- \ + [catch {interp eval $i {package require http 1}} msg] $msg -- \ + $mappA -- [safe::interpDelete $i] +} -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.0 -- {TCLLIB *TCLLIB/http1.0} -- {}} + +# The following test checks whether the definition of tcl_endOfWord can be +# obtained from auto_loading. It was previously test "safe-5.1". +test safe-stock-9.8 {test auto-loading in safe interpreters, was test 5.1} -setup { + catch {safe::interpDelete a} + safe::interpCreate a +} -body { + interp eval a {tcl_endOfWord "" 0} +} -cleanup { + safe::interpDelete a +} -result -1 + +set ::auto_path $SaveAutoPath +unset SaveAutoPath TestsDir PathMapp +rename mapList {} + +# cleanup +::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# End: Index: tests/safe.test ================================================================== --- tests/safe.test +++ tests/safe.test @@ -1,32 +1,58 @@ # safe.test -- # # This file contains a collection of tests for safe Tcl, packages loading, and # using safe interpreters. Sourcing this file into tcl runs the tests and # generates output for errors. No output means no errors were found. +# +# The package http 1.0 is convenient for testing package loading, but will soon +# be removed. +# - Tests that use http are replaced here with tests that use example packages +# provided in subdirectory auto0 of the tests directory, which are independent +# of any changes made to the packages provided with Tcl itself. +# - These are tests 7.1 7.2 7.4 9.11 9.13 +# - Tests 5.* test the example packages themselves before they +# are used to test Safe Base interpreters. +# - Alternative tests using stock packages of Tcl 8.6 are in file +# safe-stock.test. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # 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.5- - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } -foreach i [interp slaves] { +foreach i [interp children] { interp delete $i } -set saveAutoPath $::auto_path +set SaveAutoPath $::auto_path set ::auto_path [info library] +set TestsDir [file normalize [file dirname [info script]]] +set PathMapp [list $tcl_library TCLLIB $TestsDir TESTSDIR] -# Force actual loading of the safe package because we use un exported (and +proc mapList {map listIn} { + set listOut {} + foreach element $listIn { + lappend listOut [string map $map $element] + } + return $listOut +} +proc mapAndSortList {map listIn} { + set listOut {} + foreach element $listIn { + lappend listOut [string map $map $element] + } + lsort $listOut +} + +# Force actual loading of the safe package because we use un-exported (and # thus un-autoindexed) APIs in this test result arguments: catch {safe::interpConfigure} # testing that nested and statics do what is advertised (we use a static # package - Tcltest - but it might be absent if we're in standard tclsh) @@ -64,19 +90,21 @@ } -body { interp create a a aliases } -cleanup { safe::interpDelete a + # This (ab)use of safe::interpDelete to delete non-Safe-Base interpreters + # is regrettable and should be removed at the next major revision. } -result "" test safe-2.3 {creating safe interpreters, should have no unexpected aliases} -setup { catch {safe::interpDelete a} } -body { interp create a -safe lsort [a aliases] } -cleanup { interp delete a -} -result {clock} +} -result {::tcl::mathfunc::max ::tcl::mathfunc::min clock} test safe-3.1 {calling safe::interpInit is safe} -setup { catch {safe::interpDelete a} interp create a -safe } -body { @@ -90,11 +118,11 @@ } -body { safe::interpCreate a lsort [a aliases] } -cleanup { safe::interpDelete a -} -result {::tcl::encoding::system ::tcl::file::dirname ::tcl::file::extension ::tcl::file::rootname ::tcl::file::tail ::tcl::info::nameofexecutable clock encoding exit file glob load source} +} -result {::tcl::file::atime ::tcl::file::attributes ::tcl::file::copy ::tcl::file::delete ::tcl::file::dirname ::tcl::file::executable ::tcl::file::exists ::tcl::file::extension ::tcl::file::isdirectory ::tcl::file::isfile ::tcl::file::link ::tcl::file::lstat ::tcl::file::mkdir ::tcl::file::mtime ::tcl::file::nativename ::tcl::file::normalize ::tcl::file::owned ::tcl::file::readable ::tcl::file::readlink ::tcl::file::rename ::tcl::file::rootname ::tcl::file::size ::tcl::file::stat ::tcl::file::tail ::tcl::file::tempfile ::tcl::file::type ::tcl::file::volumes ::tcl::file::writable ::tcl::info::nameofexecutable clock encoding exit glob load source} test safe-3.3 {calling safe::interpCreate on trusted interp} -setup { catch {safe::interpDelete a} } -body { safe::interpCreate a interp eval a {source [file join $tcl_library init.tcl]} @@ -113,17 +141,21 @@ test safe-4.1 {safe::interpDelete} -setup { catch {safe::interpDelete a} } -body { interp create a safe::interpDelete a + # This (ab)use of safe::interpDelete to delete non-Safe-Base interpreters + # is regrettable and should be removed at the next major revision. } -result "" test safe-4.2 {safe::interpDelete, indirectly} -setup { catch {safe::interpDelete a} } -body { interp create a a alias exit safe::interpDelete a a eval exit + # This (ab)use of safe::interpDelete to delete non-Safe-Base interpreters + # is regrettable and should be removed at the next major revision. } -result "" test safe-4.5 {safe::interpDelete} -setup { catch {safe::interpDelete a} } -body { safe::interpCreate a @@ -136,21 +168,122 @@ } -body { safe::interpCreate a a eval exit } -result "" -# The following test checks whether the definition of tcl_endOfWord can be -# obtained from auto_loading. - -test safe-5.1 {test auto-loading in safe interpreters} -setup { - catch {safe::interpDelete a} - safe::interpCreate a -} -body { - interp eval a {tcl_endOfWord "" 0} -} -cleanup { - safe::interpDelete a -} -result -1 +# The old test "safe-5.1" has been moved to "safe-stock-9.8". +# A replacement test using example files is "safe-9.8". +# Tests 5.* test the example files before using them to test safe interpreters. + +test safe-5.1 {example tclIndex commands, test in parent interpreter} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $TestsDir auto0 auto1] [file join $TestsDir auto0 auto2] +} -body { + # Try to load the commands. + set code3 [catch report1 msg3] + set code4 [catch report2 msg4] + list $code3 $msg3 $code4 $msg4 +} -cleanup { + catch {rename report1 {}} + catch {rename report2 {}} + set ::auto_path $tmpAutoPath + auto_reset +} -match glob -result {0 ok1 0 ok2} +test safe-5.2 {example tclIndex commands, negative test in parent interpreter} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $TestsDir auto0] +} -body { + # Try to load the commands. + set code3 [catch report1 msg3] + set code4 [catch report2 msg4] + list $code3 $msg3 $code4 $msg4 +} -cleanup { + catch {rename report1 {}} + catch {rename report2 {}} + set ::auto_path $tmpAutoPath + auto_reset +} -match glob -result {1 {invalid command name "report1"} 1 {invalid command name "report2"}} +test safe-5.3 {example pkgIndex.tcl packages, test in parent interpreter, child directories} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $TestsDir auto0] +} -body { + # Try to load the packages and run a command from each one. + set code3 [catch {package require SafeTestPackage1} msg3] + set code4 [catch {package require SafeTestPackage2} msg4] + set code5 [catch HeresPackage1 msg5] + set code6 [catch HeresPackage2 msg6] + list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6 +} -cleanup { + set ::auto_path $tmpAutoPath + catch {package forget SafeTestPackage1} + catch {package forget SafeTestPackage2} + catch {rename HeresPackage1 {}} + catch {rename HeresPackage2 {}} +} -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} +test safe-5.4 {example pkgIndex.tcl packages, test in parent interpreter, main directories} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2] +} -body { + # Try to load the packages and run a command from each one. + set code3 [catch {package require SafeTestPackage1} msg3] + set code4 [catch {package require SafeTestPackage2} msg4] + set code5 [catch HeresPackage1 msg5] + set code6 [catch HeresPackage2 msg6] + list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6 +} -cleanup { + set ::auto_path $tmpAutoPath + catch {package forget SafeTestPackage1} + catch {package forget SafeTestPackage2} + catch {rename HeresPackage1 {}} + catch {rename HeresPackage2 {}} +} -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} +test safe-5.5 {example modules packages, test in parent interpreter, replace path} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + # Try to load the modules and run a command from each one. + set code0 [catch {package require test0} msg0] + set code1 [catch {package require mod1::test1} msg1] + set code2 [catch {package require mod2::test2} msg2] + set out0 [test0::try0] + set out1 [mod1::test1::try1] + set out2 [mod2::test2::try2] + list $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + catch {package forget test0} + catch {package forget mod1::test1} + catch {package forget mod2::test2} + catch {namespace delete ::test0} + catch {namespace delete ::mod1} +} -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} +test safe-5.6 {example modules packages, test in parent interpreter, append to path} -setup { + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + # Try to load the modules and run a command from each one. + set code0 [catch {package require test0} msg0] + set code1 [catch {package require mod1::test1} msg1] + set code2 [catch {package require mod2::test2} msg2] + set out0 [test0::try0] + set out1 [mod1::test1::try1] + set out2 [mod2::test2::try2] + list $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + catch {package forget test0} + catch {package forget mod1::test1} + catch {package forget mod2::test2} + catch {namespace delete ::test0} + catch {namespace delete ::mod1} +} -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} # test safe interps 'information leak' proc SafeEval {script} { # Helper procedure that ensures the safe interp is cleaned up even if # there is a failure in the script. @@ -174,63 +307,125 @@ } set r [lsearch -all -inline -not -exact $r "threaded"] lsort $r } {byteOrder engine pathSeparator platform pointerSize wordSize} +rename SafeEval {} # More test should be added to check that hostname, nameofexecutable, aren't # leaking infos, but they still do... # high level general test -test safe-7.1 {tests that everything works at high level} -body { +# Use example packages not http1.0 etc +test safe-7.1 {tests that everything works at high level} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $TestsDir auto0] set i [safe::interpCreate] + set ::auto_path $tmpAutoPath +} -body { # no error shall occur: # (because the default access_path shall include 1st level sub dirs so - # package require in a slave works like in the master) - set v [interp eval $i {package require http 2}] + # package require in a child works like in the parent) + set v [interp eval $i {package require SafeTestPackage1}] # no error shall occur: - interp eval $i {http::config} - safe::interpDelete $i + interp eval $i {HeresPackage1} set v -} -match glob -result 2.* -test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -body { +} -cleanup { + safe::interpDelete $i +} -match glob -result 1.2.3 +test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -setup { +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p* (not p1 if parent has a module path) + set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] + # should add as p* (not p2 if parent has a module path) + set token3 [safe::interpAddToAccessPath $i [file join $TestsDir auto0]] + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + # an error shall occur (SafeTestPackage1 is not anymore in the secure 0-level + # provided deep path) + list $token1 $token2 $token3 -- \ + [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg -- \ + $mappA -- [safe::interpDelete $i] +} -cleanup { +} -match glob -result {{$p(:0:)} {$p(:*:)} {$p(:*:)} --\ + 1 {can't find package SafeTestPackage1} --\ + {TCLLIB */dummy/unixlike/test/path TESTSDIR/auto0} -- {}} +test safe-7.3 {check that safe subinterpreters work} { + set g [interp children] + if {$g ne {}} { + append g { -- residue of an earlier test} + } + set h [info vars ::safe::S*] + if {$h ne {}} { + append h { -- residue of an earlier test} + } + set i [safe::interpCreate] + set j [safe::interpCreate [list $i x]] + list $g $h [interp eval $j {join {o k} ""}] [safe::interpDelete $i] \ + [interp exists $j] [info vars ::safe::S*] +} {{} {} ok {} 0 {}} +test safe-7.3.1 {check that safe subinterpreters work with namespace names} -setup { +} -body { + set g [interp children] + if {$g ne {}} { + append g { -- residue of an earlier test} + } + set h [info vars ::safe::S*] + if {$h ne {}} { + append h { -- residue of an earlier test} + } + set i [safe::interpCreate foo::bar] + set j [safe::interpCreate [list $i hello::world]] + list $g $h [interp eval $j {join {o k} ""}] \ + [foo::bar eval {hello::world eval {join {o k} ""}}] \ + [safe::interpDelete $i] \ + [interp exists $j] [info vars ::safe::S*] +} -match glob -result {{} {} ok ok {} 0 {}} +test safe-7.4 {tests specific path and positive search} -setup { +} -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] # should not add anything (p0) set token1 [safe::interpAddToAccessPath $i [info library]] - # should add as p1 - set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] - # an error shall occur (http is not anymore in the secure 0-level - # provided deep path) - list $token1 $token2 \ - [catch {interp eval $i {package require http 1}} msg] $msg \ - [safe::interpConfigure $i]\ - [safe::interpDelete $i] -} -match glob -result "{\$p(:0:)} {\$p(:*:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library */dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}" -test safe-7.3 {check that safe subinterpreters work} { - set i [safe::interpCreate] - set j [safe::interpCreate [list $i x]] - list [interp eval $j {join {o k} ""}] [safe::interpDelete $i] [interp exists $j] -} {ok {} 0} + # should add as p* (not p1 if parent has a module path) + set token2 [safe::interpAddToAccessPath $i [file join $TestsDir auto0 auto1]] + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + # this time, unlike test safe-7.2, SafeTestPackage1 should be found + list $token1 $token2 -- \ + [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg -- \ + $mappA -- [safe::interpDelete $i] + # Note that the glob match elides directories (those from the module path) + # other than the first and last in the access path. +} -cleanup { +} -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.2.3 --\ + {TCLLIB * TESTSDIR/auto0/auto1} -- {}} # test source control on file name -set i "a" test safe-8.1 {safe source control on file} -setup { + set i "a" catch {safe::interpDelete $i} } -body { safe::interpCreate $i $i eval {source} } -returnCodes error -cleanup { safe::interpDelete $i + unset i } -result {wrong # args: should be "source ?-encoding E? fileName"} test safe-8.2 {safe source control on file} -setup { + set i "a" catch {safe::interpDelete $i} } -body { safe::interpCreate $i $i eval {source a b c d e} } -returnCodes error -cleanup { safe::interpDelete $i + unset i } -result {wrong # args: should be "source ?-encoding E? fileName"} test safe-8.3 {safe source control on file} -setup { + set i "a" catch {safe::interpDelete $i} set log {} proc safe-test-log {str} {lappend ::log $str} set prevlog [safe::setLogCmd] } -body { @@ -237,14 +432,16 @@ safe::interpCreate $i safe::setLogCmd safe-test-log list [catch {$i eval {source .}} msg] $msg $log } -cleanup { safe::setLogCmd $prevlog - unset log safe::interpDelete $i + rename safe-test-log {} + unset i log } -result {1 {permission denied} {{ERROR for slave a : ".": is a directory}}} test safe-8.4 {safe source control on file} -setup { + set i "a" catch {safe::interpDelete $i} set log {} proc safe-test-log {str} {global log; lappend log $str} set prevlog [safe::setLogCmd] } -body { @@ -251,14 +448,16 @@ safe::interpCreate $i safe::setLogCmd safe-test-log list [catch {$i eval {source /abc/def}} msg] $msg $log } -cleanup { safe::setLogCmd $prevlog - unset log safe::interpDelete $i + rename safe-test-log {} + unset i log } -result {1 {permission denied} {{ERROR for slave a : "/abc/def": not in access_path}}} test safe-8.5 {safe source control on file} -setup { + set i "a" catch {safe::interpDelete $i} set log {} proc safe-test-log {str} {global log; lappend log $str} set prevlog [safe::setLogCmd] } -body { @@ -269,14 +468,16 @@ list [catch { $i eval {source [file join [info lib] blah]} } msg] $msg $log } -cleanup { safe::setLogCmd $prevlog - unset log safe::interpDelete $i + rename safe-test-log {} + unset i log } -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah]:no such file or directory"]] test safe-8.6 {safe source control on file} -setup { + set i "a" catch {safe::interpDelete $i} set log {} proc safe-test-log {str} {global log; lappend log $str} set prevlog [safe::setLogCmd] } -body { @@ -285,14 +486,16 @@ list [catch { $i eval {source [file join [info lib] blah.tcl]} } msg] $msg $log } -cleanup { safe::setLogCmd $prevlog - unset log safe::interpDelete $i + rename safe-test-log {} + unset i log } -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah.tcl]:no such file or directory"]] test safe-8.7 {safe source control on file} -setup { + set i "a" catch {safe::interpDelete $i} set log {} proc safe-test-log {str} {global log; lappend log $str} set prevlog [safe::setLogCmd] } -body { @@ -303,29 +506,33 @@ list [catch { $i eval {source [file join [info lib] xxxxxxxxxxx.tcl]} } msg] $msg $log } -cleanup { safe::setLogCmd $prevlog - unset log safe::interpDelete $i + rename safe-test-log {} + unset i log } -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] xxxxxxxxxxx.tcl]:no such file or directory"]] test safe-8.8 {safe source forbids -rsrc} emptyTest { # Disabled this test. It was only useful for long unsupported # Mac OS 9 systems. [Bug 860a9f1945] } {} test safe-8.9 {safe source and return} -setup { + set i "a" set returnScript [makeFile {return "ok"} return.tcl] catch {safe::interpDelete $i} } -body { safe::interpCreate $i set token [safe::interpAddToAccessPath $i [file dirname $returnScript]] $i eval [list source $token/[file tail $returnScript]] } -cleanup { catch {safe::interpDelete $i} removeFile $returnScript + unset i } -result ok test safe-8.10 {safe source and return} -setup { + set i "a" set returnScript [makeFile {return -level 2 "ok"} return.tcl] catch {safe::interpDelete $i} } -body { safe::interpCreate $i set token [safe::interpAddToAccessPath $i [file dirname $returnScript]] @@ -334,14 +541,15 @@ error boom }} $token/[file tail $returnScript]] } -cleanup { catch {safe::interpDelete $i} removeFile $returnScript + unset i } -result ok -set i "a" test safe-9.1 {safe interps' deleteHook} -setup { + set i "a" catch {safe::interpDelete $i} set res {} } -body { proc testDelHook {args} { global res @@ -350,12 +558,16 @@ # mark that we've been here (successfully) set res $args } safe::interpCreate $i -deleteHook "testDelHook arg1 arg2" list [interp eval $i exit] $res +} -cleanup { + catch {rename testDelHook {}} + unset i res } -result {{} {arg1 arg2 a}} test safe-9.2 {safe interps' error in deleteHook} -setup { + set i "a" catch {safe::interpDelete $i} set res {} set log {} proc safe-test-log {str} {lappend ::log $str} set prevlog [safe::setLogCmd] @@ -372,11 +584,13 @@ safe::interpCreate $i -deleteHook "testDelHook arg1 arg2" safe::setLogCmd safe-test-log list [safe::interpDelete $i] $res $log } -cleanup { safe::setLogCmd $prevlog - unset log + catch {rename testDelHook {}} + rename safe-test-log {} + unset i log res } -result {{} {arg1 arg2 a} {{NOTICE for slave a : About to delete} {ERROR for slave a : Delete hook error (being catched)} {NOTICE for slave a : Deleted}}} test safe-9.3 {dual specification of statics} -returnCodes error -body { safe::interpCreate -stat true -nostat } -result {conflicting values given for -statics and -noStatics} test safe-9.4 {dual specification of statics} { @@ -401,29 +615,568 @@ [safe::interpConfigure $i -DEL]\ [safe::interpConfigure $i -accessPath /blah -statics 1 safe::interpConfigure $i]\ [safe::interpConfigure $i -deleteHook toto -nosta -nested 0 safe::interpConfigure $i] -} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}} {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}} {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}} {-accessPath * -statics 0 -nested 0 -deleteHook toto}} +} -cleanup { + safe::interpDelete $i +} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}}\ + {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}}\ + {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}}\ + {-accessPath * -statics 0 -nested 0 -deleteHook toto}} +test safe-9.7 {interpConfigure widget like behaviour (demystified)} -body { + # this test shall work, believed equivalent to 9.6 + set i [safe::interpCreate \ + -noStatics \ + -nestedLoadOk \ + -deleteHook {foo bar}] + safe::interpConfigure $i -accessPath /foo/bar + set a [safe::interpConfigure $i] + set b [safe::interpConfigure $i -aCCess] + set c [safe::interpConfigure $i -nested] + set d [safe::interpConfigure $i -statics] + set e [safe::interpConfigure $i -DEL] + safe::interpConfigure $i -accessPath /blah -statics 1 + set f [safe::interpConfigure $i] + safe::interpConfigure $i -deleteHook toto -nosta -nested 0 + set g [safe::interpConfigure $i] + + list $a $b $c $d $e $f $g +} -cleanup { + safe::interpDelete $i + unset -nocomplain a b c d e f g i +} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}}\ + {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}}\ + {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}}\ + {-accessPath * -statics 0 -nested 0 -deleteHook toto}} +test safe-9.8 {test autoloading commands indexed in tclIndex files} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load and run the commands. + set code1 [catch {interp eval $i {report1}} msg1] + set code2 [catch {interp eval $i {report2}} msg2] + + list $path1 $path2 -- $code1 $msg1 $code2 $msg2 -- $mappA +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:1:)} {$p(:2:)} -- 0 ok1 0 ok2 --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*}} +test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset)} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load auto_load data. + interp eval $i {catch nonExistentCommand} + + # Load and run the commands. + # This guarantees the test will pass even if the tokens are swapped. + set code1 [catch {interp eval $i {report1}} msg1] + set code2 [catch {interp eval $i {report2}} msg2] + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto2] \ + [file join $TestsDir auto0 auto1]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Run the commands. + set code3 [catch {interp eval $i {report1}} msg3] + set code4 [catch {interp eval $i {report2}} msg4] + + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 ok1 0 ok2 --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ + {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*}} +test safe-9.10 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset)} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load auto_load data. + interp eval $i {catch nonExistentCommand} + + # Do not load the commands. With the tokens swapped, the test + # will pass only if the Safe Base has called auto_reset. + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto2] \ + [file join $TestsDir auto0 auto1]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load and run the commands. + set code3 [catch {interp eval $i {report1}} msg3] + set code4 [catch {interp eval $i {report2}} msg4] + + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\ + 0 ok1 0 ok2 --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ + {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*}} +test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement} -setup { +} -body { + # For complete correspondence to safe-9.10opt, include auto0 in access path. + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0] \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Rearrange access path. Swap tokens {$p(:2:)} and {$p(:3:)}. + # This would have no effect because the records in Pkg of these directories + # were from access as children of {$p(:1:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0] \ + [file join $TestsDir auto0 auto2] \ + [file join $TestsDir auto0 auto1]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Try to load the packages and run a command from each one. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3] + set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4] + set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5] + set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] + + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \ + $mappA -- $mappB -- $code5 $msg5 $code6 $msg6 +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:2:)} {$p(:3:)} -- {$p(:3:)} {$p(:2:)} -- 0 1.2.3 0 2.3.4 --\ + {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ + {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\ + 0 OK1 0 OK2} +test safe-9.12 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, 9.10 without path auto0} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto2] \ + [file join $TestsDir auto0 auto1]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Try to load the packages and run a command from each one. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3] + set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4] + set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5] + set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] + + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \ + $mappA -- $mappB -- \ + $code5 $msg5 $code6 $msg6 +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\ + 0 1.2.3 0 2.3.4 --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ + {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\ + 0 OK1 0 OK2} +test safe-9.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Limit access path. Remove tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library] + + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set code4 [catch {::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]} path4] + set code5 [catch {::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]} path5] + + # Try to load the packages. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3] + set code6 [catch {interp eval $i {package require SafeTestPackage2}} msg6] + + list $path1 $path2 -- $code4 $path4 -- $code5 $path5 -- $code3 $code6 -- \ + $mappA -- $mappB +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:1:)} {$p(:2:)} -- 1 {* not found in access path} --\ + 1 {* not found in access path} -- 1 1 --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} -- {TCLLIB*}} +test safe-9.20 {check module loading} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\ + TESTSDIR/auto0/modules/mod2} -- res0 res1 res2} +# - The command safe::InterpSetConfig adds the parent's [tcl::tm::list] in +# tokenized form to the child's access path, and then adds all the +# descendants, discovered recursively by using glob. +# - The order of the directories in the list returned by glob is system-dependent, +# and therefore this is true also for (a) the order of token assignment to +# descendants of the [tcl::tm::list] roots; and (b) the order of those same +# directories in the access path. Both those things must be sorted before +# comparing with expected results. The test is therefore not totally strict, +# but will notice missing or surplus directories. +test safe-9.21 {interpConfigure change the access path; check module loading; stale data case 1} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] + # Inspect. + set confB [safe::interpConfigure $i] + set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Load pkg data. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ + $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\ + TESTSDIR/auto0/modules/mod2} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\ + TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\ + res0 res1 res2} +# See comments on lsort after test safe-9.20. +test safe-9.22 {interpConfigure change the access path; check module loading; stale data case 0} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] + # Inspect. + set confB [safe::interpConfigure $i] + set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ + $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\ + TESTSDIR/auto0/modules/mod2} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\ + TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\ + res0 res1 res2} +# See comments on lsort after test safe-9.20. +test safe-9.23 {interpConfigure change the access path; check module loading; stale data case 3} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Force the interpreter to acquire pkg data which will soon become stale. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] + # Inspect. + set confB [safe::interpConfigure $i] + set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Refresh stale pkg data. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ + $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\ + TESTSDIR/auto0/modules/mod2} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\ + TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\ + res0 res1 res2} +# See comments on lsort after test safe-9.20. +test safe-9.24 {interpConfigure change the access path; check module loading; stale data case 2 (worst case)} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Force the interpreter to acquire pkg data which will soon become stale. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] + # Inspect. + set confB [safe::interpConfigure $i] + set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ + $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\ + TESTSDIR/auto0/modules/mod2} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\ + TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\ + res0 res1 res2} +# See comments on lsort after test safe-9.20. catch {teststaticpkg Safepkg1 0 0} test safe-10.1 {testing statics loading} -constraints TcltestPackage -setup { set i [safe::interpCreate] } -body { interp eval $i {load {} Safepkg1} } -returnCodes error -cleanup { safe::interpDelete $i -} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} +} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} test safe-10.1.1 {testing statics loading} -constraints TcltestPackage -setup { set i [safe::interpCreate] } -body { catch {interp eval $i {load {} Safepkg1}} m o dict get $o -errorinfo } -returnCodes ok -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure +} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure invoked from within "load {} Safepkg1" invoked from within "interp eval $i {load {} Safepkg1}"} test safe-10.2 {testing statics loading / -nostatics} -constraints TcltestPackage -body { @@ -442,19 +1195,19 @@ test safe-10.4 {testing nested statics loading / -nestedloadok} -constraints TcltestPackage -body { set i [safe::interpCreate -nestedloadok] interp eval $i {interp create x; load {} Safepkg1 x} } -returnCodes error -cleanup { safe::interpDelete $i -} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} +} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} test safe-10.4.1 {testing nested statics loading / -nestedloadok} -constraints TcltestPackage -body { set i [safe::interpCreate -nestedloadok] catch {interp eval $i {interp create x; load {} Safepkg1 x}} m o dict get $o -errorinfo } -returnCodes ok -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure +} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure invoked from within "load {} Safepkg1 x" invoked from within "interp eval $i {interp create x; load {} Safepkg1 x}"} @@ -462,18 +1215,18 @@ set i [safe::interpCreate] } -body { interp eval $i encoding } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding subcommand ?arg ...?"} +} -result {wrong # args: should be "encoding option ?arg ...?"} test safe-11.1a {testing safe encoding} -setup { set i [safe::interpCreate] } -body { interp eval $i encoding foobar } -returnCodes error -cleanup { safe::interpDelete $i -} -match glob -result {unknown or ambiguous subcommand "foobar": must be *} +} -match glob -result {bad option "foobar": must be *} test safe-11.2 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { interp eval $i encoding system cp775 } -returnCodes error -cleanup { @@ -524,10 +1277,12 @@ safe::interpDelete $i } -result {wrong # args: should be "encoding convertfrom ?encoding? data" while executing "encoding convertfrom" invoked from within +"::interp invokehidden interp* encoding convertfrom" + invoked from within "encoding convertfrom" invoked from within "interp eval $i encoding convertfrom"} test safe-11.8 {testing safe encoding} -setup { set i [safe::interpCreate] @@ -545,10 +1300,12 @@ unset -nocomplain m o safe::interpDelete $i } -result {wrong # args: should be "encoding convertto ?encoding? data" while executing "encoding convertto" + invoked from within +"::interp invokehidden interp* encoding convertto" invoked from within "encoding convertto" invoked from within "interp eval $i encoding convertto"} @@ -606,10 +1363,19 @@ upvar 1 testdir testdir testdir2 testdir2 testfile testfile set testdir [makeDirectory deletethisdir] set testdir2 [makeDirectory deletemetoo $testdir] set testfile [makeFile {} $filename $testdir2] } +proc buildEnvironment2 {filename} { + upvar 1 testdir testdir testdir2 testdir2 testfile testfile + upvar 1 testdir3 testdir3 testfile2 testfile2 + set testdir [makeDirectory deletethisdir] + set testdir2 [makeDirectory deletemetoo $testdir] + set testfile [makeFile {} $filename $testdir2] + set testdir3 [makeDirectory deleteme $testdir] + set testfile2 [makeFile {} $filename $testdir3] +} #### New tests for Safe base glob, with patches @ Bug 2964715 test safe-13.1 {glob is restricted [Bug 2964715]} -setup { set i [safe::interpCreate] } -body { $i eval glob * @@ -677,25 +1443,37 @@ glob -nocomplain -directory $testdir [file join deletemetoo *.tm] } -cleanup { safe::interpDelete $i removeDirectory $testdir } -result {} -test safe-13.7 {mimic the glob call by tclPkgUnknown which gives a deliberate error in a safe interpreter [Bug 2964715]} -setup { +test safe-13.7 {mimic the glob call by tclPkgUnknown in a safe interpreter [Bug 2964715]} -setup { set i [safe::interpCreate] buildEnvironment pkgIndex.tcl } -body { set safeTD [::safe::interpAddToAccessPath $i $testdir] ::safe::interpAddToAccessPath $i $testdir2 - string map [list $safeTD EXPECTED] [$i eval [list \ + mapList [list $safeTD EXPECTED] [$i eval [list \ + glob -directory $safeTD -join * pkgIndex.tcl]] +} -cleanup { + safe::interpDelete $i + removeDirectory $testdir +} -result {EXPECTED/deletemetoo/pkgIndex.tcl} +test safe-13.7.1 {mimic the glob call by tclPkgUnknown in a safe interpreter with multiple subdirectories} -setup { + set i [safe::interpCreate] + buildEnvironment2 pkgIndex.tcl +} -body { + set safeTD [::safe::interpAddToAccessPath $i $testdir] + ::safe::interpAddToAccessPath $i $testdir2 + ::safe::interpAddToAccessPath $i $testdir3 + mapAndSortList [list $safeTD EXPECTED] [$i eval [list \ glob -directory $safeTD -join * pkgIndex.tcl]] } -cleanup { safe::interpDelete $i removeDirectory $testdir -} -result {{EXPECTED/deletemetoo/pkgIndex.tcl}} -# Note the extra {} around the result above; that's *expected* because of the -# format of virtual path roots. -test safe-13.8 {mimic the glob call by tclPkgUnknown without the deliberate error that is specific to pkgIndex.tcl [Bug 2964715]} -setup { +} -result {EXPECTED/deleteme/pkgIndex.tcl EXPECTED/deletemetoo/pkgIndex.tcl} +# See comments on lsort after test safe-9.20. +test safe-13.8 {mimic the glob call by tclPkgUnknown without the special treatment that is specific to pkgIndex.tcl [Bug 2964715]} -setup { set i [safe::interpCreate] buildEnvironment notIndex.tcl } -body { set safeTD [::safe::interpAddToAccessPath $i $testdir] ::safe::interpAddToAccessPath $i $testdir2 @@ -729,13 +1507,14 @@ } -cleanup { safe::interpDelete $i removeDirectory $testdir } -result {} rename buildEnvironment {} +rename buildEnvironment2 {} #### Test for the module path -test safe-14.1 {Check that module path is the same as in the master interpreter [Bug 2964715]} -setup { +test safe-14.1 {Check that module path is the same as in the parent interpreter [Bug 2964715]} -setup { set i [safe::interpCreate] } -body { set tm {} foreach token [$i eval ::tcl::tm::path list] { lappend tm [dict get [set ::safe::S${i}(access_path,map)] $token] @@ -793,19 +1572,21 @@ list [file join [file dirname $d] [file tail $d]] } } -cleanup { safe::interpDelete $i set env(HOME) $savedHOME + unset savedHOME } -result {./~} test safe-16.2 {Bug 3529949: defang ~user in paths} -setup { set i [safe::interpCreate] set user $tcl_platform(user) } -body { string map [list $user USER] [$i eval \ "file join \[file dirname ~$user\] \[file tail ~$user\]"] } -cleanup { safe::interpDelete $i + unset user } -result {./~USER} test safe-16.3 {Bug 3529949: defang ~ in globs} -setup { set syntheticHOME [makeDirectory foo] makeFile {} bar $syntheticHOME set savedHOME $env(HOME) @@ -816,23 +1597,73 @@ $i eval {glob -nocomplain ~/*} } -cleanup { safe::interpDelete $i set env(HOME) $savedHOME removeDirectory $syntheticHOME + unset savedHOME syntheticHOME } -result {} test safe-16.4 {Bug 3529949: defang ~user in globs} -setup { set i [safe::interpCreate] } -body { ::safe::interpAddToAccessPath $i $~$tcl_platform(user) $i eval [list glob -nocomplain ~$tcl_platform(user)/*] } -cleanup { safe::interpDelete $i } -result {} +test safe-16.5 {Bug 3529949: defang ~ in paths used by AliasGlob (1)} -setup { + set savedHOME $env(HOME) + set env(HOME) /foo/bar + set i [safe::interpCreate] +} -body { + $i eval { + set d [format %c 126] + file join {$p(:0:)} $d + } +} -cleanup { + safe::interpDelete $i + set env(HOME) $savedHOME + unset savedHOME +} -result {~} +test safe-16.6 {Bug 3529949: defang ~ in paths used by AliasGlob (2)} -setup { + set savedHOME $env(HOME) + set env(HOME) /foo/bar + set i [safe::interpCreate] +} -body { + $i eval { + set d [format %c 126] + file join {$p(:0:)/foo/bar} $d + } +} -cleanup { + safe::interpDelete $i + set env(HOME) $savedHOME + unset savedHOME +} -result {~} +test safe-16.7 {Bug 3529949: defang ~user in paths used by AliasGlob (1)} -setup { + set i [safe::interpCreate] + set user $tcl_platform(user) +} -body { + string map [list $user USER] [$i eval [list file join {$p(:0:)} ~$user]] +} -cleanup { + safe::interpDelete $i + unset user +} -result {~USER} +test safe-16.8 {Bug 3529949: defang ~user in paths used by AliasGlob (2)} -setup { + set i [safe::interpCreate] + set user $tcl_platform(user) +} -body { + string map [list $user USER] [$i eval [list file join {$p(:0:)/foo/bar} ~$user]] +} -cleanup { + safe::interpDelete $i + unset user +} -result {~USER} -set ::auto_path $saveAutoPath # cleanup +set ::auto_path $SaveAutoPath +unset SaveAutoPath TestsDir PathMapp +rename mapList {} +rename mapAndSortList {} ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: Index: tests/scan.test ================================================================== --- tests/scan.test +++ tests/scan.test @@ -10,19 +10,22 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } # procedure that returns the range of integers proc int_range {} { - set MAX_INT [expr {[format %u -2]/2}] - set MIN_INT [expr { ~ $MAX_INT }] + for { set MIN_INT 1 } { int($MIN_INT) > 0 } {} { + set MIN_INT [expr { $MIN_INT << 1 }] + } + set MIN_INT [expr {int($MIN_INT)}] + set MAX_INT [expr { ~ $MIN_INT }] return [list $MIN_INT $MAX_INT] } # Big test for correct ordering of data in [expr] @@ -80,11 +83,12 @@ } } } testConstraint ieeeFloatingPoint [testIEEE] -testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}] +testConstraint wideIs64bit \ + [expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}] test scan-1.1 {BuildCharSet, CharInSet} { list [scan foo {%[^o]} x] $x } {1 f} test scan-1.2 {BuildCharSet, CharInSet} { @@ -551,12 +555,12 @@ } -returnCodes 1 -result {unsigned bignum scans are invalid} test scan-5.19 {bigint scanning invalid} -setup { set a {}; } -body { list [scan "207698809136909011942886895" \ - %llu a] $a -} -result {1 207698809136909011942886895} + %llu a] $a +} -returnCodes 1 -result {unsigned bignum scans are invalid} test scan-6.1 {floating-point scanning} -setup { set a {}; set b {}; set c {}; set d {} } -body { list [scan "2.1 -3.0e8 .99962 a" "%f%g%e%f" a b c d] $a $b $c $d Index: tests/security.test ================================================================== --- tests/security.test +++ tests/security.test @@ -9,11 +9,11 @@ # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } # If this proc becomes invoked, then there is a bug Index: tests/set-old.test ================================================================== --- tests/set-old.test +++ tests/set-old.test @@ -11,12 +11,12 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } proc ignore args {} @@ -338,11 +338,11 @@ } {1 {"x" isn't an array}} test set-old-8.6 {array command} { catch {unset a} set a(22) 3 list [catch {array gorp a} msg] $msg -} {1 {unknown or ambiguous subcommand "gorp": must be anymore, default, donesearch, exists, for, get, names, nextelement, set, size, startsearch, statistics, or unset}} +} {1 {unknown or ambiguous subcommand "gorp": must be anymore, donesearch, exists, get, names, nextelement, set, size, startsearch, statistics, or unset}} test set-old-8.7 {array command, anymore option} { catch {unset a} list [catch {array anymore a x} msg] $msg } {1 {"a" isn't an array}} test set-old-8.8 {array command, anymore option, array doesn't exist yet but has compiler-allocated procedure slot} { @@ -698,11 +698,11 @@ test set-old-9.1 {ids for array enumeration} { catch {unset a} set a(a) 1 list [array star a] [array star a] [array done a s-1-a; array star a] \ - [array done a s-2-a; array do a s-3-a; array start a] + [array done a s-2-a; array d a s-3-a; array start a] } {s-1-a s-2-a s-3-a s-1-a} test set-old-9.2 {array enumeration} { catch {unset a} set a(a) 1 set a(b) 1 Index: tests/set.test ================================================================== --- tests/set.test +++ tests/set.test @@ -8,12 +8,12 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] Index: tests/socket.test ================================================================== --- tests/socket.test +++ tests/socket.test @@ -58,19 +58,20 @@ # server will be performed; otherwise, it will attempt to start the remote # server (via exec) on platforms that support this, on the local host, # listening at port 2048. If all fails, a message is printed and the tests # using the remote server are not performed. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] -if {[expr {[info exists ::env(TRAVIS_OSX_IMAGE)] && [string match xcode* $::env(TRAVIS_OSX_IMAGE)]}]} { +# A bad interaction between socket creation, macOS, and unattended CI +# environments make this whole file impractical to run; too many weird hangs. +if {[info exists ::env(MAC_CI)]} { return } # Some tests require the Thread package or exec command testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] @@ -92,18 +93,10 @@ # try random port: set port [expr {int(rand()*16383+49152)}] } return $port } - -# Check if testsocket testflags is available -testConstraint testsocket_testflags [expr {![catch { - set h [socket -async localhost [randport]] - testsocket testflags $h 0 - close $h - }]}] - # Test the latency of tcp connections over the loopback interface. Some OSes # (e.g. NetBSD) seem to use the Nagle algorithm and delayed ACKs, so it takes # up to 200ms for a packet sent to localhost to arrive. We're measuring this # here, so that OSes that don't have this problem can run the tests at full @@ -244,11 +237,11 @@ } # Some tests are run only if we are doing testing against a remote server. testConstraint doTestsWithRemoteServer $doTestsWithRemoteServer if {!$doTestsWithRemoteServer} { - if {[string first s $::tcltest::verbose] != -1} { + if {[string first s $::tcltest::verbose] >= 0} { puts "Skipping tests with remote server. See tests/socket.test for" puts "information on how to run remote server." puts "Reason for not doing remote tests: $noRemoteTestReason" } } @@ -287,73 +280,58 @@ proc getPort sock { lindex [fconfigure $sock -sockname] 2 } +# Some tests in this file are known to hang *occasionally* on OSX; stop the +# worst offenders. +testConstraint notOSX [expr {$::tcl_platform(os) ne "Darwin"}] # ---------------------------------------------------------------------- test socket_$af-1.1 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -server } -returnCodes error -result {no argument given for -server option} test socket_$af-1.2 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -server foo -} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr boolean? ?-reuseport boolean? ?-myaddr addr? port"} +} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"} test socket_$af-1.3 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -myaddr } -returnCodes error -result {no argument given for -myaddr option} test socket_$af-1.4 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -myaddr $localhost -} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr boolean? ?-reuseport boolean? ?-myaddr addr? port"} +} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"} test socket_$af-1.5 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -myport } -returnCodes error -result {no argument given for -myport option} test socket_$af-1.6 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -myport xxxx } -returnCodes error -result {expected integer but got "xxxx"} test socket_$af-1.7 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -myport 2522 -} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr boolean? ?-reuseport boolean? ?-myaddr addr? port"} +} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"} test socket_$af-1.8 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -froboz -} -returnCodes error -result {bad option "-froboz": must be -async, -myaddr, -myport, -reuseaddr, -reuseport, or -server} +} -returnCodes error -result {bad option "-froboz": must be -async, -myaddr, -myport, or -server} test socket_$af-1.9 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -server foo -myport 2521 3333 } -returnCodes error -result {option -myport is not valid for servers} test socket_$af-1.10 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket host 2528 -junk -} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr boolean? ?-reuseport boolean? ?-myaddr addr? port"} +} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"} test socket_$af-1.11 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -server callback 2520 -- -} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr boolean? ?-reuseport boolean? ?-myaddr addr? port"} +} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"} test socket_$af-1.12 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket foo badport } -returnCodes error -result {expected integer but got "badport"} test socket_$af-1.13 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -async -server } -returnCodes error -result {cannot set -async option for server sockets} test socket_$af-1.14 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -server foo -async } -returnCodes error -result {cannot set -async option for server sockets} -test socket_$af-1.15 {arg parsing for socket command} -constraints [list socket supported_$af] -body { - socket -reuseaddr yes 4242 -} -returnCodes error -result {options -reuseaddr and -reuseport are only valid for servers} -test socket_$af-1.16 {arg parsing for socket command} -constraints [list socket supported_$af] -body { - socket -reuseaddr no 4242 -} -returnCodes error -result {options -reuseaddr and -reuseport are only valid for servers} -test socket_$af-1.17 {arg parsing for socket command} -constraints [list socket supported_$af] -body { - socket -reuseaddr -} -returnCodes error -result {no argument given for -reuseaddr option} -test socket_$af-1.18 {arg parsing for socket command} -constraints [list socket supported_$af] -body { - socket -reuseport yes 4242 -} -returnCodes error -result {options -reuseaddr and -reuseport are only valid for servers} -test socket_$af-1.19 {arg parsing for socket command} -constraints [list socket supported_$af] -body { - socket -reuseport no 4242 -} -returnCodes error -result {options -reuseaddr and -reuseport are only valid for servers} -test socket_$af-1.20 {arg parsing for socket command} -constraints [list socket supported_$af] -body { - socket -reuseport -} -returnCodes error -result {no argument given for -reuseport option} set path(script) [makeFile {} script] test socket_$af-2.1 {tcp connection} -constraints [list socket supported_$af stdio] -setup { file delete $path(script) @@ -929,11 +907,11 @@ if {![catch {socket -server dodo 0x1} msg]} { close $msg return {htons problem, should be disallowed, are you running as SU?} } return {couldn't open socket: not owner} -} -constraints [list socket supported_$af unix notRoot] -result {couldn't open socket: not owner} +} -constraints [list socket supported_$af unix notRoot notOSX] -result {couldn't open socket: not owner} test socket_$af-5.2 {byte order problems, socket numbers, htons} -body { if {![catch {socket -server dodo 0x10000} msg]} { close $msg return {port resolution problem, should be disallowed} } @@ -943,11 +921,11 @@ if {![catch {socket -server dodo 21} msg]} { close $msg return {htons problem, should be disallowed, are you running as SU?} } return {couldn't open socket: not owner} -} -constraints [list socket supported_$af unix notRoot] -result {couldn't open socket: not owner} +} -constraints [list socket supported_$af unix notRoot notOSX] -result {couldn't open socket: not owner} test socket_$af-6.1 {accept callback error} -constraints [list socket supported_$af stdio] -setup { proc myHandler {msg options} { variable x $msg } @@ -961,11 +939,11 @@ gets stdin port socket $localhost $port } close $f set f [open "|[list [interpreter] $path(script)]" r+] - proc accept {s a p} {expr 10 / 0} + proc accept {s a p} {expr {10 / 0}} set s [socket -server accept -myaddr $localhost 0] puts $f [lindex [fconfigure $s -sockname] 2] close $f set timer [after 10000 "set x timed_out"] vwait x @@ -1081,11 +1059,11 @@ close $s1 } -result {1 3} test socket_$af-7.5 {testing socket specific options} -setup { set timer [after 10000 "set x timed_out"] set l "" -} -constraints [list socket supported_$af unixOrPc] -body { +} -constraints [list socket supported_$af unixOrWin] -body { set s [socket -server accept 0] proc accept {s a p} { global x set x [fconfigure $s -sockname] close $s @@ -1842,10 +1820,109 @@ } close $s thread::release $serverthread append result " " [llength [thread::names]] } -result {hello 1} -constraints [list socket supported_$af thread] + +proc transf_test {{testmode transfer} {maxIter 1000} {maxTime 10000}} { + try { + set ::count 0 + set ::testmode $testmode + set port 0 + set srvsock {} + # if binding on port 0 is not possible (system related, blocked on ISPs etc): + if {[catch {close [socket -async $::localhost $port]}]} { + # simplest server on random port (immediatelly closing a connect): + set port [randport] + set srvsock [socket -server {apply {{ch args} {close $ch}}} -myaddr $::localhost $port] + # socket on windows has some issues yet (e. g. bug [b6d0d8cc2c]), so we simply decrease iteration count (to 1/4): + if {$::tcl_platform(platform) eq "windows" && $maxIter > 50} { + set ::count [expr {$maxIter / 4 * 3 - 1}]; # bypass 3/4 iterations + } + } + tcltest::DebugPuts 1 "== test \[$::localhost\]:$port $testmode ==" + set ::parent [thread::id] + # helper thread creating async connection and initiating transfer (detach) to parent: + set ::helper [thread::create] + thread::send -async $::helper [list \ + lassign [list $::parent $::localhost $port $testmode] \ + ::parent ::localhost ::port ::testmode + ] + thread::send -async $::helper { + set ::helper [thread::id] + proc iteration {args} { + set fd [socket -async $::localhost $::port] + if {"helper-writable" in $::testmode} {;# to test both sides during connect + fileevent $fd writable [list apply {{fd} { + if {[thread::id] ne $::helper} { + thread::send -async $::parent {set ::count "ERROR: invalid thread, $::helper is expecting"} + close $fd + return + } + }} $fd] + };# + thread::detach $fd + thread::send -async $::parent [list transf_parent $fd {*}$args] + } + iteration first + } + # parent proc commiting transfer attempt (attach) and checking acquire was successful: + proc transf_parent {fd args} { + tcltest::DebugPuts 1 "** trma / $::count ** $args **" + thread::attach $fd + if {"parent-close" in $::testmode} {;# to test close during connect + set ::count $::count + close $fd + return + };# + fileevent $fd writable [list apply {{fd} { + if {[thread::id] ne $::parent} { + thread::send -async $::parent {set ::count "ERROR: invalid thread, $::parent is expecting"} + close $fd + return + } + set ::count $::count + close $fd + }} $fd] + } + # repeat maxIter times (up to maxTime ms as timeout): + set tout [after $maxTime {set ::count "TIMEOUT"}] + while 1 { + vwait ::count + if {![string is integer $::count]} { + # if timeout just skip (test was successful until now): + if {$::count eq "TIMEOUT"} {::tcltest::Skip "timing issue"} + break + } + if {[incr ::count] >= $maxIter} break + tcltest::DebugPuts 1 "** iter / $::count **" + thread::send -async $::helper [list iteration nr $::count] + } + update + set ::count + } finally { + catch {after cancel $tout} + if {$srvsock ne {}} {close $srvsock} + if {[info exists ::helper]} {thread::release -wait $::helper} + tcltest::DebugPuts 1 "== stop / $::count ==" + unset -nocomplain ::count ::testmode ::parent ::helper + } +} +test socket_$af-13.2.tr1 {Testing socket transfer between threads during async connect} -body { + transf_test {transfer} 1000 +} -result 1000 -constraints [list socket supported_$af thread] +test socket_$af-13.2.tr2 {Testing socket transfer between threads during async connect} -body { + transf_test {transfer helper-writable} 100 +} -result 100 -constraints [list socket supported_$af thread] +test socket_$af-13.2.cl1 {Testing socket transfer between threads during async connect} -body { + transf_test {parent-close} 100 +} -result 100 -constraints [list socket supported_$af thread] +test socket_$af-13.2.cl2 {Testing socket transfer between threads during async connect} -body { + transf_test {parent-close helper-writable} 100 +} -result 100 -constraints [list socket supported_$af thread] +catch {rename transf_parent {}} +rename transf_test {} # ---------------------------------------------------------------------- removeFile script1 removeFile script2 @@ -1856,579 +1933,526 @@ } catch {close $commandSocket} catch {close $remoteProcChan} } unset ::tcl::unsupported::socketAF -test socket-14.0.0 {[socket -async] when server only listens on IPv4} \ - -constraints {socket supported_inet localhost_v4} \ - -setup { - proc accept {s a p} { - global x - puts $s bye - close $s - set x ok - } - set server [socket -server accept -myaddr 127.0.0.1 0] - set port [lindex [fconfigure $server -sockname] 2] - } -body { - set client [socket -async localhost $port] - set after [after $latency {set x [fconfigure $client -error]}] - vwait x - set x - } -cleanup { - after cancel $after - close $server - close $client - unset x - } -result ok -test socket-14.0.1 {[socket -async] when server only listens on IPv6} \ - -constraints {socket supported_inet6 localhost_v6} \ - -setup { - proc accept {s a p} { - global x - puts $s bye - close $s - set x ok - } - set server [socket -server accept -myaddr ::1 0] - set port [lindex [fconfigure $server -sockname] 2] - } -body { - set client [socket -async localhost $port] - set after [after $latency {set x [fconfigure $client -error]}] - vwait x - set x - } -cleanup { - after cancel $after - close $server - close $client - unset x - } -result ok -test socket-14.1 {[socket -async] fileevent while still connecting} \ - -constraints {socket} \ - -setup { - proc accept {s a p} { - global x - puts $s bye - close $s - lappend x ok - } - set server [socket -server accept -myaddr localhost 0] - set port [lindex [fconfigure $server -sockname] 2] - set x "" - } -body { - set client [socket -async localhost $port] - fileevent $client writable { - lappend x [fconfigure $client -error] - fileevent $client writable {} - } - set after [after $latency {lappend x timeout}] - while {[llength $x] < 2 && "timeout" ni $x} { - vwait x - } - lsort $x; # we only want to see both events, the order doesn't matter - } -cleanup { - after cancel $after - close $server - close $client - unset x - } -result {{} ok} -test socket-14.2 {[socket -async] fileevent connection refused} \ - -constraints {socket} \ - -body { - set client [socket -async localhost [randport]] - fileevent $client writable {set x ok} - set after [after $latency {set x timeout}] - vwait x - after cancel $after - lappend x [fconfigure $client -error] - } -cleanup { - after cancel $after - close $client - unset x after client - } -result {ok {connection refused}} -test socket-14.3 {[socket -async] when server only listens on IPv6} \ - -constraints {socket supported_inet6 localhost_v6} \ - -setup { - proc accept {s a p} { - global x - puts $s bye - close $s - set x ok - } - set server [socket -server accept -myaddr ::1 0] - set port [lindex [fconfigure $server -sockname] 2] - } -body { - set client [socket -async localhost $port] - set after [after $latency {set x [fconfigure $client -error]}] - vwait x - set x - } -cleanup { - after cancel $after - close $server - close $client - unset x - } -result ok -test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \ - -constraints {socket} \ - -setup { - proc accept {s a p} { - puts $s bye - close $s - } - set server [socket -server accept -myaddr localhost 0] - set port [lindex [fconfigure $server -sockname] 2] - set x "" - } -body { - set client [socket -async localhost $port] - fileevent $client writable { - lappend x [fconfigure $client -error] - fileevent $client writable {} - } - fileevent $client readable {lappend x [gets $client]} - set after [after $latency {lappend x timeout}] - while {[llength $x] < 2 && "timeout" ni $x} { - vwait x - } - lsort $x - } -cleanup { - after cancel $after - close $client - close $server - unset x - } -result {{} bye} +test socket-14.0.0 {[socket -async] when server only listens on IPv4} -setup { + proc accept {s a p} { + global x + puts $s bye + close $s + set x ok + } + set server [socket -server accept -myaddr 127.0.0.1 0] + set port [lindex [fconfigure $server -sockname] 2] +} -constraints {socket supported_inet localhost_v4} -body { + set client [socket -async localhost $port] + set after [after $latency {set x [fconfigure $client -error]}] + vwait x + set x +} -cleanup { + catch {after cancel $after} + catch {close $server} + catch {close $client} + unset -nocomplain x +} -result ok +test socket-14.0.1 {[socket -async] when server only listens on IPv6} -setup { + proc accept {s a p} { + global x + puts $s bye + close $s + set x ok + } + set server [socket -server accept -myaddr ::1 0] + set port [lindex [fconfigure $server -sockname] 2] +} -constraints {socket supported_inet6 localhost_v6} -body { + set client [socket -async localhost $port] + set after [after $latency {set x [fconfigure $client -error]}] + vwait x + set x +} -cleanup { + catch {after cancel $after} + catch {close $server} + catch {close $client} + unset -nocomplain x +} -result ok +test socket-14.1 {[socket -async] fileevent while still connecting} -setup { + proc accept {s a p} { + global x + puts $s bye + close $s + lappend x ok + } + set server [socket -server accept -myaddr localhost 0] + set port [lindex [fconfigure $server -sockname] 2] + set x "" +} -constraints socket -body { + set client [socket -async localhost $port] + fileevent $client writable { + lappend x [fconfigure $client -error] + fileevent $client writable {} + } + set after [after $latency {lappend x timeout}] + while {[llength $x] < 2 && "timeout" ni $x} { + vwait x + } + lsort $x; # we only want to see both events, the order doesn't matter +} -cleanup { + catch {after cancel $after} + catch {close $server} + catch {close $client} + unset -nocomplain x +} -result {{} ok} +test socket-14.2 {[socket -async] fileevent connection refused} -setup { + set after [after $latency set x timeout] +} -body { + set client [socket -async localhost [randport]] + fileevent $client writable {set x ok} + vwait x + lappend x [fconfigure $client -error] +} -constraints socket -cleanup { + catch {after cancel $after} + catch {close $client} + unset -nocomplain x after client +} -result {ok {connection refused}} +test socket-14.3 {[socket -async] when server only listens on IPv6} -setup { + proc accept {s a p} { + global x + puts $s bye + close $s + set x ok + } + set server [socket -server accept -myaddr ::1 0] + set port [lindex [fconfigure $server -sockname] 2] +} -constraints {socket supported_inet6 localhost_v6} -body { + set client [socket -async localhost $port] + set after [after $latency {set x [fconfigure $client -error]}] + vwait x + set x +} -cleanup { + catch {after cancel $after} + catch {close $server} + catch {close $client} + unset -nocomplain x +} -result ok +test socket-14.4 {[socket -async] and both, readdable and writable fileevents} -setup { + proc accept {s a p} { + puts $s bye + close $s + } + set server [socket -server accept -myaddr localhost 0] + set port [lindex [fconfigure $server -sockname] 2] + set x "" +} -constraints socket -body { + set client [socket -async localhost $port] + fileevent $client writable { + lappend x [fconfigure $client -error] + fileevent $client writable {} + } + fileevent $client readable {lappend x [gets $client]} + set after [after $latency {lappend x timeout}] + while {[llength $x] < 2 && "timeout" ni $x} { + vwait x + } + lsort $x +} -cleanup { + catch {after cancel $after} + catch {close $client} + catch {close $server} + unset -nocomplain x +} -result {{} bye} # FIXME: we should also have an IPv6 counterpart of this -test socket-14.5 {[socket -async] which fails before any connect() can be made} \ - -constraints {socket supported_inet} \ - -body { - # address from rfc5737 - socket -async -myaddr 192.0.2.42 127.0.0.1 [randport] - } \ - -returnCodes 1 \ +test socket-14.5 {[socket -async] which fails before any connect() can be made} -body { + # address from rfc5737 + socket -async -myaddr 192.0.2.42 127.0.0.1 [randport] +} -constraints {socket supported_inet notOSX} -returnCodes 1 \ -result {couldn't open socket: cannot assign requested address} -test socket-14.6.0 {[socket -async] with no event loop and server listening on IPv4} \ - -constraints {socket supported_inet localhost_v4} \ - -setup { - proc accept {s a p} { - global x - puts $s bye - close $s - set x ok - } - set server [socket -server accept -myaddr 127.0.0.1 0] - set port [lindex [fconfigure $server -sockname] 2] - set x "" - } \ - -body { - set client [socket -async localhost $port] - for {set i 0} {$i < 50} {incr i } { - update - if {$x ne ""} { - lappend x [gets $client] - break - } - after 100 - } - set x - } \ - -cleanup { - close $server - close $client - unset x - } \ - -result {ok bye} -test socket-14.6.1 {[socket -async] with no event loop and server listening on IPv6} \ - -constraints {socket supported_inet6 localhost_v6} \ - -setup { - proc accept {s a p} { - global x - puts $s bye - close $s - set x ok - } - set server [socket -server accept -myaddr ::1 0] - set port [lindex [fconfigure $server -sockname] 2] - set x "" - } \ - -body { - set client [socket -async localhost $port] - for {set i 0} {$i < 50} {incr i } { - update - if {$x ne ""} { - lappend x [gets $client] - break - } - after 100 - } - set x - } \ - -cleanup { - close $server - close $client - unset x - } \ - -result {ok bye} -test socket-14.7.0 {pending [socket -async] and blocking [gets], server is IPv4} \ - -constraints {socket supported_inet localhost_v4} \ - -setup { - makeFile { - fileevent stdin readable exit - set server [socket -server accept -myaddr 127.0.0.1 0] - proc accept {s h p} {puts $s ok; close $s; set ::x 1} - puts [lindex [fconfigure $server -sockname] 2] - flush stdout - vwait x - } script - set fd [open |[list [interpreter] script] RDWR] - set port [gets $fd] - } -body { - set sock [socket -async localhost $port] - list [fconfigure $sock -error] [gets $sock] [fconfigure $sock -error] - } -cleanup { - close $fd - close $sock - removeFile script - } -result {{} ok {}} -test socket-14.7.1 {pending [socket -async] and blocking [gets], server is IPv6} \ - -constraints {socket supported_inet6 localhost_v6} \ - -setup { - makeFile { - fileevent stdin readable exit - set server [socket -server accept -myaddr ::1 0] - proc accept {s h p} {puts $s ok; close $s; set ::x 1} - puts [lindex [fconfigure $server -sockname] 2] - flush stdout - vwait x - } script - set fd [open |[list [interpreter] script] RDWR] - set port [gets $fd] - } -body { - set sock [socket -async localhost $port] - list [fconfigure $sock -error] [gets $sock] [fconfigure $sock -error] - } -cleanup { - close $fd - close $sock - removeFile script - } -result {{} ok {}} -test socket-14.7.2 {pending [socket -async] and blocking [gets], no listener} \ - -constraints {socket} \ - -body { - set sock [socket -async localhost [randport]] - catch {gets $sock} x - list $x [fconfigure $sock -error] [fconfigure $sock -error] - } -cleanup { - close $sock - } -match glob -result {{error reading "sock*": socket is not connected} {connection refused} {}} -test socket-14.8.0 {pending [socket -async] and nonblocking [gets], server is IPv4} \ - -constraints {socket supported_inet localhost_v4} \ - -setup { - makeFile { - fileevent stdin readable exit - set server [socket -server accept -myaddr 127.0.0.1 0] - proc accept {s h p} {puts $s ok; close $s; set ::x 1} - puts [lindex [fconfigure $server -sockname] 2] - flush stdout - vwait x - } script - set fd [open |[list [interpreter] script] RDWR] - set port [gets $fd] - } -body { - set sock [socket -async localhost $port] - fconfigure $sock -blocking 0 - for {set i 0} {$i < 50} {incr i } { - if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break - after 200 - } - set x - } -cleanup { - close $fd - close $sock - removeFile script - } -result {ok} -test socket-14.8.1 {pending [socket -async] and nonblocking [gets], server is IPv6} \ - -constraints {socket supported_inet6 localhost_v6} \ - -setup { - makeFile { - fileevent stdin readable exit - set server [socket -server accept -myaddr ::1 0] - proc accept {s h p} {puts $s ok; close $s; set ::x 1} - puts [lindex [fconfigure $server -sockname] 2] - flush stdout - vwait x - } script - set fd [open |[list [interpreter] script] RDWR] - set port [gets $fd] - } -body { - set sock [socket -async localhost $port] - fconfigure $sock -blocking 0 - for {set i 0} {$i < 50} {incr i } { - if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break - after 200 - } - set x - } -cleanup { - close $fd - close $sock - removeFile script - } -result {ok} -test socket-14.8.2 {pending [socket -async] and nonblocking [gets], no listener} \ - -constraints {socket} \ - -body { - set sock [socket -async localhost [randport]] - fconfigure $sock -blocking 0 - for {set i 0} {$i < 50} {incr i } { - if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break - after 200 - } - list $x [fconfigure $sock -error] [fconfigure $sock -error] - } -cleanup { - close $sock - } -match glob -result {{error reading "sock*": socket is not connected} {connection refused} {}} -test socket-14.9.0 {pending [socket -async] and blocking [puts], server is IPv4} \ - -constraints {socket supported_inet localhost_v4} \ - -setup { - makeFile { - fileevent stdin readable exit - set server [socket -server accept -myaddr 127.0.0.1 0] - proc accept {s h p} {set ::x $s} - puts [lindex [fconfigure $server -sockname] 2] - flush stdout - vwait x - puts [gets $x] - } script - set fd [open |[list [interpreter] script] RDWR] - set port [gets $fd] - } -body { - set sock [socket -async localhost $port] - puts $sock ok - flush $sock - list [fconfigure $sock -error] [gets $fd] - } -cleanup { - close $fd - close $sock - removeFile script - } -result {{} ok} -test socket-14.9.1 {pending [socket -async] and blocking [puts], server is IPv6} \ - -constraints {socket supported_inet6 localhost_v6} \ - -setup { - makeFile { - fileevent stdin readable exit - set server [socket -server accept -myaddr ::1 0] - proc accept {s h p} {set ::x $s} - puts [lindex [fconfigure $server -sockname] 2] - flush stdout - vwait x - puts [gets $x] - } script - set fd [open |[list [interpreter] script] RDWR] - set port [gets $fd] - } -body { - set sock [socket -async localhost $port] - puts $sock ok - flush $sock - list [fconfigure $sock -error] [gets $fd] - } -cleanup { - close $fd - close $sock - removeFile script - } -result {{} ok} -test socket-14.10.0 {pending [socket -async] and nonblocking [puts], server is IPv4} \ - -constraints {socket supported_inet localhost_v4} \ - -setup { - makeFile { - fileevent stdin readable exit - set server [socket -server accept -myaddr 127.0.0.1 0] - proc accept {s h p} {set ::x $s} - puts [lindex [fconfigure $server -sockname] 2] - flush stdout - vwait x - puts [gets $x] - } script - set fd [open |[list [interpreter] script] RDWR] - set port [gets $fd] - } -body { - set sock [socket -async localhost $port] - fconfigure $sock -blocking 0 - puts $sock ok - flush $sock - fileevent $fd readable {set x 1} - vwait x - list [fconfigure $sock -error] [gets $fd] - } -cleanup { - close $fd - close $sock - removeFile script - } -result {{} ok} -test socket-14.10.1 {pending [socket -async] and nonblocking [puts], server is IPv6} \ - -constraints {socket supported_inet6 localhost_v6} \ - -setup { - makeFile { - fileevent stdin readable exit - set server [socket -server accept -myaddr ::1 0] - proc accept {s h p} {set ::x $s} - puts [lindex [fconfigure $server -sockname] 2] - flush stdout - vwait x - puts [gets $x] - } script - set fd [open |[list [interpreter] script] RDWR] - set port [gets $fd] - } -body { - set sock [socket -async localhost $port] - fconfigure $sock -blocking 0 - puts $sock ok - flush $sock - fileevent $fd readable {set x 1} - vwait x - list [fconfigure $sock -error] [gets $fd] - } -cleanup { - close $fd - close $sock - removeFile script - } -result {{} ok} -test socket-14.11.0 {pending [socket -async] and nonblocking [puts], no listener, no flush} \ - -constraints {socket} \ - -body { - set sock [socket -async localhost [randport]] - fconfigure $sock -blocking 0 - puts $sock ok - fileevent $sock writable {set x 1} - vwait x - close $sock - } -cleanup { - catch {close $sock} - unset x - } -result {socket is not connected} -returnCodes 1 -test socket-14.11.1 {pending [socket -async] and nonblocking [puts], no listener, flush} \ - -constraints {socket testsocket_testflags} \ - -body { - set sock [socket -async localhost [randport]] - # Set the socket in async test mode. - # The async connect will not be continued on the following fconfigure - # and puts/flush. Thus, the connect will fail after them. - testsocket testflags $sock 1 - fconfigure $sock -blocking 0 - puts $sock ok - flush $sock - testsocket testflags $sock 0 - fileevent $sock writable {set x 1} - vwait x - close $sock - } -cleanup { - catch {close $sock} - catch {unset x} - } -result {socket is not connected} -returnCodes 1 -test socket-14.12 {[socket -async] background progress triggered by [fconfigure -error]} \ - -constraints {socket} \ - -body { - set s [socket -async localhost [randport]] - for {set i 0} {$i < 50} {incr i} { - set x [fconfigure $s -error] - if {$x != ""} break - after 200 - } - set x - } -cleanup { - close $s - unset x s - } -result {connection refused} - -test socket-14.13 {testing writable event when quick failure} \ - -constraints {socket win supported_inet} \ - -body { +test socket-14.6.0 {[socket -async] with no event loop and server listening on IPv4} -setup { + proc accept {s a p} { + global x + puts $s bye + close $s + set x ok + } + set server [socket -server accept -myaddr 127.0.0.1 0] + set port [lindex [fconfigure $server -sockname] 2] + set x "" +} -constraints {socket supported_inet localhost_v4} -body { + set client [socket -async localhost $port] + for {set i 0} {$i < 50} {incr i } { + update + if {$x ne ""} { + lappend x [gets $client] + break + } + after 100 + } + set x +} -cleanup { + catch {close $server} + catch {close $client} + unset -nocomplain x +} -result {ok bye} +test socket-14.6.1 {[socket -async] with no event loop and server listening on IPv6} -setup { + proc accept {s a p} { + global x + puts $s bye + close $s + set x ok + } + set server [socket -server accept -myaddr ::1 0] + set port [lindex [fconfigure $server -sockname] 2] + set x "" +} -constraints {socket supported_inet6 localhost_v6} -body { + set client [socket -async localhost $port] + for {set i 0} {$i < 50} {incr i } { + update + if {$x ne ""} { + lappend x [gets $client] + break + } + after 100 + } + set x +} -cleanup { + catch {close $server} + catch {close $client} + unset -nocomplain x +} -result {ok bye} +test socket-14.7.0 {pending [socket -async] and blocking [gets], server is IPv4} -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr 127.0.0.1 0] + proc accept {s h p} {puts $s ok; close $s; set ::x 1} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] +} -constraints {socket supported_inet localhost_v4 notOSX} -body { + set sock [socket -async localhost $port] + list [fconfigure $sock -error] [gets $sock] [fconfigure $sock -error] +} -cleanup { + catch {close $fd} + catch {close $sock} + removeFile script +} -result {{} ok {}} +test socket-14.7.1 {pending [socket -async] and blocking [gets], server is IPv6} -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr ::1 0] + proc accept {s h p} {puts $s ok; close $s; set ::x 1} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] +} -constraints {socket supported_inet6 localhost_v6 notOSX} -body { + set sock [socket -async localhost $port] + list [fconfigure $sock -error] [gets $sock] [fconfigure $sock -error] +} -cleanup { + catch {close $fd} + catch {close $sock} + removeFile script +} -result {{} ok {}} +test socket-14.7.2 {pending [socket -async] and blocking [gets], no listener} -setup { + set sock [socket -server error 0] + set unusedPort [lindex [fconfigure $sock -sockname] 2] + close $sock +} -body { + set sock [socket -async localhost $unusedPort] + catch {gets $sock} x + list $x [fconfigure $sock -error] [fconfigure $sock -error] +} -constraints {socket notOSX} -cleanup { + catch {close $sock} +} -match glob -result {{error reading "sock*": socket is not connected} {connection refused} {}} +test socket-14.8.0 {pending [socket -async] and nonblocking [gets], server is IPv4} -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr 127.0.0.1 0] + proc accept {s h p} {puts $s ok; close $s; set ::x 1} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] +} -constraints {socket supported_inet localhost_v4} -body { + set sock [socket -async localhost $port] + fconfigure $sock -blocking 0 + for {set i 0} {$i < 50} {incr i } { + if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break + after 200 + } + set x +} -cleanup { + catch {close $fd} + catch {close $sock} + removeFile script +} -result {ok} +test socket-14.8.1 {pending [socket -async] and nonblocking [gets], server is IPv6} -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr ::1 0] + proc accept {s h p} {puts $s ok; close $s; set ::x 1} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] +} -constraints {socket supported_inet6 localhost_v6} -body { + set sock [socket -async localhost $port] + fconfigure $sock -blocking 0 + for {set i 0} {$i < 50} {incr i } { + if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break + after 200 + } + set x +} -cleanup { + catch {close $fd} + catch {close $sock} + removeFile script +} -result {ok} +test socket-14.8.2 {pending [socket -async] and nonblocking [gets], no listener} -body { + set sock [socket -async localhost [randport]] + fconfigure $sock -blocking 0 + for {set i 0} {$i < 50} {incr i } { + if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break + after 200 + } + list $x [fconfigure $sock -error] [fconfigure $sock -error] +} -constraints socket -cleanup { + catch {close $sock} +} -match glob -result {{error reading "sock*": socket is not connected} {connection refused} {}} +test socket-14.9.0 {pending [socket -async] and blocking [puts], server is IPv4} -setup { + makeFile { + fileevent stdin readable exit + after 10000 exit + set server [socket -server accept -myaddr 127.0.0.1 0] + proc accept {s h p} {set ::x $s} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + puts [gets $x] + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] +} -constraints {socket supported_inet localhost_v4 notOSX} -body { + set sock [socket -async localhost $port] + puts $sock ok + flush $sock + list [fconfigure $sock -error] [gets $fd] +} -cleanup { + catch {close $fd} + catch {close $sock} + removeFile script +} -result {{} ok} +test socket-14.9.1 {pending [socket -async] and blocking [puts], server is IPv6} -setup { + makeFile { + fileevent stdin readable exit + after 10000 exit + set server [socket -server accept -myaddr ::1 0] + proc accept {s h p} {set ::x $s} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + puts [gets $x] + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] +} -constraints {socket supported_inet6 localhost_v6 notOSX} -body { + set sock [socket -async localhost $port] + puts $sock ok + flush $sock + list [fconfigure $sock -error] [gets $fd] +} -cleanup { + catch {close $fd} + catch {close $sock} + removeFile script +} -result {{} ok} +test socket-14.10.0 {pending [socket -async] and nonblocking [puts], server is IPv4} -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr 127.0.0.1 0] + proc accept {s h p} {set ::x $s} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + puts [gets $x] + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + set after [after $latency set x timeout] +} -constraints {socket supported_inet localhost_v4} -body { + set sock [socket -async localhost $port] + fconfigure $sock -blocking 0 + puts $sock ok + flush $sock + fileevent $fd readable {set x 1} + vwait x + list [fconfigure $sock -error] [gets $fd] +} -cleanup { + after cancel $after + catch {close $fd} + catch {close $sock} + removeFile script +} -result {{} ok} +test socket-14.10.1 {pending [socket -async] and nonblocking [puts], server is IPv6} -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr ::1 0] + proc accept {s h p} {set ::x $s} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + puts [gets $x] + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + set after [after $latency set x timeout] +} -constraints {socket supported_inet6 localhost_v6} -body { + set sock [socket -async localhost $port] + fconfigure $sock -blocking 0 + puts $sock ok + flush $sock + fileevent $fd readable {set x 1} + vwait x + list [fconfigure $sock -error] [gets $fd] +} -cleanup { + after cancel $after + catch {close $fd} + catch {close $sock} + removeFile script +} -result {{} ok} +test socket-14.11.0 {pending [socket -async] and nonblocking [puts], no listener, no flush} -setup { + set after [after $latency set x timeout] +} -body { + set sock [socket -async localhost [randport]] + fconfigure $sock -blocking 0 + puts $sock ok + fileevent $sock writable {set x 1} + vwait x + close $sock +} -constraints socket -cleanup { + after cancel $after + catch {close $sock} + unset -nocomplain x +} -result {socket is not connected} -returnCodes 1 +test socket-14.11.1 {pending [socket -async] and nonblocking [puts], no listener, flush} -setup { + set after [after $latency set x timeout] +} -body { + set sock [socket -async localhost [randport]] + fconfigure $sock -blocking 0 + puts $sock ok + flush $sock + fileevent $sock writable {set x 1} + vwait x + close $sock +} -constraints {socket nonPortable} -cleanup { + after cancel $timeout + catch {close $sock} + unset -nocomplain x +} -result {socket is not connected} -returnCodes 1 +test socket-14.12 {[socket -async] background progress triggered by [fconfigure -error]} -body { + set s [socket -async localhost [randport]] + for {set i 0} {$i < 50} {incr i} { + set x [fconfigure $s -error] + if {$x != ""} break + after 200 + } + set x +} -constraints socket -cleanup { + catch {close $s} + unset -nocomplain x s +} -result {connection refused} +test socket-14.13 {testing writable event when quick failure} -body { # Test for bug 336441ed59 where a quick background fail was ignored - + # # Test only for windows as socket -async 255.255.255.255 fails # directly on unix - + # # The following connect should fail very quickly - set a1 [after 2000 {set x timeout}] + set a1 [after $latency {set x timeout}] set s [socket -async 255.255.255.255 43434] fileevent $s writable {set x writable} vwait x set x -} -cleanup { +} -constraints {socket win supported_inet} -cleanup { catch {close $s} after cancel $a1 } -result writable - -test socket-14.14 {testing fileevent readable on failed async socket connect} \ - -constraints {socket} -body { +test socket-14.14 {testing fileevent readable on failed async socket connect} -body { # Test for bug 581937ab1e - - set a1 [after 5000 {set x timeout}] + set a1 [after $latency {set x timeout}] # This connect should fail set s [socket -async localhost [randport]] fileevent $s readable {set x readable} vwait x set x -} -cleanup { +} -constraints socket -cleanup { catch {close $s} after cancel $a1 } -result readable - -test socket-14.15 {blocking read on async socket should not trigger event handlers} \ - -constraints socket -body { - set s [socket -async localhost [randport]] - set x ok - fileevent $s writable {set x fail} - catch {read $s} - close $s - set x - } -result ok - -# v4 and v6 is required to prevent that the async connect does not terminate -# before the fconfigure command. There is always an additional ip to try. -test socket-14.16 {empty -peername while [socket -async] connecting} \ - -constraints {socket localhost_v4 localhost_v6} \ - -body { - set client [socket -async localhost [randport]] - fconfigure $client -peername - } -cleanup { - catch {close $client} - } -result {} - -# v4 and v6 is required to prevent that the async connect does not terminate -# before the fconfigure command. There is always an additional ip to try. -test socket-14.17 {empty -sockname while [socket -async] connecting} \ - -constraints {socket localhost_v4 localhost_v6} \ - -body { - set client [socket -async localhost [randport]] - fconfigure $client -sockname - } -cleanup { - catch {close $client} - } -result {} - +test socket-14.15 {blocking read on async socket should not trigger event handlers} -setup { + set subprocess [open "|[list [interpreter]]" r+] + fconfigure $subprocess -blocking 0 -buffering none +} -constraints socket -body { + puts $subprocess { + set s [socket -async localhost [randport]] + set x ok + fileevent $s writable {set x fail} + catch {read $s} + close $s + puts $x + exit + } + set after [after $latency set x timeout] + fileevent $subprocess readable [list gets $subprocess x] + vwait x + return $x +} -cleanup { + catch {after cancel $after} + if {![testConstraint win]} { + catch {exec kill [pid $subprocess]} + } + catch {close $subprocess} + unset -nocomplain x +} -result ok +# v4 and v6 is required to prevent that the async connect does not terminate +# before the fconfigure command. There is always an additional ip to try. +test socket-14.16 {empty -peername while [socket -async] connecting} -body { + set client [socket -async localhost [randport]] + fconfigure $client -peername +} -constraints {socket localhost_v4 localhost_v6 notOSX} -cleanup { + catch {close $client} +} -result {} +# v4 and v6 is required to prevent that the async connect does not terminate +# before the fconfigure command. There is always an additional ip to try. +test socket-14.17 {empty -sockname while [socket -async] connecting} -body { + set client [socket -async localhost [randport]] + fconfigure $client -sockname +} -constraints {socket localhost_v4 localhost_v6 notOSX} -cleanup { + catch {close $client} +} -result {} # test for bug c6ed4acfd8: running async socket connect with other connect # established will block tcl as it goes in an infinite loop in vwait -test socket-14.18 {bug c6ed4acfd8: running async socket connect made other connect block} \ - -constraints {socket} \ - -body { - proc accept {channel address port} {} - set port [randport] - set ssock [socket -server accept $port] - set csock1 [socket -async localhost [randport]] - set csock2 [socket localhost $port] - after 1000 {set done ok} - vwait done -} -cleanup { - catch {close $ssock} - catch {close $csock1} - catch {close $csock2} - } -result {} - -test socket-14.19 {tip 456 -- introduce the -reuseport option} \ - -constraints {socket} \ - -body { - proc accept {channel address port} {} - set port [randport] - set ssock1 [socket -server accept -reuseport yes $port] - set ssock2 [socket -server accept -reuseport yes $port] - return ok -} -cleanup { - catch {close $ssock1} - catch {close $ssock2} - } -result ok +test socket-14.18 {bug c6ed4acfd8: running async socket connect made other connect block} -body { + proc accept {channel address port} {} + set port [randport] + set ssock [socket -server accept $port] + set csock1 [socket -async localhost [randport]] + set csock2 [socket localhost $port] + after 1000 {set done ok} + vwait done +} -constraints {socket notOSX} -cleanup { + catch {close $ssock} + catch {close $csock1} + catch {close $csock2} +} -result {} set num 0 set x {localhost {socket} 127.0.0.1 {supported_inet} ::1 {supported_inet6}} set resultok {-result "sock*" -match glob} @@ -2436,12 +2460,11 @@ -result {couldn't open socket: connection refused} -returnCodes 1 } foreach {servip sc} $x { foreach {cliip cc} $x { - set constraints socket - lappend constraints $sc $cc + set constraints [list socket $sc $cc] set result $resulterr switch -- [lsort -unique [list $servip $cliip]] { localhost - 127.0.0.1 - ::1 { set result $resultok } @@ -2454,21 +2477,20 @@ if {[testConstraint localhost_v6]} { set result $resultok } } } - test socket-15.1.$num "Connect to $servip from $cliip" \ - -constraints $constraints -setup { - set server [socket -server accept -myaddr $servip 0] - proc accept {s h p} { close $s } - set port [lindex [fconfigure $server -sockname] 2] - } -body { - set s [socket $cliip $port] - } -cleanup { - close $server - catch {close $s} - } {*}$result + test socket-15.1.$num "Connect to $servip from $cliip" -setup { + set server [socket -server accept -myaddr $servip 0] + proc accept {s h p} { close $s } + set port [lindex [fconfigure $server -sockname] 2] + } -constraints $constraints -body { + set s [socket $cliip $port] + } -cleanup { + close $server + catch {close $s} + } {*}$result incr num } } ::tcltest::cleanupTests Index: tests/source.test ================================================================== --- tests/source.test +++ tests/source.test @@ -10,12 +10,12 @@ # Contributions from Don Porter, NIST, 2003. (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. -if {[catch {package require tcltest 2.5}]} { - puts stderr "Skipping tests in [info script]. tcltest 2.5 required." +if {[catch {package require tcltest 2.1}]} { + puts stderr "Skipping tests in [info script]. tcltest 2.1 required." return } namespace eval ::tcl::test::source { namespace import ::tcltest::* @@ -101,13 +101,14 @@ } -returnCodes continue test source-2.6 {source error conditions} -setup { set sourcefile [makeFile {} _non_existent_] removeFile _non_existent_ } -body { - source $sourcefile -} -match glob -result {couldn't read file "*_non_existent_": no such file or directory} \ - -errorCode {POSIX ENOENT {no such file or directory}} + list [catch {source $sourcefile} msg] $msg $::errorCode +} -match listGlob -result [list 1 \ + {couldn't read file "*_non_existent_": no such file or directory} \ + {POSIX ENOENT {no such file or directory}}] test source-2.7 {utf-8 with BOM} -setup { set sourcefile [makeFile {} source.file] } -body { set out [open $sourcefile w] fconfigure $out -encoding utf-8 Index: tests/split.test ================================================================== --- tests/split.test +++ tests/split.test @@ -9,12 +9,12 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } test split-1.1 {basic split commands} { split "a\n b\t\r c\n " @@ -41,11 +41,11 @@ proc foo {} { set x {} foreach f [split {]\n} {}] { append x $f } - return $x + return $x } foo } {]\n} test split-1.9 {basic split commands} { proc foo {} { Index: tests/stack.test ================================================================== --- tests/stack.test +++ tests/stack.test @@ -7,12 +7,14 @@ # Copyright (c) 1998-2000 Ajuba Solutions. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} # Note that a failure in this test may result in a crash of the executable. test stack-1.1 {maxNestingDepth reached on infinite recursion} -body { # do this in a sub process in case it segfaults @@ -29,11 +31,11 @@ interp alias {} unknown {} notaknownproc catch { unknown } msg puts $msg } } -result {too many nested evaluations (infinite loop?)} - + # Make sure that there is enough stack to run regexp even if we're # close to the recursion limit. [Bug 947070] [Patch 746378] test stack-3.1 {enough room for regexp near recursion limit} -body { # do this in a sub process in case it segfaults exec [interpreter] << { Index: tests/string.test ================================================================== --- tests/string.test +++ tests/string.test @@ -10,506 +10,320 @@ # Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] -# Helper commands to test various optimizations, code paths, and special cases. -proc makeByteArray {s} {binary format a* $s} -proc makeUnicode {s} {lindex [regexp -inline .* $s] 0} -proc makeList {args} {return $args} -proc makeShared {s} {uplevel 1 [list lappend copy $s]; return $s} - # Some tests require the testobj command -testConstraint testobj [expr {[info commands testobj] ne {}}] -testConstraint testindexobj [expr {[info commands testindexobj] ne {}}] -testConstraint testevalex [expr {[info commands testevalex] ne {}}] -testConstraint tip389 [expr {[string length \U010000] == 2}] +testConstraint testobj [expr {[info commands testobj] != {}}] +testConstraint testindexobj [expr {[info commands testindexobj] != {}}] +testConstraint utf16 [expr {[string length \U010000] == 2}] +testConstraint testbytestring [llength [info commands testbytestring]] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] -if {[testConstraint memory]} { - proc getbytes {} { - set lines [split [memory info] \n] - return [lindex $lines 3 3] - } - proc leaktest {script {iterations 3}} { - set end [getbytes] - for {set i 0} {$i < $iterations} {incr i} { - uplevel 1 $script - set tmp $end - set end [getbytes] - } - return [expr {$end - $tmp}] - } -} - -proc representationpoke s { - set r [::tcl::unsupported::representation $s] - list [lindex $r 3] [string match {*, string representation "*"} $r] -} - -foreach noComp {0 1} { - -if {$noComp} { - if {[info commands testevalex] eq {}} { - test string-0.1.$noComp "show testevalex availability" {testevalex} {list} {} - continue - } - interp alias {} run {} testevalex - set constraints testevalex -} else { - interp alias {} run {} try - set constraints {} -} - - -test string-1.1.$noComp {error conditions} { - list [catch {run {string gorp a b}} msg] $msg -} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} -test string-1.2.$noComp {error conditions} { - list [catch {run {string}} msg] $msg -} {1 {wrong # args: should be "string subcommand ?arg ...?"}} -test stringComp-1.3.$noComp {error condition - undefined method during compile} { - # We don't want this to complain about 'never' because it may never - # be called, or string may get redefined. This must compile OK. - proc foo {str i} { - if {"yes" == "no"} { string never called but complains here } - string index $str $i - } - foo abc 0 -} a - -test string-2.1.$noComp {string compare, too few args} { - list [catch {run {string compare a}} msg] $msg -} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}} -test string-2.2.$noComp {string compare, bad args} { - list [catch {run {string compare a b c}} msg] $msg -} {1 {bad option "a": must be -nocase or -length}} -test string-2.3.$noComp {string compare, bad args} { - list [catch {run {string compare -length -nocase str1 str2}} msg] $msg -} {1 {expected integer but got "-nocase"}} -test string-2.4.$noComp {string compare, too many args} { - list [catch {run {string compare -length 10 -nocase str1 str2 str3}} msg] $msg -} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}} -test string-2.5.$noComp {string compare with length unspecified} { - list [catch {run {string compare -length 10 10}} msg] $msg -} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}} -test string-2.6.$noComp {string compare} { - run {string compare abcde abdef} -} -1 -test string-2.7.$noComp {string compare, shortest method name} { - run {string co abcde ABCDE} -} 1 -test string-2.8.$noComp {string compare} { - run {string compare abcde abcde} -} 0 -test string-2.9.$noComp {string compare with length} { - run {string compare -length 2 abcde abxyz} -} 0 -test string-2.10.$noComp {string compare with special index} { - list [catch {run {string compare -length end-3 abcde abxyz}} msg] $msg -} {1 {expected integer but got "end-3"}} -test string-2.11.$noComp {string compare, unicode} { - run {string compare ab\u7266 ab\u7267} -} -1 -test string-2.11.1.$noComp {string compare, unicode} { - run {string compare \334 \u00dc} -} 0 -test string-2.11.2.$noComp {string compare, unicode} { - run {string compare \334 \u00fc} -} -1 -test string-2.11.3.$noComp {string compare, unicode} { - run {string compare \334\334\334\374\374 \334\334\334\334\334} -} 1 -test string-2.12.$noComp {string compare, high bit} { - # This test will fail if the underlying comparaison + +test string-1.1 {error conditions} { + list [catch {string gorp a b} msg] $msg +} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +test string-1.2 {error conditions} { + list [catch {string} msg] $msg +} {1 {wrong # args: should be "string subcommand ?arg ...?"}} + +test string-2.1 {string compare, not enough args} { + list [catch {string compare a} msg] $msg +} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}} +test string-2.2 {string compare, bad args} { + list [catch {string compare a b c} msg] $msg +} {1 {bad option "a": must be -nocase or -length}} +test string-2.3 {string compare, bad args} { + list [catch {string compare -length -nocase str1 str2} msg] $msg +} {1 {expected integer but got "-nocase"}} +test string-2.4 {string compare, too many args} { + list [catch {string compare -length 10 -nocase str1 str2 str3} msg] $msg +} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}} +test string-2.5 {string compare with length unspecified} { + list [catch {string compare -length 10 10} msg] $msg +} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}} +test string-2.6 {string compare} { + string compare abcde abdef +} -1 +test string-2.7 {string compare, shortest method name} { + string co abcde ABCDE +} 1 +test string-2.8 {string compare} { + string compare abcde abcde +} 0 +test string-2.9 {string compare with length} { + string compare -length 2 abcde abxyz +} 0 +test string-2.10 {string compare with special index} { + list [catch {string compare -length end-3 abcde abxyz} msg] $msg +} {1 {expected integer but got "end-3"}} +test string-2.11 {string compare, unicode} { + string compare ab\u7266 ab\u7267 +} -1 +test string-2.12 {string compare, high bit} { + # This test will fail if the underlying comparison # is using signed chars instead of unsigned chars. # (like SunOS's default memcmp thus the compat/memcmp.c) - run {string compare "\x80" "@"} - # Nb this tests works also in utf8 space because \x80 is + string compare "\x80" "@" + # Nb this tests works also in utf-8 space because \x80 is # translated into a 2 or more bytelength but whose first byte has # the high bit set. } 1 -test string-2.13.$noComp {string compare -nocase} { - run {string compare -nocase abcde abdef} -} -1 -test string-2.13.1.$noComp {string compare -nocase} { - run {string compare -nocase abcde Abdef} -} -1 -test string-2.14.$noComp {string compare -nocase} { - run {string compare -nocase abcde ABCDE} -} 0 -test string-2.15.$noComp {string compare -nocase} { - run {string compare -nocase abcde abcde} -} 0 -test string-2.15.1.$noComp {string compare -nocase} { - run {string compare -nocase \334 \u00dc} -} 0 -test string-2.15.2.$noComp {string compare -nocase} { - run {string compare -nocase \334\334\334\374\u00fc \334\334\334\334\334} -} 0 -test string-2.16.$noComp {string compare -nocase with length} { - run {string compare -length 2 -nocase abcde Abxyz} -} 0 -test string-2.17.$noComp {string compare -nocase with length} { - run {string compare -nocase -length 3 abcde Abxyz} -} -1 -test string-2.18.$noComp {string compare -nocase with length <= 0} { - run {string compare -nocase -length -1 abcde AbCdEf} -} -1 -test string-2.19.$noComp {string compare -nocase with excessive length} { - run {string compare -nocase -length 50 AbCdEf abcde} -} 1 -test string-2.20.$noComp {string compare -len unicode} { +test string-2.13 {string compare -nocase} { + string compare -nocase abcde abdef +} -1 +test string-2.14 {string compare -nocase} { + string compare -nocase abcde ABCDE +} 0 +test string-2.15 {string compare -nocase} { + string compare -nocase abcde abcde +} 0 +test string-2.16 {string compare -nocase with length} { + string compare -length 2 -nocase abcde Abxyz +} 0 +test string-2.17 {string compare -nocase with length} { + string compare -nocase -length 3 abcde Abxyz +} -1 +test string-2.18 {string compare -nocase with length <= 0} { + string compare -nocase -length -1 abcde AbCdEf +} -1 +test string-2.19 {string compare -nocase with excessive length} { + string compare -nocase -length 50 AbCdEf abcde +} 1 +test string-2.20 {string compare -len unicode} { # These are strings that are 6 BYTELENGTH long, but the length # shouldn't make a different because there are actually 3 CHARS long - run {string compare -len 5 \334\334\334 \334\334\374} + string compare -len 5 \334\334\334 \334\334\374 } -1 -test string-2.21.$noComp {string compare -nocase with special index} { - list [catch {run {string compare -nocase -length end-3 Abcde abxyz}} msg] $msg +test string-2.21 {string compare -nocase with special index} { + list [catch {string compare -nocase -length end-3 Abcde abxyz} msg] $msg } {1 {expected integer but got "end-3"}} -test string-2.22.$noComp {string compare, null strings} { - run {string compare "" ""} -} 0 -test string-2.23.$noComp {string compare, null strings} { - run {string compare "" foo} -} -1 -test string-2.24.$noComp {string compare, null strings} { - run {string compare foo ""} -} 1 -test string-2.25.$noComp {string compare -nocase, null strings} { - run {string compare -nocase "" ""} -} 0 -test string-2.26.$noComp {string compare -nocase, null strings} { - run {string compare -nocase "" foo} -} -1 -test string-2.27.$noComp {string compare -nocase, null strings} { - run {string compare -nocase foo ""} -} 1 -test string-2.28.$noComp {string compare with length, unequal strings} { - run {string compare -length 2 abc abde} -} 0 -test string-2.29.$noComp {string compare with length, unequal strings} { - run {string compare -length 2 ab abde} -} 0 -test string-2.30.$noComp {string compare with NUL character vs. other ASCII} { +test string-2.22 {string compare, null strings} { + string compare "" "" +} 0 +test string-2.23 {string compare, null strings} { + string compare "" foo +} -1 +test string-2.24 {string compare, null strings} { + string compare foo "" +} 1 +test string-2.25 {string compare -nocase, null strings} { + string compare -nocase "" "" +} 0 +test string-2.26 {string compare -nocase, null strings} { + string compare -nocase "" foo +} -1 +test string-2.27 {string compare -nocase, null strings} { + string compare -nocase foo "" +} 1 +test string-2.28 {string compare with length, unequal strings} { + string compare -length 2 abc abde +} 0 +test string-2.29 {string compare with length, unequal strings} { + string compare -length 2 ab abde +} 0 +test string-2.30 {string compare with NUL character vs. other ASCII} { # Be careful here, since UTF-8 rep comparison with memcmp() of # these puts chars in the wrong order - run {string compare \x00 \x01} -} -1 -test string-2.31.$noComp {string compare, high bit} { - run {string compare "a\x80" "a@"} -} 1 -test string-2.32.$noComp {string compare, high bit} { - run {string compare "a\x00" "a\x01"} -} -1 -test string-2.33.$noComp {string compare, high bit} { - run {string compare "\x00\x00" "\x00\x01"} -} -1 -test string-2.34.$noComp {string compare, binary equal} { - run {string compare [binary format a100 0] [binary format a100 0]} -} 0 -test string-2.35.$noComp {string compare, binary neq} { - run {string compare [binary format a100a 0 1] [binary format a100a 0 0]} -} 1 -test string-2.36.$noComp {string compare, binary neq unequal length} { - run {string compare [binary format a20a 0 1] [binary format a100a 0 0]} + string compare \x00 \x01 +} -1 +test string-2.31 {string compare, high bit} { + proc foo {} {string compare "a\x80" "a@"} + foo +} 1 +test string-2.32 {string compare, high bit} { + proc foo {} {string compare "a\x00" "a\x01"} + foo +} -1 +test string-2.33 {string compare, high bit} { + proc foo {} {string compare "\x00\x00" "\x00\x01"} + foo +} -1 +test string-2.34 {string compare, binary equal} { + proc foo {} {string compare [binary format a100 0] [binary format a100 0]} + foo +} 0 +test string-2.35 {string compare, binary neq} { + proc foo {} {string compare [binary format a100a 0 1] [binary format a100a 0 0]} + foo +} 1 +test string-2.36 {string compare, binary neq unequal length} { + proc foo {} {string compare [binary format a20a 0 1] [binary format a100a 0 0]} + foo } 1 # only need a few tests on equal, since it uses the same code as # string compare, but just modifies the return output -test string-3.1.$noComp {string equal} { - run {string equal abcde abdef} -} 0 -test string-3.2.$noComp {string equal} { - run {string e abcde ABCDE} -} 0 -test string-3.3.$noComp {string equal} { - run {string equal abcde abcde} -} 1 -test string-3.4.$noComp {string equal -nocase} { - run {string equal -nocase \334\334\334\334\374\374\374\374 \334\334\334\334\334\334\334\334} -} 1 -test string-3.5.$noComp {string equal -nocase} { - run {string equal -nocase abcde abdef} -} 0 -test string-3.6.$noComp {string equal -nocase} { - run {string eq -nocase abcde ABCDE} -} 1 -test string-3.7.$noComp {string equal -nocase} { - run {string equal -nocase abcde abcde} -} 1 -test string-3.8.$noComp {string equal with length, unequal strings} { - run {string equal -length 2 abc abde} -} 1 -test string-3.9.$noComp {string equal, too few args} { - list [catch {run {string equal a}} msg] $msg -} {1 {wrong # args: should be "string equal ?-nocase? ?-length int? string1 string2"}} -test string-3.10.$noComp {string equal, bad args} { - list [catch {run {string equal a b c}} msg] $msg -} {1 {bad option "a": must be -nocase or -length}} -test string-3.11.$noComp {string equal, bad args} { - list [catch {run {string equal -length -nocase str1 str2}} msg] $msg -} {1 {expected integer but got "-nocase"}} -test string-3.12.$noComp {string equal, too many args} { - list [catch {run {string equal -length 10 -nocase str1 str2 str3}} msg] $msg -} {1 {wrong # args: should be "string equal ?-nocase? ?-length int? string1 string2"}} -test string-3.13.$noComp {string equal with length unspecified} { - list [catch {run {string equal -length 10 10}} msg] $msg -} {1 {wrong # args: should be "string equal ?-nocase? ?-length int? string1 string2"}} -test string-3.14.$noComp {string equal with length} { - run {string equal -length 2 abcde abxyz} -} 1 -test string-3.15.$noComp {string equal with special index} { - list [catch {run {string equal -length end-3 abcde abxyz}} msg] $msg -} {1 {expected integer but got "end-3"}} - -test string-3.16.$noComp {string equal, unicode} { - run {string equal ab\u7266 ab\u7267} -} 0 -test string-3.17.$noComp {string equal, unicode} { - run {string equal \334 \u00dc} -} 1 -test string-3.18.$noComp {string equal, unicode} { - run {string equal \334 \u00fc} -} 0 -test string-3.19.$noComp {string equal, unicode} { - run {string equal \334\334\334\374\374 \334\334\334\334\334} -} 0 -test string-3.20.$noComp {string equal, high bit} { - # This test will fail if the underlying comparaison - # is using signed chars instead of unsigned chars. - # (like SunOS's default memcmp thus the compat/memcmp.c) - run {string equal "\x80" "@"} - # Nb this tests works also in utf8 space because \x80 is - # translated into a 2 or more bytelength but whose first byte has - # the high bit set. -} 0 -test string-3.21.$noComp {string equal -nocase} { - run {string equal -nocase abcde Abdef} -} 0 -test string-3.22.$noComp {string equal, -nocase unicode} { - run {string equal -nocase \334 \u00dc} -} 1 -test string-3.23.$noComp {string equal, -nocase unicode} { - run {string equal -nocase \334\334\334\374\u00fc \334\334\334\334\334} -} 1 -test string-3.24.$noComp {string equal -nocase with length} { - run {string equal -length 2 -nocase abcde Abxyz} -} 1 -test string-3.25.$noComp {string equal -nocase with length} { - run {string equal -nocase -length 3 abcde Abxyz} -} 0 -test string-3.26.$noComp {string equal -nocase with length <= 0} { - run {string equal -nocase -length -1 abcde AbCdEf} -} 0 -test string-3.27.$noComp {string equal -nocase with excessive length} { - run {string equal -nocase -length 50 AbCdEf abcde} -} 0 -test string-3.28.$noComp {string equal -len unicode} { - # These are strings that are 6 BYTELENGTH long, but the length - # shouldn't make a different because there are actually 3 CHARS long - run {string equal -len 5 \334\334\334 \334\334\374} -} 0 -test string-3.29.$noComp {string equal -nocase with special index} { - list [catch {run {string equal -nocase -length end-3 Abcde abxyz}} msg] $msg -} {1 {expected integer but got "end-3"}} -test string-3.30.$noComp {string equal, null strings} { - run {string equal "" ""} -} 1 -test string-3.31.$noComp {string equal, null strings} { - run {string equal "" foo} -} 0 -test string-3.32.$noComp {string equal, null strings} { - run {string equal foo ""} -} 0 -test string-3.33.$noComp {string equal -nocase, null strings} { - run {string equal -nocase "" ""} -} 1 -test string-3.34.$noComp {string equal -nocase, null strings} { - run {string equal -nocase "" foo} -} 0 -test string-3.35.$noComp {string equal -nocase, null strings} { - run {string equal -nocase foo ""} -} 0 -test string-3.36.$noComp {string equal with NUL character vs. other ASCII} { - # Be careful here, since UTF-8 rep comparison with memcmp() of - # these puts chars in the wrong order - run {string equal \x00 \x01} -} 0 -test string-3.37.$noComp {string equal, high bit} { - run {string equal "a\x80" "a@"} -} 0 -test string-3.38.$noComp {string equal, high bit} { - run {string equal "a\x00" "a\x01"} -} 0 -test string-3.39.$noComp {string equal, high bit} { - run {string equal "a\x00\x00" "a\x00\x01"} -} 0 -test string-3.40.$noComp {string equal, binary equal} { - run {string equal [binary format a100 0] [binary format a100 0]} -} 1 -test string-3.41.$noComp {string equal, binary neq} { - run {string equal [binary format a100a 0 1] [binary format a100a 0 0]} -} 0 -test string-3.42.$noComp {string equal, binary neq inequal length} { - run {string equal [binary format a20a 0 1] [binary format a100a 0 0]} -} 0 - - -test string-4.1.$noComp {string first, too few args} { - list [catch {run {string first a}} msg] $msg -} {1 {wrong # args: should be "string first needleString haystackString ?startIndex?"}} -test string-4.2.$noComp {string first, bad args} { - list [catch {run {string first a b c}} msg] $msg -} {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}} -test string-4.3.$noComp {string first, too many args} { - list [catch {run {string first a b 5 d}} msg] $msg -} {1 {wrong # args: should be "string first needleString haystackString ?startIndex?"}} -test string-4.4.$noComp {string first} { - run {string first bq abcdefgbcefgbqrs} -} 12 -test string-4.5.$noComp {string first} { - run {string fir bcd abcdefgbcefgbqrs} -} 1 -test string-4.6.$noComp {string first} { - run {string f b abcdefgbcefgbqrs} -} 1 -test string-4.7.$noComp {string first} { - run {string first xxx x123xx345xxx789xxx012} -} 9 -test string-4.8.$noComp {string first} { - run {string first "" x123xx345xxx789xxx012} -} -1 -test string-4.9.$noComp {string first, unicode} { - run {string first x abc\u7266x} -} 4 -test string-4.10.$noComp {string first, unicode} { - run {string first \u7266 abc\u7266x} -} 3 -test string-4.11.$noComp {string first, start index} { - run {string first \u7266 abc\u7266x 3} -} 3 -test string-4.12.$noComp {string first, start index} { - run {string first \u7266 abc\u7266x 4} -} -1 -test string-4.13.$noComp {string first, start index} { - run {string first \u7266 abc\u7266x end-2} -} 3 -test string-4.14.$noComp {string first, negative start index} { - run {string first b abc -1} -} 1 -test string-4.15.$noComp {string first, ability to two-byte encoded utf-8 chars} { +test string-3.1 {string equal} { + string equal abcde abdef +} 0 +test string-3.2 {string equal} { + string eq abcde ABCDE +} 0 +test string-3.3 {string equal} { + string equal abcde abcde +} 1 +test string-3.4 {string equal -nocase} { + string equal -nocase \334\334\334\334\374\374\374\374 \334\334\334\334\334\334\334\334 +} 1 +test string-3.5 {string equal -nocase} { + string equal -nocase abcde abdef +} 0 +test string-3.6 {string equal -nocase} { + string eq -nocase abcde ABCDE +} 1 +test string-3.7 {string equal -nocase} { + string equal -nocase abcde abcde +} 1 +test string-3.8 {string equal with length, unequal strings} { + string equal -length 2 abc abde +} 1 + +test string-4.1 {string first, not enough args} { + list [catch {string first a} msg] $msg +} {1 {wrong # args: should be "string first needleString haystackString ?startIndex?"}} +test string-4.2 {string first, bad args} { + list [catch {string first a b c} msg] $msg +} {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}} +test string-4.3 {string first, too many args} { + list [catch {string first a b 5 d} msg] $msg +} {1 {wrong # args: should be "string first needleString haystackString ?startIndex?"}} +test string-4.4 {string first} { + string first bq abcdefgbcefgbqrs +} 12 +test string-4.5 {string first} { + string fir bcd abcdefgbcefgbqrs +} 1 +test string-4.6 {string first} { + string f b abcdefgbcefgbqrs +} 1 +test string-4.7 {string first} { + string first xxx x123xx345xxx789xxx012 +} 9 +test string-4.8 {string first} { + string first "" x123xx345xxx789xxx012 +} -1 +test string-4.9 {string first, unicode} { + string first x abc\u7266x +} 4 +test string-4.10 {string first, unicode} { + string first \u7266 abc\u7266x +} 3 +test string-4.11 {string first, start index} { + string first \u7266 abc\u7266x 3 +} 3 +test string-4.12 {string first, start index} { + string first \u7266 abc\u7266x 4 +} -1 +test string-4.13 {string first, start index} { + string first \u7266 abc\u7266x end-2 +} 3 +test string-4.14 {string first, negative start index} { + string first b abc -1 +} 1 +test string-4.15 {string first, ability to two-byte encoded utf-8 chars} { # Test for a bug in Tcl 8.3 where test for all-single-byte-encoded # strings was incorrect, leading to an index returned by [string first] # which pointed past the end of the string. - set uchar \u057e ;# character with two-byte encoding in utf-8 - run {string first % %#$uchar$uchar#$uchar$uchar#% 3} -} 8 -test string-4.16.$noComp {string first, normal string vs pure unicode string} { - set s hello - regexp ll $s m - # Representation checks are canaries - run {list [representationpoke $s] [representationpoke $m] \ - [string first $m $s]} -} {{string 1} {string 0} 2} -test string-4.17.$noComp {string first, corner case} { - run {string first a aaa 4294967295} -} {-1} -test string-4.18.$noComp {string first, corner case} { - run {string first a aaa -1} -} {0} -test string-4.19.$noComp {string first, corner case} { - run {string first a aaa end-5} -} {0} -test string-4.20.$noComp {string last, corner case} { - run {string last a aaa 4294967295} -} {2} -test string-4.21.$noComp {string last, corner case} { - run {string last a aaa -1} -} {-1} -test string-4.22.$noComp {string last, corner case} { - run {string last a aaa end-5} -} {-1} - -test string-5.1.$noComp {string index} { - list [catch {run {string index}} msg] $msg -} {1 {wrong # args: should be "string index string charIndex"}} -test string-5.2.$noComp {string index} { - list [catch {run {string index a b c}} msg] $msg -} {1 {wrong # args: should be "string index string charIndex"}} -test string-5.3.$noComp {string index} { - run {string index abcde 0} -} a -test string-5.4.$noComp {string index} { - run {string ind abcde 4} -} e -test string-5.5.$noComp {string index} { - run {string index abcde 5} -} {} -test string-5.6.$noComp {string index} { - list [catch {run {string index abcde -10}} msg] $msg -} {0 {}} -test string-5.7.$noComp {string index} { - list [catch {run {string index a xyz}} msg] $msg -} {1 {bad index "xyz": must be integer?[+-]integer? or end?[+-]integer?}} -test string-5.8.$noComp {string index} { - run {string index abc end} -} c -test string-5.9.$noComp {string index} { - run {string index abc end-1} -} b -test string-5.10.$noComp {string index, unicode} { - run {string index abc\u7266d 4} -} d -test string-5.11.$noComp {string index, unicode} { - run {string index abc\u7266d 3} -} \u7266 -test string-5.12.$noComp {string index, unicode over char length, under byte length} { - run {string index \334\374\334\374 6} -} {} -test string-5.13.$noComp {string index, bytearray object} { - run {string index [binary format a5 fuz] 0} -} f -test string-5.14.$noComp {string index, bytearray object} { - run {string index [binary format I* {0x50515253 0x52}] 3} -} S -test string-5.15.$noComp {string index, bytearray object} { - set b [binary format I* {0x50515253 0x52}] - set i1 [run {string index $b end-6}] - set i2 [run {string index $b 1}] - run {string compare $i1 $i2} -} 0 -test string-5.16.$noComp {string index, bytearray object with string obj shimmering} { - set str "0123456789\x00 abcdedfghi" - binary scan $str H* dump - run {string compare [run {string index $str 10}] \x00} -} 0 -test string-5.17.$noComp {string index, bad integer} -body { - list [catch {run {string index "abc" 0o8}} msg] $msg -} -match glob -result {1 {*}} -test string-5.18.$noComp {string index, bad integer} -body { - list [catch {run {string index "abc" end-0o0289}} msg] $msg -} -match glob -result {1 {*}} -test string-5.19.$noComp {string index, bytearray object out of bounds} { - run {string index [binary format I* {0x50515253 0x52}] -1} -} {} -test string-5.20.$noComp {string index, bytearray object out of bounds} { - run {string index [binary format I* {0x50515253 0x52}] 20} -} {} -test string-5.21.$noComp {string index, surrogates, bug [11ae2be95dac9417]} tip389 { - run {list [string index a\U100000b 1] [string index a\U100000b 2] [string index a\U100000b 3]} -} [list \U100000 {} b] + set uchar \u057E ;# character with two-byte encoding in utf-8 + string first % %#$uchar$uchar#$uchar$uchar#% 3 +} 8 +test string-4.17 {string first, corner case} { + string first a aaa 4294967295 +} {0} +test string-4.18 {string first, corner case} { + string first a aaa -1 +} {0} +test string-4.19 {string first, corner case} { + string first a aaa end-5 +} {0} +test string-4.20 {string last, corner case} { + string last a aaa 4294967295 +} {-1} +test string-4.21 {string last, corner case} { + string last a aaa -1 +} {-1} +test string-4.22 {string last, corner case} { + string last a aaa end-5 +} {-1} + +test string-5.1 {string index} { + list [catch {string index} msg] $msg +} {1 {wrong # args: should be "string index string charIndex"}} +test string-5.2 {string index} { + list [catch {string index a b c} msg] $msg +} {1 {wrong # args: should be "string index string charIndex"}} +test string-5.3 {string index} { + string index abcde 0 +} a +test string-5.4 {string index} { + string in abcde 4 +} e +test string-5.5 {string index} { + string index abcde 5 +} {} +test string-5.6 {string index} { + list [catch {string index abcde -10} msg] $msg +} {0 {}} +test string-5.7 {string index} { + list [catch {string index a xyz} msg] $msg +} {1 {bad index "xyz": must be integer?[+-]integer? or end?[+-]integer?}} +test string-5.8 {string index} { + string index abc end +} c +test string-5.9 {string index} { + string index abc end-1 +} b +test string-5.10 {string index, unicode} { + string index abc\u7266d 4 +} d +test string-5.11 {string index, unicode} { + string index abc\u7266d 3 +} \u7266 +test string-5.12 {string index, unicode over char length, under byte length} { + string index \334\374\334\374 6 +} {} +test string-5.13 {string index, bytearray object} { + string index [binary format a5 fuz] 0 +} f +test string-5.14 {string index, bytearray object} { + string index [binary format I* {0x50515253 0x52}] 3 +} S +test string-5.15 {string index, bytearray object} { + set b [binary format I* {0x50515253 0x52}] + set i1 [string index $b end-6] + set i2 [string index $b 1] + string compare $i1 $i2 +} 0 +test string-5.16 {string index, bytearray object with string obj shimmering} { + set str "0123456789\x00 abcdedfghi" + binary scan $str H* dump + string compare [string index $str 10] \x00 +} 0 +test string-5.17 {string index, bad integer} -body { + list [catch {string index "abc" 0o8} msg] $msg +} -match glob -result {1 {*invalid octal number*}} +test string-5.18 {string index, bad integer} -body { + list [catch {string index "abc" end-0o0289} msg] $msg +} -match glob -result {1 {*invalid octal number*}} +test string-5.19 {string index, bytearray object out of bounds} { + string index [binary format I* {0x50515253 0x52}] -1 +} {} +test string-5.20 {string index, bytearray object out of bounds} { + string index [binary format I* {0x50515253 0x52}] 20 +} {} proc largest_int {} { # This will give us what the largest valid int on this machine is, # so we can test for overflow properly below on >32 bit systems @@ -517,1588 +331,1568 @@ set exp 7; # assume we get at least 8 bits while {wide($int) > 0} { set int [expr {wide(1) << [incr exp]}] } return [expr {$int-1}] } -test string-6.1.$noComp {string is, too few args} { - list [catch {run {string is}} msg] $msg -} {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}} -test string-6.2.$noComp {string is, too few args} { - list [catch {run {string is alpha}} msg] $msg -} {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}} -test string-6.3.$noComp {string is, bad args} { - list [catch {run {string is alpha -failin str}} msg] $msg -} {1 {wrong # args: should be "string is alpha ?-strict? ?-failindex var? str"}} -test string-6.4.$noComp {string is, too many args} { - list [catch {run {string is alpha -failin var -strict str more}} msg] $msg -} {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}} -test string-6.5.$noComp {string is, class check} { - list [catch {run {string is bogus str}} msg] $msg -} {1 {bad class "bogus": must be alnum, alpha, ascii, control, boolean, dict, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}} -test string-6.6.$noComp {string is, ambiguous class} { - list [catch {run {string is al str}} msg] $msg -} {1 {ambiguous class "al": must be alnum, alpha, ascii, control, boolean, dict, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}} -test string-6.7.$noComp {string is alpha, all ok} { - run {string is alpha -strict -failindex var abc} -} 1 -test string-6.8.$noComp {string is, error in var} { - list [run {string is alpha -failindex var abc5def}] $var -} {0 3} -test string-6.9.$noComp {string is, var shouldn't get set} { - catch {unset var} - list [catch {run {string is alpha -failindex var abc; set var}} msg] $msg +test string-6.1 {string is, not enough args} { + list [catch {string is} msg] $msg +} {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}} +test string-6.2 {string is, not enough args} { + list [catch {string is alpha} msg] $msg +} {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}} +test string-6.3 {string is, bad args} { + list [catch {string is alpha -failin str} msg] $msg +} {1 {wrong # args: should be "string is alpha ?-strict? ?-failindex var? str"}} +test string-6.4 {string is, too many args} { + list [catch {string is alpha -failin var -strict str more} msg] $msg +} {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}} +test string-6.5 {string is, class check} { + list [catch {string is bogus str} msg] $msg +} {1 {bad class "bogus": must be alnum, alpha, ascii, control, boolean, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}} +test string-6.6 {string is, ambiguous class} { + list [catch {string is al str} msg] $msg +} {1 {ambiguous class "al": must be alnum, alpha, ascii, control, boolean, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}} +test string-6.7 {string is alpha, all ok} { + string is alpha -strict -failindex var abc +} 1 +test string-6.8 {string is, error in var} { + list [string is alpha -failindex var abc5def] $var +} {0 3} +test string-6.9 {string is, var shouldn't get set} { + catch {unset var} + list [catch {string is alpha -failindex var abc; set var} msg] $msg } {1 {can't read "var": no such variable}} -test string-6.10.$noComp {string is, ok on empty} { - run {string is alpha {}} +test string-6.10 {string is, ok on empty} { + string is alpha {} } 1 -test string-6.11.$noComp {string is, -strict check against empty} { - run {string is alpha -strict {}} +test string-6.11 {string is, -strict check against empty} { + string is alpha -strict {} } 0 -test string-6.12.$noComp {string is alnum, true} { - run {string is alnum abc123} +test string-6.12 {string is alnum, true} { + string is alnum abc123 } 1 -test string-6.13.$noComp {string is alnum, false} { - list [run {string is alnum -failindex var abc1.23}] $var +test string-6.13 {string is alnum, false} { + list [string is alnum -failindex var abc1.23] $var } {0 4} -test string-6.14.$noComp {string is alnum, unicode} "run {string is alnum abc\xfc}" 1 -test string-6.15.$noComp {string is alpha, true} { - run {string is alpha abc} +test string-6.14 {string is alnum, unicode} "string is alnum abc\xfc" 1 +test string-6.15 {string is alpha, true} { + string is alpha abc } 1 -test string-6.16.$noComp {string is alpha, false} { - list [run {string is alpha -fail var a1bcde}] $var +test string-6.16 {string is alpha, false} { + list [string is alpha -fail var a1bcde] $var } {0 1} -test string-6.17.$noComp {string is alpha, unicode} { - run {string is alpha abc\374} -} 1 -test string-6.18.$noComp {string is ascii, true} { - run {string is ascii abc\u007Fend\u0000} -} 1 -test string-6.19.$noComp {string is ascii, false} { - list [run {string is ascii -fail var abc\u0000def\u0080more}] $var +test string-6.17 {string is alpha, unicode} { + string is alpha abc\374 +} 1 +test string-6.18 {string is ascii, true} { + string is ascii abc\u007Fend\u0000 +} 1 +test string-6.19 {string is ascii, false} { + list [string is ascii -fail var abc\u0000def\u0080more] $var } {0 7} -test string-6.20.$noComp {string is boolean, true} { - run {string is boolean true} -} 1 -test string-6.21.$noComp {string is boolean, true} { - run {string is boolean f} -} 1 -test string-6.22.$noComp {string is boolean, true based on type} { - run {string is bool [run {string compare a a}]} -} 1 -test string-6.23.$noComp {string is boolean, false} { - list [run {string is bool -fail var yada}] $var +test string-6.20 {string is boolean, true} { + string is boolean true +} 1 +test string-6.21 {string is boolean, true} { + string is boolean f +} 1 +test string-6.22 {string is boolean, true based on type} { + string is bool [string compare a a] +} 1 +test string-6.23 {string is boolean, false} { + list [string is bool -fail var yada] $var } {0 0} -test string-6.24.$noComp {string is digit, true} { - run {string is digit 0123456789} +test string-6.24 {string is digit, true} { + string is digit 0123456789 } 1 -test string-6.25.$noComp {string is digit, false} { - list [run {string is digit -fail var 0123\u00dc567}] $var +test string-6.25 {string is digit, false} { + list [string is digit -fail var 0123\u00DC567] $var } {0 4} -test string-6.26.$noComp {string is digit, false} { - list [run {string is digit -fail var +123567}] $var +test string-6.26 {string is digit, false} { + list [string is digit -fail var +123567] $var } {0 0} -test string-6.27.$noComp {string is double, true} { - run {string is double 1} -} 1 -test string-6.28.$noComp {string is double, true} { - run {string is double [expr double(1)]} -} 1 -test string-6.29.$noComp {string is double, true} { - run {string is double 1.0} -} 1 -test string-6.30.$noComp {string is double, true} { - run {string is double [run {string compare a a}]} -} 1 -test string-6.31.$noComp {string is double, true} { - run {string is double " +1.0e-1 "} -} 1 -test string-6.32.$noComp {string is double, true} { - run {string is double "\n1.0\v"} -} 1 -test string-6.33.$noComp {string is double, false} { - list [run {string is double -fail var 1abc}] $var +test string-6.27 {string is double, true} { + string is double 1 +} 1 +test string-6.28 {string is double, true} { + string is double [expr double(1)] +} 1 +test string-6.29 {string is double, true} { + string is double 1.0 +} 1 +test string-6.30 {string is double, true} { + string is double [string compare a a] +} 1 +test string-6.31 {string is double, true} { + string is double " +1.0e-1 " +} 1 +test string-6.32 {string is double, true} { + string is double "\n1.0\v" +} 1 +test string-6.33 {string is double, false} { + list [string is double -fail var 1abc] $var } {0 1} -test string-6.34.$noComp {string is double, false} { - list [run {string is double -fail var abc}] $var +test string-6.34 {string is double, false} { + list [string is double -fail var abc] $var } {0 0} -test string-6.35.$noComp {string is double, false} { - list [run {string is double -fail var " 1.0e4e4 "}] $var +test string-6.35 {string is double, false} { + list [string is double -fail var " 1.0e4e4 "] $var } {0 8} -test string-6.36.$noComp {string is double, false} { - list [run {string is double -fail var "\n"}] $var +test string-6.36 {string is double, false} { + list [string is double -fail var "\n"] $var } {0 0} -test string-6.37.$noComp {string is double, false on int overflow} -setup { +test string-6.37 {string is double, false on int overflow} -setup { set var priorValue } -body { # Make it the largest int recognizable, with one more digit for overflow # Since bignums arrived in Tcl 8.5, the sense of this test changed. # Now integer values that exceed native limits become bignums, and # bignums can convert to doubles without error. - list [run {string is double -fail var [largest_int]0}] $var + list [string is double -fail var [largest_int]0] $var } -result {1 priorValue} # string-6.38 removed, underflow on input is no longer an error. -test string-6.39.$noComp {string is double, false} { +test string-6.39 {string is double, false} { # This test is non-portable because IRIX thinks # that .e1 is a valid double - this is really a bug # on IRIX as .e1 should NOT be a valid double # # Portable now. Tcl 8.5 does its own double parsing. - list [run {string is double -fail var .e1}] $var -} {0 0} -test string-6.40.$noComp {string is false, true} { - run {string is false false} -} 1 -test string-6.41.$noComp {string is false, true} { - run {string is false FaLsE} -} 1 -test string-6.42.$noComp {string is false, true} { - run {string is false N} -} 1 -test string-6.43.$noComp {string is false, true} { - run {string is false 0} -} 1 -test string-6.44.$noComp {string is false, true} { - run {string is false off} -} 1 -test string-6.45.$noComp {string is false, false} { - list [run {string is false -fail var abc}] $var -} {0 0} -test string-6.46.$noComp {string is false, false} { - catch {unset var} - list [run {string is false -fail var Y}] $var -} {0 0} -test string-6.47.$noComp {string is false, false} { - catch {unset var} - list [run {string is false -fail var offensive}] $var -} {0 0} -test string-6.48.$noComp {string is integer, true} { - run {string is integer +1234567890} -} 1 -test string-6.49.$noComp {string is integer, true on type} { - run {string is integer [expr int(50.0)]} -} 1 -test string-6.50.$noComp {string is integer, true} { - run {string is integer [list -10]} -} 1 -test string-6.51.$noComp {string is integer, true as hex} { - run {string is integer 0xabcdef} -} 1 -test string-6.52.$noComp {string is integer, true as octal} { - run {string is integer 012345} -} 1 -test string-6.53.$noComp {string is integer, true with whitespace} { - run {string is integer " \n1234\v"} -} 1 -test string-6.54.$noComp {string is integer, false} { - list [run {string is integer -fail var 123abc}] $var -} {0 3} -test string-6.55.$noComp {string is integer, no overflow possible} { - run {string is integer +[largest_int]0} -} 1 -test string-6.56.$noComp {string is integer, false} { - list [run {string is integer -fail var [expr double(1)]}] $var -} {0 1} -test string-6.57.$noComp {string is integer, false} { - list [run {string is integer -fail var " "}] $var -} {0 0} -test string-6.58.$noComp {string is integer, false on bad octal} { - list [run {string is integer -fail var 0o36963}] $var -} {0 4} -test string-6.58.1.$noComp {string is integer, false on bad octal} { - list [run {string is integer -fail var 0o36963}] $var -} {0 4} -test string-6.59.$noComp {string is integer, false on bad hex} { - list [run {string is integer -fail var 0X345XYZ}] $var -} {0 5} -test string-6.60.$noComp {string is lower, true} { - run {string is lower abc} -} 1 -test string-6.61.$noComp {string is lower, unicode true} { - run {string is lower abc\u00fcue} -} 1 -test string-6.62.$noComp {string is lower, false} { - list [run {string is lower -fail var aBc}] $var -} {0 1} -test string-6.63.$noComp {string is lower, false} { - list [run {string is lower -fail var abc1}] $var -} {0 3} -test string-6.64.$noComp {string is lower, unicode false} { - list [run {string is lower -fail var ab\u00dcUE}] $var -} {0 2} -test string-6.65.$noComp {string is space, true} { - run {string is space " \t\n\v\f"} -} 1 -test string-6.66.$noComp {string is space, false} { - list [run {string is space -fail var " \t\n\v1\f"}] $var -} {0 4} -test string-6.67.$noComp {string is true, true} { - run {string is true true} -} 1 -test string-6.68.$noComp {string is true, true} { - run {string is true TrU} -} 1 -test string-6.69.$noComp {string is true, true} { - run {string is true ye} -} 1 -test string-6.70.$noComp {string is true, true} { - run {string is true 1} -} 1 -test string-6.71.$noComp {string is true, true} { - run {string is true on} -} 1 -test string-6.72.$noComp {string is true, false} { - list [run {string is true -fail var onto}] $var -} {0 0} -test string-6.73.$noComp {string is true, false} { - catch {unset var} - list [run {string is true -fail var 25}] $var -} {0 0} -test string-6.74.$noComp {string is true, false} { - catch {unset var} - list [run {string is true -fail var no}] $var -} {0 0} -test string-6.75.$noComp {string is upper, true} { - run {string is upper ABC} -} 1 -test string-6.76.$noComp {string is upper, unicode true} { - run {string is upper ABC\u00dcUE} -} 1 -test string-6.77.$noComp {string is upper, false} { - list [run {string is upper -fail var AbC}] $var -} {0 1} -test string-6.78.$noComp {string is upper, false} { - list [run {string is upper -fail var AB2C}] $var -} {0 2} -test string-6.79.$noComp {string is upper, unicode false} { - list [run {string is upper -fail var ABC\u00fcue}] $var -} {0 3} -test string-6.80.$noComp {string is wordchar, true} { - run {string is wordchar abc_123} -} 1 -test string-6.81.$noComp {string is wordchar, unicode true} { - run {string is wordchar abc\u00fcab\u00dcAB\u5001} -} 1 -test string-6.82.$noComp {string is wordchar, false} { - list [run {string is wordchar -fail var abcd.ef}] $var -} {0 4} -test string-6.83.$noComp {string is wordchar, unicode false} { - list [run {string is wordchar -fail var abc\u0080def}] $var -} {0 3} -test string-6.84.$noComp {string is control} { - ## Control chars are in the ranges - ## 00..1F && 7F..9F - list [run {string is control -fail var \x00\x01\x10\x1F\x7F\x80\x9F\x60}] $var -} {0 7} -test string-6.85.$noComp {string is control} { - run {string is control \u0100} -} 0 -test string-6.86.$noComp {string is graph} { - ## graph is any print char, except space - list [run {string is gra -fail var "0123abc!@#\$\u0100\UE0100\UE01EF "}] $var -} {0 14} -test string-6.87.$noComp {string is print} { - ## basically any printable char - list [run {string is print -fail var "0123abc!@#\$\u0100 \UE0100\UE01EF\u0010"}] $var -} {0 15} -test string-6.88.$noComp {string is punct} { - ## any graph char that isn't alnum - list [run {string is punct -fail var "_!@#\u00beq0"}] $var -} {0 4} -test string-6.89.$noComp {string is xdigit} { - list [run {string is xdigit -fail var 0123456789\u0061bcdefABCDEFg}] $var -} {0 22} - -test string-6.90.$noComp {string is integer, bad integers} { - # SF bug #634856 - set result "" - set numbers [list 1 +1 ++1 +-1 -+1 -1 --1 "- +1"] - foreach num $numbers { - lappend result [run {string is int -strict $num}] - } - return $result -} {1 1 0 0 0 1 0 0} -test string-6.91.$noComp {string is double, bad doubles} { - set result "" - set numbers [list 1.0 +1.0 ++1.0 +-1.0 -+1.0 -1.0 --1.0 "- +1.0"] - foreach num $numbers { - lappend result [run {string is double -strict $num}] - } - return $result -} {1 1 0 0 0 1 0 0} -test string-6.92.$noComp {string is integer, no 64-bit overflow} { - # Bug 718878 - set x 0x10000000000000000 - run {string is integer $x} -} 1 -test string-6.93.$noComp {string is integer, no 64-bit overflow} { - # Bug 718878 - set x 0x10000000000000000 - append x "" - run {string is integer $x} -} 1 -test string-6.94.$noComp {string is integer, no 64-bit overflow} { - # Bug 718878 - set x 0x10000000000000000 - run {string is integer [expr {$x}]} -} 1 -test string-6.95.$noComp {string is wideinteger, true} { - run {string is wideinteger +1234567890} -} 1 -test string-6.96.$noComp {string is wideinteger, true on type} { - run {string is wideinteger [expr wide(50.0)]} -} 1 -test string-6.97.$noComp {string is wideinteger, true} { - run {string is wideinteger [list -10]} -} 1 -test string-6.98.$noComp {string is wideinteger, true as hex} { - run {string is wideinteger 0xabcdef} -} 1 -test string-6.99.$noComp {string is wideinteger, true as octal} { - run {string is wideinteger 0123456} -} 1 -test string-6.100.$noComp {string is wideinteger, true with whitespace} { - run {string is wideinteger " \n1234\v"} -} 1 -test string-6.101.$noComp {string is wideinteger, false} { - list [run {string is wideinteger -fail var 123abc}] $var -} {0 3} -test string-6.102.$noComp {string is wideinteger, false on overflow} { - list [run {string is wideinteger -fail var +[largest_int]0}] $var -} {0 -1} -test string-6.103.$noComp {string is wideinteger, false} { - list [run {string is wideinteger -fail var [expr double(1)]}] $var -} {0 1} -test string-6.104.$noComp {string is wideinteger, false} { - list [run {string is wideinteger -fail var " "}] $var -} {0 0} -test string-6.105.$noComp {string is wideinteger, false on bad octal} { - list [run {string is wideinteger -fail var 0o36963}] $var -} {0 4} -test string-6.105.1.$noComp {string is wideinteger, false on bad octal} { - list [run {string is wideinteger -fail var 0o36963}] $var -} {0 4} -test string-6.106.$noComp {string is wideinteger, false on bad hex} { - list [run {string is wideinteger -fail var 0X345XYZ}] $var -} {0 5} -test string-6.107.$noComp {string is integer, bad integers} { - # SF bug #634856 - set result "" - set numbers [list 1 +1 ++1 +-1 -+1 -1 --1 "- +1"] - foreach num $numbers { - lappend result [run {string is wideinteger -strict $num}] - } - return $result -} {1 1 0 0 0 1 0 0} -test string-6.108.$noComp {string is double, Bug 1382287} { - set x 2turtledoves - run {string is double $x} - run {string is double $x} -} 0 -test string-6.109.$noComp {string is double, Bug 1360532} { - run {string is double 1\u00a0} -} 0 -test string-6.110.$noComp {string is entier, true} { - run {string is entier +1234567890} -} 1 -test string-6.111.$noComp {string is entier, true on type} { - run {string is entier [expr wide(50.0)]} -} 1 -test string-6.112.$noComp {string is entier, true} { - run {string is entier [list -10]} -} 1 -test string-6.113.$noComp {string is entier, true as hex} { - run {string is entier 0xabcdef} -} 1 -test string-6.114.$noComp {string is entier, true as octal} { - run {string is entier 0123456} -} 1 -test string-6.115.$noComp {string is entier, true with whitespace} { - run {string is entier " \n1234\v"} -} 1 -test string-6.116.$noComp {string is entier, false} { - list [run {string is entier -fail var 123abc}] $var -} {0 3} -test string-6.117.$noComp {string is entier, false} { - list [run {string is entier -fail var 123123123123123123123123123123123123123123123123123123123123123123123123123123123123abc}] $var -} {0 84} -test string-6.118.$noComp {string is entier, false} { - list [run {string is entier -fail var [expr double(1)]}] $var -} {0 1} -test string-6.119.$noComp {string is entier, false} { - list [run {string is entier -fail var " "}] $var -} {0 0} -test string-6.120.$noComp {string is entier, false on bad octal} { - list [run {string is entier -fail var 0o36963}] $var -} {0 4} -test string-6.121.1.$noComp {string is entier, false on bad octal} { - list [run {string is entier -fail var 0o36963}] $var -} {0 4} -test string-6.122.$noComp {string is entier, false on bad hex} { - list [run {string is entier -fail var 0X345XYZ}] $var -} {0 5} -test string-6.123.$noComp {string is entier, bad integers} { - # SF bug #634856 - set result "" - set numbers [list 1 +1 ++1 +-1 -+1 -1 --1 "- +1"] - foreach num $numbers { - lappend result [run {string is entier -strict $num}] - } - return $result -} {1 1 0 0 0 1 0 0} -test string-6.124.$noComp {string is entier, true} { - run {string is entier +1234567890123456789012345678901234567890} -} 1 -test string-6.125.$noComp {string is entier, true} { - run {string is entier [list -10000000000000000000000000000000000000000000000000000000000000000000000000000000000000]} -} 1 -test string-6.126.$noComp {string is entier, true as hex} { - run {string is entier 0xabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdef} -} 1 -test string-6.127.$noComp {string is entier, true as octal} { - run {string is entier 0123456112341234561234565623456123456123456123456123456123456123456123456123456123456} -} 1 -test string-6.128.$noComp {string is entier, true with whitespace} { - run {string is entier " \n12340000000000000000000000000000000000000000000000000000000000000000000000000000000000000\v"} -} 1 -test string-6.129.$noComp {string is entier, false on bad octal} { - list [run {string is entier -fail var 0o1234561123412345612345656234561234561234561234561234561234561234561234561234561234536963}] $var -} {0 87} -test string-6.130.1.$noComp {string is entier, false on bad octal} { - list [run {string is entier -fail var 0o1234561123412345612345656234561234561234561234561234561234561234561234561234561234536963}] $var -} {0 87} -test string-6.131.$noComp {string is entier, false on bad hex} { - list [run {string is entier -fail var 0X12345611234123456123456562345612345612345612345612345612345612345612345612345612345345XYZ}] $var + list [string is double -fail var .e1] $var +} {0 0} +test string-6.40 {string is false, true} { + string is false false +} 1 +test string-6.41 {string is false, true} { + string is false FaLsE +} 1 +test string-6.42 {string is false, true} { + string is false N +} 1 +test string-6.43 {string is false, true} { + string is false 0 +} 1 +test string-6.44 {string is false, true} { + string is false off +} 1 +test string-6.45 {string is false, false} { + list [string is false -fail var abc] $var +} {0 0} +test string-6.46 {string is false, false} { + catch {unset var} + list [string is false -fail var Y] $var +} {0 0} +test string-6.47 {string is false, false} { + catch {unset var} + list [string is false -fail var offensive] $var +} {0 0} +test string-6.48 {string is integer, true} { + string is integer +1234567890 +} 1 +test string-6.49 {string is integer, true on type} { + string is integer [expr int(50.0)] +} 1 +test string-6.50 {string is integer, true} { + string is integer [list -10] +} 1 +test string-6.51 {string is integer, true as hex} { + string is integer 0xabcdef +} 1 +test string-6.52 {string is integer, true as octal} { + string is integer 012345 +} 1 +test string-6.53 {string is integer, true with whitespace} { + string is integer " \n1234\v" +} 1 +test string-6.54 {string is integer, false} { + list [string is integer -fail var 123abc] $var +} {0 3} +test string-6.55 {string is integer, false on overflow} { + list [string is integer -fail var +[largest_int]0] $var +} {0 -1} +test string-6.56 {string is integer, false} { + list [string is integer -fail var [expr double(1)]] $var +} {0 1} +test string-6.57 {string is integer, false} { + list [string is integer -fail var " "] $var +} {0 0} +test string-6.58 {string is integer, false on bad octal} { + list [string is integer -fail var 0o36963] $var +} {0 4} +test string-6.58.1 {string is integer, false on bad octal} { + list [string is integer -fail var 0o36963] $var +} {0 4} +test string-6.59 {string is integer, false on bad hex} { + list [string is integer -fail var 0X345XYZ] $var +} {0 5} +test string-6.60 {string is lower, true} { + string is lower abc +} 1 +test string-6.61 {string is lower, unicode true} { + string is lower abc\u00FCue +} 1 +test string-6.62 {string is lower, false} { + list [string is lower -fail var aBc] $var +} {0 1} +test string-6.63 {string is lower, false} { + list [string is lower -fail var abc1] $var +} {0 3} +test string-6.64 {string is lower, unicode false} { + list [string is lower -fail var ab\u00DCUE] $var +} {0 2} +test string-6.65 {string is space, true} { + string is space " \t\n\v\f" +} 1 +test string-6.66 {string is space, false} { + list [string is space -fail var " \t\n\v1\f"] $var +} {0 4} +test string-6.67 {string is true, true} { + string is true true +} 1 +test string-6.68 {string is true, true} { + string is true TrU +} 1 +test string-6.69 {string is true, true} { + string is true ye +} 1 +test string-6.70 {string is true, true} { + string is true 1 +} 1 +test string-6.71 {string is true, true} { + string is true on +} 1 +test string-6.72 {string is true, false} { + list [string is true -fail var onto] $var +} {0 0} +test string-6.73 {string is true, false} { + catch {unset var} + list [string is true -fail var 25] $var +} {0 0} +test string-6.74 {string is true, false} { + catch {unset var} + list [string is true -fail var no] $var +} {0 0} +test string-6.75 {string is upper, true} { + string is upper ABC +} 1 +test string-6.76 {string is upper, unicode true} { + string is upper ABC\u00DCUE +} 1 +test string-6.77 {string is upper, false} { + list [string is upper -fail var AbC] $var +} {0 1} +test string-6.78 {string is upper, false} { + list [string is upper -fail var AB2C] $var +} {0 2} +test string-6.79 {string is upper, unicode false} { + list [string is upper -fail var ABC\u00FCue] $var +} {0 3} +test string-6.80 {string is wordchar, true} { + string is wordchar abc_123 +} 1 +test string-6.81 {string is wordchar, unicode true} { + string is wordchar abc\u00FCab\u00DCAB\u5001 +} 1 +test string-6.82 {string is wordchar, false} { + list [string is wordchar -fail var abcd.ef] $var +} {0 4} +test string-6.83 {string is wordchar, unicode false} { + list [string is wordchar -fail var abc\u0080def] $var +} {0 3} +test string-6.84 {string is control} { + ## Control chars are in the ranges + ## 00..1F && 7F..9F + list [string is control -fail var \x00\x01\x10\x1F\x7F\x80\x9F\x60] $var +} {0 7} +test string-6.85 {string is control} { + string is control \u0100 +} 0 +test string-6.86 {string is graph} { + ## graph is any print char, except space + list [string is gra -fail var "0123abc!@#\$\u0100\UE0100\UE01EF "] $var +} {0 14} +test string-6.87 {string is print} { + ## basically any printable char + list [string is print -fail var "0123abc!@#\$\u0100 \UE0100\UE01EF\u0010"] $var +} {0 15} +test string-6.88 {string is punct} { + ## any graph char that isn't alnum + list [string is punct -fail var "_!@#\u00BEq0"] $var +} {0 4} +test string-6.89 {string is xdigit} { + list [string is xdigit -fail var 0123456789\u0061bcdefABCDEFg] $var +} {0 22} + +test string-6.90 {string is integer, bad integers} { + # SF bug #634856 + set result "" + set numbers [list 1 +1 ++1 +-1 -+1 -1 --1 "- +1"] + foreach num $numbers { + lappend result [string is int -strict $num] + } + return $result +} {1 1 0 0 0 1 0 0} +test string-6.91 {string is double, bad doubles} { + set result "" + set numbers [list 1.0 +1.0 ++1.0 +-1.0 -+1.0 -1.0 --1.0 "- +1.0"] + foreach num $numbers { + lappend result [string is double -strict $num] + } + return $result +} {1 1 0 0 0 1 0 0} +test string-6.92 {string is integer, 32-bit overflow} { + # Bug 718878 + set x 0x100000000 + list [string is integer -failindex var $x] $var +} {0 -1} +test string-6.93 {string is integer, 32-bit overflow} { + # Bug 718878 + set x 0x100000000 + append x "" + list [string is integer -failindex var $x] $var +} {0 -1} +test string-6.94 {string is integer, 32-bit overflow} { + # Bug 718878 + set x 0x100000000 + list [string is integer -failindex var [expr {$x}]] $var +} {0 -1} +test string-6.95 {string is wideinteger, true} { + string is wideinteger +1234567890 +} 1 +test string-6.96 {string is wideinteger, true on type} { + string is wideinteger [expr wide(50.0)] +} 1 +test string-6.97 {string is wideinteger, true} { + string is wideinteger [list -10] +} 1 +test string-6.98 {string is wideinteger, true as hex} { + string is wideinteger 0xabcdef +} 1 +test string-6.99 {string is wideinteger, true as octal} { + string is wideinteger 0123456 +} 1 +test string-6.100 {string is wideinteger, true with whitespace} { + string is wideinteger " \n1234\v" +} 1 +test string-6.101 {string is wideinteger, false} { + list [string is wideinteger -fail var 123abc] $var +} {0 3} +test string-6.102 {string is wideinteger, false on overflow} { + list [string is wideinteger -fail var +[largest_int]0] $var +} {0 -1} +test string-6.103 {string is wideinteger, false} { + list [string is wideinteger -fail var [expr double(1)]] $var +} {0 1} +test string-6.104 {string is wideinteger, false} { + list [string is wideinteger -fail var " "] $var +} {0 0} +test string-6.105 {string is wideinteger, false on bad octal} { + list [string is wideinteger -fail var 0o36963] $var +} {0 4} +test string-6.105.1 {string is wideinteger, false on bad octal} { + list [string is wideinteger -fail var 0o36963] $var +} {0 4} +test string-6.106 {string is wideinteger, false on bad hex} { + list [string is wideinteger -fail var 0X345XYZ] $var +} {0 5} +test string-6.107 {string is integer, bad integers} { + # SF bug #634856 + set result "" + set numbers [list 1 +1 ++1 +-1 -+1 -1 --1 "- +1"] + foreach num $numbers { + lappend result [string is wideinteger -strict $num] + } + return $result +} {1 1 0 0 0 1 0 0} +test string-6.108 {string is double, Bug 1382287} { + set x 2turtledoves + string is double $x + string is double $x +} 0 +test string-6.109 {string is double, Bug 1360532} { + string is double 1\u00A0 +} 0 +test string-6.110 {string is entier, true} { + string is entier +1234567890 +} 1 +test string-6.111 {string is entier, true on type} { + string is entier [expr wide(50.0)] +} 1 +test string-6.112 {string is entier, true} { + string is entier [list -10] +} 1 +test string-6.113 {string is entier, true as hex} { + string is entier 0xabcdef +} 1 +test string-6.114 {string is entier, true as octal} { + string is entier 0123456 +} 1 +test string-6.115 {string is entier, true with whitespace} { + string is entier " \n1234\v" +} 1 +test string-6.116 {string is entier, false} { + list [string is entier -fail var 123abc] $var +} {0 3} +test string-6.117 {string is entier, false} { + list [string is entier -fail var 123123123123123123123123123123123123123123123123123123123123123123123123123123123123abc] $var +} {0 84} +test string-6.118 {string is entier, false} { + list [string is entier -fail var [expr double(1)]] $var +} {0 1} +test string-6.119 {string is entier, false} { + list [string is entier -fail var " "] $var +} {0 0} +test string-6.120 {string is entier, false on bad octal} { + list [string is entier -fail var 0o36963] $var +} {0 4} +test string-6.121.1 {string is entier, false on bad octal} { + list [string is entier -fail var 0o36963] $var +} {0 4} +test string-6.122 {string is entier, false on bad hex} { + list [string is entier -fail var 0X345XYZ] $var +} {0 5} +test string-6.123 {string is entier, bad integers} { + # SF bug #634856 + set result "" + set numbers [list 1 +1 ++1 +-1 -+1 -1 --1 "- +1"] + foreach num $numbers { + lappend result [string is entier -strict $num] + } + return $result +} {1 1 0 0 0 1 0 0} +test string-6.124 {string is entier, true} { + string is entier +1234567890123456789012345678901234567890 +} 1 +test string-6.125 {string is entier, true} { + string is entier [list -10000000000000000000000000000000000000000000000000000000000000000000000000000000000000] +} 1 +test string-6.126 {string is entier, true as hex} { + string is entier 0xabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdef +} 1 +test string-6.127 {string is entier, true as octal} { + string is entier 0123456112341234561234565623456123456123456123456123456123456123456123456123456123456 +} 1 +test string-6.128 {string is entier, true with whitespace} { + string is entier " \n12340000000000000000000000000000000000000000000000000000000000000000000000000000000000000\v" +} 1 +test string-6.129 {string is entier, false on bad octal} { + list [string is entier -fail var 0o1234561123412345612345656234561234561234561234561234561234561234561234561234561234536963] $var +} {0 87} +test string-6.130.1 {string is entier, false on bad octal} { + list [string is entier -fail var 0o1234561123412345612345656234561234561234561234561234561234561234561234561234561234536963] $var +} {0 87} +test string-6.131 {string is entier, false on bad hex} { + list [string is entier -fail var 0X12345611234123456123456562345612345612345612345612345612345612345612345612345612345345XYZ] $var } {0 88} catch {rename largest_int {}} -test string-7.1.$noComp {string last, too few args} { - list [catch {run {string last a}} msg] $msg -} {1 {wrong # args: should be "string last needleString haystackString ?lastIndex?"}} -test string-7.2.$noComp {string last, bad args} { - list [catch {run {string last a b c}} msg] $msg -} {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}} -test string-7.3.$noComp {string last, too many args} { - list [catch {run {string last a b c d}} msg] $msg -} {1 {wrong # args: should be "string last needleString haystackString ?lastIndex?"}} -test string-7.4.$noComp {string last} { - run {string la xxx xxxx123xx345x678} -} 1 -test string-7.5.$noComp {string last} { - run {string last xx xxxx123xx345x678} -} 7 -test string-7.6.$noComp {string last} { - run {string las x xxxx123xx345x678} -} 12 -test string-7.7.$noComp {string last, unicode} { - run {string las x xxxx12\u7266xx345x678} -} 12 -test string-7.8.$noComp {string last, unicode} { - run {string las \u7266 xxxx12\u7266xx345x678} -} 6 -test string-7.9.$noComp {string last, stop index} { - run {string las \u7266 xxxx12\u7266xx345x678} -} 6 -test string-7.10.$noComp {string last, unicode} { - run {string las \u7266 xxxx12\u7266xx345x678} -} 6 -test string-7.11.$noComp {string last, start index} { - run {string last \u7266 abc\u7266x 3} -} 3 -test string-7.12.$noComp {string last, start index} { - run {string last \u7266 abc\u7266x 2} -} -1 -test string-7.13.$noComp {string last, start index} { - ## Constrain to last 'a' should work - run {string last ba badbad end-1} -} 3 -test string-7.14.$noComp {string last, start index} { - ## Constrain to last 'b' should skip last 'ba' - run {string last ba badbad end-2} -} 0 -test string-7.15.$noComp {string last, start index} { - run {string last \334a \334ad\334ad 0} -} -1 -test string-7.16.$noComp {string last, start index} { - run {string last \334a \334ad\334ad end-1} -} 3 - -test string-8.1.$noComp {string bytelength} { - list [catch {run {string bytelength}} msg] $msg -} {1 {wrong # args: should be "string bytelength string"}} -test string-8.2.$noComp {string bytelength} { - list [catch {run {string bytelength a b}} msg] $msg -} {1 {wrong # args: should be "string bytelength string"}} -test string-8.3.$noComp {string bytelength} { - run {string bytelength "\u00c7"} -} 2 -test string-8.4.$noComp {string bytelength} { - run {string b ""} -} 0 - -test string-9.1.$noComp {string length} { - list [catch {run {string length}} msg] $msg -} {1 {wrong # args: should be "string length string"}} -test string-9.2.$noComp {string length} { - list [catch {run {string length a b}} msg] $msg -} {1 {wrong # args: should be "string length string"}} -test string-9.3.$noComp {string length} { - run {string length "a little string"} -} 15 -test string-9.4.$noComp {string length} { - run {string le ""} -} 0 -test string-9.5.$noComp {string length, unicode} { - run {string le "abcd\u7266"} -} 5 -test string-9.6.$noComp {string length, bytearray object} { - run {string length [binary format a5 foo]} -} 5 -test string-9.7.$noComp {string length, bytearray object} { - run {string length [binary format I* {0x50515253 0x52}]} +test string-7.1 {string last, not enough args} { + list [catch {string last a} msg] $msg +} {1 {wrong # args: should be "string last needleString haystackString ?startIndex?"}} +test string-7.2 {string last, bad args} { + list [catch {string last a b c} msg] $msg +} {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}} +test string-7.3 {string last, too many args} { + list [catch {string last a b c d} msg] $msg +} {1 {wrong # args: should be "string last needleString haystackString ?startIndex?"}} +test string-7.4 {string last} { + string la xxx xxxx123xx345x678 +} 1 +test string-7.5 {string last} { + string last xx xxxx123xx345x678 +} 7 +test string-7.6 {string last} { + string las x xxxx123xx345x678 +} 12 +test string-7.7 {string last, unicode} { + string las x xxxx12\u7266xx345x678 +} 12 +test string-7.8 {string last, unicode} { + string las \u7266 xxxx12\u7266xx345x678 +} 6 +test string-7.9 {string last, stop index} { + string las \u7266 xxxx12\u7266xx345x678 +} 6 +test string-7.10 {string last, unicode} { + string las \u7266 xxxx12\u7266xx345x678 +} 6 +test string-7.11 {string last, start index} { + string last \u7266 abc\u7266x 3 +} 3 +test string-7.12 {string last, start index} { + string last \u7266 abc\u7266x 2 +} -1 +test string-7.13 {string last, start index} { + ## Constrain to last 'a' should work + string last ba badbad end-1 +} 3 +test string-7.14 {string last, start index} { + ## Constrain to last 'b' should skip last 'ba' + string last ba badbad end-2 +} 0 +test string-7.15 {string last, start index} { + string last \334a \334ad\334ad 0 +} -1 +test string-7.16 {string last, start index} { + string last \334a \334ad\334ad end-1 +} 3 + +test string-8.1 {string bytelength} { + list [catch {string bytelength} msg] $msg +} {1 {wrong # args: should be "string bytelength string"}} +test string-8.2 {string bytelength} { + list [catch {string bytelength a b} msg] $msg +} {1 {wrong # args: should be "string bytelength string"}} +test string-8.3 {string bytelength} { + string bytelength "\u00c7" +} 2 +test string-8.4 {string bytelength} { + string b "" +} 0 + +test string-9.1 {string length} { + list [catch {string length} msg] $msg +} {1 {wrong # args: should be "string length string"}} +test string-9.2 {string length} { + list [catch {string length a b} msg] $msg +} {1 {wrong # args: should be "string length string"}} +test string-9.3 {string length} { + string length "a little string" +} 15 +test string-9.4 {string length} { + string le "" +} 0 +test string-9.5 {string length, unicode} { + string le "abcd\u7266" +} 5 +test string-9.6 {string length, bytearray object} { + string length [binary format a5 foo] +} 5 +test string-9.7 {string length, bytearray object} { + string length [binary format I* {0x50515253 0x52}] } 8 -test string-10.1.$noComp {string map, too few args} { - list [catch {run {string map}} msg] $msg -} {1 {wrong # args: should be "string map ?-nocase? charMap string"}} -test string-10.2.$noComp {string map, bad args} { - list [catch {run {string map {a b} abba oops}} msg] $msg -} {1 {bad option "a b": must be -nocase}} -test string-10.3.$noComp {string map, too many args} { - list [catch {run {string map -nocase {a b} str1 str2}} msg] $msg -} {1 {wrong # args: should be "string map ?-nocase? charMap string"}} -test string-10.4.$noComp {string map} { - run {string map {a b} abba} -} {bbbb} -test string-10.5.$noComp {string map} { - run {string map {a b} a} -} {b} -test string-10.6.$noComp {string map -nocase} { - run {string map -nocase {a b} Abba} -} {bbbb} -test string-10.7.$noComp {string map} { - run {string map {abc 321 ab * a A} aabcabaababcab} -} {A321*A*321*} -test string-10.8.$noComp {string map -nocase} { - run {string map -nocase {aBc 321 Ab * a A} aabcabaababcab} -} {A321*A*321*} -test string-10.9.$noComp {string map -nocase} { - run {string map -no {abc 321 Ab * a A} aAbCaBaAbAbcAb} -} {A321*A*321*} -test string-10.10.$noComp {string map} { - list [catch {run {string map {a b c} abba}} msg] $msg -} {1 {char map list unbalanced}} -test string-10.11.$noComp {string map, nulls} { - run {string map {\x00 NULL blah \x00nix} {qwerty}} -} {qwerty} -test string-10.12.$noComp {string map, unicode} { - run {string map [list \374 ue UE \334] "a\374ueUE\000EU"} -} aueue\334\0EU -test string-10.13.$noComp {string map, -nocase unicode} { - run {string map -nocase [list \374 ue UE \334] "a\374ueUE\000EU"} -} aue\334\334\0EU -test string-10.14.$noComp {string map, -nocase null arguments} { - run {string map -nocase {{} abc} foo} -} foo -test string-10.15.$noComp {string map, one pair case} { - run {string map -nocase {abc 32} aAbCaBaAbAbcAb} -} {a32aBaAb32Ab} -test string-10.16.$noComp {string map, one pair case} { - run {string map -nocase {ab 4321} aAbCaBaAbAbcAb} -} {a4321C4321a43214321c4321} -test string-10.17.$noComp {string map, one pair case} { - run {string map {Ab 4321} aAbCaBaAbAbcAb} +test string-10.1 {string map, not enough args} { + list [catch {string map} msg] $msg +} {1 {wrong # args: should be "string map ?-nocase? charMap string"}} +test string-10.2 {string map, bad args} { + list [catch {string map {a b} abba oops} msg] $msg +} {1 {bad option "a b": must be -nocase}} +test string-10.3 {string map, too many args} { + list [catch {string map -nocase {a b} str1 str2} msg] $msg +} {1 {wrong # args: should be "string map ?-nocase? charMap string"}} +test string-10.4 {string map} { + string map {a b} abba +} {bbbb} +test string-10.5 {string map} { + string map {a b} a +} {b} +test string-10.6 {string map -nocase} { + string map -nocase {a b} Abba +} {bbbb} +test string-10.7 {string map} { + string map {abc 321 ab * a A} aabcabaababcab +} {A321*A*321*} +test string-10.8 {string map -nocase} { + string map -nocase {aBc 321 Ab * a A} aabcabaababcab +} {A321*A*321*} +test string-10.9 {string map -nocase} { + string map -no {abc 321 Ab * a A} aAbCaBaAbAbcAb +} {A321*A*321*} +test string-10.10 {string map} { + list [catch {string map {a b c} abba} msg] $msg +} {1 {char map list unbalanced}} +test string-10.11 {string map, nulls} { + string map {\x00 NULL blah \x00nix} {qwerty} +} {qwerty} +test string-10.12 {string map, unicode} { + string map [list \374 ue UE \334] "a\374ueUE\000EU" +} aueue\334\0EU +test string-10.13 {string map, -nocase unicode} { + string map -nocase [list \374 ue UE \334] "a\374ueUE\000EU" +} aue\334\334\0EU +test string-10.14 {string map, -nocase null arguments} { + string map -nocase {{} abc} foo +} foo +test string-10.15 {string map, one pair case} { + string map -nocase {abc 32} aAbCaBaAbAbcAb +} {a32aBaAb32Ab} +test string-10.16 {string map, one pair case} { + string map -nocase {ab 4321} aAbCaBaAbAbcAb +} {a4321C4321a43214321c4321} +test string-10.17 {string map, one pair case} { + string map {Ab 4321} aAbCaBaAbAbcAb } {a4321CaBa43214321c4321} -test string-10.18.$noComp {string map, empty argument} { - run {string map -nocase {{} abc} foo} -} foo -test string-10.19.$noComp {string map, empty arguments} { - run {string map -nocase {{} abc f bar {} def} foo} -} baroo -test string-10.20.$noComp {string map, dictionaries don't alter map ordering} { - set map {aa X a Y} - list [run {string map [dict create aa X a Y] aaa}] [run {string map $map aaa}] [dict size $map] [run {string map $map aaa}] -} {XY XY 2 XY} -test string-10.20.1.$noComp {string map, dictionaries don't alter map ordering} { - set map {a X b Y a Z} - list [run {string map [dict create a X b Y a Z] aaa}] [run {string map $map aaa}] [dict size $map] [run {string map $map aaa}] -} {ZZZ XXX 2 XXX} -test string-10.21.$noComp {string map, ABR checks} { - run {string map {longstring foob} long} -} long -test string-10.22.$noComp {string map, ABR checks} { - run {string map {long foob} long} -} foob -test string-10.23.$noComp {string map, ABR checks} { - run {string map {lon foob} long} -} foobg -test string-10.24.$noComp {string map, ABR checks} { - run {string map {lon foob} longlo} -} foobglo -test string-10.25.$noComp {string map, ABR checks} { - run {string map {lon foob} longlon} -} foobgfoob -test string-10.26.$noComp {string map, ABR checks} { - run {string map {longstring foob longstring bar} long} -} long -test string-10.27.$noComp {string map, ABR checks} { - run {string map {long foob longstring bar} long} -} foob -test string-10.28.$noComp {string map, ABR checks} { - run {string map {lon foob longstring bar} long} -} foobg -test string-10.29.$noComp {string map, ABR checks} { - run {string map {lon foob longstring bar} longlo} -} foobglo -test string-10.30.$noComp {string map, ABR checks} { - run {string map {lon foob longstring bar} longlon} -} foobgfoob -test string-10.31.$noComp {string map, nasty sharing crash from [Bug 1018562]} { - set a {a b} - run {string map $a $a} +test string-10.18 {string map, empty argument} { + string map -nocase {{} abc} foo +} foo +test string-10.19 {string map, empty arguments} { + string map -nocase {{} abc f bar {} def} foo +} baroo +test string-10.20 {string map, dictionaries don't alter map ordering} { + set map {aa X a Y} + list [string map [dict create aa X a Y] aaa] [string map $map aaa] [dict size $map] [string map $map aaa] +} {XY XY 2 XY} +test string-10.20.1 {string map, dictionaries don't alter map ordering} { + set map {a X b Y a Z} + list [string map [dict create a X b Y a Z] aaa] [string map $map aaa] [dict size $map] [string map $map aaa] +} {ZZZ XXX 2 XXX} +test string-10.21 {string map, ABR checks} { + string map {longstring foob} long +} long +test string-10.22 {string map, ABR checks} { + string map {long foob} long +} foob +test string-10.23 {string map, ABR checks} { + string map {lon foob} long +} foobg +test string-10.24 {string map, ABR checks} { + string map {lon foob} longlo +} foobglo +test string-10.25 {string map, ABR checks} { + string map {lon foob} longlon +} foobgfoob +test string-10.26 {string map, ABR checks} { + string map {longstring foob longstring bar} long +} long +test string-10.27 {string map, ABR checks} { + string map {long foob longstring bar} long +} foob +test string-10.28 {string map, ABR checks} { + string map {lon foob longstring bar} long +} foobg +test string-10.29 {string map, ABR checks} { + string map {lon foob longstring bar} longlo +} foobglo +test string-10.30 {string map, ABR checks} { + string map {lon foob longstring bar} longlon +} foobgfoob +test string-10.31 {string map, nasty sharing crash from [Bug 1018562]} { + set a {a b} + string map $a $a } {b b} -test string-11.1.$noComp {string match, too few args} { - list [catch {run {string match a}} msg] $msg -} {1 {wrong # args: should be "string match ?-nocase? pattern string"}} -test string-11.2.$noComp {string match, too many args} { - list [catch {run {string match a b c d}} msg] $msg -} {1 {wrong # args: should be "string match ?-nocase? pattern string"}} -test string-11.3.$noComp {string match} { - run {string match abc abc} -} 1 -test string-11.4.$noComp {string match} { - run {string mat abc abd} -} 0 -test string-11.5.$noComp {string match} { - run {string match ab*c abc} -} 1 -test string-11.6.$noComp {string match} { - run {string match ab**c abc} -} 1 -test string-11.7.$noComp {string match} { - run {string match ab* abcdef} -} 1 -test string-11.8.$noComp {string match} { - run {string match *c abc} -} 1 -test string-11.9.$noComp {string match} { - run {string match *3*6*9 0123456789} -} 1 -test string-11.9.1.$noComp {string match} { - run {string match *3*6*89 0123456789} -} 1 -test string-11.9.2.$noComp {string match} { - run {string match *3*456*89 0123456789} -} 1 -test string-11.9.3.$noComp {string match} { - run {string match *3*6* 0123456789} -} 1 -test string-11.9.4.$noComp {string match} { - run {string match *3*56* 0123456789} -} 1 -test string-11.9.5.$noComp {string match} { - run {string match *3*456*** 0123456789} -} 1 -test string-11.9.6.$noComp {string match} { - run {string match **3*456** 0123456789} -} 1 -test string-11.9.7.$noComp {string match} { - run {string match *3***456* 0123456789} -} 1 -test string-11.9.8.$noComp {string match} { - run {string match *3***\[456]* 0123456789} -} 1 -test string-11.9.9.$noComp {string match} { - run {string match *3***\[4-6]* 0123456789} -} 1 -test string-11.9.10.$noComp {string match} { - run {string match *3***\[4-6] 0123456789} -} 0 -test string-11.9.11.$noComp {string match} { - run {string match *3***\[4-6] 0123456} -} 1 -test string-11.10.$noComp {string match} { - run {string match *3*6*9 01234567890} -} 0 -test string-11.10.1.$noComp {string match} { - run {string match *3*6*89 01234567890} -} 0 -test string-11.10.2.$noComp {string match} { - run {string match *3*456*89 01234567890} -} 0 -test string-11.10.3.$noComp {string match} { - run {string match **3*456*89 01234567890} -} 0 -test string-11.10.4.$noComp {string match} { - run {string match *3*456***89 01234567890} -} 0 -test string-11.11.$noComp {string match} { - run {string match a?c abc} -} 1 -test string-11.12.$noComp {string match} { - run {string match a??c abc} -} 0 -test string-11.13.$noComp {string match} { - run {string match ?1??4???8? 0123456789} -} 1 -test string-11.14.$noComp {string match} { - run {string match {[abc]bc} abc} -} 1 -test string-11.15.$noComp {string match} { - run {string match {a[abc]c} abc} -} 1 -test string-11.16.$noComp {string match} { - run {string match {a[xyz]c} abc} -} 0 -test string-11.17.$noComp {string match} { - run {string match {12[2-7]45} 12345} -} 1 -test string-11.18.$noComp {string match} { - run {string match {12[ab2-4cd]45} 12345} -} 1 -test string-11.19.$noComp {string match} { - run {string match {12[ab2-4cd]45} 12b45} -} 1 -test string-11.20.$noComp {string match} { - run {string match {12[ab2-4cd]45} 12d45} -} 1 -test string-11.21.$noComp {string match} { - run {string match {12[ab2-4cd]45} 12145} -} 0 -test string-11.22.$noComp {string match} { - run {string match {12[ab2-4cd]45} 12545} -} 0 -test string-11.23.$noComp {string match} { - run {string match {a\*b} a*b} -} 1 -test string-11.24.$noComp {string match} { - run {string match {a\*b} ab} -} 0 -test string-11.25.$noComp {string match} { - run {string match {a\*\?\[\]\\\x} "a*?\[\]\\x"} -} 1 -test string-11.26.$noComp {string match} { - run {string match ** ""} -} 1 -test string-11.27.$noComp {string match} { - run {string match *. ""} -} 0 -test string-11.28.$noComp {string match} { - run {string match "" ""} -} 1 -test string-11.29.$noComp {string match} { - run {string match \[a a} -} 1 -test string-11.30.$noComp {string match, bad args} { - list [catch {run {string match - b c}} msg] $msg +test string-11.1 {string match, not enough args} { + list [catch {string match a} msg] $msg +} {1 {wrong # args: should be "string match ?-nocase? pattern string"}} +test string-11.2 {string match, too many args} { + list [catch {string match a b c d} msg] $msg +} {1 {wrong # args: should be "string match ?-nocase? pattern string"}} +test string-11.3 {string match} { + string match abc abc +} 1 +test string-11.4 {string match} { + string mat abc abd +} 0 +test string-11.5 {string match} { + string match ab*c abc +} 1 +test string-11.6 {string match} { + string match ab**c abc +} 1 +test string-11.7 {string match} { + string match ab* abcdef +} 1 +test string-11.8 {string match} { + string match *c abc +} 1 +test string-11.9 {string match} { + string match *3*6*9 0123456789 +} 1 +test string-11.9.1 {string match} { + string match *3*6*89 0123456789 +} 1 +test string-11.9.2 {string match} { + string match *3*456*89 0123456789 +} 1 +test string-11.9.3 {string match} { + string match *3*6* 0123456789 +} 1 +test string-11.9.4 {string match} { + string match *3*56* 0123456789 +} 1 +test string-11.9.5 {string match} { + string match *3*456*** 0123456789 +} 1 +test string-11.9.6 {string match} { + string match **3*456** 0123456789 +} 1 +test string-11.9.7 {string match} { + string match *3***456* 0123456789 +} 1 +test string-11.9.8 {string match} { + string match *3***\[456]* 0123456789 +} 1 +test string-11.9.9 {string match} { + string match *3***\[4-6]* 0123456789 +} 1 +test string-11.9.10 {string match} { + string match *3***\[4-6] 0123456789 +} 0 +test string-11.9.11 {string match} { + string match *3***\[4-6] 0123456 +} 1 +test string-11.10 {string match} { + string match *3*6*9 01234567890 +} 0 +test string-11.10.1 {string match} { + string match *3*6*89 01234567890 +} 0 +test string-11.10.2 {string match} { + string match *3*456*89 01234567890 +} 0 +test string-11.10.3 {string match} { + string match **3*456*89 01234567890 +} 0 +test string-11.10.4 {string match} { + string match *3*456***89 01234567890 +} 0 +test string-11.11 {string match} { + string match a?c abc +} 1 +test string-11.12 {string match} { + string match a??c abc +} 0 +test string-11.13 {string match} { + string match ?1??4???8? 0123456789 +} 1 +test string-11.14 {string match} { + string match {[abc]bc} abc +} 1 +test string-11.15 {string match} { + string match {a[abc]c} abc +} 1 +test string-11.16 {string match} { + string match {a[xyz]c} abc +} 0 +test string-11.17 {string match} { + string match {12[2-7]45} 12345 +} 1 +test string-11.18 {string match} { + string match {12[ab2-4cd]45} 12345 +} 1 +test string-11.19 {string match} { + string match {12[ab2-4cd]45} 12b45 +} 1 +test string-11.20 {string match} { + string match {12[ab2-4cd]45} 12d45 +} 1 +test string-11.21 {string match} { + string match {12[ab2-4cd]45} 12145 +} 0 +test string-11.22 {string match} { + string match {12[ab2-4cd]45} 12545 +} 0 +test string-11.23 {string match} { + string match {a\*b} a*b +} 1 +test string-11.24 {string match} { + string match {a\*b} ab +} 0 +test string-11.25 {string match} { + string match {a\*\?\[\]\\\x} "a*?\[\]\\x" +} 1 +test string-11.26 {string match} { + string match ** "" +} 1 +test string-11.27 {string match} { + string match *. "" +} 0 +test string-11.28 {string match} { + string match "" "" +} 1 +test string-11.29 {string match} { + string match \[a a +} 1 +test string-11.30 {string match, bad args} { + list [catch {string match - b c} msg] $msg } {1 {bad option "-": must be -nocase}} -test string-11.31.$noComp {string match case} { - run {string match a A} +test string-11.31 {string match case} { + string match a A } 0 -test string-11.32.$noComp {string match nocase} { - run {string match -n a A} -} 1 -test string-11.33.$noComp {string match nocase} { - run {string match -nocase a\334 A\374} -} 1 -test string-11.34.$noComp {string match nocase} { - run {string match -nocase a*f ABCDEf} -} 1 -test string-11.35.$noComp {string match case, false hope} { +test string-11.32 {string match nocase} { + string match -n a A +} 1 +test string-11.33 {string match nocase} { + string match -nocase a\334 A\374 +} 1 +test string-11.34 {string match nocase} { + string match -nocase a*f ABCDEf +} 1 +test string-11.35 {string match case, false hope} { # This is true because '_' lies between the A-Z and a-z ranges - run {string match {[A-z]} _} + string match {[A-z]} _ } 1 -test string-11.36.$noComp {string match nocase range} { +test string-11.36 {string match nocase range} { # This is false because although '_' lies between the A-Z and a-z ranges, # we lower case the end points before checking the ranges. - run {string match -nocase {[A-z]} _} -} 0 -test string-11.37.$noComp {string match nocase} { - run {string match -nocase {[A-fh-Z]} g} -} 0 -test string-11.38.$noComp {string match case, reverse range} { - run {string match {[A-fh-Z]} g} -} 1 -test string-11.39.$noComp {string match, *\ case} { - run {string match {*\abc} abc} -} 1 -test string-11.39.1.$noComp {string match, *\ case} { - run {string match {*ab\c} abc} -} 1 -test string-11.39.2.$noComp {string match, *\ case} { - run {string match {*ab\*} ab*} -} 1 -test string-11.39.3.$noComp {string match, *\ case} { - run {string match {*ab\*} abc} -} 0 -test string-11.39.4.$noComp {string match, *\ case} { - run {string match {*ab\\*} {ab\c}} -} 1 -test string-11.39.5.$noComp {string match, *\ case} { - run {string match {*ab\\*} {ab\*}} -} 1 -test string-11.40.$noComp {string match, *special case} { - run {string match {*[ab]} abc} -} 0 -test string-11.41.$noComp {string match, *special case} { - run {string match {*[ab]*} abc} -} 1 -test string-11.42.$noComp {string match, *special case} { - run {string match "*\\" "\\"} -} 0 -test string-11.43.$noComp {string match, *special case} { - run {string match "*\\\\" "\\"} -} 1 -test string-11.44.$noComp {string match, *special case} { - run {string match "*???" "12345"} -} 1 -test string-11.45.$noComp {string match, *special case} { - run {string match "*???" "12"} -} 0 -test string-11.46.$noComp {string match, *special case} { - run {string match "*\\*" "abc*"} -} 1 -test string-11.47.$noComp {string match, *special case} { - run {string match "*\\*" "*"} -} 1 -test string-11.48.$noComp {string match, *special case} { - run {string match "*\\*" "*abc"} -} 0 -test string-11.49.$noComp {string match, *special case} { - run {string match "?\\*" "a*"} -} 1 -test string-11.50.$noComp {string match, *special case} { - run {string match "\\" "\\"} -} 0 -test string-11.51.$noComp {string match; *, -nocase and UTF-8} { - run {string match -nocase [binary format I 717316707] \ - [binary format I 2028036707]} -} 1 -test string-11.52.$noComp {string match, null char in string} { + string match -nocase {[A-z]} _ +} 0 +test string-11.37 {string match nocase} { + string match -nocase {[A-fh-Z]} g +} 0 +test string-11.38 {string match case, reverse range} { + string match {[A-fh-Z]} g +} 1 +test string-11.39 {string match, *\ case} { + string match {*\abc} abc +} 1 +test string-11.39.1 {string match, *\ case} { + string match {*ab\c} abc +} 1 +test string-11.39.2 {string match, *\ case} { + string match {*ab\*} ab* +} 1 +test string-11.39.3 {string match, *\ case} { + string match {*ab\*} abc +} 0 +test string-11.39.4 {string match, *\ case} { + string match {*ab\\*} {ab\c} +} 1 +test string-11.39.5 {string match, *\ case} { + string match {*ab\\*} {ab\*} +} 1 +test string-11.40 {string match, *special case} { + string match {*[ab]} abc +} 0 +test string-11.41 {string match, *special case} { + string match {*[ab]*} abc +} 1 +test string-11.42 {string match, *special case} { + string match "*\\" "\\" +} 0 +test string-11.43 {string match, *special case} { + string match "*\\\\" "\\" +} 1 +test string-11.44 {string match, *special case} { + string match "*???" "12345" +} 1 +test string-11.45 {string match, *special case} { + string match "*???" "12" +} 0 +test string-11.46 {string match, *special case} { + string match "*\\*" "abc*" +} 1 +test string-11.47 {string match, *special case} { + string match "*\\*" "*" +} 1 +test string-11.48 {string match, *special case} { + string match "*\\*" "*abc" +} 0 +test string-11.49 {string match, *special case} { + string match "?\\*" "a*" +} 1 +test string-11.50 {string match, *special case} { + string match "\\" "\\" +} 0 +test string-11.51 {string match; *, -nocase and UTF-8} { + string match -nocase [binary format I 717316707] \ + [binary format I 2028036707] +} 1 +test string-11.52 {string match, null char in string} { set out "" set ptn "*abc*" foreach elem [list "\u0000@abc" "@abc" "\u0000@abc\u0000" "blahabcblah"] { - lappend out [run {string match $ptn $elem}] + lappend out [string match $ptn $elem] } set out } {1 1 1 1} -test string-11.53.$noComp {string match, null char in pattern} { +test string-11.53 {string match, null char in pattern} { set out "" foreach {ptn elem} [list \ "*\u0000abc\u0000" "\u0000abc\u0000" \ "*\u0000abc\u0000" "\u0000abc\u0000ef" \ "*\u0000abc\u0000*" "\u0000abc\u0000ef" \ "*\u0000abc\u0000" "@\u0000abc\u0000ef" \ "*\u0000abc\u0000*" "@\u0000abc\u0000ef" \ ] { - lappend out [run {string match $ptn $elem}] + lappend out [string match $ptn $elem] } set out } {1 0 1 0 1} -test string-11.54.$noComp {string match, failure} { +test string-11.54 {string match, failure} { set longString "" for {set i 0} {$i < 10} {incr i} { append longString "abcdefghijklmnopqrstuvwxy\u0000z01234567890123" } - run {string first $longString 123} - list [run {string match *cba* $longString}] \ - [run {string match *a*l*\u0000* $longString}] \ - [run {string match *a*l*\u0000*123 $longString}] \ - [run {string match *a*l*\u0000*123* $longString}] \ - [run {string match *a*l*\u0000*cba* $longString}] \ - [run {string match *===* $longString}] + string first $longString 123 + list [string match *cba* $longString] \ + [string match *a*l*\u0000* $longString] \ + [string match *a*l*\u0000*123 $longString] \ + [string match *a*l*\u0000*123* $longString] \ + [string match *a*l*\u0000*cba* $longString] \ + [string match *===* $longString] } {0 1 1 1 0 0} -test string-11.55.$noComp {string match, invalid binary optimization} { +test string-11.55 {string match, invalid binary optimization} { [format string] match \u0141 [binary format c 65] } 0 -test stringComp-12.1.0.$noComp {Bug 3588366: end-offsets before start} { - apply {s { - string range $s 0 end-5 - }} 12345 -} {} -test string-12.1.$noComp {string range} { - list [catch {run {string range}} msg] $msg -} {1 {wrong # args: should be "string range string first last"}} -test string-12.2.$noComp {string range} { - list [catch {run {string range a 1}} msg] $msg -} {1 {wrong # args: should be "string range string first last"}} -test string-12.3.$noComp {string range} { - list [catch {run {string range a 1 2 3}} msg] $msg -} {1 {wrong # args: should be "string range string first last"}} -test string-12.4.$noComp {string range} { - run {string range abcdefghijklmnop 2 14} -} {cdefghijklmno} -test string-12.5.$noComp {string range, last > length} { - run {string range abcdefghijklmnop 7 1000} +test string-12.1 {string range} { + list [catch {string range} msg] $msg +} {1 {wrong # args: should be "string range string first last"}} +test string-12.2 {string range} { + list [catch {string range a 1} msg] $msg +} {1 {wrong # args: should be "string range string first last"}} +test string-12.3 {string range} { + list [catch {string range a 1 2 3} msg] $msg +} {1 {wrong # args: should be "string range string first last"}} +test string-12.4 {string range} { + string range abcdefghijklmnop 2 14 +} {cdefghijklmno} +test string-12.5 {string range, last > length} { + string range abcdefghijklmnop 7 1000 } {hijklmnop} -test string-12.6.$noComp {string range} { - run {string range abcdefghijklmnop 10 end} +test string-12.6 {string range} { + string range abcdefghijklmnop 10 end } {klmnop} -test string-12.7.$noComp {string range, last < first} { - run {string range abcdefghijklmnop 10 9} +test string-12.7 {string range, last < first} { + string range abcdefghijklmnop 10 9 } {} -test string-12.8.$noComp {string range, first < 0} { - run {string range abcdefghijklmnop -3 2} +test string-12.8 {string range, first < 0} { + string range abcdefghijklmnop -3 2 } {abc} -test string-12.9.$noComp {string range} { - run {string range abcdefghijklmnop -3 -2} -} {} -test string-12.10.$noComp {string range} { - run {string range abcdefghijklmnop 1000 1010} -} {} -test string-12.11.$noComp {string range} { - run {string range abcdefghijklmnop -100 end} +test string-12.9 {string range} { + string range abcdefghijklmnop -3 -2 +} {} +test string-12.10 {string range} { + string range abcdefghijklmnop 1000 1010 +} {} +test string-12.11 {string range} { + string range abcdefghijklmnop -100 end } {abcdefghijklmnop} -test string-12.12.$noComp {string range} { - list [catch {run {string range abc abc 1}} msg] $msg +test string-12.12 {string range} { + list [catch {string range abc abc 1} msg] $msg } {1 {bad index "abc": must be integer?[+-]integer? or end?[+-]integer?}} -test string-12.13.$noComp {string range} { - list [catch {run {string range abc 1 eof}} msg] $msg +test string-12.13 {string range} { + list [catch {string range abc 1 eof} msg] $msg } {1 {bad index "eof": must be integer?[+-]integer? or end?[+-]integer?}} -test string-12.14.$noComp {string range} { - run {string range abcdefghijklmnop end-1 end} +test string-12.14 {string range} { + string range abcdefghijklmnop end-1 end } {op} -test string-12.15.$noComp {string range} { - run {string range abcdefghijklmnop end 1000} +test string-12.15 {string range} { + string range abcdefghijklmnop end 1000 } {p} -test string-12.16.$noComp {string range} { - run {string range abcdefghijklmnop end end-1} +test string-12.16 {string range} { + string range abcdefghijklmnop end end-1 } {} -test string-12.17.$noComp {string range, unicode} { - run {string range ab\u7266cdefghijklmnop 5 5} +test string-12.17 {string range, unicode} { + string range ab\u7266cdefghijklmnop 5 5 } e -test string-12.18.$noComp {string range, unicode} { - run {string range ab\u7266cdefghijklmnop 2 3} +test string-12.18 {string range, unicode} { + string range ab\u7266cdefghijklmnop 2 3 } \u7266c -test string-12.19.$noComp {string range, bytearray object} { +test string-12.19 {string range, bytearray object} { set b [binary format I* {0x50515253 0x52}] - set r1 [run {string range $b 1 end-1}] - set r2 [run {string range $b 1 6}] - run {string equal $r1 $r2} + set r1 [string range $b 1 end-1] + set r2 [string range $b 1 6] + string equal $r1 $r2 } 1 -test string-12.20.$noComp {string range, out of bounds indices} { - run {string range \u00ff 0 1} -} \u00ff +test string-12.20 {string range, out of bounds indices} { + string range \u00FF 0 1 +} \u00FF # Bug 1410553 -test string-12.21.$noComp {string range, regenerates correct reps, bug 1410553} { +test string-12.21 {string range, regenerates correct reps, bug 1410553} { set bytes "\x00 \x03 \x41" set rxBuffer {} foreach ch $bytes { append rxBuffer $ch if {$ch eq "\x03"} { - run {string length $rxBuffer} + string length $rxBuffer } } - set rxCRC [run {string range $rxBuffer end-1 end}] + set rxCRC [string range $rxBuffer end-1 end] binary scan [join $bytes {}] "H*" input_hex binary scan $rxBuffer "H*" rxBuffer_hex binary scan $rxCRC "H*" rxCRC_hex list $input_hex $rxBuffer_hex $rxCRC_hex } {000341 000341 0341} -test string-12.22.$noComp {string range, shimmering binary/index} { +test string-12.22 {string range, shimmering binary/index} { set s 0000000001 binary scan $s a* x - run {string range $s $s end} + string range $s $s end } 000000001 -test string-12.23.$noComp {string range, surrogates, bug [11ae2be95dac9417]} tip389 { - run {list [string range a\U100000b 1 1] [string range a\U100000b 2 2] [string range a\U100000b 3 3]} +test string-12.23 {string range, surrogates, bug [11ae2be95dac9417]} utf16 { + list [string range a\U100000b 1 1] [string range a\U100000b 2 2] [string range a\U100000b 3 3] } [list \U100000 {} b] -test string-13.1.$noComp {string repeat} { - list [catch {run {string repeat}} msg] $msg -} {1 {wrong # args: should be "string repeat string count"}} -test string-13.2.$noComp {string repeat} { - list [catch {run {string repeat abc 10 oops}} msg] $msg -} {1 {wrong # args: should be "string repeat string count"}} -test string-13.3.$noComp {string repeat} { - run {string repeat {} 100} -} {} -test string-13.4.$noComp {string repeat} { - run {string repeat { } 5} +test string-13.1 {string repeat} { + list [catch {string repeat} msg] $msg +} {1 {wrong # args: should be "string repeat string count"}} +test string-13.2 {string repeat} { + list [catch {string repeat abc 10 oops} msg] $msg +} {1 {wrong # args: should be "string repeat string count"}} +test string-13.3 {string repeat} { + string repeat {} 100 +} {} +test string-13.4 {string repeat} { + string repeat { } 5 } { } -test string-13.5.$noComp {string repeat} { - run {string repeat abc 3} +test string-13.5 {string repeat} { + string repeat abc 3 } {abcabcabc} -test string-13.6.$noComp {string repeat} { - run {string repeat abc -1} +test string-13.6 {string repeat} { + string repeat abc -1 } {} -test string-13.7.$noComp {string repeat} { - list [catch {run {string repeat abc end}} msg] $msg +test string-13.7 {string repeat} { + list [catch {string repeat abc end} msg] $msg } {1 {expected integer but got "end"}} -test string-13.8.$noComp {string repeat} { - run {string repeat {} -1000} -} {} -test string-13.9.$noComp {string repeat} { - run {string repeat {} 0} -} {} -test string-13.10.$noComp {string repeat} { - run {string repeat def 0} -} {} -test string-13.11.$noComp {string repeat} { - run {string repeat def 1} +test string-13.8 {string repeat} { + string repeat {} -1000 +} {} +test string-13.9 {string repeat} { + string repeat {} 0 +} {} +test string-13.10 {string repeat} { + string repeat def 0 +} {} +test string-13.11 {string repeat} { + string repeat def 1 } def -test string-13.12.$noComp {string repeat} { - run {string repeat ab\u7266cd 3} +test string-13.12 {string repeat} { + string repeat ab\u7266cd 3 } ab\u7266cdab\u7266cdab\u7266cd -test string-13.13.$noComp {string repeat} { - run {string repeat \x00 3} +test string-13.13 {string repeat} { + string repeat \x00 3 } \x00\x00\x00 -test string-13.14.$noComp {string repeat} { +test string-13.14 {string repeat} { # The string range will ensure us that string repeat gets a unicode string - run {string repeat [run {string range ab\u7266cd 2 3}] 3} + string repeat [string range ab\u7266cd 2 3] 3 } \u7266c\u7266c\u7266c -test string-14.1.$noComp {string replace} { - list [catch {run {string replace}} msg] $msg -} {1 {wrong # args: should be "string replace string first last ?string?"}} -test string-14.2.$noComp {string replace} { - list [catch {run {string replace a 1}} msg] $msg -} {1 {wrong # args: should be "string replace string first last ?string?"}} -test string-14.3.$noComp {string replace} { - list [catch {run {string replace a 1 2 3 4}} msg] $msg -} {1 {wrong # args: should be "string replace string first last ?string?"}} -test string-14.4.$noComp {string replace} { -} {} -test string-14.5.$noComp {string replace} { - run {string replace abcdefghijklmnop 2 14} +test string-14.1 {string replace} { + list [catch {string replace} msg] $msg +} {1 {wrong # args: should be "string replace string first last ?string?"}} +test string-14.2 {string replace} { + list [catch {string replace a 1} msg] $msg +} {1 {wrong # args: should be "string replace string first last ?string?"}} +test string-14.3 {string replace} { + list [catch {string replace a 1 2 3 4} msg] $msg +} {1 {wrong # args: should be "string replace string first last ?string?"}} +test string-14.4 {string replace} { +} {} +test string-14.5 {string replace} { + string replace abcdefghijklmnop 2 14 } {abp} -test string-14.6.$noComp {string replace} { - run {string replace abcdefghijklmnop 7 1000} +test string-14.6 {string replace} { + string replace abcdefghijklmnop 7 1000 } {abcdefg} -test string-14.7.$noComp {string replace} { - run {string replace abcdefghijklmnop 10 end} +test string-14.7 {string replace} { + string replace abcdefghijklmnop 10 end } {abcdefghij} -test string-14.8.$noComp {string replace} { - run {string replace abcdefghijklmnop 10 9} +test string-14.8 {string replace} { + string replace abcdefghijklmnop 10 9 } {abcdefghijklmnop} -test string-14.9.$noComp {string replace} { - run {string replace abcdefghijklmnop -3 2} +test string-14.9 {string replace} { + string replace abcdefghijklmnop -3 2 } {defghijklmnop} -test string-14.10.$noComp {string replace} { - run {string replace abcdefghijklmnop -3 -2} -} {abcdefghijklmnop} -test string-14.11.$noComp {string replace} { - run {string replace abcdefghijklmnop 1000 1010} -} {abcdefghijklmnop} -test string-14.12.$noComp {string replace} { - run {string replace abcdefghijklmnop -100 end} -} {} -test string-14.13.$noComp {string replace} { - list [catch {run {string replace abc abc 1}} msg] $msg -} {1 {bad index "abc": must be integer?[+-]integer? or end?[+-]integer?}} -test string-14.14.$noComp {string replace} { - list [catch {run {string replace abc 1 eof}} msg] $msg +test string-14.10 {string replace} { + string replace abcdefghijklmnop -3 -2 +} {abcdefghijklmnop} +test string-14.11 {string replace} { + string replace abcdefghijklmnop 1000 1010 +} {abcdefghijklmnop} +test string-14.12 {string replace} { + string replace abcdefghijklmnop -100 end +} {} +test string-14.13 {string replace} { + list [catch {string replace abc abc 1} msg] $msg +} {1 {bad index "abc": must be integer?[+-]integer? or end?[+-]integer?}} +test string-14.14 {string replace} { + list [catch {string replace abc 1 eof} msg] $msg } {1 {bad index "eof": must be integer?[+-]integer? or end?[+-]integer?}} -test string-14.15.$noComp {string replace} { - run {string replace abcdefghijklmnop end-10 end-2 NEW} +test string-14.15 {string replace} { + string replace abcdefghijklmnop end-10 end-2 NEW } {abcdeNEWop} -test string-14.16.$noComp {string replace} { - run {string replace abcdefghijklmnop 0 end foo} +test string-14.16 {string replace} { + string replace abcdefghijklmnop 0 end foo } {foo} -test string-14.17.$noComp {string replace} { - run {string replace abcdefghijklmnop end end-1} -} {abcdefghijklmnop} -test string-14.18.$noComp {string replace} { - run {string replace abcdefghijklmnop 10 9 XXX} -} {abcdefghijklmnop} -test string-14.19.$noComp {string replace} { - run {string replace {} -1 0 A} +test string-14.17 {string replace} { + string replace abcdefghijklmnop end end-1 +} {abcdefghijklmnop} +test string-14.18 {string replace} { + string replace abcdefghijklmnop 10 9 XXX +} {abcdefghijklmnop} +test string-14.19 {string replace} { + string replace {} -1 0 A } A -test string-14.20.$noComp {string replace} { - run {string replace [makeByteArray abcdefghijklmnop] end-10 end-2\ - [makeByteArray NEW]} -} {abcdeNEWop} - - -test stringComp-14.21.$noComp {Bug 82e7f67325} { - apply {x { - set a [join $x {}] - lappend b [string length [string replace ___! 0 2 $a]] - lappend b [string length [string replace ___! 0 2 $a[unset a]]] - }} {a b} -} {3 3} -test stringComp-14.22.$noComp {Bug 82e7f67325} memory { - # As in stringComp-14.1, but make sure we don't retain too many refs - leaktest { - apply {x { - set a [join $x {}] - lappend b [string length [string replace ___! 0 2 $a]] - lappend b [string length [string replace ___! 0 2 $a[unset a]]] - }} {a b} - } -} {0} -test stringComp-14.23.$noComp {Bug 0dca3bfa8f} { - apply {arg { - set argCopy $arg - set arg [string replace $arg 1 2 aa] - # Crashes in comparison before fix - expr {$arg ne $argCopy} - }} abcde -} 1 -test stringComp-14.24.$noComp {Bug 1af8de570511} { - apply {{x y} { - # Generate an unshared string value - set val "" - for { set i 0 } { $i < $x } { incr i } { - set val [format "0%s" $val] - } - string replace $val[unset val] 1 1 $y - }} 4 x -} 0x00 -test stringComp-14.25.$noComp {} { - string length [string replace [string repeat a\u00fe 2] 3 end {}] -} 3 - -test string-15.1.$noComp {string tolower too few args} { - list [catch {run {string tolower}} msg] $msg -} {1 {wrong # args: should be "string tolower string ?first? ?last?"}} -test string-15.2.$noComp {string tolower bad args} { - list [catch {run {string tolower a b}} msg] $msg -} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}} -test string-15.3.$noComp {string tolower too many args} { - list [catch {run {string tolower ABC 1 end oops}} msg] $msg -} {1 {wrong # args: should be "string tolower string ?first? ?last?"}} -test string-15.4.$noComp {string tolower} { - run {string tolower ABCDeF} -} {abcdef} -test string-15.5.$noComp {string tolower} { - run {string tolower "ABC XyZ"} -} {abc xyz} -test string-15.6.$noComp {string tolower} { - run {string tolower {123#$&*()}} -} {123#$&*()} -test string-15.7.$noComp {string tolower} { - run {string tolower ABC 1} -} AbC -test string-15.8.$noComp {string tolower} { - run {string tolower ABC 1 end} -} Abc -test string-15.9.$noComp {string tolower} { - run {string tolower ABC 0 end-1} -} abC -test string-15.10.$noComp {string tolower, unicode} { - run {string tolower ABCabc\xc7\xe7} -} "abcabc\xe7\xe7" -test string-15.11.$noComp {string tolower, compiled} { - lindex [run {string tolower [list A B [list C]]}] 1 + +test string-15.1 {string tolower not enough args} { + list [catch {string tolower} msg] $msg +} {1 {wrong # args: should be "string tolower string ?first? ?last?"}} +test string-15.2 {string tolower bad args} { + list [catch {string tolower a b} msg] $msg +} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}} +test string-15.3 {string tolower too many args} { + list [catch {string tolower ABC 1 end oops} msg] $msg +} {1 {wrong # args: should be "string tolower string ?first? ?last?"}} +test string-15.4 {string tolower} { + string tolower ABCDeF +} {abcdef} +test string-15.5 {string tolower} { + string tolower "ABC XyZ" +} {abc xyz} +test string-15.6 {string tolower} { + string tolower {123#$&*()} +} {123#$&*()} +test string-15.7 {string tolower} { + string tolower ABC 1 +} AbC +test string-15.8 {string tolower} { + string tolower ABC 1 end +} Abc +test string-15.9 {string tolower} { + string tolower ABC 0 end-1 +} abC +test string-15.10 {string tolower, unicode} { + string tolower ABCabc\xc7\xe7 +} "abcabc\xe7\xe7" +test string-15.11 {string tolower, compiled} { + lindex [string tolower [list A B [list C]]] 1 } b -test string-16.1.$noComp {string toupper} { - list [catch {run {string toupper}} msg] $msg -} {1 {wrong # args: should be "string toupper string ?first? ?last?"}} -test string-16.2.$noComp {string toupper} { - list [catch {run {string toupper a b}} msg] $msg -} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}} -test string-16.3.$noComp {string toupper} { - list [catch {run {string toupper a 1 end oops}} msg] $msg -} {1 {wrong # args: should be "string toupper string ?first? ?last?"}} -test string-16.4.$noComp {string toupper} { - run {string toupper abCDEf} -} {ABCDEF} -test string-16.5.$noComp {string toupper} { - run {string toupper "abc xYz"} -} {ABC XYZ} -test string-16.6.$noComp {string toupper} { - run {string toupper {123#$&*()}} +test string-16.1 {string toupper} { + list [catch {string toupper} msg] $msg +} {1 {wrong # args: should be "string toupper string ?first? ?last?"}} +test string-16.2 {string toupper} { + list [catch {string toupper a b} msg] $msg +} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}} +test string-16.3 {string toupper} { + list [catch {string toupper a 1 end oops} msg] $msg +} {1 {wrong # args: should be "string toupper string ?first? ?last?"}} +test string-16.4 {string toupper} { + string toupper abCDEf +} {ABCDEF} +test string-16.5 {string toupper} { + string toupper "abc xYz" +} {ABC XYZ} +test string-16.6 {string toupper} { + string toupper {123#$&*()} } {123#$&*()} -test string-16.7.$noComp {string toupper} { - run {string toupper abc 1} +test string-16.7 {string toupper} { + string toupper abc 1 } aBc -test string-16.8.$noComp {string toupper} { - run {string toupper abc 1 end} +test string-16.8 {string toupper} { + string toupper abc 1 end } aBC -test string-16.9.$noComp {string toupper} { - run {string toupper abc 0 end-1} +test string-16.9 {string toupper} { + string toupper abc 0 end-1 } ABc -test string-16.10.$noComp {string toupper, unicode} { - run {string toupper ABCabc\xc7\xe7} +test string-16.10 {string toupper, unicode} { + string toupper ABCabc\xc7\xe7 } "ABCABC\xc7\xc7" -test string-16.11.$noComp {string toupper, compiled} { - lindex [run {string toupper [list a b [list c]]}] 1 +test string-16.11 {string toupper, compiled} { + lindex [string toupper [list a b [list c]]] 1 } B -test string-17.1.$noComp {string totitle} { - list [catch {run {string totitle}} msg] $msg -} {1 {wrong # args: should be "string totitle string ?first? ?last?"}} -test string-17.2.$noComp {string totitle} { - list [catch {run {string totitle a b}} msg] $msg -} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}} -test string-17.3.$noComp {string totitle} { - run {string totitle abCDEf} -} {Abcdef} -test string-17.4.$noComp {string totitle} { - run {string totitle "abc xYz"} -} {Abc xyz} -test string-17.5.$noComp {string totitle} { - run {string totitle {123#$&*()}} -} {123#$&*()} -test string-17.6.$noComp {string totitle, unicode} { - run {string totitle ABCabc\xc7\xe7} -} "Abcabc\xe7\xe7" -test string-17.7.$noComp {string totitle, unicode} { - run {string totitle \u01f3BCabc\xc7\xe7} -} "\u01f2bcabc\xe7\xe7" -test string-17.8.$noComp {string totitle, compiled} { - lindex [run {string totitle [list aa bb [list cc]]}] 0 -} Aa -test string-17.9.$noComp {string totitle, surrogates, bug [11ae2be95dac9417]} tip389 { - run {list [string totitle a\U118c0c 1 1] [string totitle a\U118c0c 2 2] \ - [string totitle a\U118c0c 3 3]} -} [list a\U118a0c a\U118c0C a\U118c0C] - -test string-18.1.$noComp {string trim} { - list [catch {run {string trim}} msg] $msg -} {1 {wrong # args: should be "string trim string ?chars?"}} -test string-18.2.$noComp {string trim} { - list [catch {run {string trim a b c}} msg] $msg -} {1 {wrong # args: should be "string trim string ?chars?"}} -test string-18.3.$noComp {string trim} { - run {string trim " XYZ "} -} {XYZ} -test string-18.4.$noComp {string trim} { - run {string trim "\t\nXYZ\t\n\r\n"} -} {XYZ} -test string-18.5.$noComp {string trim} { - run {string trim " A XYZ A "} -} {A XYZ A} -test string-18.6.$noComp {string trim} { - run {string trim "XXYYZZABC XXYYZZ" ZYX} -} {ABC } -test string-18.7.$noComp {string trim} { - run {string trim " \t\r "} -} {} -test string-18.8.$noComp {string trim} { - run {string trim {abcdefg} {}} -} {abcdefg} -test string-18.9.$noComp {string trim} { - run {string trim {}} -} {} -test string-18.10.$noComp {string trim} { - run {string trim ABC DEF} -} {ABC} -test string-18.11.$noComp {string trim, unicode} { - run {string trim "\xe7\xe8 AB\xe7C \xe8\xe7" \xe7\xe8} -} " AB\xe7C " -test string-18.12.$noComp {string trim, unicode default} { - run {string trim \ufeff\x00\u0085\u00a0\u1680\u180eABC\u1361\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200a\u200b\u2028\u2029\u202f\u205f\u3000} +test string-17.1 {string totitle} { + list [catch {string totitle} msg] $msg +} {1 {wrong # args: should be "string totitle string ?first? ?last?"}} +test string-17.2 {string totitle} { + list [catch {string totitle a b} msg] $msg +} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}} +test string-17.3 {string totitle} { + string totitle abCDEf +} {Abcdef} +test string-17.4 {string totitle} { + string totitle "abc xYz" +} {Abc xyz} +test string-17.5 {string totitle} { + string totitle {123#$&*()} +} {123#$&*()} +test string-17.6 {string totitle, unicode} { + string totitle ABCabc\xC7\xE7 +} "Abcabc\xE7\xE7" +test string-17.7 {string totitle, unicode} { + string totitle \u01F3BCabc\xc7\xe7 +} "\u01F2bcabc\xe7\xe7" +test string-17.8 {string totitle, compiled} { + lindex [string totitle [list aa bb [list cc]]] 0 +} Aa + +test string-18.1 {string trim} { + list [catch {string trim} msg] $msg +} {1 {wrong # args: should be "string trim string ?chars?"}} +test string-18.2 {string trim} { + list [catch {string trim a b c} msg] $msg +} {1 {wrong # args: should be "string trim string ?chars?"}} +test string-18.3 {string trim} { + string trim " XYZ " +} {XYZ} +test string-18.4 {string trim} { + string trim "\t\nXYZ\t\n\r\n" +} {XYZ} +test string-18.5 {string trim} { + string trim " A XYZ A " +} {A XYZ A} +test string-18.6 {string trim} { + string trim "XXYYZZABC XXYYZZ" ZYX +} {ABC } +test string-18.7 {string trim} { + string trim " \t\r " +} {} +test string-18.8 {string trim} { + string trim {abcdefg} {} +} {abcdefg} +test string-18.9 {string trim} { + string trim {} +} {} +test string-18.10 {string trim} { + string trim ABC DEF +} {ABC} +test string-18.11 {string trim, unicode} { + string trim "\xe7\xe8 AB\xe7C \xe8\xe7" \xe7\xe8 +} " AB\xe7C " +test string-18.12 {string trim, unicode default} { + string trim \uFEFF\x00\u0085\u00A0\u1680\u180EABC\u1361\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200A\u200B\u2028\u2029\u202F\u205F\u3000 } ABC\u1361 -test string-19.1.$noComp {string trimleft} { - list [catch {run {string trimleft}} msg] $msg +test string-19.1 {string trimleft} { + list [catch {string trimleft} msg] $msg } {1 {wrong # args: should be "string trimleft string ?chars?"}} -test string-19.2.$noComp {string trimleft} { - run {string trimleft " XYZ "} +test string-19.2 {string trimleft} { + string trimleft " XYZ " } {XYZ } -test string-19.3.$noComp {string trimleft, unicode default} { - run {string trimleft \ufeff\u0085\u00a0\x00\u1680\u180e\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200a\u200b\u2028\u2029\u202f\u205f\u3000\u1361ABC} +test string-19.3 {string trimleft, unicode default} { + string trimleft \uFEFF\u0085\u00A0\x00\u1680\u180E\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200A\u200B\u2028\u2029\u202F\u205F\u3000\u1361ABC } \u1361ABC -test string-20.1.$noComp {string trimright errors} { - list [catch {run {string trimright}} msg] $msg +test string-20.1 {string trimright errors} { + list [catch {string trimright} msg] $msg } {1 {wrong # args: should be "string trimright string ?chars?"}} -test string-20.2.$noComp {string trimright errors} { - list [catch {run {string trimg a}} msg] $msg -} {1 {unknown or ambiguous subcommand "trimg": must be bytelength, cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} -test string-20.3.$noComp {string trimright} { - run {string trimright " XYZ "} +test string-20.2 {string trimright errors} { + list [catch {string trimg a} msg] $msg +} {1 {unknown or ambiguous subcommand "trimg": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +test string-20.3 {string trimright} { + string trimright " XYZ " } { XYZ} -test string-20.4.$noComp {string trimright} { - run {string trimright " "} -} {} -test string-20.5.$noComp {string trimright} { - run {string trimright ""} -} {} -test string-20.6.$noComp {string trimright, unicode default} { - run {string trimright ABC\u1361\u0085\x00\u00a0\u1680\u180e\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200a\u200b\u2028\u2029\u202f\u205f\u3000} +test string-20.4 {string trimright} { + string trimright " " +} {} +test string-20.5 {string trimright} { + string trimright "" +} {} +test string-20.6 {string trimright, unicode default} { + string trimright ABC\u1361\u0085\x00\u00A0\u1680\u180E\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200A\u200B\u2028\u2029\u202F\u205F\u3000 } ABC\u1361 - -test string-21.1.$noComp {string wordend} { - list [catch {run {string wordend a}} msg] $msg -} {1 {wrong # args: should be "string wordend string index"}} -test string-21.2.$noComp {string wordend} { - list [catch {run {string wordend a b c}} msg] $msg -} {1 {wrong # args: should be "string wordend string index"}} -test string-21.3.$noComp {string wordend} { - list [catch {run {string wordend a gorp}} msg] $msg -} {1 {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?}} -test string-21.4.$noComp {string wordend} { - run {string wordend abc. -1} -} 3 -test string-21.5.$noComp {string wordend} { - run {string wordend abc. 100} -} 4 -test string-21.6.$noComp {string wordend} { - run {string wordend "word_one two three" 2} -} 8 -test string-21.7.$noComp {string wordend} { - run {string wordend "one .&# three" 5} -} 6 -test string-21.8.$noComp {string wordend} { - run {string worde "x.y" 0} -} 1 -test string-21.9.$noComp {string wordend} { - run {string worde "x.y" end-1} -} 2 -test string-21.10.$noComp {string wordend, unicode} { - run {string wordend "xyz\u00c7de fg" 0} -} 6 -test string-21.11.$noComp {string wordend, unicode} { - run {string wordend "xyz\uc700de fg" 0} -} 6 -test string-21.12.$noComp {string wordend, unicode} { - run {string wordend "xyz\u203fde fg" 0} -} 6 -test string-21.13.$noComp {string wordend, unicode} { - run {string wordend "xyz\u2045de fg" 0} -} 3 -test string-21.14.$noComp {string wordend, unicode} { - run {string wordend "\uc700\uc700 abc" 8} -} 6 - -test string-22.1.$noComp {string wordstart} { - list [catch {run {string word a}} msg] $msg -} {1 {unknown or ambiguous subcommand "word": must be bytelength, cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} -test string-22.2.$noComp {string wordstart} { - list [catch {run {string wordstart a}} msg] $msg -} {1 {wrong # args: should be "string wordstart string index"}} -test string-22.3.$noComp {string wordstart} { - list [catch {run {string wordstart a b c}} msg] $msg -} {1 {wrong # args: should be "string wordstart string index"}} -test string-22.4.$noComp {string wordstart} { - list [catch {run {string wordstart a gorp}} msg] $msg -} {1 {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?}} -test string-22.5.$noComp {string wordstart} { - run {string wordstart "one two three_words" 400} -} 8 -test string-22.6.$noComp {string wordstart} { - run {string wordstart "one two three_words" 2} -} 0 -test string-22.7.$noComp {string wordstart} { - run {string wordstart "one two three_words" -2} -} 0 -test string-22.8.$noComp {string wordstart} { - run {string wordstart "one .*&^ three" 6} -} 6 -test string-22.9.$noComp {string wordstart} { - run {string wordstart "one two three" 4} -} 4 -test string-22.10.$noComp {string wordstart} { - run {string wordstart "one two three" end-5} -} 7 -test string-22.11.$noComp {string wordstart, unicode} { - run {string wordstart "one tw\u00c7o three" 7} -} 4 -test string-22.12.$noComp {string wordstart, unicode} { - run {string wordstart "ab\uc700\uc700 cdef ghi" 12} -} 10 -test string-22.13.$noComp {string wordstart, unicode} { - run {string wordstart "\uc700\uc700 abc" 8} -} 3 - -test string-23.0.$noComp {string is boolean, Bug 1187123} testindexobj { +test string-20.7 {string trim on not valid utf-8 sequence (consider NTS as continuation char), bug [c61818e4c9]} testbytestring { + set result {} + set a [testbytestring \xc0\x80\xA0] + set b foo$a + set m [list \u0000 U \xA0 V [testbytestring \xA0] W] + lappend result [string map $m $b] + lappend result [string map $m [string trimright $b x]] + lappend result [string map $m [string trimright $b \u0000]] + lappend result [string map $m [string trimleft $b fox]] + lappend result [string map $m [string trimleft $b fo\u0000]] + lappend result [string map $m [string trim $b fox]] + lappend result [string map $m [string trim $b fo\u0000]] +} [list {*}[lrepeat 3 fooUV] {*}[lrepeat 2 UV V]] +test string-20.8 {[c61818e4c9] [string trimright] fails when UtfPrev is ok} testbytestring { + set result {} + set a [testbytestring \xE8\xA0] + set b foo$a + set m [list \xE8 U \xA0 V [testbytestring \xE8] W [testbytestring \xA0] X]] + lappend result [string map $m $b] + lappend result [string map $m [string trimright $b x]] + lappend result [string map $m [string trimright $b \xE8]] + lappend result [string map $m [string trimright $b [bytestring \xE8]]] + lappend result [string map $m [string trimright $b \xA0]] + lappend result [string map $m [string trimright $b [bytestring \xA0]]] + lappend result [string map $m [string trimright $b \xE8\xA0]] + lappend result [string map $m [string trimright $b [bytestring \xE8\xA0]]] + lappend result [string map $m [string trimright $b \u0000]] +} [list {*}[lrepeat 4 fooUV] {*}[lrepeat 2 fooU] {*}[lrepeat 2 foo] fooUV] + +test string-21.1 {string wordend} { + list [catch {string wordend a} msg] $msg +} {1 {wrong # args: should be "string wordend string index"}} +test string-21.2 {string wordend} { + list [catch {string wordend a b c} msg] $msg +} {1 {wrong # args: should be "string wordend string index"}} +test string-21.3 {string wordend} { + list [catch {string wordend a gorp} msg] $msg +} {1 {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?}} +test string-21.4 {string wordend} { + string wordend abc. -1 +} 3 +test string-21.5 {string wordend} { + string wordend abc. 100 +} 4 +test string-21.6 {string wordend} { + string wordend "word_one two three" 2 +} 8 +test string-21.7 {string wordend} { + string wordend "one .&# three" 5 +} 6 +test string-21.8 {string wordend} { + string worde "x.y" 0 +} 1 +test string-21.9 {string wordend} { + string worde "x.y" end-1 +} 2 +test string-21.10 {string wordend, unicode} { + string wordend "xyz\u00C7de fg" 0 +} 6 +test string-21.11 {string wordend, unicode} { + string wordend "xyz\uC700de fg" 0 +} 6 +test string-21.12 {string wordend, unicode} { + string wordend "xyz\u203Fde fg" 0 +} 6 +test string-21.13 {string wordend, unicode} { + string wordend "xyz\u2045de fg" 0 +} 3 +test string-21.14 {string wordend, unicode} { + string wordend "\uC700\uC700 abc" 8 +} 6 + +test string-22.1 {string wordstart} { + list [catch {string word a} msg] $msg +} {1 {unknown or ambiguous subcommand "word": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +test string-22.2 {string wordstart} { + list [catch {string wordstart a} msg] $msg +} {1 {wrong # args: should be "string wordstart string index"}} +test string-22.3 {string wordstart} { + list [catch {string wordstart a b c} msg] $msg +} {1 {wrong # args: should be "string wordstart string index"}} +test string-22.4 {string wordstart} { + list [catch {string wordstart a gorp} msg] $msg +} {1 {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?}} +test string-22.5 {string wordstart} { + string wordstart "one two three_words" 400 +} 8 +test string-22.6 {string wordstart} { + string wordstart "one two three_words" 2 +} 0 +test string-22.7 {string wordstart} { + string wordstart "one two three_words" -2 +} 0 +test string-22.8 {string wordstart} { + string wordstart "one .*&^ three" 6 +} 6 +test string-22.9 {string wordstart} { + string wordstart "one two three" 4 +} 4 +test string-22.10 {string wordstart} { + string wordstart "one two three" end-5 +} 7 +test string-22.11 {string wordstart, unicode} { + string wordstart "one tw\u00C7o three" 7 +} 4 +test string-22.12 {string wordstart, unicode} { + string wordstart "ab\uC700\uC700 cdef ghi" 12 +} 10 +test string-22.13 {string wordstart, unicode} { + string wordstart "\uC700\uC700 abc" 8 +} 3 +test string-22.14 {string wordstart, invalid UTF-8} testbytestring { + # See Bug c61818e4c9 + set demo [testbytestring "abc def\xE0\xA9ghi"] + string index $demo [string wordstart $demo 10] +} g + +test string-23.0 {string is boolean, Bug 1187123} testindexobj { set x 5 catch {testindexobj $x foo bar soom} - run {string is boolean $x} + string is boolean $x } 0 -test string-23.1.$noComp {string is command with empty string} { +test string-23.1 {string is command with empty string} { set s "" list \ - [run {string is alnum $s}] \ - [run {string is alpha $s}] \ - [run {string is ascii $s}] \ - [run {string is control $s}] \ - [run {string is boolean $s}] \ - [run {string is digit $s}] \ - [run {string is double $s}] \ - [run {string is false $s}] \ - [run {string is graph $s}] \ - [run {string is integer $s}] \ - [run {string is lower $s}] \ - [run {string is print $s}] \ - [run {string is punct $s}] \ - [run {string is space $s}] \ - [run {string is true $s}] \ - [run {string is upper $s}] \ - [run {string is wordchar $s}] \ - [run {string is xdigit $s}] \ + [string is alnum $s] \ + [string is alpha $s] \ + [string is ascii $s] \ + [string is control $s] \ + [string is boolean $s] \ + [string is digit $s] \ + [string is double $s] \ + [string is false $s] \ + [string is graph $s] \ + [string is integer $s] \ + [string is lower $s] \ + [string is print $s] \ + [string is punct $s] \ + [string is space $s] \ + [string is true $s] \ + [string is upper $s] \ + [string is wordchar $s] \ + [string is xdigit $s] \ } {1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1} -test string-23.2.$noComp {string is command with empty string} { +test string-23.2 {string is command with empty string} { set s "" list \ - [run {string is alnum -strict $s}] \ - [run {string is alpha -strict $s}] \ - [run {string is ascii -strict $s}] \ - [run {string is control -strict $s}] \ - [run {string is boolean -strict $s}] \ - [run {string is digit -strict $s}] \ - [run {string is double -strict $s}] \ - [run {string is false -strict $s}] \ - [run {string is graph -strict $s}] \ - [run {string is integer -strict $s}] \ - [run {string is lower -strict $s}] \ - [run {string is print -strict $s}] \ - [run {string is punct -strict $s}] \ - [run {string is space -strict $s}] \ - [run {string is true -strict $s}] \ - [run {string is upper -strict $s}] \ - [run {string is wordchar -strict $s}] \ - [run {string is xdigit -strict $s}] \ + [string is alnum -strict $s] \ + [string is alpha -strict $s] \ + [string is ascii -strict $s] \ + [string is control -strict $s] \ + [string is boolean -strict $s] \ + [string is digit -strict $s] \ + [string is double -strict $s] \ + [string is false -strict $s] \ + [string is graph -strict $s] \ + [string is integer -strict $s] \ + [string is lower -strict $s] \ + [string is print -strict $s] \ + [string is punct -strict $s] \ + [string is space -strict $s] \ + [string is true -strict $s] \ + [string is upper -strict $s] \ + [string is wordchar -strict $s] \ + [string is xdigit -strict $s] \ } {0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} -test string-24.1.$noComp {string reverse command} -body { - run {string reverse} -} -returnCodes error -result "wrong # args: should be \"string reverse string\"" -test string-24.2.$noComp {string reverse command} -body { - run {string reverse a b} -} -returnCodes error -result "wrong # args: should be \"string reverse string\"" -test string-24.3.$noComp {string reverse command - shared string} { - set x abcde - run {string reverse $x} -} edcba -test string-24.4.$noComp {string reverse command - unshared string} { - set x abc - set y de - run {string reverse $x$y} -} edcba -test string-24.5.$noComp {string reverse command - shared unicode string} { - set x abcde\ud0ad - run {string reverse $x} -} \ud0adedcba -test string-24.6.$noComp {string reverse command - unshared string} { - set x abc - set y de\ud0ad - run {string reverse $x$y} -} \ud0adedcba -test string-24.7.$noComp {string reverse command - simple case} { - run {string reverse a} -} a -test string-24.8.$noComp {string reverse command - simple case} { - run {string reverse \ud0ad} -} \ud0ad -test string-24.9.$noComp {string reverse command - simple case} { - run {string reverse {}} -} {} -test string-24.10.$noComp {string reverse command - corner case} { - set x \ubeef\ud0ad - run {string reverse $x} -} \ud0ad\ubeef -test string-24.11.$noComp {string reverse command - corner case} { - set x \ubeef - set y \ud0ad - run {string reverse $x$y} -} \ud0ad\ubeef -test string-24.12.$noComp {string reverse command - corner case} { - set x \ubeef - set y \ud0ad - run {string is ascii [run {string reverse $x$y}]} -} 0 -test string-24.13.$noComp {string reverse command - pure Unicode string} { - run {string reverse [run {string range \ubeef\ud0ad\ubeef\ud0ad\ubeef\ud0ad 1 5}]} -} \ud0ad\ubeef\ud0ad\ubeef\ud0ad -test string-24.14.$noComp {string reverse command - pure bytearray} { - binary scan [run {string reverse [binary format H* 010203]}] H* x - set x -} 030201 -test string-24.15.$noComp {string reverse command - pure bytearray} { - binary scan [run {tcl::string::reverse [binary format H* 010203]}] H* x - set x -} 030201 - -test string-25.1.$noComp {string is list} { - run {string is list {a b c}} -} 1 -test string-25.2.$noComp {string is list} { - run {string is list "a \{b c"} -} 0 -test string-25.3.$noComp {string is list} { - run {string is list {a {b c}d e}} -} 0 -test string-25.4.$noComp {string is list} { - run {string is list {}} -} 1 -test string-25.5.$noComp {string is list} { - run {string is list -strict {a b c}} -} 1 -test string-25.6.$noComp {string is list} { - run {string is list -strict "a \{b c"} -} 0 -test string-25.7.$noComp {string is list} { - run {string is list -strict {a {b c}d e}} -} 0 -test string-25.8.$noComp {string is list} { - run {string is list -strict {}} -} 1 -test string-25.9.$noComp {string is list} { - set x {} - list [run {string is list -failindex x {a b c}}] $x -} {1 {}} -test string-25.10.$noComp {string is list} { - set x {} - list [run {string is list -failindex x "a \{b c"}] $x -} {0 2} -test string-25.11.$noComp {string is list} { - set x {} - list [run {string is list -failindex x {a b {b c}d e}}] $x -} {0 4} -test string-25.12.$noComp {string is list} { - set x {} - list [run {string is list -failindex x {}}] $x -} {1 {}} -test string-25.13.$noComp {string is list} { - set x {} - list [run {string is list -failindex x { {b c}d e}}] $x -} {0 2} -test string-25.14.$noComp {string is list} { - set x {} - list [run {string is list -failindex x "\uabcd {b c}d e"}] $x -} {0 2} - -test string-26.1.$noComp {tcl::prefix, too few args} -body { - tcl::prefix match a -} -returnCodes 1 -result {wrong # args: should be "tcl::prefix match ?options? table string"} -test string-26.2.$noComp {tcl::prefix, bad args} -body { - tcl::prefix match a b c -} -returnCodes 1 -result {bad option "a": must be -error, -exact, or -message} -test string-26.2.1.$noComp {tcl::prefix, empty table} -body { - tcl::prefix match {} foo -} -returnCodes 1 -result {bad option "foo": no valid options} -test string-26.3.$noComp {tcl::prefix, bad args} -body { - tcl::prefix match -error "{}x" -exact str1 str2 -} -returnCodes 1 -result {list element in braces followed by "x" instead of space} -test string-26.3.1.$noComp {tcl::prefix, bad args} -body { - tcl::prefix match -error "x" -exact str1 str2 -} -returnCodes 1 -result {error options must have an even number of elements} -test string-26.3.2.$noComp {tcl::prefix, bad args} -body { - tcl::prefix match -error str1 str2 -} -returnCodes 1 -result {missing value for -error} -test string-26.4.$noComp {tcl::prefix, bad args} -body { - tcl::prefix match -message str1 str2 -} -returnCodes 1 -result {missing value for -message} -test string-26.5.$noComp {tcl::prefix} { - tcl::prefix match {apa bepa cepa depa} cepa -} cepa -test string-26.6.$noComp {tcl::prefix} { - tcl::prefix match {apa bepa cepa depa} be -} bepa -test string-26.7.$noComp {tcl::prefix} -body { - tcl::prefix match -exact {apa bepa cepa depa} be -} -returnCodes 1 -result {bad option "be": must be apa, bepa, cepa, or depa} -test string-26.8.$noComp {tcl::prefix} -body { - tcl::prefix match -message wombat {apa bepa bear depa} be -} -returnCodes 1 -result {ambiguous wombat "be": must be apa, bepa, bear, or depa} -test string-26.9.$noComp {tcl::prefix} -body { - tcl::prefix match -error {} {apa bepa bear depa} be -} -returnCodes 0 -result {} -test string-26.10.$noComp {tcl::prefix} -body { - tcl::prefix match -error {-level 1} {apa bepa bear depa} be -} -returnCodes 2 -result {ambiguous option "be": must be apa, bepa, bear, or depa} -test string-26.10.1.$noComp {tcl::prefix} -setup { +test string-24.1 {string reverse command} -body { + string reverse +} -returnCodes error -result "wrong # args: should be \"string reverse string\"" +test string-24.2 {string reverse command} -body { + string reverse a b +} -returnCodes error -result "wrong # args: should be \"string reverse string\"" +test string-24.3 {string reverse command - shared string} { + set x abcde + string reverse $x +} edcba +test string-24.4 {string reverse command - unshared string} { + set x abc + set y de + string reverse $x$y +} edcba +test string-24.5 {string reverse command - shared unicode string} { + set x abcde\uD0AD + string reverse $x +} \uD0ADedcba +test string-24.6 {string reverse command - unshared string} { + set x abc + set y de\uD0AD + string reverse $x$y +} \uD0ADedcba +test string-24.7 {string reverse command - simple case} { + string reverse a +} a +test string-24.8 {string reverse command - simple case} { + string reverse \uD0AD +} \uD0AD +test string-24.9 {string reverse command - simple case} { + string reverse {} +} {} +test string-24.10 {string reverse command - corner case} { + set x \uBEEF\uD0AD + string reverse $x +} \uD0AD\uBEEF +test string-24.11 {string reverse command - corner case} { + set x \uBEEF + set y \uD0AD + string reverse $x$y +} \uD0AD\uBEEF +test string-24.12 {string reverse command - corner case} { + set x \uBEEF + set y \uD0AD + string is ascii [string reverse $x$y] +} 0 +test string-24.13 {string reverse command - pure Unicode string} { + string reverse [string range \uBEEF\uD0AD\uBEEF\uD0AD\uBEEF\uD0AD 1 5] +} \uD0AD\uBEEF\uD0AD\uBEEF\uD0AD +test string-24.14 {string reverse command - pure bytearray} { + binary scan [string reverse [binary format H* 010203]] H* x + set x +} 030201 +test string-24.15 {string reverse command - pure bytearray} { + binary scan [tcl::string::reverse [binary format H* 010203]] H* x + set x +} 030201 + +test string-25.1 {string is list} { + string is list {a b c} +} 1 +test string-25.2 {string is list} { + string is list "a \{b c" +} 0 +test string-25.3 {string is list} { + string is list {a {b c}d e} +} 0 +test string-25.4 {string is list} { + string is list {} +} 1 +test string-25.5 {string is list} { + string is list -strict {a b c} +} 1 +test string-25.6 {string is list} { + string is list -strict "a \{b c" +} 0 +test string-25.7 {string is list} { + string is list -strict {a {b c}d e} +} 0 +test string-25.8 {string is list} { + string is list -strict {} +} 1 +test string-25.9 {string is list} { + set x {} + list [string is list -failindex x {a b c}] $x +} {1 {}} +test string-25.10 {string is list} { + set x {} + list [string is list -failindex x "a \{b c"] $x +} {0 2} +test string-25.11 {string is list} { + set x {} + list [string is list -failindex x {a b {b c}d e}] $x +} {0 4} +test string-25.12 {string is list} { + set x {} + list [string is list -failindex x {}] $x +} {1 {}} +test string-25.13 {string is list} { + set x {} + list [string is list -failindex x { {b c}d e}] $x +} {0 2} +test string-25.14 {string is list} { + set x {} + list [string is list -failindex x "\uABCD {b c}d e"] $x +} {0 2} + +test string-26.1 {tcl::prefix, not enough args} -body { + tcl::prefix match a +} -returnCodes 1 -result {wrong # args: should be "tcl::prefix match ?options? table string"} +test string-26.2 {tcl::prefix, bad args} -body { + tcl::prefix match a b c +} -returnCodes 1 -result {bad option "a": must be -error, -exact, or -message} +test string-26.2.1 {tcl::prefix, empty table} -body { + tcl::prefix match {} foo +} -returnCodes 1 -result {bad option "foo": no valid options} +test string-26.3 {tcl::prefix, bad args} -body { + tcl::prefix match -error "{}x" -exact str1 str2 +} -returnCodes 1 -result {list element in braces followed by "x" instead of space} +test string-26.3.1 {tcl::prefix, bad args} -body { + tcl::prefix match -error "x" -exact str1 str2 +} -returnCodes 1 -result {error options must have an even number of elements} +test string-26.3.2 {tcl::prefix, bad args} -body { + tcl::prefix match -error str1 str2 +} -returnCodes 1 -result {missing value for -error} +test string-26.4 {tcl::prefix, bad args} -body { + tcl::prefix match -message str1 str2 +} -returnCodes 1 -result {missing value for -message} +test string-26.5 {tcl::prefix} { + tcl::prefix match {apa bepa cepa depa} cepa +} cepa +test string-26.6 {tcl::prefix} { + tcl::prefix match {apa bepa cepa depa} be +} bepa +test string-26.7 {tcl::prefix} -body { + tcl::prefix match -exact {apa bepa cepa depa} be +} -returnCodes 1 -result {bad option "be": must be apa, bepa, cepa, or depa} +test string-26.8 {tcl::prefix} -body { + tcl::prefix match -message wombat {apa bepa bear depa} be +} -returnCodes 1 -result {ambiguous wombat "be": must be apa, bepa, bear, or depa} +test string-26.9 {tcl::prefix} -body { + tcl::prefix match -error {} {apa bepa bear depa} be +} -returnCodes 0 -result {} +test string-26.10 {tcl::prefix} -body { + tcl::prefix match -error {-level 1} {apa bepa bear depa} be +} -returnCodes 2 -result {ambiguous option "be": must be apa, bepa, bear, or depa} +test string-26.10.1 {tcl::prefix} -setup { proc _testprefix {args} { array set opts {-a x -b y -c y} foreach {opt val} $args { set opt [tcl::prefix match -error {-level 1} {-a -b -c} $opt] set opts($opt) $val @@ -2130,11 +1924,11 @@ lappend res [expr {$end - $tmp}] } return $res } -test string-26.11.$noComp {tcl::prefix: testing for leaks} -body { +test string-26.11 {tcl::prefix: testing for leaks} -body { # This test is made to stress object reference management MemStress { set table {hejj miff gurk} set item [lindex $table 1] # If not careful, this can cause a circular reference @@ -2151,11 +1945,11 @@ set item [lindex [dict keys [lindex $table3 1]] 0] tcl::prefix match $table3 $item } } -constraints memory -result {0 0 0} -test string-26.12.$noComp {tcl::prefix: testing for leaks} -body { +test string-26.12 {tcl::prefix: testing for leaks} -body { # This is a memory leak test in a form that might actually happen # in real code. The shared literal "miff" causes a connection # between the item and the table. MemStress { proc stress1 {item} { @@ -2169,11 +1963,11 @@ rename stress1 {} rename stress2 {} } } -constraints memory -result 0 -test string-26.13.$noComp {tcl::prefix: testing for leaks} -body { +test string-26.13 {tcl::prefix: testing for leaks} -body { # This test is made to stress object reference management MemStress { set table [list hejj miff] set item $table set error $table @@ -2182,323 +1976,116 @@ tcl::prefix match -error $error $table $item } } } -constraints memory -result {0} -test string-27.1.$noComp {tcl::prefix all, too few args} -body { +test string-27.1 {tcl::prefix all, not enough args} -body { tcl::prefix all a } -returnCodes 1 -result {wrong # args: should be "tcl::prefix all table string"} -test string-27.2.$noComp {tcl::prefix all, bad args} -body { +test string-27.2 {tcl::prefix all, bad args} -body { tcl::prefix all a b c } -returnCodes 1 -result {wrong # args: should be "tcl::prefix all table string"} -test string-27.3.$noComp {tcl::prefix all, bad args} -body { +test string-27.3 {tcl::prefix all, bad args} -body { tcl::prefix all "{}x" str2 } -returnCodes 1 -result {list element in braces followed by "x" instead of space} -test string-27.4.$noComp {tcl::prefix all} { +test string-27.4 {tcl::prefix all} { tcl::prefix all {apa bepa cepa depa} c } cepa -test string-27.5.$noComp {tcl::prefix all} { +test string-27.5 {tcl::prefix all} { tcl::prefix all {apa bepa cepa depa} cepa } cepa -test string-27.6.$noComp {tcl::prefix all} { +test string-27.6 {tcl::prefix all} { tcl::prefix all {apa bepa cepa depa} cepax } {} -test string-27.7.$noComp {tcl::prefix all} { +test string-27.7 {tcl::prefix all} { tcl::prefix all {apa aska appa} a } {apa aska appa} -test string-27.8.$noComp {tcl::prefix all} { +test string-27.8 {tcl::prefix all} { tcl::prefix all {apa aska appa} ap } {apa appa} -test string-27.9.$noComp {tcl::prefix all} { +test string-27.9 {tcl::prefix all} { tcl::prefix all {apa aska appa} p } {} -test string-27.10.$noComp {tcl::prefix all} { +test string-27.10 {tcl::prefix all} { tcl::prefix all {apa aska appa} {} } {apa aska appa} -test string-28.1.$noComp {tcl::prefix longest, too few args} -body { +test string-28.1 {tcl::prefix longest, not enough args} -body { tcl::prefix longest a } -returnCodes 1 -result {wrong # args: should be "tcl::prefix longest table string"} -test string-28.2.$noComp {tcl::prefix longest, bad args} -body { +test string-28.2 {tcl::prefix longest, bad args} -body { tcl::prefix longest a b c } -returnCodes 1 -result {wrong # args: should be "tcl::prefix longest table string"} -test string-28.3.$noComp {tcl::prefix longest, bad args} -body { +test string-28.3 {tcl::prefix longest, bad args} -body { tcl::prefix longest "{}x" str2 } -returnCodes 1 -result {list element in braces followed by "x" instead of space} -test string-28.4.$noComp {tcl::prefix longest} { +test string-28.4 {tcl::prefix longest} { tcl::prefix longest {apa bepa cepa depa} c } cepa -test string-28.5.$noComp {tcl::prefix longest} { +test string-28.5 {tcl::prefix longest} { tcl::prefix longest {apa bepa cepa depa} cepa } cepa -test string-28.6.$noComp {tcl::prefix longest} { +test string-28.6 {tcl::prefix longest} { tcl::prefix longest {apa bepa cepa depa} cepax } {} -test string-28.7.$noComp {tcl::prefix longest} { +test string-28.7 {tcl::prefix longest} { tcl::prefix longest {apa aska appa} a } a -test string-28.8.$noComp {tcl::prefix longest} { +test string-28.8 {tcl::prefix longest} { tcl::prefix longest {apa aska appa} ap } ap -test string-28.9.$noComp {tcl::prefix longest} { +test string-28.9 {tcl::prefix longest} { tcl::prefix longest {apa bska appa} a } ap -test string-28.10.$noComp {tcl::prefix longest} { +test string-28.10 {tcl::prefix longest} { tcl::prefix longest {apa bska appa} {} } {} -test string-28.11.$noComp {tcl::prefix longest} { +test string-28.11 {tcl::prefix longest} { tcl::prefix longest {{} bska appa} {} } {} -test string-28.12.$noComp {tcl::prefix longest} { +test string-28.12 {tcl::prefix longest} { tcl::prefix longest {apa {} appa} {} } {} -test string-28.13.$noComp {tcl::prefix longest} { - # Test UTF8 handling +test string-28.13 {tcl::prefix longest} { + # Test utf-8 handling tcl::prefix longest {ax\x90 bep ax\x91} a } ax -test string-29.1.$noComp {string cat, no arg} { - run {string cat} -} "" -test string-29.2.$noComp {string cat, single arg} { - set x FOO - run {string compare $x [run {string cat $x}]} -} 0 -test string-29.3.$noComp {string cat, two args} { - set x FOO - run {string compare $x$x [run {string cat $x $x}]} -} 0 -test string-29.4.$noComp {string cat, many args} { - set x FOO - set n 260 - set xx [run {string repeat $x $n}] - set vv [run {string repeat {$x} $n}] - set vvs [run {string repeat {$x } $n}] - set r1 [run {string compare $xx [subst $vv]}] - set r2 [run {string compare $xx [eval "run {string cat $vvs}"]}] - list $r1 $r2 -} {0 0} -if {$noComp} { -test string-29.5.$noComp {string cat, efficiency} -body { - tcl::unsupported::representation [run {string cat [list x] [list]}] -} -match glob -result {*no string representation} -test string-29.6.$noComp {string cat, efficiency} -body { - tcl::unsupported::representation [run {string cat [list] [list x]}] -} -match glob -result {*no string representation} -test string-29.7.$noComp {string cat, efficiency} -body { - tcl::unsupported::representation [run {string cat [list x] [list] [list]}] -} -match glob -result {*no string representation} -test string-29.8.$noComp {string cat, efficiency} -body { - tcl::unsupported::representation [run {string cat [list] [list x] [list]}] -} -match glob -result {*no string representation} -test string-29.9.$noComp {string cat, efficiency} -body { - tcl::unsupported::representation [run {string cat [list] [list] [list x]}] -} -match glob -result {*no string representation} -test string-29.10.$noComp {string cat, efficiency} -body { - tcl::unsupported::representation [run {string cat [list x] [list x]}] -} -match glob -result {*, string representation "xx"} -test string-29.11.$noComp {string cat, efficiency} -body { - tcl::unsupported::representation \ - [run {string cat [list x] [encoding convertto utf-8 {}]}] -} -match glob -result {*no string representation} -test string-29.12.$noComp {string cat, efficiency} -body { - tcl::unsupported::representation \ - [run {string cat [encoding convertto utf-8 {}] [list x]}] -} -match glob -result {*, string representation "x"} -test string-29.13.$noComp {string cat, efficiency} -body { - tcl::unsupported::representation [run {string cat \ - [encoding convertto utf-8 {}] [encoding convertto utf-8 {}] [list x]}] -} -match glob -result {*, string representation "x"} -test string-29.14.$noComp {string cat, efficiency} -setup { - set e [encoding convertto utf-8 {}] -} -cleanup { - unset e -} -body { - tcl::unsupported::representation [run {string cat $e $e [list x]}] -} -match glob -result {*no string representation} -test string-29.15.$noComp {string cat, efficiency} -setup { - set e [encoding convertto utf-8 {}] - set f [encoding convertto utf-8 {}] -} -cleanup { - unset e f -} -body { - tcl::unsupported::representation [run {string cat $e $f $e $f [list x]}] -} -match glob -result {*no string representation} -} - -test string-30.1.1.$noComp {[Bug ba921a8d98]: string cat} { - run {string cat [set data [binary format a* hello]] [encoding convertto $data] [unset data]} -} hellohello -test string-30.1.2.$noComp {[Bug ba921a8d98]: inplace cat by subst (compiled to "strcat" instruction)} { - run {set x "[set data [binary format a* hello]][encoding convertto $data][unset data]"} -} hellohello - -# Note: string-31.* tests use [tcl::string::insert] rather than [string insert] -# to dodge ticket [3397978fff] which would cause all arguments to be shared, -# thereby preventing the optimizations from being tested. -test string-31.1.$noComp {string insert, start of string} { - run {tcl::string::insert 0123 0 _} -} _0123 -test string-31.2.$noComp {string insert, middle of string} { - run {tcl::string::insert 0123 2 _} -} 01_23 -test string-31.3.$noComp {string insert, end of string} { - run {tcl::string::insert 0123 4 _} -} 0123_ -test string-31.4.$noComp {string insert, start of string, end-relative} { - run {tcl::string::insert 0123 end-4 _} -} _0123 -test string-31.5.$noComp {string insert, middle of string, end-relative} { - run {tcl::string::insert 0123 end-2 _} -} 01_23 -test string-31.6.$noComp {string insert, end of string, end-relative} { - run {tcl::string::insert 0123 end _} -} 0123_ -test string-31.7.$noComp {string insert, empty target string} { - run {tcl::string::insert {} 0 _} -} _ -test string-31.8.$noComp {string insert, empty insert string} { - run {tcl::string::insert 0123 0 {}} -} 0123 -test string-31.9.$noComp {string insert, empty strings} { - run {tcl::string::insert {} 0 {}} -} {} -test string-31.10.$noComp {string insert, negative index} { - run {tcl::string::insert 0123 -1 _} -} _0123 -test string-31.11.$noComp {string insert, index beyond end} { - run {tcl::string::insert 0123 5 _} -} 0123_ -test string-31.12.$noComp {string insert, start of string, pure byte array} { - run {tcl::string::insert [makeByteArray 0123] 0 [makeByteArray _]} -} _0123 -test string-31.13.$noComp {string insert, middle of string, pure byte array} { - run {tcl::string::insert [makeByteArray 0123] 2 [makeByteArray _]} -} 01_23 -test string-31.14.$noComp {string insert, end of string, pure byte array} { - run {tcl::string::insert [makeByteArray 0123] 4 [makeByteArray _]} -} 0123_ -test string-31.15.$noComp {string insert, pure byte array, neither shared} { - run {tcl::string::insert [makeByteArray 0123] 2 [makeByteArray _]} -} 01_23 -test string-31.16.$noComp {string insert, pure byte array, first shared} { - run {tcl::string::insert [makeShared [makeByteArray 0123]] 2\ - [makeByteArray _]} -} 01_23 -test string-31.17.$noComp {string insert, pure byte array, second shared} { - run {tcl::string::insert [makeByteArray 0123] 2\ - [makeShared [makeByteArray _]]} -} 01_23 -test string-31.18.$noComp {string insert, pure byte array, both shared} { - run {tcl::string::insert [makeShared [makeByteArray 0123]] 2\ - [makeShared [makeByteArray _]]} -} 01_23 -test string-31.19.$noComp {string insert, start of string, pure Unicode} { - run {tcl::string::insert [makeUnicode 0123] 0 [makeUnicode _]} -} _0123 -test string-31.20.$noComp {string insert, middle of string, pure Unicode} { - run {tcl::string::insert [makeUnicode 0123] 2 [makeUnicode _]} -} 01_23 -test string-31.21.$noComp {string insert, end of string, pure Unicode} { - run {tcl::string::insert [makeUnicode 0123] 4 [makeUnicode _]} -} 0123_ -test string-31.22.$noComp {string insert, str start, pure Uni, first shared} { - run {tcl::string::insert [makeShared [makeUnicode 0123]] 0 [makeUnicode _]} -} _0123 -test string-31.23.$noComp {string insert, string mid, pure Uni, 2nd shared} { - run {tcl::string::insert [makeUnicode 0123] 2 [makeShared [makeUnicode _]]} -} 01_23 -test string-31.24.$noComp {string insert, string end, pure Uni, both shared} { - run {tcl::string::insert [makeShared [makeUnicode 0123]] 4\ - [makeShared [makeUnicode _]]} -} 0123_ -test string-31.25.$noComp {string insert, neither byte array nor Unicode} { - run {tcl::string::insert [makeList a b c] 1 zzzzzz} -} {azzzzzz b c} - -test string-32.1.$noComp {string is dict} { - string is dict {a b c d} -} 1 -test string-32.1a.$noComp {string is dict} { - string is dict {a b c} -} 0 -test string-32.2.$noComp {string is dict} { - string is dict "a \{b c" -} 0 -test string-32.3.$noComp {string is dict} { - string is dict {a {b c}d e} -} 0 -test string-32.4.$noComp {string is dict} { - string is dict {} -} 1 -test string-32.5.$noComp {string is dict} { - string is dict -strict {a b c d} -} 1 -test string-32.5a.$noComp {string is dict} { - string is dict -strict {a b c} -} 0 -test string-32.6.$noComp {string is dict} { - string is dict -strict "a \{b c" -} 0 -test string-32.7.$noComp {string is dict} { - string is dict -strict {a {b c}d e} -} 0 -test string-32.8.$noComp {string is dict} { - string is dict -strict {} -} 1 -test string-32.9.$noComp {string is dict} { - set x {} - list [string is dict -failindex x {a b c d}] $x -} {1 {}} -test string-32.9a.$noComp {string is dict} { - set x {} - list [string is dict -failindex x {a b c}] $x -} {0 -1} -test string-32.10.$noComp {string is dict} { - set x {} - list [string is dict -failindex x "a \{b c d"] $x -} {0 2} -test string-32.10a.$noComp {string is dict} { - set x {} - list [string is dict -failindex x "a \{b c"] $x -} {0 2} -test string-32.11.$noComp {string is dict} { - set x {} - list [string is dict -failindex x {a b {b c}d e}] $x -} {0 4} -test string-32.12.$noComp {string is dict} { - set x {} - list [string is dict -failindex x {}] $x -} {1 {}} -test string-32.13.$noComp {string is dict} { - set x {} - list [string is dict -failindex x { {b c}d e}] $x -} {0 2} -test string-32.14.$noComp {string is dict} { - set x {} - list [string is dict -failindex x "\uabcd {b c}d e"] $x -} {0 2} -test string-32.15.$noComp {string is dict, valid dict} { - string is dict {a b c d e f} -} 1 -test string-32.16.$noComp {string is dict, invalid dict} { - string is dict a -} 0 -test string-32.17.$noComp {string is dict, valid dict packed in invalid dict} { - string is dict {{a b c d e f g h}} -} 0 - -}; # foreach noComp {0 1} - -# cleanup -rename MemStress {} -rename makeByteArray {} -rename makeUnicode {} -rename makeList {} -rename makeShared {} +test string-29.1 {string cat, no arg} { + string cat +} "" +test string-29.2 {string cat, single arg} { + set x FOO + string compare $x [string cat $x] +} 0 +test string-29.3 {string cat, two args} { + set x FOO + string compare $x$x [string cat $x $x] +} 0 +test string-29.4 {string cat, many args} { + set x FOO + set n 260 + set xx [string repeat $x $n] + set vv [string repeat {$x} $n] + set vvs [string repeat {$x } $n] + set r1 [string compare $xx [subst $vv]] + set r2 [string compare $xx [eval "string cat $vvs"]] + list $r1 $r2 +} {0 0} + +test string-30.1.1 {[Bug ba921a8d98]: string cat} { + string cat [set data [binary format a* hello]] [encoding convertto $data] [unset data] +} hellohello +test string-30.1.2 {[Bug ba921a8d98]: inplace cat by subst (compiled to "strcat" instruction)} { + set x "[set data [binary format a* hello]][encoding convertto $data][unset data]" +} hellohello + + +# cleanup +rename MemStress {} catch {rename foo {}} ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: ADDED tests/stringComp.test Index: tests/stringComp.test ================================================================== --- /dev/null +++ tests/stringComp.test @@ -0,0 +1,801 @@ +# Commands covered: string +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# This differs from the original string tests in that the tests call +# things in procs, which uses the compiled string code instead of +# the runtime parse string code. The tests of import should match +# their equivalent number in string.test. +# +# Copyright (c) 2001 by ActiveState Corporation. +# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + +# Some tests require the testobj command + +testConstraint testobj [expr {[info commands testobj] != {}}] +testConstraint memory [llength [info commands memory]] +if {[testConstraint memory]} { + proc getbytes {} { + set lines [split [memory info] \n] + return [lindex $lines 3 3] + } + proc leaktest {script {iterations 3}} { + set end [getbytes] + for {set i 0} {$i < $iterations} {incr i} { + uplevel 1 $script + set tmp $end + set end [getbytes] + } + return [expr {$end - $tmp}] + } +} + +test stringComp-1.1 {error conditions} { + proc foo {} {string gorp a b} + list [catch {foo} msg] $msg +} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +test stringComp-1.2 {error conditions} { + proc foo {} {string} + list [catch {foo} msg] $msg +} {1 {wrong # args: should be "string subcommand ?arg ...?"}} +test stringComp-1.3 {error condition - undefined method during compile} { + # We don't want this to complain about 'never' because it may never + # be called, or string may get redefined. This must compile OK. + proc foo {str i} { + if {"yes" == "no"} { string never called but complains here } + string index $str $i + } + foo abc 0 +} a + +## Test string compare|equal over equal constraints +## Use result for string compare, and negate it for string equal +## The body will be tested both in and outside a proc +set i 0 +foreach {tname tbody tresult tcode} { + {too few args} { + string compare a + } {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"} {error} + {bad args} { + string compare a b c + } {bad option "a": must be -nocase or -length} {error} + {bad args} { + string compare -length -nocase str1 str2 + } {expected integer but got "-nocase"} {error} + {too many args} { + string compare -length 10 -nocase str1 str2 str3 + } {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"} {error} + {compare with length unspecified} { + string compare -length 10 10 + } {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"} {error} + {basic operation fail} { + string compare abcde abdef + } {-1} {} + {basic operation success} { + string compare abcde abcde + } {0} {} + {with length} { + string compare -length 2 abcde abxyz + } {0} {} + {with special index} { + string compare -length end-3 abcde abxyz + } {expected integer but got "end-3"} {error} + {unicode} { + string compare ab\u7266 ab\u7267 + } {-1} {} + {unicode} {string compare \334 \u00dc} 0 {} + {unicode} {string compare \334 \u00fc} -1 {} + {unicode} {string compare \334\334\334\374\374 \334\334\334\334\334} 1 {} + {high bit} { + # This test will fail if the underlying comparison + # is using signed chars instead of unsigned chars. + # (like SunOS's default memcmp thus the compat/memcmp.c) + string compare "\x80" "@" + # Nb this tests works also in utf-8 space because \x80 is + # translated into a 2 or more bytelength but whose first byte has + # the high bit set. + } {1} {} + {-nocase 1} {string compare -nocase abcde abdef} {-1} {} + {-nocase 2} {string compare -nocase abcde Abdef} {-1} {} + {-nocase 3} {string compare -nocase abcde ABCDE} {0} {} + {-nocase 4} {string compare -nocase abcde abcde} {0} {} + {-nocase unicode} { + string compare -nocase \334 \u00dc + } 0 {} + {-nocase unicode} { + string compare -nocase \334\334\334\374\u00fc \334\334\334\334\334 + } 0 {} + {-nocase with length} { + string compare -length 2 -nocase abcde Abxyz + } {0} {} + {-nocase with length} { + string compare -nocase -length 3 abcde Abxyz + } {-1} {} + {-nocase with length <= 0} { + string compare -nocase -length -1 abcde AbCdEf + } {-1} {} + {-nocase with excessive length} { + string compare -nocase -length 50 AbCdEf abcde + } {1} {} + {-len unicode} { + # These are strings that are 6 BYTELENGTH long, but the length + # shouldn't make a different because there are actually 3 CHARS long + string compare -len 5 \334\334\334 \334\334\374 + } -1 {} + {-nocase with special index} { + string compare -nocase -length end-3 Abcde abxyz + } {expected integer but got "end-3"} error + {null strings} { + string compare "" "" + } 0 {} + {null strings} { + string compare "" foo + } -1 {} + {null strings} { + string compare foo "" + } 1 {} + {-nocase null strings} { + string compare -nocase "" "" + } 0 {} + {-nocase null strings} { + string compare -nocase "" foo + } -1 {} + {-nocase null strings} { + string compare -nocase foo "" + } 1 {} + {with length, unequal strings} { + string compare -length 2 abc abde + } 0 {} + {with length, unequal strings} { + string compare -length 2 ab abde + } 0 {} + {with NUL character vs. other ASCII} { + # Be careful here, since UTF-8 rep comparison with memcmp() of + # these puts chars in the wrong order + string compare \x00 \x01 + } -1 {} + {high bit} { + string compare "a\x80" "a@" + } 1 {} + {high bit} { + string compare "a\x00" "a\x01" + } -1 {} + {high bit} { + string compare "\x00\x00" "\x00\x01" + } -1 {} + {binary equal} { + string compare [binary format a100 0] [binary format a100 0] + } 0 {} + {binary neq} { + string compare [binary format a100a 0 1] [binary format a100a 0 0] + } 1 {} + {binary neq inequal length} { + string compare [binary format a20a 0 1] [binary format a100a 0 0] + } 1 {} +} { + if {$tname eq ""} { continue } + if {$tcode eq ""} { set tcode ok } + test stringComp-2.[incr i] "string compare, $tname" \ + -body [list eval $tbody] \ + -returnCodes $tcode -result $tresult + test stringComp-2.[incr i] "string compare bc, $tname" \ + -body "[list proc foo {} $tbody];foo" \ + -returnCodes $tcode -result $tresult + if {"error" ni $tcode} { + set tresult [expr {!$tresult}] + } else { + set tresult [string map {compare equal} $tresult] + } + set tbody [string map {compare equal} $tbody] + test stringComp-2.[incr i] "string equal, $tname" \ + -body [list eval $tbody] \ + -returnCodes $tcode -result $tresult + test stringComp-2.[incr i] "string equal bc, $tname" \ + -body "[list proc foo {} $tbody];foo" \ + -returnCodes $tcode -result $tresult +} + +# need a few extra tests short abbr cmd +test stringComp-3.1 {string compare, shortest method name} { + proc foo {} {string co abcde ABCDE} + foo +} 1 +test stringComp-3.2 {string equal, shortest method name} { + proc foo {} {string e abcde ABCDE} + foo +} 0 +test stringComp-3.3 {string equal -nocase} { + proc foo {} {string eq -nocase abcde ABCDE} + foo +} 1 + +test stringComp-4.1 {string first, too few args} { + proc foo {} {string first a} + list [catch {foo} msg] $msg +} {1 {wrong # args: should be "string first needleString haystackString ?startIndex?"}} +test stringComp-4.2 {string first, bad args} { + proc foo {} {string first a b c} + list [catch {foo} msg] $msg +} {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}} +test stringComp-4.3 {string first, too many args} { + proc foo {} {string first a b 5 d} + list [catch {foo} msg] $msg +} {1 {wrong # args: should be "string first needleString haystackString ?startIndex?"}} +test stringComp-4.4 {string first} { + proc foo {} {string first bq abcdefgbcefgbqrs} + foo +} 12 +test stringComp-4.5 {string first} { + proc foo {} {string fir bcd abcdefgbcefgbqrs} + foo +} 1 +test stringComp-4.6 {string first} { + proc foo {} {string f b abcdefgbcefgbqrs} + foo +} 1 +test stringComp-4.7 {string first} { + proc foo {} {string first xxx x123xx345xxx789xxx012} + foo +} 9 +test stringComp-4.8 {string first} { + proc foo {} {string first "" x123xx345xxx789xxx012} + foo +} -1 +test stringComp-4.9 {string first, unicode} { + proc foo {} {string first x abc\u7266x} + foo +} 4 +test stringComp-4.10 {string first, unicode} { + proc foo {} {string first \u7266 abc\u7266x} + foo +} 3 +test stringComp-4.11 {string first, start index} { + proc foo {} {string first \u7266 abc\u7266x 3} + foo +} 3 +test stringComp-4.12 {string first, start index} { + proc foo {} {string first \u7266 abc\u7266x 4} + foo +} -1 +test stringComp-4.13 {string first, start index} { + proc foo {} {string first \u7266 abc\u7266x end-2} + foo +} 3 +test stringComp-4.14 {string first, negative start index} { + proc foo {} {string first b abc -1} + foo +} 1 + +test stringComp-5.1 {string index} { + proc foo {} {string index} + list [catch {foo} msg] $msg +} {1 {wrong # args: should be "string index string charIndex"}} +test stringComp-5.2 {string index} { + proc foo {} {string index a b c} + list [catch {foo} msg] $msg +} {1 {wrong # args: should be "string index string charIndex"}} +test stringComp-5.3 {string index} { + proc foo {} {string index abcde 0} + foo +} a +test stringComp-5.4 {string index} { + proc foo {} {string in abcde 4} + foo +} e +test stringComp-5.5 {string index} { + proc foo {} {string index abcde 5} + foo +} {} +test stringComp-5.6 {string index} { + proc foo {} {string index abcde -10} + list [catch {foo} msg] $msg +} {0 {}} +test stringComp-5.7 {string index} { + proc foo {} {string index a xyz} + list [catch {foo} msg] $msg +} {1 {bad index "xyz": must be integer?[+-]integer? or end?[+-]integer?}} +test stringComp-5.8 {string index} { + proc foo {} {string index abc end} + foo +} c +test stringComp-5.9 {string index} { + proc foo {} {string index abc end-1} + foo +} b +test stringComp-5.10 {string index, unicode} { + proc foo {} {string index abc\u7266d 4} + foo +} d +test stringComp-5.11 {string index, unicode} { + proc foo {} {string index abc\u7266d 3} + foo +} \u7266 +test stringComp-5.12 {string index, unicode over char length, under byte length} { + proc foo {} {string index \334\374\334\374 6} + foo +} {} +test stringComp-5.13 {string index, bytearray object} { + proc foo {} {string index [binary format a5 fuz] 0} + foo +} f +test stringComp-5.14 {string index, bytearray object} { + proc foo {} {string index [binary format I* {0x50515253 0x52}] 3} + foo +} S +test stringComp-5.15 {string index, bytearray object} { + proc foo {} { + set b [binary format I* {0x50515253 0x52}] + set i1 [string index $b end-6] + set i2 [string index $b 1] + string compare $i1 $i2 + } + foo +} 0 +test stringComp-5.16 {string index, bytearray object with string obj shimmering} { + proc foo {} { + set str "0123456789\x00 abcdedfghi" + binary scan $str H* dump + string compare [string index $str 10] \x00 + } + foo +} 0 +test stringComp-5.17 {string index, bad integer} -body { + proc foo {} {string index "abc" 0o8} + list [catch {foo} msg] $msg +} -match glob -result {1 {*invalid octal number*}} +test stringComp-5.18 {string index, bad integer} -body { + proc foo {} {string index "abc" end-0o0289} + list [catch {foo} msg] $msg +} -match glob -result {1 {*invalid octal number*}} +test stringComp-5.19 {string index, bytearray object out of bounds} { + proc foo {} {string index [binary format I* {0x50515253 0x52}] -1} + foo +} {} +test stringComp-5.20 {string index, bytearray object out of bounds} { + proc foo {} {string index [binary format I* {0x50515253 0x52}] 20} + foo +} {} + + +proc largest_int {} { + # This will give us what the largest valid int on this machine is, + # so we can test for overflow properly below on >32 bit systems + set int 1 + set exp 7; # assume we get at least 8 bits + while {$int > 0} { set int [expr {1 << [incr exp]}] } + return [expr {$int-1}] +} + +## string is +## not yet bc + +catch {rename largest_int {}} + +## string last +## not yet bc + +## string length +## not yet bc +test stringComp-8.1 {string bytelength} { + proc foo {} {string bytelength} + list [catch {foo} msg] $msg +} {1 {wrong # args: should be "string bytelength string"}} +test stringComp-8.2 {string bytelength} { + proc foo {} {string bytelength a b} + list [catch {foo} msg] $msg +} {1 {wrong # args: should be "string bytelength string"}} +test stringComp-8.3 {string bytelength} { + proc foo {} {string bytelength "\u00c7"} + foo +} 2 +test stringComp-8.4 {string bytelength} { + proc foo {} {string b ""} + foo +} 0 + +## string length +## +test stringComp-9.1 {string length} { + proc foo {} {string length} + list [catch {foo} msg] $msg +} {1 {wrong # args: should be "string length string"}} +test stringComp-9.2 {string length} { + proc foo {} {string length a b} + list [catch {foo} msg] $msg +} {1 {wrong # args: should be "string length string"}} +test stringComp-9.3 {string length} { + proc foo {} {string length "a little string"} + foo +} 15 +test stringComp-9.4 {string length} { + proc foo {} {string le ""} + foo +} 0 +test stringComp-9.5 {string length, unicode} { + proc foo {} {string le "abcd\u7266"} + foo +} 5 +test stringComp-9.6 {string length, bytearray object} { + proc foo {} {string length [binary format a5 foo]} + foo +} 5 +test stringComp-9.7 {string length, bytearray object} { + proc foo {} {string length [binary format I* {0x50515253 0x52}]} + foo +} 8 + +## string map +## not yet bc + +## string match +## +test stringComp-11.1 {string match, too few args} { + proc foo {} {string match a} + list [catch {foo} msg] $msg +} {1 {wrong # args: should be "string match ?-nocase? pattern string"}} +test stringComp-11.2 {string match, too many args} { + proc foo {} {string match a b c d} + list [catch {foo} msg] $msg +} {1 {wrong # args: should be "string match ?-nocase? pattern string"}} +test stringComp-11.3 {string match} { + proc foo {} {string match abc abc} + foo +} 1 +test stringComp-11.4 {string match} { + proc foo {} {string mat abc abd} + foo +} 0 +test stringComp-11.5 {string match} { + proc foo {} {string match ab*c abc} + foo +} 1 +test stringComp-11.6 {string match} { + proc foo {} {string match ab**c abc} + foo +} 1 +test stringComp-11.7 {string match} { + proc foo {} {string match ab* abcdef} + foo +} 1 +test stringComp-11.8 {string match} { + proc foo {} {string match *c abc} + foo +} 1 +test stringComp-11.9 {string match} { + proc foo {} {string match *3*6*9 0123456789} + foo +} 1 +test stringComp-11.10 {string match} { + proc foo {} {string match *3*6*9 01234567890} + foo +} 0 +test stringComp-11.11 {string match} { + proc foo {} {string match a?c abc} + foo +} 1 +test stringComp-11.12 {string match} { + proc foo {} {string match a??c abc} + foo +} 0 +test stringComp-11.13 {string match} { + proc foo {} {string match ?1??4???8? 0123456789} + foo +} 1 +test stringComp-11.14 {string match} { + proc foo {} {string match {[abc]bc} abc} + foo +} 1 +test stringComp-11.15 {string match} { + proc foo {} {string match {a[abc]c} abc} + foo +} 1 +test stringComp-11.16 {string match} { + proc foo {} {string match {a[xyz]c} abc} + foo +} 0 +test stringComp-11.17 {string match} { + proc foo {} {string match {12[2-7]45} 12345} + foo +} 1 +test stringComp-11.18 {string match} { + proc foo {} {string match {12[ab2-4cd]45} 12345} + foo +} 1 +test stringComp-11.19 {string match} { + proc foo {} {string match {12[ab2-4cd]45} 12b45} + foo +} 1 +test stringComp-11.20 {string match} { + proc foo {} {string match {12[ab2-4cd]45} 12d45} + foo +} 1 +test stringComp-11.21 {string match} { + proc foo {} {string match {12[ab2-4cd]45} 12145} + foo +} 0 +test stringComp-11.22 {string match} { + proc foo {} {string match {12[ab2-4cd]45} 12545} + foo +} 0 +test stringComp-11.23 {string match} { + proc foo {} {string match {a\*b} a*b} + foo +} 1 +test stringComp-11.24 {string match} { + proc foo {} {string match {a\*b} ab} + foo +} 0 +test stringComp-11.25 {string match} { + proc foo {} {string match {a\*\?\[\]\\\x} "a*?\[\]\\x"} + foo +} 1 +test stringComp-11.26 {string match} { + proc foo {} {string match ** ""} + foo +} 1 +test stringComp-11.27 {string match} { + proc foo {} {string match *. ""} + foo +} 0 +test stringComp-11.28 {string match} { + proc foo {} {string match "" ""} + foo +} 1 +test stringComp-11.29 {string match} { + proc foo {} {string match \[a a} + foo +} 1 +test stringComp-11.30 {string match, bad args} { + proc foo {} {string match - b c} + list [catch {foo} msg] $msg +} {1 {bad option "-": must be -nocase}} +test stringComp-11.31 {string match case} { + proc foo {} {string match a A} + foo +} 0 +test stringComp-11.32 {string match nocase} { + proc foo {} {string match -n a A} + foo +} 1 +test stringComp-11.33 {string match nocase} { + proc foo {} {string match -nocase a\334 A\374} + foo +} 1 +test stringComp-11.34 {string match nocase} { + proc foo {} {string match -nocase a*f ABCDEf} + foo +} 1 +test stringComp-11.35 {string match case, false hope} { + # This is true because '_' lies between the A-Z and a-z ranges + proc foo {} {string match {[A-z]} _} + foo +} 1 +test stringComp-11.36 {string match nocase range} { + # This is false because although '_' lies between the A-Z and a-z ranges, + # we lower case the end points before checking the ranges. + proc foo {} {string match -nocase {[A-z]} _} + foo +} 0 +test stringComp-11.37 {string match nocase} { + proc foo {} {string match -nocase {[A-fh-Z]} g} + foo +} 0 +test stringComp-11.38 {string match case, reverse range} { + proc foo {} {string match {[A-fh-Z]} g} + foo +} 1 +test stringComp-11.39 {string match, *\ case} { + proc foo {} {string match {*\abc} abc} + foo +} 1 +test stringComp-11.40 {string match, *special case} { + proc foo {} {string match {*[ab]} abc} + foo +} 0 +test stringComp-11.41 {string match, *special case} { + proc foo {} {string match {*[ab]*} abc} + foo +} 1 +test stringComp-11.42 {string match, *special case} { + proc foo {} {string match "*\\" "\\"} + foo +} 0 +test stringComp-11.43 {string match, *special case} { + proc foo {} {string match "*\\\\" "\\"} + foo +} 1 +test stringComp-11.44 {string match, *special case} { + proc foo {} {string match "*???" "12345"} + foo +} 1 +test stringComp-11.45 {string match, *special case} { + proc foo {} {string match "*???" "12"} + foo +} 0 +test stringComp-11.46 {string match, *special case} { + proc foo {} {string match "*\\*" "abc*"} + foo +} 1 +test stringComp-11.47 {string match, *special case} { + proc foo {} {string match "*\\*" "*"} + foo +} 1 +test stringComp-11.48 {string match, *special case} { + proc foo {} {string match "*\\*" "*abc"} + foo +} 0 +test stringComp-11.49 {string match, *special case} { + proc foo {} {string match "?\\*" "a*"} + foo +} 1 +test stringComp-11.50 {string match, *special case} { + proc foo {} {string match "\\" "\\"} + foo +} 0 +test stringComp-11.51 {string match; *, -nocase and UTF-8} { + proc foo {} {string match -nocase [binary format I 717316707] \ + [binary format I 2028036707]} + foo +} 1 +test stringComp-11.52 {string match, null char in string} { + proc foo {} { + set ptn "*abc*" + foreach elem [list "\u0000@abc" "@abc" "\u0000@abc\u0000" "blahabcblah"] { + lappend out [string match $ptn $elem] + } + set out + } + foo +} {1 1 1 1} +test stringComp-11.53 {string match, null char in pattern} { + proc foo {} { + set out "" + foreach {ptn elem} [list \ + "*\u0000abc\u0000" "\u0000abc\u0000" \ + "*\u0000abc\u0000" "\u0000abc\u0000ef" \ + "*\u0000abc\u0000*" "\u0000abc\u0000ef" \ + "*\u0000abc\u0000" "@\u0000abc\u0000ef" \ + "*\u0000abc\u0000*" "@\u0000abc\u0000ef" \ + ] { + lappend out [string match $ptn $elem] + } + set out + } + foo +} {1 0 1 0 1} +test stringComp-11.54 {string match, failure} { + proc foo {} { + set longString "" + for {set i 0} {$i < 10} {incr i} { + append longString "abcdefghijklmnopqrstuvwxy\u0000z01234567890123" + } + list [string match *cba* $longString] \ + [string match *a*l*\u0000* $longString] \ + [string match *a*l*\u0000*123 $longString] \ + [string match *a*l*\u0000*123* $longString] \ + [string match *a*l*\u0000*cba* $longString] \ + [string match *===* $longString] + } + foo +} {0 1 1 1 0 0} + +## string range +test stringComp-12.1 {Bug 3588366: end-offsets before start} { + apply {s { + string range $s 0 end-5 + }} 12345 +} {} + +## string repeat +## not yet bc + +## string replace +test stringComp-14.1 {Bug 82e7f67325} { + apply {x { + set a [join $x {}] + lappend b [string length [string replace ___! 0 2 $a]] + lappend b [string length [string replace ___! 0 2 $a[unset a]]] + }} {a b} +} {3 3} +test stringComp-14.2 {Bug 82e7f67325} memory { + # As in stringComp-14.1, but make sure we don't retain too many refs + leaktest { + apply {x { + set a [join $x {}] + lappend b [string length [string replace ___! 0 2 $a]] + lappend b [string length [string replace ___! 0 2 $a[unset a]]] + }} {a b} + } +} {0} +test stringComp-14.3 {Bug 0dca3bfa8f} { + apply {arg { + set argCopy $arg + set arg [string replace $arg 1 2 aa] + # Crashes in comparison before fix + expr {$arg ne $argCopy} + }} abcde +} 1 +test stringComp-14.4 {Bug 1af8de570511} { + apply {{x y} { + # Generate an unshared string value + set val "" + for { set i 0 } { $i < $x } { incr i } { + set val [format "0%s" $val] + } + string replace $val[unset val] 1 1 $y + }} 4 x +} 0x00 +test stringComp-14.5 {} { + string length [string replace [string repeat a\u00fe 2] 3 end {}] +} 3 + +## string tolower +## not yet bc + +## string toupper +## not yet bc + +## string totitle +## not yet bc + +## string trim* +## not yet bc + +## string word* +## not yet bc + +## string cat +test stringComp-29.1 {string cat, no arg} { + proc foo {} {string cat} + foo +} "" +test stringComp-29.2 {string cat, single arg} { + proc foo {} { + set x FOO + string compare $x [string cat $x] + } + foo +} 0 +test stringComp-29.3 {string cat, two args} { + proc foo {} { + set x FOO + string compare $x$x [string cat $x $x] + } + foo +} 0 +test stringComp-29.4 {string cat, many args} { + proc foo {} { + set x FOO + set n 260 + set xx [string repeat $x $n] + set vv [string repeat {$x} $n] + set vvs [string repeat {$x } $n] + set r1 [string compare $xx [subst $vv]] + set r2 [string compare $xx [eval "string cat $vvs"]] + list $r1 $r2 + } + foo +} {0 0} + + +# cleanup +catch {rename foo {}} +::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# End: Index: tests/stringObj.test ================================================================== --- tests/stringObj.test +++ tests/stringObj.test @@ -10,12 +10,12 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -25,12 +25,12 @@ testConstraint testdstring [llength [info commands testdstring]] test stringObj-1.1 {string type registration} testobj { set t [testobj types] set first [string first "string" $t] - set result [expr {$first != -1}] -} {1} + set result [expr {$first >= 0}] +} 1 test stringObj-2.1 {Tcl_NewStringObj} testobj { set result "" lappend result [testobj freeallvars] lappend result [teststringobj set 1 abcd] @@ -478,17 +478,14 @@ } fooo test stringObj-15.8 {Tcl_Append*ToObj: self appends} testobj { teststringobj set 1 foo teststringobj appendself2 1 3 } foo + if {[testConstraint testobj]} { testobj freeallvars } # cleanup ::tcltest::cleanupTests return - -# Local Variables: -# mode: tcl -# End: Index: tests/subst.test ================================================================== --- tests/subst.test +++ tests/subst.test @@ -9,11 +9,11 @@ # Copyright (c) 1998-2000 Ajuba Solutions. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2.1 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -130,24 +130,24 @@ test subst-7.3 {switches} -returnCodes error -body { subst -bogus bar } -result {bad option "-bogus": must be -nobackslashes, -nocommands, or -novariables} test subst-7.4 {switches} { set x 123 - subst -nobackslashes {abc $x [expr 1+2] \\\x41} + subst -nobackslashes {abc $x [expr {1 + 2}] \\\x41} } {abc 123 3 \\\x41} test subst-7.5 {switches} { set x 123 - subst -nocommands {abc $x [expr 1+2] \\\x41} -} {abc 123 [expr 1+2] \A} + subst -nocommands {abc $x [expr {1 + 2}] \\\x41} +} {abc 123 [expr {1 + 2}] \A} test subst-7.6 {switches} { set x 123 - subst -novariables {abc $x [expr 1+2] \\\x41} + subst -novariables {abc $x [expr {1 + 2}] \\\x41} } {abc $x 3 \A} test subst-7.7 {switches} { set x 123 - subst -nov -nob -noc {abc $x [expr 1+2] \\\x41} -} {abc $x [expr 1+2] \\\x41} + subst -nov -nob -noc {abc $x [expr {1 + 2}] \\\x41} +} {abc $x [expr {1 + 2}] \\\x41} test subst-8.1 {return in a subst} { subst {foo [return {x}; bogus code] bar} } {foo x bar} test subst-8.2 {return in a subst} { @@ -280,22 +280,22 @@ subst $string } demo name2 } subst13.tcl] } -body { - interp create slave - slave eval [list source $script] - interp delete slave - interp create slave - slave eval { + interp create child + child eval [list source $script] + interp delete child + interp create child + child eval { set count 400 while {[incr count -1]} { lappend bloat [expr {rand()}] } } - slave eval [list source $script] - interp delete slave + child eval [list source $script] + interp delete child } -cleanup { removeFile subst13.tcl } test subst-13.2 {Test for segfault} -body { subst {[} Index: tests/switch.test ================================================================== --- tests/switch.test +++ tests/switch.test @@ -10,11 +10,11 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } test switch-1.1 {simple patterns} { switch a a {subst 1} b {subst 2} c {subst 3} default {subst 4} Index: tests/tailcall.test ================================================================== --- tests/tailcall.test +++ tests/tailcall.test @@ -7,12 +7,12 @@ # Copyright (c) 2008 by Miguel Sofer. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -26,13 +26,13 @@ if {[testConstraint testnrelevels]} { namespace eval testnre { # # [testnrelevels] returns a 6-list with: C-stack depth, iPtr->numlevels, - # cmdFrame level, callFrame level, tosPtr and callback depth + # cmdFrame level, callFrame level, tosPtr and callback depth # - variable last [testnrelevels] + variable last [testnrelevels] proc depthDiff {} { variable last set depth [testnrelevels] set res {} foreach t $depth l $last { @@ -146,11 +146,11 @@ rename a {} rename b {} } -result {0 0 0 0 0 0} test tailcall-0.5.1 {tailcall is constant space} -constraints testnrelevels -setup { - # + # # This test is related to [bug d87cb182053fd79b3]: the fix to that bug was # to remove a call to TclSkipTailcall, which caused a violation of the # constant-space property of tailcall in that particular # configuration. This test was added to detect that, and insure that the # problem is fixed. @@ -243,11 +243,11 @@ proc xset args {error b::xset} proc moo {} {set x 0; variable y [::a::foo]; set x} } variable x *:: proc xset args {error ::xset} - list [::b::moo] | $x $a::x $b::x | $::b::y + list [::b::moo] | $x $a::x $b::x | $::b::y } -cleanup { unset x rename xset {} namespace delete a b } -result {1::b | 0:: *::a *::b | {{1 ::b::moo} {2 xset}}} @@ -617,11 +617,11 @@ tailcall lappend x 1 }} set x } -cleanup { unset x -} -result {0 1} +} -result {0 1} test tailcall-12.3b0 {[Bug 2695587]} -body { apply {{} { set catch catch $catch [list tailcall foo] @@ -652,11 +652,11 @@ tailcall lappend x 1 }} set x } -cleanup { unset x -} -result {0 1} +} -result {0 1} # MORE VARIANTS MISSING: bc'ed caught script vs (bc'ed, not-bc'ed) # catch. Actually superfluous now, as tailcall just returns TCL_RETURN so that # standard catch behaviour is required. Index: tests/tcltest.test ================================================================== --- tests/tcltest.test +++ tests/tcltest.test @@ -11,11 +11,11 @@ # of a test that has a body that runs [test] that will fail. # This is a workaround of using the same tcltest code that we are # testing to run the test itself. Ditto on things like [verbose]. # # It would be better to have the -body of the tests run the tcltest -# commands in a slave interp so the [test] being tested would not +# commands in a child interp so the [test] being tested would not # interfere with the [test] doing the testing. # if {[catch {package require tcltest 2.1}]} { puts stderr "Skipping tests in [info script]. tcltest 2.1 required." @@ -25,11 +25,11 @@ namespace eval ::tcltest::test { namespace import ::tcltest::* makeFile { - package require tcltest + package require tcltest 2.5 namespace import ::tcltest::test test a-1.0 {test a} { list 0 } {0} test b-1.0 {test b} { @@ -61,15 +61,15 @@ set result [catch {exec [interpreter] test.tcl -h} msg] list $result [regexp Usage $msg] } {1 0} # -verbose, implicit & explicit testing of [verbose] -proc slave {msgVar args} { +proc child {msgVar args} { upvar 1 $msgVar msg interp create [namespace current]::i - # Fake the slave interp into dumping output to a file + # Fake the child interp into dumping output to a file i eval {namespace eval ::tcltest {}} i eval "set tcltest::outputChannel\ \[[list open [set of [makeFile {} output]] w]]" i eval "set tcltest::errorChannel\ \[[list open [set ef [makeFile {} error]] w]]" @@ -96,68 +96,68 @@ set code 1 append msg \n$err } return $code } -test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrPc} { - set result [slave msg test.tcl] +test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrWin} { + set result [child msg test.tcl] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 1 0 0 1} -test tcltest-2.1 {tcltest -verbose 'b'} {unixOrPc} { - set result [slave msg test.tcl -verbose 'b'] +test tcltest-2.1 {tcltest -verbose 'b'} {unixOrWin} { + set result [child msg test.tcl -verbose 'b'] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 1 0 0 1} -test tcltest-2.2 {tcltest -verbose 'p'} {unixOrPc} { - set result [slave msg test.tcl -verbose 'p'] +test tcltest-2.2 {tcltest -verbose 'p'} {unixOrWin} { + set result [child msg test.tcl -verbose 'p'] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 0 1 0 1} -test tcltest-2.3 {tcltest -verbose 's'} {unixOrPc} { - set result [slave msg test.tcl -verbose 's'] +test tcltest-2.3 {tcltest -verbose 's'} {unixOrWin} { + set result [child msg test.tcl -verbose 's'] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 0 0 1 1} -test tcltest-2.4 {tcltest -verbose 'ps'} {unixOrPc} { - set result [slave msg test.tcl -verbose 'ps'] +test tcltest-2.4 {tcltest -verbose 'ps'} {unixOrWin} { + set result [child msg test.tcl -verbose 'ps'] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 0 1 1 1} -test tcltest-2.5 {tcltest -verbose 'psb'} {unixOrPc} { - set result [slave msg test.tcl -verbose 'psb'] +test tcltest-2.5 {tcltest -verbose 'psb'} {unixOrWin} { + set result [child msg test.tcl -verbose 'psb'] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 1 1 1 1} -test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrPc} { - set result [slave msg test.tcl -verbose "pass skip body"] +test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrWin} { + set result [child msg test.tcl -verbose "pass skip body"] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 1 1 1 1} test tcltest-2.6 {tcltest -verbose 't'} { - -constraints {unixOrPc} + -constraints {unixOrWin} -body { - set result [slave msg test.tcl -verbose 't'] + set result [child msg test.tcl -verbose 't'] list $result $msg } -result {^0 .*a-1.0 start.*b-1.0 start} -match regexp } test tcltest-2.6a {tcltest -verbose 'start'} { - -constraints {unixOrPc} + -constraints {unixOrWin} -body { - set result [slave msg test.tcl -verbose start] + set result [child msg test.tcl -verbose start] list $result $msg } -result {^0 .*a-1.0 start.*b-1.0 start} -match regexp } @@ -174,36 +174,36 @@ } -result {body {}} } test tcltest-2.8 {tcltest -verbose 'error'} { - -constraints {unixOrPc} + -constraints {unixOrWin} -body { - set result [slave msg test.tcl -verbose error] + set result [child msg test.tcl -verbose error] list $result $msg } -result {errorInfo: foo.*errorCode: 9} -match regexp } # -match, [match] -test tcltest-3.1 {tcltest -match 'a*'} {unixOrPc} { - set result [slave msg test.tcl -match a* -verbose 'ps'] +test tcltest-3.1 {tcltest -match 'a*'} {unixOrWin} { + set result [child msg test.tcl -match a* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg] } {0 1 0 0 1} -test tcltest-3.2 {tcltest -match 'b*'} {unixOrPc} { - set result [slave msg test.tcl -match b* -verbose 'ps'] +test tcltest-3.2 {tcltest -match 'b*'} {unixOrWin} { + set result [child msg test.tcl -match b* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg] } {0 0 1 0 1} -test tcltest-3.3 {tcltest -match 'c*'} {unixOrPc} { - set result [slave msg test.tcl -match c* -verbose 'ps'] +test tcltest-3.3 {tcltest -match 'c*'} {unixOrWin} { + set result [child msg test.tcl -match c* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+0.+Skipped.+4.+Failed.+0" $msg] } {0 0 0 1 1} -test tcltest-3.4 {tcltest -match 'a* b*'} {unixOrPc} { - set result [slave msg test.tcl -match {a* b*} -verbose 'ps'] +test tcltest-3.4 {tcltest -match 'a* b*'} {unixOrWin} { + set result [child msg test.tcl -match {a* b*} -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg] } {0 1 1 0 1} test tcltest-3.5 {tcltest::match} { @@ -218,32 +218,32 @@ } -result {foo bar} } # -skip, [skip] -test tcltest-4.1 {tcltest -skip 'a*'} {unixOrPc} { - set result [slave msg test.tcl -skip a* -verbose 'ps'] +test tcltest-4.1 {tcltest -skip 'a*'} {unixOrWin} { + set result [child msg test.tcl -skip a* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+0.+Skipped.+2.+Failed.+1" $msg] } {0 0 1 1 1} -test tcltest-4.2 {tcltest -skip 'b*'} {unixOrPc} { - set result [slave msg test.tcl -skip b* -verbose 'ps'] +test tcltest-4.2 {tcltest -skip 'b*'} {unixOrWin} { + set result [child msg test.tcl -skip b* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg] } {0 1 0 1 1} -test tcltest-4.3 {tcltest -skip 'c*'} {unixOrPc} { - set result [slave msg test.tcl -skip c* -verbose 'ps'] +test tcltest-4.3 {tcltest -skip 'c*'} {unixOrWin} { + set result [child msg test.tcl -skip c* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 1 1 0 1} -test tcltest-4.4 {tcltest -skip 'a* b*'} {unixOrPc} { - set result [slave msg test.tcl -skip {a* b*} -verbose 'ps'] +test tcltest-4.4 {tcltest -skip 'a* b*'} {unixOrWin} { + set result [child msg test.tcl -skip {a* b*} -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg] } {0 0 0 1 1} -test tcltest-4.5 {tcltest -match 'a* b*' -skip 'b*'} {unixOrPc} { - set result [slave msg test.tcl -match {a* b*} -skip b* -verbose 'ps'] +test tcltest-4.5 {tcltest -match 'a* b*' -skip 'b*'} {unixOrWin} { + set result [child msg test.tcl -match {a* b*} -skip b* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg] } {0 1 0 0 1} test tcltest-4.6 {tcltest::skip} { @@ -259,17 +259,17 @@ -result {foo bar} } # -constraints, -limitconstraints, [testConstraint], # $constraintsSpecified, [limitConstraints] -test tcltest-5.1 {tcltest -constraints 'knownBug'} {unixOrPc} { - set result [slave msg test.tcl -constraints knownBug -verbose 'ps'] +test tcltest-5.1 {tcltest -constraints 'knownBug'} {unixOrWin} { + set result [child msg test.tcl -constraints knownBug -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+2.+Skipped.+0.+Failed.+2" $msg] } {0 1 1 1 1} -test tcltest-5.2 {tcltest -constraints 'knownBug' -limitconstraints 1} {unixOrPc} { - set result [slave msg test.tcl -constraints knownBug -verbose 'p' -limitconstraints 1] +test tcltest-5.2 {tcltest -constraints 'knownBug' -limitconstraints 1} {unixOrWin} { + set result [child msg test.tcl -constraints knownBug -verbose 'p' -limitconstraints 1] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg] } {0 0 0 1 1} test tcltest-5.3 {testConstraint - constraint empty (tcltest::safeFetch)} { @@ -338,11 +338,11 @@ # -result {false knownBug knownBug} #} # -outfile, -errfile, [outputChannel], [outputFile], [errorChannel], [errorFile] set printerror [makeFile { - package require tcltest + package require tcltest 2.5 namespace import ::tcltest::* puts [outputChannel] "a test" ::tcltest::PrintError "a really short string" ::tcltest::PrintError "a really really really really really really long \ string containing \"quotes\" and other bad bad stuff" @@ -353,34 +353,34 @@ ::tcltest::PrintError "Problem renaming file: error renaming \"Z:/ws/tcl8.2/win32-ix86/tests/core\" to \"Z:/ws/tcl8.2/win32-ix86/tests/movecore-core\"" exit } printerror.tcl] test tcltest-6.1 {tcltest -outfile, -errfile defaults} { - -constraints unixOrPc + -constraints unixOrWin -body { - slave msg $printerror + child msg $printerror return $msg } -result {a test.*a really} -match regexp } -test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrPc unixExecs} { - slave msg $printerror -outfile a.tmp +test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrWin unixExecs} { + child msg $printerror -outfile a.tmp set result1 [catch {exec grep "a test" a.tmp}] set result2 [catch {exec grep "a really" a.tmp}] list [regexp "a test" $msg] [regexp "a really" $msg] \ $result1 $result2 [file exists a.tmp] [file delete a.tmp] } {0 1 0 1 1 {}} -test tcltest-6.3 {tcltest -errfile a.tmp} {unixOrPc unixExecs} { - slave msg $printerror -errfile a.tmp +test tcltest-6.3 {tcltest -errfile a.tmp} {unixOrWin unixExecs} { + child msg $printerror -errfile a.tmp set result1 [catch {exec grep "a test" a.tmp}] set result2 [catch {exec grep "a really" a.tmp}] list [regexp "a test" $msg] [regexp "a really" $msg] \ $result1 $result2 [file exists a.tmp] [file delete a.tmp] } {1 0 1 0 1 {}} -test tcltest-6.4 {tcltest -outfile a.tmp -errfile b.tmp} {unixOrPc unixExecs} { - slave msg $printerror -outfile a.tmp -errfile b.tmp +test tcltest-6.4 {tcltest -outfile a.tmp -errfile b.tmp} {unixOrWin unixExecs} { + child msg $printerror -outfile a.tmp -errfile b.tmp set result1 [catch {exec grep "a test" a.tmp}] set result2 [catch {exec grep "a really" b.tmp}] list [regexp "a test" $msg] [regexp "a really" $msg] \ $result1 $result2 \ [file exists a.tmp] [file delete a.tmp] \ @@ -461,30 +461,30 @@ } # -debug, [debug] # Must use child processes to test -debug because it always writes # messages to stdout, and we have no way to capture stdout of a -# slave interp -test tcltest-7.1 {tcltest test.tcl -debug 0} {unixOrPc} { +# child interp +test tcltest-7.1 {tcltest test.tcl -debug 0} {unixOrWin} { catch {exec [interpreter] test.tcl -debug 0} msg regexp "Flags passed into tcltest" $msg } {0} -test tcltest-7.2 {tcltest test.tcl -debug 1} {unixOrPc} { +test tcltest-7.2 {tcltest test.tcl -debug 1} {unixOrWin} { catch {exec [interpreter] test.tcl -debug 1 -skip b*} msg list [regexp userSpecifiedSkip $msg] \ [regexp "Flags passed into tcltest" $msg] } {1 0} -test tcltest-7.3 {tcltest test.tcl -debug 1} {unixOrPc} { +test tcltest-7.3 {tcltest test.tcl -debug 1} {unixOrWin} { catch {exec [interpreter] test.tcl -debug 1 -match b*} msg list [regexp userSpecifiedNonMatch $msg] \ [regexp "Flags passed into tcltest" $msg] } {1 0} -test tcltest-7.4 {tcltest test.tcl -debug 2} {unixOrPc} { +test tcltest-7.4 {tcltest test.tcl -debug 2} {unixOrWin} { catch {exec [interpreter] test.tcl -debug 2} msg list [regexp "Flags passed into tcltest" $msg] [regexp "Running" $msg] } {1 0} -test tcltest-7.5 {tcltest test.tcl -debug 3} {unixOrPc} { +test tcltest-7.5 {tcltest test.tcl -debug 3} {unixOrWin} { catch {exec [interpreter] test.tcl -debug 3} msg list [regexp "Flags passed into tcltest" $msg] [regexp "Running" $msg] } {1 1} test tcltest-7.6 {tcltest::debug} { @@ -508,11 +508,11 @@ removeFile test.tcl # directory tests set a [makeFile { - package require tcltest + package require tcltest 2.5 tcltest::makeFile {} a.tmp puts [tcltest::outputChannel] "testdir: [tcltest::testsDirectory]" exit } a.tcl] @@ -520,22 +520,22 @@ set normaldirectory [makeDirectory normaldirectory] normalizePath normaldirectory # -tmpdir, [temporaryDirectory] -test tcltest-8.1 {tcltest a.tcl -tmpdir a} -constraints unixOrPc -setup { +test tcltest-8.1 {tcltest a.tcl -tmpdir a} -constraints unixOrWin -setup { file delete -force thisdirectorydoesnotexist } -body { - slave msg $a -tmpdir thisdirectorydoesnotexist + child msg $a -tmpdir thisdirectorydoesnotexist file exists [file join thisdirectorydoesnotexist a.tmp] } -cleanup { file delete -force thisdirectorydoesnotexist } -result 1 test tcltest-8.2 {tcltest a.tcl -tmpdir thisdirectoryisafile} { - -constraints unixOrPc + -constraints unixOrWin -body { - slave msg $a -tmpdir $tdiaf + child msg $a -tmpdir $tdiaf return $msg } -result {*not a directory*} -match glob } @@ -542,11 +542,10 @@ # Test non-writeable directories, non-readable directories with directory flags set notReadableDir [file join [temporaryDirectory] notreadable] set notWriteableDir [file join [temporaryDirectory] notwriteable] makeDirectory notreadable makeDirectory notwriteable - switch -- $::tcl_platform(platform) { unix { file attributes $notReadableDir -permissions 00333 file attributes $notWriteableDir -permissions 00555 } @@ -557,11 +556,11 @@ } } test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} { -constraints {unix notRoot} -body { - slave msg $a -tmpdir $notReadableDir + child msg $a -tmpdir $notReadableDir return $msg } -result {*not readable*} -match glob } @@ -571,22 +570,22 @@ ![regexp {^(FAT\d*|NTFS)$} [lindex [file system $notWriteableDir] 1]] || $::tcl_platform(platform) eq "unix" || [llength [info commands testchmod]] }] # FAT/NTFS permissions are fairly hopeless; ignore this test if that FS is used test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} { - -constraints {unixOrPc notRoot notFAT} + -constraints {unixOrWin notRoot notFAT} -body { - slave msg $a -tmpdir $notWriteableDir + child msg $a -tmpdir $notWriteableDir return $msg } -result {*not writeable*} -match glob } test tcltest-8.5 {tcltest a.tcl -tmpdir normaldirectory} { - -constraints unixOrPc + -constraints unixOrWin -body { - slave msg $a -tmpdir $normaldirectory + child msg $a -tmpdir $normaldirectory # The join is necessary because the message can be split on multiple # lines file exists [file join $normaldirectory a.tmp] } -cleanup { @@ -623,43 +622,43 @@ set ::tcltest::temporaryDirectory $old } -result [list $normaldirectory [workingDirectory] [workingDirectory]] cd [temporaryDirectory] # -testdir, [testsDirectory] test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} { - -constraints unixOrPc + -constraints unixOrWin -setup { file delete -force thisdirectorydoesnotexist } -body { - slave msg $a -testdir thisdirectorydoesnotexist + child msg $a -testdir thisdirectorydoesnotexist return $msg } -match glob -result {*does not exist*} } test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} { - -constraints unixOrPc + -constraints unixOrWin -body { - slave msg $a -testdir $tdiaf + child msg $a -testdir $tdiaf return $msg } -match glob -result {*not a directory*} } test tcltest-8.12 {tcltest a.tcl -testdir notReadableDir} { -constraints {unix notRoot} -body { - slave msg $a -testdir $notReadableDir + child msg $a -testdir $notReadableDir return $msg } -match glob -result {*not readable*} } test tcltest-8.13 {tcltest a.tcl -testdir normaldirectory} { - -constraints unixOrPc + -constraints unixOrWin -body { - slave msg $a -testdir $normaldirectory + child msg $a -testdir $normaldirectory # The join is necessary because the message can be split on multiple # lines list [string first "testdir: $normaldirectory" [join $msg]] \ [file exists [file join [temporaryDirectory] a.tmp]] } @@ -730,25 +729,25 @@ removeFile a.tcl removeFile thisdirectoryisafile removeDirectory normaldirectory # -file, -notfile, [matchFiles], [skipFiles] -test tcltest-9.1 {-file d*.tcl} -constraints {unixOrPc} -setup { +test tcltest-9.1 {-file d*.tcl} -constraints {unixOrWin} -setup { set old [testsDirectory] testsDirectory [file dirname [info script]] } -body { - slave msg [file join [testsDirectory] all.tcl] -file d*.test + child msg [file join [testsDirectory] all.tcl] -file d*.test return $msg } -cleanup { testsDirectory $old } -match regexp -result {dstring\.test} -test tcltest-9.2 {-file d*.tcl} -constraints {unixOrPc} -setup { +test tcltest-9.2 {-file d*.tcl} -constraints {unixOrWin} -setup { set old [testsDirectory] testsDirectory [file dirname [info script]] } -body { - slave msg [file join [testsDirectory] all.tcl] \ + child msg [file join [testsDirectory] all.tcl] \ -file d*.test -notfile dstring* regexp {dstring\.test} $msg } -cleanup { testsDirectory $old } -result 0 @@ -783,11 +782,11 @@ set d [makeDirectory tmp] makeDirectory foo $d makeFile {} fee $d file copy [file join [file dirname [info script]] all.tcl] $d } -body { - slave msg [file join [temporaryDirectory] all.tcl] -file f* + child msg [file join [temporaryDirectory] all.tcl] -file f* regexp {exiting with errors:} $msg } -cleanup { file delete [file join $d all.tcl] removeFile fee $d removeDirectory foo $d @@ -794,11 +793,11 @@ removeDirectory tmp } -result 0 # -preservecore, [preserveCore] set mc [makeFile { - package require tcltest + package require tcltest 2.5 namespace import ::tcltest::test test makecore {make a core file} { set f [open core w] close $f } {} @@ -805,28 +804,28 @@ ::tcltest::cleanupTests return } makecore.tcl] cd [temporaryDirectory] -test tcltest-10.1 {-preservecore 0} {unixOrPc} { - slave msg $mc -preservecore 0 +test tcltest-10.1 {-preservecore 0} {unixOrWin} { + child msg $mc -preservecore 0 file delete core regexp "Core file produced" $msg } {0} -test tcltest-10.2 {-preservecore 1} {unixOrPc} { - slave msg $mc -preservecore 1 +test tcltest-10.2 {-preservecore 1} {unixOrWin} { + child msg $mc -preservecore 1 file delete core regexp "Core file produced" $msg } {1} -test tcltest-10.3 {-preservecore 2} {unixOrPc} { - slave msg $mc -preservecore 2 +test tcltest-10.3 {-preservecore 2} {unixOrWin} { + child msg $mc -preservecore 2 file delete core list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \ [regexp "core-" $msg] [file delete core-makecore] } {1 1 1 {}} -test tcltest-10.4 {-preservecore 3} {unixOrPc} { - slave msg $mc -preservecore 3 +test tcltest-10.4 {-preservecore 3} {unixOrWin} { + child msg $mc -preservecore 3 file delete core list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \ [regexp "core-" $msg] [file delete core-makecore] } {1 1 1 {}} @@ -845,24 +844,24 @@ #} removeFile makecore.tcl # -load, -loadfile, [loadScript], [loadFile] set contents { - package require tcltest + package require tcltest 2.5 namespace import tcltest::* puts [outputChannel] $::tcltest::loadScript exit } set loadfile [makeFile $contents load.tcl] -test tcltest-12.1 {-load xxx} {unixOrPc} { - slave msg $loadfile -load xxx +test tcltest-12.1 {-load xxx} {unixOrWin} { + child msg $loadfile -load xxx return $msg } {xxx} # Using child process because of -debug usage. -test tcltest-12.2 {-loadfile load.tcl} {unixOrPc} { +test tcltest-12.2 {-loadfile load.tcl} {unixOrWin} { catch {exec [interpreter] $loadfile -debug 2 -loadfile $loadfile} msg list \ [regexp {tcltest} [join [list $msg] [split $msg \n]]] \ [regexp {loadScript} [join [list $msg] [split $msg \n]]] } {1 1} @@ -941,31 +940,31 @@ makeFile { unset foo } single2.test $spd set allfile [makeFile { - package require tcltest + package require tcltest 2.5 namespace import tcltest::* testsDirectory [file join [temporaryDirectory] singleprocdir] runAllTests } all-single.tcl $spd] cd [workingDirectory] test tcltest-14.1 {-singleproc - single process} { - -constraints {unixOrPc} + -constraints {unixOrWin} -body { - slave msg $allfile -singleproc 0 -tmpdir [temporaryDirectory] + child msg $allfile -singleproc 0 -tmpdir [temporaryDirectory] return $msg } -result {Test file error: can't unset .foo.: no such variable} -match regexp } test tcltest-14.2 {-singleproc - multiple process} { - -constraints {unixOrPc} + -constraints {unixOrWin} -body { - slave msg $allfile -singleproc 1 -tmpdir [temporaryDirectory] + child msg $allfile -singleproc 1 -tmpdir [temporaryDirectory] return $msg } -result {single1.test.*single2.test.*all\-single.tcl:.*Total.*0.*Passed.*0.*Skipped.*0.*Failed.*0} -match regexp } @@ -998,38 +997,38 @@ set dtd [makeDirectory dirtestdir] set dtd1 [makeDirectory dirtestdir2.1 $dtd] set dtd2 [makeDirectory dirtestdir2.2 $dtd] set dtd3 [makeDirectory dirtestdir2.3 $dtd] makeFile { - package require tcltest + package require tcltest 2.5 namespace import -force tcltest::* testsDirectory [file join [temporaryDirectory] dirtestdir] runAllTests } all.tcl $dtd makeFile { - package require tcltest + package require tcltest 2.5 namespace import -force tcltest::* testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.1] runAllTests } all.tcl $dtd1 makeFile { - package require tcltest + package require tcltest 2.5 namespace import -force tcltest::* testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.2] runAllTests } all.tcl $dtd2 makeFile { - package require tcltest + package require tcltest 2.5 namespace import -force tcltest::* testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.3] runAllTests } all.tcl $dtd3 test tcltest-15.1 {basic directory walking} { - -constraints {unixOrPc} + -constraints {unixOrWin} -body { - if {[slave msg \ + if {[child msg \ [file join $dtd all.tcl] \ -tmpdir [temporaryDirectory]] == 1} { error $msg } } @@ -1037,13 +1036,13 @@ -returnCodes 1 -result {Tests located in:.*dirtestdir.*Tests located in:.*dirtestdir2.[123].*Tests located in:.*dirtestdir2.[123].*Tests located in:.*dirtestdir2.[123]} } test tcltest-15.2 {-asidefromdir} { - -constraints {unixOrPc} + -constraints {unixOrWin} -body { - if {[slave msg \ + if {[child msg \ [file join $dtd all.tcl] \ -asidefromdir dirtestdir2.3 \ -tmpdir [temporaryDirectory]] == 1} { error $msg } @@ -1055,13 +1054,13 @@ Error: No test files remain after applying your match and skip patterns! Error: No test files remain after applying your match and skip patterns!$} } test tcltest-15.3 {-relateddir, non-existent dir} { - -constraints {unixOrPc} + -constraints {unixOrWin} -body { - if {[slave msg \ + if {[child msg \ [file join $dtd all.tcl] \ -relateddir [file join [temporaryDirectory] dirtestdir0] \ -tmpdir [temporaryDirectory]] == 1} { error $msg } @@ -1070,13 +1069,13 @@ -match regexp -result {[^~]|dirtestdir[^2]} } test tcltest-15.4 {-relateddir, subdir} { - -constraints {unixOrPc} + -constraints {unixOrWin} -body { - if {[slave msg \ + if {[child msg \ [file join $dtd all.tcl] \ -relateddir dirtestdir2.1 -tmpdir [temporaryDirectory]] == 1} { error $msg } } @@ -1083,13 +1082,13 @@ -returnCodes 1 -match regexp -result {Tests located in:.*dirtestdir2.[^23]} } test tcltest-15.5 {-relateddir, -asidefromdir} { - -constraints {unixOrPc} + -constraints {unixOrWin} -body { - if {[slave msg \ + if {[child msg \ [file join $dtd all.tcl] \ -relateddir "dirtestdir2.1 dirtestdir2.2" \ -asidefromdir dirtestdir2.2 \ -tmpdir [temporaryDirectory]] == 1} { error $msg @@ -1146,38 +1145,38 @@ set oldoptions none } # set this to { } instead of just {} to get around quirk in # Windows env handling that removes empty elements from env array. set ::env(TCLTEST_OPTIONS) { } - interp create slave1 - slave1 eval [list set argv {-debug 2}] - slave1 alias puts puts - interp create slave2 - slave2 alias puts puts + interp create child1 + child1 eval [list set argv {-debug 2}] + child1 alias puts puts + interp create child2 + child2 alias puts puts } -cleanup { - interp delete slave2 - interp delete slave1 + interp delete child2 + interp delete child1 if {$oldoptions eq "none"} { unset ::env(TCLTEST_OPTIONS) } else { set ::env(TCLTEST_OPTIONS) $oldoptions } } -body { - slave1 eval [package ifneeded tcltest [package provide tcltest]] - slave1 eval tcltest::debug + child1 eval [package ifneeded tcltest [package provide tcltest]] + child1 eval tcltest::debug set ::env(TCLTEST_OPTIONS) "-debug 3" - slave2 eval [package ifneeded tcltest [package provide tcltest]] - slave2 eval tcltest::debug + child2 eval [package ifneeded tcltest [package provide tcltest]] + child2 eval tcltest::debug } -result {^3$} -match regexp -output\ {tcltest::debug\s+= 2.*tcltest::debug\s+= 3} # Begin testing of tcltest procs ... cd [temporaryDirectory] # PrintError -test tcltest-20.1 {PrintError} {unixOrPc} { - set result [slave msg $printerror] +test tcltest-20.1 {PrintError} {unixOrWin} { + set result [child msg $printerror] list $result [regexp "Error: a really short string" $msg] \ [regexp " \"quotes\"" $msg] [regexp " \"Path" $msg] \ [regexp " \"Really" $msg] [regexp Problem $msg] } {1 1 1 1 1 1} cd [workingDirectory] @@ -1384,11 +1383,11 @@ # test all.tcl usage (runAllTests); simulate .test file failure, as well as # crashes to determine whether or not these errors are logged. set atd [makeDirectory alltestdir] makeFile { - package require tcltest + package require tcltest 2.5 namespace import -force tcltest::* testsDirectory [file join [temporaryDirectory] alltestdir] runAllTests } all.tcl $atd makeFile { @@ -1396,23 +1395,23 @@ } exit.test $atd makeFile { error "throw an error" } error.test $atd makeFile { - package require tcltest + package require tcltest 2.5 namespace import -force tcltest::* test foo-1.1 {foo} { -body { return 1 } -result {1} } cleanupTests } test.test $atd # Must use a child process because stdout/stderr parsing can't be -# duplicated in slave interp. +# duplicated in child interp. test tcltest-22.1 {runAllTests} { - -constraints {unixOrPc} + -constraints {unixOrWin} -body { exec [interpreter] \ [file join $atd all.tcl] \ -verbose t -tmpdir [temporaryDirectory] } @@ -1443,11 +1442,11 @@ -setup { set mfdir [file join [temporaryDirectory] mfdir] file mkdir $mfdir makeFile {} t1.tmp makeFile {} et1.tmp $mfdir - if {![file exists [file join [temporaryDirectory] t1.tmp]] || \ + if {![file exists [file join [temporaryDirectory] t1.tmp]] || \ ![file exists [file join $mfdir et1.tmp]]} { error "file creation didn't work" } } -body { @@ -1795,41 +1794,41 @@ verbose $v } -match glob -output {*generated error; Return code was: 1*} test tcltest-26.1 {Bug/RFE 1017151} -setup { makeFile { - package require tcltest + package require tcltest 2.5 set ::errorInfo "Should never see this" tcltest::test tcltest-26.1.0 { no errorInfo when only return code mismatch } -body { set x 1 } -returnCodes error -result 1 tcltest::cleanupTests } test.tcl } -body { - slave msg [file join [temporaryDirectory] test.tcl] + child msg [file join [temporaryDirectory] test.tcl] return $msg } -cleanup { removeFile test.tcl } -match glob -result {* ---- Return code should have been one of: 1 ==== tcltest-26.1.0 FAILED*} test tcltest-26.2 {Bug/RFE 1017151} -setup { makeFile { - package require tcltest + package require tcltest 2.5 set ::errorInfo "Should never see this" tcltest::test tcltest-26.2.0 {do not mask body errorInfo} -body { error "body error" } -cleanup { error "cleanup error" } -result 1 tcltest::cleanupTests } test.tcl } -body { - slave msg [file join [temporaryDirectory] test.tcl] + child msg [file join [temporaryDirectory] test.tcl] return $msg } -cleanup { removeFile test.tcl } -match glob -result {* ---- errorInfo: body error Index: tests/tcltests.tcl ================================================================== --- tests/tcltests.tcl +++ tests/tcltests.tcl @@ -1,13 +1,46 @@ #! /usr/bin/env tclsh -package require tcltest 2.2 +package require tcltest 2.5 namespace import ::tcltest::* testConstraint exec [llength [info commands exec]] testConstraint fcopy [llength [info commands fcopy]] testConstraint fileevent [llength [info commands fileevent]] testConstraint thread [ expr {0 == [catch {package require Thread 2.7-}]}] testConstraint notValgrind [expr {![testConstraint valgrind]}] -package provide tcltests 0.1 +namespace eval ::tcltests { + + + proc init {} { + if {[namespace which ::tcl::file::tempdir] eq {}} { + interp alias {} [namespace current]::tempdir {} [ + namespace current]::tempdir_alternate + } else { + interp alias {} [namespace current]::tempdir {} ::tcl::file::tempdir + } + } + + + proc tempdir_alternate {} { + close [file tempfile tempfile] + set tmpdir [file dirname $tempfile] + set execname [info nameofexecutable] + regsub -all {[^[:alpha:][:digit:]]} $execname _ execname + for {set i 0} {$i < 10000} {incr i} { + set time [clock milliseconds] + set name $tmpdir/${execname}_${time}_$i + if {![file exists $name]} { + file mkdir $name + return $name + } + } + error [list {could not create temporary directory}] + } + + init + + package provide tcltests 0.1 + +} Index: tests/thread.test ================================================================== --- tests/thread.test +++ tests/thread.test @@ -9,21 +9,18 @@ # Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {"::tcltest" ni [namespace children]} { - package require tcltest 2 - namespace import -force ::tcltest::* -} # when thread::release is used, -wait is passed in order allow the thread to # be fully finalized, which avoids valgrind "still reachable" reports. + +package require tcltests ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] -package require tcltests # Some tests require the testthread command testConstraint testthread [expr {[info commands testthread] ne {}}] @@ -37,15 +34,15 @@ } proc getThreadErrorFromInfo { info } { set list [split $info \n] set idx [lsearch -glob $list "*eval*unwound*"] - if {$idx != -1} then { + if {$idx >= 0} then { return [lindex $list $idx] } set idx [lsearch -glob $list "*eval*canceled*"] - if {$idx != -1} then { + if {$idx >= 0} then { return [lindex $list $idx] } return ""; # some other error we do not care about. } @@ -803,11 +800,11 @@ [expr {[info exists ::threadError($serverthread)] ? \ [findThreadError $::threadError($serverthread)] : ""}] } -cleanup { unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted } -result {{} 1 1 {eval unwound}} -test thread-7.22 {cancel: slave interp} -constraints {thread drainEventQueue} -setup { +test thread-7.22 {cancel: child interp} -constraints {thread drainEventQueue} -setup { unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted } -body { set serverthread [thread::create -joinable \ [string map [list %ID% [thread::id]] { set i [interp create] @@ -833,11 +830,11 @@ [expr {[info exists ::threadError($serverthread)] ? \ [findThreadError $::threadError($serverthread)] : ""}] } -cleanup { unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted } -result {{} 1 1 {eval canceled}} -test thread-7.23 {cancel: slave interp -unwind} -constraints {thread drainEventQueue} -setup { +test thread-7.23 {cancel: child interp -unwind} -constraints {thread drainEventQueue} -setup { unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted } -body { set serverthread [thread::create -joinable \ [string map [list %ID% [thread::id]] { set i [interp create] Index: tests/timer.test ================================================================== --- tests/timer.test +++ tests/timer.test @@ -11,12 +11,12 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } test timer-1.1 {Tcl_CreateTimerHandler procedure} -setup { foreach i [after info] { @@ -566,19 +566,19 @@ update return $x } -result {before after2 after4} test timer-10.1 {Bug 1016167: [after] overwrites imports} -setup { - interp create slave - slave eval namespace export after - slave eval namespace eval foo namespace import ::after + interp create child + child eval namespace export after + child eval namespace eval foo namespace import ::after } -body { - slave eval foo::after 1 - slave eval namespace origin foo::after + child eval foo::after 1 + child eval namespace origin foo::after } -cleanup { # Bug will cause crash here; would cause failure otherwise - interp delete slave + interp delete child } -result ::after test timer-11.1 {Bug 1350291: [after] overflowing 32-bit field} -body { set b ok set a [after 0x100000001 {set b "after fired early"}] Index: tests/tm.test ================================================================== --- tests/tm.test +++ tests/tm.test @@ -6,11 +6,11 @@ # Copyright (c) 2004 by Donal K. Fellows. # All rights reserved. package require Tcl 8.5- if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } test tm-1.1 {tm: path command exists} { catch { ::tcl::tm::path } @@ -198,11 +198,11 @@ proc genpaths {base} { # Normalizing picks up drive letters on windows [Bug 1053568] set base [file normalize $base] - lassign [split [package present Tcl] .] major minor + regexp {^(\d+)\.(\d+)} [package provide Tcl] - major minor set results {} set base [file join $base tcl$major] lappend results [file join $base site-tcl] for {set i 0} {$i <= $minor} {incr i} { lappend results [file join $base ${major}.$i] Index: tests/trace.test ================================================================== --- tests/trace.test +++ tests/trace.test @@ -9,12 +9,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] testConstraint testcmdtrace [llength [info commands testcmdtrace]] @@ -2195,15 +2197,15 @@ } else { return "ok" }} 2 error leavestep foo foo 0 error leave}} -test trace-28.4 {exec traces in slave with 'return -code error'} { - interp create slave - interp alias slave traceExecute {} traceExecute +test trace-28.4 {exec traces in child with 'return -code error'} { + interp create child + interp alias child traceExecute {} traceExecute set info {} - set res [interp eval slave { + set res [interp eval child { set info {} set res {} proc foo {} { if {[catch {bar}]} { @@ -2227,11 +2229,11 @@ trace remove execution foo {enter enterstep leave leavestep} \ [list traceExecute foo] list $res }] - interp delete slave + interp delete child lappend res [join $info \n] } {{error error} {foo foo enter foo {if {[catch {bar}]} { return "error" } else { @@ -2310,12 +2312,12 @@ test trace-28.10 {exec trace info nonsense} { list [catch {trace remove execution} res] $res } {1 {wrong # args: should be "trace remove execution name opList command"}} test trace-29.1 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {testcmdtrace} { - testcmdtrace tracetest {set stuff [expr 14 + 16]} -} {{expr 14 + 16} {expr 14 + 16} {set stuff [expr 14 + 16]} {set stuff 30}} + testcmdtrace tracetest {set stuff [expr {14 + 16}]} +} {{expr {14 + 16}} {expr {14 + 16}} {set stuff [expr {14 + 16}]} {set stuff 30}} test trace-29.2 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {testcmdtrace} { testcmdtrace tracetest {set stuff [info tclversion]} } [concat {{info tclversion} {info tclversion} ::tcl::info::tclversion {::tcl::info::tclversion} {set stuff [info tclversion]}} [list "set stuff [info tclversion]"]] test trace-29.3 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {testcmdtrace} { testcmdtrace deletetest {set stuff [info tclversion]} Index: tests/unixFCmd.test ================================================================== --- tests/unixFCmd.test +++ tests/unixFCmd.test @@ -7,12 +7,12 @@ # Copyright (c) 1996 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -219,16 +219,16 @@ } -result {fifo fifo} test unixFCmd-2.5 {TclpCopyFile: copy attributes} -setup { cleanup } -constraints {unix notRoot} -body { close [open tf1 a] - file attributes tf1 -permissions 0o472 + file attributes tf1 -permissions 0472 file copy tf1 tf2 file attributes tf2 -permissions } -cleanup { cleanup -} -result 0o472 ;# i.e. perms field of [exec ls -l tf2] is -r--rwx-w- +} -result 00472 ;# i.e. perms field of [exec ls -l tf2] is -r--rwx-w- test unixFCmd-3.1 {CopyFile not done} {emptyTest unix notRoot} { } {} test unixFCmd-4.1 {TclpDeleteFile not done} {emptyTest unix notRoot} { @@ -373,15 +373,15 @@ lappend result [file attributes foo.test -permissions] } set result } $expected } -permcheck unixFCmd-17.5 rwxrwxrwx 0o777 -permcheck unixFCmd-17.6 r--r---w- 0o442 -permcheck unixFCmd-17.7 {0 u+rwx,g+r u-w o+rwx} {00000 0o740 0o540 0o547} -permcheck unixFCmd-17.11 --x--x--x 0o111 -permcheck unixFCmd-17.12 {0 a+rwx} {00000 0o777} +permcheck unixFCmd-17.5 rwxrwxrwx 00777 +permcheck unixFCmd-17.6 r--r---w- 00442 +permcheck unixFCmd-17.7 {0 u+rwx,g+r u-w o+rwx} {00000 00740 00540 00547} +permcheck unixFCmd-17.11 --x--x--x 00111 +permcheck unixFCmd-17.12 {0 a+rwx} {00000 00777} file delete -force -- foo.test test unixFCmd-18.1 {Unix pwd} -constraints {unix notRoot nonPortable} -setup { set cd [pwd] } -body { Index: tests/unixFile.test ================================================================== --- tests/unixFile.test +++ tests/unixFile.test @@ -7,12 +7,12 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] Index: tests/unixForkEvent.test ================================================================== --- tests/unixForkEvent.test +++ tests/unixForkEvent.test @@ -6,11 +6,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 +package require tcltest 2.5 namespace import -force ::tcltest::* testConstraint testfork [llength [info commands testfork]] # Test if the notifier thread is well initialized in a forked interpreter @@ -35,11 +35,11 @@ # we are the original process while {![file readable [file join $myFolder result.txt]]} {} viewFile result.txt $myFolder } \ -result {writable} \ - -cleanup { + -cleanup { catch { removeFolder $myFolder } } ::tcltest::cleanupTests return Index: tests/unixInit.test ================================================================== --- tests/unixInit.test +++ tests/unixInit.test @@ -8,18 +8,15 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2.2 +package require tcltest 2.5 namespace import ::tcltest::* unset -nocomplain path catch {set oldlang $env(LANG)} set env(LANG) C - -# Some tests require the testgetencpath command -testConstraint testgetencpath [llength [info commands testgetencpath]] test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unix stdio} { set x {} # Watch out for a race condition here. If tcltest is too slow to start # then we'll kill it before it has a chance to set up its signal handler. @@ -88,19 +85,17 @@ # TclpInitLibraryPath. That routine no longer does the things it used to do # so those tests are obsolete. Skip them. skip [concat [skip] unixInit-2.*] -test unixInit-2.0 {TclpInitLibraryPath: setting tclDefaultEncodingDir} -constraints { - testgetencpath -} -body { - set origPath [testgetencpath] - testsetencpath slappy - set path [testgetencpath] - testsetencpath $origPath +test unixInit-2.0 {TclpInitLibraryPath: setting tclDefaultEncodingDir} { + set origDir [testgetdefenc] + testsetdefenc slappy + set path [testgetdefenc] + testsetdefenc $origDir set path -} -result {slappy} +} {slappy} test unixInit-2.1 {TclpInitLibraryPath: value of installLib, developLib} -setup { unset -nocomplain oldlibrary if {[info exists env(TCL_LIBRARY)]} { set oldlibrary $env(TCL_LIBRARY) unset env(TCL_LIBRARY) Index: tests/unixNotfy.test ================================================================== --- tests/unixNotfy.test +++ tests/unixNotfy.test @@ -8,34 +8,39 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } # When run in a Tk shell, these tests hang. testConstraint noTk [expr {0 != [catch {package present Tk}]}] testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] +# Darwin always uses a threaded notifier +testConstraint unthreaded [expr { + ![::tcl::pkgconfig get threaded] + && $tcl_platform(os) ne "Darwin" +}] # The next two tests will hang if threads are enabled because the notifier # will not necessarily wait for ever in this case, so it does not generate # an error. -test unixNotfy-1.1 {Tcl_DeleteFileHandler} -constraints nonPortable -body { +test unixNotfy-1.1 {Tcl_DeleteFileHandler} -constraints {noTk unix unthreaded} -body { catch {vwait x} set f [open [makeFile "" foo] w] fileevent $f writable {set x 1} vwait x close $f list [catch {vwait x} msg] $msg -} -result {1 {can't wait for variable "x": would wait forever}} -cleanup { +} -result {1 {can't wait for variable "x": would wait forever}} -cleanup { catch { close $f } catch { removeFile foo } } -test unixNotfy-1.2 {Tcl_DeleteFileHandler} -constraints nonPortable -body { +test unixNotfy-1.2 {Tcl_DeleteFileHandler} -constraints {noTk unix unthreaded} -body { catch {vwait x} set f1 [open [makeFile "" foo] w] set f2 [open [makeFile "" foo2] w] fileevent $f1 writable {set x 1} fileevent $f2 writable {set y 1} @@ -83,15 +88,15 @@ thread::create "thread::send [thread::id] {set x ok}" vwait x set x } \ -result {ok} \ - -cleanup { + -cleanup { catch { close $f1 } catch { close $f2 } catch { removeFile foo } catch { removeFile foo2 } } # cleanup ::tcltest::cleanupTests return Index: tests/unknown.test ================================================================== --- tests/unknown.test +++ tests/unknown.test @@ -9,11 +9,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 +package require tcltest 2.5 namespace import ::tcltest::* unset -nocomplain x catch {rename unknown unknown.old} Index: tests/unload.test ================================================================== --- tests/unload.test +++ tests/unload.test @@ -9,12 +9,12 @@ # Copyright (c) 2003-2004 by Georgios Petasis # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -36,13 +36,10 @@ set alreadyLoaded [info loaded] testConstraint $loaded [expr {![string match *pkgua* $alreadyLoaded]}] set alreadyTotalLoaded [info loaded] -# Certain tests require the 'teststaticpkg' command from tcltest -testConstraint teststaticpkg [llength [info commands teststaticpkg]] - # Certain tests need the 'testsimplefilsystem' in tcltest testConstraint testsimplefilesystem \ [llength [info commands testsimplefilesystem]] proc loadIfNotPresent {pkg args} { @@ -154,18 +151,18 @@ loadIfNotPresent pkga } -constraints [list $dll $loaded] -returnCodes error -match glob -body { unload [file join $testDir pkga$ext] {} child } -result {file "*" has never been loaded in this interpreter} test unload-3.4 {basic unloading of a non-unloadable package from a safe interpreter, with guess for package name} -setup { - if {[lsearch -index 1 [info loaded child] Pkgb] == -1} { + if {[lsearch -index 1 [info loaded child] Pkgb] < 0} { load [file join $testDir pkgb$ext] pKgB child } } -constraints [list $dll $loaded] -returnCodes error -match glob -body { unload [file join $testDir pkgb$ext] {} child } -result {file "*" cannot be unloaded under a safe interpreter} test unload-3.5 {basic unloading of an unloadable package from a safe interpreter, with guess for package name} -setup { - if {[lsearch -index 1 [info loaded child] Pkgua] == -1} { + if {[lsearch -index 1 [info loaded child] Pkgua] < 0} { load [file join $testDir pkgua$ext] pkgua child } } -constraints [list $dll $loaded] -body { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ [unload [file join $testDir pkgua$ext] {} child] \ Index: tests/uplevel.test ================================================================== --- tests/uplevel.test +++ tests/uplevel.test @@ -9,17 +9,17 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } proc a {x y} { - newset z [expr $x+$y] + newset z [expr {$x + $y}] return $z } proc newset {name value} { uplevel set $name $value uplevel 1 {uplevel 1 {set xyz 22}} @@ -81,10 +81,20 @@ set y zzz proc a1 {} {set y 55; uplevel #1 set y} a1 } 55 +test uplevel-4.0.1 {error: non-existent level} -body { + uplevel #0 { uplevel { set y 222 } } +} -returnCodes error -result {bad level "1"} +test uplevel-4.0.2 {error: non-existent level} -setup { + interp create i +} -body { + i eval { uplevel { set y 222 } } +} -returnCodes error -result {bad level "1"} -cleanup { + interp delete i +} test uplevel-4.1 {error: non-existent level} -returnCodes error -body { apply {{} { uplevel #2 {set y 222} }} } -result {bad level "#2"} @@ -135,31 +145,31 @@ apply {{} {uplevel [expr 1] {}}} } {} test uplevel-4.16 {level parsing} { apply {{} {uplevel #[expr 1] {}}} } {} -test uplevel-4.17 {level parsing} -returnCodes error -body { +test uplevel-4.17 {level parsing} { apply {{} {uplevel -0xffffffff {}}} -} -result {bad level "-0xffffffff"} -test uplevel-4.18 {level parsing} -returnCodes error -body { +} {} +test uplevel-4.18 {level parsing} { apply {{} {uplevel #-0xffffffff {}}} -} -result {bad level "#-0xffffffff"} -test uplevel-4.19 {level parsing} -returnCodes error -body { +} {} +test uplevel-4.19 {level parsing} { apply {{} {uplevel [expr -0xffffffff] {}}} -} -result {bad level "-4294967295"} -test uplevel-4.20 {level parsing} -returnCodes error -body { +} {} +test uplevel-4.20 {level parsing} { apply {{} {uplevel #[expr -0xffffffff] {}}} -} -result {bad level "#-4294967295"} +} {} test uplevel-4.21 {level parsing} -body { apply {{} {uplevel -1 {}}} -} -returnCodes error -result {bad level "-1"} +} -returnCodes error -result {invalid command name "-1"} test uplevel-4.22 {level parsing} -body { apply {{} {uplevel #-1 {}}} } -returnCodes error -result {bad level "#-1"} test uplevel-4.23 {level parsing} -body { apply {{} {uplevel [expr -1] {}}} -} -returnCodes error -result {bad level "-1"} +} -returnCodes error -result {invalid command name "-1"} test uplevel-4.24 {level parsing} -body { apply {{} {uplevel #[expr -1] {}}} } -returnCodes error -result {bad level "#-1"} test uplevel-4.25 {level parsing} -body { apply {{} {uplevel 0xffffffff {}}} @@ -173,17 +183,17 @@ test uplevel-4.28 {level parsing} -body { apply {{} {uplevel #[expr 0xffffffff] {}}} } -returnCodes error -result {bad level "#4294967295"} test uplevel-4.29 {level parsing} -body { apply {{} {uplevel 0.2 {}}} -} -returnCodes error -result {invalid command name "0.2"} +} -returnCodes error -result {bad level "0.2"} test uplevel-4.30 {level parsing} -body { apply {{} {uplevel #0.2 {}}} } -returnCodes error -result {bad level "#0.2"} test uplevel-4.31 {level parsing} -body { apply {{} {uplevel [expr 0.2] {}}} -} -returnCodes error -result {invalid command name "0.2"} +} -returnCodes error -result {bad level "0.2"} test uplevel-4.32 {level parsing} -body { apply {{} {uplevel #[expr 0.2] {}}} } -returnCodes error -result {bad level "#0.2"} test uplevel-4.33 {level parsing} -body { apply {{} {uplevel .2 {}}} @@ -191,11 +201,11 @@ test uplevel-4.34 {level parsing} -body { apply {{} {uplevel #.2 {}}} } -returnCodes error -result {bad level "#.2"} test uplevel-4.35 {level parsing} -body { apply {{} {uplevel [expr .2] {}}} -} -returnCodes error -result {invalid command name "0.2"} +} -returnCodes error -result {bad level "0.2"} test uplevel-4.36 {level parsing} -body { apply {{} {uplevel #[expr .2] {}}} } -returnCodes error -result {bad level "#0.2"} @@ -292,14 +302,31 @@ moo } -cleanup { rename foo {} rename moo {} } -result {3 3 3} + + +test uplevel-8.0 { + string representation isn't generated when there is only one argument +} -body { + set res {} + set script [list lindex 5] + lappend res [apply {script { + uplevel $script + }} $script] + lappend res [string match {value is a list *no string representation*} [ + ::tcl::unsupported::representation $script]] +} -cleanup { + unset script + unset res +} -result {5 1} + # cleanup ::tcltest::cleanupTests return # Local Variables: # mode: tcl # fill-column: 78 # End: Index: tests/upvar.test ================================================================== --- tests/upvar.test +++ tests/upvar.test @@ -9,12 +9,12 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -302,10 +302,21 @@ } ok test upvar-8.3 {errors in upvar command} -returnCodes error -body { proc p1 {} {upvar a b c} p1 } -result {bad level "a"} +test upvar-8.3.1 {bad level for upvar (upvar at top-level, bug [775ee88560])} -body { + proc p1 {} { uplevel { upvar b b; lappend b UNEXPECTED } } + uplevel #0 { p1 } +} -returnCodes error -result {bad level "1"} +test upvar-8.3.2 {bad level for upvar (upvar at top-level, bug [775ee88560])} -setup { + interp create i +} -body { + i eval { upvar b b; lappend b UNEXPECTED } +} -returnCodes error -result {bad level "1"} -cleanup { + interp delete i +} test upvar-8.4 {errors in upvar command} -returnCodes error -body { proc p1 {} {upvar 0 b b} p1 } -result {can't upvar from variable to itself} test upvar-8.5 {errors in upvar command} -returnCodes error -body { @@ -353,11 +364,11 @@ upvar 0 upvarArray(elem) upvarArrayElemAlias(elem) } -returnCodes 1 -match glob -result * test upvar-9.1 {Tcl_UpVar2 procedure} testupvar { list [catch {testupvar xyz a {} x global} msg] $msg -} {1 {bad level "xyz"}} +} {1 {bad level "1"}} test upvar-9.1.1 {TclGetFrame, via Tcl_UpVar2} testupvar { apply {{} {testupvar xyz a {} x local; set x foo}} set a } foo test upvar-9.2 {Tcl_UpVar2 procedure} testupvar { @@ -479,11 +490,11 @@ return [a] } } -returnCodes error -cleanup { namespace delete test_ns_1 } -result {namespace "test_ns_0" not found in "::test_ns_1"} - + test upvar-NS-1.5 {nsupvar links to correct variable} -body { namespace eval test_ns_1 { namespace eval test_ns_0 {} namespace upvar test_ns_0 x w set w Index: tests/utf.test ================================================================== --- tests/utf.test +++ tests/utf.test @@ -6,200 +6,1082 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] + +testConstraint ucs2 [expr {[format %c 0x010000] eq "\uFFFD"}] +testConstraint fullutf [expr {[format %c 0x010000] ne "\uFFFD"}] +testConstraint utf16 [expr {[string length [format %c 0x10000]] == 2}] +testConstraint ucs4 [expr {[testConstraint fullutf] + && [string length [format %c 0x10000]] == 1}] + +testConstraint Uesc [expr {"\U0041" eq "A"}] +testConstraint pre388 [expr {"\x741" eq "A"}] +testConstraint pairsTo4bytes [expr {[llength [info commands teststringbytes]] + && [string length [teststringbytes \uD83D\uDCA9]] == 4}] testConstraint testbytestring [llength [info commands testbytestring]] +testConstraint testfindfirst [llength [info commands testfindfirst]] +testConstraint testfindlast [llength [info commands testfindlast]] +testConstraint testnumutfchars [llength [info commands testnumutfchars]] +testConstraint teststringobj [llength [info commands teststringobj]] +testConstraint testutfnext [llength [info commands testutfnext]] +testConstraint testutfprev [llength [info commands testutfprev]] + +testConstraint tip413 [expr {[string trim \x00] eq {}}] catch {unset x} -# Some tests require support for 4-byte UTF-8 sequences -testConstraint tip389 [expr {[string length \U010000] == 2}] - test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} testbytestring { - expr {"\x01" eq [testbytestring "\x01"]} + expr {"\x01" eq [testbytestring \x01]} } 1 test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} testbytestring { - expr {"\x00" eq [testbytestring "\xc0\x80"]} + expr {"\x00" eq [testbytestring \xC0\x80]} } 1 test utf-1.3 {Tcl_UniCharToUtf: 2 byte sequences} testbytestring { - expr {"\xe0" eq [testbytestring "\xc3\xa0"]} + expr {"\xE0" eq [testbytestring \xC3\xA0]} } 1 test utf-1.4 {Tcl_UniCharToUtf: 3 byte sequences} testbytestring { - expr {"\u4e4e" eq [testbytestring "\xe4\xb9\x8e"]} + expr {"\u4E4E" eq [testbytestring \xE4\xB9\x8E]} } 1 test utf-1.5 {Tcl_UniCharToUtf: overflowed Tcl_UniChar} testbytestring { - expr {[format %c 0x110000] eq [testbytestring "\xef\xbf\xbd"]} + expr {[format %c 0x110000] eq [testbytestring \xEF\xBF\xBD]} } 1 test utf-1.6 {Tcl_UniCharToUtf: negative Tcl_UniChar} testbytestring { - expr {[format %c -1] eq [testbytestring "\xef\xbf\xbd"]} + expr {[format %c -1] eq [testbytestring \xEF\xBF\xBD]} } 1 -test utf-1.7 {Tcl_UniCharToUtf: 4 byte sequences} -constraints testbytestring -body { - expr {"\U014e4e" eq [testbytestring "\xf0\x94\xb9\x8e"]} -} -result 1 +test utf-1.7.0 {Tcl_UniCharToUtf: 4 byte sequences} {fullutf Uesc testbytestring} { + expr {"\U014E4E" eq [testbytestring \xF0\x94\xB9\x8E]} +} 1 +test utf-1.7.1 {Tcl_UniCharToUtf: 4 byte sequences} {ucs2 Uesc testbytestring} { + expr {"\U014E4E" eq [testbytestring \xF0\x94\xB9\x8E]} +} 0 test utf-1.8 {Tcl_UniCharToUtf: 3 byte sequence, high surrogate} testbytestring { - expr {"\ud842" eq [testbytestring "\xed\xa1\x82"]} + expr {"\uD842" eq [testbytestring \xED\xA1\x82]} } 1 test utf-1.9 {Tcl_UniCharToUtf: 3 byte sequence, low surrogate} testbytestring { - expr {"\udc42" eq [testbytestring "\xed\xb1\x82"]} + expr {"\uDC42" eq [testbytestring \xED\xB1\x82]} } 1 test utf-1.10 {Tcl_UniCharToUtf: 3 byte sequence, high surrogate} testbytestring { - expr {[format %c 0xd842] eq [testbytestring "\xed\xa1\x82"]} + expr {[format %c 0xD842] eq [testbytestring \xED\xA1\x82]} } 1 test utf-1.11 {Tcl_UniCharToUtf: 3 byte sequence, low surrogate} testbytestring { - expr {[format %c 0xdc42] eq [testbytestring "\xed\xb1\x82"]} + expr {[format %c 0xDC42] eq [testbytestring \xED\xB1\x82]} +} 1 +test utf-1.12 {Tcl_UniCharToUtf: 4 byte sequence, high/low surrogate} {pairsTo4bytes testbytestring} { + expr {"\uD842\uDC42" eq [testbytestring \xF0\xA0\xA1\x82]} +} 1 +test utf-1.13 {Tcl_UniCharToUtf: Invalid surrogate} {Uesc ucs2} { + expr {"\UD842" eq "\uD842"} } 1 test utf-2.1 {Tcl_UtfToUniChar: low ascii} { string length "abc" -} {3} +} 3 test utf-2.2 {Tcl_UtfToUniChar: naked trail bytes} testbytestring { - string length [testbytestring "\x82\x83\x84"] -} {3} + string length [testbytestring \x82\x83\x84] +} 3 test utf-2.3 {Tcl_UtfToUniChar: lead (2-byte) followed by non-trail} testbytestring { - string length [testbytestring "\xC2"] -} {1} -test utf-2.4 {Tcl_UtfToUniChar: lead (2-byte) followed by trail} testbytestring { - string length [testbytestring "\xC2\xa2"] -} {1} + string length [testbytestring \xC2] +} 1 +test utf-2.4 {Tcl_UtfToUniChar: lead (2-byte) followed by trail} { + string length \xA2 +} 1 test utf-2.5 {Tcl_UtfToUniChar: lead (3-byte) followed by non-trail} testbytestring { - string length [testbytestring "\xE2"] -} {1} + string length [testbytestring \xE2] +} 1 test utf-2.6 {Tcl_UtfToUniChar: lead (3-byte) followed by 1 trail} testbytestring { - string length [testbytestring "\xE2\xA2"] -} {2} + string length [testbytestring \xE2\xA2] +} 2 test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} testbytestring { - string length [testbytestring "\xE4\xb9\x8e"] -} {1} -test utf-2.8 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {tip389 testbytestring} -body { - string length [testbytestring "\xF0\x90\x80\x80"] -} -result {2} -test utf-2.9 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {tip389 testbytestring} -body { - string length [testbytestring "\xF4\x8F\xBF\xBF"] -} -result {2} + string length [testbytestring \xE4\xB9\x8E] +} 1 +test utf-2.8.0 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {testbytestring ucs2} { + string length [testbytestring \xF0\x90\x80\x80] +} 2 +test utf-2.8.1 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {testbytestring ucs4} { + string length [testbytestring \xF0\x90\x80\x80] +} 1 +test utf-2.9.0 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {testbytestring ucs2} { + string length [testbytestring \xF4\x8F\xBF\xBF] +} 2 +test utf-2.9.1 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {Uesc ucs4} { + string length \U10FFFF +} 1 test utf-2.10 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, underflow} testbytestring { - string length [testbytestring "\xF0\x8F\xBF\xBF"] -} {4} + string length [testbytestring \xF0\x8F\xBF\xBF] +} 4 test utf-2.11 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, overflow} testbytestring { - string length [testbytestring "\xF4\x90\x80\x80"] -} {4} + # Would decode to U+110000 but that is outside the Unicode range. + string length [testbytestring \xF4\x90\x80\x80] +} 4 test utf-2.12 {Tcl_UtfToUniChar: longer UTF sequences not supported} testbytestring { - string length [testbytestring "\xF8\xA2\xA2\xA2\xA2"] -} {5} + string length [testbytestring \xF8\xA2\xA2\xA2\xA2] +} 5 test utf-3.1 {Tcl_UtfCharComplete} { } {} -testConstraint testnumutfchars [llength [info commands testnumutfchars]] -testConstraint testfindfirst [llength [info commands testfindfirst]] -testConstraint testfindlast [llength [info commands testfindlast]] - test utf-4.1 {Tcl_NumUtfChars: zero length} testnumutfchars { testnumutfchars "" -} {0} -test utf-4.2 {Tcl_NumUtfChars: length 1} {testnumutfchars testbytestring} { - testnumutfchars [testbytestring "\xC2\xA2"] -} {1} +} 0 +test utf-4.2 {Tcl_NumUtfChars: length 1} testnumutfchars { + testnumutfchars \xA2 +} 1 test utf-4.3 {Tcl_NumUtfChars: long string} {testnumutfchars testbytestring} { - testnumutfchars [testbytestring "abc\xC2\xA2\xE4\xB9\x8E\xA2\x4E"] -} {7} -test utf-4.4 {Tcl_NumUtfChars: #u0000} {testnumutfchars testbytestring} { - testnumutfchars [testbytestring "\xC0\x80"] -} {1} + testnumutfchars abc\xA2[testbytestring \xE4\xB9\x8E\xA2\x4E] +} 7 +test utf-4.4 {Tcl_NumUtfChars: #x00} testnumutfchars { + testnumutfchars \x00 +} 1 test utf-4.5 {Tcl_NumUtfChars: zero length, calc len} testnumutfchars { testnumutfchars "" 0 -} {0} +} 0 test utf-4.6 {Tcl_NumUtfChars: length 1, calc len} {testnumutfchars testbytestring} { - testnumutfchars [testbytestring "\xC2\xA2"] 2 -} {1} + testnumutfchars \xA2 end +} 1 test utf-4.7 {Tcl_NumUtfChars: long string, calc len} {testnumutfchars testbytestring} { - testnumutfchars [testbytestring "abc\xC2\xA2\xE4\xB9\x8E\xA2\x4E"] 10 -} {7} -test utf-4.8 {Tcl_NumUtfChars: #u0000, calc len} {testnumutfchars testbytestring} { - testnumutfchars [testbytestring "\xC0\x80"] 2 -} {1} + testnumutfchars abc\xA2[testbytestring \xE4\xB9\x8E\xA2\x4E] end +} 7 +test utf-4.8 {Tcl_NumUtfChars: #x00, calc len} testnumutfchars { + testnumutfchars \x00 end +} 1 # Bug [2738427]: Tcl_NumUtfChars(...) no overflow check test utf-4.9 {Tcl_NumUtfChars: #u20AC, calc len, incomplete} {testnumutfchars testbytestring} { - testnumutfchars [testbytestring "\xE2\x82\xAC"] 2 -} {2} -test utf-4.10 {Tcl_NumUtfChars: #u0000, calc len, overcomplete} {testnumutfchars testbytestring} { - testnumutfchars [testbytestring "\x00"] 2 -} {2} + testnumutfchars [testbytestring \xE2\x82\xAC] end-1 +} 2 +test utf-4.10 {Tcl_NumUtfChars: #x00, calc len, overcomplete} {testnumutfchars testbytestring} { + testnumutfchars [testbytestring \x00] end+1 +} 2 +test utf-4.11 {Tcl_NumUtfChars: 3 bytes of 4-byte UTF-8 characater} {testnumutfchars testbytestring} { + testnumutfchars [testbytestring \xF0\x9F\x92\xA9] end-1 +} 3 +test utf-4.12.0 {Tcl_NumUtfChars: #4-byte UTF-8 character} {testnumutfchars testbytestring ucs2} { + testnumutfchars [testbytestring \xF0\x9F\x92\xA9] end +} 2 +test utf-4.12.1 {Tcl_NumUtfChars: #4-byte UTF-8 character} {testnumutfchars testbytestring ucs4} { + testnumutfchars [testbytestring \xF0\x9F\x92\xA9] end +} 1 +test utf-4.13 {Tcl_NumUtfChars: end of string} {testnumutfchars testbytestring} { + testnumutfchars foobar[testbytestring \xF2\xC2\xA0] end +} 8 +test utf-4.14 {Tcl_NumUtfChars: 3 bytes of 4-byte UTF-8 characater} {testnumutfchars testbytestring} { + testnumutfchars [testbytestring \xF4\x90\x80\x80] end-1 +} 3 test utf-5.1 {Tcl_UtfFindFirst} {testfindfirst testbytestring} { - testfindfirst [testbytestring "abcbc"] 98 -} {bcbc} + testfindfirst [testbytestring abcbc] 98 +} bcbc test utf-5.2 {Tcl_UtfFindLast} {testfindlast testbytestring} { - testfindlast [testbytestring "abcbc"] 98 -} {bc} - -test utf-6.1 {Tcl_UtfNext} { -} {} - -test utf-7.1 {Tcl_UtfPrev} { -} {} + testfindlast [testbytestring abcbc] 98 +} bc + +test utf-6.1 {Tcl_UtfNext} {testutfnext testbytestring} { + # This takes the pointer one past the terminating NUL. + # This is really an invalid call. + testutfnext [testbytestring \x00] +} 1 +test utf-6.2 {Tcl_UtfNext} testutfnext { + testutfnext A +} 1 +test utf-6.3 {Tcl_UtfNext} testutfnext { + testutfnext AA +} 1 +test utf-6.4 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext A[testbytestring \xA0] +} 1 +test utf-6.5 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext A[testbytestring \xD0] +} 1 +test utf-6.6 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext A[testbytestring \xE8] +} 1 +test utf-6.7 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext A[testbytestring \xF2] +} 1 +test utf-6.8 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext A[testbytestring \xF8] +} 1 +test utf-6.9 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xA0\x00] +} 1 +test utf-6.10 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xA0]G +} 1 +test utf-6.11 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xA0\xA0\x00] +} 1 +test utf-6.12 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xA0\xD0] +} 1 +test utf-6.13 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xA0\xE8] +} 1 +test utf-6.14 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xA0\xF2] +} 1 +test utf-6.15 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xA0\xF8] +} 1 +test utf-6.16 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\x00] +} 1 +test utf-6.17 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0]G +} 1 +test utf-6.18 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\xA0] +} 2 +test utf-6.19 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\xD0] +} 1 +test utf-6.20 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\xE8] +} 1 +test utf-6.21 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\xF2] +} 1 +test utf-6.22 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\xF8] +} 1 +test utf-6.23 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xE8\x00] +} 1 +test utf-6.24 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xE8]G +} 1 +test utf-6.25 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xE8\xA0\x00] +} 1 +test utf-6.26 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xE8\xD0] +} 1 +test utf-6.27 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xE8\xE8] +} 1 +test utf-6.28 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xE8\xF2] +} 1 +test utf-6.29 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xE8\xF8] +} 1 +test utf-6.30.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \xF2] +} 1 +test utf-6.30.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} { + testutfnext [testbytestring \xF2\x00] +} 1 +test utf-6.31 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2]G +} 1 +test utf-6.32.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \xF2\xA0] +} 1 +test utf-6.32.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} { + testutfnext [testbytestring \xF2\xA0\x00] +} 1 +test utf-6.33 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xD0] +} 1 +test utf-6.34 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xE8] +} 1 +test utf-6.35 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xF2] +} 1 +test utf-6.36 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xF8] +} 1 +test utf-6.37 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF8] +} 1 +test utf-6.38 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF8]G +} 1 +test utf-6.39 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF8\xA0] +} 1 +test utf-6.40 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF8\xD0] +} 1 +test utf-6.41 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF8\xE8] +} 1 +test utf-6.42 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF8\xF2] +} 1 +test utf-6.43 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF8\xF8] +} 1 +test utf-6.44 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\xA0]G +} 2 +test utf-6.45 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\xA0\xA0] +} 2 +test utf-6.46 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\xA0\xD0] +} 2 +test utf-6.47 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\xA0\xE8] +} 2 +test utf-6.48 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\xA0\xF2] +} 2 +test utf-6.49 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\xA0\xF8] +} 2 +test utf-6.50 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xE8\xA0]G +} 1 +test utf-6.51 {Tcl_UtfNext} testutfnext { + testutfnext \u8820 +} 3 +test utf-6.52 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xE8\xA0\xD0] +} 1 +test utf-6.53 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xE8\xA0\xE8] +} 1 +test utf-6.54 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xE8\xA0\xF2] +} 1 +test utf-6.55 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xE8\xA0\xF8] +} 1 +test utf-6.56 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xA0]G +} 1 +test utf-6.57 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xA0\xA0\x00] +} 1 +test utf-6.58 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xA0\xD0] +} 1 +test utf-6.59 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xA0\xE8] +} 1 +test utf-6.60 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xA0\xF2] +} 1 +test utf-6.61 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xA0\xF8] +} 1 +test utf-6.62 {Tcl_UtfNext} testutfnext { + testutfnext \u8820G +} 3 +test utf-6.63 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext \u8820[testbytestring \xA0] +} 3 +test utf-6.64 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext \u8820[testbytestring \xD0] +} 3 +test utf-6.65 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext \u8820[testbytestring \xE8] +} 3 +test utf-6.66 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext \u8820[testbytestring \xF2] +} 3 +test utf-6.67 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext \u8820[testbytestring \xF8] +} 3 +test utf-6.68 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xA0\xA0]G +} 1 +test utf-6.69.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0] +} 1 +test utf-6.69.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0] +} 4 +test utf-6.70 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xA0\xA0\xD0] +} 1 +test utf-6.71 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xA0\xA0\xE8] +} 1 +test utf-6.72 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xA0\xA0\xF2] +} 1 +test utf-6.73 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xA0\xA0\xF8] +} 1 +test utf-6.74.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0]G +} 1 +test utf-6.74.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0]G +} 4 +test utf-6.75.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0\xA0] +} 1 +test utf-6.75.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0\xA0] +} 4 +test utf-6.76.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0\xD0] +} 1 +test utf-6.76.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0\xD0] +} 4 +test utf-6.77.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0\xE8] +} 1 +test utf-6.77.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0\xE8] +} 4 +test utf-6.78.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0\xF2] +} 1 +test utf-6.78.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0\xF2] +} 4 +test utf-6.79.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0G\xF8] +} 1 +test utf-6.79.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0G\xF8] +} 4 +test utf-6.80 {Tcl_UtfNext - overlong sequences} testutfnext { + testutfnext \x00 +} 2 +test utf-6.81 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} { + testutfnext [testbytestring \xC0\x81] +} 1 +test utf-6.82 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} { + testutfnext [testbytestring \xC1\x80] +} 1 +test utf-6.83 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} { + testutfnext [testbytestring \xC2\x80] +} 2 +test utf-6.84 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} { + testutfnext [testbytestring \xE0\x80\x80] +} 1 +test utf-6.85 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} { + testutfnext [testbytestring \xE0\xA0\x80] +} 3 +test utf-6.86 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} { + testutfnext [testbytestring \xF0\x80\x80\x80] +} 1 +test utf-6.87.0 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \xF0\x90\x80\x80] +} 1 +test utf-6.87.1 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring fullutf} { + testutfnext [testbytestring \xF0\x90\x80\x80] +} 4 +test utf-6.88 {Tcl_UtfNext, pointing to 2th byte of 3-byte valid sequence} {testutfnext testbytestring} { + testutfnext [testbytestring \xA0\xA0\x00] +} 1 +test utf-6.89 {Tcl_UtfNext, pointing to 2th byte of 3-byte invalid sequence} {testutfnext testbytestring} { + testutfnext [testbytestring \x80\x80\x00] +} 1 +test utf-6.90.0 {Tcl_UtfNext, validity check [493dccc2de]} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \xF4\x8F\xBF\xBF] +} 1 +test utf-6.90.1 {Tcl_UtfNext, validity check [493dccc2de]} {testutfnext testbytestring fullutf} { + testutfnext [testbytestring \xF4\x8F\xBF\xBF] +} 4 +test utf-6.91 {Tcl_UtfNext, validity check [493dccc2de]} {testutfnext testbytestring} { + testutfnext [testbytestring \xF4\x90\x80\x80] +} 1 +test utf-6.92 {Tcl_UtfNext, pointing to 2th byte of 4-byte valid sequence} {testutfnext testbytestring} { + testutfnext [testbytestring \xA0\xA0\xA0] +} 1 +test utf-6.93 {Tcl_UtfNext, pointing to 2th byte of 4-byte invalid sequence} {testutfnext testbytestring} { + testutfnext [testbytestring \x80\x80\x80] +} 1 +test utf-6.94 {Tcl_UtfNext, pointing to 2th byte of 5-byte invalid sequence} {testutfnext testbytestring} { + testutfnext [testbytestring \xA0\xA0\xA0\xA0] +} 1 +test utf-6.95 {Tcl_UtfNext, pointing to 2th byte of 5-byte invalid sequence} {testutfnext testbytestring} { + testutfnext [testbytestring \x80\x80\x80\x80] +} 1 +test utf-6.96 {Tcl_UtfNext, read limits} testutfnext { + testutfnext G 0 +} 0 +test utf-6.97 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { + testutfnext [testbytestring \xA0] 0 +} 0 +test utf-6.98 {Tcl_UtfNext, read limits} testutfnext { + testutfnext AG 1 +} 1 +test utf-6.99 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { + testutfnext A[testbytestring \xA0] 1 +} 1 +test utf-6.100 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\xA0]G 1 +} 0 +test utf-6.101 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\xA0]G 2 +} 2 +test utf-6.102 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\xA0\xA0] 1 +} 0 +test utf-6.103 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\xA0\xA0] 2 +} 2 +test utf-6.104 {Tcl_UtfNext, read limits} testutfnext { + testutfnext \u8820G 1 +} 0 +test utf-6.105 {Tcl_UtfNext, read limits} testutfnext { + testutfnext \u8820G 2 +} 0 +test utf-6.106 {Tcl_UtfNext, read limits} testutfnext { + testutfnext \u8820G 3 +} 3 +test utf-6.107 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { + testutfnext \u8820[testbytestring \xA0] 1 +} 0 +test utf-6.108 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { + testutfnext \u8820[testbytestring \xA0] 2 +} 0 +test utf-6.109 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { + testutfnext \u8820[testbytestring \xA0] 3 +} 3 +# This testcase actually tests Tcl_UtfCharComplete, not Tcl_UtfNext +test utf-6.110 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0]G 1 +} 0 +# This testcase actually tests Tcl_UtfCharComplete, not Tcl_UtfNext +test utf-6.111 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0]G 2 +} 0 +test utf-6.112.0 {Tcl_UtfNext, read limits} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0]G 3 +} 1 +test utf-6.112.1 {Tcl_UtfNext, read limits} {testutfnext testbytestring fullutf} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0]G 3 +} 0 +test utf-6.113.0 {Tcl_UtfNext, read limits} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0]G 4 +} 1 +test utf-6.113.1 {Tcl_UtfNext, read limits} {testutfnext testbytestring fullutf} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0]G 4 +} 4 +# This testcase actually tests Tcl_UtfCharComplete, not Tcl_UtfNext +test utf-6.114 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0\xA0] 1 +} 0 +# This testcase actually tests Tcl_UtfCharComplete, not Tcl_UtfNext +test utf-6.115 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0\xA0] 2 +} 0 +test utf-6.116.0 {Tcl_UtfNext, read limits} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0\xA0] 3 +} 1 +test utf-6.116.1 {Tcl_UtfNext, read limits} {testutfnext testbytestring fullutf} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0\xA0] 3 +} 0 +test utf-6.117.0 {Tcl_UtfNext, read limits} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0\xA0] 4 +} 1 +test utf-6.117.1 {Tcl_UtfNext, read limits} {testutfnext testbytestring fullutf} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0\xA0] 4 +} 4 +test utf-6.118 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { + testutfnext [testbytestring \xA0]G 0 +} 0 +test utf-6.119 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { + testutfnext [testbytestring \xA0]G 1 +} 0 +test utf-6.120 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { + testutfnext [testbytestring \xA0\xA0] 1 +} 0 +test utf-6.121 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { + testutfnext [testbytestring \xA0\xA0]G 2 +} 0 +test utf-6.122 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { + testutfnext [testbytestring \xA0\xA0\xA0] 2 +} 0 +test utf-6.123 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { + testutfnext [testbytestring \xA0\xA0\xA0]G 3 +} 1 +test utf-6.124 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { + testutfnext [testbytestring \xA0\xA0\xA0\xA0] 3 +} 1 +test utf-6.125 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { + testutfnext [testbytestring \xA0\xA0\xA0\xA0]G 4 +} 1 +test utf-6.126 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { + testutfnext [testbytestring \xA0\xA0\xA0\xA0\xA0] 4 +} 1 + +test utf-7.1 {Tcl_UtfPrev} testutfprev { + testutfprev {} +} 0 +test utf-7.2 {Tcl_UtfPrev} testutfprev { + testutfprev A +} 0 +test utf-7.3 {Tcl_UtfPrev} testutfprev { + testutfprev AA +} 1 +test utf-7.4 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF8] +} 1 +test utf-7.4.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF8\xA0\xA0\xA0] 2 +} 1 +test utf-7.4.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF8\xF8\xA0\xA0] 2 +} 1 +test utf-7.5 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF2] +} 1 +test utf-7.5.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 2 +} 1 +test utf-7.5.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF2\xF8\xA0\xA0] 2 +} 1 +test utf-7.6 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE8] +} 1 +test utf-7.6.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A\u8820[testbytestring \xA0] 2 +} 1 +test utf-7.6.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE8\xF8\xA0\xA0] 2 +} 1 +test utf-7.7 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xD0] +} 1 +test utf-7.7.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xD0\xA0\xA0\xA0] 2 +} 1 +test utf-7.7.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xD0\xF8\xA0\xA0] 2 +} 1 +test utf-7.8 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xA0] +} 1 +test utf-7.8.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xA0\xA0\xA0\xA0] 2 +} 1 +test utf-7.8.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xA0\xF8\xA0\xA0] 2 +} 1 +test utf-7.9 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF8\xA0] +} 2 +test utf-7.9.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF8\xA0\xA0\xA0] 3 +} 2 +test utf-7.9.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF8\xA0\xF8\xA0] 3 +} 2 +test utf-7.10.0 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} { + testutfprev A[testbytestring \xF2\xA0] +} 2 +test utf-7.10.1 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} { + testutfprev A[testbytestring \xF2\xA0] +} 1 +test utf-7.10.2 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} { + testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 3 +} 2 +test utf-7.10.3 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} { + testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 3 +} 1 +test utf-7.10.4 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} { + testutfprev A[testbytestring \xF2\xA0\xF8\xA0] 3 +} 2 +test utf-7.10.5 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} { + testutfprev A[testbytestring \xF2\xA0\xF8\xA0] 3 +} 1 +test utf-7.11 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE8\xA0] +} 1 +test utf-7.11.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A\u8820[testbytestring \xA0] 3 +} 1 +test utf-7.11.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE8\xA0\xF8\xA0] 3 +} 1 +test utf-7.11.3 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE8\xA0\xF8] 3 +} 1 +test utf-7.12 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xD0\xA0] +} 1 +test utf-7.12.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xD0\xA0\xA0\xA0] 3 +} 1 +test utf-7.12.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xD0\xA0\xF8\xA0] 3 +} 1 +test utf-7.13 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xA0\xA0] +} 2 +test utf-7.13.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xA0\xA0\xA0\xA0] 3 +} 2 +test utf-7.13.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xA0\xA0\xF8\xA0] 3 +} 2 +test utf-7.14 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF8\xA0\xA0] +} 3 +test utf-7.14.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF8\xA0\xA0\xA0] 4 +} 3 +test utf-7.14.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF8\xA0\xA0\xF8] 4 +} 3 +test utf-7.15.0 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} { + testutfprev A[testbytestring \xF2\xA0\xA0] +} 3 +test utf-7.15.1 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} { + testutfprev A[testbytestring \xF2\xA0\xA0] +} 1 +test utf-7.15.2 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} { + testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 4 +} 3 +test utf-7.15.3 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} { + testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 4 +} 1 +test utf-7.15.4 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} { + testutfprev A[testbytestring \xF2\xA0\xA0\xF8] 4 +} 3 +test utf-7.15.5 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} { + testutfprev A[testbytestring \xF2\xA0\xA0\xF8] 4 +} 1 +test utf-7.16 {Tcl_UtfPrev} testutfprev { + testutfprev A\u8820 +} 1 +test utf-7.16.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A\u8820[testbytestring \xA0] 4 +} 1 +test utf-7.16.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A\u8820[testbytestring \xF8] 4 +} 1 +test utf-7.17 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xD0\xA0\xA0] +} 3 +test utf-7.17.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xD0\xA0\xA0\xA0] 4 +} 3 +test utf-7.17.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xD0\xA0\xA0\xF8] 4 +} 3 +test utf-7.18.0 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xA0\xA0\xA0] +} 3 +test utf-7.18.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xA0\xA0\xA0\xA0] 4 +} 3 +test utf-7.18.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xA0\xA0\xA0\xF8] 4 +} 3 +test utf-7.19 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF8\xA0\xA0\xA0] +} 4 +test utf-7.20 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF2\xA0\xA0\xA0] +} 4 +test utf-7.21 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A\u8820[testbytestring \xA0] +} 4 +test utf-7.22 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xD0\xA0\xA0\xA0] +} 4 +test utf-7.23 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xA0\xA0\xA0\xA0] +} 4 +test utf-7.24 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xC0\x81] +} 2 +test utf-7.25 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xC0\x81] 2 +} 1 +test utf-7.26 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE0\x80\x80] +} 3 +test utf-7.27 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE0\x80] +} 2 +test utf-7.27.1 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE0\x80\x80] 3 +} 2 +test utf-7.28 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE0] +} 1 +test utf-7.28.1 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE0\x80\x80] 2 +} 1 +test utf-7.29 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF0\x80\x80\x80] +} 4 +test utf-7.30 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF0\x80\x80\x80] 4 +} 3 +test utf-7.31 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF0\x80\x80\x80] 3 +} 2 +test utf-7.32 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF0\x80\x80\x80] 2 +} 1 +test utf-7.33 {Tcl_UtfPrev -- overlong sequence} testutfprev { + testutfprev A\x00 +} 1 +test utf-7.34 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xC1\x80] +} 2 +test utf-7.35 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xC2\x80] +} 1 +test utf-7.36 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE0\xA0\x80] +} 1 +test utf-7.37 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE0\xA0\x80] 3 +} 1 +test utf-7.38 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE0\xA0\x80] 2 +} 1 +test utf-7.39 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF0\x90\x80\x80] +} 4 +test utf-7.40.0 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring ucs2} { + testutfprev A[testbytestring \xF0\x90\x80\x80] 4 +} 3 +test utf-7.40.1 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring fullutf} { + testutfprev A[testbytestring \xF0\x90\x80\x80] 4 +} 1 +test utf-7.41.0 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring ucs2} { + testutfprev A[testbytestring \xF0\x90\x80\x80] 3 +} 2 +test utf-7.41.1 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring fullutf} { + testutfprev A[testbytestring \xF0\x90\x80\x80] 3 +} 1 +test utf-7.42 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF0\x90\x80\x80] 2 +} 1 +test utf-7.43 {Tcl_UtfPrev -- no lead byte at start} {testutfprev testbytestring} { + testutfprev [testbytestring \xA0] +} 0 +test utf-7.44 {Tcl_UtfPrev -- no lead byte at start} {testutfprev testbytestring} { + testutfprev [testbytestring \xA0\xA0] +} 1 +test utf-7.45 {Tcl_UtfPrev -- no lead byte at start} {testutfprev testbytestring} { + testutfprev [testbytestring \xA0\xA0\xA0] +} 2 +test utf-7.46 {Tcl_UtfPrev -- no lead byte at start} {testutfprev testbytestring} { + testutfprev [testbytestring \xA0\xA0\xA0\xA0] +} 3 +test utf-7.47 {Tcl_UtfPrev, pointing to 3th byte of 3-byte valid sequence} {testutfprev testbytestring} { + testutfprev [testbytestring \xE8\xA0] +} 0 +test utf-7.47.1 {Tcl_UtfPrev, pointing to 3th byte of 3-byte valid sequence} testutfprev { + testutfprev \u8820 2 +} 0 +test utf-7.47.2 {Tcl_UtfPrev, pointing to 3th byte of 3-byte invalid sequence} {testutfprev testbytestring} { + testutfprev [testbytestring \xE8\xA0\x00] 2 +} 0 +test utf-7.48.0 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF4\x8F\xBF\xBF] +} 4 +test utf-7.48.1 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring ucs2} { + testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 4 +} 3 +test utf-7.48.2 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring fullutf} { + testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 4 +} 1 +test utf-7.48.3 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring ucs2} { + testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 3 +} 2 +test utf-7.48.4 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring fullutf} { + testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 3 +} 1 +test utf-7.48.5 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 2 +} 1 +test utf-7.49.0 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF4\x90\x80\x80] +} 4 +test utf-7.49.1 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF4\x90\x80\x80] 4 +} 3 +test utf-7.49.2 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF4\x90\x80\x80] 3 +} 2 +test utf-7.49.3 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF4\x90\x80\x80] 2 +} 1 test utf-8.1 {Tcl_UniCharAtIndex: index = 0} { string index abcd 0 -} {a} +} a test utf-8.2 {Tcl_UniCharAtIndex: index = 0} { - string index \u4e4e\u25a 0 -} "\u4e4e" + string index \u4E4E\u25A 0 +} \u4E4E test utf-8.3 {Tcl_UniCharAtIndex: index > 0} { string index abcd 2 -} {c} +} c test utf-8.4 {Tcl_UniCharAtIndex: index > 0} { - string index \u4e4e\u25a\xff\u543 2 -} "\uff" -test utf-8.5 {Tcl_UniCharAtIndex: high surrogate} { - string index \ud842 0 -} "\ud842" + string index \u4E4E\u25A\xFF\u543 2 +} \xFF +test utf-8.5.0 {Tcl_UniCharAtIndex: high surrogate} ucs2 { + string index \uD842 0 +} \uD842 +test utf-8.5.1 {Tcl_UniCharAtIndex: high surrogate} ucs4 { + string index \uD842 0 +} \uD842 +test utf-8.5.2 {Tcl_UniCharAtIndex: high surrogate} utf16 { + string index \uD842 0 +} \uD842 test utf-8.6 {Tcl_UniCharAtIndex: low surrogate} { - string index \udc42 0 -} "\udc42" + string index \uDC42 0 +} \uDC42 +test utf-8.7.0 {Tcl_UniCharAtIndex: Emoji} ucs2 { + string index \uD83D\uDE00G 0 +} \uD83D +test utf-8.7.1 {Tcl_UniCharAtIndex: Emoji} ucs4 { + string index \uD83D\uDE00G 0 +} \U1F600 +test utf-8.7.2 {Tcl_UniCharAtIndex: Emoji} utf16 { + string index \uD83D\uDE00G 0 +} \U1F600 +test utf-8.8.0 {Tcl_UniCharAtIndex: Emoji} ucs2 { + string index \uD83D\uDE00G 1 +} \uDE00 +test utf-8.8.1 {Tcl_UniCharAtIndex: Emoji} ucs4 { + string index \uD83D\uDE00G 1 +} G +test utf-8.8.2 {Tcl_UniCharAtIndex: Emoji} utf16 { + string index \uD83D\uDE00G 1 +} {} +test utf-8.9.0 {Tcl_UniCharAtIndex: Emoji} ucs2 { + string index \uD83D\uDE00G 2 +} G +test utf-8.9.1 {Tcl_UniCharAtIndex: Emoji} ucs4 { + string index \uD83D\uDE00G 2 +} {} +test utf-8.9.2 {Tcl_UniCharAtIndex: Emoji} utf16 { + string index \uD83D\uDE00G 2 +} G +test utf-8.10.0 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs2} { + string index \U1F600G 0 +} \uFFFD +test utf-8.10.1 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs4} { + string index \U1F600G 0 +} \U1F600 +test utf-8.10.2 {Tcl_UniCharAtIndex: Emoji} {Uesc utf16} { + string index \U1F600G 0 +} \U1F600 +test utf-8.11.0 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs2} { + string index \U1F600G 1 +} G +test utf-8.11.1 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs4} { + string index \U1F600G 1 +} G +test utf-8.11.2 {Tcl_UniCharAtIndex: Emoji} {Uesc utf16} { + string index \U1F600G 1 +} {} +test utf-8.12.0 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs2} { + string index \U1F600G 2 +} {} +test utf-8.12.1 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs4} { + string index \U1F600G 2 +} {} +test utf-8.12.2 {Tcl_UniCharAtIndex: Emoji} {Uesc utf16} { + string index \U1F600G 2 +} G test utf-9.1 {Tcl_UtfAtIndex: index = 0} { string range abcd 0 2 -} {abc} +} abc test utf-9.2 {Tcl_UtfAtIndex: index > 0} { - string range \u4e4e\u25a\xff\u543klmnop 1 5 -} "\u25a\xff\u543kl" - + string range \u4E4E\u25A\xFF\u543klmnop 1 5 +} \u25A\xFF\u543kl +test utf-9.3.0 {Tcl_UtfAtIndex: index = 0, Emoji} ucs2 { + string range \uD83D\uDE00G 0 0 +} \uD83D +test utf-9.3.1 {Tcl_UtfAtIndex: index = 0, Emoji} ucs4 { + string range \uD83D\uDE00G 0 0 +} \U1F600 +test utf-9.3.2 {Tcl_UtfAtIndex: index = 0, Emoji} utf16 { + string range \uD83D\uDE00G 0 0 +} \U1F600 +test utf-9.4.0 {Tcl_UtfAtIndex: index > 0, Emoji} ucs2 { + string range \uD83D\uDE00G 1 1 +} \uDE00 +test utf-9.4.1 {Tcl_UtfAtIndex: index > 0, Emoji} ucs4 { + string range \uD83D\uDE00G 1 1 +} G +test utf-9.4.2 {Tcl_UtfAtIndex: index > 0, Emoji} utf16 { + string range \uD83D\uDE00G 1 1 +} {} +test utf-9.5.0 {Tcl_UtfAtIndex: index > 0, Emoji} ucs2 { + string range \uD83D\uDE00G 2 2 +} G +test utf-9.5.1 {Tcl_UtfAtIndex: index > 0, Emoji} ucs4 { + string range \uD83D\uDE00G 2 2 +} {} +test utf-9.5.2 {Tcl_UtfAtIndex: index > 0, Emoji} utf16 { + string range \uD83D\uDE00G 2 2 +} G +test utf-9.6.0 {Tcl_UtfAtIndex: index = 0, Emoji} {Uesc ucs2} { + string range \U1f600G 0 0 +} \uFFFD +test utf-9.6.1 {Tcl_UtfAtIndex: index = 0, Emoji} {Uesc ucs4} { + string range \U1f600G 0 0 +} \U1F600 +test utf-9.6.2 {Tcl_UtfAtIndex: index = 0, Emoji} {Uesc utf16} { + string range \U1f600G 0 0 +} \U1F600 +test utf-9.7.0 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc ucs2} { + string range \U1f600G 1 1 +} G +test utf-9.7.1 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc ucs4} { + string range \U1f600G 1 1 +} G +test utf-9.7.2 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc utf16} { + string range \U1f600G 1 1 +} {} +test utf-9.8.0 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc ucs2} { + string range \U1f600G 2 2 +} {} +test utf-9.8.1 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc ucs4} { + string range \U1f600G 2 2 +} {} +test utf-9.8.2 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc utf16} { + string range \U1f600G 2 2 +} G test utf-10.1 {Tcl_UtfBackslash: dst == NULL} { set x \n } { } test utf-10.2 {Tcl_UtfBackslash: \u subst} testbytestring { - expr {"\ua2" eq [testbytestring "\xc2\xa2"]} + expr {"\uA2" eq [testbytestring \xC2\xA2]} } 1 test utf-10.3 {Tcl_UtfBackslash: longer \u subst} testbytestring { - expr {"\u4e21" eq [testbytestring "\xe4\xb8\xa1"]} + expr {"\u4E21" eq [testbytestring \xE4\xB8\xA1]} } 1 test utf-10.4 {Tcl_UtfBackslash: stops at first non-hex} testbytestring { - expr {"\u4e2k" eq "[testbytestring \xd3\xa2]k"} + expr {"\u4E2k" eq "[testbytestring \xD3\xA2]k"} } 1 test utf-10.5 {Tcl_UtfBackslash: stops after 4 hex chars} testbytestring { - expr {"\u4e216" eq "[testbytestring \xe4\xb8\xa1]6"} -} 1 -test utf-10.6 {Tcl_UtfBackslash: stops after 5 hex chars} testbytestring { - expr {"\U1e2165" eq "[testbytestring \xf0\x9e\x88\x96]5"} -} 1 -test utf-10.7 {Tcl_UtfBackslash: stops after 6 hex chars} testbytestring { - expr {"\U10e2165" eq "[testbytestring \xf4\x8e\x88\x96]5"} -} 1 -proc bsCheck {char num} { + expr {"\u4E216" eq "[testbytestring \xE4\xB8\xA1]6"} +} 1 +test utf-10.6 {Tcl_UtfBackslash: stops after 5 hex chars} {Uesc fullutf testbytestring} { + expr {"\U1E2165" eq "[testbytestring \xF0\x9E\x88\x96]5"} +} 1 +test utf-10.7 {Tcl_UtfBackslash: stops after 6 hex chars} {Uesc fullutf testbytestring} { + expr {"\U10E2165" eq "[testbytestring \xF4\x8E\x88\x96]5"} +} 1 + +proc bsCheck {char num {constraints {}}} { global errNum - test utf-10.$errNum {backslash substitution} { + test utf-10.$errNum {backslash substitution} $constraints { scan $char %c value set value } $num incr errNum } @@ -230,97 +1112,117 @@ bsCheck b\0 98 bsCheck \x 120 bsCheck \xa 10 bsCheck \xA 10 bsCheck \x41 65 -bsCheck \x541 84 +bsCheck \x541 65 pre388 ;# == \x41 +bsCheck \x541 84 !pre388 ;# == \x54 1 bsCheck \u 117 bsCheck \uk 117 bsCheck \u41 65 bsCheck \ua 10 bsCheck \uA 10 bsCheck \340 224 -bsCheck \ua1 161 -bsCheck \u4e21 20001 -bsCheck \741 60 -bsCheck \U 85 -bsCheck \Uk 85 -bsCheck \U41 65 -bsCheck \Ua 10 -bsCheck \UA 10 -bsCheck \Ua1 161 -bsCheck \U4e21 20001 -bsCheck \U004e21 20001 -bsCheck \U00004e21 20001 -bsCheck \U0000004e21 78 -bsCheck \U00110000 69632 -bsCheck \U01100000 69632 -bsCheck \U11000000 69632 -bsCheck \U0010FFFF 1114111 -bsCheck \U010FFFF0 1114111 -bsCheck \U10FFFF00 1114111 -bsCheck \UFFFFFFFF 1048575 +bsCheck \uA1 161 +bsCheck \u4E21 20001 +bsCheck \741 225 pre388 ;# == \341 +bsCheck \741 60 !pre388 ;# == \74 1 +bsCheck \U 85 +bsCheck \Uk 85 +bsCheck \U41 65 Uesc +bsCheck \Ua 10 Uesc +bsCheck \UA 10 Uesc +bsCheck \UA1 161 Uesc +bsCheck \U4E21 20001 Uesc +bsCheck \U004E21 20001 Uesc +bsCheck \U00004E21 20001 Uesc +bsCheck \U0000004E21 78 Uesc +bsCheck \U00110000 69632 {Uesc fullutf} +bsCheck \U01100000 69632 {Uesc fullutf} +bsCheck \U11000000 69632 {Uesc fullutf} +bsCheck \U0010FFFF 1114111 {Uesc fullutf} +bsCheck \U010FFFF0 1114111 {Uesc fullutf} +bsCheck \U10FFFF00 1114111 {Uesc fullutf} +bsCheck \UFFFFFFFF 1048575 {Uesc fullutf} test utf-11.1 {Tcl_UtfToUpper} { string toupper {} } {} test utf-11.2 {Tcl_UtfToUpper} { string toupper abc } ABC test utf-11.3 {Tcl_UtfToUpper} { - string toupper \u00e3ab -} \u00c3AB + string toupper \xE3gh +} \xC3GH test utf-11.4 {Tcl_UtfToUpper} { - string toupper \u01e3ab -} \u01e2AB + string toupper \u01E3gh +} \u01E2GH test utf-11.5 {Tcl_UtfToUpper Georgian (new in Unicode 11)} { - string toupper \u10d0\u1c90 -} \u1c90\u1c90 -test utf-11.6 {Tcl_UtfToUpper low/high surrogate)} { - string toupper \udc24\ud824 -} \udc24\ud824 + string toupper \u10D0\u1C90 +} \u1C90\u1C90 +test utf-11.6 {Tcl_UtfToUpper beyond U+FFFF} {Uesc fullutf} { + string toupper \U10428 +} \U10400 +test utf-11.7 {Tcl_UtfToUpper beyond U+FFFF} fullutf { + string toupper \uD801\uDC28 +} \uD801\uDC00 +test utf-11.8 {Tcl_UtfToUpper low/high surrogate)} { + string toupper \uDC24\uD824 +} \uDC24\uD824 test utf-12.1 {Tcl_UtfToLower} { string tolower {} } {} test utf-12.2 {Tcl_UtfToLower} { string tolower ABC } abc test utf-12.3 {Tcl_UtfToLower} { - string tolower \u00c3AB -} \u00e3ab + string tolower \xC3GH +} \xE3gh test utf-12.4 {Tcl_UtfToLower} { - string tolower \u01e2AB -} \u01e3ab + string tolower \u01E2GH +} \u01E3gh test utf-12.5 {Tcl_UtfToLower Georgian (new in Unicode 11)} { - string tolower \u10d0\u1c90 -} \u10d0\u10d0 -test utf-12.6 {Tcl_UtfToUpper low/high surrogate)} { - string tolower \udc24\ud824 -} \udc24\ud824 + string tolower \u10D0\u1C90 +} \u10D0\u10D0 +test utf-12.6 {Tcl_UtfToLower low/high surrogate)} { + string tolower \uDC24\uD824 +} \uDC24\uD824 +test utf-12.7 {Tcl_UtfToLower beyond U+FFFF} {Uesc fullutf} { + string tolower \U10400 +} \U10428 +test utf-12.8 {Tcl_UtfToLower beyond U+FFFF} fullutf { + string tolower \uD801\uDC00 +} \uD801\uDC28 test utf-13.1 {Tcl_UtfToTitle} { string totitle {} } {} test utf-13.2 {Tcl_UtfToTitle} { string totitle abc } Abc test utf-13.3 {Tcl_UtfToTitle} { - string totitle \u00e3ab -} \u00c3ab + string totitle \xE3GH +} \xC3gh test utf-13.4 {Tcl_UtfToTitle} { - string totitle \u01f3ab -} \u01f2ab + string totitle \u01F3AB +} \u01F2ab test utf-13.5 {Tcl_UtfToTitle Georgian (new in Unicode 11)} { - string totitle \u10d0\u1c90 -} \u10d0\u1c90 + string totitle \u10D0\u1C90 +} \u10D0\u1C90 test utf-13.6 {Tcl_UtfToTitle Georgian (new in Unicode 11)} { - string totitle \u1c90\u10d0 -} \u1c90\u10d0 + string totitle \u1C90\u10D0 +} \u1C90\u10D0 test utf-13.7 {Tcl_UtfToTitle low/high surrogate)} { - string totitle \udc24\ud824 -} \udc24\ud824 + string totitle \uDC24\uD824 +} \uDC24\uD824 +test utf-13.8 {Tcl_UtfToTitle beyond U+FFFF} {Uesc fullutf} { + string totitle \U10428\U10400 +} \U10400\U10428 +test utf-13.9 {Tcl_UtfToTitle beyond U+FFFF} fullutf { + string totitle \uD801\uDC28\uD801\uDC00 +} \uD801\uDC00\uD801\uDC28 test utf-14.1 {Tcl_UtfNcasecmp} { string compare -nocase a b } -1 test utf-14.2 {Tcl_UtfNcasecmp} { @@ -335,38 +1237,38 @@ test utf-15.1 {Tcl_UniCharToUpper, negative delta} { string toupper aA } AA test utf-15.2 {Tcl_UniCharToUpper, positive delta} { - string toupper \u0178\u00ff + string toupper \u0178\xFF } \u0178\u0178 test utf-15.3 {Tcl_UniCharToUpper, no delta} { string toupper ! } ! test utf-16.1 {Tcl_UniCharToLower, negative delta} { string tolower aA } aa test utf-16.2 {Tcl_UniCharToLower, positive delta} { - string tolower \u0178\u00ff\uA78D\u01c5\U10400 -} \u00ff\u00ff\u0265\u01c6\U10428 + string tolower \u0178\xFF\uA78D\u01C5 +} \xFF\xFF\u0265\u01C6 test utf-17.1 {Tcl_UniCharToLower, no delta} { string tolower ! } ! test utf-18.1 {Tcl_UniCharToTitle, add one for title} { - string totitle \u01c4 -} \u01c5 + string totitle \u01C4 +} \u01C5 test utf-18.2 {Tcl_UniCharToTitle, subtract one for title} { - string totitle \u01c6 -} \u01c5 + string totitle \u01C6 +} \u01C5 test utf-18.3 {Tcl_UniCharToTitle, subtract delta for title (positive)} { - string totitle \u017f -} \u0053 + string totitle \u017F +} \x53 test utf-18.4 {Tcl_UniCharToTitle, subtract delta for title (negative)} { - string totitle \u00ff + string totitle \xFF } \u0178 test utf-18.5 {Tcl_UniCharToTitle, no delta} { string totitle ! } ! @@ -374,162 +1276,163 @@ list [regexp \\d abc456def foo] $foo } -cleanup { unset -nocomplain foo } -result {1 4} -test utf-20.1 {TclUniCharNcmp} { -} {} +test utf-20.1 {TclUniCharNcmp} ucs4 { + string compare [string range [format %c 0xFFFF] 0 0] [string range [format %c 0x10000] 0 0] +} -1 +test utf-20.2 {[4c591fa487] TclUniCharNcmp/TclUtfNcmp} knownBug { + set one [format %c 0xFFFF] + set two [format %c 0x10000] + set first [string compare $one $two] + string range $one 0 0 + string range $two 0 0 + set second [string compare $one $two] + expr {($first == $second) ? "agree" : "disagree"} +} agree test utf-21.1 {TclUniCharIsAlnum} { # this returns 1 with Unicode 7 compliance - string is alnum \u1040\u021f\u0220 -} {1} + string is alnum \u1040\u021F\u0220 +} 1 test utf-21.2 {unicode alnum char in regc_locale.c} { # this returns 1 with Unicode 7 compliance - list [regexp {^[[:alnum:]]+$} \u1040\u021f\u0220] [regexp {^\w+$} \u1040\u021f\u0220_\u203f\u2040\u2054\ufe33\ufe34\ufe4d\ufe4e\ufe4f\uff3f] + list [regexp {^[[:alnum:]]+$} \u1040\u021F\u0220] [regexp {^\w+$} \u1040\u021F\u0220_\u203F\u2040\u2054\uFE33\uFE34\uFE4D\uFE4E\uFE4F\uFF3F] } {1 1} test utf-21.3 {unicode print char in regc_locale.c} { # this returns 1 with Unicode 7 compliance - regexp {^[[:print:]]+$} \ufbc1 + regexp {^[[:print:]]+$} \uFBC1 } 1 test utf-21.4 {TclUniCharIsGraph} { # [Bug 3464428] string is graph \u0120 -} {1} +} 1 test utf-21.5 {unicode graph char in regc_locale.c} { # [Bug 3464428] regexp {^[[:graph:]]+$} \u0120 -} {1} +} 1 test utf-21.6 {TclUniCharIsGraph} { # [Bug 3464428] - string is graph \u00a0 -} {0} + string is graph \xA0 +} 0 test utf-21.7 {unicode graph char in regc_locale.c} { # [Bug 3464428] - regexp {[[:graph:]]} \u0020\u00a0\u2028\u2029 -} {0} + regexp {[[:graph:]]} \x20\xA0\u2028\u2029 +} 0 test utf-21.8 {TclUniCharIsPrint} { # [Bug 3464428] - string is print \u0009 -} {0} + string is print \x09 +} 0 test utf-21.9 {unicode print char in regc_locale.c} { # [Bug 3464428] - regexp {[[:print:]]} \u0009 -} {0} + regexp {[[:print:]]} \x09 +} 0 test utf-21.10 {unicode print char in regc_locale.c} { # [Bug 3464428] - regexp {[[:print:]]} \u0009 -} {0} + regexp {[[:print:]]} \x09 +} 0 test utf-21.11 {TclUniCharIsControl} { # [Bug 3464428] - string is control \u0000\u001f\u00ad\u0605\u061c\u180e\u2066\ufeff -} {1} + string is control \x00\x1F\xAD\u0605\u061C\u180E\u2066\uFEFF +} 1 test utf-21.12 {unicode control char in regc_locale.c} { # [Bug 3464428], [Bug a876646efe] - regexp {^[[:cntrl:]]*$} \u0000\u001f\u00ad\u0605\u061c\u180e\u2066\ufeff -} {1} + regexp {^[[:cntrl:]]*$} \x00\x1F\xAD\u0605\u061C\u180E\u2066\uFEFF +} 1 test utf-22.1 {TclUniCharIsWordChar} { string wordend "xyz123_bar fg" 0 } 10 test utf-22.2 {TclUniCharIsWordChar} { - string wordend "x\u5080z123_bar\u203c fg" 0 + string wordend "x\u5080z123_bar\u203C fg" 0 } 10 test utf-23.1 {TclUniCharIsAlpha} { # this returns 1 with Unicode 7 compliance - string is alpha \u021f\u0220\u037f\u052f -} {1} + string is alpha \u021F\u0220\u037F\u052F +} 1 test utf-23.2 {unicode alpha char in regc_locale.c} { # this returns 1 with Unicode 7 compliance - regexp {^[[:alpha:]]+$} \u021f\u0220\u037f\u052f -} {1} + regexp {^[[:alpha:]]+$} \u021F\u0220\u037F\u052F +} 1 test utf-24.1 {TclUniCharIsDigit} { # this returns 1 with Unicode 7 compliance - string is digit \u1040\uabf0 -} {1} + string is digit \u1040\uABF0 +} 1 test utf-24.2 {unicode digit char in regc_locale.c} { # this returns 1 with Unicode 7 compliance - list [regexp {^[[:digit:]]+$} \u1040\uabf0] [regexp {^\d+$} \u1040\uabf0] + list [regexp {^[[:digit:]]+$} \u1040\uABF0] [regexp {^\d+$} \u1040\uABF0] } {1 1} test utf-24.3 {TclUniCharIsSpace} { - # this returns 1 with Unicode 7/TIP 413 compliance - string is space \u0085\u1680\u180e\u200b\u202f\u2060 -} {1} -test utf-24.4 {unicode space char in regc_locale.c} { - # this returns 1 with Unicode 7/TIP 413 compliance - list [regexp {^[[:space:]]+$} \u0085\u1680\u180e\u200b\u202f\u2060] [regexp {^\s+$} \u0085\u1680\u180e\u200b\u202f\u2060] -} {1 1} - -testConstraint teststringobj [llength [info commands teststringobj]] - -test utf-25.1 {Tcl_UniCharNcasecmp} -constraints teststringobj \ - -setup { - testobj freeallvars - } \ - -body { - teststringobj set 1 a - teststringobj set 2 b - teststringobj getunicode 1 - teststringobj getunicode 2 - string compare -nocase [teststringobj get 1] [teststringobj get 2] - } \ - -cleanup { - testobj freeallvars - } \ - -result -1 -test utf-25.2 {Tcl_UniCharNcasecmp} -constraints teststringobj \ - -setup { - testobj freeallvars - } \ - -body { - teststringobj set 1 b - teststringobj set 2 a - teststringobj getunicode 1 - teststringobj getunicode 2 - string compare -nocase [teststringobj get 1] [teststringobj get 2] - } \ - -cleanup { - testobj freeallvars - } \ - -result 1 -test utf-25.3 {Tcl_UniCharNcasecmp} -constraints teststringobj \ - -setup { - testobj freeallvars - } \ - -body { - teststringobj set 1 B - teststringobj set 2 a - teststringobj getunicode 1 - teststringobj getunicode 2 - string compare -nocase [teststringobj get 1] [teststringobj get 2] - } \ - -cleanup { - testobj freeallvars - } \ - -result 1 - -test utf-25.4 {Tcl_UniCharNcasecmp} -constraints teststringobj \ - -setup { - testobj freeallvars - } \ - -body { - teststringobj set 1 aBcB - teststringobj set 2 abca - teststringobj getunicode 1 - teststringobj getunicode 2 - string compare -nocase [teststringobj get 1] [teststringobj get 2] - } \ - -cleanup { - testobj freeallvars - } \ - -result 1 + # this returns 1 with Unicode 7 compliance + string is space \u1680\u180E\u202F +} 1 +test utf-24.4 {unicode space char in regc_locale.c} { + # this returns 1 with Unicode 7 compliance + list [regexp {^[[:space:]]+$} \u1680\u180E\u202F] [regexp {^\s+$} \u1680\u180E\u202F] +} {1 1} +test utf-24.5 {TclUniCharIsSpace} tip413 { + # this returns 1 with Unicode 7/TIP 413 compliance + string is space \x85\u1680\u180E\u200B\u202F\u2060 +} 1 +test utf-24.6 {unicode space char in regc_locale.c} tip413 { + # this returns 1 with Unicode 7/TIP 413 compliance + list [regexp {^[[:space:]]+$} \x85\u1680\u180E\u200B\u202F\u2060] [regexp {^\s+$} \x85\u1680\u180E\u200B\u202F\u2060] +} {1 1} + +proc UniCharCaseCmpTest {order one two {constraints {}}} { + variable count + test utf-25.$count {Tcl_UniCharNcasecmp} -setup { + testobj freeallvars + } -constraints [linsert $constraints 0 teststringobj] -cleanup { + testobj freeallvars + } -body { + teststringobj set 1 $one + teststringobj set 2 $two + teststringobj getunicode 1 + teststringobj getunicode 2 + set result [string compare -nocase [teststringobj get 1] [teststringobj get 2]] + if {$result eq [string map {< -1 = 0 > 1} $order]} { + set result ok + } else { + set result "'$one' should be $order '$two' (no case)" + } + set result + } -result ok + incr count +} +variable count 1 +UniCharCaseCmpTest < a b +UniCharCaseCmpTest > b a +UniCharCaseCmpTest > B a +UniCharCaseCmpTest > aBcB abca +UniCharCaseCmpTest < \uFFFF [format %c 0x10000] ucs4 +UniCharCaseCmpTest < \uFFFF \U10000 {Uesc ucs4} +UniCharCaseCmpTest > [format %c 0x10000] \uFFFF ucs4 +UniCharCaseCmpTest > \U10000 \uFFFF {Uesc ucs4} + + +test utf-26.1 {Tcl_UniCharDString} -setup { + testobj freeallvars +} -constraints {teststringobj testbytestring} -cleanup { + testobj freeallvars +} -body { + teststringobj set 1 foo + teststringobj getunicode 1 + teststringobj append 1 [testbytestring barsoom\xF2\xC2\x80] 10 + scan [string index [teststringobj get 1] 11] %c +} -result 128 + + +unset count +rename UniCharCaseCmpTest {} # cleanup ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: Index: tests/util.test ================================================================== --- tests/util.test +++ tests/util.test @@ -5,12 +5,12 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -18,11 +18,10 @@ testConstraint controversialNaN 1 testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testdstring [llength [info commands testdstring]] testConstraint testconcatobj [llength [info commands testconcatobj]] testConstraint testdoubledigits [llength [info commands testdoubledigits]] -testConstraint testprint [llength [info commands testprint]] # Big test for correct ordering of data in [expr] proc testIEEE {} { variable ieeeValues @@ -277,11 +276,11 @@ Wrapper_Tcl_StringMatch "a\[a\u4e4fc]c" "a\u4e4fc" } 1 test util-5.18 {Tcl_StringMatch: UTF-8} testbytestring { # pattern += Tcl_UtfToUniChar(pattern, &endChar); # proper advance: wrong answer would match on UTF trail byte of \u4e4f - Wrapper_Tcl_StringMatch {a[a\u4e4fc]c} [testbytestring a\x8Fc] + Wrapper_Tcl_StringMatch {a[a\u4e4fc]c} [testbytestring a\u008fc] } 0 test util-5.19 {Tcl_StringMatch: UTF-8} { # pattern += Tcl_UtfToUniChar(pattern, &endChar); # proper advance. Wrapper_Tcl_StringMatch {a[a\u4e4fc]c} "acc" @@ -382,20 +381,100 @@ Wrapper_Tcl_StringMatch *. "" } 0 test util-5.51 {Tcl_StringMatch} { Wrapper_Tcl_StringMatch "" "" } 1 +test util-5.52 {Tcl_StringMatch} { + Wrapper_Tcl_StringMatch \[a\u0000 a\x80 +} 0 + +test util-6.1 {Tcl_PrintDouble - using tcl_precision} -setup { + set old_precision $::tcl_precision + set ::tcl_precision 12 +} -body { + concat x[expr 1.4] +} -cleanup { + set ::tcl_precision $old_precision +} -result {x1.4} +test util-6.2 {Tcl_PrintDouble - using tcl_precision} -setup { + set old_precision $::tcl_precision + set ::tcl_precision 12 +} -body { + concat x[expr 1.39999999999] +} -cleanup { + set ::tcl_precision $old_precision +} -result {x1.39999999999} +test util-6.3 {Tcl_PrintDouble - using tcl_precision} -setup { + set old_precision $::tcl_precision + set ::tcl_precision 12 +} -body { + concat x[expr 1.399999999999] +} -cleanup { + set ::tcl_precision $old_precision +} -result {x1.4} +test util-6.4 {Tcl_PrintDouble - using tcl_precision} -setup { + set old_precision $::tcl_precision + set ::tcl_precision 5 +} -body { + concat x[expr 1.123412341234] +} -cleanup { + set tcl_precision $old_precision +} -result {x1.1234} test util-6.5 {Tcl_PrintDouble - make sure there's a decimal point} { concat x[expr 2.0] } {x2.0} test util-6.6 {Tcl_PrintDouble - make sure there's a decimal point} { concat x[expr 3.0e98] } {x3e+98} +test util-7.1 {TclPrecTraceProc - unset callbacks} -setup { + set old_precision $::tcl_precision +} -body { + set tcl_precision 7 + set x $tcl_precision + unset tcl_precision + list $x $tcl_precision +} -cleanup { + set ::tcl_precision $old_precision +} -result {7 7} +test util-7.2 {TclPrecTraceProc - read traces, sharing among interpreters} -setup { + set old_precision $::tcl_precision +} -body { + set tcl_precision 12 + interp create child + set x [child eval set tcl_precision] + child eval {set tcl_precision 6} + interp delete child + list $x $tcl_precision +} -cleanup { + set ::tcl_precision $old_precision +} -result {12 6} +test util-7.3 {TclPrecTraceProc - write traces, safe interpreters} -setup { + set old_precision $::tcl_precision +} -body { + set tcl_precision 12 + interp create -safe child + set x [child eval { + list [catch {set tcl_precision 8} msg] $msg + }] + interp delete child + list $x $tcl_precision +} -cleanup { + set ::tcl_precision $old_precision +} -result {{1 {can't set "tcl_precision": can't modify precision from a safe interpreter}} 12} +test util-7.4 {TclPrecTraceProc - write traces, bogus values} -setup { + set old_precision $::tcl_precision +} -body { + set tcl_precision 12 + list [catch {set tcl_precision abc} msg] $msg $tcl_precision +} -cleanup { + set ::tcl_precision $old_precision +} -result {1 {can't set "tcl_precision": improper value for precision} 12} + # This test always succeeded in the C locale anyway... -test util-8.1 {TclNeedSpace - correct UTF8 handling} { +test util-8.1 {TclNeedSpace - correct utf-8 handling} { # Bug 411825 # Note that this test relies on the fact that # [interp target] calls on Tcl_AppendElement() # which calls on TclNeedSpace(). If [interp target] # is ever updated, this test will no longer test @@ -405,299 +484,277 @@ interp alias {} fooset [list \u5420 foo] set set result [interp target {} fooset] interp delete \u5420 set result } "\u5420 foo" -test util-8.2 {TclNeedSpace - correct UTF8 handling} testdstring { +test util-8.2 {TclNeedSpace - correct utf-8 handling} testdstring { # Bug 411825 # This tests the same bug as the previous test, but # should be more future-proof, as the DString # operations will likely continue to call TclNeedSpace testdstring free testdstring append \u5420 -1 testdstring element foo llength [testdstring get] } 2 -test util-8.3 {TclNeedSpace - correct UTF8 handling} testdstring { +test util-8.3 {TclNeedSpace - correct utf-8 handling} testdstring { # Bug 411825 - new variant reported by Dossy Shiobara testdstring free testdstring append \u00A0 -1 testdstring element foo llength [testdstring get] } 2 -test util-8.4 {TclNeedSpace - correct UTF8 handling} testdstring { +test util-8.4 {TclNeedSpace - correct utf-8 handling} testdstring { # Another bug uncovered while fixing 411825 testdstring free testdstring append {\ } -1 testdstring append \{ -1 testdstring element foo llength [testdstring get] } 2 -test util-8.5 {TclNeedSpace - correct UTF8 handling} testdstring { - # Note that in this test TclNeedSpace actually gets it wrong, - # claiming we need a space when we really do not. Extra space - # between list elements is harmless though, and better to have - # extra space in really weird string reps of lists, than to - # invest the effort required to make TclNeedSpace foolproof. +test util-8.5 {TclNeedSpace - correct utf-8 handling} testdstring { testdstring free testdstring append {\\ } -1 testdstring element foo list [llength [testdstring get]] [string length [testdstring get]] -} {2 7} -test util-8.6 {TclNeedSpace - correct UTF8 handling} testdstring { - # Another example of TclNeedSpace harmlessly getting it wrong. +} {2 6} +test util-8.6 {TclNeedSpace - correct utf-8 handling} testdstring { testdstring free testdstring append {\\ } -1 testdstring append \{ -1 testdstring element foo testdstring append \} -1 list [llength [testdstring get]] [string length [testdstring get]] -} {2 9} +} {2 8} +test util-8.7 {TclNeedSpace - watch out for escaped space} { + testdstring free + testdstring append {\ } -1 + testdstring start + testdstring end + + # Should make {\ {}} + list [llength [testdstring get]] [string index [testdstring get] 3] +} {2 \{} +test util-8.8 {TclNeedSpace - watch out for escaped space} { + testdstring free + testdstring append {\\ } -1 + testdstring start + testdstring end + + # Should make {\\ {}} + list [llength [testdstring get]] [string index [testdstring get] 3] +} {2 \{} +test util-8.9 {TclNeedSpace - watch out for escaped space} { + testdstring free + testdstring append {\\\ } -1 + testdstring start + testdstring end + + # Should make {\\\ {}} + list [llength [testdstring get]] [string index [testdstring get] 5] +} {2 \{} +test util-8.10 {TclNeedSpace - watch out for escaped space} { + testdstring free + testdstring append {\\\\\\\ } -1 + testdstring start + testdstring end + + # Should make {\\\\\\\ {}} + list [llength [testdstring get]] [string index [testdstring get] 9] +} {2 \{} +test util-8.11 {TclNeedSpace - watch out for escaped space} { + testdstring free + testdstring append {\\\\\\\\ } -1 + testdstring start + testdstring end + + # Should make {\\\\\\\\ {}} + list [llength [testdstring get]] [string index [testdstring get] 9] +} {2 \{} -test util-9.0.0 {Tcl_GetIntForIndex} { +test util-9.0.0 {TclGetIntForIndex} { string index abcd 0 } a -test util-9.0.1 {Tcl_GetIntForIndex} { +test util-9.0.1 {TclGetIntForIndex} { string index abcd 0x0 } a -test util-9.0.2 {Tcl_GetIntForIndex} { +test util-9.0.2 {TclGetIntForIndex} { string index abcd -0x0 } a -test util-9.0.3 {Tcl_GetIntForIndex} { +test util-9.0.3 {TclGetIntForIndex} { string index abcd { 0 } } a -test util-9.0.4 {Tcl_GetIntForIndex} { +test util-9.0.4 {TclGetIntForIndex} { string index abcd { 0x0 } } a -test util-9.0.5 {Tcl_GetIntForIndex} { +test util-9.0.5 {TclGetIntForIndex} { string index abcd { -0x0 } } a -test util-9.0.6 {Tcl_GetIntForIndex} { +test util-9.0.6 {TclGetIntForIndex} { string index abcd 01 } b -test util-9.0.7 {Tcl_GetIntForIndex} { +test util-9.0.7 {TclGetIntForIndex} { string index abcd { 01 } } b -test util-9.0.8 {Tcl_GetIntForIndex} { - string index abcd { 0d0 } -} a -test util-9.0.9 {Tcl_GetIntForIndex} { - string index abcd { -0d0 } -} a -test util-9.1.0 {Tcl_GetIntForIndex} { +test util-9.1.0 {TclGetIntForIndex} { string index abcd 3 } d -test util-9.1.1 {Tcl_GetIntForIndex} { +test util-9.1.1 {TclGetIntForIndex} { string index abcd { 3 } } d -test util-9.1.2 {Tcl_GetIntForIndex} { +test util-9.1.2 {TclGetIntForIndex} { string index abcdefghijk 0xa } k -test util-9.1.3 {Tcl_GetIntForIndex} { +test util-9.1.3 {TclGetIntForIndex} { string index abcdefghijk { 0xa } } k -test util-9.1.4 {Tcl_GetIntForIndex} { - string index abcdefghijk 0d10 -} k -test util-9.1.5 {Tcl_GetIntForIndex} { - string index abcdefghijk { 0d10 } -} k -test util-9.2.0 {Tcl_GetIntForIndex} { +test util-9.2.0 {TclGetIntForIndex} { string index abcd end } d -test util-9.2.1 {Tcl_GetIntForIndex} -body { +test util-9.2.1 {TclGetIntForIndex} -body { string index abcd { end} } -returnCodes error -match glob -result * -test util-9.2.2 {Tcl_GetIntForIndex} -body { +test util-9.2.2 {TclGetIntForIndex} -body { string index abcd {end } } -returnCodes error -match glob -result * -test util-9.3 {Tcl_GetIntForIndex} -body { +test util-9.3 {TclGetIntForIndex} { # Deprecated string index abcd en -} -returnCodes error -match glob -result * -test util-9.4 {Tcl_GetIntForIndex} -body { +} d +test util-9.4 {TclGetIntForIndex} { # Deprecated string index abcd e -} -returnCodes error -match glob -result * -test util-9.5.0 {Tcl_GetIntForIndex} { +} d +test util-9.5.0 {TclGetIntForIndex} { string index abcd end-1 } c -test util-9.5.1 {Tcl_GetIntForIndex} { +test util-9.5.1 {TclGetIntForIndex} { string index abcd {end-1 } } c -test util-9.5.2 {Tcl_GetIntForIndex} -body { +test util-9.5.2 {TclGetIntForIndex} -body { string index abcd { end-1} } -returnCodes error -match glob -result * -test util-9.6 {Tcl_GetIntForIndex} { +test util-9.6 {TclGetIntForIndex} { string index abcd end+-1 } c -test util-9.7 {Tcl_GetIntForIndex} { +test util-9.7 {TclGetIntForIndex} { string index abcd end+1 } {} -test util-9.8 {Tcl_GetIntForIndex} { +test util-9.8 {TclGetIntForIndex} { string index abcd end--1 } {} -test util-9.9.0 {Tcl_GetIntForIndex} { +test util-9.9.0 {TclGetIntForIndex} { string index abcd 0+0 } a -test util-9.9.1 {Tcl_GetIntForIndex} { +test util-9.9.1 {TclGetIntForIndex} { string index abcd { 0+0 } } a -test util-9.10 {Tcl_GetIntForIndex} { +test util-9.10 {TclGetIntForIndex} { string index abcd 0-0 } a -test util-9.11 {Tcl_GetIntForIndex} { +test util-9.11 {TclGetIntForIndex} { string index abcd 1+0 } b -test util-9.12 {Tcl_GetIntForIndex} { +test util-9.12 {TclGetIntForIndex} { string index abcd 1-0 } b -test util-9.13 {Tcl_GetIntForIndex} { +test util-9.13 {TclGetIntForIndex} { string index abcd 1+1 } c -test util-9.14 {Tcl_GetIntForIndex} { +test util-9.14 {TclGetIntForIndex} { string index abcd 1-1 } a -test util-9.15 {Tcl_GetIntForIndex} { +test util-9.15 {TclGetIntForIndex} { string index abcd -1+2 } b -test util-9.16 {Tcl_GetIntForIndex} { +test util-9.16 {TclGetIntForIndex} { string index abcd -1--2 } b -test util-9.17 {Tcl_GetIntForIndex} { +test util-9.17 {TclGetIntForIndex} { string index abcd { -1+2 } } b -test util-9.18 {Tcl_GetIntForIndex} { +test util-9.18 {TclGetIntForIndex} { string index abcd { -1--2 } } b -test util-9.19 {Tcl_GetIntForIndex} -body { +test util-9.19 {TclGetIntForIndex} -body { string index a {} } -returnCodes error -match glob -result * -test util-9.20 {Tcl_GetIntForIndex} -body { +test util-9.20 {TclGetIntForIndex} -body { string index a { } } -returnCodes error -match glob -result * -test util-9.21 {Tcl_GetIntForIndex} -body { - string index a " \r\t\n" -} -returnCodes error -match glob -result * -test util-9.22 {Tcl_GetIntForIndex} -body { - string index a + -} -returnCodes error -match glob -result * -test util-9.23 {Tcl_GetIntForIndex} -body { - string index a - -} -returnCodes error -match glob -result * -test util-9.24 {Tcl_GetIntForIndex} -body { - string index a x -} -returnCodes error -match glob -result * -test util-9.25 {Tcl_GetIntForIndex} -body { - string index a +x -} -returnCodes error -match glob -result * -test util-9.26 {Tcl_GetIntForIndex} -body { - string index a -x -} -returnCodes error -match glob -result * -test util-9.27 {Tcl_GetIntForIndex} -body { - string index a 0y -} -returnCodes error -match glob -result * -test util-9.28 {Tcl_GetIntForIndex} -body { - string index a 1* -} -returnCodes error -match glob -result * -test util-9.29 {Tcl_GetIntForIndex} -body { - string index a 0+ -} -returnCodes error -match glob -result * -test util-9.30 {Tcl_GetIntForIndex} -body { - string index a {0+ } -} -returnCodes error -match glob -result * -test util-9.31 {Tcl_GetIntForIndex} -body { - string index a 0x -} -returnCodes error -match glob -result * -test util-9.31.1 {Tcl_GetIntForIndex} -body { - string index a 0d -} -returnCodes error -match glob -result * -test util-9.32 {Tcl_GetIntForIndex} -body { - string index a 0x1FFFFFFFF+0 -} -result {} -test util-9.33 {Tcl_GetIntForIndex} -body { - string index a 100000000000+0 -} -result {} -test util-9.33.1 {Tcl_GetIntForIndex} -body { - string index a 0d100000000000+0 -} -result {} -test util-9.34 {Tcl_GetIntForIndex} -body { - string index a 1.0 -} -returnCodes error -match glob -result * -test util-9.35 {Tcl_GetIntForIndex} -body { - string index a 1e23 -} -returnCodes error -match glob -result * -test util-9.36 {Tcl_GetIntForIndex} -body { - string index a 1.5e2 -} -returnCodes error -match glob -result * -test util-9.37 {Tcl_GetIntForIndex} -body { - string index a 0+x -} -returnCodes error -match glob -result * -test util-9.38 {Tcl_GetIntForIndex} -body { - string index a 0+0x -} -returnCodes error -match glob -result * -test util-9.39 {Tcl_GetIntForIndex} -body { - string index a 0+0xg -} -returnCodes error -match glob -result * -test util-9.40 {Tcl_GetIntForIndex} -body { - string index a 0+0xg -} -returnCodes error -match glob -result * -test util-9.41 {Tcl_GetIntForIndex} -body { - string index a 0+1.0 -} -returnCodes error -match glob -result * -test util-9.42 {Tcl_GetIntForIndex} -body { - string index a 0+1e2 -} -returnCodes error -match glob -result * -test util-9.43 {Tcl_GetIntForIndex} -body { - string index a 0+1.5e1 -} -returnCodes error -match glob -result * -test util-9.44 {Tcl_GetIntForIndex} -body { - string index a 0+1000000000000 -} -result {} -test util-9.45 {Tcl_GetIntForIndex} { - string index abcd end+2305843009213693950 -} {} -test util-9.46 {Tcl_GetIntForIndex} { - string index abcd end+4294967294 -} {} -# TIP 502 -test util-9.47 {Tcl_GetIntForIndex} { - string index abcd 0x10000000000000000 -} {} -test util-9.48 {Tcl_GetIntForIndex} { - string index abcd -0x10000000000000000 -} {} -test util-9.49 {Tcl_GetIntForIndex} -body { - string index abcd end*1 -} -returnCodes error -match glob -result * -test util-9.50 {Tcl_GetIntForIndex} -body { - string index abcd {end- 1} -} -returnCodes error -match glob -result * -test util-9.51 {Tcl_GetIntForIndex} -body { - string index abcd end-end -} -returnCodes error -match glob -result * -test util-9.52 {Tcl_GetIntForIndex} -body { - string index abcd end-x -} -returnCodes error -match glob -result * -test util-9.53 {Tcl_GetIntForIndex} -body { - string index abcd end-0.1 -} -returnCodes error -match glob -result * -test util-9.54 {Tcl_GetIntForIndex} { - string index abcd end-0x10000000000000000 -} {} -test util-9.55 {Tcl_GetIntForIndex} { - string index abcd end+0x10000000000000000 -} {} -test util-9.56 {Tcl_GetIntForIndex} { - string index abcd end--0x10000000000000000 -} {} -test util-9.57 {Tcl_GetIntForIndex} { - string index abcd end+-0x10000000000000000 -} {} -test util-9.58 {Tcl_GetIntForIndex} { - string index abcd end--0x8000000000000000 -} {} +test util-9.21 {TclGetIntForIndex} -body { + string index a " \r\t\n" +} -returnCodes error -match glob -result * +test util-9.22 {TclGetIntForIndex} -body { + string index a + +} -returnCodes error -match glob -result * +test util-9.23 {TclGetIntForIndex} -body { + string index a - +} -returnCodes error -match glob -result * +test util-9.24 {TclGetIntForIndex} -body { + string index a x +} -returnCodes error -match glob -result * +test util-9.25 {TclGetIntForIndex} -body { + string index a +x +} -returnCodes error -match glob -result * +test util-9.26 {TclGetIntForIndex} -body { + string index a -x +} -returnCodes error -match glob -result * +test util-9.27 {TclGetIntForIndex} -body { + string index a 0y +} -returnCodes error -match glob -result * +test util-9.28 {TclGetIntForIndex} -body { + string index a 1* +} -returnCodes error -match glob -result * +test util-9.29 {TclGetIntForIndex} -body { + string index a 0+ +} -returnCodes error -match glob -result * +test util-9.30 {TclGetIntForIndex} -body { + string index a {0+ } +} -returnCodes error -match glob -result * +test util-9.31 {TclGetIntForIndex} -body { + string index a 0x +} -returnCodes error -match glob -result * +test util-9.32 {TclGetIntForIndex} -body { + string index a 0x1FFFFFFFF+0 +} -returnCodes error -match glob -result * +test util-9.33 {TclGetIntForIndex} -body { + string index a 100000000000+0 +} -returnCodes error -match glob -result * +test util-9.34 {TclGetIntForIndex} -body { + string index a 1.0 +} -returnCodes error -match glob -result * +test util-9.35 {TclGetIntForIndex} -body { + string index a 1e23 +} -returnCodes error -match glob -result * +test util-9.36 {TclGetIntForIndex} -body { + string index a 1.5e2 +} -returnCodes error -match glob -result * +test util-9.37 {TclGetIntForIndex} -body { + string index a 0+x +} -returnCodes error -match glob -result * +test util-9.38 {TclGetIntForIndex} -body { + string index a 0+0x +} -returnCodes error -match glob -result * +test util-9.39 {TclGetIntForIndex} -body { + string index a 0+0xg +} -returnCodes error -match glob -result * +test util-9.40 {TclGetIntForIndex} -body { + string index a 0+0xg +} -returnCodes error -match glob -result * +test util-9.41 {TclGetIntForIndex} -body { + string index a 0+1.0 +} -returnCodes error -match glob -result * +test util-9.42 {TclGetIntForIndex} -body { + string index a 0+1e2 +} -returnCodes error -match glob -result * +test util-9.43 {TclGetIntForIndex} -body { + string index a 0+1.5e1 +} -returnCodes error -match glob -result * +test util-9.44 {TclGetIntForIndex} -body { + string index a 0+1000000000000 +} -returnCodes error -match glob -result * test util-10.1 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x0000000000000000 } {0.0} test util-10.2 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { @@ -2102,10 +2159,1879 @@ -result 0x8010000000000000 -cleanup { unset x } } + +set saved_precision $::tcl_precision +foreach ::tcl_precision {0 12} { + for {set e -312} {$e < -9} {incr e} { + test util-16.1.$::tcl_precision.$e {shortening of numbers} \ + "expr 1.1e$e" 1.1e$e + } +} +set tcl_precision 0 +for {set e -9} {$e < -4} {incr e} { + test util-16.1.$::tcl_precision.$e {shortening of numbers} \ + "expr 1.1e$e" 1.1e$e +} +set tcl_precision 12 +for {set e -9} {$e < -4} {incr e} { + test util-16.1.$::tcl_precision.$e {8.4 compatible formatting of doubles} \ + "expr 1.1e$e" 1.1e[format %+03d $e] +} +foreach ::tcl_precision {0 12} { + test util-16.1.$::tcl_precision.-4 {shortening of numbers} \ + {expr 1.1e-4} \ + 0.00011 + test util-16.1.$::tcl_precision.-3 {shortening of numbers} \ + {expr 1.1e-3} \ + 0.0011 + test util-16.1.$::tcl_precision.-2 {shortening of numbers} \ + {expr 1.1e-2} \ + 0.011 + test util-16.1.$::tcl_precision.-1 {shortening of numbers} \ + {expr 1.1e-1} \ + 0.11 + test util-16.1.$::tcl_precision.0 {shortening of numbers} \ + {expr 1.1} \ + 1.1 + for {set e 1} {$e < 17} {incr e} { + test util-16.1.$::tcl_precision.$e {shortening of numbers} \ + "expr 11[string repeat 0 [expr {$e-1}]].0" \ + 11[string repeat 0 [expr {$e-1}]].0 + } + for {set e 17} {$e < 309} {incr e} { + test util-16.1.$::tcl_precision.$e {shortening of numbers} \ + "expr 1.1e$e" 1.1e+$e + } +} +set tcl_precision 17 +test util-16.1.17.-300 {8.4 compatible formatting of doubles} \ + {expr 1e-300} \ + 1e-300 +test util-16.1.17.-299 {8.4 compatible formatting of doubles} \ + {expr 1e-299} \ + 9.9999999999999999e-300 +test util-16.1.17.-298 {8.4 compatible formatting of doubles} \ + {expr 1e-298} \ + 9.9999999999999991e-299 +test util-16.1.17.-297 {8.4 compatible formatting of doubles} \ + {expr 1e-297} \ + 1e-297 +test util-16.1.17.-296 {8.4 compatible formatting of doubles} \ + {expr 1e-296} \ + 1e-296 +test util-16.1.17.-295 {8.4 compatible formatting of doubles} \ + {expr 1e-295} \ + 1.0000000000000001e-295 +test util-16.1.17.-294 {8.4 compatible formatting of doubles} \ + {expr 1e-294} \ + 1e-294 +test util-16.1.17.-293 {8.4 compatible formatting of doubles} \ + {expr 1e-293} \ + 1.0000000000000001e-293 +test util-16.1.17.-292 {8.4 compatible formatting of doubles} \ + {expr 1e-292} \ + 1.0000000000000001e-292 +test util-16.1.17.-291 {8.4 compatible formatting of doubles} \ + {expr 1e-291} \ + 9.9999999999999996e-292 +test util-16.1.17.-290 {8.4 compatible formatting of doubles} \ + {expr 1e-290} \ + 1.0000000000000001e-290 +test util-16.1.17.-289 {8.4 compatible formatting of doubles} \ + {expr 1e-289} \ + 1e-289 +test util-16.1.17.-288 {8.4 compatible formatting of doubles} \ + {expr 1e-288} \ + 1.0000000000000001e-288 +test util-16.1.17.-287 {8.4 compatible formatting of doubles} \ + {expr 1e-287} \ + 1e-287 +test util-16.1.17.-286 {8.4 compatible formatting of doubles} \ + {expr 1e-286} \ + 1.0000000000000001e-286 +test util-16.1.17.-285 {8.4 compatible formatting of doubles} \ + {expr 1e-285} \ + 1.0000000000000001e-285 +test util-16.1.17.-284 {8.4 compatible formatting of doubles} \ + {expr 1e-284} \ + 1e-284 +test util-16.1.17.-283 {8.4 compatible formatting of doubles} \ + {expr 1e-283} \ + 9.9999999999999995e-284 +test util-16.1.17.-282 {8.4 compatible formatting of doubles} \ + {expr 1e-282} \ + 1e-282 +test util-16.1.17.-281 {8.4 compatible formatting of doubles} \ + {expr 1e-281} \ + 1e-281 +test util-16.1.17.-280 {8.4 compatible formatting of doubles} \ + {expr 1e-280} \ + 9.9999999999999996e-281 +test util-16.1.17.-279 {8.4 compatible formatting of doubles} \ + {expr 1e-279} \ + 1.0000000000000001e-279 +test util-16.1.17.-278 {8.4 compatible formatting of doubles} \ + {expr 1e-278} \ + 9.9999999999999994e-279 +test util-16.1.17.-277 {8.4 compatible formatting of doubles} \ + {expr 1e-277} \ + 9.9999999999999997e-278 +test util-16.1.17.-276 {8.4 compatible formatting of doubles} \ + {expr 1e-276} \ + 1.0000000000000001e-276 +test util-16.1.17.-275 {8.4 compatible formatting of doubles} \ + {expr 1e-275} \ + 9.9999999999999993e-276 +test util-16.1.17.-274 {8.4 compatible formatting of doubles} \ + {expr 1e-274} \ + 9.9999999999999997e-275 +test util-16.1.17.-273 {8.4 compatible formatting of doubles} \ + {expr 1e-273} \ + 1.0000000000000001e-273 +test util-16.1.17.-272 {8.4 compatible formatting of doubles} \ + {expr 1e-272} \ + 9.9999999999999993e-273 +test util-16.1.17.-271 {8.4 compatible formatting of doubles} \ + {expr 1e-271} \ + 9.9999999999999996e-272 +test util-16.1.17.-270 {8.4 compatible formatting of doubles} \ + {expr 1e-270} \ + 1e-270 +test util-16.1.17.-269 {8.4 compatible formatting of doubles} \ + {expr 1e-269} \ + 9.9999999999999996e-270 +test util-16.1.17.-268 {8.4 compatible formatting of doubles} \ + {expr 1e-268} \ + 9.9999999999999996e-269 +test util-16.1.17.-267 {8.4 compatible formatting of doubles} \ + {expr 1e-267} \ + 9.9999999999999998e-268 +test util-16.1.17.-266 {8.4 compatible formatting of doubles} \ + {expr 1e-266} \ + 9.9999999999999998e-267 +test util-16.1.17.-265 {8.4 compatible formatting of doubles} \ + {expr 1e-265} \ + 9.9999999999999998e-266 +test util-16.1.17.-264 {8.4 compatible formatting of doubles} \ + {expr 1e-264} \ + 1e-264 +test util-16.1.17.-263 {8.4 compatible formatting of doubles} \ + {expr 1e-263} \ + 1e-263 +test util-16.1.17.-262 {8.4 compatible formatting of doubles} \ + {expr 1e-262} \ + 1e-262 +test util-16.1.17.-261 {8.4 compatible formatting of doubles} \ + {expr 1e-261} \ + 9.9999999999999998e-262 +test util-16.1.17.-260 {8.4 compatible formatting of doubles} \ + {expr 1e-260} \ + 9.9999999999999996e-261 +test util-16.1.17.-259 {8.4 compatible formatting of doubles} \ + {expr 1e-259} \ + 1.0000000000000001e-259 +test util-16.1.17.-258 {8.4 compatible formatting of doubles} \ + {expr 1e-258} \ + 9.9999999999999995e-259 +test util-16.1.17.-257 {8.4 compatible formatting of doubles} \ + {expr 1e-257} \ + 9.9999999999999998e-258 +test util-16.1.17.-256 {8.4 compatible formatting of doubles} \ + {expr 1e-256} \ + 9.9999999999999998e-257 +test util-16.1.17.-255 {8.4 compatible formatting of doubles} \ + {expr 1e-255} \ + 1e-255 +test util-16.1.17.-254 {8.4 compatible formatting of doubles} \ + {expr 1e-254} \ + 9.9999999999999991e-255 +test util-16.1.17.-253 {8.4 compatible formatting of doubles} \ + {expr 1e-253} \ + 1.0000000000000001e-253 +test util-16.1.17.-252 {8.4 compatible formatting of doubles} \ + {expr 1e-252} \ + 9.9999999999999994e-253 +test util-16.1.17.-251 {8.4 compatible formatting of doubles} \ + {expr 1e-251} \ + 1e-251 +test util-16.1.17.-250 {8.4 compatible formatting of doubles} \ + {expr 1e-250} \ + 1.0000000000000001e-250 +test util-16.1.17.-249 {8.4 compatible formatting of doubles} \ + {expr 1e-249} \ + 1.0000000000000001e-249 +test util-16.1.17.-248 {8.4 compatible formatting of doubles} \ + {expr 1e-248} \ + 9.9999999999999998e-249 +test util-16.1.17.-247 {8.4 compatible formatting of doubles} \ + {expr 1e-247} \ + 1e-247 +test util-16.1.17.-246 {8.4 compatible formatting of doubles} \ + {expr 1e-246} \ + 9.9999999999999996e-247 +test util-16.1.17.-245 {8.4 compatible formatting of doubles} \ + {expr 1e-245} \ + 9.9999999999999993e-246 +test util-16.1.17.-244 {8.4 compatible formatting of doubles} \ + {expr 1e-244} \ + 9.9999999999999993e-245 +test util-16.1.17.-243 {8.4 compatible formatting of doubles} \ + {expr 1e-243} \ + 1e-243 +test util-16.1.17.-242 {8.4 compatible formatting of doubles} \ + {expr 1e-242} \ + 9.9999999999999997e-243 +test util-16.1.17.-241 {8.4 compatible formatting of doubles} \ + {expr 1e-241} \ + 9.9999999999999997e-242 +test util-16.1.17.-240 {8.4 compatible formatting of doubles} \ + {expr 1e-240} \ + 9.9999999999999997e-241 +test util-16.1.17.-239 {8.4 compatible formatting of doubles} \ + {expr 1e-239} \ + 1.0000000000000001e-239 +test util-16.1.17.-238 {8.4 compatible formatting of doubles} \ + {expr 1e-238} \ + 9.9999999999999999e-239 +test util-16.1.17.-237 {8.4 compatible formatting of doubles} \ + {expr 1e-237} \ + 9.9999999999999999e-238 +test util-16.1.17.-236 {8.4 compatible formatting of doubles} \ + {expr 1e-236} \ + 1e-236 +test util-16.1.17.-235 {8.4 compatible formatting of doubles} \ + {expr 1e-235} \ + 9.9999999999999996e-236 +test util-16.1.17.-234 {8.4 compatible formatting of doubles} \ + {expr 1e-234} \ + 9.9999999999999996e-235 +test util-16.1.17.-233 {8.4 compatible formatting of doubles} \ + {expr 1e-233} \ + 9.9999999999999996e-234 +test util-16.1.17.-232 {8.4 compatible formatting of doubles} \ + {expr 1e-232} \ + 1e-232 +test util-16.1.17.-231 {8.4 compatible formatting of doubles} \ + {expr 1e-231} \ + 9.9999999999999999e-232 +test util-16.1.17.-230 {8.4 compatible formatting of doubles} \ + {expr 1e-230} \ + 1e-230 +test util-16.1.17.-229 {8.4 compatible formatting of doubles} \ + {expr 1e-229} \ + 1.0000000000000001e-229 +test util-16.1.17.-228 {8.4 compatible formatting of doubles} \ + {expr 1e-228} \ + 1e-228 +test util-16.1.17.-227 {8.4 compatible formatting of doubles} \ + {expr 1e-227} \ + 9.9999999999999994e-228 +test util-16.1.17.-226 {8.4 compatible formatting of doubles} \ + {expr 1e-226} \ + 9.9999999999999992e-227 +test util-16.1.17.-225 {8.4 compatible formatting of doubles} \ + {expr 1e-225} \ + 9.9999999999999996e-226 +test util-16.1.17.-224 {8.4 compatible formatting of doubles} \ + {expr 1e-224} \ + 1e-224 +test util-16.1.17.-223 {8.4 compatible formatting of doubles} \ + {expr 1e-223} \ + 9.9999999999999997e-224 +test util-16.1.17.-222 {8.4 compatible formatting of doubles} \ + {expr 1e-222} \ + 1e-222 +test util-16.1.17.-221 {8.4 compatible formatting of doubles} \ + {expr 1e-221} \ + 1e-221 +test util-16.1.17.-220 {8.4 compatible formatting of doubles} \ + {expr 1e-220} \ + 9.9999999999999999e-221 +test util-16.1.17.-219 {8.4 compatible formatting of doubles} \ + {expr 1e-219} \ + 1e-219 +test util-16.1.17.-218 {8.4 compatible formatting of doubles} \ + {expr 1e-218} \ + 1e-218 +test util-16.1.17.-217 {8.4 compatible formatting of doubles} \ + {expr 1e-217} \ + 1.0000000000000001e-217 +test util-16.1.17.-216 {8.4 compatible formatting of doubles} \ + {expr 1e-216} \ + 1e-216 +test util-16.1.17.-215 {8.4 compatible formatting of doubles} \ + {expr 1e-215} \ + 1e-215 +test util-16.1.17.-214 {8.4 compatible formatting of doubles} \ + {expr 1e-214} \ + 9.9999999999999991e-215 +test util-16.1.17.-213 {8.4 compatible formatting of doubles} \ + {expr 1e-213} \ + 9.9999999999999995e-214 +test util-16.1.17.-212 {8.4 compatible formatting of doubles} \ + {expr 1e-212} \ + 9.9999999999999995e-213 +test util-16.1.17.-211 {8.4 compatible formatting of doubles} \ + {expr 1e-211} \ + 1.0000000000000001e-211 +test util-16.1.17.-210 {8.4 compatible formatting of doubles} \ + {expr 1e-210} \ + 1e-210 +test util-16.1.17.-209 {8.4 compatible formatting of doubles} \ + {expr 1e-209} \ + 1e-209 +test util-16.1.17.-208 {8.4 compatible formatting of doubles} \ + {expr 1e-208} \ + 1.0000000000000001e-208 +test util-16.1.17.-207 {8.4 compatible formatting of doubles} \ + {expr 1e-207} \ + 9.9999999999999993e-208 +test util-16.1.17.-206 {8.4 compatible formatting of doubles} \ + {expr 1e-206} \ + 1e-206 +test util-16.1.17.-205 {8.4 compatible formatting of doubles} \ + {expr 1e-205} \ + 1e-205 +test util-16.1.17.-204 {8.4 compatible formatting of doubles} \ + {expr 1e-204} \ + 1e-204 +test util-16.1.17.-203 {8.4 compatible formatting of doubles} \ + {expr 1e-203} \ + 1e-203 +test util-16.1.17.-202 {8.4 compatible formatting of doubles} \ + {expr 1e-202} \ + 1e-202 +test util-16.1.17.-201 {8.4 compatible formatting of doubles} \ + {expr 1e-201} \ + 9.9999999999999995e-202 +test util-16.1.17.-200 {8.4 compatible formatting of doubles} \ + {expr 1e-200} \ + 9.9999999999999998e-201 +test util-16.1.17.-199 {8.4 compatible formatting of doubles} \ + {expr 1e-199} \ + 9.9999999999999998e-200 +test util-16.1.17.-198 {8.4 compatible formatting of doubles} \ + {expr 1e-198} \ + 9.9999999999999991e-199 +test util-16.1.17.-197 {8.4 compatible formatting of doubles} \ + {expr 1e-197} \ + 9.9999999999999999e-198 +test util-16.1.17.-196 {8.4 compatible formatting of doubles} \ + {expr 1e-196} \ + 1e-196 +test util-16.1.17.-195 {8.4 compatible formatting of doubles} \ + {expr 1e-195} \ + 1.0000000000000001e-195 +test util-16.1.17.-194 {8.4 compatible formatting of doubles} \ + {expr 1e-194} \ + 1e-194 +test util-16.1.17.-193 {8.4 compatible formatting of doubles} \ + {expr 1e-193} \ + 1e-193 +test util-16.1.17.-192 {8.4 compatible formatting of doubles} \ + {expr 1e-192} \ + 1.0000000000000001e-192 +test util-16.1.17.-191 {8.4 compatible formatting of doubles} \ + {expr 1e-191} \ + 1e-191 +test util-16.1.17.-190 {8.4 compatible formatting of doubles} \ + {expr 1e-190} \ + 1e-190 +test util-16.1.17.-189 {8.4 compatible formatting of doubles} \ + {expr 1e-189} \ + 1.0000000000000001e-189 +test util-16.1.17.-188 {8.4 compatible formatting of doubles} \ + {expr 1e-188} \ + 9.9999999999999995e-189 +test util-16.1.17.-187 {8.4 compatible formatting of doubles} \ + {expr 1e-187} \ + 1e-187 +test util-16.1.17.-186 {8.4 compatible formatting of doubles} \ + {expr 1e-186} \ + 9.9999999999999991e-187 +test util-16.1.17.-185 {8.4 compatible formatting of doubles} \ + {expr 1e-185} \ + 9.9999999999999999e-186 +test util-16.1.17.-184 {8.4 compatible formatting of doubles} \ + {expr 1e-184} \ + 1.0000000000000001e-184 +test util-16.1.17.-183 {8.4 compatible formatting of doubles} \ + {expr 1e-183} \ + 1e-183 +test util-16.1.17.-182 {8.4 compatible formatting of doubles} \ + {expr 1e-182} \ + 1e-182 +test util-16.1.17.-181 {8.4 compatible formatting of doubles} \ + {expr 1e-181} \ + 1e-181 +test util-16.1.17.-180 {8.4 compatible formatting of doubles} \ + {expr 1e-180} \ + 1e-180 +test util-16.1.17.-179 {8.4 compatible formatting of doubles} \ + {expr 1e-179} \ + 1e-179 +test util-16.1.17.-178 {8.4 compatible formatting of doubles} \ + {expr 1e-178} \ + 9.9999999999999995e-179 +test util-16.1.17.-177 {8.4 compatible formatting of doubles} \ + {expr 1e-177} \ + 9.9999999999999995e-178 +test util-16.1.17.-176 {8.4 compatible formatting of doubles} \ + {expr 1e-176} \ + 1e-176 +test util-16.1.17.-175 {8.4 compatible formatting of doubles} \ + {expr 1e-175} \ + 1e-175 +test util-16.1.17.-174 {8.4 compatible formatting of doubles} \ + {expr 1e-174} \ + 1e-174 +test util-16.1.17.-173 {8.4 compatible formatting of doubles} \ + {expr 1e-173} \ + 1e-173 +test util-16.1.17.-172 {8.4 compatible formatting of doubles} \ + {expr 1e-172} \ + 1e-172 +test util-16.1.17.-171 {8.4 compatible formatting of doubles} \ + {expr 1e-171} \ + 9.9999999999999998e-172 +test util-16.1.17.-170 {8.4 compatible formatting of doubles} \ + {expr 1e-170} \ + 9.9999999999999998e-171 +test util-16.1.17.-169 {8.4 compatible formatting of doubles} \ + {expr 1e-169} \ + 1e-169 +test util-16.1.17.-168 {8.4 compatible formatting of doubles} \ + {expr 1e-168} \ + 1e-168 +test util-16.1.17.-167 {8.4 compatible formatting of doubles} \ + {expr 1e-167} \ + 1e-167 +test util-16.1.17.-166 {8.4 compatible formatting of doubles} \ + {expr 1e-166} \ + 1e-166 +test util-16.1.17.-165 {8.4 compatible formatting of doubles} \ + {expr 1e-165} \ + 1e-165 +test util-16.1.17.-164 {8.4 compatible formatting of doubles} \ + {expr 1e-164} \ + 9.9999999999999996e-165 +test util-16.1.17.-163 {8.4 compatible formatting of doubles} \ + {expr 1e-163} \ + 9.9999999999999992e-164 +test util-16.1.17.-162 {8.4 compatible formatting of doubles} \ + {expr 1e-162} \ + 9.9999999999999995e-163 +test util-16.1.17.-161 {8.4 compatible formatting of doubles} \ + {expr 1e-161} \ + 1e-161 +test util-16.1.17.-160 {8.4 compatible formatting of doubles} \ + {expr 1e-160} \ + 9.9999999999999999e-161 +test util-16.1.17.-159 {8.4 compatible formatting of doubles} \ + {expr 1e-159} \ + 9.9999999999999999e-160 +test util-16.1.17.-158 {8.4 compatible formatting of doubles} \ + {expr 1e-158} \ + 1.0000000000000001e-158 +test util-16.1.17.-157 {8.4 compatible formatting of doubles} \ + {expr 1e-157} \ + 9.9999999999999994e-158 +test util-16.1.17.-156 {8.4 compatible formatting of doubles} \ + {expr 1e-156} \ + 1e-156 +test util-16.1.17.-155 {8.4 compatible formatting of doubles} \ + {expr 1e-155} \ + 1e-155 +test util-16.1.17.-154 {8.4 compatible formatting of doubles} \ + {expr 1e-154} \ + 9.9999999999999997e-155 +test util-16.1.17.-153 {8.4 compatible formatting of doubles} \ + {expr 1e-153} \ + 1e-153 +test util-16.1.17.-152 {8.4 compatible formatting of doubles} \ + {expr 1e-152} \ + 1.0000000000000001e-152 +test util-16.1.17.-151 {8.4 compatible formatting of doubles} \ + {expr 1e-151} \ + 9.9999999999999994e-152 +test util-16.1.17.-150 {8.4 compatible formatting of doubles} \ + {expr 1e-150} \ + 1e-150 +test util-16.1.17.-149 {8.4 compatible formatting of doubles} \ + {expr 1e-149} \ + 9.9999999999999998e-150 +test util-16.1.17.-148 {8.4 compatible formatting of doubles} \ + {expr 1e-148} \ + 9.9999999999999994e-149 +test util-16.1.17.-147 {8.4 compatible formatting of doubles} \ + {expr 1e-147} \ + 9.9999999999999997e-148 +test util-16.1.17.-146 {8.4 compatible formatting of doubles} \ + {expr 1e-146} \ + 1e-146 +test util-16.1.17.-145 {8.4 compatible formatting of doubles} \ + {expr 1e-145} \ + 9.9999999999999991e-146 +test util-16.1.17.-144 {8.4 compatible formatting of doubles} \ + {expr 1e-144} \ + 9.9999999999999995e-145 +test util-16.1.17.-143 {8.4 compatible formatting of doubles} \ + {expr 1e-143} \ + 9.9999999999999995e-144 +test util-16.1.17.-142 {8.4 compatible formatting of doubles} \ + {expr 1e-142} \ + 1e-142 +test util-16.1.17.-141 {8.4 compatible formatting of doubles} \ + {expr 1e-141} \ + 1e-141 +test util-16.1.17.-140 {8.4 compatible formatting of doubles} \ + {expr 1e-140} \ + 9.9999999999999998e-141 +test util-16.1.17.-139 {8.4 compatible formatting of doubles} \ + {expr 1e-139} \ + 1e-139 +test util-16.1.17.-138 {8.4 compatible formatting of doubles} \ + {expr 1e-138} \ + 1.0000000000000001e-138 +test util-16.1.17.-137 {8.4 compatible formatting of doubles} \ + {expr 1e-137} \ + 9.9999999999999998e-138 +test util-16.1.17.-136 {8.4 compatible formatting of doubles} \ + {expr 1e-136} \ + 1e-136 +test util-16.1.17.-135 {8.4 compatible formatting of doubles} \ + {expr 1e-135} \ + 1e-135 +test util-16.1.17.-134 {8.4 compatible formatting of doubles} \ + {expr 1e-134} \ + 1e-134 +test util-16.1.17.-133 {8.4 compatible formatting of doubles} \ + {expr 1e-133} \ + 1.0000000000000001e-133 +test util-16.1.17.-132 {8.4 compatible formatting of doubles} \ + {expr 1e-132} \ + 9.9999999999999999e-133 +test util-16.1.17.-131 {8.4 compatible formatting of doubles} \ + {expr 1e-131} \ + 9.9999999999999999e-132 +test util-16.1.17.-130 {8.4 compatible formatting of doubles} \ + {expr 1e-130} \ + 1.0000000000000001e-130 +test util-16.1.17.-129 {8.4 compatible formatting of doubles} \ + {expr 1e-129} \ + 9.9999999999999993e-130 +test util-16.1.17.-128 {8.4 compatible formatting of doubles} \ + {expr 1e-128} \ + 1.0000000000000001e-128 +test util-16.1.17.-127 {8.4 compatible formatting of doubles} \ + {expr 1e-127} \ + 1e-127 +test util-16.1.17.-126 {8.4 compatible formatting of doubles} \ + {expr 1e-126} \ + 9.9999999999999995e-127 +test util-16.1.17.-125 {8.4 compatible formatting of doubles} \ + {expr 1e-125} \ + 1e-125 +test util-16.1.17.-124 {8.4 compatible formatting of doubles} \ + {expr 1e-124} \ + 9.9999999999999993e-125 +test util-16.1.17.-123 {8.4 compatible formatting of doubles} \ + {expr 1e-123} \ + 1.0000000000000001e-123 +test util-16.1.17.-122 {8.4 compatible formatting of doubles} \ + {expr 1e-122} \ + 1.0000000000000001e-122 +test util-16.1.17.-121 {8.4 compatible formatting of doubles} \ + {expr 1e-121} \ + 9.9999999999999998e-122 +test util-16.1.17.-120 {8.4 compatible formatting of doubles} \ + {expr 1e-120} \ + 9.9999999999999998e-121 +test util-16.1.17.-119 {8.4 compatible formatting of doubles} \ + {expr 1e-119} \ + 1e-119 +test util-16.1.17.-118 {8.4 compatible formatting of doubles} \ + {expr 1e-118} \ + 9.9999999999999999e-119 +test util-16.1.17.-117 {8.4 compatible formatting of doubles} \ + {expr 1e-117} \ + 1e-117 +test util-16.1.17.-116 {8.4 compatible formatting of doubles} \ + {expr 1e-116} \ + 9.9999999999999999e-117 +test util-16.1.17.-115 {8.4 compatible formatting of doubles} \ + {expr 1e-115} \ + 1.0000000000000001e-115 +test util-16.1.17.-114 {8.4 compatible formatting of doubles} \ + {expr 1e-114} \ + 1.0000000000000001e-114 +test util-16.1.17.-113 {8.4 compatible formatting of doubles} \ + {expr 1e-113} \ + 9.9999999999999998e-114 +test util-16.1.17.-112 {8.4 compatible formatting of doubles} \ + {expr 1e-112} \ + 9.9999999999999995e-113 +test util-16.1.17.-111 {8.4 compatible formatting of doubles} \ + {expr 1e-111} \ + 1.0000000000000001e-111 +test util-16.1.17.-110 {8.4 compatible formatting of doubles} \ + {expr 1e-110} \ + 1.0000000000000001e-110 +test util-16.1.17.-109 {8.4 compatible formatting of doubles} \ + {expr 1e-109} \ + 9.9999999999999999e-110 +test util-16.1.17.-108 {8.4 compatible formatting of doubles} \ + {expr 1e-108} \ + 1e-108 +test util-16.1.17.-107 {8.4 compatible formatting of doubles} \ + {expr 1e-107} \ + 1e-107 +test util-16.1.17.-106 {8.4 compatible formatting of doubles} \ + {expr 1e-106} \ + 9.9999999999999994e-107 +test util-16.1.17.-105 {8.4 compatible formatting of doubles} \ + {expr 1e-105} \ + 9.9999999999999997e-106 +test util-16.1.17.-104 {8.4 compatible formatting of doubles} \ + {expr 1e-104} \ + 9.9999999999999993e-105 +test util-16.1.17.-103 {8.4 compatible formatting of doubles} \ + {expr 1e-103} \ + 9.9999999999999996e-104 +test util-16.1.17.-102 {8.4 compatible formatting of doubles} \ + {expr 1e-102} \ + 9.9999999999999993e-103 +test util-16.1.17.-101 {8.4 compatible formatting of doubles} \ + {expr 1e-101} \ + 1.0000000000000001e-101 +test util-16.1.17.-100 {8.4 compatible formatting of doubles} \ + {expr 1e-100} \ + 1e-100 +test util-16.1.17.-99 {8.4 compatible formatting of doubles} \ + {expr 1e-99} \ + 1e-99 +test util-16.1.17.-98 {8.4 compatible formatting of doubles} \ + {expr 1e-98} \ + 9.9999999999999994e-99 +test util-16.1.17.-97 {8.4 compatible formatting of doubles} \ + {expr 1e-97} \ + 1e-97 +test util-16.1.17.-96 {8.4 compatible formatting of doubles} \ + {expr 1e-96} \ + 9.9999999999999991e-97 +test util-16.1.17.-95 {8.4 compatible formatting of doubles} \ + {expr 1e-95} \ + 9.9999999999999999e-96 +test util-16.1.17.-94 {8.4 compatible formatting of doubles} \ + {expr 1e-94} \ + 9.9999999999999996e-95 +test util-16.1.17.-93 {8.4 compatible formatting of doubles} \ + {expr 1e-93} \ + 9.999999999999999e-94 +test util-16.1.17.-92 {8.4 compatible formatting of doubles} \ + {expr 1e-92} \ + 9.9999999999999999e-93 +test util-16.1.17.-91 {8.4 compatible formatting of doubles} \ + {expr 1e-91} \ + 1e-91 +test util-16.1.17.-90 {8.4 compatible formatting of doubles} \ + {expr 1e-90} \ + 9.9999999999999999e-91 +test util-16.1.17.-89 {8.4 compatible formatting of doubles} \ + {expr 1e-89} \ + 1e-89 +test util-16.1.17.-88 {8.4 compatible formatting of doubles} \ + {expr 1e-88} \ + 9.9999999999999993e-89 +test util-16.1.17.-87 {8.4 compatible formatting of doubles} \ + {expr 1e-87} \ + 1e-87 +test util-16.1.17.-86 {8.4 compatible formatting of doubles} \ + {expr 1e-86} \ + 1.0000000000000001e-86 +test util-16.1.17.-85 {8.4 compatible formatting of doubles} \ + {expr 1e-85} \ + 9.9999999999999998e-86 +test util-16.1.17.-84 {8.4 compatible formatting of doubles} \ + {expr 1e-84} \ + 1e-84 +test util-16.1.17.-83 {8.4 compatible formatting of doubles} \ + {expr 1e-83} \ + 1e-83 +test util-16.1.17.-82 {8.4 compatible formatting of doubles} \ + {expr 1e-82} \ + 9.9999999999999996e-83 +test util-16.1.17.-81 {8.4 compatible formatting of doubles} \ + {expr 1e-81} \ + 9.9999999999999996e-82 +test util-16.1.17.-80 {8.4 compatible formatting of doubles} \ + {expr 1e-80} \ + 9.9999999999999996e-81 +test util-16.1.17.-79 {8.4 compatible formatting of doubles} \ + {expr 1e-79} \ + 1e-79 +test util-16.1.17.-78 {8.4 compatible formatting of doubles} \ + {expr 1e-78} \ + 1e-78 +test util-16.1.17.-77 {8.4 compatible formatting of doubles} \ + {expr 1e-77} \ + 9.9999999999999993e-78 +test util-16.1.17.-76 {8.4 compatible formatting of doubles} \ + {expr 1e-76} \ + 9.9999999999999993e-77 +test util-16.1.17.-75 {8.4 compatible formatting of doubles} \ + {expr 1e-75} \ + 9.9999999999999996e-76 +test util-16.1.17.-74 {8.4 compatible formatting of doubles} \ + {expr 1e-74} \ + 9.9999999999999996e-75 +test util-16.1.17.-73 {8.4 compatible formatting of doubles} \ + {expr 1e-73} \ + 1e-73 +test util-16.1.17.-72 {8.4 compatible formatting of doubles} \ + {expr 1e-72} \ + 9.9999999999999997e-73 +test util-16.1.17.-71 {8.4 compatible formatting of doubles} \ + {expr 1e-71} \ + 9.9999999999999992e-72 +test util-16.1.17.-70 {8.4 compatible formatting of doubles} \ + {expr 1e-70} \ + 1e-70 +test util-16.1.17.-69 {8.4 compatible formatting of doubles} \ + {expr 1e-69} \ + 9.9999999999999996e-70 +test util-16.1.17.-68 {8.4 compatible formatting of doubles} \ + {expr 1e-68} \ + 1.0000000000000001e-68 +test util-16.1.17.-67 {8.4 compatible formatting of doubles} \ + {expr 1e-67} \ + 9.9999999999999994e-68 +test util-16.1.17.-66 {8.4 compatible formatting of doubles} \ + {expr 1e-66} \ + 9.9999999999999998e-67 +test util-16.1.17.-65 {8.4 compatible formatting of doubles} \ + {expr 1e-65} \ + 9.9999999999999992e-66 +test util-16.1.17.-64 {8.4 compatible formatting of doubles} \ + {expr 1e-64} \ + 9.9999999999999997e-65 +test util-16.1.17.-63 {8.4 compatible formatting of doubles} \ + {expr 1e-63} \ + 1.0000000000000001e-63 +test util-16.1.17.-62 {8.4 compatible formatting of doubles} \ + {expr 1e-62} \ + 1e-62 +test util-16.1.17.-61 {8.4 compatible formatting of doubles} \ + {expr 1e-61} \ + 1e-61 +test util-16.1.17.-60 {8.4 compatible formatting of doubles} \ + {expr 1e-60} \ + 9.9999999999999997e-61 +test util-16.1.17.-59 {8.4 compatible formatting of doubles} \ + {expr 1e-59} \ + 1e-59 +test util-16.1.17.-58 {8.4 compatible formatting of doubles} \ + {expr 1e-58} \ + 1e-58 +test util-16.1.17.-57 {8.4 compatible formatting of doubles} \ + {expr 1e-57} \ + 9.9999999999999995e-58 +test util-16.1.17.-56 {8.4 compatible formatting of doubles} \ + {expr 1e-56} \ + 1e-56 +test util-16.1.17.-55 {8.4 compatible formatting of doubles} \ + {expr 1e-55} \ + 9.9999999999999999e-56 +test util-16.1.17.-54 {8.4 compatible formatting of doubles} \ + {expr 1e-54} \ + 1e-54 +test util-16.1.17.-53 {8.4 compatible formatting of doubles} \ + {expr 1e-53} \ + 1e-53 +test util-16.1.17.-52 {8.4 compatible formatting of doubles} \ + {expr 1e-52} \ + 1e-52 +test util-16.1.17.-51 {8.4 compatible formatting of doubles} \ + {expr 1e-51} \ + 1e-51 +test util-16.1.17.-50 {8.4 compatible formatting of doubles} \ + {expr 1e-50} \ + 1e-50 +test util-16.1.17.-49 {8.4 compatible formatting of doubles} \ + {expr 1e-49} \ + 9.9999999999999994e-50 +test util-16.1.17.-48 {8.4 compatible formatting of doubles} \ + {expr 1e-48} \ + 9.9999999999999997e-49 +test util-16.1.17.-47 {8.4 compatible formatting of doubles} \ + {expr 1e-47} \ + 9.9999999999999997e-48 +test util-16.1.17.-46 {8.4 compatible formatting of doubles} \ + {expr 1e-46} \ + 1e-46 +test util-16.1.17.-45 {8.4 compatible formatting of doubles} \ + {expr 1e-45} \ + 9.9999999999999998e-46 +test util-16.1.17.-44 {8.4 compatible formatting of doubles} \ + {expr 1e-44} \ + 9.9999999999999995e-45 +test util-16.1.17.-43 {8.4 compatible formatting of doubles} \ + {expr 1e-43} \ + 1.0000000000000001e-43 +test util-16.1.17.-42 {8.4 compatible formatting of doubles} \ + {expr 1e-42} \ + 1e-42 +test util-16.1.17.-41 {8.4 compatible formatting of doubles} \ + {expr 1e-41} \ + 1e-41 +test util-16.1.17.-40 {8.4 compatible formatting of doubles} \ + {expr 1e-40} \ + 9.9999999999999993e-41 +test util-16.1.17.-39 {8.4 compatible formatting of doubles} \ + {expr 1e-39} \ + 9.9999999999999993e-40 +test util-16.1.17.-38 {8.4 compatible formatting of doubles} \ + {expr 1e-38} \ + 9.9999999999999996e-39 +test util-16.1.17.-37 {8.4 compatible formatting of doubles} \ + {expr 1e-37} \ + 1.0000000000000001e-37 +test util-16.1.17.-36 {8.4 compatible formatting of doubles} \ + {expr 1e-36} \ + 9.9999999999999994e-37 +test util-16.1.17.-35 {8.4 compatible formatting of doubles} \ + {expr 1e-35} \ + 1e-35 +test util-16.1.17.-34 {8.4 compatible formatting of doubles} \ + {expr 1e-34} \ + 9.9999999999999993e-35 +test util-16.1.17.-33 {8.4 compatible formatting of doubles} \ + {expr 1e-33} \ + 1.0000000000000001e-33 +test util-16.1.17.-32 {8.4 compatible formatting of doubles} \ + {expr 1e-32} \ + 1.0000000000000001e-32 +test util-16.1.17.-31 {8.4 compatible formatting of doubles} \ + {expr 1e-31} \ + 1.0000000000000001e-31 +test util-16.1.17.-30 {8.4 compatible formatting of doubles} \ + {expr 1e-30} \ + 1.0000000000000001e-30 +test util-16.1.17.-29 {8.4 compatible formatting of doubles} \ + {expr 1e-29} \ + 9.9999999999999994e-30 +test util-16.1.17.-28 {8.4 compatible formatting of doubles} \ + {expr 1e-28} \ + 9.9999999999999997e-29 +test util-16.1.17.-27 {8.4 compatible formatting of doubles} \ + {expr 1e-27} \ + 1e-27 +test util-16.1.17.-26 {8.4 compatible formatting of doubles} \ + {expr 1e-26} \ + 1e-26 +test util-16.1.17.-25 {8.4 compatible formatting of doubles} \ + {expr 1e-25} \ + 1e-25 +test util-16.1.17.-24 {8.4 compatible formatting of doubles} \ + {expr 1e-24} \ + 9.9999999999999992e-25 +test util-16.1.17.-23 {8.4 compatible formatting of doubles} \ + {expr 1e-23} \ + 9.9999999999999996e-24 +test util-16.1.17.-22 {8.4 compatible formatting of doubles} \ + {expr 1e-22} \ + 1e-22 +test util-16.1.17.-21 {8.4 compatible formatting of doubles} \ + {expr 1e-21} \ + 9.9999999999999991e-22 +test util-16.1.17.-20 {8.4 compatible formatting of doubles} \ + {expr 1e-20} \ + 9.9999999999999995e-21 +test util-16.1.17.-19 {8.4 compatible formatting of doubles} \ + {expr 1e-19} \ + 9.9999999999999998e-20 +test util-16.1.17.-18 {8.4 compatible formatting of doubles} \ + {expr 1e-18} \ + 1.0000000000000001e-18 +test util-16.1.17.-17 {8.4 compatible formatting of doubles} \ + {expr 1e-17} \ + 1.0000000000000001e-17 +test util-16.1.17.-16 {8.4 compatible formatting of doubles} \ + {expr 1e-16} \ + 9.9999999999999998e-17 +test util-16.1.17.-15 {8.4 compatible formatting of doubles} \ + {expr 1e-15} \ + 1.0000000000000001e-15 +test util-16.1.17.-14 {8.4 compatible formatting of doubles} \ + {expr 1e-14} \ + 1e-14 +test util-16.1.17.-13 {8.4 compatible formatting of doubles} \ + {expr 1e-13} \ + 1e-13 +test util-16.1.17.-12 {8.4 compatible formatting of doubles} \ + {expr 1e-12} \ + 9.9999999999999998e-13 +test util-16.1.17.-11 {8.4 compatible formatting of doubles} \ + {expr 1e-11} \ + 9.9999999999999994e-12 +test util-16.1.17.-10 {8.4 compatible formatting of doubles} \ + {expr 1e-10} \ + 1e-10 +test util-16.1.17.-9 {8.4 compatible formatting of doubles} \ + {expr 1e-9} \ + 1.0000000000000001e-09 +test util-16.1.17.-8 {8.4 compatible formatting of doubles} \ + {expr 1e-8} \ + 1e-08 +test util-16.1.17.-7 {8.4 compatible formatting of doubles} \ + {expr 1e-7} \ + 9.9999999999999995e-08 +test util-16.1.17.-6 {8.4 compatible formatting of doubles} \ + {expr 1e-6} \ + 9.9999999999999995e-07 +test util-16.1.17.-5 {8.4 compatible formatting of doubles} \ + {expr 1e-5} \ + 1.0000000000000001e-05 +test util-16.1.17.-4 {8.4 compatible formatting of doubles} \ + {expr 1e-4} \ + 0.0001 +test util-16.1.17.-3 {8.4 compatible formatting of doubles} \ + {expr 1e-3} \ + 0.001 +test util-16.1.17.-2 {8.4 compatible formatting of doubles} \ + {expr 1e-2} \ + 0.01 +test util-16.1.17.-1 {8.4 compatible formatting of doubles} \ + {expr 1e-1} \ + 0.10000000000000001 +test util-16.1.17.0 {8.4 compatible formatting of doubles} \ + {expr 1e0} \ + 1.0 +test util-16.1.17.1 {8.4 compatible formatting of doubles} \ + {expr 1e1} \ + 10.0 +test util-16.1.17.2 {8.4 compatible formatting of doubles} \ + {expr 1e2} \ + 100.0 +test util-16.1.17.3 {8.4 compatible formatting of doubles} \ + {expr 1e3} \ + 1000.0 +test util-16.1.17.4 {8.4 compatible formatting of doubles} \ + {expr 1e4} \ + 10000.0 +test util-16.1.17.5 {8.4 compatible formatting of doubles} \ + {expr 1e5} \ + 100000.0 +test util-16.1.17.6 {8.4 compatible formatting of doubles} \ + {expr 1e6} \ + 1000000.0 +test util-16.1.17.7 {8.4 compatible formatting of doubles} \ + {expr 1e7} \ + 10000000.0 +test util-16.1.17.8 {8.4 compatible formatting of doubles} \ + {expr 1e8} \ + 100000000.0 +test util-16.1.17.9 {8.4 compatible formatting of doubles} \ + {expr 1e9} \ + 1000000000.0 +test util-16.1.17.10 {8.4 compatible formatting of doubles} \ + {expr 1e10} \ + 10000000000.0 +test util-16.1.17.11 {8.4 compatible formatting of doubles} \ + {expr 1e11} \ + 100000000000.0 +test util-16.1.17.12 {8.4 compatible formatting of doubles} \ + {expr 1e12} \ + 1000000000000.0 +test util-16.1.17.13 {8.4 compatible formatting of doubles} \ + {expr 1e13} \ + 10000000000000.0 +test util-16.1.17.14 {8.4 compatible formatting of doubles} \ + {expr 1e14} \ + 100000000000000.0 +test util-16.1.17.15 {8.4 compatible formatting of doubles} \ + {expr 1e15} \ + 1000000000000000.0 +test util-16.1.17.16 {8.4 compatible formatting of doubles} \ + {expr 1e16} \ + 10000000000000000.0 +test util-16.1.17.17 {8.4 compatible formatting of doubles} \ + {expr 1e17} \ + 1e+17 +test util-16.1.17.18 {8.4 compatible formatting of doubles} \ + {expr 1e18} \ + 1e+18 +test util-16.1.17.19 {8.4 compatible formatting of doubles} \ + {expr 1e19} \ + 1e+19 +test util-16.1.17.20 {8.4 compatible formatting of doubles} \ + {expr 1e20} \ + 1e+20 +test util-16.1.17.21 {8.4 compatible formatting of doubles} \ + {expr 1e21} \ + 1e+21 +test util-16.1.17.22 {8.4 compatible formatting of doubles} \ + {expr 1e22} \ + 1e+22 +test util-16.1.17.23 {8.4 compatible formatting of doubles} \ + {expr 1e23} \ + 9.9999999999999992e+22 +test util-16.1.17.24 {8.4 compatible formatting of doubles} \ + {expr 1e24} \ + 9.9999999999999998e+23 +test util-16.1.17.25 {8.4 compatible formatting of doubles} \ + {expr 1e25} \ + 1.0000000000000001e+25 +test util-16.1.17.26 {8.4 compatible formatting of doubles} \ + {expr 1e26} \ + 1e+26 +test util-16.1.17.27 {8.4 compatible formatting of doubles} \ + {expr 1e27} \ + 1e+27 +test util-16.1.17.28 {8.4 compatible formatting of doubles} \ + {expr 1e28} \ + 9.9999999999999996e+27 +test util-16.1.17.29 {8.4 compatible formatting of doubles} \ + {expr 1e29} \ + 9.9999999999999991e+28 +test util-16.1.17.30 {8.4 compatible formatting of doubles} \ + {expr 1e30} \ + 1e+30 +test util-16.1.17.31 {8.4 compatible formatting of doubles} \ + {expr 1e31} \ + 9.9999999999999996e+30 +test util-16.1.17.32 {8.4 compatible formatting of doubles} \ + {expr 1e32} \ + 1.0000000000000001e+32 +test util-16.1.17.33 {8.4 compatible formatting of doubles} \ + {expr 1e33} \ + 9.9999999999999995e+32 +test util-16.1.17.34 {8.4 compatible formatting of doubles} \ + {expr 1e34} \ + 9.9999999999999995e+33 +test util-16.1.17.35 {8.4 compatible formatting of doubles} \ + {expr 1e35} \ + 9.9999999999999997e+34 +test util-16.1.17.36 {8.4 compatible formatting of doubles} \ + {expr 1e36} \ + 1e+36 +test util-16.1.17.37 {8.4 compatible formatting of doubles} \ + {expr 1e37} \ + 9.9999999999999995e+36 +test util-16.1.17.38 {8.4 compatible formatting of doubles} \ + {expr 1e38} \ + 9.9999999999999998e+37 +test util-16.1.17.39 {8.4 compatible formatting of doubles} \ + {expr 1e39} \ + 9.9999999999999994e+38 +test util-16.1.17.40 {8.4 compatible formatting of doubles} \ + {expr 1e40} \ + 1e+40 +test util-16.1.17.41 {8.4 compatible formatting of doubles} \ + {expr 1e41} \ + 1e+41 +test util-16.1.17.42 {8.4 compatible formatting of doubles} \ + {expr 1e42} \ + 1e+42 +test util-16.1.17.43 {8.4 compatible formatting of doubles} \ + {expr 1e43} \ + 1e+43 +test util-16.1.17.44 {8.4 compatible formatting of doubles} \ + {expr 1e44} \ + 1.0000000000000001e+44 +test util-16.1.17.45 {8.4 compatible formatting of doubles} \ + {expr 1e45} \ + 9.9999999999999993e+44 +test util-16.1.17.46 {8.4 compatible formatting of doubles} \ + {expr 1e46} \ + 9.9999999999999999e+45 +test util-16.1.17.47 {8.4 compatible formatting of doubles} \ + {expr 1e47} \ + 1e+47 +test util-16.1.17.48 {8.4 compatible formatting of doubles} \ + {expr 1e48} \ + 1e+48 +test util-16.1.17.49 {8.4 compatible formatting of doubles} \ + {expr 1e49} \ + 9.9999999999999995e+48 +test util-16.1.17.50 {8.4 compatible formatting of doubles} \ + {expr 1e50} \ + 1.0000000000000001e+50 +test util-16.1.17.51 {8.4 compatible formatting of doubles} \ + {expr 1e51} \ + 9.9999999999999999e+50 +test util-16.1.17.52 {8.4 compatible formatting of doubles} \ + {expr 1e52} \ + 9.9999999999999999e+51 +test util-16.1.17.53 {8.4 compatible formatting of doubles} \ + {expr 1e53} \ + 9.9999999999999999e+52 +test util-16.1.17.54 {8.4 compatible formatting of doubles} \ + {expr 1e54} \ + 1.0000000000000001e+54 +test util-16.1.17.55 {8.4 compatible formatting of doubles} \ + {expr 1e55} \ + 1e+55 +test util-16.1.17.56 {8.4 compatible formatting of doubles} \ + {expr 1e56} \ + 1.0000000000000001e+56 +test util-16.1.17.57 {8.4 compatible formatting of doubles} \ + {expr 1e57} \ + 1e+57 +test util-16.1.17.58 {8.4 compatible formatting of doubles} \ + {expr 1e58} \ + 9.9999999999999994e+57 +test util-16.1.17.59 {8.4 compatible formatting of doubles} \ + {expr 1e59} \ + 9.9999999999999997e+58 +test util-16.1.17.60 {8.4 compatible formatting of doubles} \ + {expr 1e60} \ + 9.9999999999999995e+59 +test util-16.1.17.61 {8.4 compatible formatting of doubles} \ + {expr 1e61} \ + 9.9999999999999995e+60 +test util-16.1.17.62 {8.4 compatible formatting of doubles} \ + {expr 1e62} \ + 1e+62 +test util-16.1.17.63 {8.4 compatible formatting of doubles} \ + {expr 1e63} \ + 1.0000000000000001e+63 +test util-16.1.17.64 {8.4 compatible formatting of doubles} \ + {expr 1e64} \ + 1e+64 +test util-16.1.17.65 {8.4 compatible formatting of doubles} \ + {expr 1e65} \ + 9.9999999999999999e+64 +test util-16.1.17.66 {8.4 compatible formatting of doubles} \ + {expr 1e66} \ + 9.9999999999999995e+65 +test util-16.1.17.67 {8.4 compatible formatting of doubles} \ + {expr 1e67} \ + 9.9999999999999998e+66 +test util-16.1.17.68 {8.4 compatible formatting of doubles} \ + {expr 1e68} \ + 9.9999999999999995e+67 +test util-16.1.17.69 {8.4 compatible formatting of doubles} \ + {expr 1e69} \ + 1.0000000000000001e+69 +test util-16.1.17.70 {8.4 compatible formatting of doubles} \ + {expr 1e70} \ + 1.0000000000000001e+70 +test util-16.1.17.71 {8.4 compatible formatting of doubles} \ + {expr 1e71} \ + 1e+71 +test util-16.1.17.72 {8.4 compatible formatting of doubles} \ + {expr 1e72} \ + 9.9999999999999994e+71 +test util-16.1.17.73 {8.4 compatible formatting of doubles} \ + {expr 1e73} \ + 9.9999999999999998e+72 +test util-16.1.17.74 {8.4 compatible formatting of doubles} \ + {expr 1e74} \ + 9.9999999999999995e+73 +test util-16.1.17.75 {8.4 compatible formatting of doubles} \ + {expr 1e75} \ + 9.9999999999999993e+74 +test util-16.1.17.76 {8.4 compatible formatting of doubles} \ + {expr 1e76} \ + 1e+76 +test util-16.1.17.77 {8.4 compatible formatting of doubles} \ + {expr 1e77} \ + 9.9999999999999998e+76 +test util-16.1.17.78 {8.4 compatible formatting of doubles} \ + {expr 1e78} \ + 1e+78 +test util-16.1.17.79 {8.4 compatible formatting of doubles} \ + {expr 1e79} \ + 9.9999999999999997e+78 +test util-16.1.17.80 {8.4 compatible formatting of doubles} \ + {expr 1e80} \ + 1e+80 +test util-16.1.17.81 {8.4 compatible formatting of doubles} \ + {expr 1e81} \ + 9.9999999999999992e+80 +test util-16.1.17.82 {8.4 compatible formatting of doubles} \ + {expr 1e82} \ + 9.9999999999999996e+81 +test util-16.1.17.83 {8.4 compatible formatting of doubles} \ + {expr 1e83} \ + 1e+83 +test util-16.1.17.84 {8.4 compatible formatting of doubles} \ + {expr 1e84} \ + 1.0000000000000001e+84 +test util-16.1.17.85 {8.4 compatible formatting of doubles} \ + {expr 1e85} \ + 1e+85 +test util-16.1.17.86 {8.4 compatible formatting of doubles} \ + {expr 1e86} \ + 1e+86 +test util-16.1.17.87 {8.4 compatible formatting of doubles} \ + {expr 1e87} \ + 9.9999999999999996e+86 +test util-16.1.17.88 {8.4 compatible formatting of doubles} \ + {expr 1e88} \ + 9.9999999999999996e+87 +test util-16.1.17.89 {8.4 compatible formatting of doubles} \ + {expr 1e89} \ + 9.9999999999999999e+88 +test util-16.1.17.90 {8.4 compatible formatting of doubles} \ + {expr 1e90} \ + 9.9999999999999997e+89 +test util-16.1.17.91 {8.4 compatible formatting of doubles} \ + {expr 1e91} \ + 1.0000000000000001e+91 +test util-16.1.17.92 {8.4 compatible formatting of doubles} \ + {expr 1e92} \ + 1e+92 +test util-16.1.17.93 {8.4 compatible formatting of doubles} \ + {expr 1e93} \ + 1e+93 +test util-16.1.17.94 {8.4 compatible formatting of doubles} \ + {expr 1e94} \ + 1e+94 +test util-16.1.17.95 {8.4 compatible formatting of doubles} \ + {expr 1e95} \ + 1e+95 +test util-16.1.17.96 {8.4 compatible formatting of doubles} \ + {expr 1e96} \ + 1e+96 +test util-16.1.17.97 {8.4 compatible formatting of doubles} \ + {expr 1e97} \ + 1.0000000000000001e+97 +test util-16.1.17.98 {8.4 compatible formatting of doubles} \ + {expr 1e98} \ + 1e+98 +test util-16.1.17.99 {8.4 compatible formatting of doubles} \ + {expr 1e99} \ + 9.9999999999999997e+98 +test util-16.1.17.100 {8.4 compatible formatting of doubles} \ + {expr 1e100} \ + 1e+100 +test util-16.1.17.101 {8.4 compatible formatting of doubles} \ + {expr 1e101} \ + 9.9999999999999998e+100 +test util-16.1.17.102 {8.4 compatible formatting of doubles} \ + {expr 1e102} \ + 9.9999999999999998e+101 +test util-16.1.17.103 {8.4 compatible formatting of doubles} \ + {expr 1e103} \ + 1e+103 +test util-16.1.17.104 {8.4 compatible formatting of doubles} \ + {expr 1e104} \ + 1e+104 +test util-16.1.17.105 {8.4 compatible formatting of doubles} \ + {expr 1e105} \ + 9.9999999999999994e+104 +test util-16.1.17.106 {8.4 compatible formatting of doubles} \ + {expr 1e106} \ + 1.0000000000000001e+106 +test util-16.1.17.107 {8.4 compatible formatting of doubles} \ + {expr 1e107} \ + 9.9999999999999997e+106 +test util-16.1.17.108 {8.4 compatible formatting of doubles} \ + {expr 1e108} \ + 1e+108 +test util-16.1.17.109 {8.4 compatible formatting of doubles} \ + {expr 1e109} \ + 9.9999999999999998e+108 +test util-16.1.17.110 {8.4 compatible formatting of doubles} \ + {expr 1e110} \ + 1e+110 +test util-16.1.17.111 {8.4 compatible formatting of doubles} \ + {expr 1e111} \ + 9.9999999999999996e+110 +test util-16.1.17.112 {8.4 compatible formatting of doubles} \ + {expr 1e112} \ + 9.9999999999999993e+111 +test util-16.1.17.113 {8.4 compatible formatting of doubles} \ + {expr 1e113} \ + 1e+113 +test util-16.1.17.114 {8.4 compatible formatting of doubles} \ + {expr 1e114} \ + 1e+114 +test util-16.1.17.115 {8.4 compatible formatting of doubles} \ + {expr 1e115} \ + 1e+115 +test util-16.1.17.116 {8.4 compatible formatting of doubles} \ + {expr 1e116} \ + 1e+116 +test util-16.1.17.117 {8.4 compatible formatting of doubles} \ + {expr 1e117} \ + 1.0000000000000001e+117 +test util-16.1.17.118 {8.4 compatible formatting of doubles} \ + {expr 1e118} \ + 9.9999999999999997e+117 +test util-16.1.17.119 {8.4 compatible formatting of doubles} \ + {expr 1e119} \ + 9.9999999999999994e+118 +test util-16.1.17.120 {8.4 compatible formatting of doubles} \ + {expr 1e120} \ + 9.9999999999999998e+119 +test util-16.1.17.121 {8.4 compatible formatting of doubles} \ + {expr 1e121} \ + 1e+121 +test util-16.1.17.122 {8.4 compatible formatting of doubles} \ + {expr 1e122} \ + 1e+122 +test util-16.1.17.123 {8.4 compatible formatting of doubles} \ + {expr 1e123} \ + 9.9999999999999998e+122 +test util-16.1.17.124 {8.4 compatible formatting of doubles} \ + {expr 1e124} \ + 9.9999999999999995e+123 +test util-16.1.17.125 {8.4 compatible formatting of doubles} \ + {expr 1e125} \ + 9.9999999999999992e+124 +test util-16.1.17.126 {8.4 compatible formatting of doubles} \ + {expr 1e126} \ + 9.9999999999999992e+125 +test util-16.1.17.127 {8.4 compatible formatting of doubles} \ + {expr 1e127} \ + 9.9999999999999995e+126 +test util-16.1.17.128 {8.4 compatible formatting of doubles} \ + {expr 1e128} \ + 1.0000000000000001e+128 +test util-16.1.17.129 {8.4 compatible formatting of doubles} \ + {expr 1e129} \ + 1e+129 +test util-16.1.17.130 {8.4 compatible formatting of doubles} \ + {expr 1e130} \ + 1.0000000000000001e+130 +test util-16.1.17.131 {8.4 compatible formatting of doubles} \ + {expr 1e131} \ + 9.9999999999999991e+130 +test util-16.1.17.132 {8.4 compatible formatting of doubles} \ + {expr 1e132} \ + 9.9999999999999999e+131 +test util-16.1.17.133 {8.4 compatible formatting of doubles} \ + {expr 1e133} \ + 1e+133 +test util-16.1.17.134 {8.4 compatible formatting of doubles} \ + {expr 1e134} \ + 9.9999999999999992e+133 +test util-16.1.17.135 {8.4 compatible formatting of doubles} \ + {expr 1e135} \ + 9.9999999999999996e+134 +test util-16.1.17.136 {8.4 compatible formatting of doubles} \ + {expr 1e136} \ + 1.0000000000000001e+136 +test util-16.1.17.137 {8.4 compatible formatting of doubles} \ + {expr 1e137} \ + 1e+137 +test util-16.1.17.138 {8.4 compatible formatting of doubles} \ + {expr 1e138} \ + 1e+138 +test util-16.1.17.139 {8.4 compatible formatting of doubles} \ + {expr 1e139} \ + 1e+139 +test util-16.1.17.140 {8.4 compatible formatting of doubles} \ + {expr 1e140} \ + 1.0000000000000001e+140 +test util-16.1.17.141 {8.4 compatible formatting of doubles} \ + {expr 1e141} \ + 1e+141 +test util-16.1.17.142 {8.4 compatible formatting of doubles} \ + {expr 1e142} \ + 1.0000000000000001e+142 +test util-16.1.17.143 {8.4 compatible formatting of doubles} \ + {expr 1e143} \ + 1e+143 +test util-16.1.17.144 {8.4 compatible formatting of doubles} \ + {expr 1e144} \ + 1e+144 +test util-16.1.17.145 {8.4 compatible formatting of doubles} \ + {expr 1e145} \ + 9.9999999999999999e+144 +test util-16.1.17.146 {8.4 compatible formatting of doubles} \ + {expr 1e146} \ + 9.9999999999999993e+145 +test util-16.1.17.147 {8.4 compatible formatting of doubles} \ + {expr 1e147} \ + 9.9999999999999998e+146 +test util-16.1.17.148 {8.4 compatible formatting of doubles} \ + {expr 1e148} \ + 1e+148 +test util-16.1.17.149 {8.4 compatible formatting of doubles} \ + {expr 1e149} \ + 1e+149 +test util-16.1.17.150 {8.4 compatible formatting of doubles} \ + {expr 1e150} \ + 9.9999999999999998e+149 +test util-16.1.17.151 {8.4 compatible formatting of doubles} \ + {expr 1e151} \ + 1e+151 +test util-16.1.17.152 {8.4 compatible formatting of doubles} \ + {expr 1e152} \ + 1e+152 +test util-16.1.17.153 {8.4 compatible formatting of doubles} \ + {expr 1e153} \ + 1e+153 +test util-16.1.17.154 {8.4 compatible formatting of doubles} \ + {expr 1e154} \ + 1e+154 +test util-16.1.17.155 {8.4 compatible formatting of doubles} \ + {expr 1e155} \ + 1e+155 +test util-16.1.17.156 {8.4 compatible formatting of doubles} \ + {expr 1e156} \ + 9.9999999999999998e+155 +test util-16.1.17.157 {8.4 compatible formatting of doubles} \ + {expr 1e157} \ + 9.9999999999999998e+156 +test util-16.1.17.158 {8.4 compatible formatting of doubles} \ + {expr 1e158} \ + 9.9999999999999995e+157 +test util-16.1.17.159 {8.4 compatible formatting of doubles} \ + {expr 1e159} \ + 9.9999999999999993e+158 +test util-16.1.17.160 {8.4 compatible formatting of doubles} \ + {expr 1e160} \ + 1e+160 +test util-16.1.17.161 {8.4 compatible formatting of doubles} \ + {expr 1e161} \ + 1e+161 +test util-16.1.17.162 {8.4 compatible formatting of doubles} \ + {expr 1e162} \ + 9.9999999999999994e+161 +test util-16.1.17.163 {8.4 compatible formatting of doubles} \ + {expr 1e163} \ + 9.9999999999999994e+162 +test util-16.1.17.164 {8.4 compatible formatting of doubles} \ + {expr 1e164} \ + 1e+164 +test util-16.1.17.165 {8.4 compatible formatting of doubles} \ + {expr 1e165} \ + 9.999999999999999e+164 +test util-16.1.17.166 {8.4 compatible formatting of doubles} \ + {expr 1e166} \ + 9.9999999999999994e+165 +test util-16.1.17.167 {8.4 compatible formatting of doubles} \ + {expr 1e167} \ + 1e+167 +test util-16.1.17.168 {8.4 compatible formatting of doubles} \ + {expr 1e168} \ + 9.9999999999999993e+167 +test util-16.1.17.169 {8.4 compatible formatting of doubles} \ + {expr 1e169} \ + 9.9999999999999993e+168 +test util-16.1.17.170 {8.4 compatible formatting of doubles} \ + {expr 1e170} \ + 1e+170 +test util-16.1.17.171 {8.4 compatible formatting of doubles} \ + {expr 1e171} \ + 9.9999999999999995e+170 +test util-16.1.17.172 {8.4 compatible formatting of doubles} \ + {expr 1e172} \ + 1.0000000000000001e+172 +test util-16.1.17.173 {8.4 compatible formatting of doubles} \ + {expr 1e173} \ + 1e+173 +test util-16.1.17.174 {8.4 compatible formatting of doubles} \ + {expr 1e174} \ + 1.0000000000000001e+174 +test util-16.1.17.175 {8.4 compatible formatting of doubles} \ + {expr 1e175} \ + 9.9999999999999994e+174 +test util-16.1.17.176 {8.4 compatible formatting of doubles} \ + {expr 1e176} \ + 1e+176 +test util-16.1.17.177 {8.4 compatible formatting of doubles} \ + {expr 1e177} \ + 1e+177 +test util-16.1.17.178 {8.4 compatible formatting of doubles} \ + {expr 1e178} \ + 1.0000000000000001e+178 +test util-16.1.17.179 {8.4 compatible formatting of doubles} \ + {expr 1e179} \ + 9.9999999999999998e+178 +test util-16.1.17.180 {8.4 compatible formatting of doubles} \ + {expr 1e180} \ + 1e+180 +test util-16.1.17.181 {8.4 compatible formatting of doubles} \ + {expr 1e181} \ + 9.9999999999999992e+180 +test util-16.1.17.182 {8.4 compatible formatting of doubles} \ + {expr 1e182} \ + 1.0000000000000001e+182 +test util-16.1.17.183 {8.4 compatible formatting of doubles} \ + {expr 1e183} \ + 9.9999999999999995e+182 +test util-16.1.17.184 {8.4 compatible formatting of doubles} \ + {expr 1e184} \ + 1e+184 +test util-16.1.17.185 {8.4 compatible formatting of doubles} \ + {expr 1e185} \ + 9.9999999999999998e+184 +test util-16.1.17.186 {8.4 compatible formatting of doubles} \ + {expr 1e186} \ + 9.9999999999999998e+185 +test util-16.1.17.187 {8.4 compatible formatting of doubles} \ + {expr 1e187} \ + 9.9999999999999991e+186 +test util-16.1.17.188 {8.4 compatible formatting of doubles} \ + {expr 1e188} \ + 1e+188 +test util-16.1.17.189 {8.4 compatible formatting of doubles} \ + {expr 1e189} \ + 1e+189 +test util-16.1.17.190 {8.4 compatible formatting of doubles} \ + {expr 1e190} \ + 1.0000000000000001e+190 +test util-16.1.17.191 {8.4 compatible formatting of doubles} \ + {expr 1e191} \ + 1.0000000000000001e+191 +test util-16.1.17.192 {8.4 compatible formatting of doubles} \ + {expr 1e192} \ + 1e+192 +test util-16.1.17.193 {8.4 compatible formatting of doubles} \ + {expr 1e193} \ + 1.0000000000000001e+193 +test util-16.1.17.194 {8.4 compatible formatting of doubles} \ + {expr 1e194} \ + 9.9999999999999994e+193 +test util-16.1.17.195 {8.4 compatible formatting of doubles} \ + {expr 1e195} \ + 9.9999999999999998e+194 +test util-16.1.17.196 {8.4 compatible formatting of doubles} \ + {expr 1e196} \ + 9.9999999999999995e+195 +test util-16.1.17.197 {8.4 compatible formatting of doubles} \ + {expr 1e197} \ + 9.9999999999999995e+196 +test util-16.1.17.198 {8.4 compatible formatting of doubles} \ + {expr 1e198} \ + 1e+198 +test util-16.1.17.199 {8.4 compatible formatting of doubles} \ + {expr 1e199} \ + 1.0000000000000001e+199 +test util-16.1.17.200 {8.4 compatible formatting of doubles} \ + {expr 1e200} \ + 9.9999999999999997e+199 +test util-16.1.17.201 {8.4 compatible formatting of doubles} \ + {expr 1e201} \ + 1e+201 +test util-16.1.17.202 {8.4 compatible formatting of doubles} \ + {expr 1e202} \ + 9.999999999999999e+201 +test util-16.1.17.203 {8.4 compatible formatting of doubles} \ + {expr 1e203} \ + 9.9999999999999999e+202 +test util-16.1.17.204 {8.4 compatible formatting of doubles} \ + {expr 1e204} \ + 9.9999999999999999e+203 +test util-16.1.17.205 {8.4 compatible formatting of doubles} \ + {expr 1e205} \ + 1e+205 +test util-16.1.17.206 {8.4 compatible formatting of doubles} \ + {expr 1e206} \ + 1e+206 +test util-16.1.17.207 {8.4 compatible formatting of doubles} \ + {expr 1e207} \ + 1e+207 +test util-16.1.17.208 {8.4 compatible formatting of doubles} \ + {expr 1e208} \ + 9.9999999999999998e+207 +test util-16.1.17.209 {8.4 compatible formatting of doubles} \ + {expr 1e209} \ + 1.0000000000000001e+209 +test util-16.1.17.210 {8.4 compatible formatting of doubles} \ + {expr 1e210} \ + 9.9999999999999993e+209 +test util-16.1.17.211 {8.4 compatible formatting of doubles} \ + {expr 1e211} \ + 9.9999999999999996e+210 +test util-16.1.17.212 {8.4 compatible formatting of doubles} \ + {expr 1e212} \ + 9.9999999999999991e+211 +test util-16.1.17.213 {8.4 compatible formatting of doubles} \ + {expr 1e213} \ + 9.9999999999999998e+212 +test util-16.1.17.214 {8.4 compatible formatting of doubles} \ + {expr 1e214} \ + 9.9999999999999995e+213 +test util-16.1.17.215 {8.4 compatible formatting of doubles} \ + {expr 1e215} \ + 9.9999999999999991e+214 +test util-16.1.17.216 {8.4 compatible formatting of doubles} \ + {expr 1e216} \ + 1e+216 +test util-16.1.17.217 {8.4 compatible formatting of doubles} \ + {expr 1e217} \ + 9.9999999999999996e+216 +test util-16.1.17.218 {8.4 compatible formatting of doubles} \ + {expr 1e218} \ + 1.0000000000000001e+218 +test util-16.1.17.219 {8.4 compatible formatting of doubles} \ + {expr 1e219} \ + 9.9999999999999997e+218 +test util-16.1.17.220 {8.4 compatible formatting of doubles} \ + {expr 1e220} \ + 1e+220 +test util-16.1.17.221 {8.4 compatible formatting of doubles} \ + {expr 1e221} \ + 1e+221 +test util-16.1.17.222 {8.4 compatible formatting of doubles} \ + {expr 1e222} \ + 1e+222 +test util-16.1.17.223 {8.4 compatible formatting of doubles} \ + {expr 1e223} \ + 1e+223 +test util-16.1.17.224 {8.4 compatible formatting of doubles} \ + {expr 1e224} \ + 9.9999999999999997e+223 +test util-16.1.17.225 {8.4 compatible formatting of doubles} \ + {expr 1e225} \ + 9.9999999999999993e+224 +test util-16.1.17.226 {8.4 compatible formatting of doubles} \ + {expr 1e226} \ + 9.9999999999999996e+225 +test util-16.1.17.227 {8.4 compatible formatting of doubles} \ + {expr 1e227} \ + 1.0000000000000001e+227 +test util-16.1.17.228 {8.4 compatible formatting of doubles} \ + {expr 1e228} \ + 9.9999999999999992e+227 +test util-16.1.17.229 {8.4 compatible formatting of doubles} \ + {expr 1e229} \ + 9.9999999999999999e+228 +test util-16.1.17.230 {8.4 compatible formatting of doubles} \ + {expr 1e230} \ + 1.0000000000000001e+230 +test util-16.1.17.231 {8.4 compatible formatting of doubles} \ + {expr 1e231} \ + 1.0000000000000001e+231 +test util-16.1.17.232 {8.4 compatible formatting of doubles} \ + {expr 1e232} \ + 1.0000000000000001e+232 +test util-16.1.17.233 {8.4 compatible formatting of doubles} \ + {expr 1e233} \ + 9.9999999999999997e+232 +test util-16.1.17.234 {8.4 compatible formatting of doubles} \ + {expr 1e234} \ + 1e+234 +test util-16.1.17.235 {8.4 compatible formatting of doubles} \ + {expr 1e235} \ + 1.0000000000000001e+235 +test util-16.1.17.236 {8.4 compatible formatting of doubles} \ + {expr 1e236} \ + 1.0000000000000001e+236 +test util-16.1.17.237 {8.4 compatible formatting of doubles} \ + {expr 1e237} \ + 9.9999999999999994e+236 +test util-16.1.17.238 {8.4 compatible formatting of doubles} \ + {expr 1e238} \ + 1e+238 +test util-16.1.17.239 {8.4 compatible formatting of doubles} \ + {expr 1e239} \ + 9.9999999999999999e+238 +test util-16.1.17.240 {8.4 compatible formatting of doubles} \ + {expr 1e240} \ + 1e+240 +test util-16.1.17.241 {8.4 compatible formatting of doubles} \ + {expr 1e241} \ + 1.0000000000000001e+241 +test util-16.1.17.242 {8.4 compatible formatting of doubles} \ + {expr 1e242} \ + 1.0000000000000001e+242 +test util-16.1.17.243 {8.4 compatible formatting of doubles} \ + {expr 1e243} \ + 1.0000000000000001e+243 +test util-16.1.17.244 {8.4 compatible formatting of doubles} \ + {expr 1e244} \ + 1.0000000000000001e+244 +test util-16.1.17.245 {8.4 compatible formatting of doubles} \ + {expr 1e245} \ + 1e+245 +test util-16.1.17.246 {8.4 compatible formatting of doubles} \ + {expr 1e246} \ + 1.0000000000000001e+246 +test util-16.1.17.247 {8.4 compatible formatting of doubles} \ + {expr 1e247} \ + 9.9999999999999995e+246 +test util-16.1.17.248 {8.4 compatible formatting of doubles} \ + {expr 1e248} \ + 1e+248 +test util-16.1.17.249 {8.4 compatible formatting of doubles} \ + {expr 1e249} \ + 9.9999999999999992e+248 +test util-16.1.17.250 {8.4 compatible formatting of doubles} \ + {expr 1e250} \ + 9.9999999999999992e+249 +test util-16.1.17.251 {8.4 compatible formatting of doubles} \ + {expr 1e251} \ + 1e+251 +test util-16.1.17.252 {8.4 compatible formatting of doubles} \ + {expr 1e252} \ + 1.0000000000000001e+252 +test util-16.1.17.253 {8.4 compatible formatting of doubles} \ + {expr 1e253} \ + 9.9999999999999994e+252 +test util-16.1.17.254 {8.4 compatible formatting of doubles} \ + {expr 1e254} \ + 9.9999999999999994e+253 +test util-16.1.17.255 {8.4 compatible formatting of doubles} \ + {expr 1e255} \ + 9.9999999999999999e+254 +test util-16.1.17.256 {8.4 compatible formatting of doubles} \ + {expr 1e256} \ + 1e+256 +test util-16.1.17.257 {8.4 compatible formatting of doubles} \ + {expr 1e257} \ + 1e+257 +test util-16.1.17.258 {8.4 compatible formatting of doubles} \ + {expr 1e258} \ + 1.0000000000000001e+258 +test util-16.1.17.259 {8.4 compatible formatting of doubles} \ + {expr 1e259} \ + 9.9999999999999993e+258 +test util-16.1.17.260 {8.4 compatible formatting of doubles} \ + {expr 1e260} \ + 1.0000000000000001e+260 +test util-16.1.17.261 {8.4 compatible formatting of doubles} \ + {expr 1e261} \ + 9.9999999999999993e+260 +test util-16.1.17.262 {8.4 compatible formatting of doubles} \ + {expr 1e262} \ + 1e+262 +test util-16.1.17.263 {8.4 compatible formatting of doubles} \ + {expr 1e263} \ + 1e+263 +test util-16.1.17.264 {8.4 compatible formatting of doubles} \ + {expr 1e264} \ + 1e+264 +test util-16.1.17.265 {8.4 compatible formatting of doubles} \ + {expr 1e265} \ + 1.0000000000000001e+265 +test util-16.1.17.266 {8.4 compatible formatting of doubles} \ + {expr 1e266} \ + 1e+266 +test util-16.1.17.267 {8.4 compatible formatting of doubles} \ + {expr 1e267} \ + 9.9999999999999997e+266 +test util-16.1.17.268 {8.4 compatible formatting of doubles} \ + {expr 1e268} \ + 9.9999999999999997e+267 +test util-16.1.17.269 {8.4 compatible formatting of doubles} \ + {expr 1e269} \ + 1e+269 +test util-16.1.17.270 {8.4 compatible formatting of doubles} \ + {expr 1e270} \ + 1e+270 +test util-16.1.17.271 {8.4 compatible formatting of doubles} \ + {expr 1e271} \ + 9.9999999999999995e+270 +test util-16.1.17.272 {8.4 compatible formatting of doubles} \ + {expr 1e272} \ + 1.0000000000000001e+272 +test util-16.1.17.273 {8.4 compatible formatting of doubles} \ + {expr 1e273} \ + 9.9999999999999995e+272 +test util-16.1.17.274 {8.4 compatible formatting of doubles} \ + {expr 1e274} \ + 9.9999999999999992e+273 +test util-16.1.17.275 {8.4 compatible formatting of doubles} \ + {expr 1e275} \ + 9.9999999999999996e+274 +test util-16.1.17.276 {8.4 compatible formatting of doubles} \ + {expr 1e276} \ + 1.0000000000000001e+276 +test util-16.1.17.277 {8.4 compatible formatting of doubles} \ + {expr 1e277} \ + 1e+277 +test util-16.1.17.278 {8.4 compatible formatting of doubles} \ + {expr 1e278} \ + 9.9999999999999996e+277 +test util-16.1.17.279 {8.4 compatible formatting of doubles} \ + {expr 1e279} \ + 1.0000000000000001e+279 +test util-16.1.17.280 {8.4 compatible formatting of doubles} \ + {expr 1e280} \ + 1e+280 +test util-16.1.17.281 {8.4 compatible formatting of doubles} \ + {expr 1e281} \ + 1e+281 +test util-16.1.17.282 {8.4 compatible formatting of doubles} \ + {expr 1e282} \ + 1e+282 +test util-16.1.17.283 {8.4 compatible formatting of doubles} \ + {expr 1e283} \ + 9.9999999999999996e+282 +test util-16.1.17.284 {8.4 compatible formatting of doubles} \ + {expr 1e284} \ + 1.0000000000000001e+284 +test util-16.1.17.285 {8.4 compatible formatting of doubles} \ + {expr 1e285} \ + 9.9999999999999998e+284 +test util-16.1.17.286 {8.4 compatible formatting of doubles} \ + {expr 1e286} \ + 1e+286 +test util-16.1.17.287 {8.4 compatible formatting of doubles} \ + {expr 1e287} \ + 1.0000000000000001e+287 +test util-16.1.17.288 {8.4 compatible formatting of doubles} \ + {expr 1e288} \ + 1e+288 +test util-16.1.17.289 {8.4 compatible formatting of doubles} \ + {expr 1e289} \ + 1.0000000000000001e+289 +test util-16.1.17.290 {8.4 compatible formatting of doubles} \ + {expr 1e290} \ + 1.0000000000000001e+290 +test util-16.1.17.291 {8.4 compatible formatting of doubles} \ + {expr 1e291} \ + 9.9999999999999996e+290 +test util-16.1.17.292 {8.4 compatible formatting of doubles} \ + {expr 1e292} \ + 1e+292 +test util-16.1.17.293 {8.4 compatible formatting of doubles} \ + {expr 1e293} \ + 9.9999999999999992e+292 +test util-16.1.17.294 {8.4 compatible formatting of doubles} \ + {expr 1e294} \ + 1.0000000000000001e+294 +test util-16.1.17.295 {8.4 compatible formatting of doubles} \ + {expr 1e295} \ + 9.9999999999999998e+294 +test util-16.1.17.296 {8.4 compatible formatting of doubles} \ + {expr 1e296} \ + 9.9999999999999998e+295 +test util-16.1.17.297 {8.4 compatible formatting of doubles} \ + {expr 1e297} \ + 1e+297 +test util-16.1.17.298 {8.4 compatible formatting of doubles} \ + {expr 1e298} \ + 9.9999999999999996e+297 +test util-16.1.17.299 {8.4 compatible formatting of doubles} \ + {expr 1e299} \ + 1.0000000000000001e+299 +test util-16.1.17.300 {8.4 compatible formatting of doubles} \ + {expr 1e300} \ + 1.0000000000000001e+300 +test util-16.1.17.301 {8.4 compatible formatting of doubles} \ + {expr 1e301} \ + 1.0000000000000001e+301 +test util-16.1.17.302 {8.4 compatible formatting of doubles} \ + {expr 1e302} \ + 1.0000000000000001e+302 +test util-16.1.17.303 {8.4 compatible formatting of doubles} \ + {expr 1e303} \ + 1e+303 +test util-16.1.17.304 {8.4 compatible formatting of doubles} \ + {expr 1e304} \ + 9.9999999999999994e+303 +test util-16.1.17.305 {8.4 compatible formatting of doubles} \ + {expr 1e305} \ + 9.9999999999999994e+304 +test util-16.1.17.306 {8.4 compatible formatting of doubles} \ + {expr 1e306} \ + 1e+306 +test util-16.1.17.307 {8.4 compatible formatting of doubles} \ + {expr 1e307} \ + 9.9999999999999999e+306 test util-17.1 {bankers' rounding [Bug 3349507]} {ieeeFloatingPoint} { set r {} foreach {input} { 0x1ffffffffffffc000 @@ -2132,60 +4058,14 @@ 0x43fffffffffffffe 0xc3fffffffffffffe 0x43ffffffffffffff 0xc3ffffffffffffff 0x4400000000000000 0xc400000000000000 }] -test util-18.1 {Tcl_ObjPrintf} {testprint} { - testprint %lld [expr 2**63-1] -} {9223372036854775807} - -test util-18.2 {Tcl_ObjPrintf} {testprint} { - testprint %I64d [expr 2**63-1] -} {9223372036854775807} - -test util-18.3 {Tcl_ObjPrintf} {testprint} { - testprint %qd [expr 2**63-1] -} {9223372036854775807} - -test util-18.4 {Tcl_ObjPrintf} {testprint} { - testprint %jd [expr 2**63-1] -} {9223372036854775807} - -test util-18.5 {Tcl_ObjPrintf} {testprint} { - testprint %lld [expr -2**63] -} {-9223372036854775808} - -test util-18.6 {Tcl_ObjPrintf} {testprint} { - testprint %I64d [expr -2**63] -} {-9223372036854775808} - -test util-18.7 {Tcl_ObjPrintf} {testprint} { - testprint %qd [expr -2**63] -} {-9223372036854775808} - -test util-18.8 {Tcl_ObjPrintf} {testprint} { - testprint %jd [expr -2**63] -} {-9223372036854775808} - -test util-18.9 {Tcl_ObjPrintf} {testprint} { - testprint "%I64d %I32d" [expr -2**63+2] -} {-9223372036854775806 2} - -test util-18.10 {Tcl_ObjPrintf} {testprint} { - testprint "%I64d %p" 65535 -} {65535 0xffff} - -test util-18.11 {Tcl_ObjPrintf} {testprint} { - testprint "%I64d %td" 65536 -} {65536 65536} - -test util-18.12 {Tcl_ObjPrintf} {testprint} { - testprint "%I64d %Id" 65537 -} {65537 65537} +set ::tcl_precision $saved_precision # cleanup ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: Index: tests/var.test ================================================================== --- tests/var.test +++ tests/var.test @@ -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. if {"::tcltest" ni [namespace children]} { - package require tcltest 2.2 + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -38,11 +38,10 @@ set end [getbytes] } return [expr {$end - $tmp}] } } - catch {rename p ""} catch {namespace delete test_ns_var} catch {unset xx} catch {unset x} @@ -267,15 +266,14 @@ set a 456 namespace eval test_ns_var { catch {unset ::test_ns_var::vv} proc p {} { # create namespace var vv linked to global a - testupvar 2 a {} vv namespace + testupvar 1 a {} vv namespace } p } - # Modified: that should create a global var according to the docs! list $test_ns_var::vv [set test_ns_var::vv 123] $a } -result {456 123 123} test var-3.5 {MakeUpvar, no call frame so my var will be in global :: ns} -setup { catch {unset aaaaa} catch {unset xxxxx} @@ -451,11 +449,11 @@ } -body { namespace eval test_ns_var { variable three 3 four 4 } list [lsort [info vars test_ns_var::*]] \ - [namespace eval test_ns_var {expr $three+$four}] + [namespace eval test_ns_var {expr {$three+$four}}] } -result [list [lsort {::test_ns_var::four ::test_ns_var::three ::test_ns_var::two ::test_ns_var::one}] 7] test var-7.5 {Tcl_VariableObjCmd, value for last var is optional} -setup { catch {unset a} catch {unset five} catch {unset six} @@ -463,11 +461,11 @@ set a "" set five 555 set six 666 namespace eval test_ns_var { variable five 5 six - lappend ::a $five + lappend a $five } lappend a $test_ns_var::five \ [set test_ns_var::six 6] [set test_ns_var::six] $six } -cleanup { catch {unset five} @@ -490,13 +488,13 @@ } -result {can't define "sev:::en": parent namespace doesn't exist} test var-7.8 {Tcl_VariableObjCmd, if var already exists and no value is given, leave value unchanged} { set a "" namespace eval test_ns_var { variable eight 8 - lappend ::a $eight + lappend a $eight variable eight - lappend ::a $eight + lappend a $eight } set a } {8 8} test var-7.9 {Tcl_VariableObjCmd, mark as namespace var so var persists until namespace is destroyed or var is unset} -setup { catch {namespace delete test_ns_var2} @@ -1016,10 +1014,13 @@ } -cleanup { rename linenumber {} } -result 1 test var-22.0 {leak in array element unset: Bug a3309d01db} -setup { + proc getbytes {} { + lindex [split [memory info] \n] 3 3 + } proc doit k { variable A set A($k) {} foreach n [array names A] { if {$n <= $k-1} { @@ -1035,23 +1036,27 @@ set end [getbytes] } set leakedBytes [expr {$end - $tmp}] } -cleanup { array unset A + rename getbytes {} rename doit {} } -result 0 test var-22.1 {leak in localVarName intrep: Bug 80304238ac} -setup { + proc getbytes {} { + lindex [split [memory info] \n] 3 3 + } proc doit {} { - interp create slave - slave eval { + interp create child + child eval { proc doit script { eval $script set foo bar } doit {foreach foo baz {}} } - interp delete slave + interp delete child } } -constraints memory -body { set end [getbytes] for {set i 0} {$i < 5} {incr i} { doit @@ -1059,435 +1064,19 @@ set end [getbytes] } set leakedBytes [expr {$end - $tmp}] } -cleanup { array unset A - rename doit {} -} -result 0 -test var-22.2 {leak in parsedVarName} -constraints memory -body { - set i 0 - leaktest {lappend x($i)} -} -cleanup { - unset -nocomplain i x -} -result 0 - -unset -nocomplain a k v -test var-23.1 {array command, for loop, too many args} -returnCodes error -body { - array for {k v} c d e {} -} -result {wrong # args: should be "array for {key value} arrayName script"} -test var-23.2 {array command, for loop, not enough args} -returnCodes error -body { - array for {k v} {} -} -result {wrong # args: should be "array for {key value} arrayName script"} -test var-23.3 {array command, for loop, too many list args} -setup { - unset -nocomplain a -} -returnCodes error -body { - array for {k v w} a {} -} -result {must have two variable names} -test var-23.4 {array command, for loop, not enough list args} -setup { - unset -nocomplain a -} -returnCodes error -body { - array for {k} a {} -} -result {must have two variable names} -test var-23.5 {array command, for loop, no array} -setup { - unset -nocomplain a -} -returnCodes error -body { - array for {k v} a {} -} -result {"a" isn't an array} -test var-23.6 {array command, for loop, array doesn't exist yet but has compiler-allocated procedure slot} -setup { - catch {rename p ""} -} -returnCodes error -body { - apply {{x} { - if {$x==1} { - return [array for {k v} a {}] - } - set a(x) 123 - }} 1 -} -result {"a" isn't an array} -test var-23.7 {array enumeration} -setup { - unset -nocomplain a - set reslist [list] -} -body { - array set a {a 1 b 2 c 3} - array for {k v} a { - lappend reslist $k $v - } - lsort -stride 2 -index 0 $reslist -} -cleanup { - unset -nocomplain a - unset -nocomplain reslist -} -result {a 1 b 2 c 3} -test var-23.9 {array enumeration, nested} -setup { - unset -nocomplain a - set reslist [list] -} -body { - array set a {a 1 b 2 c 3} - array for {k1 v1} a { - lappend reslist $k1 $v1 - set r2 {} - array for {k2 v2} a { - lappend r2 $k2 $v2 - } - lappend reslist [lsort -stride 2 -index 0 $r2] - } - # there is no guarantee in which order the array contents will be - # returned. - lsort -stride 3 -index 0 $reslist -} -cleanup { - unset -nocomplain a - unset -nocomplain reslist -} -result {a 1 {a 1 b 2 c 3} b 2 {a 1 b 2 c 3} c 3 {a 1 b 2 c 3}} -test var-23.10 {array enumeration, delete key} -match glob -setup { - unset -nocomplain a - set reslist [list] -} -body { - set retval {} - try { - array set a {a 1 b 2 c 3 d 4} - array for {k v} a { - lappend reslist $k $v - if { $k eq "a" } { - unset a(c) - } - } - lsort -stride 2 -index 0 $reslist - } on error {err res} { - set retval [dict get $res -errorinfo] - } - set retval -} -cleanup { - unset -nocomplain a - unset -nocomplain reslist - unset -nocomplain retval -} -result {array changed during iteration*} -test var-23.11 {array enumeration, insert key} -match glob -setup { - unset -nocomplain a - set reslist [list] -} -body { - set retval {} - try { - array set a {a 1 b 2 c 3 d 4} - array for {k v} a { - lappend reslist $k $v - if { $k eq "a" } { - set a(e) 5 - } - } - lsort -stride 2 -index 0 $reslist - } on error {err res} { - set retval [dict get $res -errorinfo] - } -} -cleanup { - unset -nocomplain a - unset -nocomplain reslist -} -result {array changed during iteration*} -test var-23.12 {array enumeration, change value} -setup { - unset -nocomplain a - set reslist [list] -} -body { - array set a {a 1 b 2 c 3} - array for {k v} a { - lappend reslist $k $v - if { $k eq "a" } { - set a(c) 9 - } - } - lsort -stride 2 -index 0 $reslist -} -cleanup { - unset -nocomplain a - unset -nocomplain reslist -} -result {a 1 b 2 c 9} -test var-23.13 {array enumeration, number of traces} -setup { - set ::countarrayfor 0 - proc ::tracearrayfor { args } { - incr ::countarrayfor - } - unset -nocomplain ::a - set reslist [list] -} -body { - array set ::a {a 1 b 2 c 3} - foreach {k} [array names a] { - trace add variable ::a($k) read ::tracearrayfor - } - array for {k v} ::a { - lappend reslist $k $v - } - set ::countarrayfor -} -cleanup { - unset -nocomplain ::countarrayfor - unset -nocomplain ::a - unset -nocomplain reslist -} -result 3 -test var-23.14 {array for, shared arguments} -setup { - set vn {k v} - unset -nocomplain $vn -} -body { - array set $vn {a 1 b 2 c 3} - array for $vn $vn {} -} -cleanup { - unset -nocomplain $vn vn -} -result {} - -test var-24.1 {array default set and get: interpreted} -setup { - unset -nocomplain ary -} -body { - array set ary {a 3} - array default set ary 7 - list $ary(a) $ary(b) [info exist ary(a)] [info exist ary(b)] \ - [array default get ary] -} -cleanup { - unset -nocomplain ary -} -result {3 7 1 0 7} -test var-24.2 {array default set and get: compiled} { - apply {{} { - array set ary {a 3} - array default set ary 7 - list $ary(a) $ary(b) [info exist ary(a)] [info exist ary(b)] \ - [array default get ary] - }} -} {3 7 1 0 7} -test var-24.3 {array default unset: interpreted} -setup { - unset -nocomplain ary -} -body { - array set ary {a 3} - array default set ary 7 - list $ary(a) $ary(b) [array default unset ary] $ary(a) [catch {set ary(b)}] -} -cleanup { - unset -nocomplain ary -} -result {3 7 {} 3 1} -test var-24.4 {array default unset: compiled} { - apply {{} { - array set ary {a 3} - array default set ary 7 - list $ary(a) $ary(b) [array default unset ary] $ary(a) \ - [catch {set ary(b)}] - }} -} {3 7 {} 3 1} -test var-24.5 {array default exists: interpreted} -setup { - unset -nocomplain ary result - set result {} -} -body { - array set ary {a 3} - lappend result [info exists ary],[array exists ary],[array default exists ary] - array default set ary 7 - lappend result [info exists ary],[array exists ary],[array default exists ary] - array default unset ary - lappend result [info exists ary],[array exists ary],[array default exists ary] - unset ary - lappend result [info exists ary],[array exists ary],[array default exists ary] - array default set ary 11 - lappend result [info exists ary],[array exists ary],[array default exists ary] -} -cleanup { - unset -nocomplain ary result -} -result {1,1,0 1,1,1 1,1,0 0,0,0 1,1,1} -test var-24.6 {array default exists: compiled} { - apply {{} { - array set ary {a 3} - lappend result [info exists ary],[array exists ary],[array default exists ary] - array default set ary 7 - lappend result [info exists ary],[array exists ary],[array default exists ary] - array default unset ary - lappend result [info exists ary],[array exists ary],[array default exists ary] - unset ary - lappend result [info exists ary],[array exists ary],[array default exists ary] - array default set ary 11 - lappend result [info exists ary],[array exists ary],[array default exists ary] - }} -} {1,1,0 1,1,1 1,1,0 0,0,0 1,1,1} -test var-24.7 {array default and append: interpreted} -setup { - unset -nocomplain ary result - set result {} -} -body { - array default set ary grill - lappend result [array size ary] [info exist ary(x)] - append ary(x) abc - lappend result [array size ary] $ary(x) - array default unset ary - append ary(x) def - append ary(y) ghi - lappend result [array size ary] $ary(x) $ary(y) -} -cleanup { - unset -nocomplain ary result -} -result {0 0 1 grillabc 2 grillabcdef ghi} -test var-24.8 {array default and append: compiled} { - apply {{} { - array default set ary grill - lappend result [array size ary] [info exist ary(x)] - append ary(x) abc - lappend result [array size ary] $ary(x) - array default unset ary - append ary(x) def - append ary(y) ghi - lappend result [array size ary] $ary(x) $ary(y) - }} -} {0 0 1 grillabc 2 grillabcdef ghi} -test var-24.9 {array default and lappend: interpreted} -setup { - unset -nocomplain ary result - set result {} -} -body { - array default set ary grill - lappend result [array size ary] [info exist ary(x)] - lappend ary(x) abc - lappend result [array size ary] $ary(x) - array default unset ary - lappend ary(x) def - lappend ary(y) ghi - lappend result [array size ary] $ary(x) $ary(y) -} -cleanup { - unset -nocomplain ary result -} -result {0 0 1 {grill abc} 2 {grill abc def} ghi} -test var-24.10 {array default and lappend: compiled} { - apply {{} { - array default set ary grill - lappend result [array size ary] [info exist ary(x)] - lappend ary(x) abc - lappend result [array size ary] $ary(x) - array default unset ary - lappend ary(x) def - lappend ary(y) ghi - lappend result [array size ary] $ary(x) $ary(y) - }} -} {0 0 1 {grill abc} 2 {grill abc def} ghi} -test var-24.11 {array default and incr: interpreted} -setup { - unset -nocomplain ary result - set result {} -} -body { - array default set ary 7 - lappend result [array size ary] [info exist ary(x)] - incr ary(x) 11 - lappend result [array size ary] $ary(x) - array default unset ary - incr ary(x) - incr ary(y) - lappend result [array size ary] $ary(x) $ary(y) -} -cleanup { - unset -nocomplain ary result -} -result {0 0 1 18 2 19 1} -test var-24.12 {array default and incr: compiled} { - apply {{} { - array default set ary 7 - lappend result [array size ary] [info exist ary(x)] - incr ary(x) 11 - lappend result [array size ary] $ary(x) - array default unset ary - incr ary(x) - incr ary(y) - lappend result [array size ary] $ary(x) $ary(y) - }} -} {0 0 1 18 2 19 1} -test var-24.13 {array default and dict: interpreted} -setup { - unset -nocomplain ary x y z -} -body { - array default set ary {x y} - dict lappend ary(p) x z - dict update ary(q) x y { - set y z - } - dict with ary(r) { - set x 123 - } - lsort -stride 2 -index 0 [array get ary] -} -cleanup { - unset -nocomplain ary x y z -} -result {p {x {y z}} q {x z} r {x 123}} -test var-24.14 {array default and dict: compiled} { - lsort -stride 2 -index 0 [apply {{} { - array default set ary {x y} - dict lappend ary(p) x z - dict update ary(q) x y { - set y z - } - dict with ary(r) { - set x 123 - } - array get ary - }}] -} {p {x {y z}} q {x z} r {x 123}} -test var-24.15 {array default set and get: two-level} { - apply {{} { - array set ary {a 3} - array default set ary 7 - apply {{} { - upvar 1 ary ary ary(c) c - lappend result $ary(a) $ary(b) $c - lappend result [info exist ary(a)] [info exist ary(b)] [info exist c] - lappend result [array default get ary] - }} - }} -} {3 7 7 1 0 0 7} -test var-24.16 {array default set: errors} -setup { - unset -nocomplain ary -} -body { - set ary not-an-array - array default set ary 7 -} -returnCodes error -cleanup { - unset -nocomplain ary -} -result {can't array default set "ary": variable isn't array} -test var-24.17 {array default set: errors} -setup { - unset -nocomplain ary -} -body { - array default set ary -} -returnCodes error -cleanup { - unset -nocomplain ary -} -result * -match glob -test var-24.18 {array default set: errors} -setup { - unset -nocomplain ary -} -body { - array default set ary x y -} -returnCodes error -cleanup { - unset -nocomplain ary -} -result * -match glob -test var-24.19 {array default get: errors} -setup { - unset -nocomplain ary -} -body { - set ary not-an-array - array default get ary -} -returnCodes error -cleanup { - unset -nocomplain ary -} -result {"ary" isn't an array} -test var-24.20 {array default get: errors} -setup { - unset -nocomplain ary -} -body { - array default get ary x y -} -returnCodes error -cleanup { - unset -nocomplain ary -} -result * -match glob -test var-24.21 {array default exists: errors} -setup { - unset -nocomplain ary -} -body { - set ary not-an-array - array default exists ary -} -returnCodes error -cleanup { - unset -nocomplain ary -} -result {"ary" isn't an array} -test var-24.22 {array default exists: errors} -setup { - unset -nocomplain ary -} -body { - array default exists ary x -} -returnCodes error -cleanup { - unset -nocomplain ary -} -result * -match glob -test var-24.23 {array default unset: errors} -setup { - unset -nocomplain ary -} -body { - set ary not-an-array - array default unset ary -} -returnCodes error -cleanup { - unset -nocomplain ary -} -result {"ary" isn't an array} -test var-24.24 {array default unset: errors} -setup { - unset -nocomplain ary -} -body { - array default unset ary x -} -returnCodes error -cleanup { - unset -nocomplain ary -} -result * -match glob + rename getbytes {} + rename doit {} +} -result 0 + catch {namespace delete ns} catch {unset arr} catch {unset v} -catch {rename getbytes ""} catch {rename p ""} catch {namespace delete test_ns_var} catch {namespace delete test_ns_var2} catch {unset xx} catch {unset x} Index: tests/while-old.test ================================================================== --- tests/while-old.test +++ tests/while-old.test @@ -11,18 +11,18 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } test while-old-1.1 {basic while loops} { set count 0 - while {$count < 10} {set count [expr $count+1]} + while {$count < 10} {set count [expr {$count + 1}]} set count } 10 test while-old-1.2 {basic while loops} { set value xxx while {2 > 3} {set value yyy} @@ -56,13 +56,13 @@ test while-old-2.1 {continue in while loop} { set list {1 2 3 4 5} set index 0 set result {} while {$index < 5} { - if {$index == 2} {set index [expr $index+1]; continue} + if {$index == 2} {set index [expr {$index + 1}]; continue} set result [concat $result [lindex $list $index]] - set index [expr $index+1] + set index [expr {$index + 1}] } set result } {1 2 4 5} test while-old-3.1 {break in while loop} { @@ -70,11 +70,11 @@ set index 0 set result {} while {$index < 5} { if {$index == 3} break set result [concat $result [lindex $list $index]] - set index [expr $index+1] + set index [expr {$index + 1}] } set result } {1 2 3} test while-old-4.1 {errors in while loops} { @@ -90,11 +90,11 @@ list $err $msg } {1 {wrong # args: should be "while test command"}} test while-old-4.4 {errors in while loops} { set err [catch {while {"a"+"b"} {error "loop aborted"}} msg] list $err $msg -} {1 {can't use non-numeric string "a" as operand of "+"}} +} {1 {can't use non-numeric string as operand of "+"}} test while-old-4.5 {errors in while loops} { catch {unset x} set x 1 set err [catch {while {$x} {set x foo}} msg] list $err $msg Index: tests/while.test ================================================================== --- tests/while.test +++ tests/while.test @@ -9,11 +9,11 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } # Basic "while" operation. @@ -30,11 +30,11 @@ } -cleanup { unset i } -match glob -result {*"while {$i<} break"} test while-1.3 {TclCompileWhileCmd: error in test expression} -body { while {"a"+"b"} {error "loop aborted"} -} -returnCodes error -result {can't use non-numeric string "a" as operand of "+"} +} -returnCodes error -result {can't use non-numeric string as operand of "+"} test while-1.4 {TclCompileWhileCmd: multiline test expr} -body { set value 1 while {($tcl_platform(platform) != "foobar1") && \ ($tcl_platform(platform) != "foobar2")} { incr value @@ -75,11 +75,11 @@ "set"*} test while-1.9 {TclCompileWhileCmd: simple command body} -body { set a {} set i 1 while {$i<6} { - if $i==4 break + if {$i==4} break set a [concat $a $i] incr i } return $a } -cleanup { @@ -110,12 +110,12 @@ } -result {x1} test while-1.12 {TclCompileWhileCmd: long command body} -body { set a {} set i 1 while {$i<6} { - if $i==4 break - if $i>5 continue + if {$i==4} break + if {$i>5} continue if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } @@ -153,11 +153,11 @@ } -cleanup { unset a i } -result {} test while-1.14 {TclCompileWhileCmd: while command result} -body { set i 0 - set a [while {$i < 5} {if $i==3 break; incr i}] + set a [while {$i < 5} {if {$i==3} break; incr i}] return $a } -cleanup { unset a i } -result {} @@ -205,13 +205,13 @@ } -result {2.2 2.3 3.2 4.2 5.2} test while-2.4 {continue tests, long command body} -body { set a {} set i 1 while {$i<6} { - if $i==2 {incr i; continue} - if $i==4 break - if $i>5 continue + if {$i==2} {incr i; continue} + if {$i==4} break + if {$i>5} continue if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } @@ -275,13 +275,13 @@ } -result {1.1 1.2 2.1 3.1 4.1} test while-3.3 {break tests, long command body} -body { set a {} set i 1 while {$i<6} { - if $i==2 {incr i; continue} - if $i==5 break - if $i>5 continue + if {$i==2} {incr i; continue} + if {$i==5} break + if {$i>5} continue if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } @@ -293,11 +293,11 @@ if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if $i==4 break + if {$i==4} break if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } @@ -341,11 +341,11 @@ unset i z } -result {*"$z {$i<} {set x 1}"} test while-4.4 {while (not compiled): error in test expression} -body { set z while $z {"a"+"b"} {error "loop aborted"} -} -returnCodes error -result {can't use non-numeric string "a" as operand of "+"} +} -returnCodes error -result {can't use non-numeric string as operand of "+"} test while-4.5 {while (not compiled): multiline test expr} -body { set value 1 set z while $z {($tcl_platform(platform) != "foobar1") && \ ($tcl_platform(platform) != "foobar2")} { @@ -399,11 +399,11 @@ test while-4.10 {while (not compiled): simple command body} -body { set a {} set i 1 set z while $z {$i<6} { - if $i==4 break + if {$i==4} break set a [concat $a $i] incr i } return $a } -cleanup { @@ -437,12 +437,12 @@ test while-4.13 {while (not compiled): long command body} -body { set a {} set z while set i 1 $z {$i<6} { - if $i==4 break - if $i>5 continue + if {$i==4} break + if {$i>5} continue if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } @@ -482,11 +482,11 @@ unset a i z } -result {} test while-4.15 {while (not compiled): while command result} -body { set i 0 set z while - set a [$z {$i < 5} {if $i==3 break; incr i}] + set a [$z {$i < 5} {if {$i==3} break; incr i}] return $a } -cleanup { unset a i z } -result {} @@ -536,13 +536,13 @@ test while-5.4 {break tests, long command body with computed command names} -body { set a {} set i 1 set z break while {$i<6} { - if $i==2 {incr i; continue} - if $i==5 $z - if $i>5 continue + if {$i==2} {incr i; continue} + if {$i==5} $z + if {$i>5} continue if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } @@ -554,11 +554,11 @@ if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if $i==4 $z + if {$i==4} $z if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } @@ -635,13 +635,13 @@ test while-6.5 {continue tests, long command body with computed command names} -body { set a {} set i 1 set z continue while {$i<6} { - if $i==2 {incr i; continue} - if $i==4 break - if $i>5 $z + if {$i==2} {incr i; continue} + if {$i==4} break + if {$i>5} $z if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } Index: tests/winConsole.test ================================================================== --- tests/winConsole.test +++ tests/winConsole.test @@ -7,12 +7,12 @@ # Copyright (c) 1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } test winConsole-1.1 {Console file channel: non-blocking gets} {win interactive} { Index: tests/winDde.test ================================================================== --- tests/winDde.test +++ tests/winDde.test @@ -8,22 +8,22 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 #tcltest::configure -verbose {pass start} namespace import -force ::tcltest::* } testConstraint debug [::tcl::pkgconfig get debug] testConstraint dde 0 if {[testConstraint win]} { if {![catch { ::tcltest::loadTestedCommands - set ::ddever [package require dde 1.4.1] - set ::ddelib [lindex [package ifneeded dde $::ddever] 1]}]} { + set ::ddever [package require dde 1.4.3] + set ::ddelib [info loaded "" Dde]}]} { testConstraint dde 1 } } @@ -36,16 +36,16 @@ proc createChildProcess {ddeServerName args} { file delete -force $::scriptName set f [open $::scriptName w+] puts $f [list set ddeServerName $ddeServerName] - puts $f [list load $::ddelib dde] + puts $f [list load $::ddelib Dde] puts $f { # DDE child server - # if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } # If an error occurs during the tests, this process may end up not # being closed down. To deal with this we create a 30s timeout. @@ -102,30 +102,30 @@ } # ------------------------------------------------------------------------- test winDde-1.0 {check if we are testing the right dll} {win dde} { set ::ddever -} {1.4.1} +} {1.4.3} 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} test winDde-2.1 {Checking for other services} -constraints dde -body { - expr [llength [dde services {} {}]] >= 0 + expr {[llength [dde services {} {}]] >= 0} } -result 1 test winDde-2.2 {Checking for existence, with service and topic specified} \ -constraints dde -body { llength [dde services TclEval self] } -result 1 test winDde-2.3 {Checking for existence, with only the service specified} \ -constraints dde -body { - expr [llength [dde services TclEval {}]] >= 1 + expr {[llength [dde services TclEval {}]] >= 1} } -result 1 test winDde-2.4 {Checking for existence, with only the topic specified} \ -constraints dde -body { - expr [llength [dde services {} self]] >= 1 + expr {[llength [dde services {} self]] >= 1} } -result 1 # ------------------------------------------------------------------------- test winDde-3.1 {DDE execute locally} -constraints dde -body { @@ -152,12 +152,12 @@ set \xe1 "" dde execute TclEval self [list set \xe1 foo] dde request -binary TclEval self \xe1 } -result "foo\x00" # Set variable a to A with diaeresis (unicode C4) by relying on the fact -# that utf8 is sent (e.g. "c3 84" on the wire) -test winDde-3.6 {DDE request utf8} -constraints dde -body { +# that utf-8 is sent (e.g. "c3 84" on the wire) +test winDde-3.6 {DDE request utf-8} -constraints dde -body { set \xe1 "not set" dde execute TclEval self "set \xe1 \xc4" scan [set \xe1] %c } -result 196 # Set variable a to A with diaeresis (unicode C4) using binary execute @@ -277,153 +277,153 @@ update } -result "ch\xEDld-6.6" # ------------------------------------------------------------------------- -test winDde-7.1 {Load DDE in slave interpreter} -constraints dde -setup { - interp create slave +test winDde-7.1 {Load DDE in child interpreter} -constraints dde -setup { + interp create child } -body { - slave eval [list load $::ddelib Dde] - slave eval [list dde servername -- dde-interp-7.1] + child eval [list load $::ddelib Dde] + child eval [list dde servername -- dde-interp-7.1] } -cleanup { - interp delete slave + interp delete child } -result {dde-interp-7.1} -test winDde-7.2 {DDE slave cleanup} -constraints dde -setup { - interp create slave - slave eval [list load $::ddelib Dde] - slave eval [list dde servername -- dde-interp-7.5] - interp delete slave +test winDde-7.2 {DDE child cleanup} -constraints dde -setup { + interp create child + child eval [list load $::ddelib Dde] + child eval [list dde servername -- dde-interp-7.5] + interp delete child } -body { dde services TclEval {} set s [dde services TclEval {}] set m [list [list TclEval dde-interp-7.5]] if {$m in $s} { set s } } -result {} -test winDde-7.3 {DDE present in slave interp} -constraints dde -setup { - interp create slave - slave eval [list load $::ddelib Dde] - slave eval [list dde servername -- dde-interp-7.3] +test winDde-7.3 {DDE present in child interp} -constraints dde -setup { + interp create child + child eval [list load $::ddelib Dde] + child eval [list dde servername -- dde-interp-7.3] } -body { dde services TclEval dde-interp-7.3 } -cleanup { - interp delete slave + interp delete child } -result {{TclEval dde-interp-7.3}} test winDde-7.4 {interp name collision with -force} -constraints dde -setup { - interp create slave - slave eval [list load $::ddelib Dde] - slave eval [list dde servername -- dde-interp-7.4] + interp create child + child eval [list load $::ddelib Dde] + child eval [list dde servername -- dde-interp-7.4] } -body { dde servername -force -- dde-interp-7.4 } -cleanup { - interp delete slave + interp delete child } -result {dde-interp-7.4} test winDde-7.5 {interp name collision without -force} -constraints dde -setup { - interp create slave - slave eval [list load $::ddelib Dde] - slave eval [list dde servername -- dde-interp-7.5] + interp create child + child eval [list load $::ddelib Dde] + child eval [list dde servername -- dde-interp-7.5] } -body { dde servername -- dde-interp-7.5 } -cleanup { - interp delete slave + interp delete child } -result "dde-interp-7.5 #2" # ------------------------------------------------------------------------- test winDde-8.1 {Safe DDE load} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde + interp create -safe child + child invokehidden load $::ddelib Dde } -body { - slave eval dde servername slave + child eval dde servername child } -cleanup { - interp delete slave + interp delete child } -returnCodes error -result {invalid command name "dde"} test winDde-8.2 {Safe DDE set servername} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde + interp create -safe child + child invokehidden load $::ddelib Dde } -body { - slave invokehidden dde servername slave -} -cleanup {interp delete slave} -result {slave} + child invokehidden dde servername child +} -cleanup {interp delete child} -result {child} test winDde-8.3 {Safe DDE check handler required for eval} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave invokehidden dde servername slave + interp create -safe child + child invokehidden load $::ddelib Dde + child invokehidden dde servername child } -body { - catch {dde eval slave set a 1} msg -} -cleanup {interp delete slave} -result {1} + catch {dde eval child set a 1} msg +} -cleanup {interp delete child} -result {1} test winDde-8.4 {Safe DDE check that execute is denied} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave invokehidden dde servername slave + interp create -safe child + child invokehidden load $::ddelib Dde + child invokehidden dde servername child } -body { - slave eval set a 1 - dde execute TclEval slave {set a 2} - slave eval set a -} -cleanup {interp delete slave} -result 1 + child eval set a 1 + dde execute TclEval child {set a 2} + child eval set a +} -cleanup {interp delete child} -result 1 test winDde-8.5 {Safe DDE check that request is denied} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave invokehidden dde servername slave + interp create -safe child + child invokehidden load $::ddelib Dde + child invokehidden dde servername child } -body { - slave eval set a 1 - dde request TclEval slave a + child eval set a 1 + dde request TclEval child a } -cleanup { - interp delete slave + interp delete child } -returnCodes error -result {remote server cannot handle this command} test winDde-8.6 {Safe DDE assign handler procedure} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} + interp create -safe child + child invokehidden load $::ddelib Dde + child eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} } -body { - slave invokehidden dde servername -handler DDEACCEPT slave -} -cleanup {interp delete slave} -result slave + child invokehidden dde servername -handler DDEACCEPT child +} -cleanup {interp delete child} -result child test winDde-8.7 {Safe DDE check simple command} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} - slave invokehidden dde servername -handler DDEACCEPT slave + interp create -safe child + child invokehidden load $::ddelib Dde + child eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} + child invokehidden dde servername -handler DDEACCEPT child } -body { - dde eval slave set x 1 -} -cleanup {interp delete slave} -result {set x 1} + dde eval child set x 1 +} -cleanup {interp delete child} -result {set x 1} test winDde-8.8 {Safe DDE check non-list command} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} - slave invokehidden dde servername -handler DDEACCEPT slave + interp create -safe child + child invokehidden load $::ddelib Dde + child eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} + child invokehidden dde servername -handler DDEACCEPT child } -body { set s "c:\\Program Files\\Microsoft Visual Studio\\" - dde eval slave $s - string equal [slave eval set DDECMD] $s -} -cleanup {interp delete slave} -result 1 + dde eval child $s + string equal [child eval set DDECMD] $s +} -cleanup {interp delete child} -result 1 test winDde-8.9 {Safe DDE check command evaluation} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} - slave invokehidden dde servername -handler DDEACCEPT slave + interp create -safe child + child invokehidden load $::ddelib Dde + child eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} + child invokehidden dde servername -handler DDEACCEPT child } -body { - dde eval slave set \xe1 1 - slave eval set \xe1 -} -cleanup {interp delete slave} -result 1 + dde eval child set \xe1 1 + child eval set \xe1 +} -cleanup {interp delete child} -result 1 test winDde-8.10 {Safe DDE check command evaluation (2)} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} - slave invokehidden dde servername -handler DDEACCEPT slave + interp create -safe child + child invokehidden load $::ddelib Dde + child eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} + child invokehidden dde servername -handler DDEACCEPT child } -body { - dde eval slave [list set x 1] - slave eval set x -} -cleanup {interp delete slave} -result 1 + dde eval child [list set x 1] + child eval set x +} -cleanup {interp delete child} -result 1 test winDde-8.11 {Safe DDE check command evaluation (3)} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} - slave invokehidden dde servername -handler DDEACCEPT slave + interp create -safe child + child invokehidden load $::ddelib Dde + child eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} + child invokehidden dde servername -handler DDEACCEPT child } -body { - dde eval slave [list [list set x 1]] - slave eval set x -} -cleanup {interp delete slave} -returnCodes error -result {invalid command name "set x 1"} + dde eval child [list [list set x 1]] + child eval set x +} -cleanup {interp delete child} -returnCodes error -result {invalid command name "set x 1"} # ------------------------------------------------------------------------- test winDde-9.1 {External safe DDE check string passing} -constraints {dde stdio} -setup { set name ch\xEDld-9.1 @@ -479,13 +479,13 @@ } -result {null data} # ------------------------------------------------------------------------- #cleanup -#catch {interp delete $slave}; # ensure we clean up the slave. +#catch {interp delete $child}; # ensure we clean up the child. file delete -force $::scriptName ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: Index: tests/winFCmd.test ================================================================== --- tests/winFCmd.test +++ tests/winFCmd.test @@ -8,28 +8,32 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] # Initialise the test constraints testConstraint winVista 0 -testConstraint winXP 0 +testConstraint win2000orXP 0 +testConstraint winOlderThan2000 0 testConstraint testvolumetype [llength [info commands testvolumetype]] testConstraint testfile [llength [info commands testfile]] testConstraint testchmod [llength [info commands testchmod]] testConstraint cdrom 0 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)]}] proc createfile {file {string a}} { set f [open $file w] puts -nonewline $f $string close $f @@ -53,15 +57,19 @@ catch {file delete -force -- {*}$x} } } } -if {[testConstraint win]} { - if {$::tcl_platform(osVersion) >= 5.0} { - testConstraint winVista 1 +if {[testConstraint winOnly]} { + if {[testConstraint nt] && $::tcl_platform(osVersion) >= 5.0} { + if {$::tcl_platform(osVersion) >= 6.0} { + testConstraint winVista 1 + } else { + testConstraint win2000orXP 1 + } } else { - testConstraint winXP 1 + testConstraint winOlderThan2000 1 } } # find a CD-ROM so we can test read-only filesystems. @@ -90,12 +98,17 @@ } # NB: filename is chosen to be short but unlikely to clash with other apps if {[file exists c:/] && [file exists d:/]} { catch {file delete d:/TclTmpF.1} - if {[catch {createfile d:/TclTmpF.1 {}}] == 0} { - file delete d:/TclTmpF.1 + catch {file delete d:/TclTmpD.1} + catch {file delete c:/TclTmpC.1} + if {![catch {createfile d:/TclTmpF.1 {}}] && [file isfile d:/TclTmpF.1] + && ![catch {file mkdir d:/TclTmpD.1}] && [file isdirectory d:/TclTmpD.1] + && ![catch {file mkdir c:/TclTmpC.1}] && [file isdirectory c:/TclTmpC.1] + } { + file delete d:/TclTmpF.1 d:/TclTmpD.1 c:/TclTmpC.1 testConstraint exdev 1 } } file delete -force -- td1 @@ -171,16 +184,16 @@ file mkdir td1 createfile tf1 testfile mv td1 tf1 } -returnCodes error -result ENOTDIR test winFCmd-1.10 {TclpRenameFile: errno: EXDEV} -setup { - file delete -force d:/tf1 + file delete -force d:/TclTmpD.1 } -constraints {win exdev testfile} -body { - file mkdir c:/tf1 - testfile mv c:/tf1 d:/tf1 + file mkdir c:/TclTmpC.1 + testfile mv c:/TclTmpC.1 d:/TclTmpD.1 } -cleanup { - file delete -force c:/tf1 + file delete -force c:/TclTmpC.1 } -returnCodes error -result EXDEV test winFCmd-1.11 {TclpRenameFile: errno: EACCES} -setup { cleanup } -constraints {win testfile} -body { set fd [open tf1 w] @@ -197,16 +210,21 @@ } -cleanup { catch {close $fd} } -returnCodes error -result EACCES test winFCmd-1.13 {TclpRenameFile: errno: EACCES} -setup { cleanup -} -constraints {win winXP testfile} -body { +} -constraints {win win2000orXP testfile} -body { testfile mv nul tf1 } -returnCodes error -result EINVAL +test winFCmd-1.14 {TclpRenameFile: errno: EACCES} -setup { + cleanup +} -constraints {win nt winOlderThan2000 testfile} -body { + testfile mv nul tf1 +} -returnCodes error -result EACCES test winFCmd-1.15 {TclpRenameFile: errno: EEXIST} -setup { cleanup -} -constraints {win testfile} -body { +} -constraints {win nt testfile} -body { createfile tf1 testfile mv tf1 nul } -returnCodes error -result EEXIST test winFCmd-1.16 {TclpRenameFile: MoveFile() != FALSE} -setup { cleanup @@ -225,16 +243,23 @@ } -constraints {win testfile} -body { testfile mv tf1 tf2 } -returnCodes error -result ENOENT test winFCmd-1.19 {TclpRenameFile: errno == EACCES} -setup { cleanup -} -constraints {win winXP testfile} -body { +} -constraints {win win2000orXP testfile} -body { testfile mv nul tf1 } -returnCodes error -result EINVAL +test winFCmd-1.19.1 {TclpRenameFile: errno == EACCES} -setup { + cleanup +} -constraints {win nt winOlderThan2000 testfile} -body { + testfile mv nul tf1 +} -returnCodes error -result EACCES test winFCmd-1.20 {TclpRenameFile: src is dir} -setup { cleanup -} -constraints {win testfile} -body { +} -constraints {win nt testfile} -body { + # under 95, this would actually succeed and move the current dir out from + # under the current process! file delete /tf1 testfile mv [pwd] /tf1 } -returnCodes error -result EACCES test winFCmd-1.21 {TclpRenameFile: long src} -setup { cleanup @@ -314,19 +339,19 @@ testfile mv td1 td2 list [file exists td1] [file exists td2] [file exists td2/td2] } -result {0 1 1} test winFCmd-1.33 {TclpRenameFile: After removing dst dir, MoveFile fails} \ -constraints {win exdev testfile testchmod} -body { - file mkdir d:/td1 - testchmod 0 d:/td1 - file mkdir c:/tf1 - catch {testfile mv c:/tf1 d:/td1} msg - list $msg [file writable d:/td1] + file mkdir d:/TclTmpD.1 + testchmod 0 d:/TclTmpD.1 + file mkdir c:/TclTmpC.1 + catch {testfile mv c:/TclTmpC.1 d:/TclTmpD.1} msg + list $msg [file writable d:/TclTmpD.1] } -cleanup { - catch {testchmod 0o666 d:/td1} - file delete d:/td1 - file delete -force c:/tf1 + catch {testchmod 0o666 d:/TclTmpD.1} + file delete d:/TclTmpD.1 + file delete -force c:/TclTmpC.1 } -result {EXDEV 0} test winFCmd-1.34 {TclpRenameFile: src is dir, dst is not} -setup { cleanup } -constraints {win testfile} -body { file mkdir td1 @@ -376,21 +401,21 @@ } set filename [file join $dirname Test[incr ndx]] set f [open $filename w] close $f file stat $filename stat - if {[set n [lsearch -exact -integer $inodes $stat(ino)]] != -1} { + if {[set n [lsearch -exact -integer $inodes $stat(ino)]] >= 0} { return [list [file join $dirname Test$n] $filename] } lappend inodes $stat(ino) unset stat } } test winFCmd-1.38 {TclpRenameFile: check rename of conflicting inodes} -setup { cleanup -} -constraints {win winNonZeroInodes} -body { +} -constraints {win winNonZeroInodes notInCIenv} -body { file mkdir td1 foreach {a b} [MakeFiles td1] break file rename -force $a $b file exists $a } -cleanup { @@ -438,13 +463,18 @@ } -cleanup { cleanup } -returnCodes error -result ENOENT test winFCmd-2.7 {TclpCopyFile: errno: EACCES} -setup { cleanup -} -constraints {win winXP testfile} -body { +} -constraints {win win2000orXP testfile} -body { testfile cp nul tf1 } -returnCodes error -result EINVAL +test winFCmd-2.8 {TclpCopyFile: errno: EACCES} -setup { + cleanup +} -constraints {win nt winOlderThan2000 testfile} -body { + testfile cp nul tf1 +} -returnCodes error -result EACCES test winFCmd-2.10 {TclpCopyFile: CopyFile succeeds} -setup { cleanup } -constraints {win testfile} -body { createfile tf1 tf1 testfile cp tf1 tf2 @@ -598,11 +628,11 @@ cleanup } -returnCodes error -result EACCES test winFCmd-4.1 {TclpCreateDirectory: errno: EACCES} -body { testfile mkdir $cdrom/dummy~~.dir -} -constraints {win cdrom testfile} -returnCodes error -result EACCES +} -constraints {win nt cdrom testfile} -returnCodes error -result EACCES test winFCmd-4.3 {TclpCreateDirectory: errno: EEXIST} -setup { cleanup } -constraints {win testfile} -body { file mkdir td1 testfile mkdir td1 @@ -631,11 +661,11 @@ cleanup } -result {directory directory} test winFCmd-6.1 {TclpRemoveDirectory: errno: EACCES} -setup { cleanup -} -constraints {winVista testfile testchmod} -body { +} -constraints {winVista testfile testchmod notInCIenv} -body { file mkdir td1 testchmod 0 td1 testfile rmdir td1 file exists td1 } -returnCodes error -cleanup { @@ -685,11 +715,11 @@ createfile tf1 list [catch {testfile rmdir tf1} msg] [file tail $msg] } -result {1 {tf1 ENOTDIR}} test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} -setup { cleanup -} -constraints {winVista testfile testchmod} -body { +} -constraints {winVista testfile testchmod notInCIenv} -body { file mkdir td1 testchmod 0 td1 testfile rmdir td1 file exists td1 } -returnCodes error -cleanup { @@ -696,18 +726,18 @@ catch {testchmod 0o666 td1} cleanup } -result {td1 EACCES} test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} -setup { cleanup -} -constraints {win testfile} -body { +} -constraints {win nt testfile} -body { testfile rmdir / # WinXP returns EEXIST, WinNT seems to return EACCES. No policy # decision has been made as to which is correct. } -returnCodes error -match regexp -result {^/ E(ACCES|EXIST)$} test winFCmd-6.13 {TclpRemoveDirectory: write-protected} -setup { cleanup -} -constraints {winVista testfile testchmod} -body { +} -constraints {winVista testfile testchmod notInCIenv} -body { file mkdir td1 testchmod 0 td1 testfile rmdir td1 file exists td1 } -cleanup { @@ -794,11 +824,11 @@ } -cleanup { cleanup } -result {tf1} test winFCmd-7.9 {TraverseWinTree: append \ to source if necessary} -body { testfile rmdir $cdrom/ -} -constraints {win cdrom testfile} -returnCodes error -match glob \ +} -constraints {win nt cdrom testfile} -returnCodes error -match glob \ -result {* EACCES} test winFCmd-7.10 {TraverseWinTree: can't read directory: handle == INVALID} \ {win emptyTest} { # can't make it happen } {} @@ -832,11 +862,11 @@ } -cleanup { cleanup } -result {tf1} test winFCmd-7.15 {TraverseWinTree: append \ to target if necessary} -setup { cleanup -} -constraints {win testfile} -body { +} -constraints {win nt testfile} -body { file mkdir td1 testfile cpdir td1 / } -cleanup { cleanup # Windows7 returns EEXIST, XP returns EACCES @@ -932,11 +962,11 @@ createfile td1/tf1 testfile rmdir -force td1 } -result {} test winFCmd-9.3 {TraversalDelete: DOTREE_PRED} -setup { cleanup -} -constraints {winVista testfile testchmod} -body { +} -constraints {winVista testfile testchmod notInCIenv} -body { file mkdir td1/td2 testchmod 0 td1 testfile rmdir -force td1 file exists td1 } -cleanup { @@ -1046,17 +1076,17 @@ } -result {./td1} test winFCmd-12.5 {ConvertFileNameFormat: absolute path} -body { list [file attributes / -longname] [file attributes \\ -longname] } -constraints {win} -result {/ /} test winFCmd-12.6 {ConvertFileNameFormat: absolute path with drive} -setup { - catch {file delete -force -- c:/td1} -} -constraints {win winXP} -body { - createfile c:/td1 {} - string tolower [file attributes c:/td1 -longname] + catch {file delete -force -- c:/TclTmpC.1} +} -constraints {win win2000orXP} -body { + createfile c:/TclTmpC.1 {} + string tolower [file attributes c:/TclTmpC.1 -longname] } -cleanup { - file delete -force -- c:/td1 -} -result {c:/td1} + file delete -force -- c:/TclTmpC.1 +} -result [string tolower {c:/TclTmpC.1}] test winFCmd-12.6.2 {ConvertFileNameFormat: absolute path with drive (in temp folder)} -setup { catch {file delete -force -- $::env(TEMP)/td1} } -constraints {win} -body { createfile $::env(TEMP)/td1 {} string equal [string tolower [file attributes $::env(TEMP)/td1 -longname]] \ @@ -1334,17 +1364,17 @@ } -result COM1 test winFCmd-18.8 {Windows reserved path names} -constraints win -body { file normalize cOm1: } -result COM1 -test winFCmd-19.1 {Windows extended path names} -constraints win -body { +test winFCmd-19.1 {Windows extended path names} -constraints nt -body { file normalize //?/c:/windows/win.ini } -result //?/c:/windows/win.ini -test winFCmd-19.2 {Windows extended path names} -constraints win -body { +test winFCmd-19.2 {Windows extended path names} -constraints nt -body { file normalize //?/c:/windows/../windows/win.ini } -result //?/c:/windows/win.ini -test winFCmd-19.3 {Windows extended path names} -constraints win -setup { +test winFCmd-19.3 {Windows extended path names} -constraints nt -setup { set tmpfile [file join $::env(TEMP) tcl[string repeat x 20].tmp] set tmpfile [file normalize $tmpfile] } -body { list [catch { set f [open $tmpfile [list WRONLY CREAT]] @@ -1351,11 +1381,11 @@ close $f } res] $res } -cleanup { catch {file delete $tmpfile} } -result [list 0 {}] -test winFCmd-19.4 {Windows extended path names} -constraints win -setup { +test winFCmd-19.4 {Windows extended path names} -constraints nt -setup { set tmpfile [file join $::env(TEMP) tcl[string repeat x 20].tmp] set tmpfile //?/[file normalize $tmpfile] } -body { list [catch { set f [open $tmpfile [list WRONLY CREAT]] @@ -1362,11 +1392,11 @@ close $f } res] $res } -cleanup { catch {file delete $tmpfile} } -result [list 0 {}] -test winFCmd-19.5 {Windows extended path names} -constraints win -setup { +test winFCmd-19.5 {Windows extended path names} -constraints nt -setup { set tmpfile [file join $::env(TEMP) tcl[string repeat x 248].tmp] set tmpfile [file normalize $tmpfile] } -body { list [catch { set f [open $tmpfile [list WRONLY CREAT]] @@ -1373,11 +1403,11 @@ close $f } res] $res } -cleanup { catch {file delete $tmpfile} } -result [list 0 {}] -test winFCmd-19.6 {Windows extended path names} -constraints win -setup { +test winFCmd-19.6 {Windows extended path names} -constraints nt -setup { set tmpfile [file join $::env(TEMP) tcl[string repeat x 248].tmp] set tmpfile //?/[file normalize $tmpfile] } -body { list [catch { set f [open $tmpfile [list WRONLY CREAT]] @@ -1384,11 +1414,11 @@ close $f } res] $res } -cleanup { catch {file delete $tmpfile} } -result [list 0 {}] -test winFCmd-19.7 {Windows extended path names} -constraints win -setup { +test winFCmd-19.7 {Windows extended path names} -constraints nt -setup { set tmpfile [file join $::env(TEMP) "tcl[pid].tmp "] set tmpfile [file normalize $tmpfile] } -body { list [catch { set f [open $tmpfile [list WRONLY CREAT]] @@ -1395,11 +1425,11 @@ close $f } res] $res [glob -directory $::env(TEMP) -tails tcl[pid].*] } -cleanup { catch {file delete $tmpfile} } -result [list 0 {} [list tcl[pid].tmp]] -test winFCmd-19.8 {Windows extended path names} -constraints win -setup { +test winFCmd-19.8 {Windows extended path names} -constraints nt -setup { set tmpfile [file join $::env(TEMP) "tcl[pid].tmp "] set tmpfile //?/[file normalize $tmpfile] } -body { list [catch { set f [open $tmpfile [list WRONLY CREAT]] @@ -1407,11 +1437,11 @@ } res] $res [glob -directory $::env(TEMP) -tails tcl[pid].*] } -cleanup { catch {file delete $tmpfile} } -result [list 0 {} [list "tcl[pid].tmp "]] -test winFCmd-19.9 {Windows devices path names} -constraints win -body { +test winFCmd-19.9 {Windows devices path names} -constraints nt -body { file normalize //./com1 } -result //./com1 # This block of code used to occur after the "return" call, so I'm Index: tests/winFile.test ================================================================== --- tests/winFile.test +++ tests/winFile.test @@ -8,34 +8,38 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[catch {package require tcltest 2.0.2}]} { - puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required." +if {[catch {package require tcltest 2.5}]} { + puts stderr "Skipping tests in [info script]. tcltest 2.5 required." return } namespace import -force ::tcltest::* ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] testConstraint testvolumetype [llength [info commands testvolumetype]] testConstraint notNTFS 0 +testConstraint win2000 0 if {[testConstraint testvolumetype]} { testConstraint notNTFS [expr {[testvolumetype] eq "NTFS"}] +} +if {[testConstraint nt] && $::tcl_platform(osVersion) >= 5.0} { + testConstraint win2000 1 } test winFile-1.1 {TclpGetUserHome} -constraints {win} -body { glob ~nosuchuser } -returnCodes error -result {user "nosuchuser" doesn't exist} -test winFile-1.2 {TclpGetUserHome} -constraints {win nonPortable} -body { +test winFile-1.2 {TclpGetUserHome} -constraints {win nt nonPortable} -body { # The administrator account should always exist. glob ~administrator } -match glob -result * -test winFile-1.4 {TclpGetUserHome} {win nonPortable} { +test winFile-1.4 {TclpGetUserHome} {win nt nonPortable} { catch {glob ~stanton@workgroup} } {0} test winFile-2.1 {TclpMatchFiles: case sensitivity} -constraints {win} -body { makeFile {} GlobCapS @@ -149,11 +153,11 @@ } test winFile-4.0 { Enhanced NTFS user/group permissions: test no acccess } -constraints { - win notNTFS + win nt notNTFS win2000 } -setup { set owner [getuser $fname] set user $::env(USERDOMAIN)\\$::env(USERNAME) } -body { # Clean out all well-known ACLs @@ -164,11 +168,11 @@ test_access $fname 0 0 } -result {} test winFile-4.1 { Enhanced NTFS user/group permissions: test readable only } -constraints { - win notNTFS + win nt notNTFS } -setup { set user $::env(USERDOMAIN)\\$::env(USERNAME) } -body { cacls $fname /E /P $user:N cacls $fname /E /G $user:R @@ -175,11 +179,11 @@ test_access $fname 1 0 } -result {} test winFile-4.2 { Enhanced NTFS user/group permissions: test writable only } -constraints { - win notNTFS + win nt notNTFS } -setup { set user $::env(USERDOMAIN)\\$::env(USERNAME) } -body { catch {cacls $fname /E /R $user} result cacls $fname /E /P $user:N @@ -187,11 +191,11 @@ test_access $fname 0 1 } -result {} test winFile-4.3 { Enhanced NTFS user/group permissions: test read+write } -constraints { - win notNTFS + win nt notNTFS } -setup { set user $::env(USERDOMAIN)\\$::env(USERNAME) } -body { catch {cacls $fname /E /R $user} result cacls $fname /E /P $user:N @@ -200,11 +204,11 @@ test_access $fname 1 1 } -result {} test winFile-4.4 { Enhanced NTFS user/group permissions: test full access } -constraints { - win notNTFS + win nt notNTFS } -setup { set user $::env(USERDOMAIN)\\$::env(USERNAME) } -body { catch {cacls $fname /E /R $user} result cacls $fname /E /P $user:N Index: tests/winNotify.test ================================================================== --- tests/winNotify.test +++ tests/winNotify.test @@ -8,12 +8,12 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] Index: tests/winPipe.test ================================================================== --- tests/winPipe.test +++ tests/winPipe.test @@ -10,11 +10,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest +package require tcltest 2.5 namespace import -force ::tcltest::* unset -nocomplain path catch { ::tcltest::loadTestedCommands @@ -37,11 +37,11 @@ testConstraint slowTest 0 set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n append big $big -append big $big +append big $big append big $big append big $big append big $big append big $big @@ -77,15 +77,15 @@ } {little stderr32} test winpipe-1.2 {32 bit comprehensive tests: from big file} {win exec cat32} { exec $cat32 < $path(big) > $path(stdout) 2> $path(stderr) list [contents $path(stdout)] [contents $path(stderr)] } "{$big} stderr32" -test winpipe-1.3 {32 bit comprehensive tests: a little from pipe} {win exec cat32} { +test winpipe-1.3 {32 bit comprehensive tests: a little from pipe} {win nt exec cat32} { exec [interpreter] $path(more) < $path(little) | $cat32 > $path(stdout) 2> $path(stderr) list [contents $path(stdout)] [contents $path(stderr)] } {little stderr32} -test winpipe-1.4 {32 bit comprehensive tests: a lot from pipe} {win exec cat32} { +test winpipe-1.4 {32 bit comprehensive tests: a lot from pipe} {win nt exec cat32} { exec [interpreter] $path(more) < $path(big) | $cat32 > $path(stdout) 2> $path(stderr) list [contents $path(stdout)] [contents $path(stderr)] } "{$big} stderr32" test winpipe-1.6 {32 bit comprehensive tests: from console} \ {win cat32 AllocConsole} { @@ -174,11 +174,11 @@ set r [read $f 64] catch {close $f} set r } "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" -test winpipe-4.1 {Tcl_WaitPid} {win exec cat32} { +test winpipe-4.1 {Tcl_WaitPid} {win nt exec cat32} { proc readResults {f} { global x result if { [eof $f] } { close $f set x 1 Index: tests/winTime.test ================================================================== --- tests/winTime.test +++ tests/winTime.test @@ -8,19 +8,22 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] testConstraint testwinclock [llength [info commands testwinclock]] +# 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)]}] # The next two tests will crash on Windows if the check for negative # clock values is not done properly. test winTime-1.1 {TclpGetDate} {win} { @@ -38,21 +41,21 @@ # Next test tries to make sure that the Tcl clock stays in step # with the Windows clock. 30 sec really isn't enough, # but how much time does a tester have patience for? -test winTime-2.1 {Synchronization of Tcl and Windows clocks} {testwinclock} { +test winTime-2.1 {Synchronization of Tcl and Windows clocks} {testwinclock notInCIenv} { # May fail due to OS/hardware discrepancies. See: # http://support.microsoft.com/default.aspx?scid=kb;en-us;274323 set failed {} set ok 1 foreach start_sec [testwinclock] break while { 1 } { foreach { sys_sec sys_usec tcl_sec tcl_usec } [testwinclock] break set diff [expr { $tcl_sec - $sys_sec + 1.0e-6 * ( $tcl_usec - $sys_usec ) }] - if { abs($diff) > 0.06 } { + if { abs($diff) > 0.1 } { set failed "Tcl clock differs from system clock by $diff sec" break } else { testwinsleep 1 } DELETED tests/zipfs.test Index: tests/zipfs.test ================================================================== --- tests/zipfs.test +++ /dev/null @@ -1,284 +0,0 @@ -# The file tests the tclZlib.c file. -# -# This file contains a collection of tests for one or more of the Tcl built-in -# commands. Sourcing this file into Tcl runs the tests and generates output -# for errors. No output means no errors were found. -# -# Copyright (c) 1996-1998 by Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# -# See the file "license.terms" for information on usage and redistribution of -# this file, and for a DISCLAIMER OF ALL WARRANTIES. - -if {"::tcltest" ni [namespace children]} { - package require tcltest 2.1 - namespace import -force ::tcltest::* -} - -testConstraint zipfs [expr { - [llength [info commands zlib]] && [regexp tcltest [info nameofexecutable]] -}] -testConstraint zipfslib 1 - -# Removed in tip430 - zipfs is no longer a static package -#test zipfs-0.0 {zipfs basics} -constraints zipfs -body { -# load {} zipfs -#} -result {} - -set ziproot [zipfs root] -set CWD [pwd] -set tmpdir [file join $CWD tmp] -file mkdir $tmpdir - -test zipfs-0.0 {zipfs basics} -constraints zipfs -body { - package require zipfs -} -result {2.0} -test zipfs-0.1 {zipfs basics} -constraints zipfs -body { - expr {${ziproot} in [file volumes]} -} -result 1 - -if {![string match ${ziproot}* $tcl_library]} { - ### - # "make test" does not map tcl_library from the dynamic library on Unix - # - # Hack the environment to pretend we did pull tcl_library from a zip - # archive - ### - set tclzip [file join $CWD [::tcl::pkgconfig get zipfile,runtime]] - testConstraint zipfslib [file exists $tclzip] - if {[testConstraint zipfslib]} { - zipfs mount /lib/tcl $tclzip - set ::tcl_library ${ziproot}lib/tcl/tcl_library - } -} - -test zipfs-0.2 {zipfs basics} -constraints zipfslib -body { - string match ${ziproot}* $tcl_library -} -result 1 -test zipfs-0.3 {zipfs basics: glob} -constraints zipfslib -setup { - set pwd [pwd] -} -body { - cd $tcl_library - expr { [file join . http] in [glob -dir . http*] } -} -cleanup { - cd $pwd -} -result 1 -test zipfs-0.4 {zipfs basics: glob} -constraints zipfslib -setup { - set pwd [pwd] -} -body { - cd $tcl_library - expr { [file join $tcl_library http] in [glob -dir [pwd] http*] } -} -cleanup { - cd $pwd -} -result 1 -test zipfs-0.5 {zipfs basics: glob} -constraints zipfslib -body { - expr { [file join $tcl_library http] in [glob -dir $tcl_library http*] } -} -result 1 -test zipfs-0.6 {zipfs basics: glob} -constraints zipfslib -body { - expr { [file join $tcl_library http] in [glob [file join $tcl_library http*]] } -} -result 1 -test zipfs-0.7 {zipfs basics: glob} -constraints zipfslib -body { - expr { "http" in [glob -tails -dir $tcl_library http*] } -} -result 1 -test zipfs-0.8 {zipfs basics: glob} -constraints zipfslib -body { - expr { "http" in [glob -nocomplain -tails -types d -dir $tcl_library http*] } -} -result 1 -test zipfs-0.9 {zipfs basics: glob} -constraints zipfslib -body { - glob -nocomplain -tails -types f -dir $tcl_library http* -} -result {} -test zipfs-0.10 {zipfs basics: join} -constraints {zipfs zipfslib} -body { - file join [zipfs root] bar baz -} -result "[zipfs root]bar/baz" -test zipfs-0.11 {zipfs basics: join} -constraints {zipfs zipfslib} -body { - file normalize [zipfs root] -} -result "[zipfs root]" -test zipfs-0.12 {zipfs basics: join} -constraints {zipfs zipfslib} -body { - file normalize [zipfs root]//bar/baz//qux/../ -} -result "[zipfs root]bar/baz" - -test zipfs-1.3 {zipfs errors} -constraints zipfs -returnCodes error -body { - zipfs mount a b c d e f -} -result {wrong # args: should be "zipfs mount ?mountpoint? ?zipfile? ?password?"} -test zipfs-1.4 {zipfs errors} -constraints zipfs -returnCodes error -body { - zipfs unmount a b c d e f -} -result {wrong # args: should be "zipfs unmount zipfile"} -test zipfs-1.5 {zipfs errors} -constraints zipfs -returnCodes error -body { - zipfs mkkey a b c d e f -} -result {wrong # args: should be "zipfs mkkey password"} -test zipfs-1.6 {zipfs errors} -constraints zipfs -returnCodes error -body { - zipfs mkimg a b c d e f -} -result {wrong # args: should be "zipfs mkimg outfile indir ?strip? ?password? ?infile?"} -test zipfs-1.7 {zipfs errors} -constraints zipfs -returnCodes error -body { - zipfs mkzip a b c d e f -} -result {wrong # args: should be "zipfs mkzip outfile indir ?strip? ?password?"} -test zipfs-1.8 {zipfs errors} -constraints zipfs -returnCodes error -body { - zipfs exists a b c d e f -} -result {wrong # args: should be "zipfs exists filename"} -test zipfs-1.9 {zipfs errors} -constraints zipfs -returnCodes error -body { - zipfs info a b c d e f -} -result {wrong # args: should be "zipfs info filename"} -test zipfs-1.10 {zipfs errors} -constraints zipfs -returnCodes error -body { - zipfs list a b c d e f -} -result {wrong # args: should be "zipfs list ?(-glob|-regexp)? ?pattern?"} - -file mkdir tmp -test zipfs-2.1 {zipfs mkzip empty archive} -constraints zipfs -returnCodes error -body { - zipfs mkzip [file join $tmpdir empty.zip] $tcl_library/xxxx -} -result {empty archive} -### -# The next series of tests operate within a zipfile created a temporary -# directory. -### -set zipfile [file join $tmpdir abc.zip] -if {[file exists $zipfile]} { - file delete $zipfile -} -test zipfs-2.2 {zipfs mkzip} -constraints zipfs -body { - cd $tcl_library/encoding - zipfs mkzip $zipfile . - zipfs mount ${ziproot}abc $zipfile - zipfs list -glob ${ziproot}abc/cp850.* -} -cleanup { - cd $CWD -} -result "[zipfs root]abc/cp850.enc" -testConstraint zipfsenc [zipfs exists /abc/cp850.enc] -test zipfs-2.3 {zipfs info} -constraints {zipfs zipfsenc} -body { - set r [zipfs info ${ziproot}abc/cp850.enc] - lrange $r 0 2 -} -result [list $zipfile 1090 527] ;# NOTE: Only the first 3 results are stable -test zipfs-2.4 {zipfs data} -constraints {zipfs zipfsenc} -body { - set zipfd [open ${ziproot}/abc/cp850.enc] ;# FIXME: leave open - see later test - read $zipfd -} -result {# Encoding file: cp850, single-byte -S -003F 0 1 -00 -0000000100020003000400050006000700080009000A000B000C000D000E000F -0010001100120013001400150016001700180019001A001B001C001D001E001F -0020002100220023002400250026002700280029002A002B002C002D002E002F -0030003100320033003400350036003700380039003A003B003C003D003E003F -0040004100420043004400450046004700480049004A004B004C004D004E004F -0050005100520053005400550056005700580059005A005B005C005D005E005F -0060006100620063006400650066006700680069006A006B006C006D006E006F -0070007100720073007400750076007700780079007A007B007C007D007E007F -00C700FC00E900E200E400E000E500E700EA00EB00E800EF00EE00EC00C400C5 -00C900E600C600F400F600F200FB00F900FF00D600DC00F800A300D800D70192 -00E100ED00F300FA00F100D100AA00BA00BF00AE00AC00BD00BC00A100AB00BB -2591259225932502252400C100C200C000A9256325512557255D00A200A52510 -25142534252C251C2500253C00E300C3255A25542569256625602550256C00A4 -00F000D000CA00CB00C8013100CD00CE00CF2518250C2588258400A600CC2580 -00D300DF00D400D200F500D500B500FE00DE00DA00DB00D900FD00DD00AF00B4 -00AD00B1201700BE00B600A700F700B800B000A800B700B900B300B225A000A0 -} ;# FIXME: result depends on content of encodings dir -test zipfs-2.5 {zipfs exists} -constraints {zipfs zipfsenc} -body { - zipfs exists /abc/cp850.enc -} -result 1 -test zipfs-2.6 {zipfs unmount while busy} -constraints {zipfs zipfsenc} -body { - zipfs unmount /abc -} -returnCodes error -result {filesystem is busy} -test zipfs-2.7 {zipfs unmount} -constraints {zipfs zipfsenc} -body { - close $zipfd - zipfs unmount /abc - zipfs exists /abc/cp850.enc -} -result 0 -### -# Repeat the tests for a buffer mounted archive -### -test zipfs-2.8 {zipfs mkzip} -constraints zipfs -body { - cd $tcl_library/encoding - zipfs mkzip $zipfile . - set fin [open $zipfile r] - fconfigure $fin -translation binary - set dat [read $fin] - close $fin - zipfs mount_data def $dat - zipfs list -glob ${ziproot}def/cp850.* -} -cleanup { - cd $CWD -} -result "[zipfs root]def/cp850.enc" -testConstraint zipfsencbuf [zipfs exists /def/cp850.enc] -test zipfs-2.9 {zipfs info} -constraints {zipfs zipfsencbuf} -body { - set r [zipfs info ${ziproot}def/cp850.enc] - lrange $r 0 2 -} -result [list {Memory Buffer} 1090 527] ;# NOTE: Only the first 3 results are stable -test zipfs-2.10 {zipfs data} -constraints {zipfs zipfsencbuf} -body { - set zipfd [open ${ziproot}/def/cp850.enc] ;# FIXME: leave open - see later test - read $zipfd -} -result {# Encoding file: cp850, single-byte -S -003F 0 1 -00 -0000000100020003000400050006000700080009000A000B000C000D000E000F -0010001100120013001400150016001700180019001A001B001C001D001E001F -0020002100220023002400250026002700280029002A002B002C002D002E002F -0030003100320033003400350036003700380039003A003B003C003D003E003F -0040004100420043004400450046004700480049004A004B004C004D004E004F -0050005100520053005400550056005700580059005A005B005C005D005E005F -0060006100620063006400650066006700680069006A006B006C006D006E006F -0070007100720073007400750076007700780079007A007B007C007D007E007F -00C700FC00E900E200E400E000E500E700EA00EB00E800EF00EE00EC00C400C5 -00C900E600C600F400F600F200FB00F900FF00D600DC00F800A300D800D70192 -00E100ED00F300FA00F100D100AA00BA00BF00AE00AC00BD00BC00A100AB00BB -2591259225932502252400C100C200C000A9256325512557255D00A200A52510 -25142534252C251C2500253C00E300C3255A25542569256625602550256C00A4 -00F000D000CA00CB00C8013100CD00CE00CF2518250C2588258400A600CC2580 -00D300DF00D400D200F500D500B500FE00DE00DA00DB00D900FD00DD00AF00B4 -00AD00B1201700BE00B600A700F700B800B000A800B700B900B300B225A000A0 -} ;# FIXME: result depends on content of encodings dir -test zipfs-2.11 {zipfs exists} -constraints {zipfs zipfsencbuf} -body { - zipfs exists /def/cp850.enc -} -result 1 -test zipfs-2.12 {zipfs unmount while busy} -constraints {zipfs zipfsencbuf} -body { - zipfs unmount /def -} -returnCodes error -result {filesystem is busy} -test zipfs-2.13 {zipfs unmount} -constraints {zipfs zipfsencbuf} -body { - close $zipfd - zipfs unmount /def - zipfs exists /def/cp850.enc -} -result 0 - -catch {file delete -force $tmpdir} - -test zipfs-3.1 {zipfs in child interpreters} -constraints zipfs -setup { - set interp [interp create] -} -body { - interp eval $interp { - zipfs ? - } -} -returnCodes error -cleanup { - interp delete $interp -} -result {unknown or ambiguous subcommand "?": must be canonical, exists, find, info, list, lmkimg, lmkzip, mkimg, mkkey, mkzip, mount, mount_data, root, or unmount} -test zipfs-3.2 {zipfs in child interpreters} -constraints zipfs -setup { - set interp [interp create] -} -body { - interp eval $interp { - zipfs mkzip - } -} -returnCodes error -cleanup { - interp delete $interp -} -result {wrong # args: should be "zipfs mkzip outfile indir ?strip? ?password?"} -test zipfs-3.3 {zipfs in child interpreters} -constraints zipfs -setup { - set safe [interp create -safe] -} -body { - interp eval $safe { - zipfs ? - } -} -returnCodes error -cleanup { - interp delete $safe -} -result {unknown or ambiguous subcommand "?": must be canonical, exists, find, info, list, lmkimg, lmkzip, mkimg, mkkey, mkzip, mount, mount_data, root, or unmount} -test zipfs-3.4 {zipfs in child interpreters} -constraints zipfs -setup { - set safe [interp create -safe] -} -body { - interp eval $safe { - zipfs mkzip - } -} -returnCodes error -cleanup { - interp delete $safe -} -result {not allowed to invoke subcommand mkzip of zipfs} - -::tcltest::cleanupTests -return - -# Local Variables: -# mode: tcl -# End: Index: tests/zlib.test ================================================================== --- tests/zlib.test +++ tests/zlib.test @@ -9,11 +9,11 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2.1 + package require tcltest 2.5 namespace import -force ::tcltest::* } testConstraint zlib [llength [info commands zlib]] testConstraint recentZlib 0 @@ -138,11 +138,11 @@ } -cleanup { catch {$s close} } -result "" # Also causes Tk Bug 10f2e7872b test zlib-7.8 {zlib stream: Bug b26e38a3e4} -constraints zlib -setup { - expr srand(12345) + expr {srand(12345)} set randdata {} for {set i 0} {$i<6001} {incr i} { append randdata [binary format c [expr {int(256*rand())}]] } } -body { @@ -449,11 +449,11 @@ } -result {358 358} test zlib-8.16 {Bug 3603553: buffer transfer with large writes} -setup { # Actual data isn't very important; needs to be substantially larger than # the internal buffer (32kB) and incompressible. set largeData {} - for {set i 0;expr srand(1)} {$i < 100000} {incr i} { + for {set i 0;expr {srand(1)}} {$i < 100000} {incr i} { append largeData [lindex "a b c d e f g h i j k l m n o p" \ [expr {int(16*rand())}]] } set file [makeFile {} test.gz] } -constraints zlib -body { @@ -918,11 +918,11 @@ close $srv rename bgerror {} rename zlibRead {} } -result {error {invalid block type}} -test zlib-11.1 "Bug #3390073: mis-appled gzip filtering" -setup { +test zlib-11.1 "Bug #3390073: mis-applied gzip filtering" -setup { set file [makeFile {} test.input] } -constraints zlib -body { set f [open $file wb] puts -nonewline [zlib push gzip $f] [string repeat "hello" 1000] close $f @@ -932,11 +932,11 @@ set d [zlib gunzip $d] list [regexp -all "hello" $d] [string length [regsub -all "hello" $d {}]] } -cleanup { removeFile $file } -result {1000 0} -test zlib-11.2 "Bug #3390073: mis-appled gzip filtering" -setup { +test zlib-11.2 "Bug #3390073: mis-applied gzip filtering" -setup { set file [makeFile {} test.input] } -constraints zlib -body { set f [open $file wb] puts -nonewline [zlib push gzip $f -header {filename /foo/bar}] \ [string repeat "hello" 1000] @@ -1003,12 +1003,92 @@ file size $filedst } -cleanup { removeFile $filesrc removeFile $filedst } -result 56 + +set zlibbinf "" +proc _zlibbinf {} { + # inlined zlib.bin file creator: + variable zlibbinf + if {$zlibbinf eq ""} { + set zlibbinf [makeFile {} test-zlib-13.bin] + set f [open $zlibbinf wb] + puts -nonewline $f [zlib decompress [binary decode base64 { + eJx7e+6s1+EAgYaLjK3ratptGmOck0vT/y/ZujHAd0qJelDBXfUPJ3tfrtLbpX+wOOFHmtn03/tizm + /+tXROXU3d203b79p5X6/0cvUyFzTsqOj4sa9r8SrZI5zT7265e2Xzq595Fb9LbpgffVy7cZaJ/d15 + 4U9L7LLM2vdqut8+aSU/r6q9Ltv6+T9mBhTgIK97bH33m/O1C1eBwf9FDKNgaIDaj9wA+5hToA== + }]] + close $f + } + return $zlibbinf +} +test zlib-13.1 {Ticket [8af92dfb66] - zlib stream mis-expansion} -constraints zlib -setup { + set pathin [_zlibbinf] + set chanin [open $pathin rb] + set pathout [makeFile {} test-zlib-13.deflated] + set chanout [open $pathout wb] + zlib push inflate $chanin + fcopy $chanin $chanout + close $chanin + close $chanout +} -body { + file size $pathout +} -cleanup { + removeFile $pathout + unset chanin pathin chanout pathout +} -result 458752 + +test zlib-13.2 {Ticket [f70ce1fead] - zlib multi-stream expansion} -constraints zlib -setup { + # Start from the basic asset + set pathin [_zlibbinf] + set chanin [open $pathin rb] + # Create a multi-stream by copying the asset twice into it. + set pathout [makeFile {} test-zlib-13.multi] + set chanout [open $pathout wb] + fcopy $chanin $chanout + seek $chanin 0 start + fcopy $chanin $chanout + close $chanin + close $chanout + # The multi-stream file shall be our input + set pathin $pathout + set chanin [open $pathin rb] + # And our destinations + set pathout1 [makeFile {} test-zlib-13.multi-1] + set pathout2 [makeFile {} test-zlib-13.multi-2] +} -body { + # Decode first stream + set chanout [open $pathout1 wb] + zlib push inflate $chanin + fcopy $chanin $chanout + chan pop $chanin + close $chanout + # Decode second stream + set chanout [open $pathout2 wb] + zlib push inflate $chanin + fcopy $chanin $chanout + chan pop $chanin + close $chanout + # + list [file size $pathout1] [file size $pathout2] +} -cleanup { + close $chanin + removeFile $pathout + removeFile $pathout1 + removeFile $pathout2 + unset chanin pathin chanout pathout pathout1 pathout2 +} -result {458752 458752} + +if {$zlibbinf ne ""} { + removeFile $zlibbinf +} +unset zlibbinf +rename _zlibbinf {} + ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: Index: tools/README ================================================================== --- tools/README +++ tools/README @@ -10,11 +10,11 @@ Generating HTML files. The tcl-tk-man-html.tcl script from Robert Critchlow generates a nice set of HTML with good cross references. Use it like - tclsh tcl-tk-man-html.tcl --htmldir=/tmp/tcl9.0 + tclsh tcl-tk-man-html.tcl --htmldir=/tmp/tcl8.2 This script is very picky about the organization of man pages, effectively acting as a style enforcer. Generating Windows Help Files: 1) Build tcl in the ../unix directory Index: tools/checkLibraryDoc.tcl ================================================================== --- tools/checkLibraryDoc.tcl +++ tools/checkLibraryDoc.tcl @@ -1,11 +1,11 @@ # checkLibraryDoc.tcl -- # # This script attempts to determine what APIs exist in the source base that # have not been documented. By grepping through all of the doc/*.3 man # pages, looking for "Pkg_*" (e.g., Tcl_ or Tk_), and comparing this list -# against the list of Pkg_ APIs found in the source (e.g., tcl9.0/*/*.[ch]) +# against the list of Pkg_ APIs found in the source (e.g., tcl8.6/*/*.[ch]) # we create six lists: # 1) APIs in Source not in Docs. # 2) APIs in Docs not in Source. # 3) Internal APIs and structs. # 4) Misc APIs and structs that we are not documenting. @@ -48,10 +48,12 @@ Tcl_ThreadId \ Tcl_Time \ Tcl_TimerToken \ Tcl_Token \ Tcl_Trace \ + Tcl_Value \ + Tcl_ValueType \ Tcl_Var \ Tk_3DBorder \ Tk_ArgvInfo \ Tk_BindingTable \ Tk_Canvas \ @@ -65,10 +67,11 @@ Tk_Font \ Tk_FontMetrics \ Tk_GeomMgr \ Tk_Image \ Tk_ImageMaster \ + Tk_ImageModel \ Tk_ImageType \ Tk_Item \ Tk_ItemType \ Tk_OptionSpec\ Tk_OptionTable \ @@ -102,11 +105,10 @@ set len [llength $argv] if {($len != 2) && ($len != 3)} { puts "usage: $argv0 pkgName pkgDir \[outFile\]" puts " pkgName == Tcl,Tk" - puts " pkgDir == /home/surles/cvs/tcl9.0" exit 1 } set pkg [lindex $argv 0] set dir [lindex $argv 1] Index: tools/configure ================================================================== --- tools/configure +++ tools/configure @@ -1,650 +1,285 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.69. +# Generated by GNU Autoconf 2.59. # -# -# Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. -# -# +# Copyright (C) 2003 Free Software Foundation, Inc. # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. -## -------------------- ## -## M4sh Initialization. ## -## -------------------- ## +## --------------------- ## +## M4sh Initialization. ## +## --------------------- ## -# Be more Bourne compatible -DUALCASE=1; export DUALCASE # for MKS sh -if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : +# Be Bourne compatible +if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then emulate sh NULLCMD=: - # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which + # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' - setopt NO_GLOB_SUBST -else - case `(set -o) 2>/dev/null` in #( - *posix*) : - set -o posix ;; #( - *) : - ;; -esac -fi - - -as_nl=' -' -export as_nl -# Printing a long string crashes Solaris 7 /usr/bin/printf. -as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' -as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo -as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo -# Prefer a ksh shell builtin over an external printf program on Solaris, -# but without wasting forks for bash or zsh. -if test -z "$BASH_VERSION$ZSH_VERSION" \ - && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then - as_echo='print -r --' - as_echo_n='print -rn --' -elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then - as_echo='printf %s\n' - as_echo_n='printf %s' -else - if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then - as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' - as_echo_n='/usr/ucb/echo -n' - else - as_echo_body='eval expr "X$1" : "X\\(.*\\)"' - as_echo_n_body='eval - arg=$1; - case $arg in #( - *"$as_nl"*) - expr "X$arg" : "X\\(.*\\)$as_nl"; - arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; - esac; - expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" - ' - export as_echo_n_body - as_echo_n='sh -c $as_echo_n_body as_echo' - fi - export as_echo_body - as_echo='sh -c $as_echo_body as_echo' -fi - -# The user is always right. -if test "${PATH_SEPARATOR+set}" != set; then - PATH_SEPARATOR=: - (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { - (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || - PATH_SEPARATOR=';' - } -fi - - -# IFS -# We need space, tab and new line, in precisely that order. Quoting is -# there to prevent editors from complaining about space-tab. -# (If _AS_PATH_WALK were called with IFS unset, it would disable word -# splitting by setting IFS to empty value.) -IFS=" "" $as_nl" - -# Find who we are. Look in the path if we contain no directory separator. -as_myself= -case $0 in #(( - *[\\/]* ) as_myself=$0 ;; - *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break - done -IFS=$as_save_IFS - - ;; -esac -# We did not find ourselves, most probably we were run as `sh COMMAND' -# in which case we are not to be found in the path. -if test "x$as_myself" = x; then - as_myself=$0 -fi -if test ! -f "$as_myself"; then - $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 - exit 1 -fi - -# Unset variables that we do not need and which cause bugs (e.g. in -# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" -# suppresses any "Segmentation fault" message there. '((' could -# trigger a bug in pdksh 5.2.14. -for as_var in BASH_ENV ENV MAIL MAILPATH -do eval test x\${$as_var+set} = xset \ - && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : -done +elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then + set -o posix +fi +DUALCASE=1; export DUALCASE # for MKS sh + +# Support unset when possible. +if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then + as_unset=unset +else + as_unset=false +fi + + +# Work around bugs in pre-3.0 UWIN ksh. +$as_unset ENV MAIL MAILPATH PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. -LC_ALL=C -export LC_ALL -LANGUAGE=C -export LANGUAGE - -# CDPATH. -(unset CDPATH) >/dev/null 2>&1 && unset CDPATH - -# Use a proper internal environment variable to ensure we don't fall - # into an infinite loop, continuously re-executing ourselves. - if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then - _as_can_reexec=no; export _as_can_reexec; - # We cannot yet assume a decent shell, so we have to provide a -# neutralization value for shells without unset; and this also -# works around shells that cannot unset nonexistent variables. -# Preserve -v and -x to the replacement shell. -BASH_ENV=/dev/null -ENV=/dev/null -(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV -case $- in # (((( - *v*x* | *x*v* ) as_opts=-vx ;; - *v* ) as_opts=-v ;; - *x* ) as_opts=-x ;; - * ) as_opts= ;; -esac -exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} -# Admittedly, this is quite paranoid, since all the known shells bail -# out after a failed `exec'. -$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 -as_fn_exit 255 - fi - # We don't want this to propagate to other subprocesses. - { _as_can_reexec=; unset _as_can_reexec;} -if test "x$CONFIG_SHELL" = x; then - as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then : - emulate sh - NULLCMD=: - # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which - # is contrary to our usage. Disable this feature. - alias -g '\${1+\"\$@\"}'='\"\$@\"' - setopt NO_GLOB_SUBST -else - case \`(set -o) 2>/dev/null\` in #( - *posix*) : - set -o posix ;; #( - *) : - ;; -esac -fi -" - as_required="as_fn_return () { (exit \$1); } -as_fn_success () { as_fn_return 0; } -as_fn_failure () { as_fn_return 1; } -as_fn_ret_success () { return 0; } -as_fn_ret_failure () { return 1; } - -exitcode=0 -as_fn_success || { exitcode=1; echo as_fn_success failed.; } -as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } -as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } -as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } -if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then : - -else - exitcode=1; echo positional parameters were not saved. -fi -test x\$exitcode = x0 || exit 1 -test -x / || exit 1" - as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO - as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO - eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && - test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1" - if (eval "$as_required") 2>/dev/null; then : - as_have_required=yes -else - as_have_required=no -fi - if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then : - -else - as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -as_found=false -for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - as_found=: - case $as_dir in #( - /*) - for as_base in sh bash ksh sh5; do - # Try only shells that exist, to save several forks. - as_shell=$as_dir/$as_base - if { test -f "$as_shell" || test -f "$as_shell.exe"; } && - { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then : - CONFIG_SHELL=$as_shell as_have_required=yes - if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then : - break 2 -fi -fi - done;; - esac - as_found=false -done -$as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } && - { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then : - CONFIG_SHELL=$SHELL as_have_required=yes -fi; } -IFS=$as_save_IFS - - - if test "x$CONFIG_SHELL" != x; then : - export CONFIG_SHELL - # We cannot yet assume a decent shell, so we have to provide a -# neutralization value for shells without unset; and this also -# works around shells that cannot unset nonexistent variables. -# Preserve -v and -x to the replacement shell. -BASH_ENV=/dev/null -ENV=/dev/null -(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV -case $- in # (((( - *v*x* | *x*v* ) as_opts=-vx ;; - *v* ) as_opts=-v ;; - *x* ) as_opts=-x ;; - * ) as_opts= ;; -esac -exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} -# Admittedly, this is quite paranoid, since all the known shells bail -# out after a failed `exec'. -$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 -exit 255 -fi - - if test x$as_have_required = xno; then : - $as_echo "$0: This script requires a shell more modern than all" - $as_echo "$0: the shells that I found on your system." - if test x${ZSH_VERSION+set} = xset ; then - $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should" - $as_echo "$0: be upgraded to zsh 4.3.4 or later." - else - $as_echo "$0: Please tell bug-autoconf@gnu.org about your system, -$0: including any error possibly output before this -$0: message. Then install a modern shell, or manually run -$0: the script under such a shell if you do have one." - fi - exit 1 -fi -fi -fi -SHELL=${CONFIG_SHELL-/bin/sh} -export SHELL -# Unset more variables known to interfere with behavior of common tools. -CLICOLOR_FORCE= GREP_OPTIONS= -unset CLICOLOR_FORCE GREP_OPTIONS - -## --------------------- ## -## M4sh Shell Functions. ## -## --------------------- ## -# as_fn_unset VAR -# --------------- -# Portably unset VAR. -as_fn_unset () -{ - { eval $1=; unset $1;} -} -as_unset=as_fn_unset - -# as_fn_set_status STATUS -# ----------------------- -# Set $? to STATUS, without forking. -as_fn_set_status () -{ - return $1 -} # as_fn_set_status - -# as_fn_exit STATUS -# ----------------- -# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. -as_fn_exit () -{ - set +e - as_fn_set_status $1 - exit $1 -} # as_fn_exit - -# as_fn_mkdir_p -# ------------- -# Create "$as_dir" as a directory, including parents if necessary. -as_fn_mkdir_p () -{ - - case $as_dir in #( - -*) as_dir=./$as_dir;; - esac - test -d "$as_dir" || eval $as_mkdir_p || { - as_dirs= - while :; do - case $as_dir in #( - *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( - *) as_qdir=$as_dir;; - esac - as_dirs="'$as_qdir' $as_dirs" - as_dir=`$as_dirname -- "$as_dir" || -$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$as_dir" : 'X\(//\)[^/]' \| \ - X"$as_dir" : 'X\(//\)$' \| \ - X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X"$as_dir" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - test -d "$as_dir" && break - done - test -z "$as_dirs" || eval "mkdir $as_dirs" - } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" - - -} # as_fn_mkdir_p - -# as_fn_executable_p FILE -# ----------------------- -# Test if FILE is an executable regular file. -as_fn_executable_p () -{ - test -f "$1" && test -x "$1" -} # as_fn_executable_p -# as_fn_append VAR VALUE -# ---------------------- -# Append the text in VALUE to the end of the definition contained in VAR. Take -# advantage of any shell optimizations that allow amortized linear growth over -# repeated appends, instead of the typical quadratic growth present in naive -# implementations. -if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : - eval 'as_fn_append () - { - eval $1+=\$2 - }' -else - as_fn_append () - { - eval $1=\$$1\$2 - } -fi # as_fn_append - -# as_fn_arith ARG... -# ------------------ -# Perform arithmetic evaluation on the ARGs, and store the result in the -# global $as_val. Take advantage of shells that can avoid forks. The arguments -# must be portable across $(()) and expr. -if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : - eval 'as_fn_arith () - { - as_val=$(( $* )) - }' -else - as_fn_arith () - { - as_val=`expr "$@" || test $? -eq 1` - } -fi # as_fn_arith - - -# as_fn_error STATUS ERROR [LINENO LOG_FD] -# ---------------------------------------- -# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are -# provided, also output the error to LOG_FD, referencing LINENO. Then exit the -# script with STATUS, using 1 if that was 0. -as_fn_error () -{ - as_status=$1; test $as_status -eq 0 && as_status=1 - if test "$4"; then - as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 - fi - $as_echo "$as_me: error: $2" >&2 - as_fn_exit $as_status -} # as_fn_error - -if expr a : '\(a\)' >/dev/null 2>&1 && - test "X`expr 00001 : '.*\(...\)'`" = X001; then +for as_var in \ + LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \ + LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \ + LC_TELEPHONE LC_TIME +do + if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then + eval $as_var=C; export $as_var + else + $as_unset $as_var + fi +done + +# Required to use basename. +if expr a : '\(a\)' >/dev/null 2>&1; then as_expr=expr else as_expr=false fi -if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then +if (basename /) >/dev/null 2>&1 && test "X`basename / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi -if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then - as_dirname=dirname -else - as_dirname=false -fi -as_me=`$as_basename -- "$0" || +# Name of the executable. +as_me=`$as_basename "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ - X"$0" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X/"$0" | - sed '/^.*\/\([^/][^/]*\)\/*$/{ - s//\1/ - q - } - /^X\/\(\/\/\)$/{ - s//\1/ - q - } - /^X\/\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - + X"$0" : 'X\(/\)$' \| \ + . : '\(.\)' 2>/dev/null || +echo X/"$0" | + sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/; q; } + /^X\/\(\/\/\)$/{ s//\1/; q; } + /^X\/\(\/\).*/{ s//\1/; q; } + s/.*/./; q'` + + +# PATH needs CR, and LINENO needs CR and PATH. # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits - - as_lineno_1=$LINENO as_lineno_1a=$LINENO - as_lineno_2=$LINENO as_lineno_2a=$LINENO - eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && - test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { - # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) - sed -n ' - p - /[$]LINENO/= - ' <$as_myself | - sed ' - s/[$]LINENO.*/&-/ - t lineno - b - :lineno - N - :loop - s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ - t loop - s/-\n.*// - ' >$as_me.lineno && - chmod +x "$as_me.lineno" || - { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } - - # If we had to re-execute with $CONFIG_SHELL, we're ensured to have - # already done that, so ensure we don't try to do so again and fall - # in an infinite loop. This has already happened in practice. - _as_can_reexec=no; export _as_can_reexec +# The user is always right. +if test "${PATH_SEPARATOR+set}" != set; then + echo "#! /bin/sh" >conf$$.sh + echo "exit 0" >>conf$$.sh + chmod +x conf$$.sh + if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then + PATH_SEPARATOR=';' + else + PATH_SEPARATOR=: + fi + rm -f conf$$.sh +fi + + + as_lineno_1=$LINENO + as_lineno_2=$LINENO + as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` + test "x$as_lineno_1" != "x$as_lineno_2" && + test "x$as_lineno_3" = "x$as_lineno_2" || { + # Find who we are. Look in the path if we contain no path at all + # relative or not. + case $0 in + *[\\/]* ) as_myself=$0 ;; + *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break +done + + ;; + esac + # We did not find ourselves, most probably we were run as `sh COMMAND' + # in which case we are not to be found in the path. + if test "x$as_myself" = x; then + as_myself=$0 + fi + if test ! -f "$as_myself"; then + { echo "$as_me: error: cannot find myself; rerun with an absolute path" >&2 + { (exit 1); exit 1; }; } + fi + case $CONFIG_SHELL in + '') + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for as_base in sh bash ksh sh5; do + case $as_dir in + /*) + if ("$as_dir/$as_base" -c ' + as_lineno_1=$LINENO + as_lineno_2=$LINENO + as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` + test "x$as_lineno_1" != "x$as_lineno_2" && + test "x$as_lineno_3" = "x$as_lineno_2" ') 2>/dev/null; then + $as_unset BASH_ENV || test "${BASH_ENV+set}" != set || { BASH_ENV=; export BASH_ENV; } + $as_unset ENV || test "${ENV+set}" != set || { ENV=; export ENV; } + CONFIG_SHELL=$as_dir/$as_base + export CONFIG_SHELL + exec "$CONFIG_SHELL" "$0" ${1+"$@"} + fi;; + esac + done +done +;; + esac + + # Create $as_me.lineno as a copy of $as_myself, but with $LINENO + # uniformly replaced by the line number. The first 'sed' inserts a + # line-number line before each line; the second 'sed' does the real + # work. The second script uses 'N' to pair each line-number line + # with the numbered line, and appends trailing '-' during + # substitution so that $LINENO is not a special case at line end. + # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the + # second 'sed' script. Blame Lee E. McMahon for sed's syntax. :-) + sed '=' <$as_myself | + sed ' + N + s,$,-, + : loop + s,^\(['$as_cr_digits']*\)\(.*\)[$]LINENO\([^'$as_cr_alnum'_]\),\1\2\1\3, + t loop + s,-$,, + s,^['$as_cr_digits']*\n,, + ' >$as_me.lineno && + chmod +x $as_me.lineno || + { echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2 + { (exit 1); exit 1; }; } + # Don't try to exec as it changes $[0], causing all sort of problems # (the dirname of $[0] is not the place where we might find the - # original and so on. Autoconf is especially sensitive to this). - . "./$as_me.lineno" + # original and so on. Autoconf is especially sensible to this). + . ./$as_me.lineno # Exit status is that of the last command. exit } -ECHO_C= ECHO_N= ECHO_T= -case `echo -n x` in #((((( --n*) - case `echo 'xy\c'` in - *c*) ECHO_T=' ';; # ECHO_T is single tab character. - xy) ECHO_C='\c';; - *) echo `echo ksh88 bug on AIX 6.1` > /dev/null - ECHO_T=' ';; - esac;; -*) - ECHO_N='-n';; + +case `echo "testing\c"; echo 1,2,3`,`echo -n testing; echo 1,2,3` in + *c*,-n*) ECHO_N= ECHO_C=' +' ECHO_T=' ' ;; + *c*,* ) ECHO_N=-n ECHO_C= ECHO_T= ;; + *) ECHO_N= ECHO_C='\c' ECHO_T= ;; esac + +if expr a : '\(a\)' >/dev/null 2>&1; then + as_expr=expr +else + as_expr=false +fi rm -f conf$$ conf$$.exe conf$$.file -if test -d conf$$.dir; then - rm -f conf$$.dir/conf$$.file -else - rm -f conf$$.dir - mkdir conf$$.dir 2>/dev/null -fi -if (echo >conf$$.file) 2>/dev/null; then - if ln -s conf$$.file conf$$ 2>/dev/null; then +echo >conf$$.file +if ln -s conf$$.file conf$$ 2>/dev/null; then + # We could just check for DJGPP; but this test a) works b) is more generic + # and c) will remain valid once DJGPP supports symlinks (DJGPP 2.04). + if test -f conf$$.exe; then + # Don't use ln at all; we don't have any links + as_ln_s='cp -p' + else as_ln_s='ln -s' - # ... but there are two gotchas: - # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. - # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. - # In both cases, we have to default to `cp -pR'. - ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || - as_ln_s='cp -pR' - elif ln conf$$.file conf$$ 2>/dev/null; then - as_ln_s=ln - else - as_ln_s='cp -pR' - fi -else - as_ln_s='cp -pR' -fi -rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file -rmdir conf$$.dir 2>/dev/null + fi +elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln +else + as_ln_s='cp -p' +fi +rm -f conf$$ conf$$.exe conf$$.file if mkdir -p . 2>/dev/null; then - as_mkdir_p='mkdir -p "$as_dir"' + as_mkdir_p=: else test -d ./-p && rmdir ./-p as_mkdir_p=false fi -as_test_x='test -x' -as_executable_p=as_fn_executable_p +as_executable_p="test -f" # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" -test -n "$DJDIR" || exec 7<&0 &1 +# IFS +# We need space, tab and new line, in precisely that order. +as_nl=' +' +IFS=" $as_nl" + +# CDPATH. +$as_unset CDPATH + # Name of the host. -# hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, +# hostname on some systems (SVR3.2, Linux) returns a bogus exit status, # so uname gets run too. ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` + +exec 6>&1 # # Initializations. # ac_default_prefix=/usr/local -ac_clean_files= ac_config_libobj_dir=. -LIBOBJS= cross_compiling=no subdirs= MFLAGS= MAKEFLAGS= +SHELL=${CONFIG_SHELL-/bin/sh} + +# Maximum number of lines to put in a shell here document. +# This variable seems obsolete. It should probably be removed, and +# only ac_max_sed_lines should be used. +: ${ac_max_here_lines=38} # Identity of this package. PACKAGE_NAME= PACKAGE_TARNAME= PACKAGE_VERSION= PACKAGE_STRING= PACKAGE_BUGREPORT= -PACKAGE_URL= ac_unique_file="man2tcl.c" -ac_subst_vars='LTLIBOBJS -LIBOBJS -TCL_BIN_DIR -TCL_SRC_DIR -TCL_PATCH_LEVEL -TCL_VERSION -CC -TCL_WIN_VERSION -target_alias -host_alias -build_alias -LIBS -ECHO_T -ECHO_N -ECHO_C -DEFS -mandir -localedir -libdir -psdir -pdfdir -dvidir -htmldir -infodir -docdir -oldincludedir -includedir -localstatedir -sharedstatedir -sysconfdir -datadir -datarootdir -libexecdir -sbindir -bindir -program_transform_name -prefix -exec_prefix -PACKAGE_URL -PACKAGE_BUGREPORT -PACKAGE_STRING -PACKAGE_VERSION -PACKAGE_TARNAME -PACKAGE_NAME -PATH_SEPARATOR -SHELL' +ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS TCL_WIN_VERSION CC TCL_VERSION TCL_PATCH_LEVEL TCL_SRC_DIR TCL_BIN_DIR LIBOBJS LTLIBOBJS' ac_subst_files='' -ac_user_opts=' -enable_option_checking -with_tcl -' - ac_precious_vars='build_alias -host_alias -target_alias' - # Initialize some variables set by options. ac_init_help= ac_init_version=false -ac_unrecognized_opts= -ac_unrecognized_sep= # The variables have the same names as the options, with # dashes changed to underlines. cache_file=/dev/null exec_prefix=NONE no_create= @@ -663,53 +298,38 @@ # Installation directory options. # These are left unexpanded so users can "make install exec_prefix=/foo" # and all the variables that are supposed to be based on exec_prefix # by default will actually change. # Use braces instead of parens because sh, perl, etc. also accept them. -# (The list follows the same order as the GNU Coding Standards.) bindir='${exec_prefix}/bin' sbindir='${exec_prefix}/sbin' libexecdir='${exec_prefix}/libexec' -datarootdir='${prefix}/share' -datadir='${datarootdir}' +datadir='${prefix}/share' sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var' +libdir='${exec_prefix}/lib' includedir='${prefix}/include' oldincludedir='/usr/include' -docdir='${datarootdir}/doc/${PACKAGE}' -infodir='${datarootdir}/info' -htmldir='${docdir}' -dvidir='${docdir}' -pdfdir='${docdir}' -psdir='${docdir}' -libdir='${exec_prefix}/lib' -localedir='${datarootdir}/locale' -mandir='${datarootdir}/man' +infodir='${prefix}/info' +mandir='${prefix}/man' ac_prev= -ac_dashdash= for ac_option do # If the previous option needs an argument, assign it. if test -n "$ac_prev"; then - eval $ac_prev=\$ac_option + eval "$ac_prev=\$ac_option" ac_prev= continue fi - case $ac_option in - *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; - *=) ac_optarg= ;; - *) ac_optarg=yes ;; - esac + ac_optarg=`expr "x$ac_option" : 'x[^=]*=\(.*\)'` # Accept the important Cygnus configure options, so we can diagnose typos. - case $ac_dashdash$ac_option in - --) - ac_dashdash=yes ;; + case $ac_option in -bindir | --bindir | --bindi | --bind | --bin | --bi) ac_prev=bindir ;; -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) bindir=$ac_optarg ;; @@ -727,63 +347,37 @@ cache_file=$ac_optarg ;; --config-cache | -C) cache_file=config.cache ;; - -datadir | --datadir | --datadi | --datad) + -datadir | --datadir | --datadi | --datad | --data | --dat | --da) ac_prev=datadir ;; - -datadir=* | --datadir=* | --datadi=* | --datad=*) + -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \ + | --da=*) datadir=$ac_optarg ;; - -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ - | --dataroo | --dataro | --datar) - ac_prev=datarootdir ;; - -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ - | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) - datarootdir=$ac_optarg ;; - -disable-* | --disable-*) - ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` + ac_feature=`expr "x$ac_option" : 'x-*disable-\(.*\)'` # Reject names that are not valid shell variable names. - expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid feature name: $ac_useropt" - ac_useropt_orig=$ac_useropt - ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` - case $ac_user_opts in - *" -"enable_$ac_useropt" -"*) ;; - *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" - ac_unrecognized_sep=', ';; - esac - eval enable_$ac_useropt=no ;; - - -docdir | --docdir | --docdi | --doc | --do) - ac_prev=docdir ;; - -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) - docdir=$ac_optarg ;; - - -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) - ac_prev=dvidir ;; - -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) - dvidir=$ac_optarg ;; + expr "x$ac_feature" : ".*[^-_$as_cr_alnum]" >/dev/null && + { echo "$as_me: error: invalid feature name: $ac_feature" >&2 + { (exit 1); exit 1; }; } + ac_feature=`echo $ac_feature | sed 's/-/_/g'` + eval "enable_$ac_feature=no" ;; -enable-* | --enable-*) - ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` + ac_feature=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` # Reject names that are not valid shell variable names. - expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid feature name: $ac_useropt" - ac_useropt_orig=$ac_useropt - ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` - case $ac_user_opts in - *" -"enable_$ac_useropt" -"*) ;; - *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" - ac_unrecognized_sep=', ';; + expr "x$ac_feature" : ".*[^-_$as_cr_alnum]" >/dev/null && + { echo "$as_me: error: invalid feature name: $ac_feature" >&2 + { (exit 1); exit 1; }; } + ac_feature=`echo $ac_feature | sed 's/-/_/g'` + case $ac_option in + *=*) ac_optarg=`echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"`;; + *) ac_optarg=yes ;; esac - eval enable_$ac_useropt=\$ac_optarg ;; + eval "enable_$ac_feature='$ac_optarg'" ;; -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ | --exec | --exe | --ex) ac_prev=exec_prefix ;; @@ -806,16 +400,10 @@ -host | --host | --hos | --ho) ac_prev=host_alias ;; -host=* | --host=* | --hos=* | --ho=*) host_alias=$ac_optarg ;; - -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) - ac_prev=htmldir ;; - -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ - | --ht=*) - htmldir=$ac_optarg ;; - -includedir | --includedir | --includedi | --included | --include \ | --includ | --inclu | --incl | --inc) ac_prev=includedir ;; -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ | --includ=* | --inclu=* | --incl=* | --inc=*) @@ -836,20 +424,17 @@ ac_prev=libexecdir ;; -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ | --libexe=* | --libex=* | --libe=*) libexecdir=$ac_optarg ;; - -localedir | --localedir | --localedi | --localed | --locale) - ac_prev=localedir ;; - -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) - localedir=$ac_optarg ;; - -localstatedir | --localstatedir | --localstatedi | --localstated \ - | --localstate | --localstat | --localsta | --localst | --locals) + | --localstate | --localstat | --localsta | --localst \ + | --locals | --local | --loca | --loc | --lo) ac_prev=localstatedir ;; -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ - | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) + | --localstate=* | --localstat=* | --localsta=* | --localst=* \ + | --locals=* | --local=* | --loca=* | --loc=* | --lo=*) localstatedir=$ac_optarg ;; -mandir | --mandir | --mandi | --mand | --man | --ma | --m) ac_prev=mandir ;; -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) @@ -910,20 +495,10 @@ | --program-transfo=* | --program-transf=* \ | --program-trans=* | --program-tran=* \ | --progr-tra=* | --program-tr=* | --program-t=*) program_transform_name=$ac_optarg ;; - -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) - ac_prev=pdfdir ;; - -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) - pdfdir=$ac_optarg ;; - - -psdir | --psdir | --psdi | --psd | --ps) - ac_prev=psdir ;; - -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) - psdir=$ac_optarg ;; - -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) silent=yes ;; -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) @@ -970,40 +545,30 @@ -version | --version | --versio | --versi | --vers | -V) ac_init_version=: ;; -with-* | --with-*) - ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` + ac_package=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` # Reject names that are not valid shell variable names. - expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid package name: $ac_useropt" - ac_useropt_orig=$ac_useropt - ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` - case $ac_user_opts in - *" -"with_$ac_useropt" -"*) ;; - *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" - ac_unrecognized_sep=', ';; + expr "x$ac_package" : ".*[^-_$as_cr_alnum]" >/dev/null && + { echo "$as_me: error: invalid package name: $ac_package" >&2 + { (exit 1); exit 1; }; } + ac_package=`echo $ac_package| sed 's/-/_/g'` + case $ac_option in + *=*) ac_optarg=`echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"`;; + *) ac_optarg=yes ;; esac - eval with_$ac_useropt=\$ac_optarg ;; + eval "with_$ac_package='$ac_optarg'" ;; -without-* | --without-*) - ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` + ac_package=`expr "x$ac_option" : 'x-*without-\(.*\)'` # Reject names that are not valid shell variable names. - expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid package name: $ac_useropt" - ac_useropt_orig=$ac_useropt - ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` - case $ac_user_opts in - *" -"with_$ac_useropt" -"*) ;; - *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" - ac_unrecognized_sep=', ';; - esac - eval with_$ac_useropt=no ;; + expr "x$ac_package" : ".*[^-_$as_cr_alnum]" >/dev/null && + { echo "$as_me: error: invalid package name: $ac_package" >&2 + { (exit 1); exit 1; }; } + ac_package=`echo $ac_package | sed 's/-/_/g'` + eval "with_$ac_package=no" ;; --x) # Obsolete; use --with-x. with_x=yes ;; @@ -1019,67 +584,63 @@ ac_prev=x_libraries ;; -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) x_libraries=$ac_optarg ;; - -*) as_fn_error $? "unrecognized option: \`$ac_option' -Try \`$0 --help' for more information" + -*) { echo "$as_me: error: unrecognized option: $ac_option +Try \`$0 --help' for more information." >&2 + { (exit 1); exit 1; }; } ;; *=*) ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` # Reject names that are not valid shell variable names. - case $ac_envvar in #( - '' | [0-9]* | *[!_$as_cr_alnum]* ) - as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; - esac - eval $ac_envvar=\$ac_optarg + expr "x$ac_envvar" : ".*[^_$as_cr_alnum]" >/dev/null && + { echo "$as_me: error: invalid variable name: $ac_envvar" >&2 + { (exit 1); exit 1; }; } + ac_optarg=`echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` + eval "$ac_envvar='$ac_optarg'" export $ac_envvar ;; *) # FIXME: should be removed in autoconf 3.0. - $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 + echo "$as_me: WARNING: you should use --build, --host, --target" >&2 expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && - $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 - : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" + echo "$as_me: WARNING: invalid host type: $ac_option" >&2 + : ${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option} ;; esac done if test -n "$ac_prev"; then ac_option=--`echo $ac_prev | sed 's/_/-/g'` - as_fn_error $? "missing argument to $ac_option" -fi - -if test -n "$ac_unrecognized_opts"; then - case $enable_option_checking in - no) ;; - fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; - *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; - esac -fi - -# Check all directory arguments for consistency. -for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ - datadir sysconfdir sharedstatedir localstatedir includedir \ - oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ - libdir localedir mandir -do - eval ac_val=\$$ac_var - # Remove trailing slashes. - case $ac_val in - */ ) - ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` - eval $ac_var=\$ac_val;; - esac - # Be sure to have absolute directory names. - case $ac_val in - [\\/$]* | ?:[\\/]* ) continue;; - NONE | '' ) case $ac_var in *prefix ) continue;; esac;; - esac - as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" + { echo "$as_me: error: missing argument to $ac_option" >&2 + { (exit 1); exit 1; }; } +fi + +# Be sure to have absolute paths. +for ac_var in exec_prefix prefix +do + eval ac_val=$`echo $ac_var` + case $ac_val in + [\\/$]* | ?:[\\/]* | NONE | '' ) ;; + *) { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2 + { (exit 1); exit 1; }; };; + esac +done + +# Be sure to have absolute paths. +for ac_var in bindir sbindir libexecdir datadir sysconfdir sharedstatedir \ + localstatedir libdir includedir oldincludedir infodir mandir +do + eval ac_val=$`echo $ac_var` + case $ac_val in + [\\/$]* | ?:[\\/]* ) ;; + *) { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2 + { (exit 1); exit 1; }; };; + esac done # There might be people who depend on the old broken behavior: `$host' # used to hold the argument of --host etc. # FIXME: To remove some day. @@ -1089,10 +650,12 @@ # FIXME: To remove some day. if test "x$host_alias" != x; then if test "x$build_alias" = x; then cross_compiling=maybe + echo "$as_me: WARNING: If you wanted to set the --build type, don't use --host. + If a cross compiler is detected then cross compile mode will be used." >&2 elif test "x$build_alias" != "x$host_alias"; then cross_compiling=yes fi fi @@ -1099,77 +662,59 @@ ac_tool_prefix= test -n "$host_alias" && ac_tool_prefix=$host_alias- test "$silent" = yes && exec 6>/dev/null - -ac_pwd=`pwd` && test -n "$ac_pwd" && -ac_ls_di=`ls -di .` && -ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || - as_fn_error $? "working directory cannot be determined" -test "X$ac_ls_di" = "X$ac_pwd_ls_di" || - as_fn_error $? "pwd does not report name of working directory" - # Find the source files, if location was not specified. if test -z "$srcdir"; then ac_srcdir_defaulted=yes - # Try the directory containing this script, then the parent directory. - ac_confdir=`$as_dirname -- "$as_myself" || -$as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$as_myself" : 'X\(//\)[^/]' \| \ - X"$as_myself" : 'X\(//\)$' \| \ - X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X"$as_myself" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` + # Try the directory containing this script, then its parent. + ac_confdir=`(dirname "$0") 2>/dev/null || +$as_expr X"$0" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$0" : 'X\(//\)[^/]' \| \ + X"$0" : 'X\(//\)$' \| \ + X"$0" : 'X\(/\)' \| \ + . : '\(.\)' 2>/dev/null || +echo X"$0" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } + /^X\(\/\/\)[^/].*/{ s//\1/; q; } + /^X\(\/\/\)$/{ s//\1/; q; } + /^X\(\/\).*/{ s//\1/; q; } + s/.*/./; q'` srcdir=$ac_confdir - if test ! -r "$srcdir/$ac_unique_file"; then + if test ! -r $srcdir/$ac_unique_file; then srcdir=.. fi else ac_srcdir_defaulted=no fi -if test ! -r "$srcdir/$ac_unique_file"; then - test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." - as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" -fi -ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" -ac_abs_confdir=`( - cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" - pwd)` -# When building in place, set srcdir=. -if test "$ac_abs_confdir" = "$ac_pwd"; then - srcdir=. -fi -# Remove unnecessary trailing slashes from srcdir. -# Double slashes in file names in object file debugging info -# mess up M-x gdb in Emacs. -case $srcdir in -*/) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; -esac -for ac_var in $ac_precious_vars; do - eval ac_env_${ac_var}_set=\${${ac_var}+set} - eval ac_env_${ac_var}_value=\$${ac_var} - eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} - eval ac_cv_env_${ac_var}_value=\$${ac_var} -done +if test ! -r $srcdir/$ac_unique_file; then + if test "$ac_srcdir_defaulted" = yes; then + { echo "$as_me: error: cannot find sources ($ac_unique_file) in $ac_confdir or .." >&2 + { (exit 1); exit 1; }; } + else + { echo "$as_me: error: cannot find sources ($ac_unique_file) in $srcdir" >&2 + { (exit 1); exit 1; }; } + fi +fi +(cd $srcdir && test -r ./$ac_unique_file) 2>/dev/null || + { echo "$as_me: error: sources are in $srcdir, but \`cd $srcdir' does not work" >&2 + { (exit 1); exit 1; }; } +srcdir=`echo "$srcdir" | sed 's%\([^\\/]\)[\\/]*$%\1%'` +ac_env_build_alias_set=${build_alias+set} +ac_env_build_alias_value=$build_alias +ac_cv_env_build_alias_set=${build_alias+set} +ac_cv_env_build_alias_value=$build_alias +ac_env_host_alias_set=${host_alias+set} +ac_env_host_alias_value=$host_alias +ac_cv_env_host_alias_set=${host_alias+set} +ac_cv_env_host_alias_value=$host_alias +ac_env_target_alias_set=${target_alias+set} +ac_env_target_alias_value=$target_alias +ac_cv_env_target_alias_set=${target_alias+set} +ac_cv_env_target_alias_value=$target_alias # # Report the --help message. # if test "$ac_init_help" = "long"; then @@ -1188,49 +733,45 @@ Configuration: -h, --help display this help and exit --help=short display options specific to this package --help=recursive display the short help of all the included packages -V, --version display version information and exit - -q, --quiet, --silent do not print \`checking ...' messages + -q, --quiet, --silent do not print \`checking...' messages --cache-file=FILE cache test results in FILE [disabled] -C, --config-cache alias for \`--cache-file=config.cache' -n, --no-create do not create output files --srcdir=DIR find the sources in DIR [configure dir or \`..'] +_ACEOF + + cat <<_ACEOF Installation directories: --prefix=PREFIX install architecture-independent files in PREFIX - [$ac_default_prefix] + [$ac_default_prefix] --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX - [PREFIX] + [PREFIX] By default, \`make install' will install all the files in \`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify an installation prefix other than \`$ac_default_prefix' using \`--prefix', for instance \`--prefix=\$HOME'. For better control, use the options below. Fine tuning of the installation directories: - --bindir=DIR user executables [EPREFIX/bin] - --sbindir=DIR system admin executables [EPREFIX/sbin] - --libexecdir=DIR program executables [EPREFIX/libexec] - --sysconfdir=DIR read-only single-machine data [PREFIX/etc] - --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] - --localstatedir=DIR modifiable single-machine data [PREFIX/var] - --libdir=DIR object code libraries [EPREFIX/lib] - --includedir=DIR C header files [PREFIX/include] - --oldincludedir=DIR C header files for non-gcc [/usr/include] - --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] - --datadir=DIR read-only architecture-independent data [DATAROOTDIR] - --infodir=DIR info documentation [DATAROOTDIR/info] - --localedir=DIR locale-dependent data [DATAROOTDIR/locale] - --mandir=DIR man documentation [DATAROOTDIR/man] - --docdir=DIR documentation root [DATAROOTDIR/doc/PACKAGE] - --htmldir=DIR html documentation [DOCDIR] - --dvidir=DIR dvi documentation [DOCDIR] - --pdfdir=DIR pdf documentation [DOCDIR] - --psdir=DIR ps documentation [DOCDIR] + --bindir=DIR user executables [EPREFIX/bin] + --sbindir=DIR system admin executables [EPREFIX/sbin] + --libexecdir=DIR program executables [EPREFIX/libexec] + --datadir=DIR read-only architecture-independent data [PREFIX/share] + --sysconfdir=DIR read-only single-machine data [PREFIX/etc] + --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] + --localstatedir=DIR modifiable single-machine data [PREFIX/var] + --libdir=DIR object code libraries [EPREFIX/lib] + --includedir=DIR C header files [PREFIX/include] + --oldincludedir=DIR C header files for non-gcc [/usr/include] + --infodir=DIR info documentation [PREFIX/info] + --mandir=DIR man documentation [PREFIX/man] _ACEOF cat <<\_ACEOF _ACEOF fi @@ -1242,97 +783,123 @@ Optional Packages: --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) --with-tcl=DIR use Tcl $DEF_VER binaries from DIR -Report bugs to the package provider. _ACEOF -ac_status=$? fi if test "$ac_init_help" = "recursive"; then # If there are subdirs, report their specific --help. + ac_popdir=`pwd` for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue - test -d "$ac_dir" || - { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } || - continue + test -d $ac_dir || continue ac_builddir=. -case "$ac_dir" in -.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; -*) - ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` - # A ".." for each directory in $ac_dir_suffix. - ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` - case $ac_top_builddir_sub in - "") ac_top_builddir_sub=. ac_top_build_prefix= ;; - *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; - esac ;; -esac -ac_abs_top_builddir=$ac_pwd -ac_abs_builddir=$ac_pwd$ac_dir_suffix -# for backward compatibility: -ac_top_builddir=$ac_top_build_prefix +if test "$ac_dir" != .; then + ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'` + # A "../" for each directory in $ac_dir_suffix. + ac_top_builddir=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,../,g'` +else + ac_dir_suffix= ac_top_builddir= +fi case $srcdir in - .) # We are building in place. + .) # No --srcdir option. We are building in place. ac_srcdir=. - ac_top_srcdir=$ac_top_builddir_sub - ac_abs_top_srcdir=$ac_pwd ;; - [\\/]* | ?:[\\/]* ) # Absolute name. + if test -z "$ac_top_builddir"; then + ac_top_srcdir=. + else + ac_top_srcdir=`echo $ac_top_builddir | sed 's,/$,,'` + fi ;; + [\\/]* | ?:[\\/]* ) # Absolute path. ac_srcdir=$srcdir$ac_dir_suffix; - ac_top_srcdir=$srcdir - ac_abs_top_srcdir=$srcdir ;; - *) # Relative name. - ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix - ac_top_srcdir=$ac_top_build_prefix$srcdir - ac_abs_top_srcdir=$ac_pwd/$srcdir ;; + ac_top_srcdir=$srcdir ;; + *) # Relative path. + ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix + ac_top_srcdir=$ac_top_builddir$srcdir ;; +esac + +# Do not use `cd foo && pwd` to compute absolute paths, because +# the directories may not exist. +case `pwd` in +.) ac_abs_builddir="$ac_dir";; +*) + case "$ac_dir" in + .) ac_abs_builddir=`pwd`;; + [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";; + *) ac_abs_builddir=`pwd`/"$ac_dir";; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_top_builddir=${ac_top_builddir}.;; +*) + case ${ac_top_builddir}. in + .) ac_abs_top_builddir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;; + *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_srcdir=$ac_srcdir;; +*) + case $ac_srcdir in + .) ac_abs_srcdir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;; + *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_top_srcdir=$ac_top_srcdir;; +*) + case $ac_top_srcdir in + .) ac_abs_top_srcdir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;; + *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;; + esac;; esac -ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix - - cd "$ac_dir" || { ac_status=$?; continue; } - # Check for guested configure. - if test -f "$ac_srcdir/configure.gnu"; then - echo && - $SHELL "$ac_srcdir/configure.gnu" --help=recursive - elif test -f "$ac_srcdir/configure"; then - echo && - $SHELL "$ac_srcdir/configure" --help=recursive + + cd $ac_dir + # Check for guested configure; otherwise get Cygnus style configure. + if test -f $ac_srcdir/configure.gnu; then + echo + $SHELL $ac_srcdir/configure.gnu --help=recursive + elif test -f $ac_srcdir/configure; then + echo + $SHELL $ac_srcdir/configure --help=recursive + elif test -f $ac_srcdir/configure.ac || + test -f $ac_srcdir/configure.in; then + echo + $ac_configure --help else - $as_echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 - fi || ac_status=$? - cd "$ac_pwd" || { ac_status=$?; break; } + echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 + fi + cd $ac_popdir done fi -test -n "$ac_init_help" && exit $ac_status +test -n "$ac_init_help" && exit 0 if $ac_init_version; then cat <<\_ACEOF -configure -generated by GNU Autoconf 2.69 -Copyright (C) 2012 Free Software Foundation, Inc. +Copyright (C) 2003 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF - exit + exit 0 fi - -## ------------------------ ## -## Autoconf initialization. ## -## ------------------------ ## -cat >config.log <<_ACEOF +exec 5>config.log +cat >&5 <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. It was created by $as_me, which was -generated by GNU Autoconf 2.69. Invocation command line was +generated by GNU Autoconf 2.59. Invocation command line was $ $0 $@ _ACEOF -exec 5>>config.log { cat <<_ASUNAME ## --------- ## ## Platform. ## ## --------- ## @@ -1347,11 +914,11 @@ /bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` /bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` -/usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` +hostinfo = `(hostinfo) 2>/dev/null || echo unknown` /bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` /bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` _ASUNAME @@ -1359,13 +926,12 @@ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - $as_echo "PATH: $as_dir" - done -IFS=$as_save_IFS + echo "PATH: $as_dir" +done } >&5 cat >&5 <<_ACEOF @@ -1383,10 +949,11 @@ # Also quote any args containing shell meta-characters. # Make two passes to allow for proper duplicate-argument suppression. ac_configure_args= ac_configure_args0= ac_configure_args1= +ac_sep= ac_must_keep_next=false for ac_pass in 1 2 do for ac_arg do @@ -1393,17 +960,17 @@ case $ac_arg in -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) continue ;; - *\'*) - ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; + *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?\"\']*) + ac_arg=`echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac case $ac_pass in - 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; + 1) ac_configure_args0="$ac_configure_args0 '$ac_arg'" ;; 2) - as_fn_append ac_configure_args1 " '$ac_arg'" + ac_configure_args1="$ac_configure_args1 '$ac_arg'" if test $ac_must_keep_next = true; then ac_must_keep_next=false # Got value, back to normal. else case $ac_arg in *=* | --config-cache | -C | -disable-* | --disable-* \ @@ -1415,263 +982,244 @@ esac ;; -* ) ac_must_keep_next=true ;; esac fi - as_fn_append ac_configure_args " '$ac_arg'" + ac_configure_args="$ac_configure_args$ac_sep'$ac_arg'" + # Get rid of the leading space. + ac_sep=" " ;; esac done done -{ ac_configure_args0=; unset ac_configure_args0;} -{ ac_configure_args1=; unset ac_configure_args1;} +$as_unset ac_configure_args0 || test "${ac_configure_args0+set}" != set || { ac_configure_args0=; export ac_configure_args0; } +$as_unset ac_configure_args1 || test "${ac_configure_args1+set}" != set || { ac_configure_args1=; export ac_configure_args1; } # When interrupted or exit'd, cleanup temporary files, and complete # config.log. We remove comments because anyway the quotes in there # would cause problems or look ugly. -# WARNING: Use '\'' to represent an apostrophe within the trap. -# WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. +# WARNING: Be sure not to use single quotes in there, as some shells, +# such as our DU 5.0 friend, will then `close' the trap. trap 'exit_status=$? # Save into config.log some information that might help in debugging. { echo - $as_echo "## ---------------- ## + cat <<\_ASBOX +## ---------------- ## ## Cache variables. ## -## ---------------- ##" +## ---------------- ## +_ASBOX echo # The following way of writing the cache mishandles newlines in values, -( - for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do - eval ac_val=\$$ac_var - case $ac_val in #( - *${as_nl}*) - case $ac_var in #( - *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 -$as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; - esac - case $ac_var in #( - _ | IFS | as_nl) ;; #( - BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( - *) { eval $ac_var=; unset $ac_var;} ;; - esac ;; - esac - done +{ (set) 2>&1 | - case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( - *${as_nl}ac_space=\ *) + case `(ac_space='"'"' '"'"'; set | grep ac_space) 2>&1` in + *ac_space=\ *) + sed -n \ + "s/'"'"'/'"'"'\\\\'"'"''"'"'/g; + s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='"'"'\\2'"'"'/p" + ;; + *) sed -n \ - "s/'\''/'\''\\\\'\'''\''/g; - s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" - ;; #( - *) - sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" + "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p" ;; - esac | - sort -) + esac; +} echo - $as_echo "## ----------------- ## + cat <<\_ASBOX +## ----------------- ## ## Output variables. ## -## ----------------- ##" +## ----------------- ## +_ASBOX echo for ac_var in $ac_subst_vars do - eval ac_val=\$$ac_var - case $ac_val in - *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; - esac - $as_echo "$ac_var='\''$ac_val'\''" + eval ac_val=$`echo $ac_var` + echo "$ac_var='"'"'$ac_val'"'"'" done | sort echo if test -n "$ac_subst_files"; then - $as_echo "## ------------------- ## -## File substitutions. ## -## ------------------- ##" + cat <<\_ASBOX +## ------------- ## +## Output files. ## +## ------------- ## +_ASBOX echo for ac_var in $ac_subst_files do - eval ac_val=\$$ac_var - case $ac_val in - *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; - esac - $as_echo "$ac_var='\''$ac_val'\''" + eval ac_val=$`echo $ac_var` + echo "$ac_var='"'"'$ac_val'"'"'" done | sort echo fi if test -s confdefs.h; then - $as_echo "## ----------- ## + cat <<\_ASBOX +## ----------- ## ## confdefs.h. ## -## ----------- ##" +## ----------- ## +_ASBOX echo - cat confdefs.h + sed "/^$/d" confdefs.h | sort echo fi test "$ac_signal" != 0 && - $as_echo "$as_me: caught signal $ac_signal" - $as_echo "$as_me: exit $exit_status" + echo "$as_me: caught signal $ac_signal" + echo "$as_me: exit $exit_status" } >&5 - rm -f core *.core core.conftest.* && - rm -f -r conftest* confdefs* conf$$* $ac_clean_files && + rm -f core *.core && + rm -rf conftest* confdefs* conf$$* $ac_clean_files && exit $exit_status -' 0 + ' 0 for ac_signal in 1 2 13 15; do - trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal + trap 'ac_signal='$ac_signal'; { (exit 1); exit 1; }' $ac_signal done ac_signal=0 # confdefs.h avoids OS command line length limits that DEFS can exceed. -rm -f -r conftest* confdefs.h - -$as_echo "/* confdefs.h */" > confdefs.h +rm -rf conftest* confdefs.h +# AIX cpp loses on an empty file, so make sure it contains at least a newline. +echo >confdefs.h # Predefined preprocessor variables. cat >>confdefs.h <<_ACEOF #define PACKAGE_NAME "$PACKAGE_NAME" _ACEOF + cat >>confdefs.h <<_ACEOF #define PACKAGE_TARNAME "$PACKAGE_TARNAME" _ACEOF + cat >>confdefs.h <<_ACEOF #define PACKAGE_VERSION "$PACKAGE_VERSION" _ACEOF + cat >>confdefs.h <<_ACEOF #define PACKAGE_STRING "$PACKAGE_STRING" _ACEOF + cat >>confdefs.h <<_ACEOF #define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" _ACEOF -cat >>confdefs.h <<_ACEOF -#define PACKAGE_URL "$PACKAGE_URL" -_ACEOF - # Let the site file select an alternate cache file if it wants to. -# Prefer an explicitly selected file to automatically selected ones. -ac_site_file1=NONE -ac_site_file2=NONE -if test -n "$CONFIG_SITE"; then - # We do not want a PATH search for config.site. - case $CONFIG_SITE in #(( - -*) ac_site_file1=./$CONFIG_SITE;; - */*) ac_site_file1=$CONFIG_SITE;; - *) ac_site_file1=./$CONFIG_SITE;; - esac -elif test "x$prefix" != xNONE; then - ac_site_file1=$prefix/share/config.site - ac_site_file2=$prefix/etc/config.site -else - ac_site_file1=$ac_default_prefix/share/config.site - ac_site_file2=$ac_default_prefix/etc/config.site +# Prefer explicitly selected file to automatically selected ones. +if test -z "$CONFIG_SITE"; then + if test "x$prefix" != xNONE; then + CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site" + else + CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" + fi fi -for ac_site_file in "$ac_site_file1" "$ac_site_file2" -do - test "x$ac_site_file" = xNONE && continue - if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 -$as_echo "$as_me: loading site script $ac_site_file" >&6;} +for ac_site_file in $CONFIG_SITE; do + if test -r "$ac_site_file"; then + { echo "$as_me:$LINENO: loading site script $ac_site_file" >&5 +echo "$as_me: loading site script $ac_site_file" >&6;} sed 's/^/| /' "$ac_site_file" >&5 - . "$ac_site_file" \ - || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "failed to load site script $ac_site_file -See \`config.log' for more details" "$LINENO" 5; } + . "$ac_site_file" fi done if test -r "$cache_file"; then - # Some versions of bash will fail to source /dev/null (special files - # actually), so we avoid doing that. DJGPP emulates it as a regular file. - if test /dev/null != "$cache_file" && test -f "$cache_file"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 -$as_echo "$as_me: loading cache $cache_file" >&6;} + # Some versions of bash will fail to source /dev/null (special + # files actually), so we avoid doing that. + if test -f "$cache_file"; then + { echo "$as_me:$LINENO: loading cache $cache_file" >&5 +echo "$as_me: loading cache $cache_file" >&6;} case $cache_file in - [\\/]* | ?:[\\/]* ) . "$cache_file";; - *) . "./$cache_file";; + [\\/]* | ?:[\\/]* ) . $cache_file;; + *) . ./$cache_file;; esac fi else - { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 -$as_echo "$as_me: creating cache $cache_file" >&6;} + { echo "$as_me:$LINENO: creating cache $cache_file" >&5 +echo "$as_me: creating cache $cache_file" >&6;} >$cache_file fi # Check that the precious variables saved in the cache have kept the same # value. ac_cache_corrupted=false -for ac_var in $ac_precious_vars; do +for ac_var in `(set) 2>&1 | + sed -n 's/^ac_env_\([a-zA-Z_0-9]*\)_set=.*/\1/p'`; do eval ac_old_set=\$ac_cv_env_${ac_var}_set eval ac_new_set=\$ac_env_${ac_var}_set - eval ac_old_val=\$ac_cv_env_${ac_var}_value - eval ac_new_val=\$ac_env_${ac_var}_value + eval ac_old_val="\$ac_cv_env_${ac_var}_value" + eval ac_new_val="\$ac_env_${ac_var}_value" case $ac_old_set,$ac_new_set in set,) - { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 -$as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} + { echo "$as_me:$LINENO: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 +echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) - { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 -$as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} + { echo "$as_me:$LINENO: error: \`$ac_var' was not set in the previous run" >&5 +echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} ac_cache_corrupted=: ;; ,);; *) if test "x$ac_old_val" != "x$ac_new_val"; then - # differences in whitespace do not lead to failure. - ac_old_val_w=`echo x $ac_old_val` - ac_new_val_w=`echo x $ac_new_val` - if test "$ac_old_val_w" != "$ac_new_val_w"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 -$as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} - ac_cache_corrupted=: - else - { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 -$as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} - eval $ac_var=\$ac_old_val - fi - { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 -$as_echo "$as_me: former value: \`$ac_old_val'" >&2;} - { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 -$as_echo "$as_me: current value: \`$ac_new_val'" >&2;} + { echo "$as_me:$LINENO: error: \`$ac_var' has changed since the previous run:" >&5 +echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} + { echo "$as_me:$LINENO: former value: $ac_old_val" >&5 +echo "$as_me: former value: $ac_old_val" >&2;} + { echo "$as_me:$LINENO: current value: $ac_new_val" >&5 +echo "$as_me: current value: $ac_new_val" >&2;} + ac_cache_corrupted=: fi;; esac # Pass precious variables to config.status. if test "$ac_new_set" = set; then case $ac_new_val in - *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; + *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?\"\']*) + ac_arg=$ac_var=`echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; *) ac_arg=$ac_var=$ac_new_val ;; esac case " $ac_configure_args " in *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. - *) as_fn_append ac_configure_args " '$ac_arg'" ;; + *) ac_configure_args="$ac_configure_args '$ac_arg'" ;; esac fi done if $ac_cache_corrupted; then - { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} - { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 -$as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} - as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 + { echo "$as_me:$LINENO: error: changes in the environment can compromise the build" >&5 +echo "$as_me: error: changes in the environment can compromise the build" >&2;} + { { echo "$as_me:$LINENO: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&5 +echo "$as_me: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&2;} + { (exit 1); exit 1; }; } fi -## -------------------- ## -## Main body of script. ## -## -------------------- ## ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu + + + + + + + + + + + + + + + + + # Recover information that Tcl computed with its configure script. @@ -1679,25 +1227,29 @@ #-------------------------------------------------------------------- # See if there was a command-line option for where Tcl is; if # not, assume that its top-level directory is a sibling of ours. #-------------------------------------------------------------------- -DEF_VER=9.0 +DEF_VER=8.6 -# Check whether --with-tcl was given. -if test "${with_tcl+set}" = set; then : - withval=$with_tcl; TCL_BIN_DIR=$withval +# Check whether --with-tcl or --without-tcl was given. +if test "${with_tcl+set}" = set; then + withval="$with_tcl" + TCL_BIN_DIR=$withval else TCL_BIN_DIR=`cd ../../tcl$DEF_VER$TCL_PATCH_LEVEL/unix; pwd` -fi - +fi; if test ! -d $TCL_BIN_DIR; then - as_fn_error $? "Tcl directory $TCL_BIN_DIR doesn't exist" "$LINENO" 5 + { { echo "$as_me:$LINENO: error: Tcl directory $TCL_BIN_DIR doesn't exist" >&5 +echo "$as_me: error: Tcl directory $TCL_BIN_DIR doesn't exist" >&2;} + { (exit 1); exit 1; }; } fi if test ! -f $TCL_BIN_DIR/tclConfig.sh; then - as_fn_error $? "There's no tclConfig.sh in $TCL_BIN_DIR; perhaps you didn't specify the Tcl *build* directory (not the toplevel Tcl directory) or you forgot to configure Tcl?" "$LINENO" 5 + { { echo "$as_me:$LINENO: error: There's no tclConfig.sh in $TCL_BIN_DIR; perhaps you didn't specify the Tcl *build* directory (not the toplevel Tcl directory) or you forgot to configure Tcl?" >&5 +echo "$as_me: error: There's no tclConfig.sh in $TCL_BIN_DIR; perhaps you didn't specify the Tcl *build* directory (not the toplevel Tcl directory) or you forgot to configure Tcl?" >&2;} + { (exit 1); exit 1; }; } fi . $TCL_BIN_DIR/tclConfig.sh TCL_WIN_VERSION=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION @@ -1707,12 +1259,11 @@ -ac_config_files="$ac_config_files Makefile tcl.hpj" - + ac_config_files="$ac_config_files Makefile tcl.hpj" cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure # scripts and configure runs, see configure's option --config-cache. # It is not useful on other systems. If it contains results you don't @@ -1727,653 +1278,512 @@ _ACEOF # The following way of writing the cache mishandles newlines in values, # but we know of no workaround that is simple, portable, and efficient. -# So, we kill variables containing newlines. +# So, don't put newlines in cache variables' values. # Ultrix sh set writes to stderr and can't be redirected directly, # and sets the high bit in the cache file unless we assign to the vars. -( - for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do - eval ac_val=\$$ac_var - case $ac_val in #( - *${as_nl}*) - case $ac_var in #( - *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 -$as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; - esac - case $ac_var in #( - _ | IFS | as_nl) ;; #( - BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( - *) { eval $ac_var=; unset $ac_var;} ;; - esac ;; - esac - done - +{ (set) 2>&1 | - case $as_nl`(ac_space=' '; set) 2>&1` in #( - *${as_nl}ac_space=\ *) - # `set' does not quote correctly, so add quotes: double-quote - # substitution turns \\\\ into \\, and sed turns \\ into \. + case `(ac_space=' '; set | grep ac_space) 2>&1` in + *ac_space=\ *) + # `set' does not quote correctly, so add quotes (double-quote + # substitution turns \\\\ into \\, and sed turns \\ into \). sed -n \ "s/'/'\\\\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" - ;; #( + ;; *) # `set' quotes correctly as required by POSIX, so do not add quotes. - sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" + sed -n \ + "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p" ;; - esac | - sort -) | + esac; +} | sed ' - /^ac_cv_env_/b end t clear - :clear + : clear s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ t end - s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ - :end' >>confcache -if diff "$cache_file" confcache >/dev/null 2>&1; then :; else - if test -w "$cache_file"; then - if test "x$cache_file" != "x/dev/null"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 -$as_echo "$as_me: updating cache $cache_file" >&6;} - if test ! -f "$cache_file" || test -h "$cache_file"; then - cat confcache >"$cache_file" - else - case $cache_file in #( - */* | ?:*) - mv -f confcache "$cache_file"$$ && - mv -f "$cache_file"$$ "$cache_file" ;; #( - *) - mv -f confcache "$cache_file" ;; - esac - fi - fi - else - { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 -$as_echo "$as_me: not updating unwritable cache $cache_file" >&6;} + /^ac_cv_env/!s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ + : end' >>confcache +if diff $cache_file confcache >/dev/null 2>&1; then :; else + if test -w $cache_file; then + test "x$cache_file" != "x/dev/null" && echo "updating cache $cache_file" + cat confcache >$cache_file + else + echo "not updating unwritable cache $cache_file" fi fi rm -f confcache test "x$prefix" = xNONE && prefix=$ac_default_prefix # Let make expand exec_prefix. test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' + +# VPATH may cause trouble with some makes, so we remove $(srcdir), +# ${srcdir} and @srcdir@ from VPATH if srcdir is ".", strip leading and +# trailing colons and then remove the whole line if VPATH becomes empty +# (actually we leave an empty line to preserve line numbers). +if test "x$srcdir" = x.; then + ac_vpsub='/^[ ]*VPATH[ ]*=/{ +s/:*\$(srcdir):*/:/; +s/:*\${srcdir}:*/:/; +s/:*@srcdir@:*/:/; +s/^\([^=]*=[ ]*\):*/\1/; +s/:*$//; +s/^[^=]*=[ ]*$//; +}' +fi # Transform confdefs.h into DEFS. # Protect against shell expansion while executing Makefile rules. # Protect against Makefile macro expansion. # # If the first sed substitution is executed (which looks for macros that -# take arguments), then branch to the quote section. Otherwise, -# look for a macro that doesn't take arguments. -ac_script=' -:mline -/\\$/{ - N - s,\\\n,, - b mline -} -t clear -:clear -s/^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\)/-D\1=\2/g -t quote -s/^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\)/-D\1=\2/g -t quote -b any -:quote -s/[ `~#$^&*(){}\\|;'\''"<>?]/\\&/g -s/\[/\\&/g -s/\]/\\&/g -s/\$/$$/g -H -:any -${ - g - s/^\n// - s/\n/ /g - p -} -' -DEFS=`sed -n "$ac_script" confdefs.h` +# take arguments), then we branch to the quote section. Otherwise, +# look for a macro that doesn't take arguments. +cat >confdef2opt.sed <<\_ACEOF +t clear +: clear +s,^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\),-D\1=\2,g +t quote +s,^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\),-D\1=\2,g +t quote +d +: quote +s,[ `~#$^&*(){}\\|;'"<>?],\\&,g +s,\[,\\&,g +s,\],\\&,g +s,\$,$$,g +p +_ACEOF +# We use echo to avoid assuming a particular line-breaking character. +# The extra dot is to prevent the shell from consuming trailing +# line-breaks from the sub-command output. A line-break within +# single-quotes doesn't work because, if this script is created in a +# platform that uses two characters for line-breaks (e.g., DOS), tr +# would break. +ac_LF_and_DOT=`echo; echo .` +DEFS=`sed -n -f confdef2opt.sed confdefs.h | tr "$ac_LF_and_DOT" ' .'` +rm -f confdef2opt.sed ac_libobjs= ac_ltlibobjs= -U= for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue # 1. Remove the extension, and $U if already installed. - ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' - ac_i=`$as_echo "$ac_i" | sed "$ac_script"` - # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR - # will be set to the directory where LIBOBJS objects are built. - as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" - as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' + ac_i=`echo "$ac_i" | + sed 's/\$U\././;s/\.o$//;s/\.obj$//'` + # 2. Add them. + ac_libobjs="$ac_libobjs $ac_i\$U.$ac_objext" + ac_ltlibobjs="$ac_ltlibobjs $ac_i"'$U.lo' done LIBOBJS=$ac_libobjs LTLIBOBJS=$ac_ltlibobjs -: "${CONFIG_STATUS=./config.status}" -ac_write_fail=0 +: ${CONFIG_STATUS=./config.status} ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files $CONFIG_STATUS" -{ $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 -$as_echo "$as_me: creating $CONFIG_STATUS" >&6;} -as_write_fail=0 -cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 +{ echo "$as_me:$LINENO: creating $CONFIG_STATUS" >&5 +echo "$as_me: creating $CONFIG_STATUS" >&6;} +cat >$CONFIG_STATUS <<_ACEOF #! $SHELL # Generated by $as_me. # Run this file to recreate the current configuration. # Compiler output produced by configure, useful for debugging # configure, is in config.log if it exists. debug=false ac_cs_recheck=false ac_cs_silent=false - SHELL=\${CONFIG_SHELL-$SHELL} -export SHELL -_ASEOF -cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 -## -------------------- ## -## M4sh Initialization. ## -## -------------------- ## - -# Be more Bourne compatible -DUALCASE=1; export DUALCASE # for MKS sh -if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF +## --------------------- ## +## M4sh Initialization. ## +## --------------------- ## + +# Be Bourne compatible +if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then emulate sh NULLCMD=: - # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which + # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' - setopt NO_GLOB_SUBST -else - case `(set -o) 2>/dev/null` in #( - *posix*) : - set -o posix ;; #( - *) : - ;; -esac -fi - - -as_nl=' -' -export as_nl -# Printing a long string crashes Solaris 7 /usr/bin/printf. -as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' -as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo -as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo -# Prefer a ksh shell builtin over an external printf program on Solaris, -# but without wasting forks for bash or zsh. -if test -z "$BASH_VERSION$ZSH_VERSION" \ - && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then - as_echo='print -r --' - as_echo_n='print -rn --' -elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then - as_echo='printf %s\n' - as_echo_n='printf %s' -else - if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then - as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' - as_echo_n='/usr/ucb/echo -n' - else - as_echo_body='eval expr "X$1" : "X\\(.*\\)"' - as_echo_n_body='eval - arg=$1; - case $arg in #( - *"$as_nl"*) - expr "X$arg" : "X\\(.*\\)$as_nl"; - arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; - esac; - expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" - ' - export as_echo_n_body - as_echo_n='sh -c $as_echo_n_body as_echo' - fi - export as_echo_body - as_echo='sh -c $as_echo_body as_echo' -fi - -# The user is always right. -if test "${PATH_SEPARATOR+set}" != set; then - PATH_SEPARATOR=: - (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { - (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || - PATH_SEPARATOR=';' - } -fi - - -# IFS -# We need space, tab and new line, in precisely that order. Quoting is -# there to prevent editors from complaining about space-tab. -# (If _AS_PATH_WALK were called with IFS unset, it would disable word -# splitting by setting IFS to empty value.) -IFS=" "" $as_nl" - -# Find who we are. Look in the path if we contain no directory separator. -as_myself= -case $0 in #(( - *[\\/]* ) as_myself=$0 ;; - *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break - done -IFS=$as_save_IFS - - ;; -esac -# We did not find ourselves, most probably we were run as `sh COMMAND' -# in which case we are not to be found in the path. -if test "x$as_myself" = x; then - as_myself=$0 -fi -if test ! -f "$as_myself"; then - $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 - exit 1 -fi - -# Unset variables that we do not need and which cause bugs (e.g. in -# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" -# suppresses any "Segmentation fault" message there. '((' could -# trigger a bug in pdksh 5.2.14. -for as_var in BASH_ENV ENV MAIL MAILPATH -do eval test x\${$as_var+set} = xset \ - && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : -done +elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then + set -o posix +fi +DUALCASE=1; export DUALCASE # for MKS sh + +# Support unset when possible. +if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then + as_unset=unset +else + as_unset=false +fi + + +# Work around bugs in pre-3.0 UWIN ksh. +$as_unset ENV MAIL MAILPATH PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. -LC_ALL=C -export LC_ALL -LANGUAGE=C -export LANGUAGE - -# CDPATH. -(unset CDPATH) >/dev/null 2>&1 && unset CDPATH - - -# as_fn_error STATUS ERROR [LINENO LOG_FD] -# ---------------------------------------- -# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are -# provided, also output the error to LOG_FD, referencing LINENO. Then exit the -# script with STATUS, using 1 if that was 0. -as_fn_error () -{ - as_status=$1; test $as_status -eq 0 && as_status=1 - if test "$4"; then - as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 +for as_var in \ + LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \ + LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \ + LC_TELEPHONE LC_TIME +do + if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then + eval $as_var=C; export $as_var + else + $as_unset $as_var fi - $as_echo "$as_me: error: $2" >&2 - as_fn_exit $as_status -} # as_fn_error - - -# as_fn_set_status STATUS -# ----------------------- -# Set $? to STATUS, without forking. -as_fn_set_status () -{ - return $1 -} # as_fn_set_status - -# as_fn_exit STATUS -# ----------------- -# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. -as_fn_exit () -{ - set +e - as_fn_set_status $1 - exit $1 -} # as_fn_exit - -# as_fn_unset VAR -# --------------- -# Portably unset VAR. -as_fn_unset () -{ - { eval $1=; unset $1;} -} -as_unset=as_fn_unset -# as_fn_append VAR VALUE -# ---------------------- -# Append the text in VALUE to the end of the definition contained in VAR. Take -# advantage of any shell optimizations that allow amortized linear growth over -# repeated appends, instead of the typical quadratic growth present in naive -# implementations. -if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : - eval 'as_fn_append () - { - eval $1+=\$2 - }' -else - as_fn_append () - { - eval $1=\$$1\$2 - } -fi # as_fn_append - -# as_fn_arith ARG... -# ------------------ -# Perform arithmetic evaluation on the ARGs, and store the result in the -# global $as_val. Take advantage of shells that can avoid forks. The arguments -# must be portable across $(()) and expr. -if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : - eval 'as_fn_arith () - { - as_val=$(( $* )) - }' -else - as_fn_arith () - { - as_val=`expr "$@" || test $? -eq 1` - } -fi # as_fn_arith - - -if expr a : '\(a\)' >/dev/null 2>&1 && - test "X`expr 00001 : '.*\(...\)'`" = X001; then +done + +# Required to use basename. +if expr a : '\(a\)' >/dev/null 2>&1; then as_expr=expr else as_expr=false fi -if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then +if (basename /) >/dev/null 2>&1 && test "X`basename / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi -if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then - as_dirname=dirname -else - as_dirname=false -fi -as_me=`$as_basename -- "$0" || +# Name of the executable. +as_me=`$as_basename "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ - X"$0" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X/"$0" | - sed '/^.*\/\([^/][^/]*\)\/*$/{ - s//\1/ - q - } - /^X\/\(\/\/\)$/{ - s//\1/ - q - } - /^X\/\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - + X"$0" : 'X\(/\)$' \| \ + . : '\(.\)' 2>/dev/null || +echo X/"$0" | + sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/; q; } + /^X\/\(\/\/\)$/{ s//\1/; q; } + /^X\/\(\/\).*/{ s//\1/; q; } + s/.*/./; q'` + + +# PATH needs CR, and LINENO needs CR and PATH. # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits -ECHO_C= ECHO_N= ECHO_T= -case `echo -n x` in #((((( --n*) - case `echo 'xy\c'` in - *c*) ECHO_T=' ';; # ECHO_T is single tab character. - xy) ECHO_C='\c';; - *) echo `echo ksh88 bug on AIX 6.1` > /dev/null - ECHO_T=' ';; - esac;; -*) - ECHO_N='-n';; -esac - -rm -f conf$$ conf$$.exe conf$$.file -if test -d conf$$.dir; then - rm -f conf$$.dir/conf$$.file -else - rm -f conf$$.dir - mkdir conf$$.dir 2>/dev/null -fi -if (echo >conf$$.file) 2>/dev/null; then - if ln -s conf$$.file conf$$ 2>/dev/null; then - as_ln_s='ln -s' - # ... but there are two gotchas: - # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. - # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. - # In both cases, we have to default to `cp -pR'. - ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || - as_ln_s='cp -pR' - elif ln conf$$.file conf$$ 2>/dev/null; then - as_ln_s=ln - else - as_ln_s='cp -pR' - fi -else - as_ln_s='cp -pR' -fi -rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file -rmdir conf$$.dir 2>/dev/null - - -# as_fn_mkdir_p -# ------------- -# Create "$as_dir" as a directory, including parents if necessary. -as_fn_mkdir_p () -{ - - case $as_dir in #( - -*) as_dir=./$as_dir;; - esac - test -d "$as_dir" || eval $as_mkdir_p || { - as_dirs= - while :; do - case $as_dir in #( - *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( - *) as_qdir=$as_dir;; - esac - as_dirs="'$as_qdir' $as_dirs" - as_dir=`$as_dirname -- "$as_dir" || -$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$as_dir" : 'X\(//\)[^/]' \| \ - X"$as_dir" : 'X\(//\)$' \| \ - X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X"$as_dir" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - test -d "$as_dir" && break - done - test -z "$as_dirs" || eval "mkdir $as_dirs" - } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" - - -} # as_fn_mkdir_p -if mkdir -p . 2>/dev/null; then - as_mkdir_p='mkdir -p "$as_dir"' +# The user is always right. +if test "${PATH_SEPARATOR+set}" != set; then + echo "#! /bin/sh" >conf$$.sh + echo "exit 0" >>conf$$.sh + chmod +x conf$$.sh + if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then + PATH_SEPARATOR=';' + else + PATH_SEPARATOR=: + fi + rm -f conf$$.sh +fi + + + as_lineno_1=$LINENO + as_lineno_2=$LINENO + as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` + test "x$as_lineno_1" != "x$as_lineno_2" && + test "x$as_lineno_3" = "x$as_lineno_2" || { + # Find who we are. Look in the path if we contain no path at all + # relative or not. + case $0 in + *[\\/]* ) as_myself=$0 ;; + *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break +done + + ;; + esac + # We did not find ourselves, most probably we were run as `sh COMMAND' + # in which case we are not to be found in the path. + if test "x$as_myself" = x; then + as_myself=$0 + fi + if test ! -f "$as_myself"; then + { { echo "$as_me:$LINENO: error: cannot find myself; rerun with an absolute path" >&5 +echo "$as_me: error: cannot find myself; rerun with an absolute path" >&2;} + { (exit 1); exit 1; }; } + fi + case $CONFIG_SHELL in + '') + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for as_base in sh bash ksh sh5; do + case $as_dir in + /*) + if ("$as_dir/$as_base" -c ' + as_lineno_1=$LINENO + as_lineno_2=$LINENO + as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` + test "x$as_lineno_1" != "x$as_lineno_2" && + test "x$as_lineno_3" = "x$as_lineno_2" ') 2>/dev/null; then + $as_unset BASH_ENV || test "${BASH_ENV+set}" != set || { BASH_ENV=; export BASH_ENV; } + $as_unset ENV || test "${ENV+set}" != set || { ENV=; export ENV; } + CONFIG_SHELL=$as_dir/$as_base + export CONFIG_SHELL + exec "$CONFIG_SHELL" "$0" ${1+"$@"} + fi;; + esac + done +done +;; + esac + + # Create $as_me.lineno as a copy of $as_myself, but with $LINENO + # uniformly replaced by the line number. The first 'sed' inserts a + # line-number line before each line; the second 'sed' does the real + # work. The second script uses 'N' to pair each line-number line + # with the numbered line, and appends trailing '-' during + # substitution so that $LINENO is not a special case at line end. + # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the + # second 'sed' script. Blame Lee E. McMahon for sed's syntax. :-) + sed '=' <$as_myself | + sed ' + N + s,$,-, + : loop + s,^\(['$as_cr_digits']*\)\(.*\)[$]LINENO\([^'$as_cr_alnum'_]\),\1\2\1\3, + t loop + s,-$,, + s,^['$as_cr_digits']*\n,, + ' >$as_me.lineno && + chmod +x $as_me.lineno || + { { echo "$as_me:$LINENO: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&5 +echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2;} + { (exit 1); exit 1; }; } + + # Don't try to exec as it changes $[0], causing all sort of problems + # (the dirname of $[0] is not the place where we might find the + # original and so on. Autoconf is especially sensible to this). + . ./$as_me.lineno + # Exit status is that of the last command. + exit +} + + +case `echo "testing\c"; echo 1,2,3`,`echo -n testing; echo 1,2,3` in + *c*,-n*) ECHO_N= ECHO_C=' +' ECHO_T=' ' ;; + *c*,* ) ECHO_N=-n ECHO_C= ECHO_T= ;; + *) ECHO_N= ECHO_C='\c' ECHO_T= ;; +esac + +if expr a : '\(a\)' >/dev/null 2>&1; then + as_expr=expr +else + as_expr=false +fi + +rm -f conf$$ conf$$.exe conf$$.file +echo >conf$$.file +if ln -s conf$$.file conf$$ 2>/dev/null; then + # We could just check for DJGPP; but this test a) works b) is more generic + # and c) will remain valid once DJGPP supports symlinks (DJGPP 2.04). + if test -f conf$$.exe; then + # Don't use ln at all; we don't have any links + as_ln_s='cp -p' + else + as_ln_s='ln -s' + fi +elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln +else + as_ln_s='cp -p' +fi +rm -f conf$$ conf$$.exe conf$$.file + +if mkdir -p . 2>/dev/null; then + as_mkdir_p=: else test -d ./-p && rmdir ./-p as_mkdir_p=false fi - -# as_fn_executable_p FILE -# ----------------------- -# Test if FILE is an executable regular file. -as_fn_executable_p () -{ - test -f "$1" && test -x "$1" -} # as_fn_executable_p -as_test_x='test -x' -as_executable_p=as_fn_executable_p +as_executable_p="test -f" # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" +# IFS +# We need space, tab and new line, in precisely that order. +as_nl=' +' +IFS=" $as_nl" + +# CDPATH. +$as_unset CDPATH + exec 6>&1 -## ----------------------------------- ## -## Main body of $CONFIG_STATUS script. ## -## ----------------------------------- ## -_ASEOF -test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 - -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -# Save the log message, to keep $0 and so on meaningful, and to + +# Open the log real soon, 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=" +# values after options handling. Logging --version etc. is OK. +exec 5>>config.log +{ + echo + sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX +## Running $as_me. ## +_ASBOX +} >&5 +cat >&5 <<_CSEOF + This file was extended by $as_me, which was -generated by GNU Autoconf 2.69. Invocation command line was +generated by GNU Autoconf 2.59. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS CONFIG_COMMANDS = $CONFIG_COMMANDS $ $0 $@ -on `(hostname || uname -n) 2>/dev/null | sed 1q` -" - +_CSEOF +echo "on `(hostname || uname -n) 2>/dev/null | sed 1q`" >&5 +echo >&5 _ACEOF -case $ac_config_files in *" -"*) set x $ac_config_files; shift; ac_config_files=$*;; -esac - - - -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 # Files that config.status was made for. -config_files="$ac_config_files" +if test -n "$ac_config_files"; then + echo "config_files=\"$ac_config_files\"" >>$CONFIG_STATUS +fi + +if test -n "$ac_config_headers"; then + echo "config_headers=\"$ac_config_headers\"" >>$CONFIG_STATUS +fi + +if test -n "$ac_config_links"; then + echo "config_links=\"$ac_config_links\"" >>$CONFIG_STATUS +fi -_ACEOF +if test -n "$ac_config_commands"; then + echo "config_commands=\"$ac_config_commands\"" >>$CONFIG_STATUS +fi -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +cat >>$CONFIG_STATUS <<\_ACEOF + ac_cs_usage="\ -\`$as_me' instantiates files and other configuration actions -from templates according to the current configuration. Unless the files -and actions are specified as TAGs, all are instantiated by default. +\`$as_me' instantiates files from templates according to the +current configuration. -Usage: $0 [OPTION]... [TAG]... +Usage: $0 [OPTIONS] [FILE]... -h, --help print this help, then exit - -V, --version print version number and configuration settings, then exit - --config print configuration, then exit - -q, --quiet, --silent - do not print progress messages + -V, --version print version number, then exit + -q, --quiet do not print progress messages -d, --debug don't remove temporary files --recheck update $as_me by reconfiguring in the same conditions - --file=FILE[:TEMPLATE] - instantiate the configuration file FILE + --file=FILE[:TEMPLATE] + instantiate the configuration file FILE Configuration files: $config_files -Report bugs to the package provider." - +Report bugs to ." _ACEOF -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" + +cat >>$CONFIG_STATUS <<_ACEOF ac_cs_version="\\ config.status -configured by $0, generated by GNU Autoconf 2.69, - with options \\"\$ac_cs_config\\" +configured by $0, generated by GNU Autoconf 2.59, + with options \\"`echo "$ac_configure_args" | sed 's/[\\""\`\$]/\\\\&/g'`\\" -Copyright (C) 2012 Free Software Foundation, Inc. +Copyright (C) 2003 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." - -ac_pwd='$ac_pwd' -srcdir='$srcdir' -test -n "\$AWK" || AWK=awk +srcdir=$srcdir _ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -# The default lists apply if the user does not specify any file. +cat >>$CONFIG_STATUS <<\_ACEOF +# If no file are specified by the user, then we need to provide default +# value. By we need to know if files were specified by the user. ac_need_defaults=: while test $# != 0 do case $1 in - --*=?*) - ac_option=`expr "X$1" : 'X\([^=]*\)='` - ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` + --*=*) + ac_option=`expr "x$1" : 'x\([^=]*\)='` + ac_optarg=`expr "x$1" : 'x[^=]*=\(.*\)'` ac_shift=: ;; - --*=) - ac_option=`expr "X$1" : 'X\([^=]*\)='` - ac_optarg= - ac_shift=: - ;; - *) + -*) ac_option=$1 ac_optarg=$2 ac_shift=shift ;; + *) # This is not an option, so the user has probably given explicit + # arguments. + ac_option=$1 + ac_need_defaults=false;; esac case $ac_option in # Handling of the options. +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) ac_cs_recheck=: ;; - --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) - $as_echo "$ac_cs_version"; exit ;; - --config | --confi | --conf | --con | --co | --c ) - $as_echo "$ac_cs_config"; exit ;; - --debug | --debu | --deb | --de | --d | -d ) + --version | --vers* | -V ) + echo "$ac_cs_version"; exit 0 ;; + --he | --h) + # Conflict between --help and --header + { { echo "$as_me:$LINENO: error: ambiguous option: $1 +Try \`$0 --help' for more information." >&5 +echo "$as_me: error: ambiguous option: $1 +Try \`$0 --help' for more information." >&2;} + { (exit 1); exit 1; }; };; + --help | --hel | -h ) + echo "$ac_cs_usage"; exit 0 ;; + --debug | --d* | -d ) debug=: ;; --file | --fil | --fi | --f ) $ac_shift - case $ac_optarg in - *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; - '') as_fn_error $? "missing file argument" ;; - esac - as_fn_append CONFIG_FILES " '$ac_optarg'" + CONFIG_FILES="$CONFIG_FILES $ac_optarg" ac_need_defaults=false;; - --he | --h | --help | --hel | -h ) - $as_echo "$ac_cs_usage"; exit ;; + --header | --heade | --head | --hea ) + $ac_shift + CONFIG_HEADERS="$CONFIG_HEADERS $ac_optarg" + ac_need_defaults=false;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil | --si | --s) ac_cs_silent=: ;; # This is an error. - -*) as_fn_error $? "unrecognized option: \`$1' -Try \`$0 --help' for more information." ;; + -*) { { echo "$as_me:$LINENO: error: unrecognized option: $1 +Try \`$0 --help' for more information." >&5 +echo "$as_me: error: unrecognized option: $1 +Try \`$0 --help' for more information." >&2;} + { (exit 1); exit 1; }; } ;; - *) as_fn_append ac_config_targets " $1" - ac_need_defaults=false ;; + *) ac_config_targets="$ac_config_targets $1" ;; esac shift done @@ -2383,48 +1793,34 @@ exec 6>/dev/null ac_configure_extra_args="$ac_configure_extra_args --silent" fi _ACEOF -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +cat >>$CONFIG_STATUS <<_ACEOF if \$ac_cs_recheck; then - set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion - shift - \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6 - CONFIG_SHELL='$SHELL' - export CONFIG_SHELL - exec "\$@" + echo "running $SHELL $0 " $ac_configure_args \$ac_configure_extra_args " --no-create --no-recursion" >&6 + exec $SHELL $0 $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion fi _ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -exec 5>>config.log -{ - echo - sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX -## Running $as_me. ## -_ASBOX - $as_echo "$ac_log" -} >&5 - -_ACEOF -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -_ACEOF - -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 - -# Handling of arguments. + + + + + +cat >>$CONFIG_STATUS <<\_ACEOF for ac_config_target in $ac_config_targets do - case $ac_config_target in - "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;; - "tcl.hpj") CONFIG_FILES="$CONFIG_FILES tcl.hpj" ;; - - *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; + case "$ac_config_target" in + # Handling of arguments. + "Makefile" ) CONFIG_FILES="$CONFIG_FILES Makefile" ;; + "tcl.hpj" ) CONFIG_FILES="$CONFIG_FILES tcl.hpj" ;; + *) { { echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5 +echo "$as_me: error: invalid argument: $ac_config_target" >&2;} + { (exit 1); exit 1; }; };; esac done - # If the user did not use the arguments to specify the items to instantiate, # then the envvar interface is used. Set only those that are not. # We use the long form for the default assignment because of an extremely # bizarre bug on SunOS 4.1.3. @@ -2431,417 +1827,326 @@ if $ac_need_defaults; then test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files fi # Have a temporary directory for convenience. Make it in the build tree -# simply because there is no reason against having it here, and in addition, +# simply because there is no reason to put it here, and in addition, # creating and moving files from /tmp can sometimes cause problems. -# Hook for its removal unless debugging. -# Note that there is a small window in which the directory will not be cleaned: -# after its creation but before its name has been assigned to `$tmp'. +# Create a temporary directory, and hook for its removal unless debugging. $debug || { - tmp= ac_tmp= - trap 'exit_status=$? - : "${ac_tmp:=$tmp}" - { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status -' 0 - trap 'as_fn_exit 1' 1 2 13 15 + trap 'exit_status=$?; rm -rf $tmp && exit $exit_status' 0 + trap '{ (exit 1); exit 1; }' 1 2 13 15 } + # Create a (secure) tmp directory for tmp files. { - tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && - test -d "$tmp" + tmp=`(umask 077 && mktemp -d -q "./confstatXXXXXX") 2>/dev/null` && + test -n "$tmp" && test -d "$tmp" } || { - tmp=./conf$$-$RANDOM - (umask 077 && mkdir "$tmp") -} || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 -ac_tmp=$tmp - -# Set up the scripts for CONFIG_FILES section. -# No need to generate them if there are no CONFIG_FILES. -# This happens for instance with `./config.status config.h'. -if test -n "$CONFIG_FILES"; then - - -ac_cr=`echo X | tr X '\015'` -# On cygwin, bash can eat \r inside `` if the user requested igncr. -# But we know of no other shell where ac_cr would be empty at this -# point, so we can use a bashism as a fallback. -if test "x$ac_cr" = x; then - eval ac_cr=\$\'\\r\' -fi -ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` -if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then - ac_cs_awk_cr='\\r' -else - ac_cs_awk_cr=$ac_cr -fi - -echo 'BEGIN {' >"$ac_tmp/subs1.awk" && -_ACEOF - - -{ - echo "cat >conf$$subs.awk <<_ACEOF" && - echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && - echo "_ACEOF" -} >conf$$subs.sh || - as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 -ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` -ac_delim='%!_!# ' -for ac_last_try in false false false false false :; do - . ./conf$$subs.sh || - as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 - - ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` - if test $ac_delim_n = $ac_delim_num; then - break - elif $ac_last_try; then - as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 - else - ac_delim="$ac_delim!$ac_delim _$ac_delim!! " - fi -done -rm -f conf$$subs.sh - -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && -_ACEOF -sed -n ' -h -s/^/S["/; s/!.*/"]=/ -p -g -s/^[^!]*!// -:repl -t repl -s/'"$ac_delim"'$// -t delim -:nl -h -s/\(.\{148\}\)..*/\1/ -t more1 -s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ -p -n -b repl -:more1 -s/["\\]/\\&/g; s/^/"/; s/$/"\\/ -p -g -s/.\{148\}// -t nl -:delim -h -s/\(.\{148\}\)..*/\1/ -t more2 -s/["\\]/\\&/g; s/^/"/; s/$/"/ -p -b -:more2 -s/["\\]/\\&/g; s/^/"/; s/$/"\\/ -p -g -s/.\{148\}// -t delim -' >$CONFIG_STATUS || ac_write_fail=1 -rm -f conf$$subs.awk -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -_ACAWK -cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && - for (key in S) S_is_set[key] = 1 - FS = "" - -} -{ - line = $ 0 - nfields = split(line, field, "@") - substed = 0 - len = length(field[1]) - for (i = 2; i < nfields; i++) { - key = field[i] - keylen = length(key) - if (S_is_set[key]) { - value = S[key] - line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) - len += length(value) + length(field[++i]) - substed = 1 - } else - len += 1 + keylen - } - - print line -} - -_ACAWK -_ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then - sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" -else - cat -fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ - || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 -_ACEOF - -# VPATH may cause trouble with some makes, so we remove sole $(srcdir), -# ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and -# trailing colons and then remove the whole line if VPATH becomes empty -# (actually we leave an empty line to preserve line numbers). -if test "x$srcdir" = x.; then - ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ -h -s/// -s/^/:/ -s/[ ]*$/:/ -s/:\$(srcdir):/:/g -s/:\${srcdir}:/:/g -s/:@srcdir@:/:/g -s/^:*// -s/:*$// -x -s/\(=[ ]*\).*/\1/ -G -s/\n// -s/^[^=]*=[ ]*$// -}' -fi - -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 + tmp=./confstat$$-$RANDOM + (umask 077 && mkdir $tmp) +} || +{ + echo "$me: cannot create a temporary directory in ." >&2 + { (exit 1); exit 1; } +} + +_ACEOF + +cat >>$CONFIG_STATUS <<_ACEOF + +# +# CONFIG_FILES section. +# + +# No need to generate the scripts if there are no CONFIG_FILES. +# This happens for instance when ./config.status config.h +if test -n "\$CONFIG_FILES"; then + # Protect against being on the right side of a sed subst in config.status. + sed 's/,@/@@/; s/@,/@@/; s/,;t t\$/@;t t/; /@;t t\$/s/[\\\\&,]/\\\\&/g; + s/@@/,@/; s/@@/@,/; s/@;t t\$/,;t t/' >\$tmp/subs.sed <<\\CEOF +s,@SHELL@,$SHELL,;t t +s,@PATH_SEPARATOR@,$PATH_SEPARATOR,;t t +s,@PACKAGE_NAME@,$PACKAGE_NAME,;t t +s,@PACKAGE_TARNAME@,$PACKAGE_TARNAME,;t t +s,@PACKAGE_VERSION@,$PACKAGE_VERSION,;t t +s,@PACKAGE_STRING@,$PACKAGE_STRING,;t t +s,@PACKAGE_BUGREPORT@,$PACKAGE_BUGREPORT,;t t +s,@exec_prefix@,$exec_prefix,;t t +s,@prefix@,$prefix,;t t +s,@program_transform_name@,$program_transform_name,;t t +s,@bindir@,$bindir,;t t +s,@sbindir@,$sbindir,;t t +s,@libexecdir@,$libexecdir,;t t +s,@datadir@,$datadir,;t t +s,@sysconfdir@,$sysconfdir,;t t +s,@sharedstatedir@,$sharedstatedir,;t t +s,@localstatedir@,$localstatedir,;t t +s,@libdir@,$libdir,;t t +s,@includedir@,$includedir,;t t +s,@oldincludedir@,$oldincludedir,;t t +s,@infodir@,$infodir,;t t +s,@mandir@,$mandir,;t t +s,@build_alias@,$build_alias,;t t +s,@host_alias@,$host_alias,;t t +s,@target_alias@,$target_alias,;t t +s,@DEFS@,$DEFS,;t t +s,@ECHO_C@,$ECHO_C,;t t +s,@ECHO_N@,$ECHO_N,;t t +s,@ECHO_T@,$ECHO_T,;t t +s,@LIBS@,$LIBS,;t t +s,@TCL_WIN_VERSION@,$TCL_WIN_VERSION,;t t +s,@CC@,$CC,;t t +s,@TCL_VERSION@,$TCL_VERSION,;t t +s,@TCL_PATCH_LEVEL@,$TCL_PATCH_LEVEL,;t t +s,@TCL_SRC_DIR@,$TCL_SRC_DIR,;t t +s,@TCL_BIN_DIR@,$TCL_BIN_DIR,;t t +s,@LIBOBJS@,$LIBOBJS,;t t +s,@LTLIBOBJS@,$LTLIBOBJS,;t t +CEOF + +_ACEOF + + cat >>$CONFIG_STATUS <<\_ACEOF + # Split the substitutions into bite-sized pieces for seds with + # small command number limits, like on Digital OSF/1 and HP-UX. + ac_max_sed_lines=48 + ac_sed_frag=1 # Number of current file. + ac_beg=1 # First line for current file. + ac_end=$ac_max_sed_lines # Line after last line for current file. + ac_more_lines=: + ac_sed_cmds= + while $ac_more_lines; do + if test $ac_beg -gt 1; then + sed "1,${ac_beg}d; ${ac_end}q" $tmp/subs.sed >$tmp/subs.frag + else + sed "${ac_end}q" $tmp/subs.sed >$tmp/subs.frag + fi + if test ! -s $tmp/subs.frag; then + ac_more_lines=false + else + # The purpose of the label and of the branching condition is to + # speed up the sed processing (if there are no `@' at all, there + # is no need to browse any of the substitutions). + # These are the two extra sed commands mentioned above. + (echo ':t + /@[a-zA-Z_][a-zA-Z_0-9]*@/!b' && cat $tmp/subs.frag) >$tmp/subs-$ac_sed_frag.sed + if test -z "$ac_sed_cmds"; then + ac_sed_cmds="sed -f $tmp/subs-$ac_sed_frag.sed" + else + ac_sed_cmds="$ac_sed_cmds | sed -f $tmp/subs-$ac_sed_frag.sed" + fi + ac_sed_frag=`expr $ac_sed_frag + 1` + ac_beg=$ac_end + ac_end=`expr $ac_end + $ac_max_sed_lines` + fi + done + if test -z "$ac_sed_cmds"; then + ac_sed_cmds=cat + fi fi # test -n "$CONFIG_FILES" - -eval set X " :F $CONFIG_FILES " -shift -for ac_tag -do - case $ac_tag in - :[FHLC]) ac_mode=$ac_tag; continue;; - esac - case $ac_mode$ac_tag in - :[FHL]*:*);; - :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; - :[FH]-) ac_tag=-:-;; - :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; - esac - ac_save_IFS=$IFS - IFS=: - set x $ac_tag - IFS=$ac_save_IFS - shift - ac_file=$1 - shift - - case $ac_mode in - :L) ac_source=$1;; - :[FH]) - ac_file_inputs= - for ac_f - do - case $ac_f in - -) ac_f="$ac_tmp/stdin";; - *) # Look for the file first in the build tree, then in the source tree - # (if the path is not absolute). The absolute path cannot be DOS-style, - # because $ac_f cannot contain `:'. - test -f "$ac_f" || - case $ac_f in - [\\/$]*) false;; - *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; - esac || - as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; - esac - case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac - as_fn_append ac_file_inputs " '$ac_f'" - done - - # Let's still pretend it is `configure' which instantiates (i.e., don't - # use $as_me), people would be surprised to read: - # /* config.h. Generated by config.status. */ - configure_input='Generated from '` - $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' - `' by configure.' - if test x"$ac_file" != x-; then - configure_input="$ac_file. $configure_input" - { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 -$as_echo "$as_me: creating $ac_file" >&6;} - fi - # Neutralize special characters interpreted by sed in replacement strings. - case $configure_input in #( - *\&* | *\|* | *\\* ) - ac_sed_conf_input=`$as_echo "$configure_input" | - sed 's/[\\\\&|]/\\\\&/g'`;; #( - *) ac_sed_conf_input=$configure_input;; - esac - - case $ac_tag in - *:-:* | *:-) cat >"$ac_tmp/stdin" \ - || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; - esac - ;; - esac - - ac_dir=`$as_dirname -- "$ac_file" || +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF +for ac_file in : $CONFIG_FILES; do test "x$ac_file" = x: && continue + # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in". + case $ac_file in + - | *:- | *:-:* ) # input from stdin + cat >$tmp/stdin + ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'` + ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; + *:* ) ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'` + ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; + * ) ac_file_in=$ac_file.in ;; + esac + + # Compute @srcdir@, @top_srcdir@, and @INSTALL@ for subdirectories. + ac_dir=`(dirname "$ac_file") 2>/dev/null || $as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$ac_file" : 'X\(//\)[^/]' \| \ X"$ac_file" : 'X\(//\)$' \| \ - X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X"$ac_file" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - as_dir="$ac_dir"; as_fn_mkdir_p + X"$ac_file" : 'X\(/\)' \| \ + . : '\(.\)' 2>/dev/null || +echo X"$ac_file" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } + /^X\(\/\/\)[^/].*/{ s//\1/; q; } + /^X\(\/\/\)$/{ s//\1/; q; } + /^X\(\/\).*/{ s//\1/; q; } + s/.*/./; q'` + { if $as_mkdir_p; then + mkdir -p "$ac_dir" + else + as_dir="$ac_dir" + as_dirs= + while test ! -d "$as_dir"; do + as_dirs="$as_dir $as_dirs" + as_dir=`(dirname "$as_dir") 2>/dev/null || +$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_dir" : 'X\(//\)[^/]' \| \ + X"$as_dir" : 'X\(//\)$' \| \ + X"$as_dir" : 'X\(/\)' \| \ + . : '\(.\)' 2>/dev/null || +echo X"$as_dir" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } + /^X\(\/\/\)[^/].*/{ s//\1/; q; } + /^X\(\/\/\)$/{ s//\1/; q; } + /^X\(\/\).*/{ s//\1/; q; } + s/.*/./; q'` + done + test ! -n "$as_dirs" || mkdir $as_dirs + fi || { { echo "$as_me:$LINENO: error: cannot create directory \"$ac_dir\"" >&5 +echo "$as_me: error: cannot create directory \"$ac_dir\"" >&2;} + { (exit 1); exit 1; }; }; } + ac_builddir=. -case "$ac_dir" in -.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; -*) - ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` - # A ".." for each directory in $ac_dir_suffix. - ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` - case $ac_top_builddir_sub in - "") ac_top_builddir_sub=. ac_top_build_prefix= ;; - *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; - esac ;; -esac -ac_abs_top_builddir=$ac_pwd -ac_abs_builddir=$ac_pwd$ac_dir_suffix -# for backward compatibility: -ac_top_builddir=$ac_top_build_prefix +if test "$ac_dir" != .; then + ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'` + # A "../" for each directory in $ac_dir_suffix. + ac_top_builddir=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,../,g'` +else + ac_dir_suffix= ac_top_builddir= +fi case $srcdir in - .) # We are building in place. - ac_srcdir=. - ac_top_srcdir=$ac_top_builddir_sub - ac_abs_top_srcdir=$ac_pwd ;; - [\\/]* | ?:[\\/]* ) # Absolute name. - ac_srcdir=$srcdir$ac_dir_suffix; - ac_top_srcdir=$srcdir - ac_abs_top_srcdir=$srcdir ;; - *) # Relative name. - ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix - ac_top_srcdir=$ac_top_build_prefix$srcdir - ac_abs_top_srcdir=$ac_pwd/$srcdir ;; -esac -ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix - - - case $ac_mode in - :F) - # - # CONFIG_FILE - # - -_ACEOF - -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -# If the template does not know about datarootdir, expand it. -# FIXME: This hack should be removed a few years after 2.60. -ac_datarootdir_hack=; ac_datarootdir_seen= -ac_sed_dataroot=' -/datarootdir/ { - p - q -} -/@datadir@/p -/@docdir@/p -/@infodir@/p -/@localedir@/p -/@mandir@/p' -case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in -*datarootdir*) ac_datarootdir_seen=yes;; -*@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 -$as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} -_ACEOF -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 - ac_datarootdir_hack=' - s&@datadir@&$datadir&g - s&@docdir@&$docdir&g - s&@infodir@&$infodir&g - s&@localedir@&$localedir&g - s&@mandir@&$mandir&g - s&\\\${datarootdir}&$datarootdir&g' ;; -esac -_ACEOF - -# Neutralize VPATH when `$srcdir' = `.'. -# Shell code in configure.ac might set extrasub. -# FIXME: do we really want to maintain this feature? -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -ac_sed_extra="$ac_vpsub + .) # No --srcdir option. We are building in place. + ac_srcdir=. + if test -z "$ac_top_builddir"; then + ac_top_srcdir=. + else + ac_top_srcdir=`echo $ac_top_builddir | sed 's,/$,,'` + fi ;; + [\\/]* | ?:[\\/]* ) # Absolute path. + ac_srcdir=$srcdir$ac_dir_suffix; + ac_top_srcdir=$srcdir ;; + *) # Relative path. + ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix + ac_top_srcdir=$ac_top_builddir$srcdir ;; +esac + +# Do not use `cd foo && pwd` to compute absolute paths, because +# the directories may not exist. +case `pwd` in +.) ac_abs_builddir="$ac_dir";; +*) + case "$ac_dir" in + .) ac_abs_builddir=`pwd`;; + [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";; + *) ac_abs_builddir=`pwd`/"$ac_dir";; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_top_builddir=${ac_top_builddir}.;; +*) + case ${ac_top_builddir}. in + .) ac_abs_top_builddir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;; + *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_srcdir=$ac_srcdir;; +*) + case $ac_srcdir in + .) ac_abs_srcdir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;; + *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_top_srcdir=$ac_top_srcdir;; +*) + case $ac_top_srcdir in + .) ac_abs_top_srcdir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;; + *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;; + esac;; +esac + + + + if test x"$ac_file" != x-; then + { echo "$as_me:$LINENO: creating $ac_file" >&5 +echo "$as_me: creating $ac_file" >&6;} + rm -f "$ac_file" + fi + # Let's still pretend it is `configure' which instantiates (i.e., don't + # use $as_me), people would be surprised to read: + # /* config.h. Generated by config.status. */ + if test x"$ac_file" = x-; then + configure_input= + else + configure_input="$ac_file. " + fi + configure_input=$configure_input"Generated from `echo $ac_file_in | + sed 's,.*/,,'` by configure." + + # First look for the input files in the build tree, otherwise in the + # src tree. + ac_file_inputs=`IFS=: + for f in $ac_file_in; do + case $f in + -) echo $tmp/stdin ;; + [\\/$]*) + # Absolute (can't be DOS-style, as IFS=:) + test -f "$f" || { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 +echo "$as_me: error: cannot find input file: $f" >&2;} + { (exit 1); exit 1; }; } + echo "$f";; + *) # Relative + if test -f "$f"; then + # Build tree + echo "$f" + elif test -f "$srcdir/$f"; then + # Source tree + echo "$srcdir/$f" + else + # /dev/null tree + { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 +echo "$as_me: error: cannot find input file: $f" >&2;} + { (exit 1); exit 1; }; } + fi;; + esac + done` || { (exit 1); exit 1; } +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF + sed "$ac_vpsub $extrasub _ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +cat >>$CONFIG_STATUS <<\_ACEOF :t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b -s|@configure_input@|$ac_sed_conf_input|;t t -s&@top_builddir@&$ac_top_builddir_sub&;t t -s&@top_build_prefix@&$ac_top_build_prefix&;t t -s&@srcdir@&$ac_srcdir&;t t -s&@abs_srcdir@&$ac_abs_srcdir&;t t -s&@top_srcdir@&$ac_top_srcdir&;t t -s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t -s&@builddir@&$ac_builddir&;t t -s&@abs_builddir@&$ac_abs_builddir&;t t -s&@abs_top_builddir@&$ac_abs_top_builddir&;t t -$ac_datarootdir_hack -" -eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ - >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 - -test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && - { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && - { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ - "$ac_tmp/out"`; test -z "$ac_out"; } && - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' -which seems to be undefined. Please make sure it is defined" >&5 -$as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' -which seems to be undefined. Please make sure it is defined" >&2;} - - rm -f "$ac_tmp/stdin" - case $ac_file in - -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; - *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; - esac \ - || as_fn_error $? "could not create $ac_file" "$LINENO" 5 - ;; - - - - esac - -done # for ac_tag - - -as_fn_exit 0 -_ACEOF -ac_clean_files=$ac_clean_files_save - -test $ac_write_fail = 0 || - as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 +s,@configure_input@,$configure_input,;t t +s,@srcdir@,$ac_srcdir,;t t +s,@abs_srcdir@,$ac_abs_srcdir,;t t +s,@top_srcdir@,$ac_top_srcdir,;t t +s,@abs_top_srcdir@,$ac_abs_top_srcdir,;t t +s,@builddir@,$ac_builddir,;t t +s,@abs_builddir@,$ac_abs_builddir,;t t +s,@top_builddir@,$ac_top_builddir,;t t +s,@abs_top_builddir@,$ac_abs_top_builddir,;t t +" $ac_file_inputs | (eval "$ac_sed_cmds") >$tmp/out + rm -f $tmp/stdin + if test x"$ac_file" != x-; then + mv $tmp/out $ac_file + else + cat $tmp/out + rm -f $tmp/out + fi + +done +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF + +{ (exit 0); exit 0; } +_ACEOF +chmod +x $CONFIG_STATUS +ac_clean_files=$ac_clean_files_save # configure is writing to config.log, and then calls config.status. # config.status does its own redirection, appending to config.log. # Unfortunately, on DOS this fails, as config.log is still kept open @@ -2858,12 +2163,8 @@ exec 5>/dev/null $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false exec 5>>config.log # Use ||, not &&, to avoid exiting from the if with $? = 1, which # would make configure fail if this is the last instruction. - $ac_cs_success || as_fn_exit 1 -fi -if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 -$as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} + $ac_cs_success || { (exit 1); exit 1; } fi DELETED tools/configure.ac Index: tools/configure.ac ================================================================== --- tools/configure.ac +++ /dev/null @@ -1,35 +0,0 @@ -dnl This file is an input file used by the GNU "autoconf" program to -dnl generate the file "configure", which is run to configure the -dnl Makefile in this directory. -AC_INIT(man2tcl.c) -AC_PREREQ(2.69) - -# Recover information that Tcl computed with its configure script. - -#-------------------------------------------------------------------- -# See if there was a command-line option for where Tcl is; if -# not, assume that its top-level directory is a sibling of ours. -#-------------------------------------------------------------------- - -DEF_VER=9.0 - -AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl $DEF_VER binaries from DIR], TCL_BIN_DIR=$withval, TCL_BIN_DIR=`cd ../../tcl$DEF_VER$TCL_PATCH_LEVEL/unix; pwd`) -if test ! -d $TCL_BIN_DIR; then - AC_MSG_ERROR(Tcl directory $TCL_BIN_DIR doesn't exist) -fi -if test ! -f $TCL_BIN_DIR/tclConfig.sh; then - AC_MSG_ERROR(There's no tclConfig.sh in $TCL_BIN_DIR; perhaps you didn't specify the Tcl *build* directory (not the toplevel Tcl directory) or you forgot to configure Tcl?) -fi - -. $TCL_BIN_DIR/tclConfig.sh - -TCL_WIN_VERSION=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION -AC_SUBST(TCL_WIN_VERSION) -CC=$TCL_CC -AC_SUBST(CC) -AC_SUBST(TCL_VERSION) -AC_SUBST(TCL_PATCH_LEVEL) -AC_SUBST(TCL_SRC_DIR) -AC_SUBST(TCL_BIN_DIR) - -AC_OUTPUT(Makefile tcl.hpj) ADDED tools/configure.in Index: tools/configure.in ================================================================== --- /dev/null +++ tools/configure.in @@ -0,0 +1,35 @@ +dnl This file is an input file used by the GNU "autoconf" program to +dnl generate the file "configure", which is run to configure the +dnl Makefile in this directory. +AC_INIT(man2tcl.c) +AC_PREREQ(2.59) + +# Recover information that Tcl computed with its configure script. + +#-------------------------------------------------------------------- +# See if there was a command-line option for where Tcl is; if +# not, assume that its top-level directory is a sibling of ours. +#-------------------------------------------------------------------- + +DEF_VER=8.6 + +AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl $DEF_VER binaries from DIR], TCL_BIN_DIR=$withval, TCL_BIN_DIR=`cd ../../tcl$DEF_VER$TCL_PATCH_LEVEL/unix; pwd`) +if test ! -d $TCL_BIN_DIR; then + AC_MSG_ERROR(Tcl directory $TCL_BIN_DIR doesn't exist) +fi +if test ! -f $TCL_BIN_DIR/tclConfig.sh; then + AC_MSG_ERROR(There's no tclConfig.sh in $TCL_BIN_DIR; perhaps you didn't specify the Tcl *build* directory (not the toplevel Tcl directory) or you forgot to configure Tcl?) +fi + +. $TCL_BIN_DIR/tclConfig.sh + +TCL_WIN_VERSION=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION +AC_SUBST(TCL_WIN_VERSION) +CC=$TCL_CC +AC_SUBST(CC) +AC_SUBST(TCL_VERSION) +AC_SUBST(TCL_PATCH_LEVEL) +AC_SUBST(TCL_SRC_DIR) +AC_SUBST(TCL_BIN_DIR) + +AC_OUTPUT(Makefile tcl.hpj) Index: tools/encoding/Makefile ================================================================== --- tools/encoding/Makefile +++ tools/encoding/Makefile @@ -1,7 +1,7 @@ # -# This file is a Makefile to compile all the encoding files. +# This file is a Makefile to compile all the encoding files. # # Run "make" to compile all the encoding files (*.txt,*.esc) into the # format that Tcl can use (*.enc). It is your responsibility to move the # encoding files to the appropriate place ($TCL_ROOT/library/encoding # @@ -24,20 +24,20 @@ # internal distribution and to freely use the information supplied # in the creation of products supporting Unicode. Unicode, Inc. # specifically excludes the right to re-distribute this file directly # to third parties or other organizations whether for profit or not. # -# In other words: Don't put this file on the Internet. People who want to +# In other words: Don't put this file on the Internet. People who want to # get it over the Internet should do so directly from ftp://unicode.org. They # can therefore be assured of getting the most recent and accurate version. # #---------------------------------------------------------------------------- # # The txt2enc program built by this makefile is used to compile individual -# .txt files into .enc files, the format that Tcl understands for encoding +# .txt files into .enc files, the format that Tcl understands for encoding # files. This compilation to a different format is allowed by the above -# restriction. +# restriction. # # The files shiftjis.txt and jis0208.txt were modified from the original # ones provided on the Unicode CD. The double-width backslash character # 0x815F in these two Japanese encodings was being mapped to Unicode 005C # (REVERSE SOLIDUS), the normal backslash character. They have been @@ -51,11 +51,11 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # SCCS: @(#) Makefile 1.1 98/01/28 11:41:36 # -EUC_ENCODINGS = euc-cn.txt euc-kr.txt euc-jp.txt +EUC_ENCODINGS = euc-cn.txt euc-kr.txt euc-jp.txt encodings: clean txt2enc $(EUC_ENCODINGS) @echo Compiling encoding files. @for p in *.esc; do \ base=`echo $$p | sed 's/\..*$$//'`; \ @@ -67,11 +67,11 @@ @for p in *.txt; do \ enc=`echo $$p | sed 's/\..*$$/\.enc/'`; \ echo $$enc; \ ./txt2enc -e 0 -u 1 $$p > $$enc; \ done - @echo + @echo @echo Compiling special versions of encoding files. @for p in ascii.txt; do \ enc=`echo $$p | sed 's/\..*$$/\.enc/'`; \ echo $$enc; \ ./txt2enc -m $$p > $$enc; \ Index: tools/encoding/big5.txt ================================================================== --- tools/encoding/big5.txt +++ tools/encoding/big5.txt @@ -39,11 +39,11 @@ # # This table contains the data Metis and Taligent currently have on how # BIG5 characters map into Unicode. # # WARNING! It is currently impossible to provide round-trip compatibility -# between BIG5 and Unicode. +# between BIG5 and Unicode. # # A number of characters are not currently mapped because # of conflicts with other mappings. They are as follows: # # BIG5 Description Comments @@ -56,12 +56,12 @@ # 0xA2CC HANGZHOU NUMERAL TEN conflicts with A451 mapping # 0xA2CE HANGZHOU NUMERAL THIRTY conflicts with A4CA mapping # # We currently map all of these characters to U+FFFD REPLACEMENT CHARACTER. # It is also possible to map these characters to their duplicates, or to -# the user zone. -# +# the user zone. +# # Notes: # # 1. In addition to the above, there is some uncertainty about the # mappings in the range C6A1 - C8FE, and F9DD - F9FE. The ETEN # version of BIG5 organizes the former range differently, and adds @@ -70,17 +70,17 @@ # # 2. There is an uncertainty in the mapping of the Big Five character # 0xA3BC. This character occurs within the Big Five block of tone marks # for bopomofo and is intended to be the tone mark for the first tone in # Mandarin Chinese. We have selected the mapping U+02C9 MODIFIER LETTER -# MACRON (Mandarin Chinese first tone) to reflect this semantic. +# MACRON (Mandarin Chinese first tone) to reflect this semantic. # However, because bopomofo uses the absense of a tone mark to indicate # the first Mandarin tone, most implementations of Big Five represent # this character with a blank space, and so a mapping such as U+2003 EM SPACE -# might be preferred. -# -# +# might be preferred. +# +# # # Format: Three tab-separated columns # Column #1 is the BIG5 code (in hex as 0xXXXX) # Column #2 is the Unicode (in hex as 0xXXXX) # Column #3 is the Unicode name (follows a comment sign, '#') Index: tools/encoding/jis0212.txt ================================================================== --- tools/encoding/jis0212.txt +++ tools/encoding/jis0212.txt @@ -59,21 +59,21 @@ # # Notes: # # 1. JIS X 0212 apparently unified the following two symbols # into a single character at 0x2922: -# +# # LATIN CAPITAL LETTER D WITH STROKE # LATIN CAPITAL LETTER ETH # # However, JIS X 0212 maintains the distinction between # the lowercase forms of these two elements at 0x2942 and 0x2943. # Given the structre of these JIS encodings, it is clear that # 0x2922 and 0x2942 are intended to be a capital/small pair. # Consequently, in the Unicode mapping, 0x2922 is treated as # LATIN CAPITAL LETTER D WITH STROKE. -# +# 0x222F 0x02D8 # BREVE 0x2230 0x02C7 # CARON (Mandarin Chinese third tone) 0x2231 0x00B8 # CEDILLA 0x2232 0x02D9 # DOT ABOVE (Mandarin Chinese light tone) 0x2233 0x02DD # DOUBLE ACUTE ACCENT Index: tools/encoding/ksc5601.txt ================================================================== --- tools/encoding/ksc5601.txt +++ tools/encoding/ksc5601.txt @@ -3,11 +3,11 @@ # (at ftp://ftp.unicode.org/Public/MAPPING/EASTASIA/KSC) which is # actually NOT the mapping between KS C 5601-1992 and Unicode 2.0 # BUT the mapping table between UHC(Microsoft Unified Hangul Code) # and Unicode 2.0. Hence, in this pacakge, I renamed it as UHC.TXT # -# The Unix command used is +# The Unix command used is # egrep '^0x' < KSC5601.TXT | \ # egrep -v '^0x([8-9]...|A0..|..[4-9].|..A0)' | perl tab.pl # # where tab.pl is as following #----------tab.pl @@ -24,12 +24,12 @@ # in hex as 0xXXXX # Column #2 : the Unicode (in hex as 0xXXXX) # Column #3 : the Unicode name (following a comment sign, '#') # The number of characters enumerated in this table is 8824, the # as listed in KS C 5601-987 -# -# +# +# # The entries are in KS C 5601-1987 order # You can use the following algorithms to convert the hex form # of KS C 5601 to other forms # To get EUCKorea(EUC-KR) code points, add 0x8080. # To get row(Hang) and column(Yol) as used in KS C 5601-1987 manual, Index: tools/encoding/macCentEuro.txt ================================================================== --- tools/encoding/macCentEuro.txt +++ tools/encoding/macCentEuro.txt @@ -32,11 +32,11 @@ # Unicode standard. # # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable -# for direct, indirect, special, incidental, or consequential damages +# for direct, indirect, special, incidental, or consequential damages # resulting from any defect or inaccuracy in this document or the # accompanying tables. # # These mapping tables and character lists are subject to change. # The latest tables should be available from the following: Index: tools/encoding/macCroatian.txt ================================================================== --- tools/encoding/macCroatian.txt +++ tools/encoding/macCroatian.txt @@ -34,11 +34,11 @@ # Unicode standard. # # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable -# for direct, indirect, special, incidental, or consequential damages +# for direct, indirect, special, incidental, or consequential damages # resulting from any defect or inaccuracy in this document or the # accompanying tables. # # These mapping tables and character lists are subject to change. # The latest tables should be available from the following: Index: tools/encoding/macCyrillic.txt ================================================================== --- tools/encoding/macCyrillic.txt +++ tools/encoding/macCyrillic.txt @@ -35,11 +35,11 @@ # Unicode standard. # # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable -# for direct, indirect, special, incidental, or consequential damages +# for direct, indirect, special, incidental, or consequential damages # resulting from any defect or inaccuracy in this document or the # accompanying tables. # # These mapping tables and character lists are subject to change. # The latest tables should be available from the following: Index: tools/encoding/macGreek.txt ================================================================== --- tools/encoding/macGreek.txt +++ tools/encoding/macGreek.txt @@ -33,11 +33,11 @@ # Unicode standard. # # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable -# for direct, indirect, special, incidental, or consequential damages +# for direct, indirect, special, incidental, or consequential damages # resulting from any defect or inaccuracy in this document or the # accompanying tables. # # These mapping tables and character lists are subject to change. # The latest tables should be available from the following: Index: tools/encoding/macIceland.txt ================================================================== --- tools/encoding/macIceland.txt +++ tools/encoding/macIceland.txt @@ -35,11 +35,11 @@ # Unicode standard. # # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable -# for direct, indirect, special, incidental, or consequential damages +# for direct, indirect, special, incidental, or consequential damages # resulting from any defect or inaccuracy in this document or the # accompanying tables. # # These mapping tables and character lists are subject to change. # The latest tables should be available from the following: Index: tools/encoding/macRoman.txt ================================================================== --- tools/encoding/macRoman.txt +++ tools/encoding/macRoman.txt @@ -39,11 +39,11 @@ # Unicode standard. # # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable -# for direct, indirect, special, incidental, or consequential damages +# for direct, indirect, special, incidental, or consequential damages # resulting from any defect or inaccuracy in this document or the # accompanying tables. # # These mapping tables and character lists are subject to change. # The latest tables should be available from the following: Index: tools/encoding/macTurkish.txt ================================================================== --- tools/encoding/macTurkish.txt +++ tools/encoding/macTurkish.txt @@ -32,11 +32,11 @@ # Unicode standard. # # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable -# for direct, indirect, special, incidental, or consequential damages +# for direct, indirect, special, incidental, or consequential damages # resulting from any defect or inaccuracy in this document or the # accompanying tables. # # These mapping tables and character lists are subject to change. # The latest tables should be available from the following: Index: tools/encoding/shiftjis.txt ================================================================== --- tools/encoding/shiftjis.txt +++ tools/encoding/shiftjis.txt @@ -45,11 +45,11 @@ # The single-byte and double-byte blocks are in ascending # hexadecimal order # There is an alternative order some people might be preferred, # where all the entries are in order of the top (or only) byte. # This alternate order can be generated from the one given here -# by a simple sort. +# by a simple sort. # # The kanji mappings are a normative part of ISO/IEC 10646. The # non-kanji mappings are provisional, pending definition of # official mappings by Japanese standards bodies # Index: tools/encoding/tis-620.txt ================================================================== --- tools/encoding/tis-620.txt +++ tools/encoding/tis-620.txt @@ -174,11 +174,11 @@ 0xA6 0x0E06 #THAI CHARACTER KHO RAKHANG 0xA7 0x0E07 #THAI CHARACTER NGO NGU 0xA8 0x0E08 #THAI CHARACTER CHO CHAN 0xA9 0x0E09 #THAI CHARACTER CHO CHING 0xAA 0x0E0A #THAI CHARACTER CHO CHANG -0xAB 0x0E0B #THAI CHARACTER SO SO +0xAB 0x0E0B #THAI CHARACTER SO SO 0xAC 0x0E0C #THAI CHARACTER CHO CHOE 0xAD 0x0E0D #THAI CHARACTER YO YING 0xAE 0x0E0E #THAI CHARACTER DO CHADA 0xAF 0x0E0F #THAI CHARACTER TO PATAK 0xB0 0x0E10 #THAI CHARACTER THO THAN Index: tools/encoding/txt2enc.c ================================================================== --- tools/encoding/txt2enc.c +++ tools/encoding/txt2enc.c @@ -174,11 +174,11 @@ if (enc < 32 || uni < 32) { continue; } hi = enc >> 8; - lo = enc & 0xff; + lo = enc & 0xFF; if (toUnicode[hi] == NULL) { toUnicode[hi] = (Rune *) malloc(256 * sizeof(Rune)); memset(toUnicode[hi], 0, 256 * sizeof(Rune)); } toUnicode[hi][lo] = uni; @@ -206,11 +206,11 @@ } for (i = 0; i < 0x20; i++) { toUnicode[0][i] = i; } if (fixmissing) { - for (i = 0x7F; i < 0xa0; i++) { + for (i = 0x7F; i < 0xA0; i++) { if (toUnicode[i] == NULL && toUnicode[0][i] == 0) { toUnicode[0][i] = i; } } } @@ -232,11 +232,11 @@ for (hi = 0; hi < 256; hi++) { if (toUnicode[hi] != NULL) { printf("%02X\n", hi); for (lo = 0; lo < 256; lo++) { printf("%04X", toUnicode[hi][lo]); - if ((lo & 0x0f) == 0x0f) { + if ((lo & 0x0F) == 0x0F) { putchar('\n'); } } } } Index: tools/fix_tommath_h.tcl ================================================================== --- tools/fix_tommath_h.tcl +++ tools/fix_tommath_h.tcl @@ -20,10 +20,11 @@ if {!$eat_semi && !$eat_endif} { switch -regexp -- $line { {#define BN_H_} { puts $line puts {} + puts "\#include \"tclInt.h\"" puts "\#include \"tclTomMathDecls.h\"" puts "\#ifndef MODULE_SCOPE" puts "\#define MODULE_SCOPE extern" puts "\#endif" } @@ -43,16 +44,10 @@ puts "\#ifndef MP_DIGIT_DECLARED" puts $line puts "\#define MP_DIGIT_DECLARED" puts "\#endif" } - {typedef.*mp_word;} { - puts "\#ifndef MP_WORD_DECLARED" - puts $line - puts "\#define MP_WORD_DECLARED" - puts "\#endif" - } {typedef struct} { puts "\#ifndef MP_INT_DECLARED" puts "\#define MP_INT_DECLARED" puts "typedef struct mp_int mp_int;" puts "\#endif" @@ -76,10 +71,14 @@ {define heap macros} { puts $line puts "\#if 0 /* these are macros in tclTomMathDecls.h */" set eat_endif 1 } + {__x86_64__} { + puts "[string map {__x86_64__ NEVER} $line]\ + /* 128-bit ints fail in too many places */" + } {#include} { # remove all includes } default { puts $line Index: tools/genStubs.tcl ================================================================== --- tools/genStubs.tcl +++ tools/genStubs.tcl @@ -477,15 +477,19 @@ append text "/* $index */\n" if {[info exists stubs($name,deprecated,$index)]} { append text "[string toupper $libraryName]_DEPRECATED(\"$stubs($name,deprecated,$index)\")\n" set line "$rtype" + } elseif {[string range $rtype end-5 end] eq "MP_WUR"} { + set line "$scspec [string trim [string range $rtype 0 end-6]]" } else { set line "$scspec $rtype" } set count [expr {2 - ([string length $line] / 8)}] - append line [string range "\t\t\t" 0 $count] + if {$count >= 0} { + append line [string range "\t\t\t" 0 $count] + } set pad [expr {24 - [string length $line]}] if {$pad <= 0} { append line " " set pad 0 } @@ -545,10 +549,13 @@ append line $next set sep ", " } append line ")" } + } + if {[string range $rtype end-5 end] eq "MP_WUR"} { + append line " MP_WUR" } return "$text$line;\n" } # genStubs::makeMacro -- @@ -609,10 +616,12 @@ } if {[string range $rtype end-8 end] eq "__stdcall"} { append text [string trim [string range $rtype 0 end-9]] " (__stdcall *" $lfname ") " } elseif {[string range $rtype 0 11] eq "TCL_NORETURN"} { append text "TCL_NORETURN1 " [string trim [string range $rtype 12 end]] " (*" $lfname ") " + } elseif {[string range $rtype end-5 end] eq "MP_WUR"} { + append text [string trim [string range $rtype 0 end-6]] " (*" $lfname ") " } else { append text $rtype " (*" $lfname ") " } set arg1 [lindex $args 0] switch -exact $arg1 { @@ -646,10 +655,13 @@ } append text ")" } } + if {[string range $rtype end-5 end] eq "MP_WUR"} { + append text " MP_WUR" + } append text "; /* $index */\n" return $text } # genStubs::makeInit -- DELETED tools/installVfs.tcl Index: tools/installVfs.tcl ================================================================== --- tools/installVfs.tcl +++ /dev/null @@ -1,54 +0,0 @@ -#!/bin/sh -#\ -exec tclsh "$0" ${1+"$@"} - -#---------------------------------------------------------------------- -# -# installVfs.tcl -- -# -# This file wraps the /library file system around a binary -# -#---------------------------------------------------------------------- -# -# Copyright (c) 2018 by Sean Woods. All rights reserved. -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -#---------------------------------------------------------------------- - -proc mapDir {resultvar prefix filepath} { - upvar 1 $resultvar result - if {![info exists result]} { - set result {} - } - set queue [list $prefix $filepath] - while {[llength $queue]} { - set queue [lassign $queue qprefix qpath] - foreach ftail [glob -directory $qpath -nocomplain -tails *] { - set f [file join $qpath $ftail] - if {[file isdirectory $f]} { - if {$ftail eq "CVS"} continue - lappend queue [file join $qprefix $ftail] $f - } elseif {[file isfile $f]} { - if {$ftail eq "pkgIndex.tcl"} continue - if {$ftail eq "manifest.txt"} { - lappend result $f [file join $qprefix pkgIndex.tcl] - } else { - lappend result $f [file join $qprefix $ftail] - } - } - } - } -} -if {[llength $argv]<4} { - error "Usage: [file tail [info script]] IMG_OUTPUT IMG_INPUT PREFIX FILE_SYSTEM ?PREFIX FILE_SYSTEM?..." -} - -set paths [lassign $argv DLL_OUTPUT DLL_INPUT] -foreach {prefix fpath} $paths { - mapDir files $prefix [file normalize $fpath] -} -if {$DLL_INPUT != {}} { - zipfs lmkzip $DLL_OUTPUT $files -} else { - zipfs lmkimg $DLL_OUTPUT $files {} $DLL_INPUT -} Index: tools/loadICU.tcl ================================================================== --- tools/loadICU.tcl +++ tools/loadICU.tcl @@ -25,13 +25,10 @@ # Copyright (c) 2004 by Kevin B. Kenny. All rights reserved. # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. #---------------------------------------------------------------------- -puts stdout "TODO: output in UTF-8 in stead of using \\uhhhh sequences" -exit; # Remove those two lines after modifying this tool. - # Calculate the Chinese numerals from zero to ninety-nine. set zhDigits [list {} \u4e00 \u4e8c \u4e09 \u56db \ \u4e94 \u516d \u4e03 \u516b \u4e5d] set t 0 @@ -589,11 +586,11 @@ proc backslashify { string } { set retval {} foreach char [split $string {}] { scan $char %c ccode - if { $ccode >= 0x0020 && $ccode < 0x007f && $char ne "\"" + if { $ccode >= 0x20 && $ccode < 0x7F && $char ne "\"" && $char ne "\{" && $char ne "\}" && $char ne "\[" && $char ne "\]" && $char ne "\\" && $char ne "\$" } { append retval $char } else { append retval \\u [format %04x $ccode] DELETED tools/makeHeader.tcl Index: tools/makeHeader.tcl ================================================================== --- tools/makeHeader.tcl +++ /dev/null @@ -1,182 +0,0 @@ -# makeHeader.tcl -- -# -# This script generates embeddable C source (in a .h file) from a .tcl -# script. -# -# Copyright (c) 2018 Donal K. Fellows -# -# 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 - -namespace eval makeHeader { - - #################################################################### - # - # mapSpecial -- - # Transform a single line so that it is able to be put in a C string. - # - proc mapSpecial {str} { - # All Tcl metacharacters and key C backslash sequences - set MAP { - \" \\\\\" \\ \\\\\\\\ $ \\$ [ \\[ ] \\] ' \\\\' ? \\\\? - \a \\\\a \b \\\\b \f \\\\f \n \\\\n \r \\\\r \t \\\\t \v \\\\v - } - set XFORM {[format \\\\\\\\u%04x {*}[scan & %c]]} - - subst [regsub -all {[^\u0020-\u007e]} [string map $MAP $str] $XFORM] - } - - #################################################################### - # - # compactLeadingSpaces -- - # Converts the leading whitespace on a line into a more compact form. - # - proc compactLeadingSpaces {line} { - set line [string map {\t { }} [string trimright $line]] - if {[regexp {^[ ]+} $line spaces]} { - regsub -all {[ ]{4}} $spaces \t replace - set len [expr {[string length $spaces] - 1}] - set line [string replace $line 0 $len $replace] - } - return $line - } - - #################################################################### - # - # processScript -- - # Transform a whole sequence of lines with [mapSpecial]. - # - proc processScript {scriptLines} { - lmap line $scriptLines { - # Skip blank and comment lines; they're there in the original - # sources so we don't need to copy them over. - if {[regexp {^\s*(?:#|$)} $line]} continue - format {"%s"} [mapSpecial [compactLeadingSpaces $line]\n] - } - } - - #################################################################### - # - # updateTemplate -- - # Rewrite a template to contain the content from the input script. - # - proc updateTemplate {dataVar scriptLines} { - set BEGIN "*!BEGIN!: Do not edit below this line.*" - set END "*!END!: Do not edit above this line.*" - - upvar 1 $dataVar data - - set from [lsearch -glob $data $BEGIN] - set to [lsearch -glob $data $END] - if {$from == -1 || $to == -1 || $from >= $to} { - throw BAD "not a template" - } - - set data [lreplace $data $from+1 $to-1 {*}[processScript $scriptLines]] - } - - #################################################################### - # - # stripSurround -- - # Removes the header and footer comments from a (line-split list of - # lines of) Tcl script code. - # - proc stripSurround {lines} { - set RE {^\s*$|^#} - set state 0 - set lines [lmap line [lreverse $lines] { - if {!$state && [regexp $RE $line]} continue { - set state 1 - set line - } - }] - return [lmap line [lreverse $lines] { - if {$state && [regexp $RE $line]} continue { - set state 0 - set line - } - }] - } - - #################################################################### - # - # updateTemplateFile -- - # Rewrites a template file with the lines of the given script. - # - proc updateTemplateFile {headerFile scriptLines} { - set f [open $headerFile "r+"] - try { - set content [split [chan read -nonewline $f] "\n"] - updateTemplate content [stripSurround $scriptLines] - chan seek $f 0 - chan puts $f [join $content \n] - chan truncate $f - } trap BAD msg { - # Add the filename to the message - throw BAD "${headerFile}: $msg" - } finally { - chan close $f - } - } - - #################################################################### - # - # readScript -- - # Read a script from a file and return its lines. - # - proc readScript {script} { - set f [open $script] - try { - chan configure $f -encoding utf-8 - return [split [string trim [chan read $f]] "\n"] - } finally { - chan close $f - } - } - - #################################################################### - # - # run -- - # The main program of this script. - # - proc run {args} { - try { - if {[llength $args] != 2} { - throw ARGS "inputTclScript templateFile" - } - lassign $args inputTclScript templateFile - - puts "Inserting $inputTclScript into $templateFile" - set scriptLines [readScript $inputTclScript] - updateTemplateFile $templateFile $scriptLines - exit 0 - } trap ARGS msg { - puts stderr "wrong # args: should be \"[file tail $::argv0] $msg\"" - exit 2 - } trap BAD msg { - puts stderr $msg - exit 1 - } trap POSIX msg { - puts stderr $msg - exit 1 - } on error {- opts} { - puts stderr [dict get $opts -errorinfo] - exit 3 - } - } -} - -######################################################################## -# -# Launch the main program -# -if {[info script] eq $::argv0} { - makeHeader::run {*}$::argv -} - -# Local-Variables: -# mode: tcl -# fill-column: 78 -# End: Index: tools/makeTestCases.tcl ================================================================== --- tools/makeTestCases.tcl +++ tools/makeTestCases.tcl @@ -590,11 +590,11 @@ foreach row $TZData(:America/Detroit) { foreach { t offset isdst tzname } $row break if { $t > -4000000000000 } { set conds [list detroit] - if { $t > wide(0x7fffffff) } { + if { $t > wide(0x7FFFFFFF) } { set conds [list detroit y2038] } incr t -1 set x [clock format $t -format {%Y-%m-%d %H:%M:%S} \ -timezone :America/Detroit] Index: tools/man2help2.tcl ================================================================== --- tools/man2help2.tcl +++ tools/man2help2.tcl @@ -155,11 +155,11 @@ "\{" "\\\{" \ "\}" "\\\}" \ "\t" {\tab } \ '' "\\rdblquote " \ `` "\\ldblquote " \ - "\u00b7" "\\bullet " \ + "\xB7" "\\bullet " \ ] $string] # Check if this is the beginning of an international character string. # If so, look up the sequence in the chars table and substitute the # appropriate hex value. @@ -822,11 +822,11 @@ set indent 5 } elseif {$length == 1} { set indent 5 } if {$text == {\(bu}} { - set text "\u00b7" + set text "\xB7" } set tab [expr {$indent * 0.1}]i newPara $tab -$tab set state(sb) 80 DELETED tools/mkVfs.tcl Index: tools/mkVfs.tcl ================================================================== --- tools/mkVfs.tcl +++ /dev/null @@ -1,99 +0,0 @@ -proc cat fname { - set fname [open $fname r] - set data [read $fname] - close $fname - return $data -} - -proc pkgIndexDir {root fout d1} { - - puts [format {%*sIndexing %s} [expr {4 * [info level]}] {} \ - [file tail $d1]] - set idx [string length $root] - foreach ftail [glob -directory $d1 -nocomplain -tails *] { - set f [file join $d1 $ftail] - if {[file isdirectory $f] && [string compare CVS $ftail]} { - pkgIndexDir $root $fout $f - } elseif {[file tail $f] eq "pkgIndex.tcl"} { - puts $fout "set dir \${VFSROOT}[string range $d1 $idx end]" - puts $fout [cat $f] - } - } -} - -### -# Script to build the VFS file system -### -proc copyDir {d1 d2} { - - puts [format {%*sCreating %s} [expr {4 * [info level]}] {} \ - [file tail $d2]] - - file delete -force -- $d2 - file mkdir $d2 - - foreach ftail [glob -directory $d1 -nocomplain -tails *] { - set f [file join $d1 $ftail] - if {[file isdirectory $f] && [string compare CVS $ftail]} { - copyDir $f [file join $d2 $ftail] - } elseif {[file isfile $f]} { - file copy -force $f [file join $d2 $ftail] - if {$::tcl_platform(platform) eq {unix}} { - file attributes [file join $d2 $ftail] -permissions 0644 - } else { - file attributes [file join $d2 $ftail] -readonly 1 - } - } - } - - if {$::tcl_platform(platform) eq {unix}} { - file attributes $d2 -permissions 0755 - } else { - file attributes $d2 -readonly 1 - } -} - -if {[llength $argv] < 3} { - puts "Usage: VFS_ROOT TCLSRC_ROOT PLATFORM" - exit 1 -} -set TCL_SCRIPT_DIR [lindex $argv 0] -set TCLSRC_ROOT [lindex $argv 1] -set PLATFORM [lindex $argv 2] -set TKDLL [lindex $argv 3] -set TKVER [lindex $argv 4] - -puts "Building [file tail $TCL_SCRIPT_DIR] for $PLATFORM" -copyDir ${TCLSRC_ROOT}/library ${TCL_SCRIPT_DIR} - -if {$PLATFORM == "windows"} { - set ddedll [glob -nocomplain ${TCLSRC_ROOT}/win/tcldde*.dll] - puts "DDE DLL $ddedll" - if {$ddedll != {}} { - file copy $ddedll ${TCL_SCRIPT_DIR}/dde - } - set regdll [glob -nocomplain ${TCLSRC_ROOT}/win/tclreg*.dll] - puts "REG DLL $ddedll" - if {$regdll != {}} { - file copy $regdll ${TCL_SCRIPT_DIR}/reg - } -} else { - # Remove the dde and reg package paths - file delete -force ${TCL_SCRIPT_DIR}/dde - file delete -force ${TCL_SCRIPT_DIR}/reg -} - -# For the following packages, cat their pkgIndex files to tclIndex -file attributes ${TCL_SCRIPT_DIR}/tclIndex -readonly 0 -set fout [open ${TCL_SCRIPT_DIR}/tclIndex a] -puts $fout {# -# MANIFEST OF INCLUDED PACKAGES -# -set VFSROOT $dir -} -if {$TKDLL ne {} && [file exists $TKDLL]} { - file copy $TKDLL ${TCL_SCRIPT_DIR} - puts $fout [list package ifneeded Tk $TKVER "load \$dir $TKDLL"] -} -pkgIndexDir ${TCL_SCRIPT_DIR} $fout ${TCL_SCRIPT_DIR} -close $fout Index: tools/mkdepend.tcl ================================================================== --- tools/mkdepend.tcl +++ tools/mkdepend.tcl @@ -86,21 +86,21 @@ proc readDepends {chan} { set line "" array set depends {} - while {[gets $chan line] != -1} { + while {[gets $chan line] >= 0} { if {[regexp {^#line [0-9]+ \"(.*)\"$} $line dummy fname] != 0} { set fname [file normalize $fname] if {![info exists target]} { # this is ourself set target $fname puts stderr "processing [file tail $fname]" } else { # don't include ourselves as a dependency of ourself. if {![string compare $fname $target]} {continue} - # store in an array so multiple occurances are not counted. + # store in an array so multiple occurrences are not counted. set depends($target|$fname) "" } } } Index: tools/tcl.hpj.in ================================================================== --- tools/tcl.hpj.in +++ tools/tcl.hpj.in @@ -3,13 +3,13 @@ [OPTIONS] HCW=0 LCID=0x409 0x0 0x0 ;English (United States) REPORT=Yes TITLE=Tcl/Tk Reference Manual -CNT=tcl90.cnt +CNT=tcl86.cnt COPYRIGHT=Copyright © 2000 Ajuba Solutions -HLP=tcl90.hlp +HLP=tcl86.hlp [FILES] tcl.rtf [WINDOWS] Index: tools/tclZIC.tcl ================================================================== --- tools/tclZIC.tcl +++ tools/tclZIC.tcl @@ -34,11 +34,11 @@ # We avoid the solar time files and the leap seconds. set olsonFiles { africa antarctica asia australasia backward etcetera europe northamerica - pacificnew southamerica systemv + southamerica } # Define the year at which the DST information will stop. set maxyear 2100 Index: tools/tcltk-man2html-utils.tcl ================================================================== --- tools/tcltk-man2html-utils.tcl +++ tools/tcltk-man2html-utils.tcl @@ -128,12 +128,12 @@ {\|} { } \ {\0} { } \ \" {"} \ {<} {<} \ {>} {>} \ - \u201c "“" \ - \u201d "”" + \u201c "“" \ + \u201d "”" return [string map $charmap $text] } proc process-text {text} { @@ -142,29 +142,74 @@ # need to have things added to it as the manuals expand to use them. set charmap [list \ {\&} "\t" \ {\%} {} \ "\\\n" "\n" \ - {\(+-} "±" \ + {\(r!} "¡" \ + {\(ct} "¢" \ + {\(Po} "£" \ + {\(Cs} "¤" \ + {\(Ye} "¥" \ + {\(bb} "¦" \ + {\(sc} "§" \ + {\(ad} "¨" \ {\(co} "©" \ - {\(em} "—" \ - {\(en} "–" \ - {\(fm} "′" \ - {\(mc} "µ" \ - {\(mu} "×" \ - {\(mi} "−" \ - {\(->} "→" \ + {\(Of} "ª" \ + {\(Fo} "«" \ + {\(no} "¬" \ + {\(rg} "®" \ + {\(a-} "¯" \ + {\(de} "°" \ + {\(+-} "±" \ + {\(S2} "²" \ + {\(S3} "³" \ + {\(aa} "´" \ + {\(mc} "µ" \ + {\(ps} "¶" \ + {\(pc} "·" \ + {\(ac} "¸" \ + {\(S1} "¹" \ + {\(Om} "º" \ + {\(Fc} "»" \ + {\(14} "¼" \ + {\(12} "½" \ + {\(34} "¾" \ + {\(r?} "¿" \ + {\(AE} "Æ" \ + {\(-D} "Ð" \ + {\(mu} "×" \ + {\(TP} "Þ" \ + {\(ss} "ß" \ + {\(ae} "æ" \ + {\(Sd} "ð" \ + {\(di} "÷" \ + {\(Tp} "þ" \ + {\(em} "—" \ + {\(en} "–" \ + {\(bu} "•" \ + {\(fm} "′" \ + {\(mi} "−" \ + {\(.i} "ı" \ + {\(.j} "ȷ" \ + {\(Fn} "ƒ" \ + {\(OE} "Œ" \ + {\(oe} "œ" \ + {\(IJ} "IJ" \ + {\(ij} "ij" \ + {\(<-} "←" \ + {\(->} "→" \ + {\(eu} "€" \ {\fP} {\fR} \ {\.} . \ - {\(bu} "•" \ ] # This might make a few invalid mappings, but we don't use them - foreach c {a e i o u y A E I O U Y} { + foreach c {a c e g i l n o s t u y z A C E G I L N O S T U Y Z} { foreach {prefix suffix} { - o ring / slash : uml ' acute ^ circ ` grave + o ring / slash : uml ' acute ^ circ ` grave ~ tilde , cedil v caron } { lappend charmap "\\\[${prefix}${c}\]" "&${c}${suffix};" + lappend charmap "\\(${prefix}${c}" "&${c}${suffix};" } } lappend charmap {\-\|\-} -- ; # two hyphens lappend charmap {\-} - ; # a hyphen @@ -874,11 +919,11 @@ [string range $text 0 [expr {$offset(bold)-1}]] set body [string range $text [expr {$offset(bold)+3}] \ [expr {$offset(end-bold)-1}]] set text [string range $text[set text ""] \ [expr {$offset(end-bold)+4}] end] - regsub {http://[\w/.]+} $body {&} body + regsub {http://[\w/.-]+} $body {&} body append result [cross-reference $body] continue } anchor { append result \ @@ -910,11 +955,11 @@ continue } url { set off [lindex $offsets 0] append result [string range $text 0 [expr {$off-1}]] - regexp -indices -start $off {http://[\w/.]+} $text range + regexp -indices -start $off {http://[\w/.-]+} $text range set url [string range $text {*}$range] append result "$url" set text [string range $text[set text ""] \ [expr {[lindex $range 1]+1}] end] continue Index: tools/tcltk-man2html.tcl ================================================================== --- tools/tcltk-man2html.tcl +++ tools/tcltk-man2html.tcl @@ -2,11 +2,11 @@ if {[catch {package require Tcl 8.6-} msg]} { puts stderr "ERROR: $msg" puts stderr "If running this script from 'make html', set the\ NATIVE_TCLSH environment\nvariable to point to an installed\ - tclsh9.0 (or the equivalent tclsh90.exe\non Windows)." + tclsh8.6 (or the equivalent tclsh86.exe\non Windows)." exit 1 } # Convert Ousterhout format man pages into highly crosslinked hypertext. # @@ -20,65 +20,19 @@ # try to use this, you'll be very much on your own. # # Copyright (c) 1995-1997 Roger E. Critchlow Jr # Copyright (c) 2004-2010 Donal K. Fellows -set ::Version "50/9.0" +set ::Version "50/8.6" set ::CSSFILE "docs.css" ## ## Source the utility functions that provide most of the ## implementation of the transformation from nroff to html. ## source [file join [file dirname [info script]] tcltk-man2html-utils.tcl] -proc getversion {tclh {name {}}} { - if {[file exists $tclh]} { - set chan [open $tclh] - set data [read $chan] - close $chan - if {$name eq ""} { - set name [string toupper [file root [file tail $tclh]]] - } - # backslash isn't required in front of quote, but it keeps syntax - # highlighting straight in some editors - if {[regexp -lineanchor \ - [string map [list @name@ $name] \ - {^#define\s+@name@_VERSION\s+\"([^.])+\.([^.\"]+)}] \ - $data -> major minor]} { - return [list $major $minor] - } - } -} -proc findversion {top name useversion} { - # Default search version is a glob pattern, switch it for string match: - if {$useversion eq {{,[8-9].[0-9]{,[.ab][0-9]{,[0-9]}}}}} { - set useversion {[8-9].[0-9]} - } - # Search: - set upper [string toupper $name] - foreach top1 [list $top $top/..] sub {{} generic} { - foreach dirname [ - glob -nocomplain -tails -type d -directory $top1 *] { - - set tclh [join [list $top1 $dirname {*}$sub ${name}.h] /] - set v [getversion $tclh $upper] - if {[llength $v]} { - lassign $v major minor - # to do - # use glob matching instead of string matching or add - # brace handling to [string matcch] - if {$useversion eq {} || [string match $useversion $major.$minor]} { - set top [file dirname [file dirname $tclh]] - set prefix [file dirname $top] - return [list $prefix [file tail $top] $major $minor] - } - } - } - } -} - proc parse_command_line {} { global argv Version # These variables determine where the man pages come from and where # the converted pages go to. @@ -88,13 +42,11 @@ set tcltkdir ../.. set tkdir {} set tcldir {} set webdir ../html set build_tcl 0 - set opt_build_tcl 0 set build_tk 0 - set opt_build_tk 0 set verbose 0 # Default search version is a glob pattern set useversion {{,[8-9].[0-9]{,[.ab][0-9]{,[0-9]}}}} # Handle arguments a la GNU: @@ -139,16 +91,14 @@ set useversion [string range $option 13 end] } --tcl { set build_tcl 1 - set opt_build_tcl 1 } --tk { set build_tk 1 - set opt_build_tk 1 } --verbose=* { set verbose [string range $option \ [string length --verbose=] end] @@ -163,44 +113,26 @@ if {!$build_tcl && !$build_tk} { set build_tcl 1; set build_tk 1 } - set major "" - set minor "" - if {$build_tcl} { - # Find Tcl (firstly using glob pattern / backwards compatible way) + # Find Tcl. set tcldir [lindex [lsort [glob -nocomplain -tails -type d \ -directory $tcltkdir tcl$useversion]] end] - if {$tcldir ne {}} { - # obtain version from generic header if we can: - lassign [getversion [file join $tcltkdir $tcldir generic tcl.h]] major minor - } else { - lassign [findversion $tcltkdir tcl $useversion] tcltkdir tcldir major minor - } - if {$tcldir eq {} && $opt_build_tcl} { + if {$tcldir eq ""} { puts stderr "tcltk-man-html: couldn't find Tcl below $tcltkdir" exit 1 } - puts "using Tcl source directory $tcltkdir $tcldir" + puts "using Tcl source directory $tcldir" } - if {$build_tk} { - # Find Tk (firstly using glob pattern / backwards compatible way) + # Find Tk. set tkdir [lindex [lsort [glob -nocomplain -tails -type d \ -directory $tcltkdir tk$useversion]] end] - if {$tkdir ne {}} { - if {$major eq ""} { - # obtain version from generic header if we can: - lassign [getversion [file join $tcltkdir $tcldir generic tk.h]] major minor - } - } else { - lassign [findversion $tcltkdir tk $useversion] tcltkdir tkdir major minor - } - if {$tkdir eq {} && $opt_build_tk} { + if {$tkdir eq ""} { puts stderr "tcltk-man-html: couldn't find Tk below $tcltkdir" exit 1 } puts "using Tk source directory $tkdir" } @@ -209,15 +141,11 @@ # the title for the man pages overall global overall_title set overall_title "" if {$build_tcl} { - if {$major ne ""} { - append overall_title "Tcl $major.$minor" - } else { - append overall_title "Tcl [capitalize $tcldir]" - } + append overall_title "[capitalize $tcldir]" } if {$build_tcl && $build_tk} { append overall_title "/" } if {$build_tk} { @@ -627,10 +555,11 @@ Tk_Cursor Tk_GetCursor Tk_Dash Tk_GetDash Tk_Font Tk_GetFont Tk_Image Tk_GetImage Tk_ImageMaster Tk_GetImage + Tk_ImageModel Tk_GetImage Tk_ItemType Tk_CreateItemType Tk_Justify Tk_GetJustify Ttk_Theme Ttk_GetTheme } array set exclude_refs_map { @@ -738,11 +667,15 @@ set description [list $n $v] } # ... but try to extract (name, version) from subdir contents try { - set f [open [file join $pkgsDir $dir configure.ac]] + try { + set f [open [file join $pkgsDir $dir configure.in]] + } trap {POSIX ENOENT} {} { + set f [open [file join $pkgsDir $dir configure.ac]] + } foreach line [split [read $f] \n] { if {2 == [scan $line \ { AC_INIT ( [%[^]]] , [%[^]]] ) } n v]} { set description [list $n $v] break Index: tools/tsdPerf.c ================================================================== --- tools/tsdPerf.c +++ tools/tsdPerf.c @@ -3,25 +3,25 @@ extern DLLEXPORT Tcl_PackageInitProc Tsdperf_Init; static Tcl_ThreadDataKey key; typedef struct { - Tcl_WideInt value; + int value; } TsdPerf; static int tsdPerfSetObjCmd(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { TsdPerf *perf = Tcl_GetThreadData(&key, sizeof(TsdPerf)); - Tcl_WideInt i; + int i; if (2 != objc) { Tcl_WrongNumArgs(interp, 1, objv, "value"); return TCL_ERROR; } - if (TCL_OK != Tcl_GetWideIntFromObj(interp, objv[1], &i)) { + if (TCL_OK != Tcl_GetIntFromObj(interp, objv[1], &i)) { return TCL_ERROR; } perf->value = i; @@ -31,18 +31,18 @@ static int tsdPerfGetObjCmd(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { TsdPerf *perf = Tcl_GetThreadData(&key, sizeof(TsdPerf)); - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(perf->value)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(perf->value)); return TCL_OK; } int Tsdperf_Init(Tcl_Interp *interp) { - if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { + if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) { return TCL_ERROR; } Tcl_CreateObjCommand(interp, "tsdPerfSet", tsdPerfSetObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "tsdPerfGet", tsdPerfGetObjCmd, NULL, NULL); Index: tools/uniClass.tcl ================================================================== --- tools/uniClass.tcl +++ tools/uniClass.tcl @@ -14,37 +14,37 @@ proc emitRange {first last} { global ranges numranges chars numchars extchars extranges if {$first < ($last-1)} { - if {!$extranges && ($first) > 0xffff} { + if {!$extranges && ($first) > 0xFFFF} { set extranges 1 set numranges 0 set ranges [string trimright $ranges " \n\r\t,"] append ranges "\n#if CHRBITS > 16\n ," } - append ranges [format "{0x%x, 0x%x}, " \ + append ranges [format "{0x%X, 0x%X}, " \ $first $last] if {[incr numranges] % 4 == 0} { set ranges [string trimright $ranges] append ranges "\n " } } else { - if {!$extchars && ($first) > 0xffff} { + if {!$extchars && ($first) > 0xFFFF} { set extchars 1 set numchars 0 set chars [string trimright $chars " \n\r\t,"] append chars "\n#if CHRBITS > 16\n ," } - append chars [format "0x%x, " $first] + append chars [format "0x%X, " $first] incr numchars if {$numchars % 9 == 0} { set chars [string trimright $chars] append chars "\n " } if {$first != $last} { - append chars [format "0x%x, " $last] + append chars [format "0x%X, " $last] incr numchars if {$numchars % 9 == 0} { append chars "\n " } } @@ -61,15 +61,15 @@ set chars " " set numchars 0 set extchars 0 set extranges 0 - for {set i 0} {$i <= 0x10ffff} {incr i} { - if {$i == 0xd800} { - # Skip surrogates - set i 0xe000 - } + for {set i 0} {$i <= 0x10FFFF} {incr i} { + if {$i == 0xD800} { + # Skip surrogates + set i 0xE000 + } if {[string is $type [format %c $i]]} { if {$i == ($last + 1)} { set last $i } else { if {$first >= 0} { Index: tools/uniParse.tcl ================================================================== --- tools/uniParse.tcl +++ tools/uniParse.tcl @@ -66,11 +66,11 @@ proc uni::getGroup {value} { variable groups set gIndex [lsearch -exact $groups $value] - if {$gIndex == -1} { + if {$gIndex < 0} { set gIndex [llength $groups] lappend groups $value } return $gIndex } @@ -79,11 +79,11 @@ variable pMap variable pages variable shift set pIndex [lsearch -exact $pages $info] - if {$pIndex == -1} { + if {$pIndex < 0} { set pIndex [llength $pages] lappend pages $info } lappend pMap [expr {$pIndex << $shift}] return @@ -112,12 +112,12 @@ } set items [split $line \;] scan [lindex $items 0] %x index - if {$index > 0x2ffff} then { - # Ignore non-BMP characters, as long as Tcl doesn't support them + if {$index > 0x3FFFF} then { + # Ignore characters > plane 3 continue } set index [format %d $index] set gIndex [getGroup [getValue $items $index]] @@ -341,13 +341,13 @@ } puts $f $line puts -nonewline $f "}; #if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6 -# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1fffff) >= [format 0x%x $next]) +# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1FFFFF) >= [format 0x%X $next]) #else -# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1f0000) != 0) +# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1F0000) != 0) #endif /* * The following constants are used to determine the category of a * Unicode character. @@ -390,27 +390,27 @@ * The following macros extract the fields of the character info. The * GetDelta() macro is complicated because we can't rely on the C compiler * to do sign extension on right shifts. */ -#define GetCaseType(info) (((info) & 0xe0) >> 5) -#define GetCategory(ch) (GetUniCharInfo(ch) & 0x1f) +#define GetCaseType(info) (((info) & 0xE0) >> 5) +#define GetCategory(ch) (GetUniCharInfo(ch) & 0x1F) #define GetDelta(info) ((info) >> 8) /* * This macro extracts the information about a character from the * Unicode character tables. */ #if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6 -# define GetUniCharInfo(ch) (groups\[groupMap\[pageMap\[((ch) & 0x1fffff) >> OFFSET_BITS\] | ((ch) & ((1 << OFFSET_BITS)-1))\]\]) +# define GetUniCharInfo(ch) (groups\[groupMap\[pageMap\[((ch) & 0x1FFFFF) >> OFFSET_BITS\] | ((ch) & ((1 << OFFSET_BITS)-1))\]\]) #else -# define GetUniCharInfo(ch) (groups\[groupMap\[pageMap\[((ch) & 0xffff) >> OFFSET_BITS\] | ((ch) & ((1 << OFFSET_BITS)-1))\]\]) +# define GetUniCharInfo(ch) (groups\[groupMap\[pageMap\[((ch) & 0xFFFF) >> OFFSET_BITS\] | ((ch) & ((1 << OFFSET_BITS)-1))\]\]) #endif " close $f } uni::main return Index: unix/Makefile.in ================================================================== --- unix/Makefile.in +++ unix/Makefile.in @@ -26,10 +26,11 @@ exec_prefix = @exec_prefix@ bindir = @bindir@ libdir = @libdir@ includedir = @includedir@ datarootdir = @datarootdir@ +runstatedir = @runstatedir@ mandir = @mandir@ # The following definition can be set to non-null for special systems like AFS # with replication. It allows the pathnames used for installation to be # different than those used for actually reference files at run-time. @@ -50,10 +51,13 @@ DLL_INSTALL_DIR = @DLL_INSTALL_DIR@ # Path name to use when installing library scripts. SCRIPT_INSTALL_DIR = $(INSTALL_ROOT)$(TCL_LIBRARY) +# Path name to use when installing Tcl modules. +MODULE_INSTALL_DIR = $(SCRIPT_INSTALL_DIR)/../tcl8 + # Directory in which to install the include file tcl.h: INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) # Path to the private tcl header dir: PRIVATE_INCLUDE_DIR = @PRIVATE_INCLUDE_DIR@ @@ -81,11 +85,11 @@ # Directory in which to install the configuration file tclConfig.sh CONFIG_INSTALL_DIR = $(INSTALL_ROOT)$(libdir) # Directory in which to install bundled packages: -PACKAGE_DIR = @PACKAGE_DIR@ +PACKAGE_DIR = @PACKAGE_DIR@ # Package search path. TCL_PACKAGE_PATH = @TCL_PACKAGE_PATH@ # Tcl Module default path roots (TIP189). @@ -108,15 +112,10 @@ # Flags to pass to the linker LDFLAGS_DEBUG = @LDFLAGS_DEBUG@ LDFLAGS_OPTIMIZE = @LDFLAGS_OPTIMIZE@ LDFLAGS = @LDFLAGS_DEFAULT@ @LDFLAGS@ -# To disable ANSI-C procedure prototypes reverse the comment characters on the -# following lines: -PROTO_FLAGS = -#PROTO_FLAGS = -DNO_PROTOTYPE - # If you use the setenv, putenv, or unsetenv procedures to modify environment # variables in your application and you'd like those modifications to appear # in the "env" Tcl variable, switch the comments on the two lines below so # that Tcl provides these procedures instead of your standard C library. @@ -123,11 +122,11 @@ ENV_FLAGS = #ENV_FLAGS = -DTclSetEnv=setenv -DTcl_PutEnv=putenv -DTclUnsetEnv=unsetenv # To enable memory debugging, call configure with --enable-symbols=mem # Warning: if you enable memory debugging, you must do it *everywhere*, -# including all the code that calls Tcl, and you must use Tcl_Alloc and Tcl_Free +# including all the code that calls Tcl, and you must use ckalloc and ckfree # everywhere instead of malloc and free. TCL_STUB_LIB_FILE = @TCL_STUB_LIB_FILE@ #TCL_STUB_LIB_FILE = libtclstub.a @@ -149,12 +148,12 @@ # Tcl used to let the configure script choose which program to use for # installing, but there are just too many different versions of "install" # around; better to use the install-sh script that comes with the # distribution, which is slower but guaranteed to work. -INSTALL_STRIP_PROGRAM = -s -INSTALL_STRIP_LIBRARY = -S -x +INSTALL_STRIP_PROGRAM = -s +INSTALL_STRIP_LIBRARY = -S -x INSTALL = $(SHELL) $(UNIX_DIR)/install-sh -c INSTALL_PROGRAM = ${INSTALL} INSTALL_LIBRARY = ${INSTALL} INSTALL_DATA = ${INSTALL} -m 644 @@ -169,18 +168,19 @@ TCL_EXE = tclsh${EXE_SUFFIX} TCLTEST_EXE = tcltest${EXE_SUFFIX} NATIVE_TCLSH = @TCLSH_PROG@ # The symbols below provide support for dynamic loading and shared libraries. -# See configure.ac for a description of what the symbols mean. The values of +# See configure.in for a description of what the symbols mean. The values of # the symbols are normally set by the configure script. You shouldn't normally # need to modify any of these definitions by hand. STLIB_LD = @STLIB_LD@ SHLIB_LD = @SHLIB_LD@ SHLIB_CFLAGS = @SHLIB_CFLAGS@ -DBUILD_tcl SHLIB_LD_LIBS = @SHLIB_LD_LIBS@ +SHLIB_LD_FLAGS = @SHLIB_LD_FLAGS@ TCL_SHLIB_LD_EXTRAS = @TCL_SHLIB_LD_EXTRAS@ SHLIB_SUFFIX = @SHLIB_SUFFIX@ DLTEST_TARGETS = dltest.marker @@ -240,17 +240,15 @@ ZLIB_DIR = ${COMPAT_DIR}/zlib ZLIB_INCLUDE = @ZLIB_INCLUDE@ CC = @CC@ -OBJEXT = @OBJEXT@ - #CC = purify -best-effort @CC@ -DPURIFY # Flags to be passed to installManPage to control how the manpages should be # installed (symlinks, compression, package name suffix). -MAN_FLAGS = @MAN_FLAGS@ +MAN_FLAGS = @MAN_FLAGS@ # If non-empty, install the timezone files that are included with Tcl, # otherwise use the ones that ship with the OS. INSTALL_TZDATA = @INSTALL_TZDATA@ @@ -259,36 +257,34 @@ # modify it and it only exists to make working around selected rare system # configurations easier. #-------------------------------------------------------------------------- GDB = gdb -LLDB = lldb TRACE = strace TRACE_OPTS = VALGRIND = valgrind VALGRINDARGS = --tool=memcheck --num-callers=24 \ - --leak-resolution=high --leak-check=yes --show-reachable=yes -v \ - --suppressions=$(TOOL_DIR)/valgrind_suppress + --leak-resolution=high --leak-check=yes --show-reachable=yes -v \ + --suppressions=$(TOOL_DIR)/valgrind_suppress #-------------------------------------------------------------------------- # The information below should be usable as is. The configure script won't # modify it and you shouldn't need to modify it either. #-------------------------------------------------------------------------- STUB_CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \ - -I"${BUILD_DIR}" -I${UNIX_DIR} -I${GENERIC_DIR} -I${TOMMATH_DIR} \ - ${AC_FLAGS} ${PROTO_FLAGS} ${ENV_FLAGS} ${EXTRA_CFLAGS} \ - @EXTRA_CC_SWITCHES@ +-I"${BUILD_DIR}" -I${UNIX_DIR} -I${GENERIC_DIR} -I${TOMMATH_DIR} \ +${AC_FLAGS} ${ENV_FLAGS} ${EXTRA_CFLAGS} @EXTRA_CC_SWITCHES@ -CC_SWITCHES = $(STUB_CC_SWITCHES) ${NO_DEPRECATED_FLAGS} +CC_SWITCHES = $(STUB_CC_SWITCHES) ${NO_DEPRECATED_FLAGS} -DMP_FIXED_CUTOFFS -DMP_NO_STDINT APP_CC_SWITCHES = $(CC_SWITCHES) @EXTRA_APP_CC_SWITCHES@ LIBS = @TCL_LIBS@ DEPEND_SWITCHES = ${CFLAGS} -I${UNIX_DIR} -I${GENERIC_DIR} \ - ${AC_FLAGS} ${PROTO_FLAGS} ${EXTRA_CFLAGS} @EXTRA_CC_SWITCHES@ +${AC_FLAGS} ${EXTRA_CFLAGS} @EXTRA_CC_SWITCHES@ TCLSH_OBJS = tclAppInit.o TCLTEST_OBJS = tclTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \ tclThreadTest.o tclUnixTest.o @@ -307,42 +303,41 @@ tclIORChan.o tclIORTrans.o tclIOGT.o tclIOSock.o tclIOUtil.o \ tclLink.o tclListObj.o \ tclLiteral.o tclLoad.o tclMain.o tclNamesp.o tclNotify.o \ tclObj.o tclOptimize.o tclPanic.o tclParse.o tclPathObj.o tclPipe.o \ tclPkg.o tclPkgConfig.o tclPosixStr.o \ - tclPreserve.o tclProc.o tclProcess.o tclRegexp.o \ + tclPreserve.o tclProc.o tclRegexp.o \ tclResolve.o tclResult.o tclScan.o tclStringObj.o \ tclStrToD.o tclThread.o \ tclThreadAlloc.o tclThreadJoin.o tclThreadStorage.o tclStubInit.o \ tclTimer.o tclTrace.o tclUtf.o tclUtil.o tclVar.o tclZlib.o \ - tclTomMathInterface.o tclZipfs.o + tclTomMathInterface.o OO_OBJS = tclOO.o tclOOBasic.o tclOOCall.o tclOODefineCmds.o tclOOInfo.o \ tclOOMethod.o tclOOStubInit.o -TOMMATH_OBJS = bn_reverse.o bn_fast_s_mp_mul_digs.o \ - bn_fast_s_mp_sqr.o bn_mp_add.o bn_mp_and.o \ +TOMMATH_OBJS = bn_s_mp_reverse.o bn_s_mp_mul_digs_fast.o \ + bn_s_mp_sqr_fast.o bn_mp_add.o bn_mp_and.o \ bn_mp_add_d.o bn_mp_clamp.o bn_mp_clear.o bn_mp_clear_multi.o \ bn_mp_cmp.o bn_mp_cmp_d.o bn_mp_cmp_mag.o \ bn_mp_cnt_lsb.o bn_mp_copy.o \ bn_mp_count_bits.o bn_mp_div.o bn_mp_div_d.o bn_mp_div_2.o \ - bn_mp_div_2d.o bn_mp_div_3.o bn_mp_exch.o \ - bn_mp_expt_d.o bn_mp_expt_d_ex.o bn_s_mp_get_bit.o bn_mp_get_int.o \ - bn_mp_get_long.o bn_mp_get_long_long.o bn_mp_grow.o bn_mp_init.o \ + bn_mp_div_2d.o bn_mp_div_3.o bn_mp_exch.o bn_mp_expt_u32.o \ + bn_mp_grow.o bn_mp_init.o \ bn_mp_init_copy.o bn_mp_init_multi.o bn_mp_init_set.o \ - bn_mp_init_set_int.o bn_mp_init_size.o bn_mp_karatsuba_mul.o \ - bn_mp_karatsuba_sqr.o \ + bn_mp_init_size.o bn_s_mp_karatsuba_mul.o \ + bn_s_mp_karatsuba_sqr.o bn_s_mp_balance_mul.o \ bn_mp_lshd.o bn_mp_mod.o bn_mp_mod_2d.o bn_mp_mul.o bn_mp_mul_2.o \ bn_mp_mul_2d.o bn_mp_mul_d.o bn_mp_neg.o bn_mp_or.o \ bn_mp_radix_size.o bn_mp_radix_smap.o \ - bn_mp_read_radix.o bn_mp_rshd.o bn_mp_set.o bn_mp_set_int.o \ - bn_mp_set_long.o bn_mp_set_long_long.o bn_mp_shrink.o \ + bn_mp_read_radix.o bn_mp_rshd.o bn_mp_set.o \ + bn_mp_shrink.o \ bn_mp_sqr.o bn_mp_sqrt.o bn_mp_sub.o bn_mp_sub_d.o \ bn_mp_signed_rsh.o \ - bn_mp_to_unsigned_bin.o bn_mp_to_unsigned_bin_n.o \ - bn_mp_toom_mul.o bn_mp_toom_sqr.o bn_mp_toradix_n.o \ - bn_mp_unsigned_bin_size.o bn_mp_xor.o bn_mp_zero.o bn_s_mp_add.o \ + bn_mp_to_ubin.o \ + bn_s_mp_toom_mul.o bn_s_mp_toom_sqr.o bn_mp_to_radix.o \ + bn_mp_ubin_size.o bn_mp_xor.o bn_mp_zero.o bn_s_mp_add.o \ bn_s_mp_mul_digs.o bn_s_mp_sqr.o bn_s_mp_sub.o STUB_LIB_OBJS = tclStubLib.o \ tclTomMathStubLib.o \ tclOOStubLib.o \ @@ -351,11 +346,11 @@ UNIX_OBJS = tclUnixChan.o tclUnixEvent.o tclUnixFCmd.o \ tclUnixFile.o tclUnixPipe.o tclUnixSock.o \ tclUnixTime.o tclUnixInit.o tclUnixThrd.o \ tclUnixCompat.o -NOTIFY_OBJS = tclEpollNotfy.o tclKqueueNotfy.o tclSelectNotfy.o +NOTIFY_OBJS = tclUnixNotfy.o MAC_OSX_OBJS = tclMacOSXBundle.o tclMacOSXFCmd.o tclMacOSXNotify.o CYGWIN_OBJS = tclWinError.o @@ -450,11 +445,10 @@ $(GENERIC_DIR)/tclPkg.c \ $(GENERIC_DIR)/tclPkgConfig.c \ $(GENERIC_DIR)/tclPosixStr.c \ $(GENERIC_DIR)/tclPreserve.c \ $(GENERIC_DIR)/tclProc.c \ - $(GENERIC_DIR)/tclProcess.c \ $(GENERIC_DIR)/tclRegexp.c \ $(GENERIC_DIR)/tclResolve.c \ $(GENERIC_DIR)/tclResult.c \ $(GENERIC_DIR)/tclScan.c \ $(GENERIC_DIR)/tclStubInit.c \ @@ -470,12 +464,11 @@ $(GENERIC_DIR)/tclTimer.c \ $(GENERIC_DIR)/tclTrace.c \ $(GENERIC_DIR)/tclUtil.c \ $(GENERIC_DIR)/tclVar.c \ $(GENERIC_DIR)/tclAssembly.c \ - $(GENERIC_DIR)/tclZlib.c \ - $(GENERIC_DIR)/tclZipfs.c + $(GENERIC_DIR)/tclZlib.c OO_SRCS = \ $(GENERIC_DIR)/tclOO.c \ $(GENERIC_DIR)/tclOOBasic.c \ $(GENERIC_DIR)/tclOOCall.c \ @@ -488,80 +481,167 @@ $(GENERIC_DIR)/tclStubLib.c \ $(GENERIC_DIR)/tclTomMathStubLib.c \ $(GENERIC_DIR)/tclOOStubLib.c TOMMATH_SRCS = \ - $(TOMMATH_DIR)/bn_reverse.c \ - $(TOMMATH_DIR)/bn_fast_s_mp_mul_digs.c \ - $(TOMMATH_DIR)/bn_fast_s_mp_sqr.c \ + $(TOMMATH_DIR)/bn_cutoffs.c \ + $(TOMMATH_DIR)/bn_deprecated.c \ + $(TOMMATH_DIR)/bn_mp_2expt.c \ + $(TOMMATH_DIR)/bn_mp_abs.c \ $(TOMMATH_DIR)/bn_mp_add.c \ $(TOMMATH_DIR)/bn_mp_add_d.c \ + $(TOMMATH_DIR)/bn_mp_addmod.c \ $(TOMMATH_DIR)/bn_mp_and.c \ $(TOMMATH_DIR)/bn_mp_clamp.c \ $(TOMMATH_DIR)/bn_mp_clear.c \ $(TOMMATH_DIR)/bn_mp_clear_multi.c \ $(TOMMATH_DIR)/bn_mp_cmp.c \ $(TOMMATH_DIR)/bn_mp_cmp_d.c \ $(TOMMATH_DIR)/bn_mp_cmp_mag.c \ - $(TOMMATH_DIR)/bn_mp_copy.c \ $(TOMMATH_DIR)/bn_mp_cnt_lsb.c \ + $(TOMMATH_DIR)/bn_mp_complement.c \ + $(TOMMATH_DIR)/bn_mp_copy.c \ $(TOMMATH_DIR)/bn_mp_count_bits.c \ + $(TOMMATH_DIR)/bn_mp_decr.c \ $(TOMMATH_DIR)/bn_mp_div.c \ - $(TOMMATH_DIR)/bn_mp_div_d.c \ $(TOMMATH_DIR)/bn_mp_div_2.c \ $(TOMMATH_DIR)/bn_mp_div_2d.c \ $(TOMMATH_DIR)/bn_mp_div_3.c \ + $(TOMMATH_DIR)/bn_mp_div_d.c \ + $(TOMMATH_DIR)/bn_mp_dr_is_modulus.c \ + $(TOMMATH_DIR)/bn_mp_dr_reduce.c \ + $(TOMMATH_DIR)/bn_mp_dr_setup.c \ + $(TOMMATH_DIR)/bn_mp_error_to_string.c \ $(TOMMATH_DIR)/bn_mp_exch.c \ - $(TOMMATH_DIR)/bn_mp_expt_d.c \ - $(TOMMATH_DIR)/bn_mp_expt_d_ex.c \ - $(TOMMATH_DIR)/bn_mp_get_int.c \ - $(TOMMATH_DIR)/bn_mp_get_long.c \ - $(TOMMATH_DIR)/bn_mp_get_long_long.c \ + $(TOMMATH_DIR)/bn_mp_expt_u32.c \ + $(TOMMATH_DIR)/bn_mp_exptmod.c \ + $(TOMMATH_DIR)/bn_mp_exteuclid.c \ + $(TOMMATH_DIR)/bn_mp_fread.c \ + $(TOMMATH_DIR)/bn_mp_from_sbin.c \ + $(TOMMATH_DIR)/bn_mp_from_ubin.c \ + $(TOMMATH_DIR)/bn_mp_fwrite.c \ + $(TOMMATH_DIR)/bn_mp_gcd.c \ + $(TOMMATH_DIR)/bn_mp_get_double.c \ + $(TOMMATH_DIR)/bn_mp_get_i32.c \ + $(TOMMATH_DIR)/bn_mp_get_i64.c \ + $(TOMMATH_DIR)/bn_mp_get_l.c \ + $(TOMMATH_DIR)/bn_mp_get_ll.c \ + $(TOMMATH_DIR)/bn_mp_get_mag_u32.c \ + $(TOMMATH_DIR)/bn_mp_get_mag_u64.c \ + $(TOMMATH_DIR)/bn_mp_get_mag_ul.c \ + $(TOMMATH_DIR)/bn_mp_get_mag_ull.c \ $(TOMMATH_DIR)/bn_mp_grow.c \ + $(TOMMATH_DIR)/bn_mp_incr.c \ $(TOMMATH_DIR)/bn_mp_init.c \ $(TOMMATH_DIR)/bn_mp_init_copy.c \ + $(TOMMATH_DIR)/bn_mp_init_i32.c \ + $(TOMMATH_DIR)/bn_mp_init_i64.c \ + $(TOMMATH_DIR)/bn_mp_init_l.c \ + $(TOMMATH_DIR)/bn_mp_init_ll.c \ $(TOMMATH_DIR)/bn_mp_init_multi.c \ $(TOMMATH_DIR)/bn_mp_init_set.c \ - $(TOMMATH_DIR)/bn_mp_init_set_int.c \ $(TOMMATH_DIR)/bn_mp_init_size.c \ - $(TOMMATH_DIR)/bn_mp_karatsuba_mul.c \ - $(TOMMATH_DIR)/bn_mp_karatsuba_sqr.c \ + $(TOMMATH_DIR)/bn_mp_init_u32.c \ + $(TOMMATH_DIR)/bn_mp_init_u64.c \ + $(TOMMATH_DIR)/bn_mp_init_ul.c \ + $(TOMMATH_DIR)/bn_mp_init_ull.c \ + $(TOMMATH_DIR)/bn_mp_invmod.c \ + $(TOMMATH_DIR)/bn_mp_is_square.c \ + $(TOMMATH_DIR)/bn_mp_iseven.c \ + $(TOMMATH_DIR)/bn_mp_isodd.c \ + $(TOMMATH_DIR)/bn_mp_kronecker.c \ + $(TOMMATH_DIR)/bn_mp_lcm.c \ + $(TOMMATH_DIR)/bn_mp_log_u32.c \ $(TOMMATH_DIR)/bn_mp_lshd.c \ $(TOMMATH_DIR)/bn_mp_mod.c \ $(TOMMATH_DIR)/bn_mp_mod_2d.c \ + $(TOMMATH_DIR)/bn_mp_mod_d.c \ + $(TOMMATH_DIR)/bn_mp_montgomery_calc_normalization.c \ + $(TOMMATH_DIR)/bn_mp_montgomery_reduce.c \ + $(TOMMATH_DIR)/bn_mp_montgomery_setup.c \ $(TOMMATH_DIR)/bn_mp_mul.c \ $(TOMMATH_DIR)/bn_mp_mul_2.c \ $(TOMMATH_DIR)/bn_mp_mul_2d.c \ $(TOMMATH_DIR)/bn_mp_mul_d.c \ + $(TOMMATH_DIR)/bn_mp_mulmod.c \ $(TOMMATH_DIR)/bn_mp_neg.c \ $(TOMMATH_DIR)/bn_mp_or.c \ + $(TOMMATH_DIR)/bn_mp_pack.c \ + $(TOMMATH_DIR)/bn_mp_pack_count.c \ + $(TOMMATH_DIR)/bn_mp_prime_fermat.c \ + $(TOMMATH_DIR)/bn_mp_prime_frobenius_underwood.c \ + $(TOMMATH_DIR)/bn_mp_prime_is_prime.c \ + $(TOMMATH_DIR)/bn_mp_prime_miller_rabin.c \ + $(TOMMATH_DIR)/bn_mp_prime_next_prime.c \ + $(TOMMATH_DIR)/bn_mp_prime_rabin_miller_trials.c \ + $(TOMMATH_DIR)/bn_mp_prime_rand.c \ + $(TOMMATH_DIR)/bn_mp_prime_strong_lucas_selfridge.c \ $(TOMMATH_DIR)/bn_mp_radix_size.c \ $(TOMMATH_DIR)/bn_mp_radix_smap.c \ + $(TOMMATH_DIR)/bn_mp_rand.c \ $(TOMMATH_DIR)/bn_mp_read_radix.c \ + $(TOMMATH_DIR)/bn_mp_reduce.c \ + $(TOMMATH_DIR)/bn_mp_reduce_2k.c \ + $(TOMMATH_DIR)/bn_mp_reduce_2k_l.c \ + $(TOMMATH_DIR)/bn_mp_reduce_2k_setup.c \ + $(TOMMATH_DIR)/bn_mp_reduce_2k_setup_l.c \ + $(TOMMATH_DIR)/bn_mp_reduce_is_2k.c \ + $(TOMMATH_DIR)/bn_mp_reduce_is_2k_l.c \ + $(TOMMATH_DIR)/bn_mp_reduce_setup.c \ + $(TOMMATH_DIR)/bn_mp_root_u32.c \ $(TOMMATH_DIR)/bn_mp_rshd.c \ + $(TOMMATH_DIR)/bn_mp_sbin_size.c \ $(TOMMATH_DIR)/bn_mp_set.c \ - $(TOMMATH_DIR)/bn_mp_set_int.c \ - $(TOMMATH_DIR)/bn_mp_set_long.c \ - $(TOMMATH_DIR)/bn_mp_set_long_long.c \ + $(TOMMATH_DIR)/bn_mp_set_double.c \ + $(TOMMATH_DIR)/bn_mp_set_i32.c \ + $(TOMMATH_DIR)/bn_mp_set_i64.c \ + $(TOMMATH_DIR)/bn_mp_set_l.c \ + $(TOMMATH_DIR)/bn_mp_set_ll.c \ + $(TOMMATH_DIR)/bn_mp_set_u32.c \ + $(TOMMATH_DIR)/bn_mp_set_u64.c \ + $(TOMMATH_DIR)/bn_mp_set_ul.c \ + $(TOMMATH_DIR)/bn_mp_set_ull.c \ $(TOMMATH_DIR)/bn_mp_shrink.c \ + $(TOMMATH_DIR)/bn_mp_signed_rsh.c \ $(TOMMATH_DIR)/bn_mp_sqr.c \ + $(TOMMATH_DIR)/bn_mp_sqrmod.c \ $(TOMMATH_DIR)/bn_mp_sqrt.c \ + $(TOMMATH_DIR)/bn_mp_sqrtmod_prime.c \ $(TOMMATH_DIR)/bn_mp_sub.c \ $(TOMMATH_DIR)/bn_mp_sub_d.c \ - $(TOMMATH_DIR)/bn_mp_signed_rsh.c \ - $(TOMMATH_DIR)/bn_mp_to_unsigned_bin.c \ - $(TOMMATH_DIR)/bn_mp_to_unsigned_bin_n.c \ - $(TOMMATH_DIR)/bn_mp_toom_mul.c \ - $(TOMMATH_DIR)/bn_mp_toom_sqr.c \ - $(TOMMATH_DIR)/bn_mp_toradix_n.c \ - $(TOMMATH_DIR)/bn_mp_unsigned_bin_size.c \ + $(TOMMATH_DIR)/bn_mp_submod.c \ + $(TOMMATH_DIR)/bn_mp_to_radix.c \ + $(TOMMATH_DIR)/bn_mp_to_sbin.c \ + $(TOMMATH_DIR)/bn_mp_to_ubin.c \ + $(TOMMATH_DIR)/bn_mp_ubin_size.c \ + $(TOMMATH_DIR)/bn_mp_unpack.c \ $(TOMMATH_DIR)/bn_mp_xor.c \ $(TOMMATH_DIR)/bn_mp_zero.c \ + $(TOMMATH_DIR)/bn_prime_tab.c \ $(TOMMATH_DIR)/bn_s_mp_add.c \ + $(TOMMATH_DIR)/bn_s_mp_balance_mul.c \ + $(TOMMATH_DIR)/bn_s_mp_exptmod.c \ + $(TOMMATH_DIR)/bn_s_mp_exptmod_fast.c \ + $(TOMMATH_DIR)/bn_s_mp_get_bit.c \ + $(TOMMATH_DIR)/bn_s_mp_invmod_fast.c \ + $(TOMMATH_DIR)/bn_s_mp_invmod_slow.c \ + $(TOMMATH_DIR)/bn_s_mp_karatsuba_mul.c \ + $(TOMMATH_DIR)/bn_s_mp_karatsuba_sqr.c \ + $(TOMMATH_DIR)/bn_s_mp_montgomery_reduce_fast.c \ $(TOMMATH_DIR)/bn_s_mp_mul_digs.c \ + $(TOMMATH_DIR)/bn_s_mp_mul_digs_fast.c \ + $(TOMMATH_DIR)/bn_s_mp_mul_high_digs.c \ + $(TOMMATH_DIR)/bn_s_mp_mul_high_digs_fast.c \ + $(TOMMATH_DIR)/bn_s_mp_prime_is_divisible.c \ + $(TOMMATH_DIR)/bn_s_mp_rand_jenkins.c \ + $(TOMMATH_DIR)/bn_s_mp_rand_platform.c \ + $(TOMMATH_DIR)/bn_s_mp_reverse.c \ $(TOMMATH_DIR)/bn_s_mp_sqr.c \ - $(TOMMATH_DIR)/bn_s_mp_sub.c + $(TOMMATH_DIR)/bn_s_mp_sqr_fast.c \ + $(TOMMATH_DIR)/bn_s_mp_sub.c \ + $(TOMMATH_DIR)/bn_s_mp_toom_mul.c \ + $(TOMMATH_DIR)/bn_s_mp_toom_sqr.c UNIX_HDRS = \ $(UNIX_DIR)/tclUnixPort.h # $(UNIX_DIR)/tclConfig.h @@ -578,13 +658,11 @@ $(UNIX_DIR)/tclUnixTime.c \ $(UNIX_DIR)/tclUnixInit.c \ $(UNIX_DIR)/tclUnixCompat.c NOTIFY_SRCS = \ - $(UNIX_DIR)/tclEpollNotfy.c \ - $(UNIX_DIR)/tclKqueueNotfy.c \ - $(UNIX_DIR)/tclSelectNotfy.c + $(UNIX_DIR)/tclUnixNotfy.c DL_SRCS = \ $(UNIX_DIR)/tclLoadAix.c \ $(UNIX_DIR)/tclLoadDl.c \ $(UNIX_DIR)/tclLoadDl2.c \ @@ -624,48 +702,10 @@ # things like "make depend". SRCS = $(GENERIC_SRCS) $(TOMMATH_SRCS) $(UNIX_SRCS) $(NOTIFY_SRCS) \ $(OO_SRCS) $(STUB_SRCS) @PLAT_SRCS@ @ZLIB_SRCS@ -### -# Tip 430 - ZipFS Modifications -### - -TCL_ZIP_FILE = @TCL_ZIP_FILE@ -TCL_VFS_ROOT = libtcl.vfs -TCL_VFS_PATH = ${TCL_VFS_ROOT}/tcl_library - -HOST_CC = @CC_FOR_BUILD@ -HOST_EXEEXT = @EXEEXT_FOR_BUILD@ -HOST_OBJEXT = @OBJEXT_FOR_BUILD@ -ZIPFS_BUILD = @ZIPFS_BUILD@ -NATIVE_ZIP = @ZIP_PROG@ -ZIP_PROG_OPTIONS = @ZIP_PROG_OPTIONS@ -ZIP_PROG_VFSSEARCH = @ZIP_PROG_VFSSEARCH@ -SHARED_BUILD = @SHARED_BUILD@ -INSTALL_LIBRARIES = @INSTALL_LIBRARIES@ -INSTALL_MSGS = @INSTALL_MSGS@ - -# Minizip -MINIZIP_OBJS = \ - adler32.$(HOST_OBJEXT) \ - compress.$(HOST_OBJEXT) \ - crc32.$(HOST_OBJEXT) \ - deflate.$(HOST_OBJEXT) \ - infback.$(HOST_OBJEXT) \ - inffast.$(HOST_OBJEXT) \ - inflate.$(HOST_OBJEXT) \ - inftrees.$(HOST_OBJEXT) \ - ioapi.$(HOST_OBJEXT) \ - trees.$(HOST_OBJEXT) \ - uncompr.$(HOST_OBJEXT) \ - zip.$(HOST_OBJEXT) \ - zutil.$(HOST_OBJEXT) \ - minizip.$(HOST_OBJEXT) - -ZIP_INSTALL_OBJS = @ZIP_INSTALL_OBJS@ - #-------------------------------------------------------------------------- # Start of rules #-------------------------------------------------------------------------- all: binaries libraries doc packages @@ -674,45 +714,19 @@ libraries: doc: -tclzipfile: ${TCL_ZIP_FILE} - -${TCL_ZIP_FILE}: ${ZIP_INSTALL_OBJS} - @rm -rf ${TCL_VFS_ROOT} - @mkdir -p ${TCL_VFS_PATH} - @echo "creating ${TCL_VFS_PATH} (prepare compression)" - @if \ - ln -s $(TOP_DIR)/library/* ${TCL_VFS_PATH}/ && \ - ln ${TCL_VFS_PATH}/manifest.txt ${TCL_VFS_PATH}/pkgIndex.tcl; \ - then : ; else \ - cp -a $(TOP_DIR)/library/* ${TCL_VFS_PATH}; \ - cp -a ${TCL_VFS_PATH}/manifest.txt ${TCL_VFS_PATH}/pkgIndex.tcl; \ - fi - @find ${TCL_VFS_ROOT} -type d -empty -delete - @echo "creating ${TCL_ZIP_FILE} from ${TCL_VFS_PATH}" - @(zip=`(realpath '${NATIVE_ZIP}' || readlink -m '${NATIVE_ZIP}' || \ - echo '${NATIVE_ZIP}' | sed "s?^\./?$$(pwd)/?") 2>/dev/null`; \ - echo 'cd ${TCL_VFS_ROOT} &&' $$zip '${ZIP_PROG_OPTIONS} ../${TCL_ZIP_FILE} ${ZIP_PROG_VFSSEARCH}'; \ - cd ${TCL_VFS_ROOT} && \ - $$zip ${ZIP_PROG_OPTIONS} ../${TCL_ZIP_FILE} ${ZIP_PROG_VFSSEARCH} >/dev/null) - # The following target is configured by autoconf to generate either a shared # library or non-shared library for Tcl. -${LIB_FILE}: ${STUB_LIB_FILE} ${OBJS} ${TCL_ZIP_FILE} +${LIB_FILE}: ${STUB_LIB_FILE} ${OBJS} rm -f $@ @MAKE_LIB@ - @if test "${ZIPFS_BUILD}" = "1" ; then \ - cat ${TCL_ZIP_FILE} >> ${LIB_FILE}; \ - ${NATIVE_ZIP} -A ${LIB_FILE} \ - || echo 'ignore zip-error by adjust sfx process (not executable?)'; \ - fi ${STUB_LIB_FILE}: ${STUB_LIB_OBJS} - @if [ "x${LIB_FILE}" = "xlibtcl${MAJOR_VERSION}.${MINOR_VERSION}.dll" ] ; then \ - ( cd ${TOP_DIR}/win; ${MAKE} winextensions ); \ + @if test "x${LIB_FILE}" = "xlibtcl${MAJOR_VERSION}.${MINOR_VERSION}.dll"; then \ + (cd ${TOP_DIR}/win; ${MAKE} winextensions); \ fi rm -f $@ @MAKE_STUB_LIB@ # Make target which outputs the list of the .o contained in the Tcl lib useful @@ -738,18 +752,17 @@ #tclConfig.h: $(UNIX_DIR)/tclConfig.h.in # $(SHELL) config.status clean: clean-packages rm -rf *.a *.o libtcl* core errs *~ \#* TAGS *.E a.out \ - errors ${TCL_EXE} ${TCLTEST_EXE} lib.exp Tcl @DTRACE_HDR@ \ - minizip${HOST_EXEEXT} *.${HOST_OBJEXT} *.zip *.vfs - (cd dltest ; $(MAKE) clean) + errors ${TCL_EXE} ${TCLTEST_EXE} lib.exp Tcl @DTRACE_HDR@ + cd dltest ; $(MAKE) clean distclean: distclean-packages clean rm -rf Makefile config.status config.cache config.log tclConfig.sh \ tclConfig.h *.plist Tcl.framework tcl.pc - (cd dltest ; $(MAKE) distclean) + cd dltest ; $(MAKE) distclean depend: makedepend -- $(DEPEND_SWITCHES) -- $(SRCS) #-------------------------------------------------------------------------- @@ -800,18 +813,11 @@ gdb-test: ${TCLTEST_EXE} @echo "set env @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}" > gdb.run @echo "set env TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> gdb.run @echo "set args $(TOP_DIR)/tests/all.tcl $(TESTFLAGS) -singleproc 1" >> gdb.run $(GDB) ./${TCLTEST_EXE} --command=gdb.run - @rm gdb.run - -lldb-test: ${TCLTEST_EXE} - @echo "settings set target.env-vars @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}" > lldb.run - @echo "settings set target.env-vars TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> lldb.run - $(LLDB) --source lldb.run ./${TCLTEST_EXE} -- $(TOP_DIR)/tests/all.tcl \ - $(TESTFLAGS) -singleproc 1 - @rm lldb.run + rm gdb.run # Useful target to launch a built tcltest with the proper path,... runtest: ${TCLTEST_EXE} $(SHELL_ENV) ./${TCLTEST_EXE} @@ -841,13 +847,11 @@ # This target can be used to run tclsh inside either gdb or insight gdb: ${TCL_EXE} $(SHELL_ENV) $(GDB) ./${TCL_EXE} valgrind: ${TCL_EXE} ${TCLTEST_EXE} - $(SHELL_ENV) $(VALGRIND) $(VALGRINDARGS) ./${TCLTEST_EXE} \ - $(TOP_DIR)/tests/all.tcl -singleproc 1 -constraints valgrind \ - $(TESTFLAGS) + $(SHELL_ENV) $(VALGRIND) $(VALGRINDARGS) ./${TCLTEST_EXE} $(TOP_DIR)/tests/all.tcl -singleproc 1 -constraints valgrind $(TESTFLAGS) valgrindshell: ${TCL_EXE} $(SHELL_ENV) $(VALGRIND) $(VALGRINDARGS) ./${TCL_EXE} $(SCRIPT) trace-shell: ${TCL_EXE} @@ -858,11 +862,11 @@ #-------------------------------------------------------------------------- # Installation rules #-------------------------------------------------------------------------- -INSTALL_BASE_TARGETS = install-binaries $(INSTALL_LIBRARIES) $(INSTALL_MSGS) $(INSTALL_TZDATA) +INSTALL_BASE_TARGETS = install-binaries install-libraries install-msgs $(INSTALL_TZDATA) INSTALL_DOC_TARGETS = install-doc INSTALL_PACKAGE_TARGETS = install-packages INSTALL_DEV_TARGETS = install-headers INSTALL_EXTRA_TARGETS = @EXTRA_INSTALL@ INSTALL_TARGETS = $(INSTALL_BASE_TARGETS) $(INSTALL_DOC_TARGETS) $(INSTALL_DEV_TARGETS) \ @@ -870,20 +874,23 @@ install: $(INSTALL_TARGETS) install-strip: $(MAKE) $(INSTALL_TARGETS) \ - INSTALL_PROGRAM="$(INSTALL_PROGRAM) ${INSTALL_STRIP_PROGRAM}" + INSTALL_PROGRAM="$(INSTALL_PROGRAM) ${INSTALL_STRIP_PROGRAM}" \ + INSTALL_LIBRARY="$(INSTALL_LIBRARY) ${INSTALL_STRIP_LIBRARY}" install-binaries: binaries @for i in "$(LIB_INSTALL_DIR)" "$(BIN_INSTALL_DIR)" \ - "$(CONFIG_INSTALL_DIR)" ; do \ + "$(CONFIG_INSTALL_DIR)"; \ + do \ if [ ! -d "$$i" ] ; then \ echo "Making directory $$i"; \ $(INSTALL_DATA_DIR) "$$i"; \ - fi; \ - done + else true; \ + fi; \ + done; @echo "Installing $(LIB_FILE) to $(DLL_INSTALL_DIR)/" @@INSTALL_LIB@ @chmod 555 "$(DLL_INSTALL_DIR)/$(LIB_FILE)" @echo "Installing ${TCL_EXE} as $(BIN_INSTALL_DIR)/tclsh$(VERSION)${EXE_SUFFIX}" @$(INSTALL_PROGRAM) ${TCL_EXE} "$(BIN_INSTALL_DIR)/tclsh$(VERSION)${EXE_SUFFIX}" @@ -896,181 +903,188 @@ echo "Installing $(STUB_LIB_FILE) to $(LIB_INSTALL_DIR)/"; \ @INSTALL_STUB_LIB@ ; \ fi @EXTRA_INSTALL_BINARIES@ @echo "Installing pkg-config file to $(LIB_INSTALL_DIR)/pkgconfig/" - @$(INSTALL_DATA_DIR) $(LIB_INSTALL_DIR)/pkgconfig - @$(INSTALL_DATA) tcl.pc $(LIB_INSTALL_DIR)/pkgconfig/tcl.pc - -install-libraries-zipfs-shared: libraries - @for i in "$(SCRIPT_INSTALL_DIR)" ; do \ - if [ ! -d "$$i" ] ; then \ - echo "Making directory $$i"; \ - $(INSTALL_DATA_DIR) "$$i"; \ - fi; \ - done - @echo "Installing library files to $(SCRIPT_INSTALL_DIR)/" - @for i in $(UNIX_DIR)/tclAppInit.c @LDAIX_SRC@ @DTRACE_SRC@ ; do \ - $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"; \ - done - -install-libraries-zipfs-static: install-libraries-zipfs-shared - $(INSTALL_DATA) ${TCL_ZIP_FILE} "$(LIB_INSTALL_DIR)" - -MODULE_INSTALL_DIR=$(SCRIPT_INSTALL_DIR)/.. - -install-libraries: libraries - @for i in "$(SCRIPT_INSTALL_DIR)" ; do \ - if [ ! -d "$$i" ] ; then \ - echo "Making directory $$i"; \ - $(INSTALL_DATA_DIR) "$$i"; \ - fi; \ - done - @for i in opt0.4 encoding ../tcl9 ../tcl9/9.0 ../tcl9/9.0/platform ; do \ - if [ ! -d "$(SCRIPT_INSTALL_DIR)"/$$i ] ; then \ - echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ - $(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)"/$$i; \ - fi; \ - done - @echo "Installing library files to $(SCRIPT_INSTALL_DIR)/" - @for i in $(TOP_DIR)/library/*.tcl $(TOP_DIR)/library/tclIndex \ - $(UNIX_DIR)/tclAppInit.c @LDAIX_SRC@ @DTRACE_SRC@ ; do \ - $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"; \ - done - @echo "Installing package http 2.9.0 as a Tcl Module" - @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl \ - "$(MODULE_INSTALL_DIR)"/tcl9/9.0/http-2.9.0.tm - @echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/" - @for i in $(TOP_DIR)/library/opt/*.tcl ; do \ - $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \ - done - @echo "Installing package msgcat 1.7.0 as a Tcl Module" - @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl \ - "$(MODULE_INSTALL_DIR)"/tcl9/9.0/msgcat-1.7.0.tm - @echo "Installing package tcltest 2.5.0 as a Tcl Module" - @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl \ - "$(MODULE_INSTALL_DIR)"/tcl9/9.0/tcltest-2.5.0.tm - @echo "Installing package platform 1.0.14 as a Tcl Module" - @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl \ - "$(MODULE_INSTALL_DIR)"/tcl9/9.0/platform-1.0.14.tm - @echo "Installing package platform::shell 1.1.4 as a Tcl Module" - @$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl \ - "$(MODULE_INSTALL_DIR)"/tcl9/9.0/platform/shell-1.1.4.tm - @echo "Installing encoding files to $(SCRIPT_INSTALL_DIR)/encoding/" - @for i in $(TOP_DIR)/library/encoding/*.enc ; do \ - $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/encoding; \ - done - @if [ -n "$(TCL_MODULE_PATH)" -a -f $(TOP_DIR)/library/tm.tcl ] ; then \ - echo "Customizing tcl module path"; \ - echo "if {![interp issafe]} { ::tcl::tm::roots {$(TCL_MODULE_PATH)} }" >> \ - "$(SCRIPT_INSTALL_DIR)"/tm.tcl; \ - fi - -install-tzdata: - @for i in tzdata ; do \ - if [ ! -d "$(SCRIPT_INSTALL_DIR)"/$$i ] ; then \ - echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ - $(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)"/$$i; \ - fi; \ - done + @$(INSTALL_DATA_DIR) "$(LIB_INSTALL_DIR)/pkgconfig" + @$(INSTALL_DATA) tcl.pc "$(LIB_INSTALL_DIR)/pkgconfig/tcl.pc" + +install-libraries: libraries + @for i in "$(SCRIPT_INSTALL_DIR)" "$(MODULE_INSTALL_DIR)"; \ + do \ + if [ ! -d "$$i" ] ; then \ + echo "Making directory $$i"; \ + $(INSTALL_DATA_DIR) "$$i"; \ + else true; \ + fi; \ + done; + @for i in opt0.4 http1.0 encoding; \ + do \ + if [ ! -d "$(SCRIPT_INSTALL_DIR)/$$i" ] ; then \ + echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ + $(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)/$$i"; \ + else true; \ + fi; \ + done; + @for i in 8.4 8.4/platform 8.5 8.6; \ + do \ + if [ ! -d "$(MODULE_INSTALL_DIR)/$$i" ] ; then \ + echo "Making directory $(MODULE_INSTALL_DIR)/$$i"; \ + $(INSTALL_DATA_DIR) "$(MODULE_INSTALL_DIR)/$$i"; \ + else true; \ + fi; \ + done; + @echo "Installing library files to $(SCRIPT_INSTALL_DIR)/"; + @for i in $(TOP_DIR)/library/*.tcl $(TOP_DIR)/library/tclIndex \ + $(UNIX_DIR)/tclAppInit.c @LDAIX_SRC@ @DTRACE_SRC@; \ + do \ + $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"; \ + done; + @echo "Installing package http1.0 files to $(SCRIPT_INSTALL_DIR)/http1.0/"; + @for i in $(TOP_DIR)/library/http1.0/*.tcl ; \ + do \ + $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/http1.0"; \ + done; + @echo "Installing package http 2.9.5 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.9.5.tm"; + @echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/"; + @for i in $(TOP_DIR)/library/opt/*.tcl ; \ + do \ + $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ + done; + @echo "Installing package msgcat 1.6.1 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(MODULE_INSTALL_DIR)/8.5/msgcat-1.6.1.tm"; + @echo "Installing package tcltest 2.5.3 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(MODULE_INSTALL_DIR)/8.5/tcltest-2.5.3.tm"; + + @echo "Installing package platform 1.0.14 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(MODULE_INSTALL_DIR)/8.4/platform-1.0.14.tm"; + @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl "$(MODULE_INSTALL_DIR)/8.4/platform/shell-1.1.4.tm"; + + @echo "Installing encoding files to $(SCRIPT_INSTALL_DIR)/encoding/"; + @for i in $(TOP_DIR)/library/encoding/*.enc ; do \ + $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/encoding"; \ + done; + @if [ -n "$(TCL_MODULE_PATH)" -a -f $(TOP_DIR)/library/tm.tcl ]; then \ + echo "Customizing tcl module path"; \ + echo "if {![interp issafe]} { ::tcl::tm::roots {$(TCL_MODULE_PATH)} }" >> \ + "$(SCRIPT_INSTALL_DIR)/tm.tcl"; \ + fi + +install-tzdata: + @for i in tzdata; \ + do \ + if [ ! -d "$(SCRIPT_INSTALL_DIR)/$$i" ] ; then \ + echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ + $(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)/$$i"; \ + else true; \ + fi; \ + done; @echo "Installing time zone files to $(SCRIPT_INSTALL_DIR)/tzdata/" @for i in $(TOP_DIR)/library/tzdata/* ; do \ if [ -d $$i ] ; then \ ii=`basename $$i`; \ - if [ ! -d "$(SCRIPT_INSTALL_DIR)"/tzdata/$$ii ] ; then \ - $(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)"/tzdata/$$ii; \ + if [ ! -d "$(SCRIPT_INSTALL_DIR)/tzdata/$$ii" ] ; then \ + $(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)/tzdata/$$ii"; \ fi; \ for j in $$i/* ; do \ if [ -d $$j ] ; then \ jj=`basename $$j`; \ - if [ ! -d "$(SCRIPT_INSTALL_DIR)"/tzdata/$$ii/$$jj ] ; then \ - $(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)"/tzdata/$$ii/$$jj; \ - fi; \ - for k in $$j/* ; do \ - $(INSTALL_DATA) $$k "$(SCRIPT_INSTALL_DIR)"/tzdata/$$ii/$$jj; \ - done; \ - else \ - $(INSTALL_DATA) $$j "$(SCRIPT_INSTALL_DIR)"/tzdata/$$ii; \ - fi; \ - done; \ - else \ - $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/tzdata; \ - fi; \ - done - -install-msgs: - @for i in msgs ; do \ - if [ ! -d "$(SCRIPT_INSTALL_DIR)"/$$i ] ; then \ - echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ - $(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)"/$$i; \ - fi; \ - done - @echo "Installing message catalog files to $(SCRIPT_INSTALL_DIR)/msgs/" - @for i in $(TOP_DIR)/library/msgs/*.msg ; do \ - $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/msgs; \ - done - -install-doc: doc - @for i in "$(MAN_INSTALL_DIR)" "$(MAN1_INSTALL_DIR)" "$(MAN3_INSTALL_DIR)" "$(MANN_INSTALL_DIR)" ; do \ + if [ ! -d "$(SCRIPT_INSTALL_DIR)/tzdata/$$ii/$$jj" ] ; then \ + $(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)/tzdata/$$ii/$$jj"; \ + fi; \ + for k in $$j/* ; do \ + $(INSTALL_DATA) $$k "$(SCRIPT_INSTALL_DIR)/tzdata/$$ii/$$jj"; \ + done; \ + else \ + $(INSTALL_DATA) $$j "$(SCRIPT_INSTALL_DIR)/tzdata/$$ii"; \ + fi; \ + done; \ + else \ + $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/tzdata"; \ + fi; \ + done; + +install-msgs: + @for i in msgs; \ + do \ + if [ ! -d "$(SCRIPT_INSTALL_DIR)/$$i" ] ; then \ + echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ + $(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)/$$i"; \ + else true; \ + fi; \ + done; + @echo "Installing message catalog files to $(SCRIPT_INSTALL_DIR)/msgs/" + @for i in $(TOP_DIR)/library/msgs/*.msg ; do \ + $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/msgs"; \ + done; + +install-doc: doc + @for i in "$(MAN_INSTALL_DIR)" "$(MAN1_INSTALL_DIR)" "$(MAN3_INSTALL_DIR)" "$(MANN_INSTALL_DIR)" ; \ + do \ if [ ! -d "$$i" ] ; then \ echo "Making directory $$i"; \ $(INSTALL_DATA_DIR) "$$i"; \ - fi; \ - done - @echo "Installing and cross-linking top-level (.1) docs to $(MAN1_INSTALL_DIR)/" - @for i in $(TOP_DIR)/doc/*.1 ; do \ + else true; \ + fi; \ + done; + @echo "Installing and cross-linking top-level (.1) docs to $(MAN1_INSTALL_DIR)/"; + @for i in $(TOP_DIR)/doc/*.1; do \ $(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MAN1_INSTALL_DIR)"; \ done - @echo "Installing and cross-linking C API (.3) docs to $(MAN3_INSTALL_DIR)/" - @for i in $(TOP_DIR)/doc/*.3 ; do \ + + @echo "Installing and cross-linking C API (.3) docs to $(MAN3_INSTALL_DIR)/"; + @for i in $(TOP_DIR)/doc/*.3; do \ $(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MAN3_INSTALL_DIR)"; \ done + @echo "Installing and cross-linking command (.n) docs to $(MANN_INSTALL_DIR)/"; - @for i in $(TOP_DIR)/doc/*.n ; do \ + @for i in $(TOP_DIR)/doc/*.n; do \ $(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MANN_INSTALL_DIR)"; \ done -# Public headers that define Tcl's API -TCL_PUBLIC_HEADERS = $(GENERIC_DIR)/tcl.h $(GENERIC_DIR)/tclDecls.h \ - $(GENERIC_DIR)/tclOO.h $(GENERIC_DIR)/tclOODecls.h \ - $(GENERIC_DIR)/tclPlatDecls.h $(GENERIC_DIR)/tclTomMath.h \ - $(GENERIC_DIR)/tclTomMathDecls.h -# Private headers that define Tcl's internal API -TCL_PRIVATE_HEADERS = $(GENERIC_DIR)/tclInt.h $(GENERIC_DIR)/tclIntDecls.h \ - $(GENERIC_DIR)/tclIntPlatDecls.h $(GENERIC_DIR)/tclPort.h \ - $(GENERIC_DIR)/tclOOInt.h $(GENERIC_DIR)/tclOOIntDecls.h \ - $(UNIX_DIR)/tclUnixPort.h -# Any other headers you find in the Tcl sources are purely part of Tcl's -# implementation, and aren't to be installed. - install-headers: - @for i in "$(INCLUDE_INSTALL_DIR)" ; do \ + @for i in "$(INCLUDE_INSTALL_DIR)"; \ + do \ if [ ! -d "$$i" ] ; then \ echo "Making directory $$i"; \ $(INSTALL_DATA_DIR) "$$i"; \ - fi; \ - done + else true; \ + fi; \ + done; @echo "Installing header files to $(INCLUDE_INSTALL_DIR)/"; - @for i in $(TCL_PUBLIC_HEADERS) ; do \ + @for i in $(GENERIC_DIR)/tcl.h $(GENERIC_DIR)/tclDecls.h \ + $(GENERIC_DIR)/tclOO.h $(GENERIC_DIR)/tclOODecls.h \ + $(GENERIC_DIR)/tclPlatDecls.h \ + $(GENERIC_DIR)/tclTomMath.h \ + $(GENERIC_DIR)/tclTomMathDecls.h ; \ + do \ $(INSTALL_DATA) $$i "$(INCLUDE_INSTALL_DIR)"; \ - done + done; # Optional target to install private headers install-private-headers: - @for i in "$(PRIVATE_INCLUDE_INSTALL_DIR)" ; do \ + @for i in "$(PRIVATE_INCLUDE_INSTALL_DIR)"; \ + do \ if [ ! -d "$$i" ] ; then \ echo "Making directory $$i"; \ $(INSTALL_DATA_DIR) "$$i"; \ - fi; \ - done + else true; \ + fi; \ + done; @echo "Installing private header files to $(PRIVATE_INCLUDE_INSTALL_DIR)/"; - @for i in $(TCL_PRIVATE_HEADERS) ; do \ + @for i in $(GENERIC_DIR)/tclInt.h $(GENERIC_DIR)/tclIntDecls.h \ + $(GENERIC_DIR)/tclIntPlatDecls.h $(GENERIC_DIR)/tclPort.h \ + $(GENERIC_DIR)/tclOOInt.h $(GENERIC_DIR)/tclOOIntDecls.h \ + $(UNIX_DIR)/tclUnixPort.h; \ + do \ $(INSTALL_DATA) $$i "$(PRIVATE_INCLUDE_INSTALL_DIR)"; \ - done - @if test -f tclConfig.h ; then \ + done; + @if test -f tclConfig.h; then\ $(INSTALL_DATA) tclConfig.h "$(PRIVATE_INCLUDE_INSTALL_DIR)"; \ - fi + fi; #-------------------------------------------------------------------------- # Rules for how to compile C files #-------------------------------------------------------------------------- @@ -1085,49 +1099,46 @@ tclTestInit.o: $(UNIX_DIR)/tclAppInit.c ${TCL_EXE} @if test -f tclAppInit.o ; then \ rm -f tclAppInit.sav; \ mv tclAppInit.o tclAppInit.sav; \ - fi + fi; $(CC) -c $(APP_CC_SWITCHES) \ -DTCL_BUILDTIME_LIBRARY="\"${TCL_BUILDTIME_LIBRARY}\"" \ -DTCL_TEST $(UNIX_DIR)/tclAppInit.c - @rm -f tclTestInit.o + rm -f tclTestInit.o mv tclAppInit.o tclTestInit.o @if test -f tclAppInit.sav ; then \ mv tclAppInit.sav tclAppInit.o; \ - fi + fi; xtTestInit.o: $(UNIX_DIR)/tclAppInit.c ${TCL_EXE} @if test -f tclAppInit.o ; then \ rm -f tclAppInit.sav; \ mv tclAppInit.o tclAppInit.sav; \ - fi + fi; $(CC) -c $(APP_CC_SWITCHES) \ -DTCL_BUILDTIME_LIBRARY="\"${TCL_BUILDTIME_LIBRARY}\"" \ -DTCL_TEST -DTCL_XT_TEST $(UNIX_DIR)/tclAppInit.c - @rm -f xtTestInit.o + rm -f xtTestInit.o mv tclAppInit.o xtTestInit.o @if test -f tclAppInit.sav ; then \ mv tclAppInit.sav tclAppInit.o; \ - fi + fi; # Object files used on all Unix systems: -REGHDRS = $(GENERIC_DIR)/regex.h $(GENERIC_DIR)/regguts.h \ - $(GENERIC_DIR)/regcustom.h -TCLREHDRS = $(GENERIC_DIR)/tclRegexp.h -COMPILEHDR = $(GENERIC_DIR)/tclCompile.h -FSHDR = $(GENERIC_DIR)/tclFileSystem.h -IOHDR = $(GENERIC_DIR)/tclIO.h -MATHHDRS = $(GENERIC_DIR)/tommath.h $(GENERIC_DIR)/tclTomMath.h -PARSEHDR = $(GENERIC_DIR)/tclParse.h -NREHDR = $(GENERIC_DIR)/tclInt.h -TRIMHDR = $(GENERIC_DIR)/tclStringTrim.h - -TCL_LOCATIONS = -DTCL_LIBRARY="\"${TCL_LIBRARY}\"" \ - -DTCL_PACKAGE_PATH="\"${TCL_PACKAGE_PATH}\"" +REGHDRS=$(GENERIC_DIR)/regex.h $(GENERIC_DIR)/regguts.h \ + $(GENERIC_DIR)/regcustom.h +TCLREHDRS=$(GENERIC_DIR)/tclRegexp.h +COMPILEHDR=$(GENERIC_DIR)/tclCompile.h +FSHDR=$(GENERIC_DIR)/tclFileSystem.h +IOHDR=$(GENERIC_DIR)/tclIO.h +MATHHDRS=$(GENERIC_DIR)/tommath.h $(GENERIC_DIR)/tclTomMath.h +PARSEHDR=$(GENERIC_DIR)/tclParse.h +NREHDR=$(GENERIC_DIR)/tclInt.h +TRIMHDR=$(GENERIC_DIR)/tclStringTrim.h regcomp.o: $(REGHDRS) $(GENERIC_DIR)/regcomp.c $(GENERIC_DIR)/regc_lex.c \ $(GENERIC_DIR)/regc_color.c $(GENERIC_DIR)/regc_locale.c \ $(GENERIC_DIR)/regc_nfa.c $(GENERIC_DIR)/regc_cvec.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/regcomp.c @@ -1307,11 +1318,11 @@ $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclNamesp.c tclNotify.o: $(GENERIC_DIR)/tclNotify.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclNotify.c -tclOO.o: $(GENERIC_DIR)/tclOO.c $(GENERIC_DIR)/tclOOScript.h +tclOO.o: $(GENERIC_DIR)/tclOO.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOO.c tclOOBasic.o: $(GENERIC_DIR)/tclOOBasic.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOOBasic.c @@ -1352,23 +1363,23 @@ # this information from the variables which can be overridden by the user. As # every path can be configured separately we do not remember one general # prefix/exec_prefix but all the different paths individually. tclPkgConfig.o: $(GENERIC_DIR)/tclPkgConfig.c - $(CC) -c $(CC_SWITCHES) \ + $(CC) -c $(CC_SWITCHES) \ -DCFG_INSTALL_LIBDIR="\"$(LIB_INSTALL_DIR)\"" \ -DCFG_INSTALL_BINDIR="\"$(BIN_INSTALL_DIR)\"" \ -DCFG_INSTALL_SCRDIR="\"$(SCRIPT_INSTALL_DIR)\"" \ -DCFG_INSTALL_INCDIR="\"$(INCLUDE_INSTALL_DIR)\"" \ -DCFG_INSTALL_DOCDIR="\"$(MAN_INSTALL_DIR)\"" \ + \ -DCFG_RUNTIME_LIBDIR="\"$(libdir)\"" \ -DCFG_RUNTIME_BINDIR="\"$(bindir)\"" \ -DCFG_RUNTIME_SCRDIR="\"$(TCL_LIBRARY)\"" \ -DCFG_RUNTIME_INCDIR="\"$(includedir)\"" \ -DCFG_RUNTIME_DOCDIR="\"$(mandir)\"" \ - -DCFG_RUNTIME_DLLFILE="\"$(TCL_LIB_FILE)\"" \ - -DCFG_RUNTIME_ZIPFILE="\"$(TCL_ZIP_FILE)\"" \ + \ $(GENERIC_DIR)/tclPkgConfig.c tclPosixStr.o: $(GENERIC_DIR)/tclPosixStr.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclPosixStr.c @@ -1376,13 +1387,10 @@ $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclPreserve.c tclProc.o: $(GENERIC_DIR)/tclProc.c $(COMPILEHDR) $(NREHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclProc.c -tclProcess.o: $(GENERIC_DIR)/tclProcess.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclProcess.c - tclRegexp.o: $(GENERIC_DIR)/tclRegexp.c $(TCLREHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclRegexp.c tclResolve.o: $(GENERIC_DIR)/tclResolve.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclResolve.c @@ -1415,19 +1423,10 @@ $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclVar.c tclZlib.o: $(GENERIC_DIR)/tclZlib.c $(CC) -c $(CC_SWITCHES) $(ZLIB_INCLUDE) $(GENERIC_DIR)/tclZlib.c -tclZipfs.o: $(GENERIC_DIR)/tclZipfs.c - $(CC) -c $(CC_SWITCHES) \ - -DCFG_RUNTIME_DLLFILE="\"$(TCL_LIB_FILE)\"" \ - -DCFG_RUNTIME_ZIPFILE="\"$(TCL_ZIP_FILE)\"" \ - -DCFG_RUNTIME_LIBDIR="\"$(libdir)\"" \ - -DCFG_RUNTIME_SCRDIR="\"$(TCL_LIBRARY)\"" \ - $(ZLIB_INCLUDE) -I$(ZLIB_DIR)/contrib/minizip \ - $(GENERIC_DIR)/tclZipfs.c - tclTest.o: $(GENERIC_DIR)/tclTest.c $(IOHDR) $(TCLREHDRS) $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTest.c tclTestObj.o: $(GENERIC_DIR)/tclTestObj.c $(MATHHDRS) $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTestObj.c @@ -1454,18 +1453,18 @@ $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclThreadTest.c tclTomMathInterface.o: $(GENERIC_DIR)/tclTomMathInterface.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclTomMathInterface.c -bn_reverse.o: $(TOMMATH_DIR)/bn_reverse.c $(MATHHDRS) - $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_reverse.c - -bn_fast_s_mp_mul_digs.o: $(TOMMATH_DIR)/bn_fast_s_mp_mul_digs.c $(MATHHDRS) - $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_fast_s_mp_mul_digs.c - -bn_fast_s_mp_sqr.o: $(TOMMATH_DIR)/bn_fast_s_mp_sqr.c $(MATHHDRS) - $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_fast_s_mp_sqr.c +bn_s_mp_reverse.o: $(TOMMATH_DIR)/bn_s_mp_reverse.c $(MATHHDRS) + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_s_mp_reverse.c + +bn_s_mp_mul_digs_fast.o: $(TOMMATH_DIR)/bn_s_mp_mul_digs_fast.c $(MATHHDRS) + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_s_mp_mul_digs_fast.c + +bn_s_mp_sqr_fast.o: $(TOMMATH_DIR)/bn_s_mp_sqr_fast.c $(MATHHDRS) + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_s_mp_sqr_fast.c bn_mp_add.o: $(TOMMATH_DIR)/bn_mp_add.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_add.c bn_mp_add_d.o: $(TOMMATH_DIR)/bn_mp_add_d.c $(MATHHDRS) @@ -1517,27 +1516,12 @@ $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_div_3.c bn_mp_exch.o: $(TOMMATH_DIR)/bn_mp_exch.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_exch.c -bn_mp_expt_d.o: $(TOMMATH_DIR)/bn_mp_expt_d.c $(MATHHDRS) - $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_expt_d.c - -bn_mp_expt_d_ex.o: $(TOMMATH_DIR)/bn_mp_expt_d_ex.c $(MATHHDRS) - $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_expt_d_ex.c - -bn_s_mp_get_bit.o: $(TOMMATH_DIR)/bn_s_mp_get_bit.c $(MATHHDRS) - $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_s_mp_get_bit.c - -bn_mp_get_int.o: $(TOMMATH_DIR)/bn_mp_get_int.c $(MATHHDRS) - $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_get_int.c - -bn_mp_get_long.o: $(TOMMATH_DIR)/bn_mp_get_long.c $(MATHHDRS) - $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_get_long.c - -bn_mp_get_long_long.o: $(TOMMATH_DIR)/bn_mp_get_long_long.c $(MATHHDRS) - $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_get_long_long.c +bn_mp_expt_u32.o: $(TOMMATH_DIR)/bn_mp_expt_u32.c $(MATHHDRS) + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_expt_u32.c bn_mp_grow.o: $(TOMMATH_DIR)/bn_mp_grow.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_grow.c bn_mp_init.o: $(TOMMATH_DIR)/bn_mp_init.c $(MATHHDRS) @@ -1550,21 +1534,21 @@ $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_init_multi.c bn_mp_init_set.o: $(TOMMATH_DIR)/bn_mp_init_set.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_init_set.c -bn_mp_init_set_int.o: $(TOMMATH_DIR)/bn_mp_init_set_int.c $(MATHHDRS) - $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_init_set_int.c - bn_mp_init_size.o:$(TOMMATH_DIR)/bn_mp_init_size.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_init_size.c -bn_mp_karatsuba_mul.o: $(TOMMATH_DIR)/bn_mp_karatsuba_mul.c $(MATHHDRS) - $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_karatsuba_mul.c +bn_s_mp_karatsuba_mul.o: $(TOMMATH_DIR)/bn_s_mp_karatsuba_mul.c $(MATHHDRS) + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_s_mp_karatsuba_mul.c -bn_mp_karatsuba_sqr.o: $(TOMMATH_DIR)/bn_mp_karatsuba_sqr.c $(MATHHDRS) - $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_karatsuba_sqr.c +bn_s_mp_karatsuba_sqr.o: $(TOMMATH_DIR)/bn_s_mp_karatsuba_sqr.c $(MATHHDRS) + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_s_mp_karatsuba_sqr.c + +bn_s_mp_balance_mul.o: $(TOMMATH_DIR)/bn_s_mp_balance_mul.c $(MATHHDRS) + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_s_mp_balance_mul.c bn_mp_lshd.o: $(TOMMATH_DIR)/bn_mp_lshd.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_lshd.c bn_mp_mod.o: $(TOMMATH_DIR)/bn_mp_mod.c $(MATHHDRS) @@ -1604,19 +1588,10 @@ $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_rshd.c bn_mp_set.o: $(TOMMATH_DIR)/bn_mp_set.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_set.c -bn_mp_set_int.o: $(TOMMATH_DIR)/bn_mp_set_int.c $(MATHHDRS) - $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_set_int.c - -bn_mp_set_long.o: $(TOMMATH_DIR)/bn_mp_set_long.c $(MATHHDRS) - $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_set_long.c - -bn_mp_set_long_long.o: $(TOMMATH_DIR)/bn_mp_set_long_long.c $(MATHHDRS) - $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_set_long_long.c - bn_mp_shrink.o: $(TOMMATH_DIR)/bn_mp_shrink.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_shrink.c bn_mp_sqr.o: $(TOMMATH_DIR)/bn_mp_sqr.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_sqr.c @@ -1631,27 +1606,24 @@ $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_sub_d.c bn_mp_signed_rsh.o: $(TOMMATH_DIR)/bn_mp_signed_rsh.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_signed_rsh.c -bn_mp_to_unsigned_bin.o: $(TOMMATH_DIR)/bn_mp_to_unsigned_bin.c $(MATHHDRS) - $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_to_unsigned_bin.c - -bn_mp_to_unsigned_bin_n.o: $(TOMMATH_DIR)/bn_mp_to_unsigned_bin_n.c $(MATHHDRS) - $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_to_unsigned_bin_n.c - -bn_mp_toom_mul.o: $(TOMMATH_DIR)/bn_mp_toom_mul.c $(MATHHDRS) - $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_toom_mul.c - -bn_mp_toom_sqr.o: $(TOMMATH_DIR)/bn_mp_toom_sqr.c $(MATHHDRS) - $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_toom_sqr.c - -bn_mp_toradix_n.o: $(TOMMATH_DIR)/bn_mp_toradix_n.c $(MATHHDRS) - $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_toradix_n.c - -bn_mp_unsigned_bin_size.o: $(TOMMATH_DIR)/bn_mp_unsigned_bin_size.c $(MATHHDRS) - $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_unsigned_bin_size.c +bn_mp_to_ubin.o: $(TOMMATH_DIR)/bn_mp_to_ubin.c $(MATHHDRS) + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_to_ubin.c + +bn_s_mp_toom_mul.o: $(TOMMATH_DIR)/bn_s_mp_toom_mul.c $(MATHHDRS) + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_s_mp_toom_mul.c + +bn_s_mp_toom_sqr.o: $(TOMMATH_DIR)/bn_s_mp_toom_sqr.c $(MATHHDRS) + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_s_mp_toom_sqr.c + +bn_mp_to_radix.o: $(TOMMATH_DIR)/bn_mp_to_radix.c $(MATHHDRS) + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_to_radix.c + +bn_mp_ubin_size.o: $(TOMMATH_DIR)/bn_mp_ubin_size.c $(MATHHDRS) + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_ubin_size.c bn_mp_xor.o: $(TOMMATH_DIR)/bn_mp_xor.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_xor.c bn_mp_zero.o: $(TOMMATH_DIR)/bn_mp_zero.c $(MATHHDRS) @@ -1679,18 +1651,12 @@ $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixFCmd.c tclUnixFile.o: $(UNIX_DIR)/tclUnixFile.c $(FSHDR) $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixFile.c -tclEpollNotfy.o: $(UNIX_DIR)/tclEpollNotfy.c - $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclEpollNotfy.c - -tclKqueueNotfy.o: $(UNIX_DIR)/tclKqueueNotfy.c - $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclKqueueNotfy.c - -tclSelectNotfy.o: $(UNIX_DIR)/tclSelectNotfy.c - $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclSelectNotfy.c +tclUnixNotfy.o: $(UNIX_DIR)/tclUnixNotfy.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixNotfy.c tclUnixPipe.o: $(UNIX_DIR)/tclUnixPipe.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixPipe.c tclUnixSock.o: $(UNIX_DIR)/tclUnixSock.c @@ -1703,10 +1669,11 @@ $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixThrd.c tclUnixTime.o: $(UNIX_DIR)/tclUnixTime.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixTime.c +TCL_LOCATIONS=-DTCL_LIBRARY="\"${TCL_LIBRARY}\"" -DTCL_PACKAGE_PATH="\"${TCL_PACKAGE_PATH}\"" tclUnixInit.o: $(UNIX_DIR)/tclUnixInit.c tclConfig.sh $(CC) -c $(CC_SWITCHES) $(TCL_LOCATIONS) $(UNIX_DIR)/tclUnixInit.c tclUnixCompat.o: $(UNIX_DIR)/tclUnixCompat.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixCompat.c @@ -1827,162 +1794,111 @@ $(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclOOStubLib.c .c.o: $(CC) -c $(CC_SWITCHES) $< -#-------------------------------------------------------------------------- -# Minizip implementation -#-------------------------------------------------------------------------- -adler32.$(HOST_OBJEXT): - $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/adler32.c - -compress.$(HOST_OBJEXT): - $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/compress.c - -crc32.$(HOST_OBJEXT): - $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/crc32.c - -deflate.$(HOST_OBJEXT): - $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/deflate.c - -ioapi.$(HOST_OBJEXT): - $(HOST_CC) -o $@ -DIOAPI_NO_64 -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip -c \ - $(ZLIB_DIR)/contrib/minizip/ioapi.c - -infback.$(HOST_OBJEXT): - $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/infback.c - -inffast.$(HOST_OBJEXT): - $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/inffast.c - -inflate.$(HOST_OBJEXT): - $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/inflate.c - -inftrees.$(HOST_OBJEXT): - $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/inftrees.c - -trees.$(HOST_OBJEXT): - $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/trees.c - -uncompr.$(HOST_OBJEXT): - $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/uncompr.c - -zip.$(HOST_OBJEXT): - $(HOST_CC) -o $@ -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip -c \ - $(ZLIB_DIR)/contrib/minizip/zip.c - -zutil.$(HOST_OBJEXT): - $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/zutil.c - -minizip.$(HOST_OBJEXT): - $(HOST_CC) -o $@ -DIOAPI_NO_64 -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip -c \ - $(ZLIB_DIR)/contrib/minizip/minizip.c - -minizip${HOST_EXEEXT}: $(MINIZIP_OBJS) - $(HOST_CC) -o $@ $(MINIZIP_OBJS) - #-------------------------------------------------------------------------- # Bundled Package targets #-------------------------------------------------------------------------- # Propagate configure args like --enable-64bit to package configure PKG_CFG_ARGS = @PKG_CFG_ARGS@ # 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 +# to adapt the ../.. relative paths below and at the top of configure.in (we # cannot use absolute paths due to issues in nested configure when path to # build dir contains spaces). PKG_DIR = ./pkgs 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 $(PKG_DIR)/$$pkg; \ - if [ ! -f $(PKG_DIR)/$$pkg/Makefile ] ; then \ - ( cd $(PKG_DIR)/$$pkg; \ - $$i/configure --with-tcl=../.. \ - --with-tclinclude=$(GENERIC_DIR) \ - $(PKG_CFG_ARGS) --libdir=$(PACKAGE_DIR) \ - --enable-shared; ) || exit $$?; \ - fi; \ - fi; \ - fi; \ + @for i in $(PKGS_DIR)/*; do \ + if [ -d $$i ]; then \ + if [ -x $$i/configure ]; then \ + pkg=`basename $$i`; \ + echo "Configuring package '$$pkg'"; \ + mkdir -p $(PKG_DIR)/$$pkg; \ + if [ ! -f $(PKG_DIR)/$$pkg/Makefile ]; then \ + ( cd $(PKG_DIR)/$$pkg; \ + $$i/configure --with-tcl=../.. \ + --with-tclinclude=$(GENERIC_DIR) \ + $(PKG_CFG_ARGS) --libdir=$(PACKAGE_DIR) \ + --enable-shared --enable-threads; ) || exit $$?; \ + fi; \ + fi; \ + fi; \ done packages: configure-packages ${STUB_LIB_FILE} - @for i in $(PKGS_DIR)/* ; do \ - if [ -d $$i ] ; then \ - pkg=`basename $$i`; \ - if [ -f $(PKG_DIR)/$$pkg/Makefile ] ; then \ - echo "Building package '$$pkg'"; \ - ( cd $(PKG_DIR)/$$pkg; $(MAKE); ) || exit $$?; \ - fi; \ - fi; \ + @for i in $(PKGS_DIR)/*; do \ + if [ -d $$i ]; then \ + pkg=`basename $$i`; \ + if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \ + echo "Building package '$$pkg'"; \ + ( cd $(PKG_DIR)/$$pkg; $(MAKE); ) || exit $$?; \ + fi; \ + fi; \ done install-packages: packages - @for i in $(PKGS_DIR)/* ; do \ - if [ -d $$i ] ; then \ - pkg=`basename $$i`; \ - if [ -f $(PKG_DIR)/$$pkg/Makefile ] ; then \ - echo "Installing package '$$pkg'"; \ - ( cd $(PKG_DIR)/$$pkg; $(MAKE) install \ - "DESTDIR=$(INSTALL_ROOT)"; ) || exit $$?; \ - fi; \ - fi; \ + @for i in $(PKGS_DIR)/*; do \ + if [ -d $$i ]; then \ + pkg=`basename $$i`; \ + if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \ + echo "Installing package '$$pkg'"; \ + ( cd $(PKG_DIR)/$$pkg; $(MAKE) install \ + "DESTDIR=$(INSTALL_ROOT)"; ) || exit $$?; \ + fi; \ + fi; \ done test-packages: ${TCLTEST_EXE} packages - @for i in $(PKGS_DIR)/* ; do \ - if [ -d $$i ] ; then \ - pkg=`basename $$i`; \ - if [ -f $(PKG_DIR)/$$pkg/Makefile ] ; then \ - echo "Testing package '$$pkg'"; \ - ( cd $(PKG_DIR)/$$pkg; $(MAKE) \ - "@LD_LIBRARY_PATH_VAR@=../..:$${@LD_LIBRARY_PATH_VAR@}" \ - "TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" \ - "TCLLIBPATH=../../pkgs" test \ - "TCLSH_PROG=../../${TCLTEST_EXE}"; ) \ - fi; \ - fi; \ + @for i in $(PKGS_DIR)/*; do \ + if [ -d $$i ]; then \ + pkg=`basename $$i`; \ + if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \ + echo "Testing package '$$pkg'"; \ + ( cd $(PKG_DIR)/$$pkg; $(MAKE) \ + "@LD_LIBRARY_PATH_VAR@=../..:$${@LD_LIBRARY_PATH_VAR@}" \ + "TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" \ + "TCLLIBPATH=../../pkgs" test \ + "TCLSH_PROG=../../${TCLTEST_EXE}"; ) \ + fi; \ + fi; \ done clean-packages: - @for i in $(PKGS_DIR)/* ; do \ - if [ -d $$i ] ; then \ - pkg=`basename $$i`; \ - if [ -f $(PKG_DIR)/$$pkg/Makefile ] ; then \ - ( cd $(PKG_DIR)/$$pkg; $(MAKE) clean; ) \ - fi; \ + @for i in $(PKGS_DIR)/*; do \ + if [ -d $$i ]; then \ + pkg=`basename $$i`; \ + if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \ + ( cd $(PKG_DIR)/$$pkg; $(MAKE) clean; ) \ fi; \ + fi; \ done distclean-packages: - @for i in $(PKGS_DIR)/* ; do \ - if [ -d $$i ] ; then \ - pkg=`basename $$i`; \ - if [ -f $(PKG_DIR)/$$pkg/Makefile ] ; then \ - ( cd $(PKG_DIR)/$$pkg; $(MAKE) distclean; ) \ - fi; \ - rm -rf $(PKG_DIR)/$$pkg; \ - fi; \ + @for i in $(PKGS_DIR)/*; do \ + if [ -d $$i ]; then \ + pkg=`basename $$i`; \ + if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \ + ( cd $(PKG_DIR)/$$pkg; $(MAKE) distclean; ) \ + fi; \ + rm -rf $(PKG_DIR)/$$pkg; \ + fi; \ done; \ rm -rf $(PKG_DIR) dist-packages: configure-packages @rm -rf $(DISTROOT)/pkgs; \ mkdir -p $(DISTROOT)/pkgs; \ - for i in $(PKGS_DIR)/* ; do \ - if [ -d $$i ] ; then \ - pkg=`basename $$i`; \ - if [ -f $(PKG_DIR)/$$pkg/Makefile ] ; then \ - ( cd $(PKG_DIR)/$$pkg; $(MAKE) dist \ - "DIST_ROOT=$(DISTROOT)/pkgs"; ) || exit $$?; \ - fi; \ - fi; \ + for i in $(PKGS_DIR)/*; do \ + if [ -d $$i ]; then \ + pkg=`basename $$i`; \ + if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \ + ( cd $(PKG_DIR)/$$pkg; $(MAKE) dist \ + "DIST_ROOT=$(DISTROOT)/pkgs"; ) || exit $$?; \ + fi; \ + fi; \ done #-------------------------------------------------------------------------- # Maintainer-only targets #-------------------------------------------------------------------------- @@ -1993,13 +1909,13 @@ # the name of the .y file so that make doesn't try to automatically regenerate # the .c file. gendate: bison --output-file=$(GENERIC_DIR)/tclDate.c \ - --no-lines \ - --name-prefix=TclDate \ - $(GENERIC_DIR)/tclGetDate.y + --no-lines \ + --name-prefix=TclDate \ + $(GENERIC_DIR)/tclGetDate.y # yacc -l $(GENERIC_DIR)/tclGetDate.y # sed -e 's/yy/TclDate/g' -e '/^#include /d' \ # -e 's?SCCSID?RCS: @(#) ?' \ # -e '/#ifdef __STDC__/,/#endif/d' -e '/TclDateerrlab:/d' \ @@ -2031,72 +1947,58 @@ $(GENERIC_DIR)/tclOOStubInit.c: $(GENERIC_DIR)/tclOO.decls @echo "Warning: tclOOStubInit.c may be out of date." @echo "Developers may want to run \"make genstubs\" to regenerate." @echo "This warning can be safely ignored, do not report as a bug!" -$(GENERIC_DIR)/tclOOScript.h: $(GENERIC_DIR)/tclOOScript.tcl - @echo "Warning: tclOOScript.h may be out of date." - @echo "Developers may want to run \"make genscript\" to regenerate." - @echo "This warning can be safely ignored, do not report as a bug!" - genstubs: $(NATIVE_TCLSH) $(TOOL_DIR)/genStubs.tcl $(GENERIC_DIR) \ $(GENERIC_DIR)/tcl.decls $(GENERIC_DIR)/tclInt.decls \ $(GENERIC_DIR)/tclTomMath.decls $(NATIVE_TCLSH) $(TOOL_DIR)/genStubs.tcl $(GENERIC_DIR) \ $(GENERIC_DIR)/tclOO.decls -genscript: - $(NATIVE_TCLSH) $(TOOL_DIR)/makeHeader.tcl \ - $(GENERIC_DIR)/tclOOScript.tcl $(GENERIC_DIR)/tclOOScript.h - # # Target to check that all exported functions have an entry in the stubs # tables. # checkstubs: $(TCL_LIB_FILE) -@for i in `nm -p $(TCL_LIB_FILE) \ | awk '$$2 ~ /^[TDBCS]$$/ { sub("^_", "", $$3); print $$3 }' \ - | sort -n` ; do \ - match=0; \ - for j in $(TCL_DECLS) ; do \ - if [ `grep -c "$$i *(" $$j` -gt 0 ] ; then \ - match=1; \ - fi; \ - done; \ - if [ $$match -eq 0 ] ; then \ - echo $$i; \ - fi; \ + | sort -n`; do \ + match=0; \ + for j in $(TCL_DECLS); do \ + if [ `grep -c "$$i *(" $$j` -gt 0 ]; then \ + match=1; \ + fi; \ + done; \ + if [ $$match -eq 0 ]; then echo $$i; fi \ done # # Target to check that all public APIs which are not command implementations # have an entry in section three of the distributed manpages. # checkdoc: $(TCL_LIB_FILE) -@for i in `nm -p $(TCL_LIB_FILE) | awk '$$3 ~ /Tcl_/ { print $$3 }' \ - | grep -Fv . | grep -v 'Cmd$$' | sort -n` ; do \ - match=0; \ - i=`echo $$i | sed 's/^_//'`; \ - for j in $(TOP_DIR)/doc/*.3 ; do \ - if [ `grep '\-' $$j | grep -c $$i` -gt 0 ] ; then \ - match=1; \ - fi; \ - done; \ - if [ $$match -eq 0 ] ; then \ - echo $$i; \ - fi; \ + | grep -v 'Cmd$$' | sort -n`; do \ + match=0; \ + for j in $(TOP_DIR)/doc/*.3; do \ + if [ `grep '\-' $$j | grep -c $$i` -gt 0 ]; then \ + match=1; \ + fi; \ + done; \ + if [ $$match -eq 0 ]; then echo $$i; fi \ done # # Target to check for proper usage of UCHAR macro. # checkuchar: - -@egrep isalnum\|isalpha\|iscntrl\|isdigit\|islower\|isprint\|ispunct\|isspace\|isupper\|isxdigit\|toupper\|tolower $(SRCS) | grep -v UCHAR + -egrep isalnum\|isalpha\|iscntrl\|isdigit\|islower\|isprint\|ispunct\|isspace\|isupper\|isxdigit\|toupper\|tolower $(SRCS) | grep -v UCHAR # # Target to make sure that only symbols with "Tcl" prefixes are exported. # @@ -2112,163 +2014,156 @@ # # Target to create a Tcl RPM for Linux. Requires that you be on a Linux # system. # -RPM_PLATFORMS = i386 rpm: all - -@rm -f THIS.TCL.SPEC + rm -f THIS.TCL.SPEC echo "%define _builddir `pwd`" > THIS.TCL.SPEC echo "%define _rpmdir `pwd`/RPMS" >> THIS.TCL.SPEC cat tcl.spec >> THIS.TCL.SPEC - for platform in $(RPM_PLATFORMS); do \ - mkdir -p RPMS/$$platform && \ - rpmbuild -bb THIS.TCL.SPEC && \ - mv RPMS/$$platform/*.rpm .; \ - done - -rm -rf RPMS THIS.TCL.SPEC + mkdir -p RPMS/i386 + rpmbuild -bb THIS.TCL.SPEC + mv RPMS/i386/*.rpm . + rm -rf RPMS THIS.TCL.SPEC # -# Target to create a proper Tcl distribution from information in the master -# source directory. DISTDIR must be defined to indicate where to put the -# distribution. DISTDIR must be an absolute path name. +# Target to create a proper Tcl distribution from information in the +# source directory. DISTDIR must be defined to indicate where to put +# the distribution. DISTDIR must be an absolute path name. # DISTROOT = /tmp/dist DISTNAME = tcl${VERSION}${PATCH_LEVEL} ZIPNAME = tcl${MAJOR_VERSION}${MINOR_VERSION}${PATCH_LEVEL}-src.zip DISTDIR = $(DISTROOT)/$(DISTNAME) -DIST_INSTALL_DATA = CPPROG='cp -p' $(INSTALL) -m 644 -DIST_INSTALL_SCRIPT = CPPROG='cp -p' $(INSTALL) -m 755 -BUILTIN_PACKAGE_LIST = http opt msgcat reg dde tcltest platform - -$(UNIX_DIR)/configure: $(UNIX_DIR)/configure.ac $(UNIX_DIR)/tcl.m4 \ +$(UNIX_DIR)/configure: $(UNIX_DIR)/configure.in $(UNIX_DIR)/tcl.m4 \ $(UNIX_DIR)/aclocal.m4 cd $(UNIX_DIR); autoconf $(MAC_OSX_DIR)/configure: $(MAC_OSX_DIR)/configure.ac $(UNIX_DIR)/configure cd $(MAC_OSX_DIR); autoconf $(UNIX_DIR)/tclConfig.h.in: $(MAC_OSX_DIR)/configure cd $(MAC_OSX_DIR); autoheader; touch $@ -dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in \ - $(MAC_OSX_DIR)/configure genstubs dist-packages ${NATIVE_TCLSH} +$(TOP_DIR)/manifest.uuid: + printf "git." >$(TOP_DIR)/manifest.uuid + git rev-parse HEAD >>$(TOP_DIR)/manifest.uuid + +dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(MAC_OSX_DIR)/configure $(TOP_DIR)/manifest.uuid genstubs dist-packages ${NATIVE_TCLSH} rm -rf $(DISTDIR) - $(INSTALL_DATA_DIR) $(DISTDIR)/unix - $(DIST_INSTALL_DATA) $(UNIX_DIR)/*.[ch] $(DISTDIR)/unix - $(DIST_INSTALL_DATA) $(UNIX_DIR)/Makefile.in $(DISTDIR)/unix - $(DIST_INSTALL_DATA) $(UNIX_DIR)/configure.ac \ + mkdir -p $(DISTDIR)/unix + cp -p $(TOP_DIR)/manifest.uuid $(DISTDIR) + cp -p $(UNIX_DIR)/*.[ch] $(DISTDIR)/unix + cp $(UNIX_DIR)/Makefile.in $(DISTDIR)/unix + chmod 664 $(DISTDIR)/unix/Makefile.in + cp $(UNIX_DIR)/configure $(UNIX_DIR)/configure.in \ $(UNIX_DIR)/tcl.m4 $(UNIX_DIR)/aclocal.m4 \ $(UNIX_DIR)/tclConfig.sh.in $(UNIX_DIR)/tclooConfig.sh \ $(UNIX_DIR)/install-sh \ - $(UNIX_DIR)/README $(UNIX_DIR)/tcl.spec \ + $(UNIX_DIR)/README $(UNIX_DIR)/ldAix $(UNIX_DIR)/tcl.spec \ $(UNIX_DIR)/installManPage $(UNIX_DIR)/tclConfig.h.in \ $(UNIX_DIR)/tcl.pc.in $(DISTDIR)/unix - $(DIST_INSTALL_SCRIPT) $(UNIX_DIR)/configure $(UNIX_DIR)/ldAix $(DISTDIR)/unix - $(INSTALL_DATA_DIR) $(DISTDIR)/generic - $(DIST_INSTALL_DATA) $(GENERIC_DIR)/*.[cdh] $(DISTDIR)/generic - $(DIST_INSTALL_DATA) $(GENERIC_DIR)/*.decls $(DISTDIR)/generic - $(DIST_INSTALL_DATA) $(GENERIC_DIR)/README $(DISTDIR)/generic - $(DIST_INSTALL_DATA) $(GENERIC_DIR)/tclGetDate.y $(DISTDIR)/generic - $(DIST_INSTALL_DATA) $(TOP_DIR)/changes $(TOP_DIR)/ChangeLog $(TOP_DIR)/README.md \ + chmod 775 $(DISTDIR)/unix/configure $(DISTDIR)/unix/configure.in + chmod 775 $(DISTDIR)/unix/ldAix + @mkdir $(DISTDIR)/generic + cp -p $(GENERIC_DIR)/*.[cdh] $(DISTDIR)/generic + cp -p $(GENERIC_DIR)/*.decls $(DISTDIR)/generic + cp -p $(GENERIC_DIR)/README $(DISTDIR)/generic + cp -p $(GENERIC_DIR)/tclGetDate.y $(DISTDIR)/generic + cp -p $(TOP_DIR)/changes $(TOP_DIR)/ChangeLog $(TOP_DIR)/README.md \ $(TOP_DIR)/ChangeLog.[12]??? $(TOP_DIR)/license.terms \ $(DISTDIR) - $(INSTALL_DATA_DIR) $(DISTDIR)/library - $(DIST_INSTALL_DATA) $(TOP_DIR)/license.terms $(TOP_DIR)/library/*.tcl \ + @mkdir $(DISTDIR)/library + cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/library/*.tcl \ $(TOP_DIR)/library/tclIndex $(DISTDIR)/library - @for i in $(BUILTIN_PACKAGE_LIST) ; do \ - $(INSTALL_DATA_DIR) $(DISTDIR)/library/$$i;\ - $(DIST_INSTALL_DATA) $(TOP_DIR)/library/$$i/*.tcl $(DISTDIR)/library/$$i; \ - done - $(INSTALL_DATA_DIR) $(DISTDIR)/library/encoding - $(DIST_INSTALL_DATA) $(TOP_DIR)/library/encoding/*.enc $(DISTDIR)/library/encoding - $(INSTALL_DATA_DIR) $(DISTDIR)/library/msgs - $(DIST_INSTALL_DATA) $(TOP_DIR)/library/msgs/*.msg $(DISTDIR)/library/msgs + for i in http1.0 http opt msgcat reg dde tcltest platform; \ + do \ + mkdir $(DISTDIR)/library/$$i ;\ + cp -p $(TOP_DIR)/library/$$i/*.tcl $(DISTDIR)/library/$$i; \ + done; + @mkdir $(DISTDIR)/library/encoding + cp -p $(TOP_DIR)/library/encoding/*.enc $(DISTDIR)/library/encoding + @mkdir $(DISTDIR)/library/msgs + cp -p $(TOP_DIR)/library/msgs/*.msg $(DISTDIR)/library/msgs @echo cp -r $(TOP_DIR)/library/tzdata $(DISTDIR)/library/tzdata - @( cd $(TOP_DIR); find library/tzdata -type f -print ) \ + @( cd $(TOP_DIR); \ + find library/tzdata -name CVS -prune -o -type f -print ) \ | ( cd $(TOP_DIR) ; xargs tar cf - ) \ | ( cd $(DISTDIR) ; tar xfp - ) - $(INSTALL_DATA_DIR) $(DISTDIR)/doc - $(DIST_INSTALL_DATA) $(TOP_DIR)/license.terms $(TOP_DIR)/doc/*.[13n] \ + @mkdir $(DISTDIR)/doc + cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/doc/*.[13n] \ $(TOP_DIR)/doc/man.macros $(DISTDIR)/doc - $(INSTALL_DATA_DIR) $(DISTDIR)/compat - $(DIST_INSTALL_DATA) $(TOP_DIR)/license.terms $(COMPAT_DIR)/*.[ch] \ + @mkdir $(DISTDIR)/compat + cp -p $(TOP_DIR)/license.terms $(COMPAT_DIR)/*.[ch] \ $(COMPAT_DIR)/README $(DISTDIR)/compat - $(INSTALL_DATA_DIR) $(DISTDIR)/compat/zlib - @echo cp -r $(COMPAT_DIR)/zlib $(DISTDIR)/compat/zlib - @( cd $(COMPAT_DIR)/zlib; find . -type f -print ) \ + @mkdir $(DISTDIR)/compat/zlib + ( cd $(COMPAT_DIR)/zlib; \ + find . -name CVS -prune -o -type f -print ) \ | ( cd $(COMPAT_DIR)/zlib ; xargs tar cf - ) \ | ( cd $(DISTDIR)/compat/zlib ; tar xfp - ) - $(INSTALL_DATA_DIR) $(DISTDIR)/tests - $(DIST_INSTALL_DATA) $(TOP_DIR)/license.terms $(DISTDIR)/tests - $(DIST_INSTALL_DATA) $(TOP_DIR)/tests/*.test $(TOP_DIR)/tests/README \ + @mkdir $(DISTDIR)/tests + cp -p $(TOP_DIR)/license.terms $(DISTDIR)/tests + cp -p $(TOP_DIR)/tests/*.test $(TOP_DIR)/tests/README \ $(TOP_DIR)/tests/httpd $(TOP_DIR)/tests/*.tcl \ $(DISTDIR)/tests - $(INSTALL_DATA_DIR) $(DISTDIR)/win - $(DIST_INSTALL_DATA) $(TOP_DIR)/win/Makefile.in $(DISTDIR)/win - $(DIST_INSTALL_DATA) $(TOP_DIR)/win/configure.ac \ + @mkdir $(DISTDIR)/win + cp $(TOP_DIR)/win/Makefile.in $(DISTDIR)/win + cp $(TOP_DIR)/win/configure.in $(TOP_DIR)/win/configure \ $(TOP_DIR)/win/tclConfig.sh.in $(TOP_DIR)/win/tclooConfig.sh \ $(TOP_DIR)/win/tcl.m4 $(TOP_DIR)/win/aclocal.m4 \ $(TOP_DIR)/win/tclsh.exe.manifest.in \ $(DISTDIR)/win - $(DIST_INSTALL_SCRIPT) $(TOP_DIR)/win/configure $(DISTDIR)/win - $(DIST_INSTALL_DATA) $(TOP_DIR)/win/*.[ch] $(TOP_DIR)/win/*.ico $(TOP_DIR)/win/*.rc \ + cp -p $(TOP_DIR)/win/*.[ch] $(TOP_DIR)/win/*.ico $(TOP_DIR)/win/*.rc \ $(DISTDIR)/win - $(DIST_INSTALL_DATA) $(TOP_DIR)/win/*.bat $(DISTDIR)/win - $(DIST_INSTALL_DATA) $(TOP_DIR)/win/*.vc $(DISTDIR)/win - $(DIST_INSTALL_DATA) $(TOP_DIR)/win/tcl.hpj.in $(DISTDIR)/win - $(DIST_INSTALL_DATA) $(TOP_DIR)/win/tcl.ds* $(DISTDIR)/win - $(DIST_INSTALL_DATA) $(TOP_DIR)/win/README $(DISTDIR)/win - $(DIST_INSTALL_DATA) $(TOP_DIR)/license.terms $(DISTDIR)/win - $(INSTALL_DATA_DIR) $(DISTDIR)/macosx - $(DIST_INSTALL_DATA) $(MAC_OSX_DIR)/GNUmakefile $(MAC_OSX_DIR)/README \ + cp -p $(TOP_DIR)/win/*.bat $(DISTDIR)/win + cp -p $(TOP_DIR)/win/*.vc $(DISTDIR)/win + cp -p $(TOP_DIR)/win/coffbase.txt $(DISTDIR)/win + cp -p $(TOP_DIR)/win/tcl.hpj.in $(DISTDIR)/win + cp -p $(TOP_DIR)/win/tcl.ds* $(DISTDIR)/win + cp -p $(TOP_DIR)/win/README $(DISTDIR)/win + cp -p $(TOP_DIR)/license.terms $(DISTDIR)/win + @mkdir $(DISTDIR)/macosx + cp -p $(MAC_OSX_DIR)/GNUmakefile $(MAC_OSX_DIR)/README \ $(MAC_OSX_DIR)/*.c $(MAC_OSX_DIR)/*.in \ $(MAC_OSX_DIR)/*.ac $(MAC_OSX_DIR)/*.xcconfig \ - $(DISTDIR)/macosx - $(DIST_INSTALL_SCRIPT) $(MAC_OSX_DIR)/configure $(DISTDIR)/macosx - $(DIST_INSTALL_DATA) $(TOP_DIR)/license.terms $(DISTDIR)/macosx - $(INSTALL_DATA_DIR) $(DISTDIR)/macosx/Tcl.xcode - $(DIST_INSTALL_DATA) $(MAC_OSX_DIR)/Tcl.xcode/project.pbxproj \ + $(MAC_OSX_DIR)/configure $(DISTDIR)/macosx + cp -p $(TOP_DIR)/license.terms $(DISTDIR)/macosx + @mkdir $(DISTDIR)/macosx/Tcl.xcode + cp -p $(MAC_OSX_DIR)/Tcl.xcode/project.pbxproj \ $(MAC_OSX_DIR)/Tcl.xcode/default.pbxuser \ $(DISTDIR)/macosx/Tcl.xcode - $(INSTALL_DATA_DIR) $(DISTDIR)/macosx/Tcl.xcodeproj - $(DIST_INSTALL_DATA) $(MAC_OSX_DIR)/Tcl.xcodeproj/project.pbxproj \ + @mkdir $(DISTDIR)/macosx/Tcl.xcodeproj + cp -p $(MAC_OSX_DIR)/Tcl.xcodeproj/project.pbxproj \ $(MAC_OSX_DIR)/Tcl.xcodeproj/default.pbxuser \ $(DISTDIR)/macosx/Tcl.xcodeproj - $(INSTALL_DATA_DIR) $(DISTDIR)/unix/dltest - $(DIST_INSTALL_DATA) $(UNIX_DIR)/dltest/*.c $(UNIX_DIR)/dltest/Makefile.in \ + @mkdir $(DISTDIR)/unix/dltest + cp -p $(UNIX_DIR)/dltest/*.c $(UNIX_DIR)/dltest/Makefile.in \ $(UNIX_DIR)/dltest/README $(DISTDIR)/unix/dltest - $(INSTALL_DATA_DIR) $(DISTDIR)/tools - $(DIST_INSTALL_DATA) $(TOOL_DIR)/Makefile.in $(TOOL_DIR)/README \ - $(TOOL_DIR)/configure $(TOOL_DIR)/configure.ac \ + @mkdir $(DISTDIR)/tools + cp -p $(TOOL_DIR)/Makefile.in $(TOOL_DIR)/README \ + $(TOOL_DIR)/configure $(TOOL_DIR)/configure.in \ $(TOOL_DIR)/*.tcl $(TOOL_DIR)/man2tcl.c \ $(TOOL_DIR)/*.bmp $(TOOL_DIR)/tcl.hpj.in \ $(DISTDIR)/tools - chmod 755 $(DISTDIR)/tools/checkLibraryDoc.tcl \ - $(DISTDIR)/tools/configure $(DISTDIR)/tools/findBadExternals.tcl \ - $(DISTDIR)/tools/fix_tommath_h.tcl $(DISTDIR)/tools/loadICU.tcl \ - $(DISTDIR)/tools/makeTestCases.tcl $(DISTDIR)/tools/tclZIC.tcl \ - $(DISTDIR)/tools/tcltk-man2html.tcl - $(INSTALL_DATA_DIR) $(DISTDIR)/libtommath - $(DIST_INSTALL_DATA) $(TOMMATH_SRCS) $(TOMMATH_DIR)/*.h $(DISTDIR)/libtommath - $(INSTALL_DATA_DIR) $(DISTDIR)/pkgs - $(DIST_INSTALL_DATA) $(TOP_DIR)/pkgs/README $(DISTDIR)/pkgs - $(DIST_INSTALL_DATA) $(TOP_DIR)/pkgs/package.list.txt $(DISTDIR)/pkgs - for i in `ls $(DISTROOT)/pkgs/*.tar.gz 2> /dev/null` ; do \ + @mkdir $(DISTDIR)/libtommath + cp -p $(TOMMATH_SRCS) $(TOMMATH_DIR)/*.h $(DISTDIR)/libtommath + @mkdir $(DISTDIR)/pkgs + cp $(TOP_DIR)/pkgs/README $(DISTDIR)/pkgs + cp $(TOP_DIR)/pkgs/package.list.txt $(DISTDIR)/pkgs + for i in `ls $(DISTROOT)/pkgs/*.tar.gz 2> /dev/null`; do \ tar -C $(DISTDIR)/pkgs -xzf "$$i"; \ done alldist: dist rm -f $(DISTROOT)/$(DISTNAME)-src.tar.gz $(DISTROOT)/$(ZIPNAME) - ( cd $(DISTROOT); \ - tar cf $(DISTNAME)-src.tar $(DISTNAME); \ - gzip -9 $(DISTNAME)-src.tar; \ - zip -qr8 $(ZIPNAME) $(DISTNAME) ) + cd $(DISTROOT); tar cf $(DISTNAME)-src.tar $(DISTNAME); \ + gzip -9 $(DISTNAME)-src.tar; zip -qr8 $(ZIPNAME) $(DISTNAME) #-------------------------------------------------------------------------- # This target creates the HTML folder for Tcl & Tk and places it in # DISTDIR/html. It uses the tcltk-man2html.tcl tool from the Tcl group's tool -# workspace. It depends on the Tcl & Tk being in directories called tcl9.* & +# workspace. It depends on the Tcl & Tk being in directories called tcl8.* & # tk8.* up two directories from the TOOL_DIR. # # Note that for platforms where this is important, it is more common to use a # build of this HTML documentation that has already been placed online. As # such, this rule is not guaranteed to work well on all systems; it only needs @@ -2288,14 +2183,17 @@ html-tk: ${NATIVE_TCLSH} $(BUILD_HTML) --tk @EXTRA_BUILD_HTML@ +# You'd better have these programs or you will have problems creating Makefile +# from Makefile.in in the first place... +HTML_VERSION = `basename $(TOP_DIR) | sed s/tcl//` BUILD_HTML = \ @${NATIVE_TCLSH} $(TOOL_DIR)/tcltk-man2html.tcl \ - --tcl --useversion=$(MAJOR_VERSION).$(MINOR_VERSION) --htmldir="$(HTML_INSTALL_DIR)" \ - --srcdir=$(TOP_DIR) $(BUILD_HTML_FLAGS) + --useversion=$(HTML_VERSION) --htmldir="$(HTML_INSTALL_DIR)" \ + --srcdir=$(TOP_DIR)/.. $(BUILD_HTML_FLAGS) #-------------------------------------------------------------------------- # The list of all the targets that do not correspond to real files. This stops # 'make' from getting confused when someone makes an error in a rule. #-------------------------------------------------------------------------- @@ -2308,9 +2206,8 @@ .PHONY: tclLibObjs tcltest-real test-tcl gdb-test ro-test trace-test xttest .PHONY: topDirName gendate gentommath_h trace-shell checkdoc .PHONY: install-tzdata install-msgs .PHONY: packages configure-packages test-packages clean-packages .PHONY: dist-packages distclean-packages install-packages -.PHONY: install-libraries-zipfs-shared install-libraries-zipfs-static tclzipfile #-------------------------------------------------------------------------- # DO NOT DELETE THIS LINE -- make depend depends on it. Index: unix/README ================================================================== --- unix/README +++ unix/README @@ -43,10 +43,12 @@ configure script allows you to customize the Tcl configuration for your site; for details on how you can do this, type "./configure --help" or refer to the autoconf documentation (not included here). Tcl's "configure" supports the following special switches in addition to the standard ones: + --enable-threads If this switch is set, Tcl will compile itself + with multithreading support. --disable-load If this switch is specified then Tcl will configure itself not to allow dynamic loading, even if your system appears to support it. Normally you can leave this switch out and Tcl will build itself for dynamic loading if your @@ -161,7 +163,7 @@ file in the "tests" directory for more information on the test suite. Note: don't run the tests as superuser: this will cause several of them to fail. If a test is failing consistently, please send us a bug report with as much detail as you can manage to our tracker: - http://core.tcl.tk/tcl/reportlist + https://core.tcl-lang.org/tcl/reportlist Index: unix/configure ================================================================== --- unix/configure +++ unix/configure @@ -1,804 +1,321 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.69 for tcl 9.0. +# Generated by GNU Autoconf 2.59 for tcl 8.6. # -# -# Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. -# -# +# Copyright (C) 2003 Free Software Foundation, Inc. # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. -## -------------------- ## -## M4sh Initialization. ## -## -------------------- ## +## --------------------- ## +## M4sh Initialization. ## +## --------------------- ## -# Be more Bourne compatible -DUALCASE=1; export DUALCASE # for MKS sh -if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : +# Be Bourne compatible +if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then emulate sh NULLCMD=: - # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which + # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' - setopt NO_GLOB_SUBST -else - case `(set -o) 2>/dev/null` in #( - *posix*) : - set -o posix ;; #( - *) : - ;; -esac -fi - - -as_nl=' -' -export as_nl -# Printing a long string crashes Solaris 7 /usr/bin/printf. -as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' -as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo -as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo -# Prefer a ksh shell builtin over an external printf program on Solaris, -# but without wasting forks for bash or zsh. -if test -z "$BASH_VERSION$ZSH_VERSION" \ - && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then - as_echo='print -r --' - as_echo_n='print -rn --' -elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then - as_echo='printf %s\n' - as_echo_n='printf %s' -else - if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then - as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' - as_echo_n='/usr/ucb/echo -n' - else - as_echo_body='eval expr "X$1" : "X\\(.*\\)"' - as_echo_n_body='eval - arg=$1; - case $arg in #( - *"$as_nl"*) - expr "X$arg" : "X\\(.*\\)$as_nl"; - arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; - esac; - expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" - ' - export as_echo_n_body - as_echo_n='sh -c $as_echo_n_body as_echo' - fi - export as_echo_body - as_echo='sh -c $as_echo_body as_echo' -fi - -# The user is always right. -if test "${PATH_SEPARATOR+set}" != set; then - PATH_SEPARATOR=: - (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { - (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || - PATH_SEPARATOR=';' - } -fi - - -# IFS -# We need space, tab and new line, in precisely that order. Quoting is -# there to prevent editors from complaining about space-tab. -# (If _AS_PATH_WALK were called with IFS unset, it would disable word -# splitting by setting IFS to empty value.) -IFS=" "" $as_nl" - -# Find who we are. Look in the path if we contain no directory separator. -as_myself= -case $0 in #(( - *[\\/]* ) as_myself=$0 ;; - *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break - done -IFS=$as_save_IFS - - ;; -esac -# We did not find ourselves, most probably we were run as `sh COMMAND' -# in which case we are not to be found in the path. -if test "x$as_myself" = x; then - as_myself=$0 -fi -if test ! -f "$as_myself"; then - $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 - exit 1 -fi - -# Unset variables that we do not need and which cause bugs (e.g. in -# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" -# suppresses any "Segmentation fault" message there. '((' could -# trigger a bug in pdksh 5.2.14. -for as_var in BASH_ENV ENV MAIL MAILPATH -do eval test x\${$as_var+set} = xset \ - && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : -done +elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then + set -o posix +fi +DUALCASE=1; export DUALCASE # for MKS sh + +# Support unset when possible. +if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then + as_unset=unset +else + as_unset=false +fi + + +# Work around bugs in pre-3.0 UWIN ksh. +$as_unset ENV MAIL MAILPATH PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. -LC_ALL=C -export LC_ALL -LANGUAGE=C -export LANGUAGE - -# CDPATH. -(unset CDPATH) >/dev/null 2>&1 && unset CDPATH - -# Use a proper internal environment variable to ensure we don't fall - # into an infinite loop, continuously re-executing ourselves. - if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then - _as_can_reexec=no; export _as_can_reexec; - # We cannot yet assume a decent shell, so we have to provide a -# neutralization value for shells without unset; and this also -# works around shells that cannot unset nonexistent variables. -# Preserve -v and -x to the replacement shell. -BASH_ENV=/dev/null -ENV=/dev/null -(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV -case $- in # (((( - *v*x* | *x*v* ) as_opts=-vx ;; - *v* ) as_opts=-v ;; - *x* ) as_opts=-x ;; - * ) as_opts= ;; -esac -exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} -# Admittedly, this is quite paranoid, since all the known shells bail -# out after a failed `exec'. -$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 -as_fn_exit 255 - fi - # We don't want this to propagate to other subprocesses. - { _as_can_reexec=; unset _as_can_reexec;} -if test "x$CONFIG_SHELL" = x; then - as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then : - emulate sh - NULLCMD=: - # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which - # is contrary to our usage. Disable this feature. - alias -g '\${1+\"\$@\"}'='\"\$@\"' - setopt NO_GLOB_SUBST -else - case \`(set -o) 2>/dev/null\` in #( - *posix*) : - set -o posix ;; #( - *) : - ;; -esac -fi -" - as_required="as_fn_return () { (exit \$1); } -as_fn_success () { as_fn_return 0; } -as_fn_failure () { as_fn_return 1; } -as_fn_ret_success () { return 0; } -as_fn_ret_failure () { return 1; } - -exitcode=0 -as_fn_success || { exitcode=1; echo as_fn_success failed.; } -as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } -as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } -as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } -if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then : - -else - exitcode=1; echo positional parameters were not saved. -fi -test x\$exitcode = x0 || exit 1 -test -x / || exit 1" - as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO - as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO - eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && - test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1 -test \$(( 1 + 1 )) = 2 || exit 1" - if (eval "$as_required") 2>/dev/null; then : - as_have_required=yes -else - as_have_required=no -fi - if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then : - -else - as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -as_found=false -for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - as_found=: - case $as_dir in #( - /*) - for as_base in sh bash ksh sh5; do - # Try only shells that exist, to save several forks. - as_shell=$as_dir/$as_base - if { test -f "$as_shell" || test -f "$as_shell.exe"; } && - { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then : - CONFIG_SHELL=$as_shell as_have_required=yes - if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then : - break 2 -fi -fi - done;; - esac - as_found=false -done -$as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } && - { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then : - CONFIG_SHELL=$SHELL as_have_required=yes -fi; } -IFS=$as_save_IFS - - - if test "x$CONFIG_SHELL" != x; then : - export CONFIG_SHELL - # We cannot yet assume a decent shell, so we have to provide a -# neutralization value for shells without unset; and this also -# works around shells that cannot unset nonexistent variables. -# Preserve -v and -x to the replacement shell. -BASH_ENV=/dev/null -ENV=/dev/null -(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV -case $- in # (((( - *v*x* | *x*v* ) as_opts=-vx ;; - *v* ) as_opts=-v ;; - *x* ) as_opts=-x ;; - * ) as_opts= ;; -esac -exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} -# Admittedly, this is quite paranoid, since all the known shells bail -# out after a failed `exec'. -$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 -exit 255 -fi - - if test x$as_have_required = xno; then : - $as_echo "$0: This script requires a shell more modern than all" - $as_echo "$0: the shells that I found on your system." - if test x${ZSH_VERSION+set} = xset ; then - $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should" - $as_echo "$0: be upgraded to zsh 4.3.4 or later." - else - $as_echo "$0: Please tell bug-autoconf@gnu.org about your system, -$0: including any error possibly output before this -$0: message. Then install a modern shell, or manually run -$0: the script under such a shell if you do have one." - fi - exit 1 -fi -fi -fi -SHELL=${CONFIG_SHELL-/bin/sh} -export SHELL -# Unset more variables known to interfere with behavior of common tools. -CLICOLOR_FORCE= GREP_OPTIONS= -unset CLICOLOR_FORCE GREP_OPTIONS - -## --------------------- ## -## M4sh Shell Functions. ## -## --------------------- ## -# as_fn_unset VAR -# --------------- -# Portably unset VAR. -as_fn_unset () -{ - { eval $1=; unset $1;} -} -as_unset=as_fn_unset - -# as_fn_set_status STATUS -# ----------------------- -# Set $? to STATUS, without forking. -as_fn_set_status () -{ - return $1 -} # as_fn_set_status - -# as_fn_exit STATUS -# ----------------- -# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. -as_fn_exit () -{ - set +e - as_fn_set_status $1 - exit $1 -} # as_fn_exit - -# as_fn_mkdir_p -# ------------- -# Create "$as_dir" as a directory, including parents if necessary. -as_fn_mkdir_p () -{ - - case $as_dir in #( - -*) as_dir=./$as_dir;; - esac - test -d "$as_dir" || eval $as_mkdir_p || { - as_dirs= - while :; do - case $as_dir in #( - *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( - *) as_qdir=$as_dir;; - esac - as_dirs="'$as_qdir' $as_dirs" - as_dir=`$as_dirname -- "$as_dir" || -$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$as_dir" : 'X\(//\)[^/]' \| \ - X"$as_dir" : 'X\(//\)$' \| \ - X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X"$as_dir" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - test -d "$as_dir" && break - done - test -z "$as_dirs" || eval "mkdir $as_dirs" - } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" - - -} # as_fn_mkdir_p - -# as_fn_executable_p FILE -# ----------------------- -# Test if FILE is an executable regular file. -as_fn_executable_p () -{ - test -f "$1" && test -x "$1" -} # as_fn_executable_p -# as_fn_append VAR VALUE -# ---------------------- -# Append the text in VALUE to the end of the definition contained in VAR. Take -# advantage of any shell optimizations that allow amortized linear growth over -# repeated appends, instead of the typical quadratic growth present in naive -# implementations. -if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : - eval 'as_fn_append () - { - eval $1+=\$2 - }' -else - as_fn_append () - { - eval $1=\$$1\$2 - } -fi # as_fn_append - -# as_fn_arith ARG... -# ------------------ -# Perform arithmetic evaluation on the ARGs, and store the result in the -# global $as_val. Take advantage of shells that can avoid forks. The arguments -# must be portable across $(()) and expr. -if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : - eval 'as_fn_arith () - { - as_val=$(( $* )) - }' -else - as_fn_arith () - { - as_val=`expr "$@" || test $? -eq 1` - } -fi # as_fn_arith - - -# as_fn_error STATUS ERROR [LINENO LOG_FD] -# ---------------------------------------- -# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are -# provided, also output the error to LOG_FD, referencing LINENO. Then exit the -# script with STATUS, using 1 if that was 0. -as_fn_error () -{ - as_status=$1; test $as_status -eq 0 && as_status=1 - if test "$4"; then - as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 - fi - $as_echo "$as_me: error: $2" >&2 - as_fn_exit $as_status -} # as_fn_error - -if expr a : '\(a\)' >/dev/null 2>&1 && - test "X`expr 00001 : '.*\(...\)'`" = X001; then +for as_var in \ + LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \ + LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \ + LC_TELEPHONE LC_TIME +do + if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then + eval $as_var=C; export $as_var + else + $as_unset $as_var + fi +done + +# Required to use basename. +if expr a : '\(a\)' >/dev/null 2>&1; then as_expr=expr else as_expr=false fi -if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then +if (basename /) >/dev/null 2>&1 && test "X`basename / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi -if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then - as_dirname=dirname -else - as_dirname=false -fi -as_me=`$as_basename -- "$0" || +# Name of the executable. +as_me=`$as_basename "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ - X"$0" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X/"$0" | - sed '/^.*\/\([^/][^/]*\)\/*$/{ - s//\1/ - q - } - /^X\/\(\/\/\)$/{ - s//\1/ - q - } - /^X\/\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - + X"$0" : 'X\(/\)$' \| \ + . : '\(.\)' 2>/dev/null || +echo X/"$0" | + sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/; q; } + /^X\/\(\/\/\)$/{ s//\1/; q; } + /^X\/\(\/\).*/{ s//\1/; q; } + s/.*/./; q'` + + +# PATH needs CR, and LINENO needs CR and PATH. # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits - - as_lineno_1=$LINENO as_lineno_1a=$LINENO - as_lineno_2=$LINENO as_lineno_2a=$LINENO - eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && - test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { - # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) - sed -n ' - p - /[$]LINENO/= - ' <$as_myself | - sed ' - s/[$]LINENO.*/&-/ - t lineno - b - :lineno - N - :loop - s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ - t loop - s/-\n.*// - ' >$as_me.lineno && - chmod +x "$as_me.lineno" || - { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } - - # If we had to re-execute with $CONFIG_SHELL, we're ensured to have - # already done that, so ensure we don't try to do so again and fall - # in an infinite loop. This has already happened in practice. - _as_can_reexec=no; export _as_can_reexec +# The user is always right. +if test "${PATH_SEPARATOR+set}" != set; then + echo "#! /bin/sh" >conf$$.sh + echo "exit 0" >>conf$$.sh + chmod +x conf$$.sh + if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then + PATH_SEPARATOR=';' + else + PATH_SEPARATOR=: + fi + rm -f conf$$.sh +fi + + + as_lineno_1=$LINENO + as_lineno_2=$LINENO + as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` + test "x$as_lineno_1" != "x$as_lineno_2" && + test "x$as_lineno_3" = "x$as_lineno_2" || { + # Find who we are. Look in the path if we contain no path at all + # relative or not. + case $0 in + *[\\/]* ) as_myself=$0 ;; + *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break +done + + ;; + esac + # We did not find ourselves, most probably we were run as `sh COMMAND' + # in which case we are not to be found in the path. + if test "x$as_myself" = x; then + as_myself=$0 + fi + if test ! -f "$as_myself"; then + { echo "$as_me: error: cannot find myself; rerun with an absolute path" >&2 + { (exit 1); exit 1; }; } + fi + case $CONFIG_SHELL in + '') + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for as_base in sh bash ksh sh5; do + case $as_dir in + /*) + if ("$as_dir/$as_base" -c ' + as_lineno_1=$LINENO + as_lineno_2=$LINENO + as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` + test "x$as_lineno_1" != "x$as_lineno_2" && + test "x$as_lineno_3" = "x$as_lineno_2" ') 2>/dev/null; then + $as_unset BASH_ENV || test "${BASH_ENV+set}" != set || { BASH_ENV=; export BASH_ENV; } + $as_unset ENV || test "${ENV+set}" != set || { ENV=; export ENV; } + CONFIG_SHELL=$as_dir/$as_base + export CONFIG_SHELL + exec "$CONFIG_SHELL" "$0" ${1+"$@"} + fi;; + esac + done +done +;; + esac + + # Create $as_me.lineno as a copy of $as_myself, but with $LINENO + # uniformly replaced by the line number. The first 'sed' inserts a + # line-number line before each line; the second 'sed' does the real + # work. The second script uses 'N' to pair each line-number line + # with the numbered line, and appends trailing '-' during + # substitution so that $LINENO is not a special case at line end. + # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the + # second 'sed' script. Blame Lee E. McMahon for sed's syntax. :-) + sed '=' <$as_myself | + sed ' + N + s,$,-, + : loop + s,^\(['$as_cr_digits']*\)\(.*\)[$]LINENO\([^'$as_cr_alnum'_]\),\1\2\1\3, + t loop + s,-$,, + s,^['$as_cr_digits']*\n,, + ' >$as_me.lineno && + chmod +x $as_me.lineno || + { echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2 + { (exit 1); exit 1; }; } + # Don't try to exec as it changes $[0], causing all sort of problems # (the dirname of $[0] is not the place where we might find the - # original and so on. Autoconf is especially sensitive to this). - . "./$as_me.lineno" + # original and so on. Autoconf is especially sensible to this). + . ./$as_me.lineno # Exit status is that of the last command. exit } -ECHO_C= ECHO_N= ECHO_T= -case `echo -n x` in #((((( --n*) - case `echo 'xy\c'` in - *c*) ECHO_T=' ';; # ECHO_T is single tab character. - xy) ECHO_C='\c';; - *) echo `echo ksh88 bug on AIX 6.1` > /dev/null - ECHO_T=' ';; - esac;; -*) - ECHO_N='-n';; + +case `echo "testing\c"; echo 1,2,3`,`echo -n testing; echo 1,2,3` in + *c*,-n*) ECHO_N= ECHO_C=' +' ECHO_T=' ' ;; + *c*,* ) ECHO_N=-n ECHO_C= ECHO_T= ;; + *) ECHO_N= ECHO_C='\c' ECHO_T= ;; esac + +if expr a : '\(a\)' >/dev/null 2>&1; then + as_expr=expr +else + as_expr=false +fi rm -f conf$$ conf$$.exe conf$$.file -if test -d conf$$.dir; then - rm -f conf$$.dir/conf$$.file -else - rm -f conf$$.dir - mkdir conf$$.dir 2>/dev/null -fi -if (echo >conf$$.file) 2>/dev/null; then - if ln -s conf$$.file conf$$ 2>/dev/null; then +echo >conf$$.file +if ln -s conf$$.file conf$$ 2>/dev/null; then + # We could just check for DJGPP; but this test a) works b) is more generic + # and c) will remain valid once DJGPP supports symlinks (DJGPP 2.04). + if test -f conf$$.exe; then + # Don't use ln at all; we don't have any links + as_ln_s='cp -p' + else as_ln_s='ln -s' - # ... but there are two gotchas: - # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. - # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. - # In both cases, we have to default to `cp -pR'. - ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || - as_ln_s='cp -pR' - elif ln conf$$.file conf$$ 2>/dev/null; then - as_ln_s=ln - else - as_ln_s='cp -pR' - fi -else - as_ln_s='cp -pR' -fi -rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file -rmdir conf$$.dir 2>/dev/null + fi +elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln +else + as_ln_s='cp -p' +fi +rm -f conf$$ conf$$.exe conf$$.file if mkdir -p . 2>/dev/null; then - as_mkdir_p='mkdir -p "$as_dir"' + as_mkdir_p=: else test -d ./-p && rmdir ./-p as_mkdir_p=false fi -as_test_x='test -x' -as_executable_p=as_fn_executable_p +as_executable_p="test -f" # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" -test -n "$DJDIR" || exec 7<&0 &1 +# IFS +# We need space, tab and new line, in precisely that order. +as_nl=' +' +IFS=" $as_nl" + +# CDPATH. +$as_unset CDPATH + # Name of the host. -# hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, +# hostname on some systems (SVR3.2, Linux) returns a bogus exit status, # so uname gets run too. ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` + +exec 6>&1 # # Initializations. # ac_default_prefix=/usr/local -ac_clean_files= ac_config_libobj_dir=. -LIBOBJS= cross_compiling=no subdirs= MFLAGS= MAKEFLAGS= +SHELL=${CONFIG_SHELL-/bin/sh} + +# Maximum number of lines to put in a shell here document. +# This variable seems obsolete. It should probably be removed, and +# only ac_max_sed_lines should be used. +: ${ac_max_here_lines=38} # Identity of this package. PACKAGE_NAME='tcl' PACKAGE_TARNAME='tcl' -PACKAGE_VERSION='9.0' -PACKAGE_STRING='tcl 9.0' +PACKAGE_VERSION='8.6' +PACKAGE_STRING='tcl 8.6' PACKAGE_BUGREPORT='' -PACKAGE_URL='' # Factoring default headers for most tests. ac_includes_default="\ #include -#ifdef HAVE_SYS_TYPES_H +#if HAVE_SYS_TYPES_H # include #endif -#ifdef HAVE_SYS_STAT_H +#if HAVE_SYS_STAT_H # include #endif -#ifdef STDC_HEADERS +#if STDC_HEADERS # include # include #else -# ifdef HAVE_STDLIB_H +# if HAVE_STDLIB_H # include # endif #endif -#ifdef HAVE_STRING_H -# if !defined STDC_HEADERS && defined HAVE_MEMORY_H +#if HAVE_STRING_H +# if !STDC_HEADERS && HAVE_MEMORY_H # include # endif # include #endif -#ifdef HAVE_STRINGS_H +#if HAVE_STRINGS_H # include #endif -#ifdef HAVE_INTTYPES_H +#if HAVE_INTTYPES_H # include +#else +# if HAVE_STDINT_H +# include +# endif #endif -#ifdef HAVE_STDINT_H -# include -#endif -#ifdef HAVE_UNISTD_H +#if HAVE_UNISTD_H # include #endif" -ac_subst_vars='DLTEST_SUFFIX -DLTEST_LD -EXTRA_TCLSH_LIBS -EXTRA_BUILD_HTML -EXTRA_INSTALL_BINARIES -EXTRA_INSTALL -EXTRA_APP_CC_SWITCHES -EXTRA_CC_SWITCHES -PACKAGE_DIR -HTML_DIR -PRIVATE_INCLUDE_DIR -TCL_LIBRARY -TCL_MODULE_PATH -TCL_PACKAGE_PATH -BUILD_DLTEST -MAKEFILE_SHELL -DTRACE_OBJ -DTRACE_HDR -DTRACE_SRC -INSTALL_TZDATA -TCL_HAS_LONGLONG -TCL_UNSHARED_LIB_SUFFIX -TCL_SHARED_LIB_SUFFIX -TCL_LIB_VERSIONS_OK -TCL_BUILD_LIB_SPEC -LD_LIBRARY_PATH_VAR -TCL_SHARED_BUILD -CFG_TCL_UNSHARED_LIB_SUFFIX -CFG_TCL_SHARED_LIB_SUFFIX -TCL_SRC_DIR -TCL_BUILD_STUB_LIB_PATH -TCL_BUILD_STUB_LIB_SPEC -TCL_INCLUDE_SPEC -TCL_STUB_LIB_PATH -TCL_STUB_LIB_SPEC -TCL_STUB_LIB_FLAG -TCL_STUB_LIB_FILE -TCL_LIB_SPEC -TCL_LIB_FLAG -TCL_LIB_FILE -PKG_CFG_ARGS -TCL_YEAR -TCL_PATCH_LEVEL -TCL_MINOR_VERSION -TCL_MAJOR_VERSION -TCL_VERSION -INSTALL_MSGS -INSTALL_LIBRARIES -TCL_ZIP_FILE -ZIPFS_BUILD -ZIP_INSTALL_OBJS -ZIP_PROG_VFSSEARCH -ZIP_PROG_OPTIONS -ZIP_PROG -EXEEXT_FOR_BUILD -CC_FOR_BUILD -DTRACE -LDFLAGS_DEFAULT -CFLAGS_DEFAULT -INSTALL_STUB_LIB -DLL_INSTALL_DIR -INSTALL_LIB -MAKE_STUB_LIB -MAKE_LIB -SHLIB_SUFFIX -SHLIB_CFLAGS -SHLIB_LD_LIBS -TK_SHLIB_LD_EXTRAS -TCL_SHLIB_LD_EXTRAS -SHLIB_LD -STLIB_LD -LD_SEARCH_FLAGS -CC_SEARCH_FLAGS -LDFLAGS_OPTIMIZE -LDFLAGS_DEBUG -CFLAGS_WARNING -CFLAGS_OPTIMIZE -CFLAGS_DEBUG -LDAIX_SRC -PLAT_SRCS -PLAT_OBJS -DL_OBJS -DL_LIBS -TCL_LIBS -LIBOBJS -AR -RANLIB -ZLIB_INCLUDE -ZLIB_SRCS -ZLIB_OBJS -TCLSH_PROG -SHARED_BUILD -EGREP -GREP -CPP -OBJEXT -EXEEXT -ac_ct_CC -CPPFLAGS -LDFLAGS -CFLAGS -CC -MAN_FLAGS -target_alias -host_alias -build_alias -LIBS -ECHO_T -ECHO_N -ECHO_C -DEFS -mandir -localedir -libdir -psdir -pdfdir -dvidir -htmldir -infodir -docdir -oldincludedir -includedir -localstatedir -sharedstatedir -sysconfdir -datadir -datarootdir -libexecdir -sbindir -bindir -program_transform_name -prefix -exec_prefix -PACKAGE_URL -PACKAGE_BUGREPORT -PACKAGE_STRING -PACKAGE_VERSION -PACKAGE_TARNAME -PACKAGE_NAME -PATH_SEPARATOR -SHELL -OBJEXT_FOR_BUILD' +ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS MAN_FLAGS CC CFLAGS LDFLAGS CPPFLAGS ac_ct_CC EXEEXT OBJEXT CPP EGREP TCL_THREADS TCLSH_PROG ZLIB_OBJS ZLIB_SRCS ZLIB_INCLUDE RANLIB ac_ct_RANLIB AR ac_ct_AR LIBOBJS TCL_LIBS DL_LIBS DL_OBJS PLAT_OBJS PLAT_SRCS LDAIX_SRC CFLAGS_DEBUG CFLAGS_OPTIMIZE CFLAGS_WARNING LDFLAGS_DEBUG LDFLAGS_OPTIMIZE CC_SEARCH_FLAGS LD_SEARCH_FLAGS STLIB_LD SHLIB_LD TCL_SHLIB_LD_EXTRAS TK_SHLIB_LD_EXTRAS SHLIB_LD_LIBS SHLIB_CFLAGS SHLIB_SUFFIX MAKE_LIB MAKE_STUB_LIB INSTALL_LIB DLL_INSTALL_DIR INSTALL_STUB_LIB CFLAGS_DEFAULT LDFLAGS_DEFAULT DTRACE TCL_VERSION TCL_MAJOR_VERSION TCL_MINOR_VERSION TCL_PATCH_LEVEL TCL_YEAR PKG_CFG_ARGS TCL_LIB_FILE TCL_LIB_FLAG TCL_LIB_SPEC TCL_STUB_LIB_FILE TCL_STUB_LIB_FLAG TCL_STUB_LIB_SPEC TCL_STUB_LIB_PATH TCL_INCLUDE_SPEC TCL_BUILD_STUB_LIB_SPEC TCL_BUILD_STUB_LIB_PATH TCL_SRC_DIR CFG_TCL_SHARED_LIB_SUFFIX CFG_TCL_UNSHARED_LIB_SUFFIX TCL_SHARED_BUILD LD_LIBRARY_PATH_VAR TCL_BUILD_LIB_SPEC TCL_LIB_VERSIONS_OK TCL_SHARED_LIB_SUFFIX TCL_UNSHARED_LIB_SUFFIX TCL_HAS_LONGLONG INSTALL_TZDATA DTRACE_SRC DTRACE_HDR DTRACE_OBJ MAKEFILE_SHELL BUILD_DLTEST TCL_PACKAGE_PATH TCL_MODULE_PATH TCL_LIBRARY PRIVATE_INCLUDE_DIR HTML_DIR PACKAGE_DIR EXTRA_CC_SWITCHES EXTRA_APP_CC_SWITCHES EXTRA_INSTALL EXTRA_INSTALL_BINARIES EXTRA_BUILD_HTML EXTRA_TCLSH_LIBS DLTEST_LD DLTEST_SUFFIX' ac_subst_files='' -ac_user_opts=' -enable_option_checking -enable_man_symlinks -enable_man_compression -enable_man_suffix -with_encoding -enable_shared -enable_64bit -enable_64bit_vis -enable_rpath -enable_corefoundation -enable_load -enable_symbols -enable_langinfo -enable_dll_unloading -with_tzdata -enable_dtrace -enable_zipfs -enable_framework -' - ac_precious_vars='build_alias -host_alias -target_alias -CC -CFLAGS -LDFLAGS -LIBS -CPPFLAGS -CPP' - # Initialize some variables set by options. ac_init_help= ac_init_version=false -ac_unrecognized_opts= -ac_unrecognized_sep= # The variables have the same names as the options, with # dashes changed to underlines. cache_file=/dev/null exec_prefix=NONE no_create= @@ -817,53 +334,38 @@ # Installation directory options. # These are left unexpanded so users can "make install exec_prefix=/foo" # and all the variables that are supposed to be based on exec_prefix # by default will actually change. # Use braces instead of parens because sh, perl, etc. also accept them. -# (The list follows the same order as the GNU Coding Standards.) bindir='${exec_prefix}/bin' sbindir='${exec_prefix}/sbin' libexecdir='${exec_prefix}/libexec' -datarootdir='${prefix}/share' -datadir='${datarootdir}' +datadir='${prefix}/share' sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var' +libdir='${exec_prefix}/lib' includedir='${prefix}/include' oldincludedir='/usr/include' -docdir='${datarootdir}/doc/${PACKAGE_TARNAME}' -infodir='${datarootdir}/info' -htmldir='${docdir}' -dvidir='${docdir}' -pdfdir='${docdir}' -psdir='${docdir}' -libdir='${exec_prefix}/lib' -localedir='${datarootdir}/locale' -mandir='${datarootdir}/man' +infodir='${prefix}/info' +mandir='${prefix}/man' ac_prev= -ac_dashdash= for ac_option do # If the previous option needs an argument, assign it. if test -n "$ac_prev"; then - eval $ac_prev=\$ac_option + eval "$ac_prev=\$ac_option" ac_prev= continue fi - case $ac_option in - *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; - *=) ac_optarg= ;; - *) ac_optarg=yes ;; - esac + ac_optarg=`expr "x$ac_option" : 'x[^=]*=\(.*\)'` # Accept the important Cygnus configure options, so we can diagnose typos. - case $ac_dashdash$ac_option in - --) - ac_dashdash=yes ;; + case $ac_option in -bindir | --bindir | --bindi | --bind | --bin | --bi) ac_prev=bindir ;; -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) bindir=$ac_optarg ;; @@ -881,63 +383,37 @@ cache_file=$ac_optarg ;; --config-cache | -C) cache_file=config.cache ;; - -datadir | --datadir | --datadi | --datad) + -datadir | --datadir | --datadi | --datad | --data | --dat | --da) ac_prev=datadir ;; - -datadir=* | --datadir=* | --datadi=* | --datad=*) + -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \ + | --da=*) datadir=$ac_optarg ;; - -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ - | --dataroo | --dataro | --datar) - ac_prev=datarootdir ;; - -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ - | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) - datarootdir=$ac_optarg ;; - -disable-* | --disable-*) - ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` + ac_feature=`expr "x$ac_option" : 'x-*disable-\(.*\)'` # Reject names that are not valid shell variable names. - expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid feature name: $ac_useropt" - ac_useropt_orig=$ac_useropt - ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` - case $ac_user_opts in - *" -"enable_$ac_useropt" -"*) ;; - *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" - ac_unrecognized_sep=', ';; - esac - eval enable_$ac_useropt=no ;; - - -docdir | --docdir | --docdi | --doc | --do) - ac_prev=docdir ;; - -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) - docdir=$ac_optarg ;; - - -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) - ac_prev=dvidir ;; - -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) - dvidir=$ac_optarg ;; + expr "x$ac_feature" : ".*[^-_$as_cr_alnum]" >/dev/null && + { echo "$as_me: error: invalid feature name: $ac_feature" >&2 + { (exit 1); exit 1; }; } + ac_feature=`echo $ac_feature | sed 's/-/_/g'` + eval "enable_$ac_feature=no" ;; -enable-* | --enable-*) - ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` + ac_feature=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` # Reject names that are not valid shell variable names. - expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid feature name: $ac_useropt" - ac_useropt_orig=$ac_useropt - ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` - case $ac_user_opts in - *" -"enable_$ac_useropt" -"*) ;; - *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" - ac_unrecognized_sep=', ';; + expr "x$ac_feature" : ".*[^-_$as_cr_alnum]" >/dev/null && + { echo "$as_me: error: invalid feature name: $ac_feature" >&2 + { (exit 1); exit 1; }; } + ac_feature=`echo $ac_feature | sed 's/-/_/g'` + case $ac_option in + *=*) ac_optarg=`echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"`;; + *) ac_optarg=yes ;; esac - eval enable_$ac_useropt=\$ac_optarg ;; + eval "enable_$ac_feature='$ac_optarg'" ;; -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ | --exec | --exe | --ex) ac_prev=exec_prefix ;; @@ -960,16 +436,10 @@ -host | --host | --hos | --ho) ac_prev=host_alias ;; -host=* | --host=* | --hos=* | --ho=*) host_alias=$ac_optarg ;; - -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) - ac_prev=htmldir ;; - -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ - | --ht=*) - htmldir=$ac_optarg ;; - -includedir | --includedir | --includedi | --included | --include \ | --includ | --inclu | --incl | --inc) ac_prev=includedir ;; -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ | --includ=* | --inclu=* | --incl=* | --inc=*) @@ -990,20 +460,17 @@ ac_prev=libexecdir ;; -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ | --libexe=* | --libex=* | --libe=*) libexecdir=$ac_optarg ;; - -localedir | --localedir | --localedi | --localed | --locale) - ac_prev=localedir ;; - -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) - localedir=$ac_optarg ;; - -localstatedir | --localstatedir | --localstatedi | --localstated \ - | --localstate | --localstat | --localsta | --localst | --locals) + | --localstate | --localstat | --localsta | --localst \ + | --locals | --local | --loca | --loc | --lo) ac_prev=localstatedir ;; -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ - | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) + | --localstate=* | --localstat=* | --localsta=* | --localst=* \ + | --locals=* | --local=* | --loca=* | --loc=* | --lo=*) localstatedir=$ac_optarg ;; -mandir | --mandir | --mandi | --mand | --man | --ma | --m) ac_prev=mandir ;; -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) @@ -1064,20 +531,10 @@ | --program-transfo=* | --program-transf=* \ | --program-trans=* | --program-tran=* \ | --progr-tra=* | --program-tr=* | --program-t=*) program_transform_name=$ac_optarg ;; - -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) - ac_prev=pdfdir ;; - -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) - pdfdir=$ac_optarg ;; - - -psdir | --psdir | --psdi | --psd | --ps) - ac_prev=psdir ;; - -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) - psdir=$ac_optarg ;; - -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) silent=yes ;; -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) @@ -1124,40 +581,30 @@ -version | --version | --versio | --versi | --vers | -V) ac_init_version=: ;; -with-* | --with-*) - ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` + ac_package=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` # Reject names that are not valid shell variable names. - expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid package name: $ac_useropt" - ac_useropt_orig=$ac_useropt - ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` - case $ac_user_opts in - *" -"with_$ac_useropt" -"*) ;; - *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" - ac_unrecognized_sep=', ';; + expr "x$ac_package" : ".*[^-_$as_cr_alnum]" >/dev/null && + { echo "$as_me: error: invalid package name: $ac_package" >&2 + { (exit 1); exit 1; }; } + ac_package=`echo $ac_package| sed 's/-/_/g'` + case $ac_option in + *=*) ac_optarg=`echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"`;; + *) ac_optarg=yes ;; esac - eval with_$ac_useropt=\$ac_optarg ;; + eval "with_$ac_package='$ac_optarg'" ;; -without-* | --without-*) - ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` + ac_package=`expr "x$ac_option" : 'x-*without-\(.*\)'` # Reject names that are not valid shell variable names. - expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid package name: $ac_useropt" - ac_useropt_orig=$ac_useropt - ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` - case $ac_user_opts in - *" -"with_$ac_useropt" -"*) ;; - *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" - ac_unrecognized_sep=', ';; - esac - eval with_$ac_useropt=no ;; + expr "x$ac_package" : ".*[^-_$as_cr_alnum]" >/dev/null && + { echo "$as_me: error: invalid package name: $ac_package" >&2 + { (exit 1); exit 1; }; } + ac_package=`echo $ac_package | sed 's/-/_/g'` + eval "with_$ac_package=no" ;; --x) # Obsolete; use --with-x. with_x=yes ;; @@ -1173,67 +620,63 @@ ac_prev=x_libraries ;; -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) x_libraries=$ac_optarg ;; - -*) as_fn_error $? "unrecognized option: \`$ac_option' -Try \`$0 --help' for more information" + -*) { echo "$as_me: error: unrecognized option: $ac_option +Try \`$0 --help' for more information." >&2 + { (exit 1); exit 1; }; } ;; *=*) ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` # Reject names that are not valid shell variable names. - case $ac_envvar in #( - '' | [0-9]* | *[!_$as_cr_alnum]* ) - as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; - esac - eval $ac_envvar=\$ac_optarg + expr "x$ac_envvar" : ".*[^_$as_cr_alnum]" >/dev/null && + { echo "$as_me: error: invalid variable name: $ac_envvar" >&2 + { (exit 1); exit 1; }; } + ac_optarg=`echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` + eval "$ac_envvar='$ac_optarg'" export $ac_envvar ;; *) # FIXME: should be removed in autoconf 3.0. - $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 + echo "$as_me: WARNING: you should use --build, --host, --target" >&2 expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && - $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 - : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" + echo "$as_me: WARNING: invalid host type: $ac_option" >&2 + : ${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option} ;; esac done if test -n "$ac_prev"; then ac_option=--`echo $ac_prev | sed 's/_/-/g'` - as_fn_error $? "missing argument to $ac_option" -fi - -if test -n "$ac_unrecognized_opts"; then - case $enable_option_checking in - no) ;; - fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; - *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; - esac -fi - -# Check all directory arguments for consistency. -for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ - datadir sysconfdir sharedstatedir localstatedir includedir \ - oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ - libdir localedir mandir -do - eval ac_val=\$$ac_var - # Remove trailing slashes. - case $ac_val in - */ ) - ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` - eval $ac_var=\$ac_val;; - esac - # Be sure to have absolute directory names. - case $ac_val in - [\\/$]* | ?:[\\/]* ) continue;; - NONE | '' ) case $ac_var in *prefix ) continue;; esac;; - esac - as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" + { echo "$as_me: error: missing argument to $ac_option" >&2 + { (exit 1); exit 1; }; } +fi + +# Be sure to have absolute paths. +for ac_var in exec_prefix prefix +do + eval ac_val=$`echo $ac_var` + case $ac_val in + [\\/$]* | ?:[\\/]* | NONE | '' ) ;; + *) { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2 + { (exit 1); exit 1; }; };; + esac +done + +# Be sure to have absolute paths. +for ac_var in bindir sbindir libexecdir datadir sysconfdir sharedstatedir \ + localstatedir libdir includedir oldincludedir infodir mandir +do + eval ac_val=$`echo $ac_var` + case $ac_val in + [\\/$]* | ?:[\\/]* ) ;; + *) { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2 + { (exit 1); exit 1; }; };; + esac done # There might be people who depend on the old broken behavior: `$host' # used to hold the argument of --host etc. # FIXME: To remove some day. @@ -1243,10 +686,12 @@ # FIXME: To remove some day. if test "x$host_alias" != x; then if test "x$build_alias" = x; then cross_compiling=maybe + echo "$as_me: WARNING: If you wanted to set the --build type, don't use --host. + If a cross compiler is detected then cross compile mode will be used." >&2 elif test "x$build_alias" != "x$host_alias"; then cross_compiling=yes fi fi @@ -1253,86 +698,88 @@ ac_tool_prefix= test -n "$host_alias" && ac_tool_prefix=$host_alias- test "$silent" = yes && exec 6>/dev/null - -ac_pwd=`pwd` && test -n "$ac_pwd" && -ac_ls_di=`ls -di .` && -ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || - as_fn_error $? "working directory cannot be determined" -test "X$ac_ls_di" = "X$ac_pwd_ls_di" || - as_fn_error $? "pwd does not report name of working directory" - # Find the source files, if location was not specified. if test -z "$srcdir"; then ac_srcdir_defaulted=yes - # Try the directory containing this script, then the parent directory. - ac_confdir=`$as_dirname -- "$as_myself" || -$as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$as_myself" : 'X\(//\)[^/]' \| \ - X"$as_myself" : 'X\(//\)$' \| \ - X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X"$as_myself" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` + # Try the directory containing this script, then its parent. + ac_confdir=`(dirname "$0") 2>/dev/null || +$as_expr X"$0" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$0" : 'X\(//\)[^/]' \| \ + X"$0" : 'X\(//\)$' \| \ + X"$0" : 'X\(/\)' \| \ + . : '\(.\)' 2>/dev/null || +echo X"$0" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } + /^X\(\/\/\)[^/].*/{ s//\1/; q; } + /^X\(\/\/\)$/{ s//\1/; q; } + /^X\(\/\).*/{ s//\1/; q; } + s/.*/./; q'` srcdir=$ac_confdir - if test ! -r "$srcdir/$ac_unique_file"; then + if test ! -r $srcdir/$ac_unique_file; then srcdir=.. fi else ac_srcdir_defaulted=no fi -if test ! -r "$srcdir/$ac_unique_file"; then - test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." - as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" -fi -ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" -ac_abs_confdir=`( - cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" - pwd)` -# When building in place, set srcdir=. -if test "$ac_abs_confdir" = "$ac_pwd"; then - srcdir=. -fi -# Remove unnecessary trailing slashes from srcdir. -# Double slashes in file names in object file debugging info -# mess up M-x gdb in Emacs. -case $srcdir in -*/) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; -esac -for ac_var in $ac_precious_vars; do - eval ac_env_${ac_var}_set=\${${ac_var}+set} - eval ac_env_${ac_var}_value=\$${ac_var} - eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} - eval ac_cv_env_${ac_var}_value=\$${ac_var} -done +if test ! -r $srcdir/$ac_unique_file; then + if test "$ac_srcdir_defaulted" = yes; then + { echo "$as_me: error: cannot find sources ($ac_unique_file) in $ac_confdir or .." >&2 + { (exit 1); exit 1; }; } + else + { echo "$as_me: error: cannot find sources ($ac_unique_file) in $srcdir" >&2 + { (exit 1); exit 1; }; } + fi +fi +(cd $srcdir && test -r ./$ac_unique_file) 2>/dev/null || + { echo "$as_me: error: sources are in $srcdir, but \`cd $srcdir' does not work" >&2 + { (exit 1); exit 1; }; } +srcdir=`echo "$srcdir" | sed 's%\([^\\/]\)[\\/]*$%\1%'` +ac_env_build_alias_set=${build_alias+set} +ac_env_build_alias_value=$build_alias +ac_cv_env_build_alias_set=${build_alias+set} +ac_cv_env_build_alias_value=$build_alias +ac_env_host_alias_set=${host_alias+set} +ac_env_host_alias_value=$host_alias +ac_cv_env_host_alias_set=${host_alias+set} +ac_cv_env_host_alias_value=$host_alias +ac_env_target_alias_set=${target_alias+set} +ac_env_target_alias_value=$target_alias +ac_cv_env_target_alias_set=${target_alias+set} +ac_cv_env_target_alias_value=$target_alias +ac_env_CC_set=${CC+set} +ac_env_CC_value=$CC +ac_cv_env_CC_set=${CC+set} +ac_cv_env_CC_value=$CC +ac_env_CFLAGS_set=${CFLAGS+set} +ac_env_CFLAGS_value=$CFLAGS +ac_cv_env_CFLAGS_set=${CFLAGS+set} +ac_cv_env_CFLAGS_value=$CFLAGS +ac_env_LDFLAGS_set=${LDFLAGS+set} +ac_env_LDFLAGS_value=$LDFLAGS +ac_cv_env_LDFLAGS_set=${LDFLAGS+set} +ac_cv_env_LDFLAGS_value=$LDFLAGS +ac_env_CPPFLAGS_set=${CPPFLAGS+set} +ac_env_CPPFLAGS_value=$CPPFLAGS +ac_cv_env_CPPFLAGS_set=${CPPFLAGS+set} +ac_cv_env_CPPFLAGS_value=$CPPFLAGS +ac_env_CPP_set=${CPP+set} +ac_env_CPP_value=$CPP +ac_cv_env_CPP_set=${CPP+set} +ac_cv_env_CPP_value=$CPP # # Report the --help message. # if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF -\`configure' configures tcl 9.0 to adapt to many kinds of systems. +\`configure' configures tcl 8.6 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. @@ -1342,72 +789,68 @@ Configuration: -h, --help display this help and exit --help=short display options specific to this package --help=recursive display the short help of all the included packages -V, --version display version information and exit - -q, --quiet, --silent do not print \`checking ...' messages + -q, --quiet, --silent do not print \`checking...' messages --cache-file=FILE cache test results in FILE [disabled] -C, --config-cache alias for \`--cache-file=config.cache' -n, --no-create do not create output files --srcdir=DIR find the sources in DIR [configure dir or \`..'] +_ACEOF + + cat <<_ACEOF Installation directories: --prefix=PREFIX install architecture-independent files in PREFIX - [$ac_default_prefix] + [$ac_default_prefix] --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX - [PREFIX] + [PREFIX] By default, \`make install' will install all the files in \`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify an installation prefix other than \`$ac_default_prefix' using \`--prefix', for instance \`--prefix=\$HOME'. For better control, use the options below. Fine tuning of the installation directories: - --bindir=DIR user executables [EPREFIX/bin] - --sbindir=DIR system admin executables [EPREFIX/sbin] - --libexecdir=DIR program executables [EPREFIX/libexec] - --sysconfdir=DIR read-only single-machine data [PREFIX/etc] - --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] - --localstatedir=DIR modifiable single-machine data [PREFIX/var] - --libdir=DIR object code libraries [EPREFIX/lib] - --includedir=DIR C header files [PREFIX/include] - --oldincludedir=DIR C header files for non-gcc [/usr/include] - --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] - --datadir=DIR read-only architecture-independent data [DATAROOTDIR] - --infodir=DIR info documentation [DATAROOTDIR/info] - --localedir=DIR locale-dependent data [DATAROOTDIR/locale] - --mandir=DIR man documentation [DATAROOTDIR/man] - --docdir=DIR documentation root [DATAROOTDIR/doc/tcl] - --htmldir=DIR html documentation [DOCDIR] - --dvidir=DIR dvi documentation [DOCDIR] - --pdfdir=DIR pdf documentation [DOCDIR] - --psdir=DIR ps documentation [DOCDIR] + --bindir=DIR user executables [EPREFIX/bin] + --sbindir=DIR system admin executables [EPREFIX/sbin] + --libexecdir=DIR program executables [EPREFIX/libexec] + --datadir=DIR read-only architecture-independent data [PREFIX/share] + --sysconfdir=DIR read-only single-machine data [PREFIX/etc] + --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] + --localstatedir=DIR modifiable single-machine data [PREFIX/var] + --libdir=DIR object code libraries [EPREFIX/lib] + --includedir=DIR C header files [PREFIX/include] + --oldincludedir=DIR C header files for non-gcc [/usr/include] + --infodir=DIR info documentation [PREFIX/info] + --mandir=DIR man documentation [PREFIX/man] _ACEOF cat <<\_ACEOF _ACEOF fi if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of tcl 9.0:";; + short | recursive ) echo "Configuration of tcl 8.6:";; esac cat <<\_ACEOF Optional Features: - --disable-option-checking ignore unrecognized --enable/--with options --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) --enable-FEATURE[=ARG] include FEATURE [ARG=yes] --enable-man-symlinks use symlinks for the manpages (default: off) --enable-man-compression=PROG compress the manpages with PROG (default: off) --enable-man-suffix=STRING use STRING as a suffix to manpage file names (default: no, tcl if enabled without specifying STRING) + --enable-threads build with threads (default: on) --enable-shared build and link with shared libraries (default: on) --enable-64bit enable 64bit support (default: off) --enable-64bit-vis enable 64bit Sparc VIS support (default: off) --disable-rpath disable rpath support (default: on) --enable-corefoundation use CoreFoundation API on MacOSX (default: on) @@ -1416,11 +859,10 @@ --enable-symbols build with debugging symbols (default: off) --enable-langinfo use nl_langinfo if possible to determine encoding at startup, otherwise use old heuristic (default: on) --enable-dll-unloading enable the 'unload' command (default: on) --enable-dtrace build with DTrace support (default: off) - --enable-zipfs build with Zipfs support (default: on) --enable-framework package shared libraries in MacOSX frameworks (default: off) Optional Packages: --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] @@ -1432,610 +874,132 @@ Some influential environment variables: CC C compiler command CFLAGS C compiler flags LDFLAGS linker flags, e.g. -L if you have libraries in a nonstandard directory - LIBS libraries to pass to the linker, e.g. -l - CPPFLAGS (Objective) C/C++ preprocessor flags, e.g. -I if - you have headers in a nonstandard directory + CPPFLAGS C/C++ preprocessor flags, e.g. -I if you have + headers in a nonstandard directory CPP C preprocessor Use these variables to override the choices made by `configure' or to help it to find libraries and programs with nonstandard names/locations. -Report bugs to the package provider. _ACEOF -ac_status=$? fi if test "$ac_init_help" = "recursive"; then # If there are subdirs, report their specific --help. + ac_popdir=`pwd` for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue - test -d "$ac_dir" || - { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } || - continue + test -d $ac_dir || continue ac_builddir=. -case "$ac_dir" in -.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; -*) - ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` - # A ".." for each directory in $ac_dir_suffix. - ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` - case $ac_top_builddir_sub in - "") ac_top_builddir_sub=. ac_top_build_prefix= ;; - *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; - esac ;; -esac -ac_abs_top_builddir=$ac_pwd -ac_abs_builddir=$ac_pwd$ac_dir_suffix -# for backward compatibility: -ac_top_builddir=$ac_top_build_prefix +if test "$ac_dir" != .; then + ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'` + # A "../" for each directory in $ac_dir_suffix. + ac_top_builddir=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,../,g'` +else + ac_dir_suffix= ac_top_builddir= +fi case $srcdir in - .) # We are building in place. + .) # No --srcdir option. We are building in place. ac_srcdir=. - ac_top_srcdir=$ac_top_builddir_sub - ac_abs_top_srcdir=$ac_pwd ;; - [\\/]* | ?:[\\/]* ) # Absolute name. + if test -z "$ac_top_builddir"; then + ac_top_srcdir=. + else + ac_top_srcdir=`echo $ac_top_builddir | sed 's,/$,,'` + fi ;; + [\\/]* | ?:[\\/]* ) # Absolute path. ac_srcdir=$srcdir$ac_dir_suffix; - ac_top_srcdir=$srcdir - ac_abs_top_srcdir=$srcdir ;; - *) # Relative name. - ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix - ac_top_srcdir=$ac_top_build_prefix$srcdir - ac_abs_top_srcdir=$ac_pwd/$srcdir ;; + ac_top_srcdir=$srcdir ;; + *) # Relative path. + ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix + ac_top_srcdir=$ac_top_builddir$srcdir ;; +esac + +# Do not use `cd foo && pwd` to compute absolute paths, because +# the directories may not exist. +case `pwd` in +.) ac_abs_builddir="$ac_dir";; +*) + case "$ac_dir" in + .) ac_abs_builddir=`pwd`;; + [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";; + *) ac_abs_builddir=`pwd`/"$ac_dir";; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_top_builddir=${ac_top_builddir}.;; +*) + case ${ac_top_builddir}. in + .) ac_abs_top_builddir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;; + *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_srcdir=$ac_srcdir;; +*) + case $ac_srcdir in + .) ac_abs_srcdir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;; + *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_top_srcdir=$ac_top_srcdir;; +*) + case $ac_top_srcdir in + .) ac_abs_top_srcdir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;; + *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;; + esac;; esac -ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix - - cd "$ac_dir" || { ac_status=$?; continue; } - # Check for guested configure. - if test -f "$ac_srcdir/configure.gnu"; then - echo && - $SHELL "$ac_srcdir/configure.gnu" --help=recursive - elif test -f "$ac_srcdir/configure"; then - echo && - $SHELL "$ac_srcdir/configure" --help=recursive + + cd $ac_dir + # Check for guested configure; otherwise get Cygnus style configure. + if test -f $ac_srcdir/configure.gnu; then + echo + $SHELL $ac_srcdir/configure.gnu --help=recursive + elif test -f $ac_srcdir/configure; then + echo + $SHELL $ac_srcdir/configure --help=recursive + elif test -f $ac_srcdir/configure.ac || + test -f $ac_srcdir/configure.in; then + echo + $ac_configure --help else - $as_echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 - fi || ac_status=$? - cd "$ac_pwd" || { ac_status=$?; break; } + echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 + fi + cd $ac_popdir done fi -test -n "$ac_init_help" && exit $ac_status +test -n "$ac_init_help" && exit 0 if $ac_init_version; then cat <<\_ACEOF -tcl configure 9.0 -generated by GNU Autoconf 2.69 +tcl configure 8.6 +generated by GNU Autoconf 2.59 -Copyright (C) 2012 Free Software Foundation, Inc. +Copyright (C) 2003 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF - exit -fi - -## ------------------------ ## -## Autoconf initialization. ## -## ------------------------ ## - -# ac_fn_c_try_compile LINENO -# -------------------------- -# Try to compile conftest.$ac_ext, and return whether this succeeded. -ac_fn_c_try_compile () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - rm -f conftest.$ac_objext - if { { ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_compile") 2>conftest.err - ac_status=$? - if test -s conftest.err; then - grep -v '^ *+' conftest.err >conftest.er1 - cat conftest.er1 >&5 - mv -f conftest.er1 conftest.err - fi - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then : - ac_retval=0 -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_retval=1 -fi - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $ac_retval - -} # ac_fn_c_try_compile - -# ac_fn_c_try_link LINENO -# ----------------------- -# Try to link conftest.$ac_ext, and return whether this succeeded. -ac_fn_c_try_link () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - rm -f conftest.$ac_objext conftest$ac_exeext - if { { ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_link") 2>conftest.err - ac_status=$? - if test -s conftest.err; then - grep -v '^ *+' conftest.err >conftest.er1 - cat conftest.er1 >&5 - mv -f conftest.er1 conftest.err - fi - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - test -x conftest$ac_exeext - }; then : - ac_retval=0 -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_retval=1 -fi - # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information - # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would - # interfere with the next link command; also delete a directory that is - # left behind by Apple's compiler. We do this before executing the actions. - rm -rf conftest.dSYM conftest_ipa8_conftest.oo - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $ac_retval - -} # ac_fn_c_try_link - -# ac_fn_c_try_cpp LINENO -# ---------------------- -# Try to preprocess conftest.$ac_ext, and return whether this succeeded. -ac_fn_c_try_cpp () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - if { { ac_try="$ac_cpp conftest.$ac_ext" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_cpp conftest.$ac_ext") 2>conftest.err - ac_status=$? - if test -s conftest.err; then - grep -v '^ *+' conftest.err >conftest.er1 - cat conftest.er1 >&5 - mv -f conftest.er1 conftest.err - fi - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } > conftest.i && { - test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || - test ! -s conftest.err - }; then : - ac_retval=0 -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_retval=1 -fi - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $ac_retval - -} # ac_fn_c_try_cpp - -# ac_fn_c_check_header_mongrel LINENO HEADER VAR INCLUDES -# ------------------------------------------------------- -# Tests whether HEADER exists, giving a warning if it cannot be compiled using -# the include files in INCLUDES and setting the cache variable VAR -# accordingly. -ac_fn_c_check_header_mongrel () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - if eval \${$3+:} false; then : - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 -$as_echo_n "checking for $2... " >&6; } -if eval \${$3+:} false; then : - $as_echo_n "(cached) " >&6 -fi -eval ac_res=\$$3 - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 -$as_echo "$ac_res" >&6; } -else - # Is the header compilable? -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 usability" >&5 -$as_echo_n "checking $2 usability... " >&6; } -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -$4 -#include <$2> -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - ac_header_compiler=yes -else - ac_header_compiler=no -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_compiler" >&5 -$as_echo "$ac_header_compiler" >&6; } - -# Is the header present? -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 presence" >&5 -$as_echo_n "checking $2 presence... " >&6; } -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include <$2> -_ACEOF -if ac_fn_c_try_cpp "$LINENO"; then : - ac_header_preproc=yes -else - ac_header_preproc=no -fi -rm -f conftest.err conftest.i conftest.$ac_ext -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_preproc" >&5 -$as_echo "$ac_header_preproc" >&6; } - -# So? What about this header? -case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in #(( - yes:no: ) - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&5 -$as_echo "$as_me: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&2;} - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5 -$as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;} - ;; - no:yes:* ) - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: present but cannot be compiled" >&5 -$as_echo "$as_me: WARNING: $2: present but cannot be compiled" >&2;} - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: check for missing prerequisite headers?" >&5 -$as_echo "$as_me: WARNING: $2: check for missing prerequisite headers?" >&2;} - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: see the Autoconf documentation" >&5 -$as_echo "$as_me: WARNING: $2: see the Autoconf documentation" >&2;} - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&5 -$as_echo "$as_me: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&2;} - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5 -$as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;} - ;; -esac - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 -$as_echo_n "checking for $2... " >&6; } -if eval \${$3+:} false; then : - $as_echo_n "(cached) " >&6 -else - eval "$3=\$ac_header_compiler" -fi -eval ac_res=\$$3 - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 -$as_echo "$ac_res" >&6; } -fi - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - -} # ac_fn_c_check_header_mongrel - -# ac_fn_c_try_run LINENO -# ---------------------- -# Try to link conftest.$ac_ext, and return whether this succeeded. Assumes -# that executables *can* be run. -ac_fn_c_try_run () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - if { { ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_link") 2>&5 - ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } && { ac_try='./conftest$ac_exeext' - { { case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_try") 2>&5 - ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; }; }; then : - ac_retval=0 -else - $as_echo "$as_me: program exited with status $ac_status" >&5 - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_retval=$ac_status -fi - rm -rf conftest.dSYM conftest_ipa8_conftest.oo - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $ac_retval - -} # ac_fn_c_try_run - -# ac_fn_c_check_header_compile LINENO HEADER VAR INCLUDES -# ------------------------------------------------------- -# Tests whether HEADER exists and can be compiled using the include files in -# INCLUDES, setting the cache variable VAR accordingly. -ac_fn_c_check_header_compile () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 -$as_echo_n "checking for $2... " >&6; } -if eval \${$3+:} false; then : - $as_echo_n "(cached) " >&6 -else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -$4 -#include <$2> -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - eval "$3=yes" -else - eval "$3=no" -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -fi -eval ac_res=\$$3 - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 -$as_echo "$ac_res" >&6; } - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - -} # ac_fn_c_check_header_compile - -# ac_fn_c_check_func LINENO FUNC VAR -# ---------------------------------- -# Tests whether FUNC exists, setting the cache variable VAR accordingly -ac_fn_c_check_func () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 -$as_echo_n "checking for $2... " >&6; } -if eval \${$3+:} false; then : - $as_echo_n "(cached) " >&6 -else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -/* Define $2 to an innocuous variant, in case declares $2. - For example, HP-UX 11i declares gettimeofday. */ -#define $2 innocuous_$2 - -/* System header to define __stub macros and hopefully few prototypes, - which can conflict with char $2 (); below. - Prefer to if __STDC__ is defined, since - exists even on freestanding compilers. */ - -#ifdef __STDC__ -# include -#else -# include -#endif - -#undef $2 - -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ -#ifdef __cplusplus -extern "C" -#endif -char $2 (); -/* The GNU C library defines this for functions which it implements - to always fail with ENOSYS. Some functions are actually named - something starting with __ and the normal name is an alias. */ -#if defined __stub_$2 || defined __stub___$2 -choke me -#endif - -int -main () -{ -return $2 (); - ; - return 0; -} -_ACEOF -if ac_fn_c_try_link "$LINENO"; then : - eval "$3=yes" -else - eval "$3=no" -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext -fi -eval ac_res=\$$3 - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 -$as_echo "$ac_res" >&6; } - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - -} # ac_fn_c_check_func - -# ac_fn_c_check_decl LINENO SYMBOL VAR INCLUDES -# --------------------------------------------- -# Tests whether SYMBOL is declared in INCLUDES, setting cache variable VAR -# accordingly. -ac_fn_c_check_decl () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - as_decl_name=`echo $2|sed 's/ *(.*//'` - as_decl_use=`echo $2|sed -e 's/(/((/' -e 's/)/) 0&/' -e 's/,/) 0& (/g'` - { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $as_decl_name is declared" >&5 -$as_echo_n "checking whether $as_decl_name is declared... " >&6; } -if eval \${$3+:} false; then : - $as_echo_n "(cached) " >&6 -else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -$4 -int -main () -{ -#ifndef $as_decl_name -#ifdef __cplusplus - (void) $as_decl_use; -#else - (void) $as_decl_name; -#endif -#endif - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - eval "$3=yes" -else - eval "$3=no" -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -fi -eval ac_res=\$$3 - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 -$as_echo "$ac_res" >&6; } - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - -} # ac_fn_c_check_decl - -# ac_fn_c_check_type LINENO TYPE VAR INCLUDES -# ------------------------------------------- -# Tests whether TYPE exists after having included INCLUDES, setting cache -# variable VAR accordingly. -ac_fn_c_check_type () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 -$as_echo_n "checking for $2... " >&6; } -if eval \${$3+:} false; then : - $as_echo_n "(cached) " >&6 -else - eval "$3=no" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -$4 -int -main () -{ -if (sizeof ($2)) - return 0; - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -$4 -int -main () -{ -if (sizeof (($2))) - return 0; - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - -else - eval "$3=yes" -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -fi -eval ac_res=\$$3 - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 -$as_echo "$ac_res" >&6; } - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - -} # ac_fn_c_check_type - -# ac_fn_c_check_member LINENO AGGR MEMBER VAR INCLUDES -# ---------------------------------------------------- -# Tries to find if the field MEMBER exists in type AGGR, after including -# INCLUDES, setting cache variable VAR accordingly. -ac_fn_c_check_member () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2.$3" >&5 -$as_echo_n "checking for $2.$3... " >&6; } -if eval \${$4+:} false; then : - $as_echo_n "(cached) " >&6 -else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -$5 -int -main () -{ -static $2 ac_aggr; -if (ac_aggr.$3) -return 0; - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - eval "$4=yes" -else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -$5 -int -main () -{ -static $2 ac_aggr; -if (sizeof ac_aggr.$3) -return 0; - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - eval "$4=yes" -else - eval "$4=no" -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -fi -eval ac_res=\$$4 - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 -$as_echo "$ac_res" >&6; } - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - -} # ac_fn_c_check_member -cat >config.log <<_ACEOF + exit 0 +fi +exec 5>config.log +cat >&5 <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by tcl $as_me 9.0, which was -generated by GNU Autoconf 2.69. Invocation command line was +It was created by tcl $as_me 8.6, which was +generated by GNU Autoconf 2.59. Invocation command line was $ $0 $@ _ACEOF -exec 5>>config.log { cat <<_ASUNAME ## --------- ## ## Platform. ## ## --------- ## @@ -2050,11 +1014,11 @@ /bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` /bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` -/usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` +hostinfo = `(hostinfo) 2>/dev/null || echo unknown` /bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` /bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` _ASUNAME @@ -2062,13 +1026,12 @@ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - $as_echo "PATH: $as_dir" - done -IFS=$as_save_IFS + echo "PATH: $as_dir" +done } >&5 cat >&5 <<_ACEOF @@ -2086,10 +1049,11 @@ # Also quote any args containing shell meta-characters. # Make two passes to allow for proper duplicate-argument suppression. ac_configure_args= ac_configure_args0= ac_configure_args1= +ac_sep= ac_must_keep_next=false for ac_pass in 1 2 do for ac_arg do @@ -2096,17 +1060,17 @@ case $ac_arg in -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) continue ;; - *\'*) - ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; + *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?\"\']*) + ac_arg=`echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac case $ac_pass in - 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; + 1) ac_configure_args0="$ac_configure_args0 '$ac_arg'" ;; 2) - as_fn_append ac_configure_args1 " '$ac_arg'" + ac_configure_args1="$ac_configure_args1 '$ac_arg'" if test $ac_must_keep_next = true; then ac_must_keep_next=false # Got value, back to normal. else case $ac_arg in *=* | --config-cache | -C | -disable-* | --disable-* \ @@ -2118,257 +1082,221 @@ esac ;; -* ) ac_must_keep_next=true ;; esac fi - as_fn_append ac_configure_args " '$ac_arg'" + ac_configure_args="$ac_configure_args$ac_sep'$ac_arg'" + # Get rid of the leading space. + ac_sep=" " ;; esac done done -{ ac_configure_args0=; unset ac_configure_args0;} -{ ac_configure_args1=; unset ac_configure_args1;} +$as_unset ac_configure_args0 || test "${ac_configure_args0+set}" != set || { ac_configure_args0=; export ac_configure_args0; } +$as_unset ac_configure_args1 || test "${ac_configure_args1+set}" != set || { ac_configure_args1=; export ac_configure_args1; } # When interrupted or exit'd, cleanup temporary files, and complete # config.log. We remove comments because anyway the quotes in there # would cause problems or look ugly. -# WARNING: Use '\'' to represent an apostrophe within the trap. -# WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. +# WARNING: Be sure not to use single quotes in there, as some shells, +# such as our DU 5.0 friend, will then `close' the trap. trap 'exit_status=$? # Save into config.log some information that might help in debugging. { echo - $as_echo "## ---------------- ## + cat <<\_ASBOX +## ---------------- ## ## Cache variables. ## -## ---------------- ##" +## ---------------- ## +_ASBOX echo # The following way of writing the cache mishandles newlines in values, -( - for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do - eval ac_val=\$$ac_var - case $ac_val in #( - *${as_nl}*) - case $ac_var in #( - *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 -$as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; - esac - case $ac_var in #( - _ | IFS | as_nl) ;; #( - BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( - *) { eval $ac_var=; unset $ac_var;} ;; - esac ;; - esac - done +{ (set) 2>&1 | - case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( - *${as_nl}ac_space=\ *) + case `(ac_space='"'"' '"'"'; set | grep ac_space) 2>&1` in + *ac_space=\ *) + sed -n \ + "s/'"'"'/'"'"'\\\\'"'"''"'"'/g; + s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='"'"'\\2'"'"'/p" + ;; + *) sed -n \ - "s/'\''/'\''\\\\'\'''\''/g; - s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" - ;; #( - *) - sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" + "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p" ;; - esac | - sort -) + esac; +} echo - $as_echo "## ----------------- ## + cat <<\_ASBOX +## ----------------- ## ## Output variables. ## -## ----------------- ##" +## ----------------- ## +_ASBOX echo for ac_var in $ac_subst_vars do - eval ac_val=\$$ac_var - case $ac_val in - *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; - esac - $as_echo "$ac_var='\''$ac_val'\''" + eval ac_val=$`echo $ac_var` + echo "$ac_var='"'"'$ac_val'"'"'" done | sort echo if test -n "$ac_subst_files"; then - $as_echo "## ------------------- ## -## File substitutions. ## -## ------------------- ##" + cat <<\_ASBOX +## ------------- ## +## Output files. ## +## ------------- ## +_ASBOX echo for ac_var in $ac_subst_files do - eval ac_val=\$$ac_var - case $ac_val in - *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; - esac - $as_echo "$ac_var='\''$ac_val'\''" + eval ac_val=$`echo $ac_var` + echo "$ac_var='"'"'$ac_val'"'"'" done | sort echo fi if test -s confdefs.h; then - $as_echo "## ----------- ## + cat <<\_ASBOX +## ----------- ## ## confdefs.h. ## -## ----------- ##" +## ----------- ## +_ASBOX echo - cat confdefs.h + sed "/^$/d" confdefs.h | sort echo fi test "$ac_signal" != 0 && - $as_echo "$as_me: caught signal $ac_signal" - $as_echo "$as_me: exit $exit_status" + echo "$as_me: caught signal $ac_signal" + echo "$as_me: exit $exit_status" } >&5 - rm -f core *.core core.conftest.* && - rm -f -r conftest* confdefs* conf$$* $ac_clean_files && + rm -f core *.core && + rm -rf conftest* confdefs* conf$$* $ac_clean_files && exit $exit_status -' 0 + ' 0 for ac_signal in 1 2 13 15; do - trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal + trap 'ac_signal='$ac_signal'; { (exit 1); exit 1; }' $ac_signal done ac_signal=0 # confdefs.h avoids OS command line length limits that DEFS can exceed. -rm -f -r conftest* confdefs.h - -$as_echo "/* confdefs.h */" > confdefs.h +rm -rf conftest* confdefs.h +# AIX cpp loses on an empty file, so make sure it contains at least a newline. +echo >confdefs.h # Predefined preprocessor variables. cat >>confdefs.h <<_ACEOF #define PACKAGE_NAME "$PACKAGE_NAME" _ACEOF + cat >>confdefs.h <<_ACEOF #define PACKAGE_TARNAME "$PACKAGE_TARNAME" _ACEOF + cat >>confdefs.h <<_ACEOF #define PACKAGE_VERSION "$PACKAGE_VERSION" _ACEOF + cat >>confdefs.h <<_ACEOF #define PACKAGE_STRING "$PACKAGE_STRING" _ACEOF + cat >>confdefs.h <<_ACEOF #define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" _ACEOF -cat >>confdefs.h <<_ACEOF -#define PACKAGE_URL "$PACKAGE_URL" -_ACEOF - # Let the site file select an alternate cache file if it wants to. -# Prefer an explicitly selected file to automatically selected ones. -ac_site_file1=NONE -ac_site_file2=NONE -if test -n "$CONFIG_SITE"; then - # We do not want a PATH search for config.site. - case $CONFIG_SITE in #(( - -*) ac_site_file1=./$CONFIG_SITE;; - */*) ac_site_file1=$CONFIG_SITE;; - *) ac_site_file1=./$CONFIG_SITE;; - esac -elif test "x$prefix" != xNONE; then - ac_site_file1=$prefix/share/config.site - ac_site_file2=$prefix/etc/config.site -else - ac_site_file1=$ac_default_prefix/share/config.site - ac_site_file2=$ac_default_prefix/etc/config.site +# Prefer explicitly selected file to automatically selected ones. +if test -z "$CONFIG_SITE"; then + if test "x$prefix" != xNONE; then + CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site" + else + CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" + fi fi -for ac_site_file in "$ac_site_file1" "$ac_site_file2" -do - test "x$ac_site_file" = xNONE && continue - if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 -$as_echo "$as_me: loading site script $ac_site_file" >&6;} +for ac_site_file in $CONFIG_SITE; do + if test -r "$ac_site_file"; then + { echo "$as_me:$LINENO: loading site script $ac_site_file" >&5 +echo "$as_me: loading site script $ac_site_file" >&6;} sed 's/^/| /' "$ac_site_file" >&5 - . "$ac_site_file" \ - || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "failed to load site script $ac_site_file -See \`config.log' for more details" "$LINENO" 5; } + . "$ac_site_file" fi done if test -r "$cache_file"; then - # Some versions of bash will fail to source /dev/null (special files - # actually), so we avoid doing that. DJGPP emulates it as a regular file. - if test /dev/null != "$cache_file" && test -f "$cache_file"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 -$as_echo "$as_me: loading cache $cache_file" >&6;} + # Some versions of bash will fail to source /dev/null (special + # files actually), so we avoid doing that. + if test -f "$cache_file"; then + { echo "$as_me:$LINENO: loading cache $cache_file" >&5 +echo "$as_me: loading cache $cache_file" >&6;} case $cache_file in - [\\/]* | ?:[\\/]* ) . "$cache_file";; - *) . "./$cache_file";; + [\\/]* | ?:[\\/]* ) . $cache_file;; + *) . ./$cache_file;; esac fi else - { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 -$as_echo "$as_me: creating cache $cache_file" >&6;} + { echo "$as_me:$LINENO: creating cache $cache_file" >&5 +echo "$as_me: creating cache $cache_file" >&6;} >$cache_file fi # Check that the precious variables saved in the cache have kept the same # value. ac_cache_corrupted=false -for ac_var in $ac_precious_vars; do +for ac_var in `(set) 2>&1 | + sed -n 's/^ac_env_\([a-zA-Z_0-9]*\)_set=.*/\1/p'`; do eval ac_old_set=\$ac_cv_env_${ac_var}_set eval ac_new_set=\$ac_env_${ac_var}_set - eval ac_old_val=\$ac_cv_env_${ac_var}_value - eval ac_new_val=\$ac_env_${ac_var}_value + eval ac_old_val="\$ac_cv_env_${ac_var}_value" + eval ac_new_val="\$ac_env_${ac_var}_value" case $ac_old_set,$ac_new_set in set,) - { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 -$as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} + { echo "$as_me:$LINENO: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 +echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) - { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 -$as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} + { echo "$as_me:$LINENO: error: \`$ac_var' was not set in the previous run" >&5 +echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} ac_cache_corrupted=: ;; ,);; *) if test "x$ac_old_val" != "x$ac_new_val"; then - # differences in whitespace do not lead to failure. - ac_old_val_w=`echo x $ac_old_val` - ac_new_val_w=`echo x $ac_new_val` - if test "$ac_old_val_w" != "$ac_new_val_w"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 -$as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} - ac_cache_corrupted=: - else - { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 -$as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} - eval $ac_var=\$ac_old_val - fi - { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 -$as_echo "$as_me: former value: \`$ac_old_val'" >&2;} - { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 -$as_echo "$as_me: current value: \`$ac_new_val'" >&2;} + { echo "$as_me:$LINENO: error: \`$ac_var' has changed since the previous run:" >&5 +echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} + { echo "$as_me:$LINENO: former value: $ac_old_val" >&5 +echo "$as_me: former value: $ac_old_val" >&2;} + { echo "$as_me:$LINENO: current value: $ac_new_val" >&5 +echo "$as_me: current value: $ac_new_val" >&2;} + ac_cache_corrupted=: fi;; esac # Pass precious variables to config.status. if test "$ac_new_set" = set; then case $ac_new_val in - *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; + *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?\"\']*) + ac_arg=$ac_var=`echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; *) ac_arg=$ac_var=$ac_new_val ;; esac case " $ac_configure_args " in *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. - *) as_fn_append ac_configure_args " '$ac_arg'" ;; + *) ac_configure_args="$ac_configure_args '$ac_arg'" ;; esac fi done if $ac_cache_corrupted; then - { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} - { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 -$as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} - as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 + { echo "$as_me:$LINENO: error: changes in the environment can compromise the build" >&5 +echo "$as_me: error: changes in the environment can compromise the build" >&2;} + { { echo "$as_me:$LINENO: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&5 +echo "$as_me: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&2;} + { (exit 1); exit 1; }; } fi -## -------------------- ## -## Main body of script. ## -## -------------------- ## ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' @@ -2377,14 +1305,39 @@ -TCL_VERSION=9.0 -TCL_MAJOR_VERSION=9 -TCL_MINOR_VERSION=0 -TCL_PATCH_LEVEL="a0" + + + + + + + + + + + + + + + + + + + + + + + + + +TCL_VERSION=8.6 +TCL_MAJOR_VERSION=8 +TCL_MINOR_VERSION=6 +TCL_PATCH_LEVEL=".10" VERSION=${TCL_VERSION} EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} EXTRA_BUILD_HTML=${EXTRA_BUILD_HTML:-"@:"} @@ -2427,64 +1380,66 @@ #------------------------------------------------------------------------ # Compress and/or soft link the manpages? #------------------------------------------------------------------------ - { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to use symlinks for manpages" >&5 -$as_echo_n "checking whether to use symlinks for manpages... " >&6; } - # Check whether --enable-man-symlinks was given. -if test "${enable_man_symlinks+set}" = set; then : - enableval=$enable_man_symlinks; test "$enableval" != "no" && MAN_FLAGS="$MAN_FLAGS --symlinks" + echo "$as_me:$LINENO: checking whether to use symlinks for manpages" >&5 +echo $ECHO_N "checking whether to use symlinks for manpages... $ECHO_C" >&6 + # Check whether --enable-man-symlinks or --disable-man-symlinks was given. +if test "${enable_man_symlinks+set}" = set; then + enableval="$enable_man_symlinks" + test "$enableval" != "no" && MAN_FLAGS="$MAN_FLAGS --symlinks" else enableval="no" -fi - - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $enableval" >&5 -$as_echo "$enableval" >&6; } - - { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to compress the manpages" >&5 -$as_echo_n "checking whether to compress the manpages... " >&6; } - # Check whether --enable-man-compression was given. -if test "${enable_man_compression+set}" = set; then : - enableval=$enable_man_compression; case $enableval in - yes) as_fn_error $? "missing argument to --enable-man-compression" "$LINENO" 5;; +fi; + echo "$as_me:$LINENO: result: $enableval" >&5 +echo "${ECHO_T}$enableval" >&6 + + echo "$as_me:$LINENO: checking whether to compress the manpages" >&5 +echo $ECHO_N "checking whether to compress the manpages... $ECHO_C" >&6 + # Check whether --enable-man-compression or --disable-man-compression was given. +if test "${enable_man_compression+set}" = set; then + enableval="$enable_man_compression" + case $enableval in + yes) { { echo "$as_me:$LINENO: error: missing argument to --enable-man-compression" >&5 +echo "$as_me: error: missing argument to --enable-man-compression" >&2;} + { (exit 1); exit 1; }; };; no) ;; *) MAN_FLAGS="$MAN_FLAGS --compress $enableval";; esac else enableval="no" -fi - - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $enableval" >&5 -$as_echo "$enableval" >&6; } +fi; + echo "$as_me:$LINENO: result: $enableval" >&5 +echo "${ECHO_T}$enableval" >&6 if test "$enableval" != "no"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for compressed file suffix" >&5 -$as_echo_n "checking for compressed file suffix... " >&6; } + echo "$as_me:$LINENO: checking for compressed file suffix" >&5 +echo $ECHO_N "checking for compressed file suffix... $ECHO_C" >&6 touch TeST $enableval TeST Z=`ls TeST* | sed 's/^....//'` rm -f TeST* MAN_FLAGS="$MAN_FLAGS --extension $Z" - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $Z" >&5 -$as_echo "$Z" >&6; } + echo "$as_me:$LINENO: result: $Z" >&5 +echo "${ECHO_T}$Z" >&6 fi - { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to add a package name suffix for the manpages" >&5 -$as_echo_n "checking whether to add a package name suffix for the manpages... " >&6; } - # Check whether --enable-man-suffix was given. -if test "${enable_man_suffix+set}" = set; then : - enableval=$enable_man_suffix; case $enableval in + echo "$as_me:$LINENO: checking whether to add a package name suffix for the manpages" >&5 +echo $ECHO_N "checking whether to add a package name suffix for the manpages... $ECHO_C" >&6 + # Check whether --enable-man-suffix or --disable-man-suffix was given. +if test "${enable_man_suffix+set}" = set; then + enableval="$enable_man_suffix" + case $enableval in yes) enableval="tcl" MAN_FLAGS="$MAN_FLAGS --suffix $enableval";; no) ;; *) MAN_FLAGS="$MAN_FLAGS --suffix $enableval";; esac else enableval="no" -fi - - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $enableval" >&5 -$as_echo "$enableval" >&6; } +fi; + echo "$as_me:$LINENO: result: $enableval" >&5 +echo "${ECHO_T}$enableval" >&6 #------------------------------------------------------------------------ @@ -2503,147 +1458,174 @@ ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args. set dummy ${ac_tool_prefix}gcc; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_CC+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CC="${ac_tool_prefix}gcc" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done - done -IFS=$as_save_IFS +done fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 -$as_echo "$CC" >&6; } + echo "$as_me:$LINENO: result: $CC" >&5 +echo "${ECHO_T}$CC" >&6 else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 fi - fi if test -z "$ac_cv_prog_CC"; then ac_ct_CC=$CC # Extract the first word of "gcc", so it can be a program name with args. set dummy gcc; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_ac_ct_CC+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_ac_ct_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="gcc" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done - done -IFS=$as_save_IFS +done fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 -$as_echo "$ac_ct_CC" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - if test "x$ac_ct_CC" = x; then - CC="" - else - case $cross_compiling:$ac_tool_warned in -yes:) -{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 -$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} -ac_tool_warned=yes ;; -esac - CC=$ac_ct_CC - fi + echo "$as_me:$LINENO: result: $ac_ct_CC" >&5 +echo "${ECHO_T}$ac_ct_CC" >&6 +else + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 +fi + + CC=$ac_ct_CC else CC="$ac_cv_prog_CC" fi if test -z "$CC"; then - if test -n "$ac_tool_prefix"; then - # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args. + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args. set dummy ${ac_tool_prefix}cc; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_CC+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CC="${ac_tool_prefix}cc" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done - done -IFS=$as_save_IFS +done fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 -$as_echo "$CC" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - - fi + echo "$as_me:$LINENO: result: $CC" >&5 +echo "${ECHO_T}$CC" >&6 +else + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 +fi + +fi +if test -z "$ac_cv_prog_CC"; then + ac_ct_CC=$CC + # Extract the first word of "cc", so it can be a program name with args. +set dummy cc; ac_word=$2 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_ac_ct_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + if test -n "$ac_ct_CC"; then + ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_CC="cc" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done +done + +fi +fi +ac_ct_CC=$ac_cv_prog_ac_ct_CC +if test -n "$ac_ct_CC"; then + echo "$as_me:$LINENO: result: $ac_ct_CC" >&5 +echo "${ECHO_T}$ac_ct_CC" >&6 +else + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 +fi + + CC=$ac_ct_CC +else + CC="$ac_cv_prog_CC" +fi + fi if test -z "$CC"; then # Extract the first word of "cc", so it can be a program name with args. set dummy cc; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_CC+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else ac_prog_rejected=no @@ -2650,23 +1632,22 @@ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then if test "$as_dir/$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then ac_prog_rejected=yes continue fi ac_cv_prog_CC="cc" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done - done -IFS=$as_save_IFS +done if test $ac_prog_rejected = yes; then # We found a bogon in the path, so make sure we never use it. set dummy $ac_cv_prog_CC shift @@ -2680,154 +1661,139 @@ fi fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 -$as_echo "$CC" >&6; } + echo "$as_me:$LINENO: result: $CC" >&5 +echo "${ECHO_T}$CC" >&6 else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 fi - fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then - for ac_prog in cl.exe + for ac_prog in cl do # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. set dummy $ac_tool_prefix$ac_prog; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_CC+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CC="$ac_tool_prefix$ac_prog" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done - done -IFS=$as_save_IFS +done fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 -$as_echo "$CC" >&6; } + echo "$as_me:$LINENO: result: $CC" >&5 +echo "${ECHO_T}$CC" >&6 else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 fi - test -n "$CC" && break done fi if test -z "$CC"; then ac_ct_CC=$CC - for ac_prog in cl.exe + for ac_prog in cl do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_ac_ct_CC+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_ac_ct_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="$ac_prog" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done - done -IFS=$as_save_IFS +done fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 -$as_echo "$ac_ct_CC" >&6; } + echo "$as_me:$LINENO: result: $ac_ct_CC" >&5 +echo "${ECHO_T}$ac_ct_CC" >&6 else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 fi - test -n "$ac_ct_CC" && break done - if test "x$ac_ct_CC" = x; then - CC="" - else - case $cross_compiling:$ac_tool_warned in -yes:) -{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 -$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} -ac_tool_warned=yes ;; -esac - CC=$ac_ct_CC - fi + CC=$ac_ct_CC fi fi -test -z "$CC" && { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "no acceptable C compiler found in \$PATH -See \`config.log' for more details" "$LINENO" 5; } +test -z "$CC" && { { echo "$as_me:$LINENO: error: no acceptable C compiler found in \$PATH +See \`config.log' for more details." >&5 +echo "$as_me: error: no acceptable C compiler found in \$PATH +See \`config.log' for more details." >&2;} + { (exit 1); exit 1; }; } # Provide some information about the compiler. -$as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5 -set X $ac_compile -ac_compiler=$2 -for ac_option in --version -v -V -qversion; do - { { ac_try="$ac_compiler $ac_option >&5" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_compiler $ac_option >&5") 2>conftest.err +echo "$as_me:$LINENO:" \ + "checking for C compiler version" >&5 +ac_compiler=`set X $ac_compile; echo $2` +{ (eval echo "$as_me:$LINENO: \"$ac_compiler --version &5\"") >&5 + (eval $ac_compiler --version &5) 2>&5 ac_status=$? - if test -s conftest.err; then - sed '10a\ -... rest of stderr output deleted ... - 10q' conftest.err >conftest.er1 - cat conftest.er1 >&5 - fi - rm -f conftest.er1 conftest.err - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } -done - -cat confdefs.h - <<_ACEOF >conftest.$ac_ext + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } +{ (eval echo "$as_me:$LINENO: \"$ac_compiler -v &5\"") >&5 + (eval $ac_compiler -v &5) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } +{ (eval echo "$as_me:$LINENO: \"$ac_compiler -V &5\"") >&5 + (eval $ac_compiler -V &5) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } + +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { @@ -2835,203 +1801,155 @@ ; return 0; } _ACEOF ac_clean_files_save=$ac_clean_files -ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out" +ac_clean_files="$ac_clean_files a.out a.exe b.out" # Try to create an executable without -o first, disregard a.out. # It will help us diagnose broken compilers, and finding out an intuition # of exeext. -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the C compiler works" >&5 -$as_echo_n "checking whether the C compiler works... " >&6; } -ac_link_default=`$as_echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'` - -# The possible output files: -ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*" - -ac_rmfiles= -for ac_file in $ac_files -do - case $ac_file in - *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; - * ) ac_rmfiles="$ac_rmfiles $ac_file";; - esac -done -rm -f $ac_rmfiles - -if { { ac_try="$ac_link_default" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_link_default") 2>&5 - ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; }; then : - # Autoconf-2.13 could set the ac_cv_exeext variable to `no'. -# So ignore a value of `no', otherwise this would lead to `EXEEXT = no' -# in a Makefile. We should not override ac_cv_exeext if it was cached, -# so that the user can short-circuit this test for compilers unknown to -# Autoconf. -for ac_file in $ac_files '' +echo "$as_me:$LINENO: checking for C compiler default output file name" >&5 +echo $ECHO_N "checking for C compiler default output file name... $ECHO_C" >&6 +ac_link_default=`echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'` +if { (eval echo "$as_me:$LINENO: \"$ac_link_default\"") >&5 + (eval $ac_link_default) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; then + # Find the output, starting from the most likely. This scheme is +# not robust to junk in `.', hence go to wildcards (a.*) only as a last +# resort. + +# Be careful to initialize this variable, since it used to be cached. +# Otherwise an old cache value of `no' led to `EXEEXT = no' in a Makefile. +ac_cv_exeext= +# b.out is created by i960 compilers. +for ac_file in a_out.exe a.exe conftest.exe a.out conftest a.* conftest.* b.out do test -f "$ac_file" || continue case $ac_file in - *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj ) + ;; + conftest.$ac_ext ) + # This is the source file. ;; [ab].out ) # We found the default executable, but exeext='' is most # certainly right. break;; *.* ) - if test "${ac_cv_exeext+set}" = set && test "$ac_cv_exeext" != no; - then :; else - ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` - fi - # We set ac_cv_exeext here because the later test for it is not - # safe: cross compilers may not add the suffix if given an `-o' - # argument, so we may need to know it at that point already. - # Even if this section looks crufty: it has the advantage of - # actually working. + ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` + # FIXME: I believe we export ac_cv_exeext for Libtool, + # but it would be cool to find out if it's true. Does anybody + # maintain Libtool? --akim. + export ac_cv_exeext break;; * ) break;; esac done -test "$ac_cv_exeext" = no && ac_cv_exeext= - else - ac_file='' -fi -if test -z "$ac_file"; then : - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -$as_echo "$as_me: failed program was:" >&5 + echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error 77 "C compiler cannot create executables -See \`config.log' for more details" "$LINENO" 5; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -$as_echo "yes" >&6; } +{ { echo "$as_me:$LINENO: error: C compiler cannot create executables +See \`config.log' for more details." >&5 +echo "$as_me: error: C compiler cannot create executables +See \`config.log' for more details." >&2;} + { (exit 77); exit 77; }; } fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler default output file name" >&5 -$as_echo_n "checking for C compiler default output file name... " >&6; } -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5 -$as_echo "$ac_file" >&6; } + ac_exeext=$ac_cv_exeext +echo "$as_me:$LINENO: result: $ac_file" >&5 +echo "${ECHO_T}$ac_file" >&6 -rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out +# Check the compiler produces executables we can run. If not, either +# the compiler is broken, or we cross compile. +echo "$as_me:$LINENO: checking whether the C compiler works" >&5 +echo $ECHO_N "checking whether the C compiler works... $ECHO_C" >&6 +# FIXME: These cross compiler hacks should be removed for Autoconf 3.0 +# If not cross compiling, check that we can run a simple program. +if test "$cross_compiling" != yes; then + if { ac_try='./$ac_file' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + cross_compiling=no + else + if test "$cross_compiling" = maybe; then + cross_compiling=yes + else + { { echo "$as_me:$LINENO: error: cannot run C compiled programs. +If you meant to cross compile, use \`--host'. +See \`config.log' for more details." >&5 +echo "$as_me: error: cannot run C compiled programs. +If you meant to cross compile, use \`--host'. +See \`config.log' for more details." >&2;} + { (exit 1); exit 1; }; } + fi + fi +fi +echo "$as_me:$LINENO: result: yes" >&5 +echo "${ECHO_T}yes" >&6 + +rm -f a.out a.exe conftest$ac_cv_exeext b.out ac_clean_files=$ac_clean_files_save -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5 -$as_echo_n "checking for suffix of executables... " >&6; } -if { { ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_link") 2>&5 +# Check the compiler produces executables we can run. If not, either +# the compiler is broken, or we cross compile. +echo "$as_me:$LINENO: checking whether we are cross compiling" >&5 +echo $ECHO_N "checking whether we are cross compiling... $ECHO_C" >&6 +echo "$as_me:$LINENO: result: $cross_compiling" >&5 +echo "${ECHO_T}$cross_compiling" >&6 + +echo "$as_me:$LINENO: checking for suffix of executables" >&5 +echo $ECHO_N "checking for suffix of executables... $ECHO_C" >&6 +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>&5 ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; }; then : + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; then # If both `conftest.exe' and `conftest' are `present' (well, observable) # catch `conftest.exe'. For instance with Cygwin, `ls conftest' will # work properly (i.e., refer to `conftest.exe'), while it won't with # `rm'. for ac_file in conftest.exe conftest conftest.*; do test -f "$ac_file" || continue case $ac_file in - *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj ) ;; *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` + export ac_cv_exeext break;; * ) break;; esac done else - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "cannot compute suffix of executables: cannot compile and link -See \`config.log' for more details" "$LINENO" 5; } + { { echo "$as_me:$LINENO: error: cannot compute suffix of executables: cannot compile and link +See \`config.log' for more details." >&5 +echo "$as_me: error: cannot compute suffix of executables: cannot compile and link +See \`config.log' for more details." >&2;} + { (exit 1); exit 1; }; } fi -rm -f conftest conftest$ac_cv_exeext -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5 -$as_echo "$ac_cv_exeext" >&6; } + +rm -f conftest$ac_cv_exeext +echo "$as_me:$LINENO: result: $ac_cv_exeext" >&5 +echo "${ECHO_T}$ac_cv_exeext" >&6 rm -f conftest.$ac_ext EXEEXT=$ac_cv_exeext ac_exeext=$EXEEXT -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include -int -main () -{ -FILE *f = fopen ("conftest.out", "w"); - return ferror (f) || fclose (f) != 0; - - ; - return 0; -} +echo "$as_me:$LINENO: checking for suffix of object files" >&5 +echo $ECHO_N "checking for suffix of object files... $ECHO_C" >&6 +if test "${ac_cv_objext+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ _ACEOF -ac_clean_files="$ac_clean_files conftest.out" -# Check that the compiler produces executables we can run. If not, either -# the compiler is broken, or we cross compile. -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5 -$as_echo_n "checking whether we are cross compiling... " >&6; } -if test "$cross_compiling" != yes; then - { { ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_link") 2>&5 - ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } - if { ac_try='./conftest$ac_cv_exeext' - { { case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_try") 2>&5 - ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; }; }; then - cross_compiling=no - else - if test "$cross_compiling" = maybe; then - cross_compiling=yes - else - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "cannot run C compiled programs. -If you meant to cross compile, use \`--host'. -See \`config.log' for more details" "$LINENO" 5; } - fi - fi -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5 -$as_echo "$cross_compiling" >&6; } - -rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out -ac_clean_files=$ac_clean_files_save -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5 -$as_echo_n "checking for suffix of object files... " >&6; } -if ${ac_cv_objext+:} false; then : - $as_echo_n "(cached) " >&6 -else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { @@ -3039,50 +1957,49 @@ ; return 0; } _ACEOF rm -f conftest.o conftest.obj -if { { ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_compile") 2>&5 +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>&5 ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; }; then : - for ac_file in conftest.o conftest.obj conftest.*; do - test -f "$ac_file" || continue; + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; then + for ac_file in `(ls conftest.o conftest.obj; ls conftest.*) 2>/dev/null`; do case $ac_file in - *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;; + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg ) ;; *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` break;; esac done else - $as_echo "$as_me: failed program was:" >&5 + echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "cannot compute suffix of object files: cannot compile -See \`config.log' for more details" "$LINENO" 5; } +{ { echo "$as_me:$LINENO: error: cannot compute suffix of object files: cannot compile +See \`config.log' for more details." >&5 +echo "$as_me: error: cannot compute suffix of object files: cannot compile +See \`config.log' for more details." >&2;} + { (exit 1); exit 1; }; } fi + rm -f conftest.$ac_cv_objext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5 -$as_echo "$ac_cv_objext" >&6; } +echo "$as_me:$LINENO: result: $ac_cv_objext" >&5 +echo "${ECHO_T}$ac_cv_objext" >&6 OBJEXT=$ac_cv_objext ac_objext=$OBJEXT -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU C compiler" >&5 -$as_echo_n "checking whether we are using the GNU C compiler... " >&6; } -if ${ac_cv_c_compiler_gnu+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking whether we are using the GNU C compiler" >&5 +echo $ECHO_N "checking whether we are using the GNU C compiler... $ECHO_C" >&6 +if test "${ac_cv_c_compiler_gnu+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { @@ -3092,91 +2009,102 @@ ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then ac_compiler_gnu=yes else - ac_compiler_gnu=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_compiler_gnu=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext ac_cv_c_compiler_gnu=$ac_compiler_gnu fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5 -$as_echo "$ac_cv_c_compiler_gnu" >&6; } -if test $ac_compiler_gnu = yes; then - GCC=yes -else - GCC= -fi -ac_test_CFLAGS=${CFLAGS+set} -ac_save_CFLAGS=$CFLAGS -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5 -$as_echo_n "checking whether $CC accepts -g... " >&6; } -if ${ac_cv_prog_cc_g+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_save_c_werror_flag=$ac_c_werror_flag - ac_c_werror_flag=yes - ac_cv_prog_cc_g=no - CFLAGS="-g" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - ac_cv_prog_cc_g=yes -else - CFLAGS="" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - -else - ac_c_werror_flag=$ac_save_c_werror_flag - CFLAGS="-g" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - ac_cv_prog_cc_g=yes -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - ac_c_werror_flag=$ac_save_c_werror_flag -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5 -$as_echo "$ac_cv_prog_cc_g" >&6; } +echo "$as_me:$LINENO: result: $ac_cv_c_compiler_gnu" >&5 +echo "${ECHO_T}$ac_cv_c_compiler_gnu" >&6 +GCC=`test $ac_compiler_gnu = yes && echo yes` +ac_test_CFLAGS=${CFLAGS+set} +ac_save_CFLAGS=$CFLAGS +CFLAGS="-g" +echo "$as_me:$LINENO: checking whether $CC accepts -g" >&5 +echo $ECHO_N "checking whether $CC accepts -g... $ECHO_C" >&6 +if test "${ac_cv_prog_cc_g+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_prog_cc_g=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_prog_cc_g=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_prog_cc_g" >&5 +echo "${ECHO_T}$ac_cv_prog_cc_g" >&6 if test "$ac_test_CFLAGS" = set; then CFLAGS=$ac_save_CFLAGS elif test $ac_cv_prog_cc_g = yes; then if test "$GCC" = yes; then CFLAGS="-g -O2" @@ -3188,22 +2116,27 @@ CFLAGS="-O2" else CFLAGS= fi fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $CC option to accept ISO C89" >&5 -$as_echo_n "checking for $CC option to accept ISO C89... " >&6; } -if ${ac_cv_prog_cc_c89+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for $CC option to accept ANSI C" >&5 +echo $ECHO_N "checking for $CC option to accept ANSI C... $ECHO_C" >&6 +if test "${ac_cv_prog_cc_stdc+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - ac_cv_prog_cc_c89=no + ac_cv_prog_cc_stdc=no ac_save_CC=$CC -cat confdefs.h - <<_ACEOF >conftest.$ac_ext +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include -struct stat; +#include +#include /* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */ struct buf { int x; }; FILE * (*rcsopen) (struct buf *, struct stat *, int); static char *e (p, i) char **p; @@ -3222,21 +2155,16 @@ } /* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has function prototypes and stuff, but not '\xHH' hex character constants. These don't provoke an error unfortunately, instead are silently treated - as 'x'. The following induces an error, until -std is added to get + as 'x'. The following induces an error, until -std1 is added to get proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an array size at least. It's necessary to write '\x00'==0 to get something - that's true only with -std. */ + that's true only with -std1. */ int osf4_cc_array ['\x00' == 0 ? 1 : -1]; -/* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters - inside strings and character constants. */ -#define FOO(x) 'x' -int xlc6_cc_array[FOO(a) == 'x' ? 1 : -1]; - int test (int i, double x); struct s1 {int (*f) (int a);}; struct s2 {int (*f) (double a);}; int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int); int argc; @@ -3247,74 +2175,271 @@ return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]; ; return 0; } _ACEOF -for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std \ - -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" +# Don't try gcc -ansi; that turns off useful extensions and +# breaks some systems' header files. +# AIX -qlanglvl=ansi +# Ultrix and OSF/1 -std1 +# HP-UX 10.20 and later -Ae +# HP-UX older versions -Aa -D_HPUX_SOURCE +# SVR4 -Xc -D__EXTENSIONS__ +for ac_arg in "" -qlanglvl=ansi -std1 -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" do CC="$ac_save_CC $ac_arg" - if ac_fn_c_try_compile "$LINENO"; then : - ac_cv_prog_cc_c89=$ac_arg + rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_prog_cc_stdc=$ac_arg +break +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + fi -rm -f core conftest.err conftest.$ac_objext - test "x$ac_cv_prog_cc_c89" != "xno" && break +rm -f conftest.err conftest.$ac_objext done -rm -f conftest.$ac_ext +rm -f conftest.$ac_ext conftest.$ac_objext CC=$ac_save_CC fi -# AC_CACHE_VAL -case "x$ac_cv_prog_cc_c89" in - x) - { $as_echo "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 -$as_echo "none needed" >&6; } ;; - xno) - { $as_echo "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 -$as_echo "unsupported" >&6; } ;; + +case "x$ac_cv_prog_cc_stdc" in + x|xno) + echo "$as_me:$LINENO: result: none needed" >&5 +echo "${ECHO_T}none needed" >&6 ;; *) - CC="$CC $ac_cv_prog_cc_c89" - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 -$as_echo "$ac_cv_prog_cc_c89" >&6; } ;; + echo "$as_me:$LINENO: result: $ac_cv_prog_cc_stdc" >&5 +echo "${ECHO_T}$ac_cv_prog_cc_stdc" >&6 + CC="$CC $ac_cv_prog_cc_stdc" ;; esac -if test "x$ac_cv_prog_cc_c89" != xno; then : + +# Some people use a C++ compiler to compile C. Since we use `exit', +# in C++ we need to declare it. In case someone uses the same compiler +# for both compiling C and C++ we need to have the C++ compiler decide +# the declaration of exit, since it's the most demanding environment. +cat >conftest.$ac_ext <<_ACEOF +#ifndef __cplusplus + choke me +#endif +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + for ac_declaration in \ + '' \ + 'extern "C" void std::exit (int) throw (); using std::exit;' \ + 'extern "C" void std::exit (int); using std::exit;' \ + 'extern "C" void exit (int) throw ();' \ + 'extern "C" void exit (int);' \ + 'void exit (int);' +do + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_declaration +#include +int +main () +{ +exit (42); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + : +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +continue +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_declaration +int +main () +{ +exit (42); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + break +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +done +rm -f conftest* +if test -n "$ac_declaration"; then + echo '#ifdef __cplusplus' >>confdefs.h + echo $ac_declaration >>confdefs.h + echo '#endif' >>confdefs.h +fi +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for inline" >&5 -$as_echo_n "checking for inline... " >&6; } -if ${ac_cv_c_inline+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for inline" >&5 +echo $ECHO_N "checking for inline... $ECHO_C" >&6 +if test "${ac_cv_c_inline+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_cv_c_inline=no for ac_kw in inline __inline__ __inline; do - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #ifndef __cplusplus typedef int foo_t; static $ac_kw foo_t static_foo () {return 0; } $ac_kw foo_t foo () {return 0; } #endif _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - ac_cv_c_inline=$ac_kw +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_c_inline=$ac_kw; break +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - test "$ac_cv_c_inline" != no && break +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext done fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_inline" >&5 -$as_echo "$ac_cv_c_inline" >&6; } +echo "$as_me:$LINENO: result: $ac_cv_c_inline" >&5 +echo "${ECHO_T}$ac_cv_c_inline" >&6 + case $ac_cv_c_inline in inline | yes) ;; *) case $ac_cv_c_inline in @@ -3328,11 +2453,10 @@ _ACEOF ;; esac - #-------------------------------------------------------------------- # Supply substitutes for missing POSIX header files. Special notes: # - stdlib.h doesn't define strtol, strtoul, or # strtod insome versions of SunOS # - some versions of string.h don't declare procedures such @@ -3343,19 +2467,19 @@ ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking how to run the C preprocessor" >&5 -$as_echo_n "checking how to run the C preprocessor... " >&6; } +echo "$as_me:$LINENO: checking how to run the C preprocessor" >&5 +echo $ECHO_N "checking how to run the C preprocessor... $ECHO_C" >&6 # On Suns, sometimes $CPP names a directory. if test -n "$CPP" && test -d "$CPP"; then CPP= fi if test -z "$CPP"; then - if ${ac_cv_prog_CPP+:} false; then : - $as_echo_n "(cached) " >&6 + if test "${ac_cv_prog_CPP+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else # Double quotes because CPP needs to be expanded for CPP in "$CC -E" "$CC -E -traditional-cpp" "/lib/cpp" do ac_preproc_ok=false @@ -3365,47 +2489,95 @@ # with a fresh cross-compiler works. # Prefer to if __STDC__ is defined, since # exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #ifdef __STDC__ # include #else # include #endif Syntax error _ACEOF -if ac_fn_c_try_cpp "$LINENO"; then : +if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 + (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null; then + if test -s conftest.err; then + ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag + else + ac_cpp_err= + fi +else + ac_cpp_err=yes +fi +if test -z "$ac_cpp_err"; then + : +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 -else # Broken: fails on valid input. continue fi -rm -f conftest.err conftest.i conftest.$ac_ext +rm -f conftest.err conftest.$ac_ext - # OK, works on sane cases. Now check whether nonexistent headers + # OK, works on sane cases. Now check whether non-existent headers # can be detected and how. - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF -if ac_fn_c_try_cpp "$LINENO"; then : +if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 + (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null; then + if test -s conftest.err; then + ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag + else + ac_cpp_err= + fi +else + ac_cpp_err=yes +fi +if test -z "$ac_cpp_err"; then # Broken: success on invalid input. continue else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + # Passes both tests. ac_preproc_ok=: break fi -rm -f conftest.err conftest.i conftest.$ac_ext +rm -f conftest.err conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. -rm -f conftest.i conftest.err conftest.$ac_ext -if $ac_preproc_ok; then : +rm -f conftest.err conftest.$ac_ext +if $ac_preproc_ok; then break fi done ac_cv_prog_CPP=$CPP @@ -3413,209 +2585,147 @@ fi CPP=$ac_cv_prog_CPP else ac_cv_prog_CPP=$CPP fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $CPP" >&5 -$as_echo "$CPP" >&6; } +echo "$as_me:$LINENO: result: $CPP" >&5 +echo "${ECHO_T}$CPP" >&6 ac_preproc_ok=false for ac_c_preproc_warn_flag in '' yes do # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # Prefer to if __STDC__ is defined, since # exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #ifdef __STDC__ # include #else # include #endif Syntax error _ACEOF -if ac_fn_c_try_cpp "$LINENO"; then : +if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 + (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null; then + if test -s conftest.err; then + ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag + else + ac_cpp_err= + fi +else + ac_cpp_err=yes +fi +if test -z "$ac_cpp_err"; then + : +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 -else # Broken: fails on valid input. continue fi -rm -f conftest.err conftest.i conftest.$ac_ext +rm -f conftest.err conftest.$ac_ext - # OK, works on sane cases. Now check whether nonexistent headers + # OK, works on sane cases. Now check whether non-existent headers # can be detected and how. - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF -if ac_fn_c_try_cpp "$LINENO"; then : +if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 + (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null; then + if test -s conftest.err; then + ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag + else + ac_cpp_err= + fi +else + ac_cpp_err=yes +fi +if test -z "$ac_cpp_err"; then # Broken: success on invalid input. continue else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + # Passes both tests. ac_preproc_ok=: break fi -rm -f conftest.err conftest.i conftest.$ac_ext +rm -f conftest.err conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. -rm -f conftest.i conftest.err conftest.$ac_ext -if $ac_preproc_ok; then : - +rm -f conftest.err conftest.$ac_ext +if $ac_preproc_ok; then + : else - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "C preprocessor \"$CPP\" fails sanity check -See \`config.log' for more details" "$LINENO" 5; } + { { echo "$as_me:$LINENO: error: C preprocessor \"$CPP\" fails sanity check +See \`config.log' for more details." >&5 +echo "$as_me: error: C preprocessor \"$CPP\" fails sanity check +See \`config.log' for more details." >&2;} + { (exit 1); exit 1; }; } fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for grep that handles long lines and -e" >&5 -$as_echo_n "checking for grep that handles long lines and -e... " >&6; } -if ${ac_cv_path_GREP+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -z "$GREP"; then - ac_path_GREP_found=false - # Loop through the user's path and test for each of PROGNAME-LIST - as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_prog in grep ggrep; do - for ac_exec_ext in '' $ac_executable_extensions; do - ac_path_GREP="$as_dir/$ac_prog$ac_exec_ext" - as_fn_executable_p "$ac_path_GREP" || continue -# Check for GNU ac_path_GREP and select it if it is found. - # Check for GNU $ac_path_GREP -case `"$ac_path_GREP" --version 2>&1` in -*GNU*) - ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_found=:;; -*) - ac_count=0 - $as_echo_n 0123456789 >"conftest.in" - while : - do - cat "conftest.in" "conftest.in" >"conftest.tmp" - mv "conftest.tmp" "conftest.in" - cp "conftest.in" "conftest.nl" - $as_echo 'GREP' >> "conftest.nl" - "$ac_path_GREP" -e 'GREP$' -e '-(cannot match)-' < "conftest.nl" >"conftest.out" 2>/dev/null || break - diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break - as_fn_arith $ac_count + 1 && ac_count=$as_val - if test $ac_count -gt ${ac_path_GREP_max-0}; then - # Best one so far, save it but keep looking for a better one - ac_cv_path_GREP="$ac_path_GREP" - ac_path_GREP_max=$ac_count - fi - # 10*(2^10) chars as input seems more than enough - test $ac_count -gt 10 && break - done - rm -f conftest.in conftest.tmp conftest.nl conftest.out;; -esac - - $ac_path_GREP_found && break 3 - done - done - done -IFS=$as_save_IFS - if test -z "$ac_cv_path_GREP"; then - as_fn_error $? "no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 - fi -else - ac_cv_path_GREP=$GREP -fi - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_GREP" >&5 -$as_echo "$ac_cv_path_GREP" >&6; } - GREP="$ac_cv_path_GREP" - - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for egrep" >&5 -$as_echo_n "checking for egrep... " >&6; } -if ${ac_cv_path_EGREP+:} false; then : - $as_echo_n "(cached) " >&6 -else - if echo a | $GREP -E '(a|b)' >/dev/null 2>&1 - then ac_cv_path_EGREP="$GREP -E" - else - if test -z "$EGREP"; then - ac_path_EGREP_found=false - # Loop through the user's path and test for each of PROGNAME-LIST - as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_prog in egrep; do - for ac_exec_ext in '' $ac_executable_extensions; do - ac_path_EGREP="$as_dir/$ac_prog$ac_exec_ext" - as_fn_executable_p "$ac_path_EGREP" || continue -# Check for GNU ac_path_EGREP and select it if it is found. - # Check for GNU $ac_path_EGREP -case `"$ac_path_EGREP" --version 2>&1` in -*GNU*) - ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_found=:;; -*) - ac_count=0 - $as_echo_n 0123456789 >"conftest.in" - while : - do - cat "conftest.in" "conftest.in" >"conftest.tmp" - mv "conftest.tmp" "conftest.in" - cp "conftest.in" "conftest.nl" - $as_echo 'EGREP' >> "conftest.nl" - "$ac_path_EGREP" 'EGREP$' < "conftest.nl" >"conftest.out" 2>/dev/null || break - diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break - as_fn_arith $ac_count + 1 && ac_count=$as_val - if test $ac_count -gt ${ac_path_EGREP_max-0}; then - # Best one so far, save it but keep looking for a better one - ac_cv_path_EGREP="$ac_path_EGREP" - ac_path_EGREP_max=$ac_count - fi - # 10*(2^10) chars as input seems more than enough - test $ac_count -gt 10 && break - done - rm -f conftest.in conftest.tmp conftest.nl conftest.out;; -esac - - $ac_path_EGREP_found && break 3 - done - done - done -IFS=$as_save_IFS - if test -z "$ac_cv_path_EGREP"; then - as_fn_error $? "no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 - fi -else - ac_cv_path_EGREP=$EGREP -fi - - fi -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_EGREP" >&5 -$as_echo "$ac_cv_path_EGREP" >&6; } - EGREP="$ac_cv_path_EGREP" - - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for ANSI C header files" >&5 -$as_echo_n "checking for ANSI C header files... " >&6; } -if ${ac_cv_header_stdc+:} false; then : - $as_echo_n "(cached) " >&6 -else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext +echo "$as_me:$LINENO: checking for egrep" >&5 +echo $ECHO_N "checking for egrep... $ECHO_C" >&6 +if test "${ac_cv_prog_egrep+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + if echo a | (grep -E '(a|b)') >/dev/null 2>&1 + then ac_cv_prog_egrep='grep -E' + else ac_cv_prog_egrep='egrep' + fi +fi +echo "$as_me:$LINENO: result: $ac_cv_prog_egrep" >&5 +echo "${ECHO_T}$ac_cv_prog_egrep" >&6 + EGREP=$ac_cv_prog_egrep + + +echo "$as_me:$LINENO: checking for ANSI C header files" >&5 +echo $ECHO_N "checking for ANSI C header files... $ECHO_C" >&6 +if test "${ac_cv_header_stdc+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include @@ -3626,60 +2736,95 @@ ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then ac_cv_header_stdc=yes else - ac_cv_header_stdc=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_header_stdc=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext if test $ac_cv_header_stdc = yes; then # SunOS 4.x string.h does not declare mem*, contrary to ANSI. - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - $EGREP "memchr" >/dev/null 2>&1; then : - + $EGREP "memchr" >/dev/null 2>&1; then + : else ac_cv_header_stdc=no fi rm -f conftest* fi if test $ac_cv_header_stdc = yes; then # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - $EGREP "free" >/dev/null 2>&1; then : - + $EGREP "free" >/dev/null 2>&1; then + : else ac_cv_header_stdc=no fi rm -f conftest* fi if test $ac_cv_header_stdc = yes; then # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. - if test "$cross_compiling" = yes; then : + if test "$cross_compiling" = yes; then : else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include -#include #if ((' ' & 0x0FF) == 0x020) # define ISLOWER(c) ('a' <= (c) && (c) <= 'z') # define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) #else # define ISLOWER(c) \ @@ -3695,58 +2840,132 @@ { int i; for (i = 0; i < 256; i++) if (XOR (islower (i), ISLOWER (i)) || toupper (i) != TOUPPER (i)) - return 2; - return 0; + exit(2); + exit (0); } _ACEOF -if ac_fn_c_try_run "$LINENO"; then : - -else - ac_cv_header_stdc=no -fi -rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ - conftest.$ac_objext conftest.beam conftest.$ac_ext -fi - -fi -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_header_stdc" >&5 -$as_echo "$ac_cv_header_stdc" >&6; } -if test $ac_cv_header_stdc = yes; then - -$as_echo "#define STDC_HEADERS 1" >>confdefs.h +rm -f conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { ac_try='./conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + : +else + echo "$as_me: program exited with status $ac_status" >&5 +echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +( exit $ac_status ) +ac_cv_header_stdc=no +fi +rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext +fi +fi +fi +echo "$as_me:$LINENO: result: $ac_cv_header_stdc" >&5 +echo "${ECHO_T}$ac_cv_header_stdc" >&6 +if test $ac_cv_header_stdc = yes; then + +cat >>confdefs.h <<\_ACEOF +#define STDC_HEADERS 1 +_ACEOF fi # On IRIX 5.3, sys/types and inttypes.h are conflicting. + + + + + + + + + for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \ inttypes.h stdint.h unistd.h -do : - as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` -ac_fn_c_check_header_compile "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default -" -if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : +do +as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` +echo "$as_me:$LINENO: checking for $ac_header" >&5 +echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default + +#include <$ac_header> +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + eval "$as_ac_Header=yes" +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +eval "$as_ac_Header=no" +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 +if test `eval echo '${'$as_ac_Header'}'` = yes; then cat >>confdefs.h <<_ACEOF -#define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 +#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done - { $as_echo "$as_me:${as_lineno-$LINENO}: checking dirent.h" >&5 -$as_echo_n "checking dirent.h... " >&6; } -if ${tcl_cv_dirent_h+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking dirent.h" >&5 +echo $ECHO_N "checking dirent.h... $ECHO_C" >&6 +if test "${tcl_cv_dirent_h+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () @@ -3772,108 +2991,724 @@ ; return 0; } _ACEOF -if ac_fn_c_try_link "$LINENO"; then : - tcl_cv_dirent_h=yes -else - tcl_cv_dirent_h=no -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_dirent_h" >&5 -$as_echo "$tcl_cv_dirent_h" >&6; } - - if test $tcl_cv_dirent_h = no; then - -$as_echo "#define NO_DIRENT_H 1" >>confdefs.h - - fi - - ac_fn_c_check_header_mongrel "$LINENO" "stdlib.h" "ac_cv_header_stdlib_h" "$ac_includes_default" -if test "x$ac_cv_header_stdlib_h" = xyes; then : - tcl_ok=1 -else - tcl_ok=0 -fi - - - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include - -_ACEOF -if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - $EGREP "strtol" >/dev/null 2>&1; then : - -else - tcl_ok=0 -fi -rm -f conftest* - - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include - -_ACEOF -if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - $EGREP "strtoul" >/dev/null 2>&1; then : - -else - tcl_ok=0 -fi -rm -f conftest* - - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include - -_ACEOF -if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - $EGREP "strtod" >/dev/null 2>&1; then : - +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + tcl_cv_dirent_h=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_dirent_h=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $tcl_cv_dirent_h" >&5 +echo "${ECHO_T}$tcl_cv_dirent_h" >&6 + + if test $tcl_cv_dirent_h = no; then + +cat >>confdefs.h <<\_ACEOF +#define NO_DIRENT_H 1 +_ACEOF + + fi + + if test "${ac_cv_header_float_h+set}" = set; then + echo "$as_me:$LINENO: checking for float.h" >&5 +echo $ECHO_N "checking for float.h... $ECHO_C" >&6 +if test "${ac_cv_header_float_h+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +fi +echo "$as_me:$LINENO: result: $ac_cv_header_float_h" >&5 +echo "${ECHO_T}$ac_cv_header_float_h" >&6 +else + # Is the header compilable? +echo "$as_me:$LINENO: checking float.h usability" >&5 +echo $ECHO_N "checking float.h usability... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +#include +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_header_compiler=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_header_compiler=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 +echo "${ECHO_T}$ac_header_compiler" >&6 + +# Is the header present? +echo "$as_me:$LINENO: checking float.h presence" >&5 +echo $ECHO_N "checking float.h presence... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include +_ACEOF +if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 + (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null; then + if test -s conftest.err; then + ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag + else + ac_cpp_err= + fi +else + ac_cpp_err=yes +fi +if test -z "$ac_cpp_err"; then + ac_header_preproc=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_header_preproc=no +fi +rm -f conftest.err conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 +echo "${ECHO_T}$ac_header_preproc" >&6 + +# So? What about this header? +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) + { echo "$as_me:$LINENO: WARNING: float.h: accepted by the compiler, rejected by the preprocessor!" >&5 +echo "$as_me: WARNING: float.h: accepted by the compiler, rejected by the preprocessor!" >&2;} + { echo "$as_me:$LINENO: WARNING: float.h: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: float.h: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes + ;; + no:yes:* ) + { echo "$as_me:$LINENO: WARNING: float.h: present but cannot be compiled" >&5 +echo "$as_me: WARNING: float.h: present but cannot be compiled" >&2;} + { echo "$as_me:$LINENO: WARNING: float.h: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: float.h: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: float.h: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: float.h: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: float.h: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: float.h: section \"Present But Cannot Be Compiled\"" >&2;} + { echo "$as_me:$LINENO: WARNING: float.h: proceeding with the preprocessor's result" >&5 +echo "$as_me: WARNING: float.h: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: float.h: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: float.h: in the future, the compiler will take precedence" >&2;} + ( + cat <<\_ASBOX +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## +_ASBOX + ) | + sed "s/^/$as_me: WARNING: /" >&2 + ;; +esac +echo "$as_me:$LINENO: checking for float.h" >&5 +echo $ECHO_N "checking for float.h... $ECHO_C" >&6 +if test "${ac_cv_header_float_h+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_cv_header_float_h=$ac_header_preproc +fi +echo "$as_me:$LINENO: result: $ac_cv_header_float_h" >&5 +echo "${ECHO_T}$ac_cv_header_float_h" >&6 + +fi +if test $ac_cv_header_float_h = yes; then + : +else + +cat >>confdefs.h <<\_ACEOF +#define NO_FLOAT_H 1 +_ACEOF + +fi + + + if test "${ac_cv_header_values_h+set}" = set; then + echo "$as_me:$LINENO: checking for values.h" >&5 +echo $ECHO_N "checking for values.h... $ECHO_C" >&6 +if test "${ac_cv_header_values_h+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +fi +echo "$as_me:$LINENO: result: $ac_cv_header_values_h" >&5 +echo "${ECHO_T}$ac_cv_header_values_h" >&6 +else + # Is the header compilable? +echo "$as_me:$LINENO: checking values.h usability" >&5 +echo $ECHO_N "checking values.h usability... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +#include +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_header_compiler=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_header_compiler=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 +echo "${ECHO_T}$ac_header_compiler" >&6 + +# Is the header present? +echo "$as_me:$LINENO: checking values.h presence" >&5 +echo $ECHO_N "checking values.h presence... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include +_ACEOF +if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 + (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null; then + if test -s conftest.err; then + ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag + else + ac_cpp_err= + fi +else + ac_cpp_err=yes +fi +if test -z "$ac_cpp_err"; then + ac_header_preproc=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_header_preproc=no +fi +rm -f conftest.err conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 +echo "${ECHO_T}$ac_header_preproc" >&6 + +# So? What about this header? +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) + { echo "$as_me:$LINENO: WARNING: values.h: accepted by the compiler, rejected by the preprocessor!" >&5 +echo "$as_me: WARNING: values.h: accepted by the compiler, rejected by the preprocessor!" >&2;} + { echo "$as_me:$LINENO: WARNING: values.h: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: values.h: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes + ;; + no:yes:* ) + { echo "$as_me:$LINENO: WARNING: values.h: present but cannot be compiled" >&5 +echo "$as_me: WARNING: values.h: present but cannot be compiled" >&2;} + { echo "$as_me:$LINENO: WARNING: values.h: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: values.h: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: values.h: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: values.h: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: values.h: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: values.h: section \"Present But Cannot Be Compiled\"" >&2;} + { echo "$as_me:$LINENO: WARNING: values.h: proceeding with the preprocessor's result" >&5 +echo "$as_me: WARNING: values.h: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: values.h: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: values.h: in the future, the compiler will take precedence" >&2;} + ( + cat <<\_ASBOX +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## +_ASBOX + ) | + sed "s/^/$as_me: WARNING: /" >&2 + ;; +esac +echo "$as_me:$LINENO: checking for values.h" >&5 +echo $ECHO_N "checking for values.h... $ECHO_C" >&6 +if test "${ac_cv_header_values_h+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_cv_header_values_h=$ac_header_preproc +fi +echo "$as_me:$LINENO: result: $ac_cv_header_values_h" >&5 +echo "${ECHO_T}$ac_cv_header_values_h" >&6 + +fi +if test $ac_cv_header_values_h = yes; then + : +else + +cat >>confdefs.h <<\_ACEOF +#define NO_VALUES_H 1 +_ACEOF + +fi + + + if test "${ac_cv_header_stdlib_h+set}" = set; then + echo "$as_me:$LINENO: checking for stdlib.h" >&5 +echo $ECHO_N "checking for stdlib.h... $ECHO_C" >&6 +if test "${ac_cv_header_stdlib_h+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +fi +echo "$as_me:$LINENO: result: $ac_cv_header_stdlib_h" >&5 +echo "${ECHO_T}$ac_cv_header_stdlib_h" >&6 +else + # Is the header compilable? +echo "$as_me:$LINENO: checking stdlib.h usability" >&5 +echo $ECHO_N "checking stdlib.h usability... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +#include +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_header_compiler=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_header_compiler=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 +echo "${ECHO_T}$ac_header_compiler" >&6 + +# Is the header present? +echo "$as_me:$LINENO: checking stdlib.h presence" >&5 +echo $ECHO_N "checking stdlib.h presence... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include +_ACEOF +if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 + (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null; then + if test -s conftest.err; then + ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag + else + ac_cpp_err= + fi +else + ac_cpp_err=yes +fi +if test -z "$ac_cpp_err"; then + ac_header_preproc=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_header_preproc=no +fi +rm -f conftest.err conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 +echo "${ECHO_T}$ac_header_preproc" >&6 + +# So? What about this header? +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) + { echo "$as_me:$LINENO: WARNING: stdlib.h: accepted by the compiler, rejected by the preprocessor!" >&5 +echo "$as_me: WARNING: stdlib.h: accepted by the compiler, rejected by the preprocessor!" >&2;} + { echo "$as_me:$LINENO: WARNING: stdlib.h: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: stdlib.h: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes + ;; + no:yes:* ) + { echo "$as_me:$LINENO: WARNING: stdlib.h: present but cannot be compiled" >&5 +echo "$as_me: WARNING: stdlib.h: present but cannot be compiled" >&2;} + { echo "$as_me:$LINENO: WARNING: stdlib.h: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: stdlib.h: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: stdlib.h: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: stdlib.h: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: stdlib.h: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: stdlib.h: section \"Present But Cannot Be Compiled\"" >&2;} + { echo "$as_me:$LINENO: WARNING: stdlib.h: proceeding with the preprocessor's result" >&5 +echo "$as_me: WARNING: stdlib.h: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: stdlib.h: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: stdlib.h: in the future, the compiler will take precedence" >&2;} + ( + cat <<\_ASBOX +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## +_ASBOX + ) | + sed "s/^/$as_me: WARNING: /" >&2 + ;; +esac +echo "$as_me:$LINENO: checking for stdlib.h" >&5 +echo $ECHO_N "checking for stdlib.h... $ECHO_C" >&6 +if test "${ac_cv_header_stdlib_h+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_cv_header_stdlib_h=$ac_header_preproc +fi +echo "$as_me:$LINENO: result: $ac_cv_header_stdlib_h" >&5 +echo "${ECHO_T}$ac_cv_header_stdlib_h" >&6 + +fi +if test $ac_cv_header_stdlib_h = yes; then + tcl_ok=1 +else + tcl_ok=0 +fi + + + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "strtol" >/dev/null 2>&1; then + : +else + tcl_ok=0 +fi +rm -f conftest* + + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "strtoul" >/dev/null 2>&1; then + : +else + tcl_ok=0 +fi +rm -f conftest* + + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "strtod" >/dev/null 2>&1; then + : else tcl_ok=0 fi rm -f conftest* if test $tcl_ok = 0; then -$as_echo "#define NO_STDLIB_H 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define NO_STDLIB_H 1 +_ACEOF fi - ac_fn_c_check_header_mongrel "$LINENO" "string.h" "ac_cv_header_string_h" "$ac_includes_default" -if test "x$ac_cv_header_string_h" = xyes; then : + if test "${ac_cv_header_string_h+set}" = set; then + echo "$as_me:$LINENO: checking for string.h" >&5 +echo $ECHO_N "checking for string.h... $ECHO_C" >&6 +if test "${ac_cv_header_string_h+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +fi +echo "$as_me:$LINENO: result: $ac_cv_header_string_h" >&5 +echo "${ECHO_T}$ac_cv_header_string_h" >&6 +else + # Is the header compilable? +echo "$as_me:$LINENO: checking string.h usability" >&5 +echo $ECHO_N "checking string.h usability... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +#include +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_header_compiler=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_header_compiler=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 +echo "${ECHO_T}$ac_header_compiler" >&6 + +# Is the header present? +echo "$as_me:$LINENO: checking string.h presence" >&5 +echo $ECHO_N "checking string.h presence... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include +_ACEOF +if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 + (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null; then + if test -s conftest.err; then + ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag + else + ac_cpp_err= + fi +else + ac_cpp_err=yes +fi +if test -z "$ac_cpp_err"; then + ac_header_preproc=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_header_preproc=no +fi +rm -f conftest.err conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 +echo "${ECHO_T}$ac_header_preproc" >&6 + +# So? What about this header? +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) + { echo "$as_me:$LINENO: WARNING: string.h: accepted by the compiler, rejected by the preprocessor!" >&5 +echo "$as_me: WARNING: string.h: accepted by the compiler, rejected by the preprocessor!" >&2;} + { echo "$as_me:$LINENO: WARNING: string.h: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: string.h: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes + ;; + no:yes:* ) + { echo "$as_me:$LINENO: WARNING: string.h: present but cannot be compiled" >&5 +echo "$as_me: WARNING: string.h: present but cannot be compiled" >&2;} + { echo "$as_me:$LINENO: WARNING: string.h: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: string.h: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: string.h: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: string.h: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: string.h: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: string.h: section \"Present But Cannot Be Compiled\"" >&2;} + { echo "$as_me:$LINENO: WARNING: string.h: proceeding with the preprocessor's result" >&5 +echo "$as_me: WARNING: string.h: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: string.h: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: string.h: in the future, the compiler will take precedence" >&2;} + ( + cat <<\_ASBOX +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## +_ASBOX + ) | + sed "s/^/$as_me: WARNING: /" >&2 + ;; +esac +echo "$as_me:$LINENO: checking for string.h" >&5 +echo $ECHO_N "checking for string.h... $ECHO_C" >&6 +if test "${ac_cv_header_string_h+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_cv_header_string_h=$ac_header_preproc +fi +echo "$as_me:$LINENO: result: $ac_cv_header_string_h" >&5 +echo "${ECHO_T}$ac_cv_header_string_h" >&6 + +fi +if test $ac_cv_header_string_h = yes; then tcl_ok=1 else tcl_ok=0 fi - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - $EGREP "strstr" >/dev/null 2>&1; then : - + $EGREP "strstr" >/dev/null 2>&1; then + : else tcl_ok=0 fi rm -f conftest* - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - $EGREP "strerror" >/dev/null 2>&1; then : - + $EGREP "strerror" >/dev/null 2>&1; then + : else tcl_ok=0 fi rm -f conftest* @@ -3881,42 +3716,458 @@ # See also memmove check below for a place where NO_STRING_H can be # set and why. if test $tcl_ok = 0; then -$as_echo "#define NO_STRING_H 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define NO_STRING_H 1 +_ACEOF fi - ac_fn_c_check_header_mongrel "$LINENO" "sys/wait.h" "ac_cv_header_sys_wait_h" "$ac_includes_default" -if test "x$ac_cv_header_sys_wait_h" = xyes; then : - -else - -$as_echo "#define NO_SYS_WAIT_H 1" >>confdefs.h - -fi - - - ac_fn_c_check_header_mongrel "$LINENO" "dlfcn.h" "ac_cv_header_dlfcn_h" "$ac_includes_default" -if test "x$ac_cv_header_dlfcn_h" = xyes; then : - -else - -$as_echo "#define NO_DLFCN_H 1" >>confdefs.h + if test "${ac_cv_header_sys_wait_h+set}" = set; then + echo "$as_me:$LINENO: checking for sys/wait.h" >&5 +echo $ECHO_N "checking for sys/wait.h... $ECHO_C" >&6 +if test "${ac_cv_header_sys_wait_h+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +fi +echo "$as_me:$LINENO: result: $ac_cv_header_sys_wait_h" >&5 +echo "${ECHO_T}$ac_cv_header_sys_wait_h" >&6 +else + # Is the header compilable? +echo "$as_me:$LINENO: checking sys/wait.h usability" >&5 +echo $ECHO_N "checking sys/wait.h usability... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +#include +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_header_compiler=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_header_compiler=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 +echo "${ECHO_T}$ac_header_compiler" >&6 + +# Is the header present? +echo "$as_me:$LINENO: checking sys/wait.h presence" >&5 +echo $ECHO_N "checking sys/wait.h presence... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include +_ACEOF +if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 + (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null; then + if test -s conftest.err; then + ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag + else + ac_cpp_err= + fi +else + ac_cpp_err=yes +fi +if test -z "$ac_cpp_err"; then + ac_header_preproc=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_header_preproc=no +fi +rm -f conftest.err conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 +echo "${ECHO_T}$ac_header_preproc" >&6 + +# So? What about this header? +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) + { echo "$as_me:$LINENO: WARNING: sys/wait.h: accepted by the compiler, rejected by the preprocessor!" >&5 +echo "$as_me: WARNING: sys/wait.h: accepted by the compiler, rejected by the preprocessor!" >&2;} + { echo "$as_me:$LINENO: WARNING: sys/wait.h: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: sys/wait.h: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes + ;; + no:yes:* ) + { echo "$as_me:$LINENO: WARNING: sys/wait.h: present but cannot be compiled" >&5 +echo "$as_me: WARNING: sys/wait.h: present but cannot be compiled" >&2;} + { echo "$as_me:$LINENO: WARNING: sys/wait.h: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: sys/wait.h: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: sys/wait.h: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: sys/wait.h: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: sys/wait.h: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: sys/wait.h: section \"Present But Cannot Be Compiled\"" >&2;} + { echo "$as_me:$LINENO: WARNING: sys/wait.h: proceeding with the preprocessor's result" >&5 +echo "$as_me: WARNING: sys/wait.h: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: sys/wait.h: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: sys/wait.h: in the future, the compiler will take precedence" >&2;} + ( + cat <<\_ASBOX +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## +_ASBOX + ) | + sed "s/^/$as_me: WARNING: /" >&2 + ;; +esac +echo "$as_me:$LINENO: checking for sys/wait.h" >&5 +echo $ECHO_N "checking for sys/wait.h... $ECHO_C" >&6 +if test "${ac_cv_header_sys_wait_h+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_cv_header_sys_wait_h=$ac_header_preproc +fi +echo "$as_me:$LINENO: result: $ac_cv_header_sys_wait_h" >&5 +echo "${ECHO_T}$ac_cv_header_sys_wait_h" >&6 + +fi +if test $ac_cv_header_sys_wait_h = yes; then + : +else + +cat >>confdefs.h <<\_ACEOF +#define NO_SYS_WAIT_H 1 +_ACEOF + +fi + + + if test "${ac_cv_header_dlfcn_h+set}" = set; then + echo "$as_me:$LINENO: checking for dlfcn.h" >&5 +echo $ECHO_N "checking for dlfcn.h... $ECHO_C" >&6 +if test "${ac_cv_header_dlfcn_h+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +fi +echo "$as_me:$LINENO: result: $ac_cv_header_dlfcn_h" >&5 +echo "${ECHO_T}$ac_cv_header_dlfcn_h" >&6 +else + # Is the header compilable? +echo "$as_me:$LINENO: checking dlfcn.h usability" >&5 +echo $ECHO_N "checking dlfcn.h usability... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +#include +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_header_compiler=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_header_compiler=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 +echo "${ECHO_T}$ac_header_compiler" >&6 + +# Is the header present? +echo "$as_me:$LINENO: checking dlfcn.h presence" >&5 +echo $ECHO_N "checking dlfcn.h presence... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include +_ACEOF +if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 + (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null; then + if test -s conftest.err; then + ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag + else + ac_cpp_err= + fi +else + ac_cpp_err=yes +fi +if test -z "$ac_cpp_err"; then + ac_header_preproc=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_header_preproc=no +fi +rm -f conftest.err conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 +echo "${ECHO_T}$ac_header_preproc" >&6 + +# So? What about this header? +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) + { echo "$as_me:$LINENO: WARNING: dlfcn.h: accepted by the compiler, rejected by the preprocessor!" >&5 +echo "$as_me: WARNING: dlfcn.h: accepted by the compiler, rejected by the preprocessor!" >&2;} + { echo "$as_me:$LINENO: WARNING: dlfcn.h: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: dlfcn.h: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes + ;; + no:yes:* ) + { echo "$as_me:$LINENO: WARNING: dlfcn.h: present but cannot be compiled" >&5 +echo "$as_me: WARNING: dlfcn.h: present but cannot be compiled" >&2;} + { echo "$as_me:$LINENO: WARNING: dlfcn.h: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: dlfcn.h: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: dlfcn.h: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: dlfcn.h: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: dlfcn.h: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: dlfcn.h: section \"Present But Cannot Be Compiled\"" >&2;} + { echo "$as_me:$LINENO: WARNING: dlfcn.h: proceeding with the preprocessor's result" >&5 +echo "$as_me: WARNING: dlfcn.h: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: dlfcn.h: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: dlfcn.h: in the future, the compiler will take precedence" >&2;} + ( + cat <<\_ASBOX +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## +_ASBOX + ) | + sed "s/^/$as_me: WARNING: /" >&2 + ;; +esac +echo "$as_me:$LINENO: checking for dlfcn.h" >&5 +echo $ECHO_N "checking for dlfcn.h... $ECHO_C" >&6 +if test "${ac_cv_header_dlfcn_h+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_cv_header_dlfcn_h=$ac_header_preproc +fi +echo "$as_me:$LINENO: result: $ac_cv_header_dlfcn_h" >&5 +echo "${ECHO_T}$ac_cv_header_dlfcn_h" >&6 + +fi +if test $ac_cv_header_dlfcn_h = yes; then + : +else + +cat >>confdefs.h <<\_ACEOF +#define NO_DLFCN_H 1 +_ACEOF fi # OS/390 lacks sys/param.h (and doesn't need it, by chance). - for ac_header in sys/param.h -do : - ac_fn_c_check_header_mongrel "$LINENO" "sys/param.h" "ac_cv_header_sys_param_h" "$ac_includes_default" -if test "x$ac_cv_header_sys_param_h" = xyes; then : + +for ac_header in sys/param.h +do +as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo "$as_me:$LINENO: checking for $ac_header" >&5 +echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 +else + # Is the header compilable? +echo "$as_me:$LINENO: checking $ac_header usability" >&5 +echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +#include <$ac_header> +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_header_compiler=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_header_compiler=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 +echo "${ECHO_T}$ac_header_compiler" >&6 + +# Is the header present? +echo "$as_me:$LINENO: checking $ac_header presence" >&5 +echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include <$ac_header> +_ACEOF +if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 + (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null; then + if test -s conftest.err; then + ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag + else + ac_cpp_err= + fi +else + ac_cpp_err=yes +fi +if test -z "$ac_cpp_err"; then + ac_header_preproc=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_header_preproc=no +fi +rm -f conftest.err conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 +echo "${ECHO_T}$ac_header_preproc" >&6 + +# So? What about this header? +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) + { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 +echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes + ;; + no:yes:* ) + { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 +echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 +echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} + ( + cat <<\_ASBOX +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## +_ASBOX + ) | + sed "s/^/$as_me: WARNING: /" >&2 + ;; +esac +echo "$as_me:$LINENO: checking for $ac_header" >&5 +echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + eval "$as_ac_Header=\$ac_header_preproc" +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 + +fi +if test `eval echo '${'$as_ac_Header'}'` = yes; then cat >>confdefs.h <<_ACEOF -#define HAVE_SYS_PARAM_H 1 +#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done @@ -3933,18 +4184,22 @@ # If we're using GCC, see if the compiler understands -pipe. If so, use it. # It makes compiling go faster. (This is only a performance feature.) #------------------------------------------------------------------------ if test -z "$no_pipe" && test -n "$GCC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: checking if the compiler understands -pipe" >&5 -$as_echo_n "checking if the compiler understands -pipe... " >&6; } -if ${tcl_cv_cc_pipe+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking if the compiler understands -pipe" >&5 +echo $ECHO_N "checking if the compiler understands -pipe... $ECHO_C" >&6 +if test "${tcl_cv_cc_pipe+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -pipe" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { @@ -3951,46 +4206,630 @@ ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_cc_pipe=yes else - tcl_cv_cc_pipe=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_cc_pipe=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext CFLAGS=$hold_cflags fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_pipe" >&5 -$as_echo "$tcl_cv_cc_pipe" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_cc_pipe" >&5 +echo "${ECHO_T}$tcl_cv_cc_pipe" >&6 if test $tcl_cv_cc_pipe = yes; then CFLAGS="$CFLAGS -pipe" fi fi + +#------------------------------------------------------------------------ +# Threads support +#------------------------------------------------------------------------ + + + # Check whether --enable-threads or --disable-threads was given. +if test "${enable_threads+set}" = set; then + enableval="$enable_threads" + tcl_ok=$enableval +else + tcl_ok=yes +fi; + + if test "${TCL_THREADS}" = 1; then + tcl_threaded_core=1; + fi + + if test "$tcl_ok" = "yes" -o "${TCL_THREADS}" = 1; then + TCL_THREADS=1 + # USE_THREAD_ALLOC tells us to try the special thread-based + # allocator that significantly reduces lock contention + +cat >>confdefs.h <<\_ACEOF +#define USE_THREAD_ALLOC 1 +_ACEOF + + +cat >>confdefs.h <<\_ACEOF +#define _REENTRANT 1 +_ACEOF + + if test "`uname -s`" = "SunOS" ; then + +cat >>confdefs.h <<\_ACEOF +#define _POSIX_PTHREAD_SEMANTICS 1 +_ACEOF + + fi + +cat >>confdefs.h <<\_ACEOF +#define _THREAD_SAFE 1 +_ACEOF + + echo "$as_me:$LINENO: checking for pthread_mutex_init in -lpthread" >&5 +echo $ECHO_N "checking for pthread_mutex_init in -lpthread... $ECHO_C" >&6 +if test "${ac_cv_lib_pthread_pthread_mutex_init+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lpthread $LIBS" +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char pthread_mutex_init (); +int +main () +{ +pthread_mutex_init (); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_lib_pthread_pthread_mutex_init=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_lib_pthread_pthread_mutex_init=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +echo "$as_me:$LINENO: result: $ac_cv_lib_pthread_pthread_mutex_init" >&5 +echo "${ECHO_T}$ac_cv_lib_pthread_pthread_mutex_init" >&6 +if test $ac_cv_lib_pthread_pthread_mutex_init = yes; then + tcl_ok=yes +else + tcl_ok=no +fi + + if test "$tcl_ok" = "no"; then + # Check a little harder for __pthread_mutex_init in the same + # library, as some systems hide it there until pthread.h is + # defined. We could alternatively do an AC_TRY_COMPILE with + # pthread.h, but that will work with libpthread really doesn't + # exist, like AIX 4.2. [Bug: 4359] + echo "$as_me:$LINENO: checking for __pthread_mutex_init in -lpthread" >&5 +echo $ECHO_N "checking for __pthread_mutex_init in -lpthread... $ECHO_C" >&6 +if test "${ac_cv_lib_pthread___pthread_mutex_init+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lpthread $LIBS" +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char __pthread_mutex_init (); +int +main () +{ +__pthread_mutex_init (); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_lib_pthread___pthread_mutex_init=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_lib_pthread___pthread_mutex_init=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +echo "$as_me:$LINENO: result: $ac_cv_lib_pthread___pthread_mutex_init" >&5 +echo "${ECHO_T}$ac_cv_lib_pthread___pthread_mutex_init" >&6 +if test $ac_cv_lib_pthread___pthread_mutex_init = yes; then + tcl_ok=yes +else + tcl_ok=no +fi + + fi + + if test "$tcl_ok" = "yes"; then + # The space is needed + THREADS_LIBS=" -lpthread" + else + echo "$as_me:$LINENO: checking for pthread_mutex_init in -lpthreads" >&5 +echo $ECHO_N "checking for pthread_mutex_init in -lpthreads... $ECHO_C" >&6 +if test "${ac_cv_lib_pthreads_pthread_mutex_init+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lpthreads $LIBS" +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char pthread_mutex_init (); +int +main () +{ +pthread_mutex_init (); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_lib_pthreads_pthread_mutex_init=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_lib_pthreads_pthread_mutex_init=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +echo "$as_me:$LINENO: result: $ac_cv_lib_pthreads_pthread_mutex_init" >&5 +echo "${ECHO_T}$ac_cv_lib_pthreads_pthread_mutex_init" >&6 +if test $ac_cv_lib_pthreads_pthread_mutex_init = yes; then + tcl_ok=yes +else + tcl_ok=no +fi + + if test "$tcl_ok" = "yes"; then + # The space is needed + THREADS_LIBS=" -lpthreads" + else + echo "$as_me:$LINENO: checking for pthread_mutex_init in -lc" >&5 +echo $ECHO_N "checking for pthread_mutex_init in -lc... $ECHO_C" >&6 +if test "${ac_cv_lib_c_pthread_mutex_init+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lc $LIBS" +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char pthread_mutex_init (); +int +main () +{ +pthread_mutex_init (); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_lib_c_pthread_mutex_init=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_lib_c_pthread_mutex_init=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +echo "$as_me:$LINENO: result: $ac_cv_lib_c_pthread_mutex_init" >&5 +echo "${ECHO_T}$ac_cv_lib_c_pthread_mutex_init" >&6 +if test $ac_cv_lib_c_pthread_mutex_init = yes; then + tcl_ok=yes +else + tcl_ok=no +fi + + if test "$tcl_ok" = "no"; then + echo "$as_me:$LINENO: checking for pthread_mutex_init in -lc_r" >&5 +echo $ECHO_N "checking for pthread_mutex_init in -lc_r... $ECHO_C" >&6 +if test "${ac_cv_lib_c_r_pthread_mutex_init+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lc_r $LIBS" +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char pthread_mutex_init (); +int +main () +{ +pthread_mutex_init (); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_lib_c_r_pthread_mutex_init=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_lib_c_r_pthread_mutex_init=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +echo "$as_me:$LINENO: result: $ac_cv_lib_c_r_pthread_mutex_init" >&5 +echo "${ECHO_T}$ac_cv_lib_c_r_pthread_mutex_init" >&6 +if test $ac_cv_lib_c_r_pthread_mutex_init = yes; then + tcl_ok=yes +else + tcl_ok=no +fi + + if test "$tcl_ok" = "yes"; then + # The space is needed + THREADS_LIBS=" -pthread" + else + TCL_THREADS=0 + { echo "$as_me:$LINENO: WARNING: Don't know how to find pthread lib on your system - you must disable thread support or edit the LIBS in the Makefile..." >&5 +echo "$as_me: WARNING: Don't know how to find pthread lib on your system - you must disable thread support or edit the LIBS in the Makefile..." >&2;} + fi + fi + fi + fi + + # Does the pthread-implementation provide + # 'pthread_attr_setstacksize' ? + + ac_saved_libs=$LIBS + LIBS="$LIBS $THREADS_LIBS" + + +for ac_func in pthread_attr_setstacksize pthread_atfork +do +as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` +echo "$as_me:$LINENO: checking for $ac_func" >&5 +echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 +if eval "test \"\${$as_ac_var+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define $ac_func to an innocuous variant, in case declares $ac_func. + For example, HP-UX 11i declares gettimeofday. */ +#define $ac_func innocuous_$ac_func + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char $ac_func (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef $ac_func + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char $ac_func (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_$ac_func) || defined (__stub___$ac_func) +choke me +#else +char (*f) () = $ac_func; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != $ac_func; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + eval "$as_ac_var=yes" +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +eval "$as_ac_var=no" +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 +if test `eval echo '${'$as_ac_var'}'` = yes; then + cat >>confdefs.h <<_ACEOF +#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 +_ACEOF + +fi +done + + LIBS=$ac_saved_libs + else + TCL_THREADS=0 + fi + # Do checking message here to not mess up interleaved configure output + echo "$as_me:$LINENO: checking for building with threads" >&5 +echo $ECHO_N "checking for building with threads... $ECHO_C" >&6 + if test "${TCL_THREADS}" = 1; then + +cat >>confdefs.h <<\_ACEOF +#define TCL_THREADS 1 +_ACEOF + + if test "${tcl_threaded_core}" = 1; then + echo "$as_me:$LINENO: result: yes (threaded core)" >&5 +echo "${ECHO_T}yes (threaded core)" >&6 + else + echo "$as_me:$LINENO: result: yes" >&5 +echo "${ECHO_T}yes" >&6 + fi + else + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 + fi + + + #------------------------------------------------------------------------ # Embedded configuration information, encoding to use for the values, TIP #59 #------------------------------------------------------------------------ -# Check whether --with-encoding was given. -if test "${with_encoding+set}" = set; then : - withval=$with_encoding; with_tcencoding=${withval} -fi - +# Check whether --with-encoding or --without-encoding was given. +if test "${with_encoding+set}" = set; then + withval="$with_encoding" + with_tcencoding=${withval} +fi; if test x"${with_tcencoding}" != x ; then cat >>confdefs.h <<_ACEOF #define TCL_CFGVAL_ENCODING "${with_tcencoding}" _ACEOF else -$as_echo "#define TCL_CFGVAL_ENCODING \"iso8859-1\"" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define TCL_CFGVAL_ENCODING "iso8859-1" +_ACEOF fi #-------------------------------------------------------------------- @@ -4001,12 +4840,101 @@ #-------------------------------------------------------------------- # On a few very rare systems, all of the libm.a stuff is # already in libc.a. Set compiler flags accordingly. #-------------------------------------------------------------------- - ac_fn_c_check_func "$LINENO" "sin" "ac_cv_func_sin" -if test "x$ac_cv_func_sin" = xyes; then : + echo "$as_me:$LINENO: checking for sin" >&5 +echo $ECHO_N "checking for sin... $ECHO_C" >&6 +if test "${ac_cv_func_sin+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define sin to an innocuous variant, in case declares sin. + For example, HP-UX 11i declares gettimeofday. */ +#define sin innocuous_sin + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char sin (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef sin + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char sin (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_sin) || defined (__stub___sin) +choke me +#else +char (*f) () = sin; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != sin; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_func_sin=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_func_sin=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_func_sin" >&5 +echo "${ECHO_T}$ac_cv_func_sin" >&6 +if test $ac_cv_func_sin = yes; then MATH_LIBS="" else MATH_LIBS="-lm" fi @@ -4014,49 +4942,215 @@ #-------------------------------------------------------------------- # Interactive UNIX requires -linet instead of -lsocket, plus it # needs net/errno.h to define the socket-related error codes. #-------------------------------------------------------------------- - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for main in -linet" >&5 -$as_echo_n "checking for main in -linet... " >&6; } -if ${ac_cv_lib_inet_main+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking for main in -linet" >&5 +echo $ECHO_N "checking for main in -linet... $ECHO_C" >&6 +if test "${ac_cv_lib_inet_main+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-linet $LIBS" -cat confdefs.h - <<_ACEOF >conftest.$ac_ext +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { -return main (); +main (); ; return 0; } _ACEOF -if ac_fn_c_try_link "$LINENO"; then : +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then ac_cv_lib_inet_main=yes else - ac_cv_lib_inet_main=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_lib_inet_main=no fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_inet_main" >&5 -$as_echo "$ac_cv_lib_inet_main" >&6; } -if test "x$ac_cv_lib_inet_main" = xyes; then : +echo "$as_me:$LINENO: result: $ac_cv_lib_inet_main" >&5 +echo "${ECHO_T}$ac_cv_lib_inet_main" >&6 +if test $ac_cv_lib_inet_main = yes; then LIBS="$LIBS -linet" fi - ac_fn_c_check_header_mongrel "$LINENO" "net/errno.h" "ac_cv_header_net_errno_h" "$ac_includes_default" -if test "x$ac_cv_header_net_errno_h" = xyes; then : + if test "${ac_cv_header_net_errno_h+set}" = set; then + echo "$as_me:$LINENO: checking for net/errno.h" >&5 +echo $ECHO_N "checking for net/errno.h... $ECHO_C" >&6 +if test "${ac_cv_header_net_errno_h+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +fi +echo "$as_me:$LINENO: result: $ac_cv_header_net_errno_h" >&5 +echo "${ECHO_T}$ac_cv_header_net_errno_h" >&6 +else + # Is the header compilable? +echo "$as_me:$LINENO: checking net/errno.h usability" >&5 +echo $ECHO_N "checking net/errno.h usability... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +#include +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_header_compiler=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_header_compiler=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 +echo "${ECHO_T}$ac_header_compiler" >&6 + +# Is the header present? +echo "$as_me:$LINENO: checking net/errno.h presence" >&5 +echo $ECHO_N "checking net/errno.h presence... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include +_ACEOF +if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 + (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null; then + if test -s conftest.err; then + ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag + else + ac_cpp_err= + fi +else + ac_cpp_err=yes +fi +if test -z "$ac_cpp_err"; then + ac_header_preproc=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_header_preproc=no +fi +rm -f conftest.err conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 +echo "${ECHO_T}$ac_header_preproc" >&6 + +# So? What about this header? +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) + { echo "$as_me:$LINENO: WARNING: net/errno.h: accepted by the compiler, rejected by the preprocessor!" >&5 +echo "$as_me: WARNING: net/errno.h: accepted by the compiler, rejected by the preprocessor!" >&2;} + { echo "$as_me:$LINENO: WARNING: net/errno.h: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: net/errno.h: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes + ;; + no:yes:* ) + { echo "$as_me:$LINENO: WARNING: net/errno.h: present but cannot be compiled" >&5 +echo "$as_me: WARNING: net/errno.h: present but cannot be compiled" >&2;} + { echo "$as_me:$LINENO: WARNING: net/errno.h: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: net/errno.h: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: net/errno.h: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: net/errno.h: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: net/errno.h: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: net/errno.h: section \"Present But Cannot Be Compiled\"" >&2;} + { echo "$as_me:$LINENO: WARNING: net/errno.h: proceeding with the preprocessor's result" >&5 +echo "$as_me: WARNING: net/errno.h: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: net/errno.h: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: net/errno.h: in the future, the compiler will take precedence" >&2;} + ( + cat <<\_ASBOX +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## +_ASBOX + ) | + sed "s/^/$as_me: WARNING: /" >&2 + ;; +esac +echo "$as_me:$LINENO: checking for net/errno.h" >&5 +echo $ECHO_N "checking for net/errno.h... $ECHO_C" >&6 +if test "${ac_cv_header_net_errno_h+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_cv_header_net_errno_h=$ac_header_preproc +fi +echo "$as_me:$LINENO: result: $ac_cv_header_net_errno_h" >&5 +echo "${ECHO_T}$ac_cv_header_net_errno_h" >&6 + +fi +if test $ac_cv_header_net_errno_h = yes; then -$as_echo "#define HAVE_NET_ERRNO_H 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_NET_ERRNO_H 1 +_ACEOF fi @@ -4077,59 +5171,265 @@ # To get around this problem, check for both libraries together # if -lsocket doesn't work by itself. #-------------------------------------------------------------------- tcl_checkBoth=0 - ac_fn_c_check_func "$LINENO" "connect" "ac_cv_func_connect" -if test "x$ac_cv_func_connect" = xyes; then : + echo "$as_me:$LINENO: checking for connect" >&5 +echo $ECHO_N "checking for connect... $ECHO_C" >&6 +if test "${ac_cv_func_connect+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define connect to an innocuous variant, in case declares connect. + For example, HP-UX 11i declares gettimeofday. */ +#define connect innocuous_connect + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char connect (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef connect + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char connect (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_connect) || defined (__stub___connect) +choke me +#else +char (*f) () = connect; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != connect; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_func_connect=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_func_connect=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_func_connect" >&5 +echo "${ECHO_T}$ac_cv_func_connect" >&6 +if test $ac_cv_func_connect = yes; then tcl_checkSocket=0 else tcl_checkSocket=1 fi if test "$tcl_checkSocket" = 1; then - ac_fn_c_check_func "$LINENO" "setsockopt" "ac_cv_func_setsockopt" -if test "x$ac_cv_func_setsockopt" = xyes; then : - -else - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for setsockopt in -lsocket" >&5 -$as_echo_n "checking for setsockopt in -lsocket... " >&6; } -if ${ac_cv_lib_socket_setsockopt+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking for setsockopt" >&5 +echo $ECHO_N "checking for setsockopt... $ECHO_C" >&6 +if test "${ac_cv_func_setsockopt+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define setsockopt to an innocuous variant, in case declares setsockopt. + For example, HP-UX 11i declares gettimeofday. */ +#define setsockopt innocuous_setsockopt + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char setsockopt (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef setsockopt + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char setsockopt (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_setsockopt) || defined (__stub___setsockopt) +choke me +#else +char (*f) () = setsockopt; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != setsockopt; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_func_setsockopt=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_func_setsockopt=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_func_setsockopt" >&5 +echo "${ECHO_T}$ac_cv_func_setsockopt" >&6 +if test $ac_cv_func_setsockopt = yes; then + : +else + echo "$as_me:$LINENO: checking for setsockopt in -lsocket" >&5 +echo $ECHO_N "checking for setsockopt in -lsocket... $ECHO_C" >&6 +if test "${ac_cv_lib_socket_setsockopt+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lsocket $LIBS" -cat confdefs.h - <<_ACEOF >conftest.$ac_ext +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ +/* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ char setsockopt (); int main () { -return setsockopt (); +setsockopt (); ; return 0; } _ACEOF -if ac_fn_c_try_link "$LINENO"; then : +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then ac_cv_lib_socket_setsockopt=yes else - ac_cv_lib_socket_setsockopt=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_lib_socket_setsockopt=no fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_socket_setsockopt" >&5 -$as_echo "$ac_cv_lib_socket_setsockopt" >&6; } -if test "x$ac_cv_lib_socket_setsockopt" = xyes; then : +echo "$as_me:$LINENO: result: $ac_cv_lib_socket_setsockopt" >&5 +echo "${ECHO_T}$ac_cv_lib_socket_setsockopt" >&6 +if test $ac_cv_lib_socket_setsockopt = yes; then LIBS="$LIBS -lsocket" else tcl_checkBoth=1 fi @@ -4137,395 +5437,320 @@ fi if test "$tcl_checkBoth" = 1; then tk_oldLibs=$LIBS LIBS="$LIBS -lsocket -lnsl" - ac_fn_c_check_func "$LINENO" "accept" "ac_cv_func_accept" -if test "x$ac_cv_func_accept" = xyes; then : + echo "$as_me:$LINENO: checking for accept" >&5 +echo $ECHO_N "checking for accept... $ECHO_C" >&6 +if test "${ac_cv_func_accept+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define accept to an innocuous variant, in case declares accept. + For example, HP-UX 11i declares gettimeofday. */ +#define accept innocuous_accept + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char accept (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef accept + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char accept (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_accept) || defined (__stub___accept) +choke me +#else +char (*f) () = accept; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != accept; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_func_accept=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_func_accept=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_func_accept" >&5 +echo "${ECHO_T}$ac_cv_func_accept" >&6 +if test $ac_cv_func_accept = yes; then tcl_checkNsl=0 else LIBS=$tk_oldLibs fi fi - ac_fn_c_check_func "$LINENO" "gethostbyname" "ac_cv_func_gethostbyname" -if test "x$ac_cv_func_gethostbyname" = xyes; then : - -else - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for gethostbyname in -lnsl" >&5 -$as_echo_n "checking for gethostbyname in -lnsl... " >&6; } -if ${ac_cv_lib_nsl_gethostbyname+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking for gethostbyname" >&5 +echo $ECHO_N "checking for gethostbyname... $ECHO_C" >&6 +if test "${ac_cv_func_gethostbyname+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define gethostbyname to an innocuous variant, in case declares gethostbyname. + For example, HP-UX 11i declares gettimeofday. */ +#define gethostbyname innocuous_gethostbyname + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char gethostbyname (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef gethostbyname + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char gethostbyname (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_gethostbyname) || defined (__stub___gethostbyname) +choke me +#else +char (*f) () = gethostbyname; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != gethostbyname; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_func_gethostbyname=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_func_gethostbyname=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_func_gethostbyname" >&5 +echo "${ECHO_T}$ac_cv_func_gethostbyname" >&6 +if test $ac_cv_func_gethostbyname = yes; then + : +else + echo "$as_me:$LINENO: checking for gethostbyname in -lnsl" >&5 +echo $ECHO_N "checking for gethostbyname in -lnsl... $ECHO_C" >&6 +if test "${ac_cv_lib_nsl_gethostbyname+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lnsl $LIBS" -cat confdefs.h - <<_ACEOF >conftest.$ac_ext +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ +/* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ char gethostbyname (); int main () { -return gethostbyname (); +gethostbyname (); ; return 0; } _ACEOF -if ac_fn_c_try_link "$LINENO"; then : +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then ac_cv_lib_nsl_gethostbyname=yes else - ac_cv_lib_nsl_gethostbyname=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_lib_nsl_gethostbyname=no fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_nsl_gethostbyname" >&5 -$as_echo "$ac_cv_lib_nsl_gethostbyname" >&6; } -if test "x$ac_cv_lib_nsl_gethostbyname" = xyes; then : +echo "$as_me:$LINENO: result: $ac_cv_lib_nsl_gethostbyname" >&5 +echo "${ECHO_T}$ac_cv_lib_nsl_gethostbyname" >&6 +if test $ac_cv_lib_nsl_gethostbyname = yes; then LIBS="$LIBS -lnsl" fi fi - - -$as_echo "#define _REENTRANT 1" >>confdefs.h - - -$as_echo "#define _THREAD_SAFE 1" >>confdefs.h - - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for pthread_mutex_init in -lpthread" >&5 -$as_echo_n "checking for pthread_mutex_init in -lpthread... " >&6; } -if ${ac_cv_lib_pthread_pthread_mutex_init+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_check_lib_save_LIBS=$LIBS -LIBS="-lpthread $LIBS" -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ -#ifdef __cplusplus -extern "C" -#endif -char pthread_mutex_init (); -int -main () -{ -return pthread_mutex_init (); - ; - return 0; -} -_ACEOF -if ac_fn_c_try_link "$LINENO"; then : - ac_cv_lib_pthread_pthread_mutex_init=yes -else - ac_cv_lib_pthread_pthread_mutex_init=no -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext -LIBS=$ac_check_lib_save_LIBS -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_pthread_pthread_mutex_init" >&5 -$as_echo "$ac_cv_lib_pthread_pthread_mutex_init" >&6; } -if test "x$ac_cv_lib_pthread_pthread_mutex_init" = xyes; then : - tcl_ok=yes -else - tcl_ok=no -fi - - if test "$tcl_ok" = "no"; then - # Check a little harder for __pthread_mutex_init in the same - # library, as some systems hide it there until pthread.h is - # defined. We could alternatively do an AC_TRY_COMPILE with - # pthread.h, but that will work with libpthread really doesn't - # exist, like AIX 4.2. [Bug: 4359] - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for __pthread_mutex_init in -lpthread" >&5 -$as_echo_n "checking for __pthread_mutex_init in -lpthread... " >&6; } -if ${ac_cv_lib_pthread___pthread_mutex_init+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_check_lib_save_LIBS=$LIBS -LIBS="-lpthread $LIBS" -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ -#ifdef __cplusplus -extern "C" -#endif -char __pthread_mutex_init (); -int -main () -{ -return __pthread_mutex_init (); - ; - return 0; -} -_ACEOF -if ac_fn_c_try_link "$LINENO"; then : - ac_cv_lib_pthread___pthread_mutex_init=yes -else - ac_cv_lib_pthread___pthread_mutex_init=no -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext -LIBS=$ac_check_lib_save_LIBS -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_pthread___pthread_mutex_init" >&5 -$as_echo "$ac_cv_lib_pthread___pthread_mutex_init" >&6; } -if test "x$ac_cv_lib_pthread___pthread_mutex_init" = xyes; then : - tcl_ok=yes -else - tcl_ok=no -fi - - fi - - if test "$tcl_ok" = "yes"; then - # The space is needed - THREADS_LIBS=" -lpthread" - else - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for pthread_mutex_init in -lpthreads" >&5 -$as_echo_n "checking for pthread_mutex_init in -lpthreads... " >&6; } -if ${ac_cv_lib_pthreads_pthread_mutex_init+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_check_lib_save_LIBS=$LIBS -LIBS="-lpthreads $LIBS" -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ -#ifdef __cplusplus -extern "C" -#endif -char pthread_mutex_init (); -int -main () -{ -return pthread_mutex_init (); - ; - return 0; -} -_ACEOF -if ac_fn_c_try_link "$LINENO"; then : - ac_cv_lib_pthreads_pthread_mutex_init=yes -else - ac_cv_lib_pthreads_pthread_mutex_init=no -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext -LIBS=$ac_check_lib_save_LIBS -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_pthreads_pthread_mutex_init" >&5 -$as_echo "$ac_cv_lib_pthreads_pthread_mutex_init" >&6; } -if test "x$ac_cv_lib_pthreads_pthread_mutex_init" = xyes; then : - _ok=yes -else - tcl_ok=no -fi - - if test "$tcl_ok" = "yes"; then - # The space is needed - THREADS_LIBS=" -lpthreads" - else - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for pthread_mutex_init in -lc" >&5 -$as_echo_n "checking for pthread_mutex_init in -lc... " >&6; } -if ${ac_cv_lib_c_pthread_mutex_init+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_check_lib_save_LIBS=$LIBS -LIBS="-lc $LIBS" -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ -#ifdef __cplusplus -extern "C" -#endif -char pthread_mutex_init (); -int -main () -{ -return pthread_mutex_init (); - ; - return 0; -} -_ACEOF -if ac_fn_c_try_link "$LINENO"; then : - ac_cv_lib_c_pthread_mutex_init=yes -else - ac_cv_lib_c_pthread_mutex_init=no -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext -LIBS=$ac_check_lib_save_LIBS -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_c_pthread_mutex_init" >&5 -$as_echo "$ac_cv_lib_c_pthread_mutex_init" >&6; } -if test "x$ac_cv_lib_c_pthread_mutex_init" = xyes; then : - tcl_ok=yes -else - tcl_ok=no -fi - - if test "$tcl_ok" = "no"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for pthread_mutex_init in -lc_r" >&5 -$as_echo_n "checking for pthread_mutex_init in -lc_r... " >&6; } -if ${ac_cv_lib_c_r_pthread_mutex_init+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_check_lib_save_LIBS=$LIBS -LIBS="-lc_r $LIBS" -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ -#ifdef __cplusplus -extern "C" -#endif -char pthread_mutex_init (); -int -main () -{ -return pthread_mutex_init (); - ; - return 0; -} -_ACEOF -if ac_fn_c_try_link "$LINENO"; then : - ac_cv_lib_c_r_pthread_mutex_init=yes -else - ac_cv_lib_c_r_pthread_mutex_init=no -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext -LIBS=$ac_check_lib_save_LIBS -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_c_r_pthread_mutex_init" >&5 -$as_echo "$ac_cv_lib_c_r_pthread_mutex_init" >&6; } -if test "x$ac_cv_lib_c_r_pthread_mutex_init" = xyes; then : - tcl_ok=yes -else - tcl_ok=no -fi - - if test "$tcl_ok" = "yes"; then - # The space is needed - THREADS_LIBS=" -pthread" - else - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Don't know how to find pthread lib on your system - you must edit the LIBS in the Makefile..." >&5 -$as_echo "$as_me: WARNING: Don't know how to find pthread lib on your system - you must edit the LIBS in the Makefile..." >&2;} - fi - fi - fi - fi - - # Does the pthread-implementation provide - # 'pthread_attr_setstacksize' ? - - ac_saved_libs=$LIBS - LIBS="$LIBS $THREADS_LIBS" - for ac_func in pthread_attr_setstacksize pthread_atfork -do : - as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` -ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var" -if eval test \"x\$"$as_ac_var"\" = x"yes"; then : - cat >>confdefs.h <<_ACEOF -#define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 -_ACEOF - -fi -done - - LIBS=$ac_saved_libs - - # TIP #509 - ac_fn_c_check_decl "$LINENO" "PTHREAD_MUTEX_RECURSIVE" "ac_cv_have_decl_PTHREAD_MUTEX_RECURSIVE" "#include -" -if test "x$ac_cv_have_decl_PTHREAD_MUTEX_RECURSIVE" = xyes; then : - ac_have_decl=1 -else - ac_have_decl=0 -fi - -cat >>confdefs.h <<_ACEOF -#define HAVE_DECL_PTHREAD_MUTEX_RECURSIVE $ac_have_decl -_ACEOF -if test $ac_have_decl = 1; then : - tcl_ok=yes -else - tcl_ok=no -fi - # Add the threads support libraries LIBS="$LIBS$THREADS_LIBS" - { $as_echo "$as_me:${as_lineno-$LINENO}: checking how to build libraries" >&5 -$as_echo_n "checking how to build libraries... " >&6; } - # Check whether --enable-shared was given. -if test "${enable_shared+set}" = set; then : - enableval=$enable_shared; tcl_ok=$enableval + echo "$as_me:$LINENO: checking how to build libraries" >&5 +echo $ECHO_N "checking how to build libraries... $ECHO_C" >&6 + # Check whether --enable-shared or --disable-shared was given. +if test "${enable_shared+set}" = set; then + enableval="$enable_shared" + tcl_ok=$enableval else tcl_ok=yes -fi - +fi; if test "${enable_shared+set}" = set; then enableval="$enable_shared" tcl_ok=$enableval else tcl_ok=yes fi if test "$tcl_ok" = "yes" ; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: shared" >&5 -$as_echo "shared" >&6; } + echo "$as_me:$LINENO: result: shared" >&5 +echo "${ECHO_T}shared" >&6 SHARED_BUILD=1 else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: static" >&5 -$as_echo "static" >&6; } + echo "$as_me:$LINENO: result: static" >&5 +echo "${ECHO_T}static" >&6 SHARED_BUILD=0 -$as_echo "#define STATIC_BUILD 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define STATIC_BUILD 1 +_ACEOF fi - #-------------------------------------------------------------------- # Look for a native installed tclsh binary (if available) # If one cannot be found then use the binary we build (fails for # cross compiling). This is used for NATIVE_TCLSH in Makefile. #-------------------------------------------------------------------- - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for tclsh" >&5 -$as_echo_n "checking for tclsh... " >&6; } - if ${ac_cv_path_tclsh+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking for tclsh" >&5 +echo $ECHO_N "checking for tclsh... $ECHO_C" >&6 + if test "${ac_cv_path_tclsh+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else search_path=`echo ${PATH} | sed -e 's/:/ /g'` for dir in $search_path ; do for j in `ls -r $dir/tclsh[8-9]* 2> /dev/null` \ @@ -4542,17 +5767,17 @@ fi if test -f "$ac_cv_path_tclsh" ; then TCLSH_PROG="$ac_cv_path_tclsh" - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $TCLSH_PROG" >&5 -$as_echo "$TCLSH_PROG" >&6; } + echo "$as_me:$LINENO: result: $TCLSH_PROG" >&5 +echo "${ECHO_T}$TCLSH_PROG" >&6 else # It is not an error if an installed version of Tcl can't be located. TCLSH_PROG="" - { $as_echo "$as_me:${as_lineno-$LINENO}: result: No tclsh found on PATH" >&5 -$as_echo "No tclsh found on PATH" >&6; } + echo "$as_me:$LINENO: result: No tclsh found on PATH" >&5 +echo "${ECHO_T}No tclsh found on PATH" >&6 fi if test "$TCLSH_PROG" = ""; then TCLSH_PROG='./${TCL_EXE}' @@ -4561,17 +5786,208 @@ #------------------------------------------------------------------------ # Add stuff for zlib #------------------------------------------------------------------------ zlib_ok=yes -ac_fn_c_check_header_mongrel "$LINENO" "zlib.h" "ac_cv_header_zlib_h" "$ac_includes_default" -if test "x$ac_cv_header_zlib_h" = xyes; then : +if test "${ac_cv_header_zlib_h+set}" = set; then + echo "$as_me:$LINENO: checking for zlib.h" >&5 +echo $ECHO_N "checking for zlib.h... $ECHO_C" >&6 +if test "${ac_cv_header_zlib_h+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +fi +echo "$as_me:$LINENO: result: $ac_cv_header_zlib_h" >&5 +echo "${ECHO_T}$ac_cv_header_zlib_h" >&6 +else + # Is the header compilable? +echo "$as_me:$LINENO: checking zlib.h usability" >&5 +echo $ECHO_N "checking zlib.h usability... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +#include +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_header_compiler=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 - ac_fn_c_check_type "$LINENO" "gz_header" "ac_cv_type_gz_header" "#include -" -if test "x$ac_cv_type_gz_header" = xyes; then : +ac_header_compiler=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 +echo "${ECHO_T}$ac_header_compiler" >&6 +# Is the header present? +echo "$as_me:$LINENO: checking zlib.h presence" >&5 +echo $ECHO_N "checking zlib.h presence... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include +_ACEOF +if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 + (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null; then + if test -s conftest.err; then + ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag + else + ac_cpp_err= + fi +else + ac_cpp_err=yes +fi +if test -z "$ac_cpp_err"; then + ac_header_preproc=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_header_preproc=no +fi +rm -f conftest.err conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 +echo "${ECHO_T}$ac_header_preproc" >&6 + +# So? What about this header? +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) + { echo "$as_me:$LINENO: WARNING: zlib.h: accepted by the compiler, rejected by the preprocessor!" >&5 +echo "$as_me: WARNING: zlib.h: accepted by the compiler, rejected by the preprocessor!" >&2;} + { echo "$as_me:$LINENO: WARNING: zlib.h: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: zlib.h: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes + ;; + no:yes:* ) + { echo "$as_me:$LINENO: WARNING: zlib.h: present but cannot be compiled" >&5 +echo "$as_me: WARNING: zlib.h: present but cannot be compiled" >&2;} + { echo "$as_me:$LINENO: WARNING: zlib.h: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: zlib.h: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: zlib.h: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: zlib.h: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: zlib.h: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: zlib.h: section \"Present But Cannot Be Compiled\"" >&2;} + { echo "$as_me:$LINENO: WARNING: zlib.h: proceeding with the preprocessor's result" >&5 +echo "$as_me: WARNING: zlib.h: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: zlib.h: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: zlib.h: in the future, the compiler will take precedence" >&2;} + ( + cat <<\_ASBOX +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## +_ASBOX + ) | + sed "s/^/$as_me: WARNING: /" >&2 + ;; +esac +echo "$as_me:$LINENO: checking for zlib.h" >&5 +echo $ECHO_N "checking for zlib.h... $ECHO_C" >&6 +if test "${ac_cv_header_zlib_h+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_cv_header_zlib_h=$ac_header_preproc +fi +echo "$as_me:$LINENO: result: $ac_cv_header_zlib_h" >&5 +echo "${ECHO_T}$ac_cv_header_zlib_h" >&6 + +fi +if test $ac_cv_header_zlib_h = yes; then + + echo "$as_me:$LINENO: checking for gz_header" >&5 +echo $ECHO_N "checking for gz_header... $ECHO_C" >&6 +if test "${ac_cv_type_gz_header+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include + +int +main () +{ +if ((gz_header *) 0) + return 0; +if (sizeof (gz_header)) + return 0; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_type_gz_header=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_type_gz_header=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_type_gz_header" >&5 +echo "${ECHO_T}$ac_cv_type_gz_header" >&6 +if test $ac_cv_type_gz_header = yes; then + : else zlib_ok=no fi else @@ -4578,74 +5994,145 @@ zlib_ok=no fi -if test $zlib_ok = yes; then : +if test $zlib_ok = yes; then - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for library containing deflateSetHeader" >&5 -$as_echo_n "checking for library containing deflateSetHeader... " >&6; } -if ${ac_cv_search_deflateSetHeader+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking for library containing deflateSetHeader" >&5 +echo $ECHO_N "checking for library containing deflateSetHeader... $ECHO_C" >&6 +if test "${ac_cv_search_deflateSetHeader+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_func_search_save_LIBS=$LIBS -cat confdefs.h - <<_ACEOF >conftest.$ac_ext +ac_cv_search_deflateSetHeader=no +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +#endif +/* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ +char deflateSetHeader (); +int +main () +{ +deflateSetHeader (); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_search_deflateSetHeader="none required" +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +if test "$ac_cv_search_deflateSetHeader" = no; then + for ac_lib in z; do + LIBS="-l$ac_lib $ac_func_search_save_LIBS" + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +/* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ char deflateSetHeader (); int main () { -return deflateSetHeader (); +deflateSetHeader (); ; return 0; } _ACEOF -for ac_lib in '' z; do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib $ac_func_search_save_LIBS" - fi - if ac_fn_c_try_link "$LINENO"; then : - ac_cv_search_deflateSetHeader=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext - if ${ac_cv_search_deflateSetHeader+:} false; then : - break -fi -done -if ${ac_cv_search_deflateSetHeader+:} false; then : - -else - ac_cv_search_deflateSetHeader=no -fi -rm conftest.$ac_ext +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_search_deflateSetHeader="-l$ac_lib" +break +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + done +fi LIBS=$ac_func_search_save_LIBS fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_deflateSetHeader" >&5 -$as_echo "$ac_cv_search_deflateSetHeader" >&6; } -ac_res=$ac_cv_search_deflateSetHeader -if test "$ac_res" != no; then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" +echo "$as_me:$LINENO: result: $ac_cv_search_deflateSetHeader" >&5 +echo "${ECHO_T}$ac_cv_search_deflateSetHeader" >&6 +if test "$ac_cv_search_deflateSetHeader" != no; then + test "$ac_cv_search_deflateSetHeader" = "none required" || LIBS="$ac_cv_search_deflateSetHeader $LIBS" else zlib_ok=no fi fi -if test $zlib_ok = no; then : + +if test $zlib_ok = no; then ZLIB_OBJS=\${ZLIB_OBJS} ZLIB_SRCS=\${ZLIB_SRCS} @@ -4652,11 +6139,14 @@ ZLIB_INCLUDE=-I\${ZLIB_DIR} fi -$as_echo "#define HAVE_ZLIB 1" >>confdefs.h + +cat >>confdefs.h <<\_ACEOF +#define HAVE_ZLIB 1 +_ACEOF #-------------------------------------------------------------------- # The statements below define a collection of compile flags. This # macro depends on the value of SHARED_BUILD, and should be called @@ -4664,144 +6154,137 @@ #-------------------------------------------------------------------- if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}ranlib", so it can be a program name with args. set dummy ${ac_tool_prefix}ranlib; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_RANLIB+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_RANLIB+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$RANLIB"; then ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_RANLIB="${ac_tool_prefix}ranlib" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done - done -IFS=$as_save_IFS +done fi fi RANLIB=$ac_cv_prog_RANLIB if test -n "$RANLIB"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $RANLIB" >&5 -$as_echo "$RANLIB" >&6; } + echo "$as_me:$LINENO: result: $RANLIB" >&5 +echo "${ECHO_T}$RANLIB" >&6 else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 fi - fi if test -z "$ac_cv_prog_RANLIB"; then ac_ct_RANLIB=$RANLIB # Extract the first word of "ranlib", so it can be a program name with args. set dummy ranlib; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_ac_ct_RANLIB+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_ac_ct_RANLIB+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$ac_ct_RANLIB"; then ac_cv_prog_ac_ct_RANLIB="$ac_ct_RANLIB" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_RANLIB="ranlib" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done - done -IFS=$as_save_IFS +done + test -z "$ac_cv_prog_ac_ct_RANLIB" && ac_cv_prog_ac_ct_RANLIB=":" fi fi ac_ct_RANLIB=$ac_cv_prog_ac_ct_RANLIB if test -n "$ac_ct_RANLIB"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_RANLIB" >&5 -$as_echo "$ac_ct_RANLIB" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - if test "x$ac_ct_RANLIB" = x; then - RANLIB=":" - else - case $cross_compiling:$ac_tool_warned in -yes:) -{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 -$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} -ac_tool_warned=yes ;; -esac - RANLIB=$ac_ct_RANLIB - fi + echo "$as_me:$LINENO: result: $ac_ct_RANLIB" >&5 +echo "${ECHO_T}$ac_ct_RANLIB" >&6 +else + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 +fi + + RANLIB=$ac_ct_RANLIB else RANLIB="$ac_cv_prog_RANLIB" fi # Step 0.a: Enable 64 bit support? - { $as_echo "$as_me:${as_lineno-$LINENO}: checking if 64bit support is requested" >&5 -$as_echo_n "checking if 64bit support is requested... " >&6; } - # Check whether --enable-64bit was given. -if test "${enable_64bit+set}" = set; then : - enableval=$enable_64bit; do64bit=$enableval + echo "$as_me:$LINENO: checking if 64bit support is requested" >&5 +echo $ECHO_N "checking if 64bit support is requested... $ECHO_C" >&6 + # Check whether --enable-64bit or --disable-64bit was given. +if test "${enable_64bit+set}" = set; then + enableval="$enable_64bit" + do64bit=$enableval else do64bit=no -fi - - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $do64bit" >&5 -$as_echo "$do64bit" >&6; } +fi; + echo "$as_me:$LINENO: result: $do64bit" >&5 +echo "${ECHO_T}$do64bit" >&6 # Step 0.b: Enable Solaris 64 bit VIS support? - { $as_echo "$as_me:${as_lineno-$LINENO}: checking if 64bit Sparc VIS support is requested" >&5 -$as_echo_n "checking if 64bit Sparc VIS support is requested... " >&6; } - # Check whether --enable-64bit-vis was given. -if test "${enable_64bit_vis+set}" = set; then : - enableval=$enable_64bit_vis; do64bitVIS=$enableval + echo "$as_me:$LINENO: checking if 64bit Sparc VIS support is requested" >&5 +echo $ECHO_N "checking if 64bit Sparc VIS support is requested... $ECHO_C" >&6 + # Check whether --enable-64bit-vis or --disable-64bit-vis was given. +if test "${enable_64bit_vis+set}" = set; then + enableval="$enable_64bit_vis" + do64bitVIS=$enableval else do64bitVIS=no -fi - - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $do64bitVIS" >&5 -$as_echo "$do64bitVIS" >&6; } +fi; + echo "$as_me:$LINENO: result: $do64bitVIS" >&5 +echo "${ECHO_T}$do64bitVIS" >&6 # Force 64bit on with VIS - if test "$do64bitVIS" = "yes"; then : + if test "$do64bitVIS" = "yes"; then do64bit=yes fi + # Step 0.c: Check if visibility support is available. Do this here so # that platform specific alternatives can be used below if this fails. - { $as_echo "$as_me:${as_lineno-$LINENO}: checking if compiler supports visibility \"hidden\"" >&5 -$as_echo_n "checking if compiler supports visibility \"hidden\"... " >&6; } -if ${tcl_cv_cc_visibility_hidden+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking if compiler supports visibility \"hidden\"" >&5 +echo $ECHO_N "checking if compiler supports visibility \"hidden\"... $ECHO_C" >&6 +if test "${tcl_cv_cc_visibility_hidden+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ extern __attribute__((__visibility__("hidden"))) void f(void); void f(void) {} int @@ -4810,117 +6293,183 @@ f(); ; return 0; } _ACEOF -if ac_fn_c_try_link "$LINENO"; then : +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_cc_visibility_hidden=yes else - tcl_cv_cc_visibility_hidden=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_cc_visibility_hidden=no fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext CFLAGS=$hold_cflags fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_visibility_hidden" >&5 -$as_echo "$tcl_cv_cc_visibility_hidden" >&6; } - if test $tcl_cv_cc_visibility_hidden = yes; then : +echo "$as_me:$LINENO: result: $tcl_cv_cc_visibility_hidden" >&5 +echo "${ECHO_T}$tcl_cv_cc_visibility_hidden" >&6 + if test $tcl_cv_cc_visibility_hidden = yes; then -$as_echo "#define MODULE_SCOPE extern __attribute__((__visibility__(\"hidden\")))" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define MODULE_SCOPE extern __attribute__((__visibility__("hidden"))) +_ACEOF -$as_echo "#define HAVE_HIDDEN 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_HIDDEN 1 +_ACEOF fi + # Step 0.d: Disable -rpath support? - { $as_echo "$as_me:${as_lineno-$LINENO}: checking if rpath support is requested" >&5 -$as_echo_n "checking if rpath support is requested... " >&6; } - # Check whether --enable-rpath was given. -if test "${enable_rpath+set}" = set; then : - enableval=$enable_rpath; doRpath=$enableval + echo "$as_me:$LINENO: checking if rpath support is requested" >&5 +echo $ECHO_N "checking if rpath support is requested... $ECHO_C" >&6 + # Check whether --enable-rpath or --disable-rpath was given. +if test "${enable_rpath+set}" = set; then + enableval="$enable_rpath" + doRpath=$enableval else doRpath=yes -fi - - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $doRpath" >&5 -$as_echo "$doRpath" >&6; } +fi; + echo "$as_me:$LINENO: result: $doRpath" >&5 +echo "${ECHO_T}$doRpath" >&6 # Step 1: set the variable "system" to hold the name and version number # for the system. - { $as_echo "$as_me:${as_lineno-$LINENO}: checking system version" >&5 -$as_echo_n "checking system version... " >&6; } -if ${tcl_cv_sys_version+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking system version" >&5 +echo $ECHO_N "checking system version... $ECHO_C" >&6 +if test "${tcl_cv_sys_version+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - if test "${TEA_PLATFORM}" = "windows" ; then - tcl_cv_sys_version=windows + if test -f /usr/lib/NextStep/software_version; then + tcl_cv_sys_version=NEXTSTEP-`awk '/3/,/3/' /usr/lib/NextStep/software_version` else tcl_cv_sys_version=`uname -s`-`uname -r` if test "$?" -ne 0 ; then - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: can't find uname command" >&5 -$as_echo "$as_me: WARNING: can't find uname command" >&2;} + { echo "$as_me:$LINENO: WARNING: can't find uname command" >&5 +echo "$as_me: WARNING: can't find uname command" >&2;} tcl_cv_sys_version=unknown else + # Special check for weird MP-RAS system (uname returns weird + # results, and the version is kept in special file). + + if test -r /etc/.relid -a "X`uname -n`" = "X`uname -s`" ; then + tcl_cv_sys_version=MP-RAS-`awk '{print $3}' /etc/.relid` + fi if test "`uname -s`" = "AIX" ; then tcl_cv_sys_version=AIX-`uname -v`.`uname -r` + fi + if test "`uname -s`" = "NetBSD" -a -f /etc/debian_version ; then + tcl_cv_sys_version=NetBSD-Debian fi fi fi fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_sys_version" >&5 -$as_echo "$tcl_cv_sys_version" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_sys_version" >&5 +echo "${ECHO_T}$tcl_cv_sys_version" >&6 system=$tcl_cv_sys_version # Step 2: check for existence of -ldl library. This is needed because # Linux can use either -ldl or -ldld for dynamic loading. - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for dlopen in -ldl" >&5 -$as_echo_n "checking for dlopen in -ldl... " >&6; } -if ${ac_cv_lib_dl_dlopen+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking for dlopen in -ldl" >&5 +echo $ECHO_N "checking for dlopen in -ldl... $ECHO_C" >&6 +if test "${ac_cv_lib_dl_dlopen+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldl $LIBS" -cat confdefs.h - <<_ACEOF >conftest.$ac_ext +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ +/* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ char dlopen (); int main () { -return dlopen (); +dlopen (); ; return 0; } _ACEOF -if ac_fn_c_try_link "$LINENO"; then : +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then ac_cv_lib_dl_dlopen=yes else - ac_cv_lib_dl_dlopen=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_lib_dl_dlopen=no fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dl_dlopen" >&5 -$as_echo "$ac_cv_lib_dl_dlopen" >&6; } -if test "x$ac_cv_lib_dl_dlopen" = xyes; then : +echo "$as_me:$LINENO: result: $ac_cv_lib_dl_dlopen" >&5 +echo "${ECHO_T}$ac_cv_lib_dl_dlopen" >&6 +if test $ac_cv_lib_dl_dlopen = yes; then have_dl=yes else have_dl=no fi @@ -4942,124 +6491,115 @@ UNSHARED_LIB_SUFFIX="" TCL_TRIM_DOTS='`echo ${VERSION} | tr -d .`' ECHO_VERSION='`echo ${VERSION}`' TCL_LIB_VERSIONS_OK=ok CFLAGS_DEBUG=-g - if test "$GCC" = yes; then : + if test "$GCC" = yes; then CFLAGS_OPTIMIZE=-O2 - CFLAGS_WARNING="-Wall -Wwrite-strings -Wsign-compare -Wdeclaration-after-statement -Wpointer-arith" + CFLAGS_WARNING="-Wall -Wpointer-arith" else CFLAGS_OPTIMIZE=-O CFLAGS_WARNING="" fi + if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}ar", so it can be a program name with args. set dummy ${ac_tool_prefix}ar; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_AR+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_AR+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$AR"; then ac_cv_prog_AR="$AR" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_AR="${ac_tool_prefix}ar" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done - done -IFS=$as_save_IFS +done fi fi AR=$ac_cv_prog_AR if test -n "$AR"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $AR" >&5 -$as_echo "$AR" >&6; } + echo "$as_me:$LINENO: result: $AR" >&5 +echo "${ECHO_T}$AR" >&6 else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 fi - fi if test -z "$ac_cv_prog_AR"; then ac_ct_AR=$AR # Extract the first word of "ar", so it can be a program name with args. set dummy ar; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_ac_ct_AR+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_ac_ct_AR+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$ac_ct_AR"; then ac_cv_prog_ac_ct_AR="$ac_ct_AR" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_AR="ar" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done - done -IFS=$as_save_IFS +done fi fi ac_ct_AR=$ac_cv_prog_ac_ct_AR if test -n "$ac_ct_AR"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_AR" >&5 -$as_echo "$ac_ct_AR" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - if test "x$ac_ct_AR" = x; then - AR="" - else - case $cross_compiling:$ac_tool_warned in -yes:) -{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 -$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} -ac_tool_warned=yes ;; -esac - AR=$ac_ct_AR - fi + echo "$as_me:$LINENO: result: $ac_ct_AR" >&5 +echo "${ECHO_T}$ac_ct_AR" >&6 +else + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 +fi + + AR=$ac_ct_AR else AR="$ac_cv_prog_AR" fi STLIB_LD='${AR} cr' LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH" PLAT_OBJS="" PLAT_SRCS="" LDAIX_SRC="" - if test "x${SHLIB_VERSION}" = x; then : - SHLIB_VERSION="1.0" + if test "x${SHLIB_VERSION}" = x; then + SHLIB_VERSION=".1.0" +else + SHLIB_VERSION=".${SHLIB_VERSION}" fi + case $system in AIX-*) - if test "$GCC" != "yes"; then : + if test "${TCL_THREADS}" = "1" -a "$GCC" != "yes"; then # AIX requires the _r compiler when gcc isn't being used case "${CC}" in *_r|*_r\ *) # ok ... @@ -5067,14 +6607,15 @@ *) # Make sure only first arg gets _r CC=`echo "$CC" | sed -e 's/^\([^ ]*\)/\1_r/'` ;; esac - { $as_echo "$as_me:${as_lineno-$LINENO}: result: Using $CC for compiling with threads" >&5 -$as_echo "Using $CC for compiling with threads" >&6; } + echo "$as_me:$LINENO: result: Using $CC for compiling with threads" >&5 +echo "${ECHO_T}Using $CC for compiling with threads" >&6 fi + LIBS="$LIBS -lc" SHLIB_CFLAGS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" @@ -5083,16 +6624,16 @@ # ldAix No longer needed with use of -bexpall/-brtl # but some extensions may still reference it LDAIX_SRC='$(UNIX_DIR)/ldAix' # Check to enable 64-bit flags for compiler/linker - if test "$do64bit" = yes; then : + if test "$do64bit" = yes; then - if test "$GCC" = yes; then : + if test "$GCC" = yes; then - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported with GCC on $system" >&5 -$as_echo "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;} + { echo "$as_me:$LINENO: WARNING: 64bit mode not supported with GCC on $system" >&5 +echo "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;} else do64bit_ok=yes CFLAGS="$CFLAGS -q64" @@ -5100,48 +6641,53 @@ RANLIB="${RANLIB} -X64" AR="${AR} -X64" SHLIB_LD_FLAGS="-b64" fi + fi - if test "`uname -m`" = ia64; then : + + if test "`uname -m`" = ia64; then # AIX-5 uses ELF style dynamic libraries on IA-64, but not PPC SHLIB_LD="/usr/ccs/bin/ld -G -z text" # AIX-5 has dl* in libc.so DL_LIBS="" - if test "$GCC" = yes; then : + if test "$GCC" = yes; then CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' else CC_SEARCH_FLAGS='-R${LIB_RUNTIME_DIR}' fi + LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' else - if test "$GCC" = yes; then : + if test "$GCC" = yes; then SHLIB_LD='${CC} -shared -Wl,-bexpall' else SHLIB_LD="/bin/ld -bhalt:4 -bM:SRE -bexpall -H512 -T512 -bnoentry" LDFLAGS="$LDFLAGS -brtl" fi + SHLIB_LD="${SHLIB_LD} ${SHLIB_LD_FLAGS}" DL_LIBS="-ldl" CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} fi + ;; BeOS*) SHLIB_CFLAGS="-fPIC" SHLIB_LD='${CC} -nostart' SHLIB_SUFFIX=".so" @@ -5151,47 +6697,75 @@ #----------------------------------------------------------- # Check for inet_ntoa in -lbind, for BeOS (which also needs # -lsocket, even if the network functions are in -lnet which # is always linked to, for compatibility. #----------------------------------------------------------- - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for inet_ntoa in -lbind" >&5 -$as_echo_n "checking for inet_ntoa in -lbind... " >&6; } -if ${ac_cv_lib_bind_inet_ntoa+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking for inet_ntoa in -lbind" >&5 +echo $ECHO_N "checking for inet_ntoa in -lbind... $ECHO_C" >&6 +if test "${ac_cv_lib_bind_inet_ntoa+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lbind $LIBS" -cat confdefs.h - <<_ACEOF >conftest.$ac_ext +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ +/* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ char inet_ntoa (); int main () { -return inet_ntoa (); +inet_ntoa (); ; return 0; } _ACEOF -if ac_fn_c_try_link "$LINENO"; then : +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then ac_cv_lib_bind_inet_ntoa=yes else - ac_cv_lib_bind_inet_ntoa=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_lib_bind_inet_ntoa=no fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_bind_inet_ntoa" >&5 -$as_echo "$ac_cv_lib_bind_inet_ntoa" >&6; } -if test "x$ac_cv_lib_bind_inet_ntoa" = xyes; then : +echo "$as_me:$LINENO: result: $ac_cv_lib_bind_inet_ntoa" >&5 +echo "${ECHO_T}$ac_cv_lib_bind_inet_ntoa" >&6 +if test $ac_cv_lib_bind_inet_ntoa = yes; then LIBS="$LIBS -lbind -lsocket" fi ;; BSD/OS-2.1*|BSD/OS-3*) @@ -5211,11 +6785,11 @@ DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -export-dynamic" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; - CYGWIN_*) + CYGWIN_*|MINGW32*) SHLIB_CFLAGS="" SHLIB_LD='${CC} -shared' SHLIB_SUFFIX=".dll" DL_OBJS="tclLoadDl.o" PLAT_OBJS='${CYGWIN_OBJS}' @@ -5222,18 +6796,22 @@ PLAT_SRCS='${CYGWIN_SRCS}' DL_LIBS="-ldl" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" TCL_NEEDS_EXP_FILE=1 - TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.dll.a' + TCL_EXPORT_FILE_SUFFIX='${VERSION}.dll.a' SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,--out-implib,\$@.a" - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for Cygwin version of gcc" >&5 -$as_echo_n "checking for Cygwin version of gcc... " >&6; } -if ${ac_cv_cygwin+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking for Cygwin version of gcc" >&5 +echo $ECHO_N "checking for Cygwin version of gcc... $ECHO_C" >&6 +if test "${ac_cv_cygwin+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #ifdef __CYGWIN__ #error cygwin #endif @@ -5244,22 +6822,53 @@ ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then ac_cv_cygwin=no else - ac_cv_cygwin=yes + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_cygwin=yes fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_cygwin" >&5 -$as_echo "$ac_cv_cygwin" >&6; } +echo "$as_me:$LINENO: result: $ac_cv_cygwin" >&5 +echo "${ECHO_T}$ac_cv_cygwin" >&6 if test "$ac_cv_cygwin" = "no"; then - as_fn_error $? "${CC} is not a cygwin compiler." "$LINENO" 5 + { { echo "$as_me:$LINENO: error: ${CC} is not a cygwin compiler." >&5 +echo "$as_me: error: ${CC} is not a cygwin compiler." >&2;} + { (exit 1); exit 1; }; } + fi + if test "x${TCL_THREADS}" = "x0"; then + { { echo "$as_me:$LINENO: error: CYGWIN compile is only supported with --enable-threads" >&5 +echo "$as_me: error: CYGWIN compile is only supported with --enable-threads" >&2;} + { (exit 1); exit 1; }; } fi do64bit_ok=yes if test "x${SHARED_BUILD}" = "x1"; then echo "running cd ../win; ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args" # The eval makes quoting arguments work. @@ -5285,113 +6894,174 @@ SHLIB_CFLAGS="-fPIC" SHLIB_SUFFIX=".so" SHLIB_LD='${CC} ${CFLAGS} ${LDFLAGS} -shared' DL_OBJS="tclLoadDl.o" DL_LIBS="-lroot" - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for inet_ntoa in -lnetwork" >&5 -$as_echo_n "checking for inet_ntoa in -lnetwork... " >&6; } -if ${ac_cv_lib_network_inet_ntoa+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking for inet_ntoa in -lnetwork" >&5 +echo $ECHO_N "checking for inet_ntoa in -lnetwork... $ECHO_C" >&6 +if test "${ac_cv_lib_network_inet_ntoa+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lnetwork $LIBS" -cat confdefs.h - <<_ACEOF >conftest.$ac_ext +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ +/* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ char inet_ntoa (); int main () { -return inet_ntoa (); +inet_ntoa (); ; return 0; } _ACEOF -if ac_fn_c_try_link "$LINENO"; then : +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then ac_cv_lib_network_inet_ntoa=yes else - ac_cv_lib_network_inet_ntoa=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_lib_network_inet_ntoa=no fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_network_inet_ntoa" >&5 -$as_echo "$ac_cv_lib_network_inet_ntoa" >&6; } -if test "x$ac_cv_lib_network_inet_ntoa" = xyes; then : +echo "$as_me:$LINENO: result: $ac_cv_lib_network_inet_ntoa" >&5 +echo "${ECHO_T}$ac_cv_lib_network_inet_ntoa" >&6 +if test $ac_cv_lib_network_inet_ntoa = yes; then LIBS="$LIBS -lnetwork" fi ;; HP-UX-*.11.*) # Use updated header definitions where possible -$as_echo "#define _XOPEN_SOURCE_EXTENDED 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define _XOPEN_SOURCE_EXTENDED 1 +_ACEOF -$as_echo "#define _XOPEN_SOURCE 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define _XOPEN_SOURCE 1 +_ACEOF LIBS="$LIBS -lxnet" # Use the XOPEN network library - if test "`uname -m`" = ia64; then : + if test "`uname -m`" = ia64; then SHLIB_SUFFIX=".so" else SHLIB_SUFFIX=".sl" fi - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for shl_load in -ldld" >&5 -$as_echo_n "checking for shl_load in -ldld... " >&6; } -if ${ac_cv_lib_dld_shl_load+:} false; then : - $as_echo_n "(cached) " >&6 + + echo "$as_me:$LINENO: checking for shl_load in -ldld" >&5 +echo $ECHO_N "checking for shl_load in -ldld... $ECHO_C" >&6 +if test "${ac_cv_lib_dld_shl_load+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldld $LIBS" -cat confdefs.h - <<_ACEOF >conftest.$ac_ext +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ +/* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ char shl_load (); int main () { -return shl_load (); +shl_load (); ; return 0; } _ACEOF -if ac_fn_c_try_link "$LINENO"; then : +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then ac_cv_lib_dld_shl_load=yes else - ac_cv_lib_dld_shl_load=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_lib_dld_shl_load=no fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dld_shl_load" >&5 -$as_echo "$ac_cv_lib_dld_shl_load" >&6; } -if test "x$ac_cv_lib_dld_shl_load" = xyes; then : +echo "$as_me:$LINENO: result: $ac_cv_lib_dld_shl_load" >&5 +echo "${ECHO_T}$ac_cv_lib_dld_shl_load" >&6 +if test $ac_cv_lib_dld_shl_load = yes; then tcl_ok=yes else tcl_ok=no fi - if test "$tcl_ok" = yes; then : + if test "$tcl_ok" = yes; then SHLIB_CFLAGS="+z" SHLIB_LD="ld -b" DL_OBJS="tclLoadShl.o" DL_LIBS="-ldld" @@ -5399,43 +7069,46 @@ CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.' LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.' LD_LIBRARY_PATH_VAR="SHLIB_PATH" fi - if test "$GCC" = yes; then : + + if test "$GCC" = yes; then SHLIB_LD='${CC} -shared' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} else CFLAGS="$CFLAGS -z" fi + # Users may want PA-RISC 1.1/2.0 portable code - needs HP cc #CFLAGS="$CFLAGS +DAportable" # Check to enable 64-bit flags for compiler/linker - if test "$do64bit" = "yes"; then : + if test "$do64bit" = "yes"; then - if test "$GCC" = yes; then : + if test "$GCC" = yes; then case `${CC} -dumpmachine` in hppa64*) # 64-bit gcc in use. Fix flags for GNU ld. do64bit_ok=yes SHLIB_LD='${CC} -shared' - if test $doRpath = yes; then : + if test $doRpath = yes; then - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"' fi + LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} ;; *) - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported with GCC on $system" >&5 -$as_echo "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;} + { echo "$as_me:$LINENO: WARNING: 64bit mode not supported with GCC on $system" >&5 +echo "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;} ;; esac else @@ -5443,56 +7116,86 @@ CFLAGS="$CFLAGS +DD64" LDFLAGS_ARCH="+DD64" fi -fi ;; + +fi + ;; HP-UX-*.08.*|HP-UX-*.09.*|HP-UX-*.10.*) SHLIB_SUFFIX=".sl" - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for shl_load in -ldld" >&5 -$as_echo_n "checking for shl_load in -ldld... " >&6; } -if ${ac_cv_lib_dld_shl_load+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking for shl_load in -ldld" >&5 +echo $ECHO_N "checking for shl_load in -ldld... $ECHO_C" >&6 +if test "${ac_cv_lib_dld_shl_load+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldld $LIBS" -cat confdefs.h - <<_ACEOF >conftest.$ac_ext +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ +/* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ char shl_load (); int main () { -return shl_load (); +shl_load (); ; return 0; } _ACEOF -if ac_fn_c_try_link "$LINENO"; then : +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then ac_cv_lib_dld_shl_load=yes else - ac_cv_lib_dld_shl_load=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_lib_dld_shl_load=no fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dld_shl_load" >&5 -$as_echo "$ac_cv_lib_dld_shl_load" >&6; } -if test "x$ac_cv_lib_dld_shl_load" = xyes; then : +echo "$as_me:$LINENO: result: $ac_cv_lib_dld_shl_load" >&5 +echo "${ECHO_T}$ac_cv_lib_dld_shl_load" >&6 +if test $ac_cv_lib_dld_shl_load = yes; then tcl_ok=yes else tcl_ok=no fi - if test "$tcl_ok" = yes; then : + if test "$tcl_ok" = yes; then SHLIB_CFLAGS="+z" SHLIB_LD="ld -b" SHLIB_LD_LIBS="" DL_OBJS="tclLoadShl.o" @@ -5500,47 +7203,54 @@ LDFLAGS="$LDFLAGS -Wl,-E" CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.' LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.' LD_LIBRARY_PATH_VAR="SHLIB_PATH" -fi ;; +fi + ;; IRIX-5.*) SHLIB_CFLAGS="" SHLIB_LD="ld -shared -rdata_shared" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" - case " $LIBOBJS " in + case $LIBOBJS in + "mkstemp.$ac_objext" | \ + *" mkstemp.$ac_objext" | \ + "mkstemp.$ac_objext "* | \ *" mkstemp.$ac_objext "* ) ;; - *) LIBOBJS="$LIBOBJS mkstemp.$ac_objext" - ;; + *) LIBOBJS="$LIBOBJS mkstemp.$ac_objext" ;; esac - if test $doRpath = yes; then : + if test $doRpath = yes; then - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"' LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' fi + ;; IRIX-6.*) SHLIB_CFLAGS="" SHLIB_LD="ld -n32 -shared -rdata_shared" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" - case " $LIBOBJS " in + case $LIBOBJS in + "mkstemp.$ac_objext" | \ + *" mkstemp.$ac_objext" | \ + "mkstemp.$ac_objext "* | \ *" mkstemp.$ac_objext "* ) ;; - *) LIBOBJS="$LIBOBJS mkstemp.$ac_objext" - ;; + *) LIBOBJS="$LIBOBJS mkstemp.$ac_objext" ;; esac - if test $doRpath = yes; then : + if test $doRpath = yes; then - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"' LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' fi - if test "$GCC" = yes; then : + + if test "$GCC" = yes; then CFLAGS="$CFLAGS -mabi=n32" LDFLAGS="$LDFLAGS -mabi=n32" else @@ -5555,48 +7265,54 @@ ;; esac LDFLAGS="$LDFLAGS -n32" fi + ;; IRIX64-6.*) SHLIB_CFLAGS="" SHLIB_LD="ld -n32 -shared -rdata_shared" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" - case " $LIBOBJS " in + case $LIBOBJS in + "mkstemp.$ac_objext" | \ + *" mkstemp.$ac_objext" | \ + "mkstemp.$ac_objext "* | \ *" mkstemp.$ac_objext "* ) ;; - *) LIBOBJS="$LIBOBJS mkstemp.$ac_objext" - ;; + *) LIBOBJS="$LIBOBJS mkstemp.$ac_objext" ;; esac - if test $doRpath = yes; then : + if test $doRpath = yes; then - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"' LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' fi + # Check to enable 64-bit flags for compiler/linker - if test "$do64bit" = yes; then : + if test "$do64bit" = yes; then - if test "$GCC" = yes; then : + if test "$GCC" = yes; then - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported by gcc" >&5 -$as_echo "$as_me: WARNING: 64bit mode not supported by gcc" >&2;} + { echo "$as_me:$LINENO: WARNING: 64bit mode not supported by gcc" >&5 +echo "$as_me: WARNING: 64bit mode not supported by gcc" >&2;} else do64bit_ok=yes SHLIB_LD="ld -64 -shared -rdata_shared" CFLAGS="$CFLAGS -64" LDFLAGS_ARCH="-64" fi + fi + ;; Linux*|GNU*|NetBSD-Debian) SHLIB_CFLAGS="-fPIC" SHLIB_SUFFIX=".so" @@ -5608,29 +7324,35 @@ SHLIB_LD='${CC} ${CFLAGS} ${LDFLAGS} -shared' DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -Wl,--export-dynamic" - if test $doRpath = yes; then : + if test $doRpath = yes; then - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"' fi + LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - if test "`uname -m`" = "alpha"; then : + if test "`uname -m`" = "alpha"; then CFLAGS="$CFLAGS -mieee" fi - if test $do64bit = yes; then : - { $as_echo "$as_me:${as_lineno-$LINENO}: checking if compiler accepts -m64 flag" >&5 -$as_echo_n "checking if compiler accepts -m64 flag... " >&6; } -if ${tcl_cv_cc_m64+:} false; then : - $as_echo_n "(cached) " >&6 + if test $do64bit = yes; then + + echo "$as_me:$LINENO: checking if compiler accepts -m64 flag" >&5 +echo $ECHO_N "checking if compiler accepts -m64 flag... $ECHO_C" >&6 +if test "${tcl_cv_cc_m64+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else hold_cflags=$CFLAGS CFLAGS="$CFLAGS -m64" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { @@ -5637,53 +7359,102 @@ ; return 0; } _ACEOF -if ac_fn_c_try_link "$LINENO"; then : +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_cc_m64=yes else - tcl_cv_cc_m64=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_cc_m64=no fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext CFLAGS=$hold_cflags fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_m64" >&5 -$as_echo "$tcl_cv_cc_m64" >&6; } - if test $tcl_cv_cc_m64 = yes; then : +echo "$as_me:$LINENO: result: $tcl_cv_cc_m64" >&5 +echo "${ECHO_T}$tcl_cv_cc_m64" >&6 + if test $tcl_cv_cc_m64 = yes; then CFLAGS="$CFLAGS -m64" do64bit_ok=yes fi + fi + # The combo of gcc + glibc has a bug related to inlining of # functions like strtod(). The -fno-builtin flag should address # this problem but it does not work. The -fno-inline flag is kind # of overkill but it works. Disable inlining only when one of the # files in compat/*.c is being linked in. - if test x"${USE_COMPAT}" != x; then : + if test x"${USE_COMPAT}" != x; then CFLAGS="$CFLAGS -fno-inline" fi + ;; Lynx*) SHLIB_CFLAGS="-fPIC" SHLIB_SUFFIX=".so" CFLAGS_OPTIMIZE=-02 SHLIB_LD='${CC} -shared' DL_OBJS="tclLoadDl.o" DL_LIBS="-mshared -ldl" LD_FLAGS="-Wl,--export-dynamic" - if test $doRpath = yes; then : + if test $doRpath = yes; then - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"' + LD_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"' fi + + ;; + MP-RAS-02*) + SHLIB_CFLAGS="-K PIC" + SHLIB_LD='${CC} -G' + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + CC_SEARCH_FLAGS="" + LD_SEARCH_FLAGS="" + ;; + MP-RAS-*) + SHLIB_CFLAGS="-K PIC" + SHLIB_LD='${CC} -G' + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LDFLAGS="$LDFLAGS -Wl,-Bexport" + CC_SEARCH_FLAGS="" + LD_SEARCH_FLAGS="" ;; OpenBSD-*) arch=`arch -s` case "$arch" in alpha|sparc64) @@ -5695,22 +7466,28 @@ esac SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" - if test $doRpath = yes; then : + if test $doRpath = yes; then - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"' fi + LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.${SHLIB_VERSION}' + SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so${SHLIB_VERSION}' LDFLAGS="-Wl,-export-dynamic" CFLAGS_OPTIMIZE="-O2" - # On OpenBSD: Compile with -pthread - # Don't link with -lpthread - LIBS=`echo $LIBS | sed s/-lpthread//` - CFLAGS="$CFLAGS -pthread" + if test "${TCL_THREADS}" = "1"; then + + # On OpenBSD: Compile with -pthread + # Don't link with -lpthread + LIBS=`echo $LIBS | sed s/-lpthread//` + CFLAGS="$CFLAGS -pthread" + +fi + # OpenBSD doesn't do version numbers with dots. UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' TCL_LIB_VERSIONS_OK=nodots ;; NetBSD-*) @@ -5719,38 +7496,48 @@ SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" LDFLAGS="$LDFLAGS -export-dynamic" - if test $doRpath = yes; then : + if test $doRpath = yes; then - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"' fi + LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - # The -pthread needs to go in the CFLAGS, not LIBS - LIBS=`echo $LIBS | sed s/-pthread//` - CFLAGS="$CFLAGS -pthread" - LDFLAGS="$LDFLAGS -pthread" + if test "${TCL_THREADS}" = "1"; then + + # The -pthread needs to go in the CFLAGS, not LIBS + LIBS=`echo $LIBS | sed s/-pthread//` + CFLAGS="$CFLAGS -pthread" + LDFLAGS="$LDFLAGS -pthread" + +fi + ;; DragonFly-*|FreeBSD-*) # This configuration from FreeBSD Ports. SHLIB_CFLAGS="-fPIC" SHLIB_LD="${CC} -shared" SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,-soname,\$@" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" - LDFLAGS="" - if test $doRpath = yes; then : - - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' -fi - # The -pthread needs to go in the LDFLAGS, not LIBS - LIBS=`echo $LIBS | sed s/-pthread//` - CFLAGS="$CFLAGS $PTHREAD_CFLAGS" - LDFLAGS="$LDFLAGS $PTHREAD_LIBS" + if test $doRpath = yes; then + + CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"' + LD_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"' +fi + + if test "${TCL_THREADS}" = "1"; then + + # The -pthread needs to go in the LDFLAGS, not LIBS + LIBS=`echo $LIBS | sed s/-pthread//` + CFLAGS="$CFLAGS $PTHREAD_CFLAGS" + LDFLAGS="$LDFLAGS $PTHREAD_LIBS" +fi + case $system in FreeBSD-3.*) # Version numbers are dot-stripped by system policy. TCL_TRIM_DOTS=`echo ${VERSION} | tr -d .` UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' @@ -5769,112 +7556,176 @@ awk 'BEGIN {FS=" +-";ORS=" "}; {for (i=2;i<=NF;i++) \ if ($i~/^(isysroot|mmacosx-version-min)/) print "-"$i}'`" CFLAGS="`echo " ${CFLAGS}" | \ awk 'BEGIN {FS=" +-";ORS=" "}; {for (i=2;i<=NF;i++) \ if (!($i~/^(isysroot|mmacosx-version-min)/)) print "-"$i}'`" - if test $do64bit = yes; then : - - case `arch` in - ppc) - { $as_echo "$as_me:${as_lineno-$LINENO}: checking if compiler accepts -arch ppc64 flag" >&5 -$as_echo_n "checking if compiler accepts -arch ppc64 flag... " >&6; } -if ${tcl_cv_cc_arch_ppc64+:} false; then : - $as_echo_n "(cached) " >&6 -else - - hold_cflags=$CFLAGS - CFLAGS="$CFLAGS -arch ppc64 -mpowerpc64 -mcpu=G5" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_link "$LINENO"; then : - tcl_cv_cc_arch_ppc64=yes -else - tcl_cv_cc_arch_ppc64=no -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext - CFLAGS=$hold_cflags -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_arch_ppc64" >&5 -$as_echo "$tcl_cv_cc_arch_ppc64" >&6; } - if test $tcl_cv_cc_arch_ppc64 = yes; then : - - CFLAGS="$CFLAGS -arch ppc64 -mpowerpc64 -mcpu=G5" - do64bit_ok=yes - -fi;; - i386) - { $as_echo "$as_me:${as_lineno-$LINENO}: checking if compiler accepts -arch x86_64 flag" >&5 -$as_echo_n "checking if compiler accepts -arch x86_64 flag... " >&6; } -if ${tcl_cv_cc_arch_x86_64+:} false; then : - $as_echo_n "(cached) " >&6 -else - - hold_cflags=$CFLAGS - CFLAGS="$CFLAGS -arch x86_64" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_link "$LINENO"; then : - tcl_cv_cc_arch_x86_64=yes -else - tcl_cv_cc_arch_x86_64=no -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext - CFLAGS=$hold_cflags -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_arch_x86_64" >&5 -$as_echo "$tcl_cv_cc_arch_x86_64" >&6; } - if test $tcl_cv_cc_arch_x86_64 = yes; then : - - CFLAGS="$CFLAGS -arch x86_64" - do64bit_ok=yes - -fi;; - *) - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Don't know how enable 64-bit on architecture \`arch\`" >&5 -$as_echo "$as_me: WARNING: Don't know how enable 64-bit on architecture \`arch\`" >&2;};; + if test $do64bit = yes; then + + case `arch` in + ppc) + echo "$as_me:$LINENO: checking if compiler accepts -arch ppc64 flag" >&5 +echo $ECHO_N "checking if compiler accepts -arch ppc64 flag... $ECHO_C" >&6 +if test "${tcl_cv_cc_arch_ppc64+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + + hold_cflags=$CFLAGS + CFLAGS="$CFLAGS -arch ppc64 -mpowerpc64 -mcpu=G5" + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + tcl_cv_cc_arch_ppc64=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_cc_arch_ppc64=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + CFLAGS=$hold_cflags +fi +echo "$as_me:$LINENO: result: $tcl_cv_cc_arch_ppc64" >&5 +echo "${ECHO_T}$tcl_cv_cc_arch_ppc64" >&6 + if test $tcl_cv_cc_arch_ppc64 = yes; then + + CFLAGS="$CFLAGS -arch ppc64 -mpowerpc64 -mcpu=G5" + do64bit_ok=yes + +fi +;; + i386) + echo "$as_me:$LINENO: checking if compiler accepts -arch x86_64 flag" >&5 +echo $ECHO_N "checking if compiler accepts -arch x86_64 flag... $ECHO_C" >&6 +if test "${tcl_cv_cc_arch_x86_64+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + + hold_cflags=$CFLAGS + CFLAGS="$CFLAGS -arch x86_64" + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + tcl_cv_cc_arch_x86_64=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_cc_arch_x86_64=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + CFLAGS=$hold_cflags +fi +echo "$as_me:$LINENO: result: $tcl_cv_cc_arch_x86_64" >&5 +echo "${ECHO_T}$tcl_cv_cc_arch_x86_64" >&6 + if test $tcl_cv_cc_arch_x86_64 = yes; then + + CFLAGS="$CFLAGS -arch x86_64" + do64bit_ok=yes + +fi +;; + *) + { echo "$as_me:$LINENO: WARNING: Don't know how enable 64-bit on architecture \`arch\`" >&5 +echo "$as_me: WARNING: Don't know how enable 64-bit on architecture \`arch\`" >&2;};; esac else # Check for combined 32-bit and 64-bit fat build if echo "$CFLAGS " |grep -E -q -- '-arch (ppc64|x86_64) ' \ - && echo "$CFLAGS " |grep -E -q -- '-arch (ppc|i386) '; then : + && echo "$CFLAGS " |grep -E -q -- '-arch (ppc|i386) '; then fat_32_64=yes fi + fi + SHLIB_LD='${CC} -dynamiclib ${CFLAGS} ${LDFLAGS}' - { $as_echo "$as_me:${as_lineno-$LINENO}: checking if ld accepts -single_module flag" >&5 -$as_echo_n "checking if ld accepts -single_module flag... " >&6; } -if ${tcl_cv_ld_single_module+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking if ld accepts -single_module flag" >&5 +echo $ECHO_N "checking if ld accepts -single_module flag... $ECHO_C" >&6 +if test "${tcl_cv_ld_single_module+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else hold_ldflags=$LDFLAGS LDFLAGS="$LDFLAGS -dynamiclib -Wl,-single_module" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { @@ -5881,39 +7732,68 @@ int i; ; return 0; } _ACEOF -if ac_fn_c_try_link "$LINENO"; then : +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_ld_single_module=yes else - tcl_cv_ld_single_module=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_ld_single_module=no fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LDFLAGS=$hold_ldflags fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_ld_single_module" >&5 -$as_echo "$tcl_cv_ld_single_module" >&6; } - if test $tcl_cv_ld_single_module = yes; then : +echo "$as_me:$LINENO: result: $tcl_cv_ld_single_module" >&5 +echo "${ECHO_T}$tcl_cv_ld_single_module" >&6 + if test $tcl_cv_ld_single_module = yes; then SHLIB_LD="${SHLIB_LD} -Wl,-single_module" fi + SHLIB_SUFFIX=".dylib" DL_OBJS="tclLoadDyld.o" DL_LIBS="" LDFLAGS="$LDFLAGS -headerpad_max_install_names" - { $as_echo "$as_me:${as_lineno-$LINENO}: checking if ld accepts -search_paths_first flag" >&5 -$as_echo_n "checking if ld accepts -search_paths_first flag... " >&6; } -if ${tcl_cv_ld_search_paths_first+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking if ld accepts -search_paths_first flag" >&5 +echo $ECHO_N "checking if ld accepts -search_paths_first flag... $ECHO_C" >&6 +if test "${tcl_cv_ld_search_paths_first+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else hold_ldflags=$LDFLAGS LDFLAGS="$LDFLAGS -Wl,-search_paths_first" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { @@ -5920,73 +7800,109 @@ int i; ; return 0; } _ACEOF -if ac_fn_c_try_link "$LINENO"; then : +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_ld_search_paths_first=yes else - tcl_cv_ld_search_paths_first=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_ld_search_paths_first=no fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LDFLAGS=$hold_ldflags fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_ld_search_paths_first" >&5 -$as_echo "$tcl_cv_ld_search_paths_first" >&6; } - if test $tcl_cv_ld_search_paths_first = yes; then : +echo "$as_me:$LINENO: result: $tcl_cv_ld_search_paths_first" >&5 +echo "${ECHO_T}$tcl_cv_ld_search_paths_first" >&6 + if test $tcl_cv_ld_search_paths_first = yes; then LDFLAGS="$LDFLAGS -Wl,-search_paths_first" fi - if test "$tcl_cv_cc_visibility_hidden" != yes; then : + + if test "$tcl_cv_cc_visibility_hidden" != yes; then -$as_echo "#define MODULE_SCOPE __private_extern__" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define MODULE_SCOPE __private_extern__ +_ACEOF + tcl_cv_cc_visibility_hidden=yes fi + CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH" -$as_echo "#define MAC_OSX_TCL 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define MAC_OSX_TCL 1 +_ACEOF PLAT_OBJS='${MAC_OSX_OBJS}' PLAT_SRCS='${MAC_OSX_SRCS}' - { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to use CoreFoundation" >&5 -$as_echo_n "checking whether to use CoreFoundation... " >&6; } - # Check whether --enable-corefoundation was given. -if test "${enable_corefoundation+set}" = set; then : - enableval=$enable_corefoundation; tcl_corefoundation=$enableval + echo "$as_me:$LINENO: checking whether to use CoreFoundation" >&5 +echo $ECHO_N "checking whether to use CoreFoundation... $ECHO_C" >&6 + # Check whether --enable-corefoundation or --disable-corefoundation was given. +if test "${enable_corefoundation+set}" = set; then + enableval="$enable_corefoundation" + tcl_corefoundation=$enableval else tcl_corefoundation=yes -fi - - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_corefoundation" >&5 -$as_echo "$tcl_corefoundation" >&6; } - if test $tcl_corefoundation = yes; then : - - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for CoreFoundation.framework" >&5 -$as_echo_n "checking for CoreFoundation.framework... " >&6; } -if ${tcl_cv_lib_corefoundation+:} false; then : - $as_echo_n "(cached) " >&6 +fi; + echo "$as_me:$LINENO: result: $tcl_corefoundation" >&5 +echo "${ECHO_T}$tcl_corefoundation" >&6 + if test $tcl_corefoundation = yes; then + + echo "$as_me:$LINENO: checking for CoreFoundation.framework" >&5 +echo $ECHO_N "checking for CoreFoundation.framework... $ECHO_C" >&6 +if test "${tcl_cv_lib_corefoundation+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else hold_libs=$LIBS - if test "$fat_32_64" = yes; then : + if test "$fat_32_64" = yes; then for v in CFLAGS CPPFLAGS LDFLAGS; do # On Tiger there is no 64-bit CF, so remove 64-bit # archs from CFLAGS et al. while testing for # presence of CF. 64-bit CF is disabled in # tclUnixPort.h if necessary. eval 'hold_'$v'="$'$v'";'$v'="`echo "$'$v' "|sed -e "s/-arch ppc64 / /g" -e "s/-arch x86_64 / /g"`"' done fi + LIBS="$LIBS -framework CoreFoundation" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { @@ -5993,49 +7909,81 @@ CFBundleRef b = CFBundleGetMainBundle(); ; return 0; } _ACEOF -if ac_fn_c_try_link "$LINENO"; then : +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_lib_corefoundation=yes else - tcl_cv_lib_corefoundation=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_lib_corefoundation=no fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext - if test "$fat_32_64" = yes; then : +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + if test "$fat_32_64" = yes; then for v in CFLAGS CPPFLAGS LDFLAGS; do eval $v'="$hold_'$v'"' done fi + LIBS=$hold_libs fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_lib_corefoundation" >&5 -$as_echo "$tcl_cv_lib_corefoundation" >&6; } - if test $tcl_cv_lib_corefoundation = yes; then : +echo "$as_me:$LINENO: result: $tcl_cv_lib_corefoundation" >&5 +echo "${ECHO_T}$tcl_cv_lib_corefoundation" >&6 + if test $tcl_cv_lib_corefoundation = yes; then LIBS="$LIBS -framework CoreFoundation" -$as_echo "#define HAVE_COREFOUNDATION 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_COREFOUNDATION 1 +_ACEOF else tcl_corefoundation=no fi - if test "$fat_32_64" = yes -a $tcl_corefoundation = yes; then : - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for 64-bit CoreFoundation" >&5 -$as_echo_n "checking for 64-bit CoreFoundation... " >&6; } -if ${tcl_cv_lib_corefoundation_64+:} false; then : - $as_echo_n "(cached) " >&6 + if test "$fat_32_64" = yes -a $tcl_corefoundation = yes; then + + echo "$as_me:$LINENO: checking for 64-bit CoreFoundation" >&5 +echo $ECHO_N "checking for 64-bit CoreFoundation... $ECHO_C" >&6 +if test "${tcl_cv_lib_corefoundation_64+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else for v in CFLAGS CPPFLAGS LDFLAGS; do eval 'hold_'$v'="$'$v'";'$v'="`echo "$'$v' "|sed -e "s/-arch ppc / /g" -e "s/-arch i386 / /g"`"' done - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { @@ -6042,83 +7990,163 @@ CFBundleRef b = CFBundleGetMainBundle(); ; return 0; } _ACEOF -if ac_fn_c_try_link "$LINENO"; then : +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_lib_corefoundation_64=yes else - tcl_cv_lib_corefoundation_64=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_lib_corefoundation_64=no fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext for v in CFLAGS CPPFLAGS LDFLAGS; do eval $v'="$hold_'$v'"' done fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_lib_corefoundation_64" >&5 -$as_echo "$tcl_cv_lib_corefoundation_64" >&6; } - if test $tcl_cv_lib_corefoundation_64 = no; then : +echo "$as_me:$LINENO: result: $tcl_cv_lib_corefoundation_64" >&5 +echo "${ECHO_T}$tcl_cv_lib_corefoundation_64" >&6 + if test $tcl_cv_lib_corefoundation_64 = no; then -$as_echo "#define NO_COREFOUNDATION_64 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define NO_COREFOUNDATION_64 1 +_ACEOF LDFLAGS="$LDFLAGS -Wl,-no_arch_warnings" fi + fi + fi + + ;; + NEXTSTEP-*) + SHLIB_CFLAGS="" + SHLIB_LD='${CC} -nostdlib -r' + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadNext.o" + DL_LIBS="" + CC_SEARCH_FLAGS="" + LD_SEARCH_FLAGS="" ;; OS/390-*) SHLIB_LD_LIBS="" CFLAGS_OPTIMIZE="" # Optimizer is buggy -$as_echo "#define _OE_SOCKETS 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define _OE_SOCKETS 1 +_ACEOF + ;; + OSF1-1.0|OSF1-1.1|OSF1-1.2) + # OSF/1 1.[012] from OSF, and derivatives, including Paragon OSF/1 + SHLIB_CFLAGS="" + # Hack: make package name same as library name + SHLIB_LD='ld -R -export :' + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadOSF.o" + DL_LIBS="" + CC_SEARCH_FLAGS="" + LD_SEARCH_FLAGS="" + ;; + OSF1-1.*) + # OSF/1 1.3 from OSF using ELF, and derivatives, including AD2 + SHLIB_CFLAGS="-fPIC" + if test "$SHARED_BUILD" = 1; then + SHLIB_LD="ld -shared" +else + + SHLIB_LD="ld -non_shared" + +fi + + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="" + CC_SEARCH_FLAGS="" + LD_SEARCH_FLAGS="" ;; OSF1-V*) # Digital OSF/1 SHLIB_CFLAGS="" - if test "$SHARED_BUILD" = 1; then : + if test "$SHARED_BUILD" = 1; then SHLIB_LD='ld -shared -expect_unresolved "*"' else SHLIB_LD='ld -non_shared -expect_unresolved "*"' fi + SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" - if test $doRpath = yes; then : + if test $doRpath = yes; then - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"' LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' fi - if test "$GCC" = yes; then : + + if test "$GCC" = yes; then CFLAGS="$CFLAGS -mieee" else CFLAGS="$CFLAGS -DHAVE_TZSET -std1 -ieee" fi + # see pthread_intro(3) for pthread support on osf1, k.furukawa - CFLAGS="$CFLAGS -DHAVE_PTHREAD_ATTR_SETSTACKSIZE" - CFLAGS="$CFLAGS -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64" - LIBS=`echo $LIBS | sed s/-lpthreads//` - if test "$GCC" = yes; then : + if test "${TCL_THREADS}" = 1; then - LIBS="$LIBS -lpthread -lmach -lexc" + CFLAGS="$CFLAGS -DHAVE_PTHREAD_ATTR_SETSTACKSIZE" + CFLAGS="$CFLAGS -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64" + LIBS=`echo $LIBS | sed s/-lpthreads//` + if test "$GCC" = yes; then + + LIBS="$LIBS -lpthread -lmach -lexc" else - CFLAGS="$CFLAGS -pthread" - LDFLAGS="$LDFLAGS -pthread" + CFLAGS="$CFLAGS -pthread" + LDFLAGS="$LDFLAGS -pthread" fi + + +fi + ;; QNX-6*) # QNX RTP # This may work for all QNX, but it was only reported for v6. SHLIB_CFLAGS="-fPIC" @@ -6133,11 +8161,11 @@ ;; SCO_SV-3.2*) # Note, dlopen is available only on SCO 3.2.5 and greater. However, # this test works, since "uname -s" was non-standard in 3.2.4 and # below. - if test "$GCC" = yes; then : + if test "$GCC" = yes; then SHLIB_CFLAGS="-fPIC -melf" LDFLAGS="$LDFLAGS -melf -Wl,-Bexport" else @@ -6144,36 +8172,70 @@ SHLIB_CFLAGS="-Kpic -belf" LDFLAGS="$LDFLAGS -belf -Wl,-Bexport" fi + SHLIB_LD="ld -G" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; + SINIX*5.4*) + SHLIB_CFLAGS="-K PIC" + SHLIB_LD='${CC} -G' + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + CC_SEARCH_FLAGS="" + LD_SEARCH_FLAGS="" + ;; + SunOS-4*) + SHLIB_CFLAGS="-PIC" + SHLIB_LD="ld" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' + LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} + + # SunOS can't handle version numbers with dots in them in library + # specs, like -ltcl7.5, so use -ltcl75 instead. Also, it + # requires an extra version number at the end of .so file names. + # So, the library has to have a name like libtcl75.so.1.0 + + SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so${SHLIB_VERSION}' + UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' + TCL_LIB_VERSIONS_OK=nodots + ;; SunOS-5.[0-6]) # Careful to not let 5.10+ fall into this case # Note: If _REENTRANT isn't defined, then Solaris # won't define thread-safe library routines. -$as_echo "#define _REENTRANT 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define _REENTRANT 1 +_ACEOF -$as_echo "#define _POSIX_PTHREAD_SEMANTICS 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define _POSIX_PTHREAD_SEMANTICS 1 +_ACEOF SHLIB_CFLAGS="-KPIC" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" - if test "$GCC" = yes; then : + if test "$GCC" = yes; then SHLIB_LD='${CC} -shared' CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} @@ -6182,50 +8244,56 @@ SHLIB_LD="/usr/ccs/bin/ld -G -z text" CC_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} fi + ;; SunOS-5*) # Note: If _REENTRANT isn't defined, then Solaris # won't define thread-safe library routines. -$as_echo "#define _REENTRANT 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define _REENTRANT 1 +_ACEOF -$as_echo "#define _POSIX_PTHREAD_SEMANTICS 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define _POSIX_PTHREAD_SEMANTICS 1 +_ACEOF SHLIB_CFLAGS="-KPIC" # Check to enable 64-bit flags for compiler/linker - if test "$do64bit" = yes; then : + if test "$do64bit" = yes; then arch=`isainfo` - if test "$arch" = "sparcv9 sparc"; then : - - if test "$GCC" = yes; then : - - if test "`${CC} -dumpversion | awk -F. '{print $1}'`" -lt 3; then : - - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported with GCC < 3.2 on $system" >&5 -$as_echo "$as_me: WARNING: 64bit mode not supported with GCC < 3.2 on $system" >&2;} + if test "$arch" = "sparcv9 sparc"; then + + if test "$GCC" = yes; then + + if test "`${CC} -dumpversion | awk -F. '{print $1}'`" -lt 3; then + + { echo "$as_me:$LINENO: WARNING: 64bit mode not supported with GCC < 3.2 on $system" >&5 +echo "$as_me: WARNING: 64bit mode not supported with GCC < 3.2 on $system" >&2;} else do64bit_ok=yes CFLAGS="$CFLAGS -m64 -mcpu=v9" LDFLAGS="$LDFLAGS -m64 -mcpu=v9" SHLIB_CFLAGS="-fPIC" fi + else do64bit_ok=yes - if test "$do64bitVIS" = yes; then : + if test "$do64bitVIS" = yes; then CFLAGS="$CFLAGS -xarch=v9a" LDFLAGS_ARCH="-xarch=v9a" else @@ -6232,28 +8300,30 @@ CFLAGS="$CFLAGS -xarch=v9" LDFLAGS_ARCH="-xarch=v9" fi + # Solaris 64 uses this as well #LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH_64" fi + else - if test "$arch" = "amd64 i386"; then : + if test "$arch" = "amd64 i386"; then - if test "$GCC" = yes; then : + if test "$GCC" = yes; then case $system in SunOS-5.1[1-9]*|SunOS-5.[2-9][0-9]*) do64bit_ok=yes CFLAGS="$CFLAGS -m64" LDFLAGS="$LDFLAGS -m64";; *) - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported with GCC on $system" >&5 -$as_echo "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;};; + { echo "$as_me:$LINENO: WARNING: 64bit mode not supported with GCC on $system" >&5 +echo "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;};; esac else do64bit_ok=yes @@ -6265,63 +8335,202 @@ CFLAGS="$CFLAGS -xarch=amd64" LDFLAGS="$LDFLAGS -xarch=amd64";; esac fi + else - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported for $arch" >&5 -$as_echo "$as_me: WARNING: 64bit mode not supported for $arch" >&2;} -fi + { echo "$as_me:$LINENO: WARNING: 64bit mode not supported for $arch" >&5 +echo "$as_me: WARNING: 64bit mode not supported for $arch" >&2;} fi fi + + +fi + #-------------------------------------------------------------------- # On Solaris 5.x i386 with the sunpro compiler we need to link # with sunmath to get floating point rounding control #-------------------------------------------------------------------- - if test "$GCC" = yes; then : + if test "$GCC" = yes; then use_sunmath=no else arch=`isainfo` - { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to use -lsunmath for fp rounding control" >&5 -$as_echo_n "checking whether to use -lsunmath for fp rounding control... " >&6; } - if test "$arch" = "amd64 i386" -o "$arch" = "i386"; then : + echo "$as_me:$LINENO: checking whether to use -lsunmath for fp rounding control" >&5 +echo $ECHO_N "checking whether to use -lsunmath for fp rounding control... $ECHO_C" >&6 + if test "$arch" = "amd64 i386" -o "$arch" = "i386"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -$as_echo "yes" >&6; } + echo "$as_me:$LINENO: result: yes" >&5 +echo "${ECHO_T}yes" >&6 MATH_LIBS="-lsunmath $MATH_LIBS" - ac_fn_c_check_header_mongrel "$LINENO" "sunmath.h" "ac_cv_header_sunmath_h" "$ac_includes_default" -if test "x$ac_cv_header_sunmath_h" = xyes; then : + if test "${ac_cv_header_sunmath_h+set}" = set; then + echo "$as_me:$LINENO: checking for sunmath.h" >&5 +echo $ECHO_N "checking for sunmath.h... $ECHO_C" >&6 +if test "${ac_cv_header_sunmath_h+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +fi +echo "$as_me:$LINENO: result: $ac_cv_header_sunmath_h" >&5 +echo "${ECHO_T}$ac_cv_header_sunmath_h" >&6 +else + # Is the header compilable? +echo "$as_me:$LINENO: checking sunmath.h usability" >&5 +echo $ECHO_N "checking sunmath.h usability... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +#include +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_header_compiler=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_header_compiler=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 +echo "${ECHO_T}$ac_header_compiler" >&6 + +# Is the header present? +echo "$as_me:$LINENO: checking sunmath.h presence" >&5 +echo $ECHO_N "checking sunmath.h presence... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include +_ACEOF +if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 + (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null; then + if test -s conftest.err; then + ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag + else + ac_cpp_err= + fi +else + ac_cpp_err=yes +fi +if test -z "$ac_cpp_err"; then + ac_header_preproc=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_header_preproc=no +fi +rm -f conftest.err conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 +echo "${ECHO_T}$ac_header_preproc" >&6 + +# So? What about this header? +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) + { echo "$as_me:$LINENO: WARNING: sunmath.h: accepted by the compiler, rejected by the preprocessor!" >&5 +echo "$as_me: WARNING: sunmath.h: accepted by the compiler, rejected by the preprocessor!" >&2;} + { echo "$as_me:$LINENO: WARNING: sunmath.h: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: sunmath.h: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes + ;; + no:yes:* ) + { echo "$as_me:$LINENO: WARNING: sunmath.h: present but cannot be compiled" >&5 +echo "$as_me: WARNING: sunmath.h: present but cannot be compiled" >&2;} + { echo "$as_me:$LINENO: WARNING: sunmath.h: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: sunmath.h: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: sunmath.h: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: sunmath.h: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: sunmath.h: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: sunmath.h: section \"Present But Cannot Be Compiled\"" >&2;} + { echo "$as_me:$LINENO: WARNING: sunmath.h: proceeding with the preprocessor's result" >&5 +echo "$as_me: WARNING: sunmath.h: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: sunmath.h: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: sunmath.h: in the future, the compiler will take precedence" >&2;} + ( + cat <<\_ASBOX +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## +_ASBOX + ) | + sed "s/^/$as_me: WARNING: /" >&2 + ;; +esac +echo "$as_me:$LINENO: checking for sunmath.h" >&5 +echo $ECHO_N "checking for sunmath.h... $ECHO_C" >&6 +if test "${ac_cv_header_sunmath_h+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_cv_header_sunmath_h=$ac_header_preproc +fi +echo "$as_me:$LINENO: result: $ac_cv_header_sunmath_h" >&5 +echo "${ECHO_T}$ac_cv_header_sunmath_h" >&6 fi use_sunmath=yes else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 use_sunmath=no fi + fi + SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" - if test "$GCC" = yes; then : + if test "$GCC" = yes; then SHLIB_LD='${CC} -shared' CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - if test "$do64bit_ok" = yes; then : + if test "$do64bit_ok" = yes; then - if test "$arch" = "sparcv9 sparc"; then : + if test "$arch" = "sparcv9 sparc"; then # We need to specify -static-libgcc or we need to # add the path to the sparv9 libgcc. SHLIB_LD="$SHLIB_LD -m64 -mcpu=v9 -static-libgcc" # for finding sparcv9 libgcc, get the regular libgcc @@ -6328,26 +8537,30 @@ # path, remove so name and append 'sparcv9' #v9gcclibdir="`gcc -print-file-name=libgcc_s.so` | ..." #CC_SEARCH_FLAGS="${CC_SEARCH_FLAGS},-R,$v9gcclibdir" else - if test "$arch" = "amd64 i386"; then : + if test "$arch" = "amd64 i386"; then SHLIB_LD="$SHLIB_LD -m64 -static-libgcc" fi -fi fi + + +fi + else - if test "$use_sunmath" = yes; then : + if test "$use_sunmath" = yes; then textmode=textoff else textmode=text fi + case $system in SunOS-5.[1-9][0-9]*|SunOS-5.[7-9]) SHLIB_LD="\${CC} -G -z $textmode \${LDFLAGS}";; *) SHLIB_LD="/usr/ccs/bin/ld -G -z $textmode";; @@ -6354,10 +8567,11 @@ esac CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' fi + ;; UNIX_SV* | UnixWare-5*) SHLIB_CFLAGS="-KPIC" SHLIB_LD='${CC} -G' SHLIB_LD_LIBS="" @@ -6364,19 +8578,23 @@ SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" # Some UNIX_SV* systems (unixware 1.1.2 for example) have linkers # that don't grok the -Bexport option. Test that it does. - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ld accepts -Bexport flag" >&5 -$as_echo_n "checking for ld accepts -Bexport flag... " >&6; } -if ${tcl_cv_ld_Bexport+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking for ld accepts -Bexport flag" >&5 +echo $ECHO_N "checking for ld accepts -Bexport flag... $ECHO_C" >&6 +if test "${tcl_cv_ld_Bexport+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else hold_ldflags=$LDFLAGS LDFLAGS="$LDFLAGS -Wl,-Bexport" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { @@ -6383,67 +8601,97 @@ int i; ; return 0; } _ACEOF -if ac_fn_c_try_link "$LINENO"; then : +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_ld_Bexport=yes else - tcl_cv_ld_Bexport=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_ld_Bexport=no fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LDFLAGS=$hold_ldflags fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_ld_Bexport" >&5 -$as_echo "$tcl_cv_ld_Bexport" >&6; } - if test $tcl_cv_ld_Bexport = yes; then : +echo "$as_me:$LINENO: result: $tcl_cv_ld_Bexport" >&5 +echo "${ECHO_T}$tcl_cv_ld_Bexport" >&6 + if test $tcl_cv_ld_Bexport = yes; then LDFLAGS="$LDFLAGS -Wl,-Bexport" fi + CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; esac - if test "$do64bit" = yes -a "$do64bit_ok" = no; then : + if test "$do64bit" = yes -a "$do64bit_ok" = no; then - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: 64bit support being disabled -- don't know magic for this platform" >&5 -$as_echo "$as_me: WARNING: 64bit support being disabled -- don't know magic for this platform" >&2;} + { echo "$as_me:$LINENO: WARNING: 64bit support being disabled -- don't know magic for this platform" >&5 +echo "$as_me: WARNING: 64bit support being disabled -- don't know magic for this platform" >&2;} fi - if test "$do64bit" = yes -a "$do64bit_ok" = yes; then : + + if test "$do64bit" = yes -a "$do64bit_ok" = yes; then -$as_echo "#define TCL_CFG_DO64BIT 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define TCL_CFG_DO64BIT 1 +_ACEOF fi + # Step 4: disable dynamic loading if requested via a command-line switch. - # Check whether --enable-load was given. -if test "${enable_load+set}" = set; then : - enableval=$enable_load; tcl_ok=$enableval + # Check whether --enable-load or --disable-load was given. +if test "${enable_load+set}" = set; then + enableval="$enable_load" + tcl_ok=$enableval else tcl_ok=yes -fi - - if test "$tcl_ok" = no; then : +fi; + if test "$tcl_ok" = no; then DL_OBJS="" fi - if test "x$DL_OBJS" != x; then : + + if test "x$DL_OBJS" != x; then BUILD_DLTEST="\$(DLTEST_TARGETS)" else - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Can't figure out how to do dynamic loading or shared libraries on this system." >&5 -$as_echo "$as_me: WARNING: Can't figure out how to do dynamic loading or shared libraries on this system." >&2;} + { echo "$as_me:$LINENO: WARNING: Can't figure out how to do dynamic loading or shared libraries on this system." >&5 +echo "$as_me: WARNING: Can't figure out how to do dynamic loading or shared libraries on this system." >&2;} SHLIB_CFLAGS="" SHLIB_LD="" SHLIB_SUFFIX="" DL_OBJS="tclLoadNone.o" DL_LIBS="" @@ -6451,17 +8699,18 @@ CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" BUILD_DLTEST="" fi + LDFLAGS="$LDFLAGS $LDFLAGS_ARCH" # If we're running gcc, then change the C flags for compiling shared # libraries to the right flags for gcc, instead of those for the # standard manufacturer compiler. - if test "$DL_OBJS" != "tclLoadNone.o" -a "$GCC" = yes; then : + if test "$DL_OBJS" != "tclLoadNone.o" -a "$GCC" = yes; then case $system in AIX-*) ;; BSD/OS*) ;; CYGWIN_*) ;; @@ -6471,91 +8720,106 @@ SCO_SV-3.2*) ;; *) SHLIB_CFLAGS="-fPIC" ;; esac fi - if test "$tcl_cv_cc_visibility_hidden" != yes; then : + + if test "$tcl_cv_cc_visibility_hidden" != yes; then -$as_echo "#define MODULE_SCOPE extern" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define MODULE_SCOPE extern +_ACEOF fi - if test "$SHARED_LIB_SUFFIX" = ""; then : + + if test "$SHARED_LIB_SUFFIX" = ""; then SHARED_LIB_SUFFIX='${VERSION}${SHLIB_SUFFIX}' fi - if test "$UNSHARED_LIB_SUFFIX" = ""; then : + + if test "$UNSHARED_LIB_SUFFIX" = ""; then UNSHARED_LIB_SUFFIX='${VERSION}.a' fi + DLL_INSTALL_DIR="\$(LIB_INSTALL_DIR)" - if test "${SHARED_BUILD}" = 1 -a "${SHLIB_SUFFIX}" != ""; then : + if test "${SHARED_BUILD}" = 1 -a "${SHLIB_SUFFIX}" != ""; then LIB_SUFFIX=${SHARED_LIB_SUFFIX} - MAKE_LIB='${SHLIB_LD} -o $@ ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}' - if test "${SHLIB_SUFFIX}" = ".dll"; then : + MAKE_LIB='${SHLIB_LD} -o $@ ${OBJS} ${LDFLAGS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}' + if test "${SHLIB_SUFFIX}" = ".dll"; then INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(BIN_INSTALL_DIR)/$(LIB_FILE)";if test -f $(LIB_FILE).a; then $(INSTALL_DATA) $(LIB_FILE).a "$(LIB_INSTALL_DIR)"; fi;' DLL_INSTALL_DIR="\$(BIN_INSTALL_DIR)" else INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(LIB_INSTALL_DIR)/$(LIB_FILE)"' fi + else LIB_SUFFIX=${UNSHARED_LIB_SUFFIX} - if test "$RANLIB" = ""; then : + if test "$RANLIB" = ""; then MAKE_LIB='$(STLIB_LD) $@ ${OBJS}' else MAKE_LIB='${STLIB_LD} $@ ${OBJS} ; ${RANLIB} $@' fi + INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(LIB_INSTALL_DIR)/$(LIB_FILE)"' fi + # Stub lib does not depend on shared/static configuration - if test "$RANLIB" = ""; then : + if test "$RANLIB" = ""; then MAKE_STUB_LIB='${STLIB_LD} $@ ${STUB_LIB_OBJS}' else MAKE_STUB_LIB='${STLIB_LD} $@ ${STUB_LIB_OBJS} ; ${RANLIB} $@' fi + INSTALL_STUB_LIB='$(INSTALL_LIBRARY) $(STUB_LIB_FILE) "$(LIB_INSTALL_DIR)/$(STUB_LIB_FILE)"' # Define TCL_LIBS now that we know what DL_LIBS is. # The trick here is that we don't want to change the value of TCL_LIBS if # it is already set when tclConfig.sh had been loaded by Tk. - if test "x${TCL_LIBS}" = x; then : + if test "x${TCL_LIBS}" = x; then TCL_LIBS="${DL_LIBS} ${LIBS} ${MATH_LIBS}" fi + # See if the compiler supports casting to a union type. # This is used to stop gcc from printing a compiler # warning when initializing a union member. - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for cast to union support" >&5 -$as_echo_n "checking for cast to union support... " >&6; } -if ${tcl_cv_cast_to_union+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking for cast to union support" >&5 +echo $ECHO_N "checking for cast to union support... $ECHO_C" >&6 +if test "${tcl_cv_cast_to_union+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { @@ -6565,23 +8829,49 @@ ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_cast_to_union=yes else - tcl_cv_cast_to_union=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_cast_to_union=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cast_to_union" >&5 -$as_echo "$tcl_cv_cast_to_union" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_cast_to_union" >&5 +echo "${ECHO_T}$tcl_cv_cast_to_union" >&6 if test "$tcl_cv_cast_to_union" = "yes"; then -$as_echo "#define HAVE_CAST_TO_UNION 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_CAST_TO_UNION 1 +_ACEOF fi # FIXME: This subst was left in only because the TCL_DL_LIBS # entry in tclConfig.sh uses it. It is not clear why someone @@ -6623,86 +8913,106 @@ - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for build with symbols" >&5 -$as_echo_n "checking for build with symbols... " >&6; } - # Check whether --enable-symbols was given. -if test "${enable_symbols+set}" = set; then : - enableval=$enable_symbols; tcl_ok=$enableval + echo "$as_me:$LINENO: checking for build with symbols" >&5 +echo $ECHO_N "checking for build with symbols... $ECHO_C" >&6 + # Check whether --enable-symbols or --disable-symbols was given. +if test "${enable_symbols+set}" = set; then + enableval="$enable_symbols" + tcl_ok=$enableval else tcl_ok=no -fi - +fi; # FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT. - DBGX="" if test "$tcl_ok" = "no"; then CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)' LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)' -$as_echo "#define NDEBUG 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define NDEBUG 1 +_ACEOF - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 -$as_echo "#define TCL_CFG_OPTIMIZED 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define TCL_CFG_OPTIMIZED 1 +_ACEOF else CFLAGS_DEFAULT='$(CFLAGS_DEBUG)' LDFLAGS_DEFAULT='$(LDFLAGS_DEBUG)' if test "$tcl_ok" = "yes"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes (standard debugging)" >&5 -$as_echo "yes (standard debugging)" >&6; } + echo "$as_me:$LINENO: result: yes (standard debugging)" >&5 +echo "${ECHO_T}yes (standard debugging)" >&6 fi fi if test "$tcl_ok" = "mem" -o "$tcl_ok" = "all"; then -$as_echo "#define TCL_MEM_DEBUG 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define TCL_MEM_DEBUG 1 +_ACEOF fi if test "$tcl_ok" = "compile" -o "$tcl_ok" = "all"; then -$as_echo "#define TCL_COMPILE_DEBUG 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define TCL_COMPILE_DEBUG 1 +_ACEOF -$as_echo "#define TCL_COMPILE_STATS 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define TCL_COMPILE_STATS 1 +_ACEOF fi if test "$tcl_ok" != "yes" -a "$tcl_ok" != "no"; then if test "$tcl_ok" = "all"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: enabled symbols mem compile debugging" >&5 -$as_echo "enabled symbols mem compile debugging" >&6; } + echo "$as_me:$LINENO: result: enabled symbols mem compile debugging" >&5 +echo "${ECHO_T}enabled symbols mem compile debugging" >&6 else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: enabled $tcl_ok debugging" >&5 -$as_echo "enabled $tcl_ok debugging" >&6; } + echo "$as_me:$LINENO: result: enabled $tcl_ok debugging" >&5 +echo "${ECHO_T}enabled $tcl_ok debugging" >&6 fi fi -$as_echo "#define MP_PREC 4" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define TCL_TOMMATH 1 +_ACEOF + + +cat >>confdefs.h <<\_ACEOF +#define MP_PREC 4 +_ACEOF #-------------------------------------------------------------------- # Detect what compiler flags to set for 64-bit support. #-------------------------------------------------------------------- - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for required early compiler flags" >&5 -$as_echo_n "checking for required early compiler flags... " >&6; } + echo "$as_me:$LINENO: checking for required early compiler flags" >&5 +echo $ECHO_N "checking for required early compiler flags... $ECHO_C" >&6 tcl_flags="" - if ${tcl_cv_flag__isoc99_source+:} false; then : - $as_echo_n "(cached) " >&6 + if test "${tcl_cv_flag__isoc99_source+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { @@ -6709,14 +9019,42 @@ char *p = (char *)strtoll; char *q = (char *)strtoull; ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_flag__isoc99_source=no else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #define _ISOC99_SOURCE 1 #include int main () @@ -6724,32 +9062,62 @@ char *p = (char *)strtoll; char *q = (char *)strtoull; ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_flag__isoc99_source=yes else - tcl_cv_flag__isoc99_source=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_flag__isoc99_source=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi if test "x${tcl_cv_flag__isoc99_source}" = "xyes" ; then -$as_echo "#define _ISOC99_SOURCE 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define _ISOC99_SOURCE 1 +_ACEOF tcl_flags="$tcl_flags _ISOC99_SOURCE" fi - if ${tcl_cv_flag__largefile64_source+:} false; then : - $as_echo_n "(cached) " >&6 + if test "${tcl_cv_flag__largefile64_source+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { @@ -6756,14 +9124,42 @@ struct stat64 buf; int i = stat64("/", &buf); ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_flag__largefile64_source=no else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #define _LARGEFILE64_SOURCE 1 #include int main () @@ -6771,32 +9167,62 @@ struct stat64 buf; int i = stat64("/", &buf); ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_flag__largefile64_source=yes else - tcl_cv_flag__largefile64_source=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_flag__largefile64_source=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi if test "x${tcl_cv_flag__largefile64_source}" = "xyes" ; then -$as_echo "#define _LARGEFILE64_SOURCE 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define _LARGEFILE64_SOURCE 1 +_ACEOF tcl_flags="$tcl_flags _LARGEFILE64_SOURCE" fi - if ${tcl_cv_flag__largefile_source64+:} false; then : - $as_echo_n "(cached) " >&6 + if test "${tcl_cv_flag__largefile_source64+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { @@ -6803,14 +9229,42 @@ char *p = (char *)open64; ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_flag__largefile_source64=no else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #define _LARGEFILE_SOURCE64 1 #include int main () @@ -6818,46 +9272,76 @@ char *p = (char *)open64; ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_flag__largefile_source64=yes else - tcl_cv_flag__largefile_source64=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_flag__largefile_source64=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi if test "x${tcl_cv_flag__largefile_source64}" = "xyes" ; then -$as_echo "#define _LARGEFILE_SOURCE64 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define _LARGEFILE_SOURCE64 1 +_ACEOF tcl_flags="$tcl_flags _LARGEFILE_SOURCE64" fi if test "x${tcl_flags}" = "x" ; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: none" >&5 -$as_echo "none" >&6; } + echo "$as_me:$LINENO: result: none" >&5 +echo "${ECHO_T}none" >&6 else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: ${tcl_flags}" >&5 -$as_echo "${tcl_flags}" >&6; } + echo "$as_me:$LINENO: result: ${tcl_flags}" >&5 +echo "${ECHO_T}${tcl_flags}" >&6 fi - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for 64-bit integer type" >&5 -$as_echo_n "checking for 64-bit integer type... " >&6; } - if ${tcl_cv_type_64bit+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking for 64-bit integer type" >&5 +echo $ECHO_N "checking for 64-bit integer type... $ECHO_C" >&6 + if test "${tcl_cv_type_64bit+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else tcl_cv_type_64bit=none # See if the compiler knows natively about __int64 - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { @@ -6864,20 +9348,48 @@ __int64 value = (__int64) 0; ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_type_64bit=__int64 else - tcl_type_64bit="long long" + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_type_64bit="long long" fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - # See if we could use long anyway Note that we substitute in the +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext + # See if we should use long anyway Note that we substitute in the # type that is our current guess for a 64-bit type inside this check # program, so it should be modified only carefully... - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { @@ -6886,39 +9398,70 @@ } ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_type_64bit=${tcl_type_64bit} +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi if test "${tcl_cv_type_64bit}" = none ; then -$as_echo "#define TCL_WIDE_INT_IS_LONG 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define TCL_WIDE_INT_IS_LONG 1 +_ACEOF - { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -$as_echo "yes" >&6; } + echo "$as_me:$LINENO: result: using long" >&5 +echo "${ECHO_T}using long" >&6 else cat >>confdefs.h <<_ACEOF #define TCL_WIDE_INT_TYPE ${tcl_cv_type_64bit} _ACEOF - { $as_echo "$as_me:${as_lineno-$LINENO}: result: ${tcl_cv_type_64bit}" >&5 -$as_echo "${tcl_cv_type_64bit}" >&6; } + echo "$as_me:$LINENO: result: ${tcl_cv_type_64bit}" >&5 +echo "${ECHO_T}${tcl_cv_type_64bit}" >&6 # Now check for auxiliary declarations - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for struct dirent64" >&5 -$as_echo_n "checking for struct dirent64... " >&6; } -if ${tcl_cv_struct_dirent64+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking for struct dirent64" >&5 +echo $ECHO_N "checking for struct dirent64... $ECHO_C" >&6 +if test "${tcl_cv_struct_dirent64+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () @@ -6926,32 +9469,62 @@ struct dirent64 p; ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_struct_dirent64=yes else - tcl_cv_struct_dirent64=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_struct_dirent64=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_struct_dirent64" >&5 -$as_echo "$tcl_cv_struct_dirent64" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_struct_dirent64" >&5 +echo "${ECHO_T}$tcl_cv_struct_dirent64" >&6 if test "x${tcl_cv_struct_dirent64}" = "xyes" ; then -$as_echo "#define HAVE_STRUCT_DIRENT64 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_STRUCT_DIRENT64 1 +_ACEOF fi - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for DIR64" >&5 -$as_echo_n "checking for DIR64... " >&6; } -if ${tcl_cv_DIR64+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking for DIR64" >&5 +echo $ECHO_N "checking for DIR64... $ECHO_C" >&6 +if test "${tcl_cv_DIR64+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () @@ -6960,32 +9533,62 @@ p = readdir64(d); rewinddir64(d); closedir64(d); ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_DIR64=yes else - tcl_cv_DIR64=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_DIR64=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_DIR64" >&5 -$as_echo "$tcl_cv_DIR64" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_DIR64" >&5 +echo "${ECHO_T}$tcl_cv_DIR64" >&6 if test "x${tcl_cv_DIR64}" = "xyes" ; then -$as_echo "#define HAVE_DIR64 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_DIR64 1 +_ACEOF fi - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for struct stat64" >&5 -$as_echo_n "checking for struct stat64... " >&6; } -if ${tcl_cv_struct_stat64+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking for struct stat64" >&5 +echo $ECHO_N "checking for struct stat64... $ECHO_C" >&6 +if test "${tcl_cv_struct_stat64+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { @@ -6993,44 +9596,165 @@ ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_struct_stat64=yes else - tcl_cv_struct_stat64=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_struct_stat64=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_struct_stat64" >&5 -$as_echo "$tcl_cv_struct_stat64" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_struct_stat64" >&5 +echo "${ECHO_T}$tcl_cv_struct_stat64" >&6 if test "x${tcl_cv_struct_stat64}" = "xyes" ; then -$as_echo "#define HAVE_STRUCT_STAT64 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_STRUCT_STAT64 1 +_ACEOF fi - for ac_func in open64 lseek64 -do : - as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` -ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var" -if eval test \"x\$"$as_ac_var"\" = x"yes"; then : + + +for ac_func in open64 lseek64 +do +as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` +echo "$as_me:$LINENO: checking for $ac_func" >&5 +echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 +if eval "test \"\${$as_ac_var+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define $ac_func to an innocuous variant, in case declares $ac_func. + For example, HP-UX 11i declares gettimeofday. */ +#define $ac_func innocuous_$ac_func + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char $ac_func (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef $ac_func + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char $ac_func (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_$ac_func) || defined (__stub___$ac_func) +choke me +#else +char (*f) () = $ac_func; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != $ac_func; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + eval "$as_ac_var=yes" +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +eval "$as_ac_var=no" +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 +if test `eval echo '${'$as_ac_var'}'` = yes; then cat >>confdefs.h <<_ACEOF -#define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 +#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for off64_t" >&5 -$as_echo_n "checking for off64_t... " >&6; } - if ${tcl_cv_type_off64_t+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking for off64_t" >&5 +echo $ECHO_N "checking for off64_t... $ECHO_C" >&6 + if test "${tcl_cv_type_off64_t+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { @@ -7038,468 +9762,1423 @@ ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_type_off64_t=yes else - tcl_cv_type_off64_t=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_type_off64_t=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi if test "x${tcl_cv_type_off64_t}" = "xyes" && \ test "x${ac_cv_func_lseek64}" = "xyes" && \ test "x${ac_cv_func_open64}" = "xyes" ; then -$as_echo "#define HAVE_TYPE_OFF64_T 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_TYPE_OFF64_T 1 +_ACEOF - { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -$as_echo "yes" >&6; } + echo "$as_me:$LINENO: result: yes" >&5 +echo "${ECHO_T}yes" >&6 else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 fi fi #-------------------------------------------------------------------- # Check endianness because we can optimize comparisons of # Tcl_UniChar strings to memcmp on big-endian systems. #-------------------------------------------------------------------- - { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether byte ordering is bigendian" >&5 -$as_echo_n "checking whether byte ordering is bigendian... " >&6; } -if ${ac_cv_c_bigendian+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_cv_c_bigendian=unknown - # See if we're dealing with a universal compiler. - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#ifndef __APPLE_CC__ - not a universal capable compiler - #endif - typedef int dummy; - -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - - # Check for potential -arch flags. It is not universal unless - # there are at least two -arch flags with different values. - ac_arch= - ac_prev= - for ac_word in $CC $CFLAGS $CPPFLAGS $LDFLAGS; do - if test -n "$ac_prev"; then - case $ac_word in - i?86 | x86_64 | ppc | ppc64) - if test -z "$ac_arch" || test "$ac_arch" = "$ac_word"; then - ac_arch=$ac_word - else - ac_cv_c_bigendian=universal - break - fi - ;; - esac - ac_prev= - elif test "x$ac_word" = "x-arch"; then - ac_prev=arch - fi - done -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - if test $ac_cv_c_bigendian = unknown; then - # See if sys/param.h defines the BYTE_ORDER macro. - cat confdefs.h - <<_ACEOF >conftest.$ac_ext +echo "$as_me:$LINENO: checking whether byte ordering is bigendian" >&5 +echo $ECHO_N "checking whether byte ordering is bigendian... $ECHO_C" >&6 +if test "${ac_cv_c_bigendian+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + # See if sys/param.h defines the BYTE_ORDER macro. +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include - #include +#include int main () { -#if ! (defined BYTE_ORDER && defined BIG_ENDIAN \ - && defined LITTLE_ENDIAN && BYTE_ORDER && BIG_ENDIAN \ - && LITTLE_ENDIAN) - bogus endian macros - #endif +#if !BYTE_ORDER || !BIG_ENDIAN || !LITTLE_ENDIAN + bogus endian macros +#endif ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then # It does; now see whether it defined to BIG_ENDIAN or not. - cat confdefs.h - <<_ACEOF >conftest.$ac_ext +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include - #include +#include int main () { #if BYTE_ORDER != BIG_ENDIAN - not big endian - #endif - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - ac_cv_c_bigendian=yes -else - ac_cv_c_bigendian=no -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - fi - if test $ac_cv_c_bigendian = unknown; then - # See if defines _LITTLE_ENDIAN or _BIG_ENDIAN (e.g., Solaris). - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include - -int -main () -{ -#if ! (defined _LITTLE_ENDIAN || defined _BIG_ENDIAN) - bogus endian macros - #endif - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - # It does; now see whether it defined to _BIG_ENDIAN or not. - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include - -int -main () -{ -#ifndef _BIG_ENDIAN - not big endian - #endif - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - ac_cv_c_bigendian=yes -else - ac_cv_c_bigendian=no -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - fi - if test $ac_cv_c_bigendian = unknown; then - # Compile a test program. - if test "$cross_compiling" = yes; then : - # Try to guess by grepping values from an object file. - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -short int ascii_mm[] = - { 0x4249, 0x4765, 0x6E44, 0x6961, 0x6E53, 0x7953, 0 }; - short int ascii_ii[] = - { 0x694C, 0x5454, 0x656C, 0x6E45, 0x6944, 0x6E61, 0 }; - int use_ascii (int i) { - return ascii_mm[i] + ascii_ii[i]; - } - short int ebcdic_ii[] = - { 0x89D3, 0xE3E3, 0x8593, 0x95C5, 0x89C4, 0x9581, 0 }; - short int ebcdic_mm[] = - { 0xC2C9, 0xC785, 0x95C4, 0x8981, 0x95E2, 0xA8E2, 0 }; - int use_ebcdic (int i) { - return ebcdic_mm[i] + ebcdic_ii[i]; - } - extern int foo; - -int -main () -{ -return use_ascii (foo) == use_ebcdic (foo); - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - if grep BIGenDianSyS conftest.$ac_objext >/dev/null; then - ac_cv_c_bigendian=yes - fi - if grep LiTTleEnDian conftest.$ac_objext >/dev/null ; then - if test "$ac_cv_c_bigendian" = unknown; then - ac_cv_c_bigendian=no - else - # finding both strings is unlikely to happen, but who knows? - ac_cv_c_bigendian=unknown - fi - fi -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -$ac_includes_default -int -main () -{ - - /* Are we little or big endian? From Harbison&Steele. */ - union - { - long int l; - char c[sizeof (long int)]; - } u; - u.l = 1; - return u.c[sizeof (long int) - 1] == 1; - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_run "$LINENO"; then : - ac_cv_c_bigendian=no -else - ac_cv_c_bigendian=yes -fi -rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ - conftest.$ac_objext conftest.beam conftest.$ac_ext -fi - - fi -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_bigendian" >&5 -$as_echo "$ac_cv_c_bigendian" >&6; } - case $ac_cv_c_bigendian in #( - yes) - $as_echo "#define WORDS_BIGENDIAN 1" >>confdefs.h -;; #( - no) - ;; #( - universal) - -$as_echo "#define AC_APPLE_UNIVERSAL_BUILD 1" >>confdefs.h - - ;; #( - *) - as_fn_error $? "unknown endianness - presetting ac_cv_c_bigendian=no (or yes) will help" "$LINENO" 5 ;; - esac + not big endian +#endif + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_c_bigendian=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_c_bigendian=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +# It does not; compile a test program. +if test "$cross_compiling" = yes; then + # try to guess the endianness by grepping values into an object file + ac_cv_c_bigendian=unknown + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +short ascii_mm[] = { 0x4249, 0x4765, 0x6E44, 0x6961, 0x6E53, 0x7953, 0 }; +short ascii_ii[] = { 0x694C, 0x5454, 0x656C, 0x6E45, 0x6944, 0x6E61, 0 }; +void _ascii () { char *s = (char *) ascii_mm; s = (char *) ascii_ii; } +short ebcdic_ii[] = { 0x89D3, 0xE3E3, 0x8593, 0x95C5, 0x89C4, 0x9581, 0 }; +short ebcdic_mm[] = { 0xC2C9, 0xC785, 0x95C4, 0x8981, 0x95E2, 0xA8E2, 0 }; +void _ebcdic () { char *s = (char *) ebcdic_mm; s = (char *) ebcdic_ii; } +int +main () +{ + _ascii (); _ebcdic (); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + if grep BIGenDianSyS conftest.$ac_objext >/dev/null ; then + ac_cv_c_bigendian=yes +fi +if grep LiTTleEnDian conftest.$ac_objext >/dev/null ; then + if test "$ac_cv_c_bigendian" = unknown; then + ac_cv_c_bigendian=no + else + # finding both strings is unlikely to happen, but who knows? + ac_cv_c_bigendian=unknown + fi +fi +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +int +main () +{ + /* Are we little or big endian? From Harbison&Steele. */ + union + { + long l; + char c[sizeof (long)]; + } u; + u.l = 1; + exit (u.c[sizeof (long) - 1] == 1); +} +_ACEOF +rm -f conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { ac_try='./conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_c_bigendian=no +else + echo "$as_me: program exited with status $ac_status" >&5 +echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +( exit $ac_status ) +ac_cv_c_bigendian=yes +fi +rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext +fi +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_c_bigendian" >&5 +echo "${ECHO_T}$ac_cv_c_bigendian" >&6 +case $ac_cv_c_bigendian in + yes) + +cat >>confdefs.h <<\_ACEOF +#define WORDS_BIGENDIAN 1 +_ACEOF + ;; + no) + ;; + *) + { { echo "$as_me:$LINENO: error: unknown endianness +presetting ac_cv_c_bigendian=no (or yes) will help" >&5 +echo "$as_me: error: unknown endianness +presetting ac_cv_c_bigendian=no (or yes) will help" >&2;} + { (exit 1); exit 1; }; } ;; +esac #-------------------------------------------------------------------- # Supply substitutes for missing POSIX library procedures, or # set flags so Tcl uses alternate procedures. #-------------------------------------------------------------------- # Check if Posix compliant getcwd exists, if not we'll use getwd. + for ac_func in getcwd -do : - ac_fn_c_check_func "$LINENO" "getcwd" "ac_cv_func_getcwd" -if test "x$ac_cv_func_getcwd" = xyes; then : +do +as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` +echo "$as_me:$LINENO: checking for $ac_func" >&5 +echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 +if eval "test \"\${$as_ac_var+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define $ac_func to an innocuous variant, in case declares $ac_func. + For example, HP-UX 11i declares gettimeofday. */ +#define $ac_func innocuous_$ac_func + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char $ac_func (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef $ac_func + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char $ac_func (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_$ac_func) || defined (__stub___$ac_func) +choke me +#else +char (*f) () = $ac_func; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != $ac_func; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + eval "$as_ac_var=yes" +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +eval "$as_ac_var=no" +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 +if test `eval echo '${'$as_ac_var'}'` = yes; then cat >>confdefs.h <<_ACEOF -#define HAVE_GETCWD 1 +#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF else -$as_echo "#define USEGETWD 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define USEGETWD 1 +_ACEOF fi done # Nb: if getcwd uses popen and pwd(1) (like SunOS 4) we should really # define USEGETWD even if the posix getcwd exists. Add a test ? -ac_fn_c_check_func "$LINENO" "mkstemp" "ac_cv_func_mkstemp" -if test "x$ac_cv_func_mkstemp" = xyes; then : - $as_echo "#define HAVE_MKSTEMP 1" >>confdefs.h - -else - case " $LIBOBJS " in - *" mkstemp.$ac_objext "* ) ;; - *) LIBOBJS="$LIBOBJS mkstemp.$ac_objext" - ;; -esac - -fi - -ac_fn_c_check_func "$LINENO" "opendir" "ac_cv_func_opendir" -if test "x$ac_cv_func_opendir" = xyes; then : - $as_echo "#define HAVE_OPENDIR 1" >>confdefs.h - -else - case " $LIBOBJS " in - *" opendir.$ac_objext "* ) ;; - *) LIBOBJS="$LIBOBJS opendir.$ac_objext" - ;; -esac - -fi - -ac_fn_c_check_func "$LINENO" "strtol" "ac_cv_func_strtol" -if test "x$ac_cv_func_strtol" = xyes; then : - $as_echo "#define HAVE_STRTOL 1" >>confdefs.h - -else - case " $LIBOBJS " in - *" strtol.$ac_objext "* ) ;; - *) LIBOBJS="$LIBOBJS strtol.$ac_objext" - ;; -esac - -fi - -ac_fn_c_check_func "$LINENO" "waitpid" "ac_cv_func_waitpid" -if test "x$ac_cv_func_waitpid" = xyes; then : - $as_echo "#define HAVE_WAITPID 1" >>confdefs.h - -else - case " $LIBOBJS " in - *" waitpid.$ac_objext "* ) ;; - *) LIBOBJS="$LIBOBJS waitpid.$ac_objext" - ;; -esac - -fi - - -ac_fn_c_check_func "$LINENO" "strerror" "ac_cv_func_strerror" -if test "x$ac_cv_func_strerror" = xyes; then : - -else - -$as_echo "#define NO_STRERROR 1" >>confdefs.h - -fi - -ac_fn_c_check_func "$LINENO" "getwd" "ac_cv_func_getwd" -if test "x$ac_cv_func_getwd" = xyes; then : - -else - -$as_echo "#define NO_GETWD 1" >>confdefs.h - -fi - -ac_fn_c_check_func "$LINENO" "wait3" "ac_cv_func_wait3" -if test "x$ac_cv_func_wait3" = xyes; then : - -else - -$as_echo "#define NO_WAIT3 1" >>confdefs.h - -fi - -ac_fn_c_check_func "$LINENO" "uname" "ac_cv_func_uname" -if test "x$ac_cv_func_uname" = xyes; then : - -else - -$as_echo "#define NO_UNAME 1" >>confdefs.h - -fi - - -if test "`uname -s`" = "Darwin" && \ + + + + +for ac_func in mkstemp opendir strtol waitpid +do +as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` +echo "$as_me:$LINENO: checking for $ac_func" >&5 +echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 +if eval "test \"\${$as_ac_var+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define $ac_func to an innocuous variant, in case declares $ac_func. + For example, HP-UX 11i declares gettimeofday. */ +#define $ac_func innocuous_$ac_func + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char $ac_func (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef $ac_func + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char $ac_func (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_$ac_func) || defined (__stub___$ac_func) +choke me +#else +char (*f) () = $ac_func; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != $ac_func; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + eval "$as_ac_var=yes" +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +eval "$as_ac_var=no" +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 +if test `eval echo '${'$as_ac_var'}'` = yes; then + cat >>confdefs.h <<_ACEOF +#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 +_ACEOF + +else + case $LIBOBJS in + "$ac_func.$ac_objext" | \ + *" $ac_func.$ac_objext" | \ + "$ac_func.$ac_objext "* | \ + *" $ac_func.$ac_objext "* ) ;; + *) LIBOBJS="$LIBOBJS $ac_func.$ac_objext" ;; +esac + +fi +done + + +echo "$as_me:$LINENO: checking for strerror" >&5 +echo $ECHO_N "checking for strerror... $ECHO_C" >&6 +if test "${ac_cv_func_strerror+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define strerror to an innocuous variant, in case declares strerror. + For example, HP-UX 11i declares gettimeofday. */ +#define strerror innocuous_strerror + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char strerror (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef strerror + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char strerror (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_strerror) || defined (__stub___strerror) +choke me +#else +char (*f) () = strerror; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != strerror; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_func_strerror=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_func_strerror=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_func_strerror" >&5 +echo "${ECHO_T}$ac_cv_func_strerror" >&6 +if test $ac_cv_func_strerror = yes; then + : +else + +cat >>confdefs.h <<\_ACEOF +#define NO_STRERROR 1 +_ACEOF + +fi + +echo "$as_me:$LINENO: checking for getwd" >&5 +echo $ECHO_N "checking for getwd... $ECHO_C" >&6 +if test "${ac_cv_func_getwd+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define getwd to an innocuous variant, in case declares getwd. + For example, HP-UX 11i declares gettimeofday. */ +#define getwd innocuous_getwd + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char getwd (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef getwd + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char getwd (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_getwd) || defined (__stub___getwd) +choke me +#else +char (*f) () = getwd; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != getwd; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_func_getwd=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_func_getwd=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_func_getwd" >&5 +echo "${ECHO_T}$ac_cv_func_getwd" >&6 +if test $ac_cv_func_getwd = yes; then + : +else + +cat >>confdefs.h <<\_ACEOF +#define NO_GETWD 1 +_ACEOF + +fi + +echo "$as_me:$LINENO: checking for wait3" >&5 +echo $ECHO_N "checking for wait3... $ECHO_C" >&6 +if test "${ac_cv_func_wait3+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define wait3 to an innocuous variant, in case declares wait3. + For example, HP-UX 11i declares gettimeofday. */ +#define wait3 innocuous_wait3 + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char wait3 (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef wait3 + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char wait3 (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_wait3) || defined (__stub___wait3) +choke me +#else +char (*f) () = wait3; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != wait3; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_func_wait3=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_func_wait3=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_func_wait3" >&5 +echo "${ECHO_T}$ac_cv_func_wait3" >&6 +if test $ac_cv_func_wait3 = yes; then + : +else + +cat >>confdefs.h <<\_ACEOF +#define NO_WAIT3 1 +_ACEOF + +fi + +echo "$as_me:$LINENO: checking for uname" >&5 +echo $ECHO_N "checking for uname... $ECHO_C" >&6 +if test "${ac_cv_func_uname+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define uname to an innocuous variant, in case declares uname. + For example, HP-UX 11i declares gettimeofday. */ +#define uname innocuous_uname + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char uname (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef uname + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char uname (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_uname) || defined (__stub___uname) +choke me +#else +char (*f) () = uname; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != uname; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_func_uname=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_func_uname=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_func_uname" >&5 +echo "${ECHO_T}$ac_cv_func_uname" >&6 +if test $ac_cv_func_uname = yes; then + : +else + +cat >>confdefs.h <<\_ACEOF +#define NO_UNAME 1 +_ACEOF + +fi + + +if test "`uname -s`" = "Darwin" && test "${TCL_THREADS}" = 1 && \ test "`uname -r | awk -F. '{print $1}'`" -lt 7; then # prior to Darwin 7, realpath is not threadsafe, so don't # use it when threads are enabled, c.f. bug # 711232 ac_cv_func_realpath=no fi -ac_fn_c_check_func "$LINENO" "realpath" "ac_cv_func_realpath" -if test "x$ac_cv_func_realpath" = xyes; then : +echo "$as_me:$LINENO: checking for realpath" >&5 +echo $ECHO_N "checking for realpath... $ECHO_C" >&6 +if test "${ac_cv_func_realpath+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define realpath to an innocuous variant, in case declares realpath. + For example, HP-UX 11i declares gettimeofday. */ +#define realpath innocuous_realpath +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char realpath (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef realpath + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char realpath (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_realpath) || defined (__stub___realpath) +choke me +#else +char (*f) () = realpath; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != realpath; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_func_realpath=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_func_realpath=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_func_realpath" >&5 +echo "${ECHO_T}$ac_cv_func_realpath" >&6 +if test $ac_cv_func_realpath = yes; then + : else -$as_echo "#define NO_REALPATH 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define NO_REALPATH 1 +_ACEOF fi NEED_FAKE_RFC2553=0 - for ac_func in getnameinfo getaddrinfo freeaddrinfo gai_strerror -do : - as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` -ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var" -if eval test \"x\$"$as_ac_var"\" = x"yes"; then : + + + + +for ac_func in getnameinfo getaddrinfo freeaddrinfo gai_strerror +do +as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` +echo "$as_me:$LINENO: checking for $ac_func" >&5 +echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 +if eval "test \"\${$as_ac_var+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define $ac_func to an innocuous variant, in case declares $ac_func. + For example, HP-UX 11i declares gettimeofday. */ +#define $ac_func innocuous_$ac_func + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char $ac_func (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef $ac_func + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char $ac_func (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_$ac_func) || defined (__stub___$ac_func) +choke me +#else +char (*f) () = $ac_func; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != $ac_func; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + eval "$as_ac_var=yes" +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +eval "$as_ac_var=no" +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 +if test `eval echo '${'$as_ac_var'}'` = yes; then cat >>confdefs.h <<_ACEOF -#define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 +#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF else NEED_FAKE_RFC2553=1 fi done - ac_fn_c_check_type "$LINENO" "struct addrinfo" "ac_cv_type_struct_addrinfo" " + echo "$as_me:$LINENO: checking for struct addrinfo" >&5 +echo $ECHO_N "checking for struct addrinfo... $ECHO_C" >&6 +if test "${ac_cv_type_struct_addrinfo+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + #include #include #include #include -" -if test "x$ac_cv_type_struct_addrinfo" = xyes; then : + +int +main () +{ +if ((struct addrinfo *) 0) + return 0; +if (sizeof (struct addrinfo)) + return 0; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_type_struct_addrinfo=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_type_struct_addrinfo=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_type_struct_addrinfo" >&5 +echo "${ECHO_T}$ac_cv_type_struct_addrinfo" >&6 +if test $ac_cv_type_struct_addrinfo = yes; then cat >>confdefs.h <<_ACEOF #define HAVE_STRUCT_ADDRINFO 1 _ACEOF else NEED_FAKE_RFC2553=1 fi -ac_fn_c_check_type "$LINENO" "struct in6_addr" "ac_cv_type_struct_in6_addr" " +echo "$as_me:$LINENO: checking for struct in6_addr" >&5 +echo $ECHO_N "checking for struct in6_addr... $ECHO_C" >&6 +if test "${ac_cv_type_struct_in6_addr+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + #include #include #include #include -" -if test "x$ac_cv_type_struct_in6_addr" = xyes; then : + +int +main () +{ +if ((struct in6_addr *) 0) + return 0; +if (sizeof (struct in6_addr)) + return 0; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_type_struct_in6_addr=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_type_struct_in6_addr=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_type_struct_in6_addr" >&5 +echo "${ECHO_T}$ac_cv_type_struct_in6_addr" >&6 +if test $ac_cv_type_struct_in6_addr = yes; then cat >>confdefs.h <<_ACEOF #define HAVE_STRUCT_IN6_ADDR 1 _ACEOF else NEED_FAKE_RFC2553=1 fi -ac_fn_c_check_type "$LINENO" "struct sockaddr_in6" "ac_cv_type_struct_sockaddr_in6" " +echo "$as_me:$LINENO: checking for struct sockaddr_in6" >&5 +echo $ECHO_N "checking for struct sockaddr_in6... $ECHO_C" >&6 +if test "${ac_cv_type_struct_sockaddr_in6+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + #include #include #include #include -" -if test "x$ac_cv_type_struct_sockaddr_in6" = xyes; then : + +int +main () +{ +if ((struct sockaddr_in6 *) 0) + return 0; +if (sizeof (struct sockaddr_in6)) + return 0; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_type_struct_sockaddr_in6=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_type_struct_sockaddr_in6=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_type_struct_sockaddr_in6" >&5 +echo "${ECHO_T}$ac_cv_type_struct_sockaddr_in6" >&6 +if test $ac_cv_type_struct_sockaddr_in6 = yes; then cat >>confdefs.h <<_ACEOF #define HAVE_STRUCT_SOCKADDR_IN6 1 _ACEOF else NEED_FAKE_RFC2553=1 fi -ac_fn_c_check_type "$LINENO" "struct sockaddr_storage" "ac_cv_type_struct_sockaddr_storage" " +echo "$as_me:$LINENO: checking for struct sockaddr_storage" >&5 +echo $ECHO_N "checking for struct sockaddr_storage... $ECHO_C" >&6 +if test "${ac_cv_type_struct_sockaddr_storage+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + #include #include #include #include -" -if test "x$ac_cv_type_struct_sockaddr_storage" = xyes; then : + +int +main () +{ +if ((struct sockaddr_storage *) 0) + return 0; +if (sizeof (struct sockaddr_storage)) + return 0; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_type_struct_sockaddr_storage=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_type_struct_sockaddr_storage=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_type_struct_sockaddr_storage" >&5 +echo "${ECHO_T}$ac_cv_type_struct_sockaddr_storage" >&6 +if test $ac_cv_type_struct_sockaddr_storage = yes; then cat >>confdefs.h <<_ACEOF #define HAVE_STRUCT_SOCKADDR_STORAGE 1 _ACEOF @@ -7508,40 +11187,224 @@ NEED_FAKE_RFC2553=1 fi if test "x$NEED_FAKE_RFC2553" = "x1"; then -$as_echo "#define NEED_FAKE_RFC2553 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define NEED_FAKE_RFC2553 1 +_ACEOF - case " $LIBOBJS " in + case $LIBOBJS in + "fake-rfc2553.$ac_objext" | \ + *" fake-rfc2553.$ac_objext" | \ + "fake-rfc2553.$ac_objext "* | \ *" fake-rfc2553.$ac_objext "* ) ;; - *) LIBOBJS="$LIBOBJS fake-rfc2553.$ac_objext" - ;; + *) LIBOBJS="$LIBOBJS fake-rfc2553.$ac_objext" ;; esac - ac_fn_c_check_func "$LINENO" "strlcpy" "ac_cv_func_strlcpy" -if test "x$ac_cv_func_strlcpy" = xyes; then : + echo "$as_me:$LINENO: checking for strlcpy" >&5 +echo $ECHO_N "checking for strlcpy... $ECHO_C" >&6 +if test "${ac_cv_func_strlcpy+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define strlcpy to an innocuous variant, in case declares strlcpy. + For example, HP-UX 11i declares gettimeofday. */ +#define strlcpy innocuous_strlcpy +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char strlcpy (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef strlcpy + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char strlcpy (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_strlcpy) || defined (__stub___strlcpy) +choke me +#else +char (*f) () = strlcpy; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != strlcpy; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_func_strlcpy=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_func_strlcpy=no fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_func_strlcpy" >&5 +echo "${ECHO_T}$ac_cv_func_strlcpy" >&6 fi #-------------------------------------------------------------------- # Look for thread-safe variants of some library functions. #-------------------------------------------------------------------- -ac_fn_c_check_func "$LINENO" "getpwuid_r" "ac_cv_func_getpwuid_r" -if test "x$ac_cv_func_getpwuid_r" = xyes; then : +if test "${TCL_THREADS}" = 1; then + echo "$as_me:$LINENO: checking for getpwuid_r" >&5 +echo $ECHO_N "checking for getpwuid_r... $ECHO_C" >&6 +if test "${ac_cv_func_getpwuid_r+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define getpwuid_r to an innocuous variant, in case declares getpwuid_r. + For example, HP-UX 11i declares gettimeofday. */ +#define getpwuid_r innocuous_getpwuid_r - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for getpwuid_r with 5 args" >&5 -$as_echo_n "checking for getpwuid_r with 5 args... " >&6; } -if ${tcl_cv_api_getpwuid_r_5+:} false; then : - $as_echo_n "(cached) " >&6 +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char getpwuid_r (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef getpwuid_r + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char getpwuid_r (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_getpwuid_r) || defined (__stub___getpwuid_r) +choke me +#else +char (*f) () = getpwuid_r; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != getpwuid_r; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_func_getpwuid_r=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_func_getpwuid_r=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_func_getpwuid_r" >&5 +echo "${ECHO_T}$ac_cv_func_getpwuid_r" >&6 +if test $ac_cv_func_getpwuid_r = yes; then + + echo "$as_me:$LINENO: checking for getpwuid_r with 5 args" >&5 +echo $ECHO_N "checking for getpwuid_r with 5 args... $ECHO_C" >&6 +if test "${tcl_cv_api_getpwuid_r_5+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include @@ -7558,32 +11421,62 @@ ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_api_getpwuid_r_5=yes else - tcl_cv_api_getpwuid_r_5=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_api_getpwuid_r_5=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getpwuid_r_5" >&5 -$as_echo "$tcl_cv_api_getpwuid_r_5" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_api_getpwuid_r_5" >&5 +echo "${ECHO_T}$tcl_cv_api_getpwuid_r_5" >&6 tcl_ok=$tcl_cv_api_getpwuid_r_5 if test "$tcl_ok" = yes; then -$as_echo "#define HAVE_GETPWUID_R_5 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_GETPWUID_R_5 1 +_ACEOF else - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for getpwuid_r with 4 args" >&5 -$as_echo_n "checking for getpwuid_r with 4 args... " >&6; } -if ${tcl_cv_api_getpwuid_r_4+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking for getpwuid_r with 4 args" >&5 +echo $ECHO_N "checking for getpwuid_r with 4 args... $ECHO_C" >&6 +if test "${tcl_cv_api_getpwuid_r_4+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include @@ -7600,44 +11493,165 @@ ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_api_getpwuid_r_4=yes else - tcl_cv_api_getpwuid_r_4=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_api_getpwuid_r_4=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getpwuid_r_4" >&5 -$as_echo "$tcl_cv_api_getpwuid_r_4" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_api_getpwuid_r_4" >&5 +echo "${ECHO_T}$tcl_cv_api_getpwuid_r_4" >&6 tcl_ok=$tcl_cv_api_getpwuid_r_4 if test "$tcl_ok" = yes; then -$as_echo "#define HAVE_GETPWUID_R_4 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_GETPWUID_R_4 1 +_ACEOF fi fi if test "$tcl_ok" = yes; then -$as_echo "#define HAVE_GETPWUID_R 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_GETPWUID_R 1 +_ACEOF fi fi -ac_fn_c_check_func "$LINENO" "getpwnam_r" "ac_cv_func_getpwnam_r" -if test "x$ac_cv_func_getpwnam_r" = xyes; then : + echo "$as_me:$LINENO: checking for getpwnam_r" >&5 +echo $ECHO_N "checking for getpwnam_r... $ECHO_C" >&6 +if test "${ac_cv_func_getpwnam_r+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define getpwnam_r to an innocuous variant, in case declares getpwnam_r. + For example, HP-UX 11i declares gettimeofday. */ +#define getpwnam_r innocuous_getpwnam_r - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for getpwnam_r with 5 args" >&5 -$as_echo_n "checking for getpwnam_r with 5 args... " >&6; } -if ${tcl_cv_api_getpwnam_r_5+:} false; then : - $as_echo_n "(cached) " >&6 +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char getpwnam_r (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef getpwnam_r + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char getpwnam_r (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_getpwnam_r) || defined (__stub___getpwnam_r) +choke me +#else +char (*f) () = getpwnam_r; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != getpwnam_r; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_func_getpwnam_r=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_func_getpwnam_r=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_func_getpwnam_r" >&5 +echo "${ECHO_T}$ac_cv_func_getpwnam_r" >&6 +if test $ac_cv_func_getpwnam_r = yes; then + + echo "$as_me:$LINENO: checking for getpwnam_r with 5 args" >&5 +echo $ECHO_N "checking for getpwnam_r with 5 args... $ECHO_C" >&6 +if test "${tcl_cv_api_getpwnam_r_5+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include @@ -7654,32 +11668,62 @@ ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_api_getpwnam_r_5=yes else - tcl_cv_api_getpwnam_r_5=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_api_getpwnam_r_5=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getpwnam_r_5" >&5 -$as_echo "$tcl_cv_api_getpwnam_r_5" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_api_getpwnam_r_5" >&5 +echo "${ECHO_T}$tcl_cv_api_getpwnam_r_5" >&6 tcl_ok=$tcl_cv_api_getpwnam_r_5 if test "$tcl_ok" = yes; then -$as_echo "#define HAVE_GETPWNAM_R_5 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_GETPWNAM_R_5 1 +_ACEOF else - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for getpwnam_r with 4 args" >&5 -$as_echo_n "checking for getpwnam_r with 4 args... " >&6; } -if ${tcl_cv_api_getpwnam_r_4+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking for getpwnam_r with 4 args" >&5 +echo $ECHO_N "checking for getpwnam_r with 4 args... $ECHO_C" >&6 +if test "${tcl_cv_api_getpwnam_r_4+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include @@ -7696,44 +11740,165 @@ ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_api_getpwnam_r_4=yes else - tcl_cv_api_getpwnam_r_4=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_api_getpwnam_r_4=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getpwnam_r_4" >&5 -$as_echo "$tcl_cv_api_getpwnam_r_4" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_api_getpwnam_r_4" >&5 +echo "${ECHO_T}$tcl_cv_api_getpwnam_r_4" >&6 tcl_ok=$tcl_cv_api_getpwnam_r_4 if test "$tcl_ok" = yes; then -$as_echo "#define HAVE_GETPWNAM_R_4 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_GETPWNAM_R_4 1 +_ACEOF fi fi if test "$tcl_ok" = yes; then -$as_echo "#define HAVE_GETPWNAM_R 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_GETPWNAM_R 1 +_ACEOF fi fi -ac_fn_c_check_func "$LINENO" "getgrgid_r" "ac_cv_func_getgrgid_r" -if test "x$ac_cv_func_getgrgid_r" = xyes; then : + echo "$as_me:$LINENO: checking for getgrgid_r" >&5 +echo $ECHO_N "checking for getgrgid_r... $ECHO_C" >&6 +if test "${ac_cv_func_getgrgid_r+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define getgrgid_r to an innocuous variant, in case declares getgrgid_r. + For example, HP-UX 11i declares gettimeofday. */ +#define getgrgid_r innocuous_getgrgid_r - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for getgrgid_r with 5 args" >&5 -$as_echo_n "checking for getgrgid_r with 5 args... " >&6; } -if ${tcl_cv_api_getgrgid_r_5+:} false; then : - $as_echo_n "(cached) " >&6 +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char getgrgid_r (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef getgrgid_r + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char getgrgid_r (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_getgrgid_r) || defined (__stub___getgrgid_r) +choke me +#else +char (*f) () = getgrgid_r; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != getgrgid_r; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_func_getgrgid_r=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_func_getgrgid_r=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_func_getgrgid_r" >&5 +echo "${ECHO_T}$ac_cv_func_getgrgid_r" >&6 +if test $ac_cv_func_getgrgid_r = yes; then + + echo "$as_me:$LINENO: checking for getgrgid_r with 5 args" >&5 +echo $ECHO_N "checking for getgrgid_r with 5 args... $ECHO_C" >&6 +if test "${tcl_cv_api_getgrgid_r_5+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include @@ -7750,32 +11915,62 @@ ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_api_getgrgid_r_5=yes else - tcl_cv_api_getgrgid_r_5=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_api_getgrgid_r_5=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getgrgid_r_5" >&5 -$as_echo "$tcl_cv_api_getgrgid_r_5" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_api_getgrgid_r_5" >&5 +echo "${ECHO_T}$tcl_cv_api_getgrgid_r_5" >&6 tcl_ok=$tcl_cv_api_getgrgid_r_5 if test "$tcl_ok" = yes; then -$as_echo "#define HAVE_GETGRGID_R_5 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_GETGRGID_R_5 1 +_ACEOF else - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for getgrgid_r with 4 args" >&5 -$as_echo_n "checking for getgrgid_r with 4 args... " >&6; } -if ${tcl_cv_api_getgrgid_r_4+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking for getgrgid_r with 4 args" >&5 +echo $ECHO_N "checking for getgrgid_r with 4 args... $ECHO_C" >&6 +if test "${tcl_cv_api_getgrgid_r_4+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include @@ -7792,44 +11987,165 @@ ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_api_getgrgid_r_4=yes else - tcl_cv_api_getgrgid_r_4=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_api_getgrgid_r_4=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getgrgid_r_4" >&5 -$as_echo "$tcl_cv_api_getgrgid_r_4" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_api_getgrgid_r_4" >&5 +echo "${ECHO_T}$tcl_cv_api_getgrgid_r_4" >&6 tcl_ok=$tcl_cv_api_getgrgid_r_4 if test "$tcl_ok" = yes; then -$as_echo "#define HAVE_GETGRGID_R_4 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_GETGRGID_R_4 1 +_ACEOF fi fi if test "$tcl_ok" = yes; then -$as_echo "#define HAVE_GETGRGID_R 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_GETGRGID_R 1 +_ACEOF fi fi -ac_fn_c_check_func "$LINENO" "getgrnam_r" "ac_cv_func_getgrnam_r" -if test "x$ac_cv_func_getgrnam_r" = xyes; then : + echo "$as_me:$LINENO: checking for getgrnam_r" >&5 +echo $ECHO_N "checking for getgrnam_r... $ECHO_C" >&6 +if test "${ac_cv_func_getgrnam_r+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define getgrnam_r to an innocuous variant, in case declares getgrnam_r. + For example, HP-UX 11i declares gettimeofday. */ +#define getgrnam_r innocuous_getgrnam_r - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for getgrnam_r with 5 args" >&5 -$as_echo_n "checking for getgrnam_r with 5 args... " >&6; } -if ${tcl_cv_api_getgrnam_r_5+:} false; then : - $as_echo_n "(cached) " >&6 +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char getgrnam_r (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef getgrnam_r + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char getgrnam_r (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_getgrnam_r) || defined (__stub___getgrnam_r) +choke me +#else +char (*f) () = getgrnam_r; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != getgrnam_r; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_func_getgrnam_r=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_func_getgrnam_r=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_func_getgrnam_r" >&5 +echo "${ECHO_T}$ac_cv_func_getgrnam_r" >&6 +if test $ac_cv_func_getgrnam_r = yes; then + + echo "$as_me:$LINENO: checking for getgrnam_r with 5 args" >&5 +echo $ECHO_N "checking for getgrnam_r with 5 args... $ECHO_C" >&6 +if test "${tcl_cv_api_getgrnam_r_5+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include @@ -7846,32 +12162,62 @@ ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_api_getgrnam_r_5=yes else - tcl_cv_api_getgrnam_r_5=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_api_getgrnam_r_5=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getgrnam_r_5" >&5 -$as_echo "$tcl_cv_api_getgrnam_r_5" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_api_getgrnam_r_5" >&5 +echo "${ECHO_T}$tcl_cv_api_getgrnam_r_5" >&6 tcl_ok=$tcl_cv_api_getgrnam_r_5 if test "$tcl_ok" = yes; then -$as_echo "#define HAVE_GETGRNAM_R_5 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_GETGRNAM_R_5 1 +_ACEOF else - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for getgrnam_r with 4 args" >&5 -$as_echo_n "checking for getgrnam_r with 4 args... " >&6; } -if ${tcl_cv_api_getgrnam_r_4+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking for getgrnam_r with 4 args" >&5 +echo $ECHO_N "checking for getgrnam_r with 4 args... $ECHO_C" >&6 +if test "${tcl_cv_api_getgrnam_r_4+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include @@ -7888,69 +12234,277 @@ ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - tcl_cv_api_getgrnam_r_4=yes -else - tcl_cv_api_getgrnam_r_4=no -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getgrnam_r_4" >&5 -$as_echo "$tcl_cv_api_getgrnam_r_4" >&6; } - tcl_ok=$tcl_cv_api_getgrnam_r_4 - if test "$tcl_ok" = yes; then - -$as_echo "#define HAVE_GETGRNAM_R_4 1" >>confdefs.h - - fi - fi - if test "$tcl_ok" = yes; then - -$as_echo "#define HAVE_GETGRNAM_R 1" >>confdefs.h - - fi - -fi - -if test "`uname -s`" = "Darwin" && \ - test "`uname -r | awk -F. '{print $1}'`" -gt 5; then - # Starting with Darwin 6 (Mac OSX 10.2), gethostbyX - # are actually MT-safe as they always return pointers - # from TSD instead of static storage. - -$as_echo "#define HAVE_MTSAFE_GETHOSTBYNAME 1" >>confdefs.h - - -$as_echo "#define HAVE_MTSAFE_GETHOSTBYADDR 1" >>confdefs.h - - -elif test "`uname -s`" = "HP-UX" && \ - test "`uname -r|sed -e 's|B\.||' -e 's|\..*$||'`" -gt 10; then - # Starting with HPUX 11.00 (we believe), gethostbyX - # are actually MT-safe as they always return pointers - # from TSD instead of static storage. - -$as_echo "#define HAVE_MTSAFE_GETHOSTBYNAME 1" >>confdefs.h - - -$as_echo "#define HAVE_MTSAFE_GETHOSTBYADDR 1" >>confdefs.h - - -else - ac_fn_c_check_func "$LINENO" "gethostbyname_r" "ac_cv_func_gethostbyname_r" -if test "x$ac_cv_func_gethostbyname_r" = xyes; then : - - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for gethostbyname_r with 6 args" >&5 -$as_echo_n "checking for gethostbyname_r with 6 args... " >&6; } -if ${tcl_cv_api_gethostbyname_r_6+:} false; then : - $as_echo_n "(cached) " >&6 -else - - cat confdefs.h - <<_ACEOF >conftest.$ac_ext +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + tcl_cv_api_getgrnam_r_4=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_api_getgrnam_r_4=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $tcl_cv_api_getgrnam_r_4" >&5 +echo "${ECHO_T}$tcl_cv_api_getgrnam_r_4" >&6 + tcl_ok=$tcl_cv_api_getgrnam_r_4 + if test "$tcl_ok" = yes; then + +cat >>confdefs.h <<\_ACEOF +#define HAVE_GETGRNAM_R_4 1 +_ACEOF + + fi + fi + if test "$tcl_ok" = yes; then + +cat >>confdefs.h <<\_ACEOF +#define HAVE_GETGRNAM_R 1 +_ACEOF + + fi + +fi + + if test "`uname -s`" = "Darwin" && \ + test "`uname -r | awk -F. '{print $1}'`" -gt 5; then + # Starting with Darwin 6 (Mac OSX 10.2), gethostbyX + # are actually MT-safe as they always return pointers + # from TSD instead of static storage. + +cat >>confdefs.h <<\_ACEOF +#define HAVE_MTSAFE_GETHOSTBYNAME 1 +_ACEOF + + +cat >>confdefs.h <<\_ACEOF +#define HAVE_MTSAFE_GETHOSTBYADDR 1 +_ACEOF + + + elif test "`uname -s`" = "HP-UX" && \ + test "`uname -r|sed -e 's|B\.||' -e 's|\..*$||'`" -gt 10; then + # Starting with HPUX 11.00 (we believe), gethostbyX + # are actually MT-safe as they always return pointers + # from TSD instead of static storage. + +cat >>confdefs.h <<\_ACEOF +#define HAVE_MTSAFE_GETHOSTBYNAME 1 +_ACEOF + + +cat >>confdefs.h <<\_ACEOF +#define HAVE_MTSAFE_GETHOSTBYADDR 1 +_ACEOF + + + else + + # Avoids picking hidden internal symbol from libc + echo "$as_me:$LINENO: checking whether gethostbyname_r is declared" >&5 +echo $ECHO_N "checking whether gethostbyname_r is declared... $ECHO_C" >&6 +if test "${ac_cv_have_decl_gethostbyname_r+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include + +int +main () +{ +#ifndef gethostbyname_r + char *p = (char *) gethostbyname_r; +#endif + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_have_decl_gethostbyname_r=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_have_decl_gethostbyname_r=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_have_decl_gethostbyname_r" >&5 +echo "${ECHO_T}$ac_cv_have_decl_gethostbyname_r" >&6 +if test $ac_cv_have_decl_gethostbyname_r = yes; then + +cat >>confdefs.h <<_ACEOF +#define HAVE_DECL_GETHOSTBYNAME_R 1 +_ACEOF + + + tcl_cv_api_gethostbyname_r=yes +else + cat >>confdefs.h <<_ACEOF +#define HAVE_DECL_GETHOSTBYNAME_R 0 +_ACEOF + +tcl_cv_api_gethostbyname_r=no +fi + + + + + if test "$tcl_cv_api_gethostbyname_r" = yes; then + echo "$as_me:$LINENO: checking for gethostbyname_r" >&5 +echo $ECHO_N "checking for gethostbyname_r... $ECHO_C" >&6 +if test "${ac_cv_func_gethostbyname_r+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define gethostbyname_r to an innocuous variant, in case declares gethostbyname_r. + For example, HP-UX 11i declares gettimeofday. */ +#define gethostbyname_r innocuous_gethostbyname_r + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char gethostbyname_r (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef gethostbyname_r + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char gethostbyname_r (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_gethostbyname_r) || defined (__stub___gethostbyname_r) +choke me +#else +char (*f) () = gethostbyname_r; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != gethostbyname_r; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_func_gethostbyname_r=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_func_gethostbyname_r=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_func_gethostbyname_r" >&5 +echo "${ECHO_T}$ac_cv_func_gethostbyname_r" >&6 +if test $ac_cv_func_gethostbyname_r = yes; then + + echo "$as_me:$LINENO: checking for gethostbyname_r with 6 args" >&5 +echo $ECHO_N "checking for gethostbyname_r with 6 args... $ECHO_C" >&6 +if test "${tcl_cv_api_gethostbyname_r_6+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int @@ -7967,32 +12521,62 @@ ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_api_gethostbyname_r_6=yes else - tcl_cv_api_gethostbyname_r_6=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_api_gethostbyname_r_6=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_gethostbyname_r_6" >&5 -$as_echo "$tcl_cv_api_gethostbyname_r_6" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_api_gethostbyname_r_6" >&5 +echo "${ECHO_T}$tcl_cv_api_gethostbyname_r_6" >&6 tcl_ok=$tcl_cv_api_gethostbyname_r_6 if test "$tcl_ok" = yes; then -$as_echo "#define HAVE_GETHOSTBYNAME_R_6 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_GETHOSTBYNAME_R_6 1 +_ACEOF else - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for gethostbyname_r with 5 args" >&5 -$as_echo_n "checking for gethostbyname_r with 5 args... " >&6; } -if ${tcl_cv_api_gethostbyname_r_5+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking for gethostbyname_r with 5 args" >&5 +echo $ECHO_N "checking for gethostbyname_r with 5 args... $ECHO_C" >&6 +if test "${tcl_cv_api_gethostbyname_r_5+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int @@ -8009,32 +12593,62 @@ ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_api_gethostbyname_r_5=yes else - tcl_cv_api_gethostbyname_r_5=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_api_gethostbyname_r_5=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_gethostbyname_r_5" >&5 -$as_echo "$tcl_cv_api_gethostbyname_r_5" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_api_gethostbyname_r_5" >&5 +echo "${ECHO_T}$tcl_cv_api_gethostbyname_r_5" >&6 tcl_ok=$tcl_cv_api_gethostbyname_r_5 if test "$tcl_ok" = yes; then -$as_echo "#define HAVE_GETHOSTBYNAME_R_5 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_GETHOSTBYNAME_R_5 1 +_ACEOF else - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for gethostbyname_r with 3 args" >&5 -$as_echo_n "checking for gethostbyname_r with 3 args... " >&6; } -if ${tcl_cv_api_gethostbyname_r_3+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking for gethostbyname_r with 3 args" >&5 +echo $ECHO_N "checking for gethostbyname_r with 3 args... $ECHO_C" >&6 +if test "${tcl_cv_api_gethostbyname_r_3+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int @@ -8049,45 +12663,247 @@ ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_api_gethostbyname_r_3=yes else - tcl_cv_api_gethostbyname_r_3=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_api_gethostbyname_r_3=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_gethostbyname_r_3" >&5 -$as_echo "$tcl_cv_api_gethostbyname_r_3" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_api_gethostbyname_r_3" >&5 +echo "${ECHO_T}$tcl_cv_api_gethostbyname_r_3" >&6 tcl_ok=$tcl_cv_api_gethostbyname_r_3 if test "$tcl_ok" = yes; then -$as_echo "#define HAVE_GETHOSTBYNAME_R_3 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_GETHOSTBYNAME_R_3 1 +_ACEOF fi fi fi if test "$tcl_ok" = yes; then -$as_echo "#define HAVE_GETHOSTBYNAME_R 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_GETHOSTBYNAME_R 1 +_ACEOF + + fi + +fi fi + + # Avoids picking hidden internal symbol from libc + echo "$as_me:$LINENO: checking whether gethostbyaddr_r is declared" >&5 +echo $ECHO_N "checking whether gethostbyaddr_r is declared... $ECHO_C" >&6 +if test "${ac_cv_have_decl_gethostbyaddr_r+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include + +int +main () +{ +#ifndef gethostbyaddr_r + char *p = (char *) gethostbyaddr_r; +#endif + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_have_decl_gethostbyaddr_r=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_have_decl_gethostbyaddr_r=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_have_decl_gethostbyaddr_r" >&5 +echo "${ECHO_T}$ac_cv_have_decl_gethostbyaddr_r" >&6 +if test $ac_cv_have_decl_gethostbyaddr_r = yes; then + +cat >>confdefs.h <<_ACEOF +#define HAVE_DECL_GETHOSTBYADDR_R 1 +_ACEOF + + + tcl_cv_api_gethostbyaddr_r=yes +else + cat >>confdefs.h <<_ACEOF +#define HAVE_DECL_GETHOSTBYADDR_R 0 +_ACEOF + +tcl_cv_api_gethostbyaddr_r=no fi - ac_fn_c_check_func "$LINENO" "gethostbyaddr_r" "ac_cv_func_gethostbyaddr_r" -if test "x$ac_cv_func_gethostbyaddr_r" = xyes; then : - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for gethostbyaddr_r with 7 args" >&5 -$as_echo_n "checking for gethostbyaddr_r with 7 args... " >&6; } -if ${tcl_cv_api_gethostbyaddr_r_7+:} false; then : - $as_echo_n "(cached) " >&6 + + + if test "$tcl_cv_api_gethostbyaddr_r" = yes; then + echo "$as_me:$LINENO: checking for gethostbyaddr_r" >&5 +echo $ECHO_N "checking for gethostbyaddr_r... $ECHO_C" >&6 +if test "${ac_cv_func_gethostbyaddr_r+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define gethostbyaddr_r to an innocuous variant, in case declares gethostbyaddr_r. + For example, HP-UX 11i declares gettimeofday. */ +#define gethostbyaddr_r innocuous_gethostbyaddr_r + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char gethostbyaddr_r (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef gethostbyaddr_r + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char gethostbyaddr_r (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_gethostbyaddr_r) || defined (__stub___gethostbyaddr_r) +choke me +#else +char (*f) () = gethostbyaddr_r; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != gethostbyaddr_r; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_func_gethostbyaddr_r=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_func_gethostbyaddr_r=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_func_gethostbyaddr_r" >&5 +echo "${ECHO_T}$ac_cv_func_gethostbyaddr_r" >&6 +if test $ac_cv_func_gethostbyaddr_r = yes; then + + echo "$as_me:$LINENO: checking for gethostbyaddr_r with 7 args" >&5 +echo $ECHO_N "checking for gethostbyaddr_r with 7 args... $ECHO_C" >&6 +if test "${tcl_cv_api_gethostbyaddr_r_7+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int @@ -8107,32 +12923,62 @@ ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_api_gethostbyaddr_r_7=yes else - tcl_cv_api_gethostbyaddr_r_7=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_api_gethostbyaddr_r_7=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_gethostbyaddr_r_7" >&5 -$as_echo "$tcl_cv_api_gethostbyaddr_r_7" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_api_gethostbyaddr_r_7" >&5 +echo "${ECHO_T}$tcl_cv_api_gethostbyaddr_r_7" >&6 tcl_ok=$tcl_cv_api_gethostbyaddr_r_7 if test "$tcl_ok" = yes; then -$as_echo "#define HAVE_GETHOSTBYADDR_R_7 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_GETHOSTBYADDR_R_7 1 +_ACEOF else - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for gethostbyaddr_r with 8 args" >&5 -$as_echo_n "checking for gethostbyaddr_r with 8 args... " >&6; } -if ${tcl_cv_api_gethostbyaddr_r_8+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking for gethostbyaddr_r with 8 args" >&5 +echo $ECHO_N "checking for gethostbyaddr_r with 8 args... $ECHO_C" >&6 +if test "${tcl_cv_api_gethostbyaddr_r_8+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int @@ -8152,34 +12998,65 @@ ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_api_gethostbyaddr_r_8=yes else - tcl_cv_api_gethostbyaddr_r_8=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_api_gethostbyaddr_r_8=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_gethostbyaddr_r_8" >&5 -$as_echo "$tcl_cv_api_gethostbyaddr_r_8" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_api_gethostbyaddr_r_8" >&5 +echo "${ECHO_T}$tcl_cv_api_gethostbyaddr_r_8" >&6 tcl_ok=$tcl_cv_api_gethostbyaddr_r_8 if test "$tcl_ok" = yes; then -$as_echo "#define HAVE_GETHOSTBYADDR_R_8 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_GETHOSTBYADDR_R_8 1 +_ACEOF fi fi if test "$tcl_ok" = yes; then -$as_echo "#define HAVE_GETHOSTBYADDR_R 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_GETHOSTBYADDR_R 1 +_ACEOF + + fi + +fi fi -fi - + fi fi #--------------------------------------------------------------------------- # Check for serial port interface. # @@ -8186,41 +13063,455 @@ # termios.h is present on all POSIX systems. # sys/ioctl.h is almost always present, though what it contains # is system-specific. # sys/modem.h is needed on HP-UX. #--------------------------------------------------------------------------- + for ac_header in termios.h -do : - ac_fn_c_check_header_mongrel "$LINENO" "termios.h" "ac_cv_header_termios_h" "$ac_includes_default" -if test "x$ac_cv_header_termios_h" = xyes; then : +do +as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo "$as_me:$LINENO: checking for $ac_header" >&5 +echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 +else + # Is the header compilable? +echo "$as_me:$LINENO: checking $ac_header usability" >&5 +echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +#include <$ac_header> +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_header_compiler=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_header_compiler=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 +echo "${ECHO_T}$ac_header_compiler" >&6 + +# Is the header present? +echo "$as_me:$LINENO: checking $ac_header presence" >&5 +echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include <$ac_header> +_ACEOF +if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 + (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null; then + if test -s conftest.err; then + ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag + else + ac_cpp_err= + fi +else + ac_cpp_err=yes +fi +if test -z "$ac_cpp_err"; then + ac_header_preproc=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_header_preproc=no +fi +rm -f conftest.err conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 +echo "${ECHO_T}$ac_header_preproc" >&6 + +# So? What about this header? +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) + { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 +echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes + ;; + no:yes:* ) + { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 +echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 +echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} + ( + cat <<\_ASBOX +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## +_ASBOX + ) | + sed "s/^/$as_me: WARNING: /" >&2 + ;; +esac +echo "$as_me:$LINENO: checking for $ac_header" >&5 +echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + eval "$as_ac_Header=\$ac_header_preproc" +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 + +fi +if test `eval echo '${'$as_ac_Header'}'` = yes; then cat >>confdefs.h <<_ACEOF -#define HAVE_TERMIOS_H 1 +#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done + for ac_header in sys/ioctl.h -do : - ac_fn_c_check_header_mongrel "$LINENO" "sys/ioctl.h" "ac_cv_header_sys_ioctl_h" "$ac_includes_default" -if test "x$ac_cv_header_sys_ioctl_h" = xyes; then : +do +as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo "$as_me:$LINENO: checking for $ac_header" >&5 +echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 +else + # Is the header compilable? +echo "$as_me:$LINENO: checking $ac_header usability" >&5 +echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +#include <$ac_header> +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_header_compiler=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_header_compiler=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 +echo "${ECHO_T}$ac_header_compiler" >&6 + +# Is the header present? +echo "$as_me:$LINENO: checking $ac_header presence" >&5 +echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include <$ac_header> +_ACEOF +if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 + (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null; then + if test -s conftest.err; then + ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag + else + ac_cpp_err= + fi +else + ac_cpp_err=yes +fi +if test -z "$ac_cpp_err"; then + ac_header_preproc=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_header_preproc=no +fi +rm -f conftest.err conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 +echo "${ECHO_T}$ac_header_preproc" >&6 + +# So? What about this header? +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) + { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 +echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes + ;; + no:yes:* ) + { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 +echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 +echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} + ( + cat <<\_ASBOX +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## +_ASBOX + ) | + sed "s/^/$as_me: WARNING: /" >&2 + ;; +esac +echo "$as_me:$LINENO: checking for $ac_header" >&5 +echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + eval "$as_ac_Header=\$ac_header_preproc" +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 + +fi +if test `eval echo '${'$as_ac_Header'}'` = yes; then cat >>confdefs.h <<_ACEOF -#define HAVE_SYS_IOCTL_H 1 +#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done + for ac_header in sys/modem.h -do : - ac_fn_c_check_header_mongrel "$LINENO" "sys/modem.h" "ac_cv_header_sys_modem_h" "$ac_includes_default" -if test "x$ac_cv_header_sys_modem_h" = xyes; then : +do +as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo "$as_me:$LINENO: checking for $ac_header" >&5 +echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 +else + # Is the header compilable? +echo "$as_me:$LINENO: checking $ac_header usability" >&5 +echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +#include <$ac_header> +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_header_compiler=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_header_compiler=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 +echo "${ECHO_T}$ac_header_compiler" >&6 + +# Is the header present? +echo "$as_me:$LINENO: checking $ac_header presence" >&5 +echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include <$ac_header> +_ACEOF +if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 + (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null; then + if test -s conftest.err; then + ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag + else + ac_cpp_err= + fi +else + ac_cpp_err=yes +fi +if test -z "$ac_cpp_err"; then + ac_header_preproc=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_header_preproc=no +fi +rm -f conftest.err conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 +echo "${ECHO_T}$ac_header_preproc" >&6 + +# So? What about this header? +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) + { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 +echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes + ;; + no:yes:* ) + { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 +echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 +echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} + ( + cat <<\_ASBOX +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## +_ASBOX + ) | + sed "s/^/$as_me: WARNING: /" >&2 + ;; +esac +echo "$as_me:$LINENO: checking for $ac_header" >&5 +echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + eval "$as_ac_Header=\$ac_header_preproc" +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 + +fi +if test `eval echo '${'$as_ac_Header'}'` = yes; then cat >>confdefs.h <<_ACEOF -#define HAVE_SYS_MODEM_H 1 +#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done @@ -8234,17 +13525,21 @@ # other systems like SCO UNIX have a sys/select.h that's # pernicious. If "fd_set" isn't defined anywhere then set a # special flag. #-------------------------------------------------------------------- -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for fd_set in sys/types" >&5 -$as_echo_n "checking for fd_set in sys/types... " >&6; } -if ${tcl_cv_type_fd_set+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for fd_set in sys/types" >&5 +echo $ECHO_N "checking for fd_set in sys/types... $ECHO_C" >&6 +if test "${tcl_cv_type_fd_set+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { @@ -8251,153 +13546,253 @@ fd_set readMask, writeMask; ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_type_fd_set=yes else - tcl_cv_type_fd_set=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_type_fd_set=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_type_fd_set" >&5 -$as_echo "$tcl_cv_type_fd_set" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_type_fd_set" >&5 +echo "${ECHO_T}$tcl_cv_type_fd_set" >&6 tcl_ok=$tcl_cv_type_fd_set if test $tcl_ok = no; then - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for fd_mask in sys/select" >&5 -$as_echo_n "checking for fd_mask in sys/select... " >&6; } -if ${tcl_cv_grep_fd_mask+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking for fd_mask in sys/select" >&5 +echo $ECHO_N "checking for fd_mask in sys/select... $ECHO_C" >&6 +if test "${tcl_cv_grep_fd_mask+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - $EGREP "fd_mask" >/dev/null 2>&1; then : + $EGREP "fd_mask" >/dev/null 2>&1; then tcl_cv_grep_fd_mask=present else tcl_cv_grep_fd_mask=missing fi rm -f conftest* fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_grep_fd_mask" >&5 -$as_echo "$tcl_cv_grep_fd_mask" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_grep_fd_mask" >&5 +echo "${ECHO_T}$tcl_cv_grep_fd_mask" >&6 if test $tcl_cv_grep_fd_mask = present; then -$as_echo "#define HAVE_SYS_SELECT_H 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_SYS_SELECT_H 1 +_ACEOF tcl_ok=yes fi fi if test $tcl_ok = no; then -$as_echo "#define NO_FD_SET 1" >>confdefs.h - -fi - -#------------------------------------------------------------------------ -# Options for the notifier. Checks for epoll(7) on Linux, and -# kqueue(2) on {DragonFly,Free,Net,Open}BSD -#------------------------------------------------------------------------ - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for advanced notifier support" >&5 -$as_echo_n "checking for advanced notifier support... " >&6; } -case x`uname -s` in - xLinux) - { $as_echo "$as_me:${as_lineno-$LINENO}: result: epoll(7)" >&5 -$as_echo "epoll(7)" >&6; } - for ac_header in sys/epoll.h -do : - ac_fn_c_check_header_mongrel "$LINENO" "sys/epoll.h" "ac_cv_header_sys_epoll_h" "$ac_includes_default" -if test "x$ac_cv_header_sys_epoll_h" = xyes; then : - cat >>confdefs.h <<_ACEOF -#define HAVE_SYS_EPOLL_H 1 -_ACEOF - -$as_echo "#define NOTIFIER_EPOLL 1" >>confdefs.h - -fi - -done - - for ac_header in sys/eventfd.h -do : - ac_fn_c_check_header_mongrel "$LINENO" "sys/eventfd.h" "ac_cv_header_sys_eventfd_h" "$ac_includes_default" -if test "x$ac_cv_header_sys_eventfd_h" = xyes; then : - cat >>confdefs.h <<_ACEOF -#define HAVE_SYS_EVENTFD_H 1 -_ACEOF - -$as_echo "#define HAVE_EVENTFD 1" >>confdefs.h - -fi - -done -;; - xDragonFlyBSD|xFreeBSD|xNetBSD|xOpenBSD) - { $as_echo "$as_me:${as_lineno-$LINENO}: result: kqueue(2)" >&5 -$as_echo "kqueue(2)" >&6; } - # Messy because we want to check if *all* the headers are present, and not - # just *any* - tcl_kqueue_headers=x - for ac_header in sys/types.h sys/event.h sys/time.h -do : - as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` -ac_fn_c_check_header_mongrel "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default" -if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : - cat >>confdefs.h <<_ACEOF -#define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 -_ACEOF - tcl_kqueue_headers=${tcl_kqueue_headers}y -fi - -done - - if test $tcl_kqueue_headers = xyyy; then : - - -$as_echo "#define NOTIFIER_KQUEUE 1" >>confdefs.h - -fi;; - xDarwin) - # Assume that we've got CoreFoundation present (checked elsewhere because - # of wider impact). - { $as_echo "$as_me:${as_lineno-$LINENO}: result: OSX" >&5 -$as_echo "OSX" >&6; };; - *) - { $as_echo "$as_me:${as_lineno-$LINENO}: result: none" >&5 -$as_echo "none" >&6; };; -esac +cat >>confdefs.h <<\_ACEOF +#define NO_FD_SET 1 +_ACEOF + +fi #------------------------------------------------------------------------------ # Find out all about time handling differences. #------------------------------------------------------------------------------ - for ac_header in sys/time.h -do : - ac_fn_c_check_header_mongrel "$LINENO" "sys/time.h" "ac_cv_header_sys_time_h" "$ac_includes_default" -if test "x$ac_cv_header_sys_time_h" = xyes; then : + +for ac_header in sys/time.h +do +as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo "$as_me:$LINENO: checking for $ac_header" >&5 +echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 +else + # Is the header compilable? +echo "$as_me:$LINENO: checking $ac_header usability" >&5 +echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +#include <$ac_header> +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_header_compiler=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_header_compiler=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 +echo "${ECHO_T}$ac_header_compiler" >&6 + +# Is the header present? +echo "$as_me:$LINENO: checking $ac_header presence" >&5 +echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include <$ac_header> +_ACEOF +if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 + (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null; then + if test -s conftest.err; then + ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag + else + ac_cpp_err= + fi +else + ac_cpp_err=yes +fi +if test -z "$ac_cpp_err"; then + ac_header_preproc=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_header_preproc=no +fi +rm -f conftest.err conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 +echo "${ECHO_T}$ac_header_preproc" >&6 + +# So? What about this header? +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) + { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 +echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes + ;; + no:yes:* ) + { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 +echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 +echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} + ( + cat <<\_ASBOX +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## +_ASBOX + ) | + sed "s/^/$as_me: WARNING: /" >&2 + ;; +esac +echo "$as_me:$LINENO: checking for $ac_header" >&5 +echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + eval "$as_ac_Header=\$ac_header_preproc" +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 + +fi +if test `eval echo '${'$as_ac_Header'}'` = yes; then cat >>confdefs.h <<_ACEOF -#define HAVE_SYS_TIME_H 1 +#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done - { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether time.h and sys/time.h may both be included" >&5 -$as_echo_n "checking whether time.h and sys/time.h may both be included... " >&6; } -if ${ac_cv_header_time+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking whether time.h and sys/time.h may both be included" >&5 +echo $ECHO_N "checking whether time.h and sys/time.h may both be included... $ECHO_C" >&6 +if test "${ac_cv_header_time+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include @@ -8408,46 +13803,168 @@ return 0; ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then ac_cv_header_time=yes else - ac_cv_header_time=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_header_time=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_header_time" >&5 -$as_echo "$ac_cv_header_time" >&6; } +echo "$as_me:$LINENO: result: $ac_cv_header_time" >&5 +echo "${ECHO_T}$ac_cv_header_time" >&6 if test $ac_cv_header_time = yes; then -$as_echo "#define TIME_WITH_SYS_TIME 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define TIME_WITH_SYS_TIME 1 +_ACEOF fi - for ac_func in gmtime_r localtime_r mktime -do : - as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` -ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var" -if eval test \"x\$"$as_ac_var"\" = x"yes"; then : + + + +for ac_func in gmtime_r localtime_r mktime +do +as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` +echo "$as_me:$LINENO: checking for $ac_func" >&5 +echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 +if eval "test \"\${$as_ac_var+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define $ac_func to an innocuous variant, in case declares $ac_func. + For example, HP-UX 11i declares gettimeofday. */ +#define $ac_func innocuous_$ac_func + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char $ac_func (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef $ac_func + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char $ac_func (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_$ac_func) || defined (__stub___$ac_func) +choke me +#else +char (*f) () = $ac_func; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != $ac_func; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + eval "$as_ac_var=yes" +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +eval "$as_ac_var=no" +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 +if test `eval echo '${'$as_ac_var'}'` = yes; then cat >>confdefs.h <<_ACEOF -#define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 +#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done - { $as_echo "$as_me:${as_lineno-$LINENO}: checking tm_tzadj in struct tm" >&5 -$as_echo_n "checking tm_tzadj in struct tm... " >&6; } -if ${tcl_cv_member_tm_tzadj+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking tm_tzadj in struct tm" >&5 +echo $ECHO_N "checking tm_tzadj in struct tm... $ECHO_C" >&6 +if test "${tcl_cv_member_tm_tzadj+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { @@ -8454,68 +13971,128 @@ struct tm tm; tm.tm_tzadj; ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_member_tm_tzadj=yes else - tcl_cv_member_tm_tzadj=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_member_tm_tzadj=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_member_tm_tzadj" >&5 -$as_echo "$tcl_cv_member_tm_tzadj" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_member_tm_tzadj" >&5 +echo "${ECHO_T}$tcl_cv_member_tm_tzadj" >&6 if test $tcl_cv_member_tm_tzadj = yes ; then -$as_echo "#define HAVE_TM_TZADJ 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_TM_TZADJ 1 +_ACEOF fi - { $as_echo "$as_me:${as_lineno-$LINENO}: checking tm_gmtoff in struct tm" >&5 -$as_echo_n "checking tm_gmtoff in struct tm... " >&6; } -if ${tcl_cv_member_tm_gmtoff+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking tm_gmtoff in struct tm" >&5 +echo $ECHO_N "checking tm_gmtoff in struct tm... $ECHO_C" >&6 +if test "${tcl_cv_member_tm_gmtoff+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { -struct tm tm; tm.tm_gmtoff; +struct tm tm; (void)tm.tm_gmtoff; ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_member_tm_gmtoff=yes else - tcl_cv_member_tm_gmtoff=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_member_tm_gmtoff=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_member_tm_gmtoff" >&5 -$as_echo "$tcl_cv_member_tm_gmtoff" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_member_tm_gmtoff" >&5 +echo "${ECHO_T}$tcl_cv_member_tm_gmtoff" >&6 if test $tcl_cv_member_tm_gmtoff = yes ; then -$as_echo "#define HAVE_TM_GMTOFF 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_TM_GMTOFF 1 +_ACEOF fi # # Its important to include time.h in this check, as some systems # (like convex) have timezone functions, etc. # - { $as_echo "$as_me:${as_lineno-$LINENO}: checking long timezone variable" >&5 -$as_echo_n "checking long timezone variable... " >&6; } -if ${tcl_cv_timezone_long+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking long timezone variable" >&5 +echo $ECHO_N "checking long timezone variable... $ECHO_C" >&6 +if test "${tcl_cv_timezone_long+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { @@ -8524,34 +14101,64 @@ exit (0); ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_timezone_long=yes else - tcl_cv_timezone_long=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_timezone_long=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_timezone_long" >&5 -$as_echo "$tcl_cv_timezone_long" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_timezone_long" >&5 +echo "${ECHO_T}$tcl_cv_timezone_long" >&6 if test $tcl_cv_timezone_long = yes ; then -$as_echo "#define HAVE_TIMEZONE_VAR 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_TIMEZONE_VAR 1 +_ACEOF else # # On some systems (eg IRIX 6.2), timezone is a time_t and not a long. # - { $as_echo "$as_me:${as_lineno-$LINENO}: checking time_t timezone variable" >&5 -$as_echo_n "checking time_t timezone variable... " >&6; } -if ${tcl_cv_timezone_time+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking time_t timezone variable" >&5 +echo $ECHO_N "checking time_t timezone variable... $ECHO_C" >&6 +if test "${tcl_cv_timezone_time+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { @@ -8560,22 +14167,48 @@ exit (0); ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_timezone_time=yes else - tcl_cv_timezone_time=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_timezone_time=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_timezone_time" >&5 -$as_echo "$tcl_cv_timezone_time" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_timezone_time" >&5 +echo "${ECHO_T}$tcl_cv_timezone_time" >&6 if test $tcl_cv_timezone_time = yes ; then -$as_echo "#define HAVE_TIMEZONE_VAR 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_TIMEZONE_VAR 1 +_ACEOF fi fi @@ -8584,74 +14217,424 @@ # we might be able to use fstatfs instead. Some systems (OpenBSD?) also # lack blkcnt_t. #-------------------------------------------------------------------- if test "$ac_cv_cygwin" != "yes"; then - ac_fn_c_check_member "$LINENO" "struct stat" "st_blocks" "ac_cv_member_struct_stat_st_blocks" "$ac_includes_default" -if test "x$ac_cv_member_struct_stat_st_blocks" = xyes; then : + echo "$as_me:$LINENO: checking for struct stat.st_blocks" >&5 +echo $ECHO_N "checking for struct stat.st_blocks... $ECHO_C" >&6 +if test "${ac_cv_member_struct_stat_st_blocks+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +int +main () +{ +static struct stat ac_aggr; +if (ac_aggr.st_blocks) +return 0; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_member_struct_stat_st_blocks=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +int +main () +{ +static struct stat ac_aggr; +if (sizeof ac_aggr.st_blocks) +return 0; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_member_struct_stat_st_blocks=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_member_struct_stat_st_blocks=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_member_struct_stat_st_blocks" >&5 +echo "${ECHO_T}$ac_cv_member_struct_stat_st_blocks" >&6 +if test $ac_cv_member_struct_stat_st_blocks = yes; then cat >>confdefs.h <<_ACEOF #define HAVE_STRUCT_STAT_ST_BLOCKS 1 _ACEOF fi -ac_fn_c_check_member "$LINENO" "struct stat" "st_blksize" "ac_cv_member_struct_stat_st_blksize" "$ac_includes_default" -if test "x$ac_cv_member_struct_stat_st_blksize" = xyes; then : +echo "$as_me:$LINENO: checking for struct stat.st_blksize" >&5 +echo $ECHO_N "checking for struct stat.st_blksize... $ECHO_C" >&6 +if test "${ac_cv_member_struct_stat_st_blksize+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +int +main () +{ +static struct stat ac_aggr; +if (ac_aggr.st_blksize) +return 0; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_member_struct_stat_st_blksize=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +int +main () +{ +static struct stat ac_aggr; +if (sizeof ac_aggr.st_blksize) +return 0; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_member_struct_stat_st_blksize=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_member_struct_stat_st_blksize=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_member_struct_stat_st_blksize" >&5 +echo "${ECHO_T}$ac_cv_member_struct_stat_st_blksize" >&6 +if test $ac_cv_member_struct_stat_st_blksize = yes; then cat >>confdefs.h <<_ACEOF #define HAVE_STRUCT_STAT_ST_BLKSIZE 1 _ACEOF fi fi -ac_fn_c_check_type "$LINENO" "blkcnt_t" "ac_cv_type_blkcnt_t" "$ac_includes_default" -if test "x$ac_cv_type_blkcnt_t" = xyes; then : +echo "$as_me:$LINENO: checking for blkcnt_t" >&5 +echo $ECHO_N "checking for blkcnt_t... $ECHO_C" >&6 +if test "${ac_cv_type_blkcnt_t+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +int +main () +{ +if ((blkcnt_t *) 0) + return 0; +if (sizeof (blkcnt_t)) + return 0; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_type_blkcnt_t=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_type_blkcnt_t=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_type_blkcnt_t" >&5 +echo "${ECHO_T}$ac_cv_type_blkcnt_t" >&6 +if test $ac_cv_type_blkcnt_t = yes; then cat >>confdefs.h <<_ACEOF #define HAVE_BLKCNT_T 1 _ACEOF fi -ac_fn_c_check_func "$LINENO" "fstatfs" "ac_cv_func_fstatfs" -if test "x$ac_cv_func_fstatfs" = xyes; then : +echo "$as_me:$LINENO: checking for fstatfs" >&5 +echo $ECHO_N "checking for fstatfs... $ECHO_C" >&6 +if test "${ac_cv_func_fstatfs+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define fstatfs to an innocuous variant, in case declares fstatfs. + For example, HP-UX 11i declares gettimeofday. */ +#define fstatfs innocuous_fstatfs +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char fstatfs (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef fstatfs + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char fstatfs (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_fstatfs) || defined (__stub___fstatfs) +choke me +#else +char (*f) () = fstatfs; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != fstatfs; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_func_fstatfs=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_func_fstatfs=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_func_fstatfs" >&5 +echo "${ECHO_T}$ac_cv_func_fstatfs" >&6 +if test $ac_cv_func_fstatfs = yes; then + : else -$as_echo "#define NO_FSTATFS 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define NO_FSTATFS 1 +_ACEOF fi #-------------------------------------------------------------------- # Some system have no memcmp or it does not work with 8 bit data, this # checks it and add memcmp.o to LIBOBJS if needed #-------------------------------------------------------------------- -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for working memcmp" >&5 -$as_echo_n "checking for working memcmp... " >&6; } -if ${ac_cv_func_memcmp_working+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for working memcmp" >&5 +echo $ECHO_N "checking for working memcmp... $ECHO_C" >&6 +if test "${ac_cv_func_memcmp_working+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - if test "$cross_compiling" = yes; then : + if test "$cross_compiling" = yes; then ac_cv_func_memcmp_working=no else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { /* Some versions of memcmp are not 8-bit clean. */ - char c0 = '\100', c1 = '\200', c2 = '\201'; + char c0 = 0x40, c1 = 0x80, c2 = 0x81; if (memcmp(&c0, &c2, 1) >= 0 || memcmp(&c1, &c2, 1) >= 0) - return 1; + exit (1); /* The Next x86 OpenStep bug shows up only when comparing 16 bytes or more and with at least one buffer not starting on a 4-byte boundary. William Lewis provided this test program. */ { @@ -8663,35 +14646,50 @@ char *a = foo + i; char *b = bar + i; strcpy (a, "--------01111111"); strcpy (b, "--------10000000"); if (memcmp (a, b, 16) >= 0) - return 1; + exit (1); } - return 0; + exit (0); } ; return 0; } _ACEOF -if ac_fn_c_try_run "$LINENO"; then : +rm -f conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { ac_try='./conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then ac_cv_func_memcmp_working=yes else - ac_cv_func_memcmp_working=no -fi -rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ - conftest.$ac_objext conftest.beam conftest.$ac_ext -fi - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_func_memcmp_working" >&5 -$as_echo "$ac_cv_func_memcmp_working" >&6; } -test $ac_cv_func_memcmp_working = no && case " $LIBOBJS " in + echo "$as_me: program exited with status $ac_status" >&5 +echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +( exit $ac_status ) +ac_cv_func_memcmp_working=no +fi +rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext +fi +fi +echo "$as_me:$LINENO: result: $ac_cv_func_memcmp_working" >&5 +echo "${ECHO_T}$ac_cv_func_memcmp_working" >&6 +test $ac_cv_func_memcmp_working = no && case $LIBOBJS in + "memcmp.$ac_objext" | \ + *" memcmp.$ac_objext" | \ + "memcmp.$ac_objext "* | \ *" memcmp.$ac_objext "* ) ;; - *) LIBOBJS="$LIBOBJS memcmp.$ac_objext" - ;; + *) LIBOBJS="$LIBOBJS memcmp.$ac_objext" ;; esac #-------------------------------------------------------------------- @@ -8698,20 +14696,113 @@ # Some system like SunOS 4 and other BSD like systems have no memmove # (we assume they have bcopy instead). {The replacement define is in # compat/string.h} #-------------------------------------------------------------------- -ac_fn_c_check_func "$LINENO" "memmove" "ac_cv_func_memmove" -if test "x$ac_cv_func_memmove" = xyes; then : +echo "$as_me:$LINENO: checking for memmove" >&5 +echo $ECHO_N "checking for memmove... $ECHO_C" >&6 +if test "${ac_cv_func_memmove+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define memmove to an innocuous variant, in case declares memmove. + For example, HP-UX 11i declares gettimeofday. */ +#define memmove innocuous_memmove +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char memmove (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef memmove + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char memmove (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_memmove) || defined (__stub___memmove) +choke me +#else +char (*f) () = memmove; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != memmove; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_func_memmove=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_func_memmove=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_func_memmove" >&5 +echo "${ECHO_T}$ac_cv_func_memmove" >&6 +if test $ac_cv_func_memmove = yes; then + : else -$as_echo "#define NO_MEMMOVE 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define NO_MEMMOVE 1 +_ACEOF -$as_echo "#define NO_STRING_H 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define NO_STRING_H 1 +_ACEOF fi #-------------------------------------------------------------------- @@ -8718,56 +14809,166 @@ # On some systems strstr is broken: it returns a pointer even even if # the original string is empty. #-------------------------------------------------------------------- - ac_fn_c_check_func "$LINENO" "strstr" "ac_cv_func_strstr" -if test "x$ac_cv_func_strstr" = xyes; then : + echo "$as_me:$LINENO: checking for strstr" >&5 +echo $ECHO_N "checking for strstr... $ECHO_C" >&6 +if test "${ac_cv_func_strstr+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define strstr to an innocuous variant, in case declares strstr. + For example, HP-UX 11i declares gettimeofday. */ +#define strstr innocuous_strstr + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char strstr (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef strstr + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char strstr (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_strstr) || defined (__stub___strstr) +choke me +#else +char (*f) () = strstr; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != strstr; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_func_strstr=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_func_strstr=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_func_strstr" >&5 +echo "${ECHO_T}$ac_cv_func_strstr" >&6 +if test $ac_cv_func_strstr = yes; then tcl_ok=1 else tcl_ok=0 fi if test "$tcl_ok" = 1; then - { $as_echo "$as_me:${as_lineno-$LINENO}: checking proper strstr implementation" >&5 -$as_echo_n "checking proper strstr implementation... " >&6; } -if ${tcl_cv_strstr_unbroken+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking proper strstr implementation" >&5 +echo $ECHO_N "checking proper strstr implementation... $ECHO_C" >&6 +if test "${tcl_cv_strstr_unbroken+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - if test "$cross_compiling" = yes; then : + if test "$cross_compiling" = yes; then tcl_cv_strstr_unbroken=unknown else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ + +#include +#include int main() { - extern int strstr(); exit(strstr("\0test", "test") ? 1 : 0); } _ACEOF -if ac_fn_c_try_run "$LINENO"; then : +rm -f conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { ac_try='./conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_strstr_unbroken=ok else - tcl_cv_strstr_unbroken=broken -fi -rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ - conftest.$ac_objext conftest.beam conftest.$ac_ext -fi - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_strstr_unbroken" >&5 -$as_echo "$tcl_cv_strstr_unbroken" >&6; } + echo "$as_me: program exited with status $ac_status" >&5 +echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +( exit $ac_status ) +tcl_cv_strstr_unbroken=broken +fi +rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext +fi +fi +echo "$as_me:$LINENO: result: $tcl_cv_strstr_unbroken" >&5 +echo "${ECHO_T}$tcl_cv_strstr_unbroken" >&6 if test "$tcl_cv_strstr_unbroken" = "ok"; then tcl_ok=1 else tcl_ok=0 fi fi if test "$tcl_ok" = 0; then - case " $LIBOBJS " in + case $LIBOBJS in + "strstr.$ac_objext" | \ + *" strstr.$ac_objext" | \ + "strstr.$ac_objext "* | \ *" strstr.$ac_objext "* ) ;; - *) LIBOBJS="$LIBOBJS strstr.$ac_objext" - ;; + *) LIBOBJS="$LIBOBJS strstr.$ac_objext" ;; esac USE_COMPAT=1 fi @@ -8777,57 +14978,167 @@ # versions of AIX strtoul returns an incorrect terminator # pointer for the string "0". #-------------------------------------------------------------------- - ac_fn_c_check_func "$LINENO" "strtoul" "ac_cv_func_strtoul" -if test "x$ac_cv_func_strtoul" = xyes; then : + echo "$as_me:$LINENO: checking for strtoul" >&5 +echo $ECHO_N "checking for strtoul... $ECHO_C" >&6 +if test "${ac_cv_func_strtoul+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define strtoul to an innocuous variant, in case declares strtoul. + For example, HP-UX 11i declares gettimeofday. */ +#define strtoul innocuous_strtoul + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char strtoul (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef strtoul + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char strtoul (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_strtoul) || defined (__stub___strtoul) +choke me +#else +char (*f) () = strtoul; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != strtoul; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_func_strtoul=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_func_strtoul=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_func_strtoul" >&5 +echo "${ECHO_T}$ac_cv_func_strtoul" >&6 +if test $ac_cv_func_strtoul = yes; then tcl_ok=1 else tcl_ok=0 fi if test "$tcl_ok" = 1; then - { $as_echo "$as_me:${as_lineno-$LINENO}: checking proper strtoul implementation" >&5 -$as_echo_n "checking proper strtoul implementation... " >&6; } -if ${tcl_cv_strtoul_unbroken+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking proper strtoul implementation" >&5 +echo $ECHO_N "checking proper strtoul implementation... $ECHO_C" >&6 +if test "${tcl_cv_strtoul_unbroken+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - if test "$cross_compiling" = yes; then : + if test "$cross_compiling" = yes; then tcl_cv_strtoul_unbroken=unknown else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ + +#include +#include int main() { - extern int strtoul(); char *term, *string = "0"; exit(strtoul(string,&term,0) != 0 || term != string+1); } _ACEOF -if ac_fn_c_try_run "$LINENO"; then : +rm -f conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { ac_try='./conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_strtoul_unbroken=ok else - tcl_cv_strtoul_unbroken=broken -fi -rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ - conftest.$ac_objext conftest.beam conftest.$ac_ext -fi - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_strtoul_unbroken" >&5 -$as_echo "$tcl_cv_strtoul_unbroken" >&6; } + echo "$as_me: program exited with status $ac_status" >&5 +echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +( exit $ac_status ) +tcl_cv_strtoul_unbroken=broken +fi +rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext +fi +fi +echo "$as_me:$LINENO: result: $tcl_cv_strtoul_unbroken" >&5 +echo "${ECHO_T}$tcl_cv_strtoul_unbroken" >&6 if test "$tcl_cv_strtoul_unbroken" = "ok"; then tcl_ok=1 else tcl_ok=0 fi fi if test "$tcl_ok" = 0; then - case " $LIBOBJS " in + case $LIBOBJS in + "strtoul.$ac_objext" | \ + *" strtoul.$ac_objext" | \ + "strtoul.$ac_objext "* | \ *" strtoul.$ac_objext "* ) ;; - *) LIBOBJS="$LIBOBJS strtoul.$ac_objext" - ;; + *) LIBOBJS="$LIBOBJS strtoul.$ac_objext" ;; esac USE_COMPAT=1 fi @@ -8835,81 +15146,258 @@ #-------------------------------------------------------------------- # Check for various typedefs and provide substitutes if # they don't exist. #-------------------------------------------------------------------- -ac_fn_c_check_type "$LINENO" "mode_t" "ac_cv_type_mode_t" "$ac_includes_default" -if test "x$ac_cv_type_mode_t" = xyes; then : +echo "$as_me:$LINENO: checking for mode_t" >&5 +echo $ECHO_N "checking for mode_t... $ECHO_C" >&6 +if test "${ac_cv_type_mode_t+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +int +main () +{ +if ((mode_t *) 0) + return 0; +if (sizeof (mode_t)) + return 0; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_type_mode_t=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 +ac_cv_type_mode_t=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_type_mode_t" >&5 +echo "${ECHO_T}$ac_cv_type_mode_t" >&6 +if test $ac_cv_type_mode_t = yes; then + : else cat >>confdefs.h <<_ACEOF #define mode_t int _ACEOF fi -ac_fn_c_check_type "$LINENO" "pid_t" "ac_cv_type_pid_t" "$ac_includes_default" -if test "x$ac_cv_type_pid_t" = xyes; then : +echo "$as_me:$LINENO: checking for pid_t" >&5 +echo $ECHO_N "checking for pid_t... $ECHO_C" >&6 +if test "${ac_cv_type_pid_t+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +int +main () +{ +if ((pid_t *) 0) + return 0; +if (sizeof (pid_t)) + return 0; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_type_pid_t=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 +ac_cv_type_pid_t=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_type_pid_t" >&5 +echo "${ECHO_T}$ac_cv_type_pid_t" >&6 +if test $ac_cv_type_pid_t = yes; then + : else cat >>confdefs.h <<_ACEOF #define pid_t int _ACEOF fi -ac_fn_c_check_type "$LINENO" "size_t" "ac_cv_type_size_t" "$ac_includes_default" -if test "x$ac_cv_type_size_t" = xyes; then : +echo "$as_me:$LINENO: checking for size_t" >&5 +echo $ECHO_N "checking for size_t... $ECHO_C" >&6 +if test "${ac_cv_type_size_t+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +int +main () +{ +if ((size_t *) 0) + return 0; +if (sizeof (size_t)) + return 0; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_type_size_t=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 +ac_cv_type_size_t=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_type_size_t" >&5 +echo "${ECHO_T}$ac_cv_type_size_t" >&6 +if test $ac_cv_type_size_t = yes; then + : else cat >>confdefs.h <<_ACEOF -#define size_t unsigned int +#define size_t unsigned _ACEOF fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for uid_t in sys/types.h" >&5 -$as_echo_n "checking for uid_t in sys/types.h... " >&6; } -if ${ac_cv_type_uid_t+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for uid_t in sys/types.h" >&5 +echo $ECHO_N "checking for uid_t in sys/types.h... $ECHO_C" >&6 +if test "${ac_cv_type_uid_t+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - $EGREP "uid_t" >/dev/null 2>&1; then : + $EGREP "uid_t" >/dev/null 2>&1; then ac_cv_type_uid_t=yes else ac_cv_type_uid_t=no fi rm -f conftest* fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_type_uid_t" >&5 -$as_echo "$ac_cv_type_uid_t" >&6; } +echo "$as_me:$LINENO: result: $ac_cv_type_uid_t" >&5 +echo "${ECHO_T}$ac_cv_type_uid_t" >&6 if test $ac_cv_type_uid_t = no; then -$as_echo "#define uid_t int" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define uid_t int +_ACEOF -$as_echo "#define gid_t int" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define gid_t int +_ACEOF fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for socklen_t" >&5 -$as_echo_n "checking for socklen_t... " >&6; } -if ${tcl_cv_type_socklen_t+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for socklen_t" >&5 +echo $ECHO_N "checking for socklen_t... $ECHO_C" >&6 +if test "${tcl_cv_type_socklen_t+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include @@ -8921,66 +15409,176 @@ ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_type_socklen_t=yes else - tcl_cv_type_socklen_t=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_type_socklen_t=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_type_socklen_t" >&5 -$as_echo "$tcl_cv_type_socklen_t" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_type_socklen_t" >&5 +echo "${ECHO_T}$tcl_cv_type_socklen_t" >&6 if test $tcl_cv_type_socklen_t = no; then -$as_echo "#define socklen_t int" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define socklen_t int +_ACEOF fi -ac_fn_c_check_type "$LINENO" "intptr_t" "ac_cv_type_intptr_t" "$ac_includes_default" -if test "x$ac_cv_type_intptr_t" = xyes; then : +echo "$as_me:$LINENO: checking for intptr_t" >&5 +echo $ECHO_N "checking for intptr_t... $ECHO_C" >&6 +if test "${ac_cv_type_intptr_t+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +int +main () +{ +if ((intptr_t *) 0) + return 0; +if (sizeof (intptr_t)) + return 0; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_type_intptr_t=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_type_intptr_t=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_type_intptr_t" >&5 +echo "${ECHO_T}$ac_cv_type_intptr_t" >&6 +if test $ac_cv_type_intptr_t = yes; then -$as_echo "#define HAVE_INTPTR_T 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_INTPTR_T 1 +_ACEOF else - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for pointer-size signed integer type" >&5 -$as_echo_n "checking for pointer-size signed integer type... " >&6; } -if ${tcl_cv_intptr_t+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking for pointer-size signed integer type" >&5 +echo $ECHO_N "checking for pointer-size signed integer type... $ECHO_C" >&6 +if test "${tcl_cv_intptr_t+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else for tcl_cv_intptr_t in "int" "long" "long long" none; do if test "$tcl_cv_intptr_t" != none; then - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { static int test_array [1 - 2 * !(sizeof (void *) <= sizeof ($tcl_cv_intptr_t))]; -test_array [0] = 0; -return test_array [0]; +test_array [0] = 0 ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_ok=yes else - tcl_ok=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_ok=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext test "$tcl_ok" = yes && break; fi done fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_intptr_t" >&5 -$as_echo "$tcl_cv_intptr_t" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_intptr_t" >&5 +echo "${ECHO_T}$tcl_cv_intptr_t" >&6 if test "$tcl_cv_intptr_t" != none; then cat >>confdefs.h <<_ACEOF #define intptr_t $tcl_cv_intptr_t _ACEOF @@ -8987,52 +15585,136 @@ fi fi -ac_fn_c_check_type "$LINENO" "uintptr_t" "ac_cv_type_uintptr_t" "$ac_includes_default" -if test "x$ac_cv_type_uintptr_t" = xyes; then : +echo "$as_me:$LINENO: checking for uintptr_t" >&5 +echo $ECHO_N "checking for uintptr_t... $ECHO_C" >&6 +if test "${ac_cv_type_uintptr_t+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +int +main () +{ +if ((uintptr_t *) 0) + return 0; +if (sizeof (uintptr_t)) + return 0; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_type_uintptr_t=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_type_uintptr_t=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_type_uintptr_t" >&5 +echo "${ECHO_T}$ac_cv_type_uintptr_t" >&6 +if test $ac_cv_type_uintptr_t = yes; then -$as_echo "#define HAVE_UINTPTR_T 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_UINTPTR_T 1 +_ACEOF else - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for pointer-size unsigned integer type" >&5 -$as_echo_n "checking for pointer-size unsigned integer type... " >&6; } -if ${tcl_cv_uintptr_t+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking for pointer-size unsigned integer type" >&5 +echo $ECHO_N "checking for pointer-size unsigned integer type... $ECHO_C" >&6 +if test "${tcl_cv_uintptr_t+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else for tcl_cv_uintptr_t in "unsigned int" "unsigned long" "unsigned long long" \ none; do if test "$tcl_cv_uintptr_t" != none; then - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { static int test_array [1 - 2 * !(sizeof (void *) <= sizeof ($tcl_cv_uintptr_t))]; -test_array [0] = 0; -return test_array [0]; +test_array [0] = 0 ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_ok=yes else - tcl_ok=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_ok=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext test "$tcl_ok" = yes && break; fi done fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_uintptr_t" >&5 -$as_echo "$tcl_cv_uintptr_t" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_uintptr_t" >&5 +echo "${ECHO_T}$tcl_cv_uintptr_t" >&6 if test "$tcl_cv_uintptr_t" != none; then cat >>confdefs.h <<_ACEOF #define uintptr_t $tcl_cv_uintptr_t _ACEOF @@ -9047,16 +15729,107 @@ # then we have to supply a different version of dirent.h which # is compatible with the substitute version of opendir that's # provided. This version only works with V7-style directories. #-------------------------------------------------------------------- -ac_fn_c_check_func "$LINENO" "opendir" "ac_cv_func_opendir" -if test "x$ac_cv_func_opendir" = xyes; then : +echo "$as_me:$LINENO: checking for opendir" >&5 +echo $ECHO_N "checking for opendir... $ECHO_C" >&6 +if test "${ac_cv_func_opendir+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define opendir to an innocuous variant, in case declares opendir. + For example, HP-UX 11i declares gettimeofday. */ +#define opendir innocuous_opendir +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char opendir (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef opendir + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char opendir (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_opendir) || defined (__stub___opendir) +choke me +#else +char (*f) () = opendir; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != opendir; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_func_opendir=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_func_opendir=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_func_opendir" >&5 +echo "${ECHO_T}$ac_cv_func_opendir" >&6 +if test $ac_cv_func_opendir = yes; then + : else -$as_echo "#define USE_DIRENT2_H 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define USE_DIRENT2_H 1 +_ACEOF fi #-------------------------------------------------------------------- @@ -9065,17 +15838,21 @@ # HP-UX where "union wait" is defined in both the BSD and SYS-V # environments. Checking the usability of WIFEXITED seems to do # the trick. #-------------------------------------------------------------------- -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking union wait" >&5 -$as_echo_n "checking union wait... " >&6; } -if ${tcl_cv_union_wait+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking union wait" >&5 +echo $ECHO_N "checking union wait... $ECHO_C" >&6 +if test "${tcl_cv_union_wait+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () @@ -9087,132 +15864,305 @@ ; return 0; } _ACEOF -if ac_fn_c_try_link "$LINENO"; then : +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_union_wait=yes else - tcl_cv_union_wait=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_union_wait=no fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_union_wait" >&5 -$as_echo "$tcl_cv_union_wait" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_union_wait" >&5 +echo "${ECHO_T}$tcl_cv_union_wait" >&6 if test $tcl_cv_union_wait = no; then -$as_echo "#define NO_UNION_WAIT 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define NO_UNION_WAIT 1 +_ACEOF fi #-------------------------------------------------------------------- # Check whether there is an strncasecmp function on this system. # This is a bit tricky because under SCO it's in -lsocket and # under Sequent Dynix it's in -linet. #-------------------------------------------------------------------- -ac_fn_c_check_func "$LINENO" "strncasecmp" "ac_cv_func_strncasecmp" -if test "x$ac_cv_func_strncasecmp" = xyes; then : +echo "$as_me:$LINENO: checking for strncasecmp" >&5 +echo $ECHO_N "checking for strncasecmp... $ECHO_C" >&6 +if test "${ac_cv_func_strncasecmp+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define strncasecmp to an innocuous variant, in case declares strncasecmp. + For example, HP-UX 11i declares gettimeofday. */ +#define strncasecmp innocuous_strncasecmp + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char strncasecmp (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef strncasecmp + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char strncasecmp (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_strncasecmp) || defined (__stub___strncasecmp) +choke me +#else +char (*f) () = strncasecmp; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != strncasecmp; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_func_strncasecmp=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_func_strncasecmp=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_func_strncasecmp" >&5 +echo "${ECHO_T}$ac_cv_func_strncasecmp" >&6 +if test $ac_cv_func_strncasecmp = yes; then tcl_ok=1 else tcl_ok=0 fi if test "$tcl_ok" = 0; then - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for strncasecmp in -lsocket" >&5 -$as_echo_n "checking for strncasecmp in -lsocket... " >&6; } -if ${ac_cv_lib_socket_strncasecmp+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking for strncasecmp in -lsocket" >&5 +echo $ECHO_N "checking for strncasecmp in -lsocket... $ECHO_C" >&6 +if test "${ac_cv_lib_socket_strncasecmp+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lsocket $LIBS" -cat confdefs.h - <<_ACEOF >conftest.$ac_ext +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ +/* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ char strncasecmp (); int main () { -return strncasecmp (); +strncasecmp (); ; return 0; } _ACEOF -if ac_fn_c_try_link "$LINENO"; then : +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then ac_cv_lib_socket_strncasecmp=yes else - ac_cv_lib_socket_strncasecmp=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_lib_socket_strncasecmp=no fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_socket_strncasecmp" >&5 -$as_echo "$ac_cv_lib_socket_strncasecmp" >&6; } -if test "x$ac_cv_lib_socket_strncasecmp" = xyes; then : +echo "$as_me:$LINENO: result: $ac_cv_lib_socket_strncasecmp" >&5 +echo "${ECHO_T}$ac_cv_lib_socket_strncasecmp" >&6 +if test $ac_cv_lib_socket_strncasecmp = yes; then tcl_ok=1 else tcl_ok=0 fi fi if test "$tcl_ok" = 0; then - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for strncasecmp in -linet" >&5 -$as_echo_n "checking for strncasecmp in -linet... " >&6; } -if ${ac_cv_lib_inet_strncasecmp+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking for strncasecmp in -linet" >&5 +echo $ECHO_N "checking for strncasecmp in -linet... $ECHO_C" >&6 +if test "${ac_cv_lib_inet_strncasecmp+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-linet $LIBS" -cat confdefs.h - <<_ACEOF >conftest.$ac_ext +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ +/* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ char strncasecmp (); int main () { -return strncasecmp (); +strncasecmp (); ; return 0; } _ACEOF -if ac_fn_c_try_link "$LINENO"; then : +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then ac_cv_lib_inet_strncasecmp=yes else - ac_cv_lib_inet_strncasecmp=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_lib_inet_strncasecmp=no fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_inet_strncasecmp" >&5 -$as_echo "$ac_cv_lib_inet_strncasecmp" >&6; } -if test "x$ac_cv_lib_inet_strncasecmp" = xyes; then : +echo "$as_me:$LINENO: result: $ac_cv_lib_inet_strncasecmp" >&5 +echo "${ECHO_T}$ac_cv_lib_inet_strncasecmp" >&6 +if test $ac_cv_lib_inet_strncasecmp = yes; then tcl_ok=1 else tcl_ok=0 fi fi if test "$tcl_ok" = 0; then - case " $LIBOBJS " in + case $LIBOBJS in + "strncasecmp.$ac_objext" | \ + *" strncasecmp.$ac_objext" | \ + "strncasecmp.$ac_objext "* | \ *" strncasecmp.$ac_objext "* ) ;; - *) LIBOBJS="$LIBOBJS strncasecmp.$ac_objext" - ;; + *) LIBOBJS="$LIBOBJS strncasecmp.$ac_objext" ;; esac USE_COMPAT=1 fi @@ -9223,95 +16173,226 @@ # 2. See if gettimeofday is declared in the header file. # if not, set the GETTOD_NOT_DECLARED flag so that tclPort.h can # declare it. #-------------------------------------------------------------------- -ac_fn_c_check_func "$LINENO" "gettimeofday" "ac_cv_func_gettimeofday" -if test "x$ac_cv_func_gettimeofday" = xyes; then : +echo "$as_me:$LINENO: checking for gettimeofday" >&5 +echo $ECHO_N "checking for gettimeofday... $ECHO_C" >&6 +if test "${ac_cv_func_gettimeofday+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define gettimeofday to an innocuous variant, in case declares gettimeofday. + For example, HP-UX 11i declares gettimeofday. */ +#define gettimeofday innocuous_gettimeofday +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char gettimeofday (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef gettimeofday + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char gettimeofday (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_gettimeofday) || defined (__stub___gettimeofday) +choke me +#else +char (*f) () = gettimeofday; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != gettimeofday; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_func_gettimeofday=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_func_gettimeofday=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_func_gettimeofday" >&5 +echo "${ECHO_T}$ac_cv_func_gettimeofday" >&6 +if test $ac_cv_func_gettimeofday = yes; then + : else -$as_echo "#define NO_GETTOD 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define NO_GETTOD 1 +_ACEOF fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for gettimeofday declaration" >&5 -$as_echo_n "checking for gettimeofday declaration... " >&6; } -if ${tcl_cv_grep_gettimeofday+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for gettimeofday declaration" >&5 +echo $ECHO_N "checking for gettimeofday declaration... $ECHO_C" >&6 +if test "${tcl_cv_grep_gettimeofday+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - $EGREP "gettimeofday" >/dev/null 2>&1; then : + $EGREP "gettimeofday" >/dev/null 2>&1; then tcl_cv_grep_gettimeofday=present else tcl_cv_grep_gettimeofday=missing fi rm -f conftest* fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_grep_gettimeofday" >&5 -$as_echo "$tcl_cv_grep_gettimeofday" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_grep_gettimeofday" >&5 +echo "${ECHO_T}$tcl_cv_grep_gettimeofday" >&6 if test $tcl_cv_grep_gettimeofday = missing ; then -$as_echo "#define GETTOD_NOT_DECLARED 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define GETTOD_NOT_DECLARED 1 +_ACEOF fi #-------------------------------------------------------------------- # The following code checks to see whether it is possible to get # signed chars on this platform. This is needed in order to # properly generate sign-extended ints from character values. #-------------------------------------------------------------------- -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether char is unsigned" >&5 -$as_echo_n "checking whether char is unsigned... " >&6; } -if ${ac_cv_c_char_unsigned+:} false; then : - $as_echo_n "(cached) " >&6 + +echo "$as_me:$LINENO: checking whether char is unsigned" >&5 +echo $ECHO_N "checking whether char is unsigned... $ECHO_C" >&6 +if test "${ac_cv_c_char_unsigned+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { static int test_array [1 - 2 * !(((char) -1) < 0)]; -test_array [0] = 0; -return test_array [0]; +test_array [0] = 0 ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then ac_cv_c_char_unsigned=no else - ac_cv_c_char_unsigned=yes + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_c_char_unsigned=yes fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_char_unsigned" >&5 -$as_echo "$ac_cv_c_char_unsigned" >&6; } +echo "$as_me:$LINENO: result: $ac_cv_c_char_unsigned" >&5 +echo "${ECHO_T}$ac_cv_c_char_unsigned" >&6 if test $ac_cv_c_char_unsigned = yes && test "$GCC" != yes; then - $as_echo "#define __CHAR_UNSIGNED__ 1" >>confdefs.h + cat >>confdefs.h <<\_ACEOF +#define __CHAR_UNSIGNED__ 1 +_ACEOF fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking signed char declarations" >&5 -$as_echo_n "checking signed char declarations... " >&6; } -if ${tcl_cv_char_signed+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking signed char declarations" >&5 +echo $ECHO_N "checking signed char declarations... $ECHO_C" >&6 +if test "${tcl_cv_char_signed+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { @@ -9321,42 +16402,73 @@ ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_char_signed=yes else - tcl_cv_char_signed=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_char_signed=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_char_signed" >&5 -$as_echo "$tcl_cv_char_signed" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_char_signed" >&5 +echo "${ECHO_T}$tcl_cv_char_signed" >&6 if test $tcl_cv_char_signed = yes; then -$as_echo "#define HAVE_SIGNED_CHAR 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_SIGNED_CHAR 1 +_ACEOF fi #-------------------------------------------------------------------- # Does putenv() copy or not? We need to know to avoid memory leaks. #-------------------------------------------------------------------- -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for a putenv() that copies the buffer" >&5 -$as_echo_n "checking for a putenv() that copies the buffer... " >&6; } -if ${tcl_cv_putenv_copy+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for a putenv() that copies the buffer" >&5 +echo $ECHO_N "checking for a putenv() that copies the buffer... $ECHO_C" >&6 +if test "${tcl_cv_putenv_copy+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - if test "$cross_compiling" = yes; then : + if test "$cross_compiling" = yes; then tcl_cv_putenv_copy=no else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include + #include #define OURVAR "havecopy=yes" int main (int argc, char *argv[]) { char *foo, *bar; foo = (char *)strdup(OURVAR); @@ -9371,60 +16483,215 @@ return 1; } } _ACEOF -if ac_fn_c_try_run "$LINENO"; then : +rm -f conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { ac_try='./conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_putenv_copy=no else - tcl_cv_putenv_copy=yes -fi -rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ - conftest.$ac_objext conftest.beam conftest.$ac_ext -fi - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_putenv_copy" >&5 -$as_echo "$tcl_cv_putenv_copy" >&6; } + echo "$as_me: program exited with status $ac_status" >&5 +echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +( exit $ac_status ) +tcl_cv_putenv_copy=yes +fi +rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext +fi +fi +echo "$as_me:$LINENO: result: $tcl_cv_putenv_copy" >&5 +echo "${ECHO_T}$tcl_cv_putenv_copy" >&6 if test $tcl_cv_putenv_copy = yes; then -$as_echo "#define HAVE_PUTENV_THAT_COPIES 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_PUTENV_THAT_COPIES 1 +_ACEOF fi #-------------------------------------------------------------------- # Check for support of nl_langinfo function #-------------------------------------------------------------------- - # Check whether --enable-langinfo was given. -if test "${enable_langinfo+set}" = set; then : - enableval=$enable_langinfo; langinfo_ok=$enableval + # Check whether --enable-langinfo or --disable-langinfo was given. +if test "${enable_langinfo+set}" = set; then + enableval="$enable_langinfo" + langinfo_ok=$enableval else langinfo_ok=yes -fi - +fi; HAVE_LANGINFO=0 if test "$langinfo_ok" = "yes"; then - ac_fn_c_check_header_mongrel "$LINENO" "langinfo.h" "ac_cv_header_langinfo_h" "$ac_includes_default" -if test "x$ac_cv_header_langinfo_h" = xyes; then : + if test "${ac_cv_header_langinfo_h+set}" = set; then + echo "$as_me:$LINENO: checking for langinfo.h" >&5 +echo $ECHO_N "checking for langinfo.h... $ECHO_C" >&6 +if test "${ac_cv_header_langinfo_h+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +fi +echo "$as_me:$LINENO: result: $ac_cv_header_langinfo_h" >&5 +echo "${ECHO_T}$ac_cv_header_langinfo_h" >&6 +else + # Is the header compilable? +echo "$as_me:$LINENO: checking langinfo.h usability" >&5 +echo $ECHO_N "checking langinfo.h usability... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +#include +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_header_compiler=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_header_compiler=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 +echo "${ECHO_T}$ac_header_compiler" >&6 + +# Is the header present? +echo "$as_me:$LINENO: checking langinfo.h presence" >&5 +echo $ECHO_N "checking langinfo.h presence... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include +_ACEOF +if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 + (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null; then + if test -s conftest.err; then + ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag + else + ac_cpp_err= + fi +else + ac_cpp_err=yes +fi +if test -z "$ac_cpp_err"; then + ac_header_preproc=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_header_preproc=no +fi +rm -f conftest.err conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 +echo "${ECHO_T}$ac_header_preproc" >&6 + +# So? What about this header? +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) + { echo "$as_me:$LINENO: WARNING: langinfo.h: accepted by the compiler, rejected by the preprocessor!" >&5 +echo "$as_me: WARNING: langinfo.h: accepted by the compiler, rejected by the preprocessor!" >&2;} + { echo "$as_me:$LINENO: WARNING: langinfo.h: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: langinfo.h: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes + ;; + no:yes:* ) + { echo "$as_me:$LINENO: WARNING: langinfo.h: present but cannot be compiled" >&5 +echo "$as_me: WARNING: langinfo.h: present but cannot be compiled" >&2;} + { echo "$as_me:$LINENO: WARNING: langinfo.h: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: langinfo.h: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: langinfo.h: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: langinfo.h: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: langinfo.h: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: langinfo.h: section \"Present But Cannot Be Compiled\"" >&2;} + { echo "$as_me:$LINENO: WARNING: langinfo.h: proceeding with the preprocessor's result" >&5 +echo "$as_me: WARNING: langinfo.h: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: langinfo.h: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: langinfo.h: in the future, the compiler will take precedence" >&2;} + ( + cat <<\_ASBOX +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## +_ASBOX + ) | + sed "s/^/$as_me: WARNING: /" >&2 + ;; +esac +echo "$as_me:$LINENO: checking for langinfo.h" >&5 +echo $ECHO_N "checking for langinfo.h... $ECHO_C" >&6 +if test "${ac_cv_header_langinfo_h+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_cv_header_langinfo_h=$ac_header_preproc +fi +echo "$as_me:$LINENO: result: $ac_cv_header_langinfo_h" >&5 +echo "${ECHO_T}$ac_cv_header_langinfo_h" >&6 + +fi +if test $ac_cv_header_langinfo_h = yes; then langinfo_ok=yes else langinfo_ok=no fi fi - { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to use nl_langinfo" >&5 -$as_echo_n "checking whether to use nl_langinfo... " >&6; } + echo "$as_me:$LINENO: checking whether to use nl_langinfo" >&5 +echo $ECHO_N "checking whether to use nl_langinfo... $ECHO_C" >&6 if test "$langinfo_ok" = "yes"; then - if ${tcl_cv_langinfo_h+:} false; then : - $as_echo_n "(cached) " >&6 + if test "${tcl_cv_langinfo_h+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { @@ -9431,42 +16698,159 @@ nl_langinfo(CODESET); ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_langinfo_h=yes else - tcl_cv_langinfo_h=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_langinfo_h=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_langinfo_h" >&5 -$as_echo "$tcl_cv_langinfo_h" >&6; } + echo "$as_me:$LINENO: result: $tcl_cv_langinfo_h" >&5 +echo "${ECHO_T}$tcl_cv_langinfo_h" >&6 if test $tcl_cv_langinfo_h = yes; then -$as_echo "#define HAVE_LANGINFO 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_LANGINFO 1 +_ACEOF fi else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $langinfo_ok" >&5 -$as_echo "$langinfo_ok" >&6; } + echo "$as_me:$LINENO: result: $langinfo_ok" >&5 +echo "${ECHO_T}$langinfo_ok" >&6 fi #-------------------------------------------------------------------- -# Check for support of cfmakeraw, chflags and mkstemps functions +# Check for support of chflags and mkstemps functions #-------------------------------------------------------------------- -for ac_func in cfmakeraw chflags mkstemps -do : - as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` -ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var" -if eval test \"x\$"$as_ac_var"\" = x"yes"; then : + + +for ac_func in chflags mkstemps +do +as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` +echo "$as_me:$LINENO: checking for $ac_func" >&5 +echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 +if eval "test \"\${$as_ac_var+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define $ac_func to an innocuous variant, in case declares $ac_func. + For example, HP-UX 11i declares gettimeofday. */ +#define $ac_func innocuous_$ac_func + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char $ac_func (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef $ac_func + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char $ac_func (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_$ac_func) || defined (__stub___$ac_func) +choke me +#else +char (*f) () = $ac_func; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != $ac_func; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + eval "$as_ac_var=yes" +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +eval "$as_ac_var=no" +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 +if test `eval echo '${'$as_ac_var'}'` = yes; then cat >>confdefs.h <<_ACEOF -#define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 +#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done @@ -9473,17 +16857,21 @@ #-------------------------------------------------------------------- # Check for support of isnan() function or macro #-------------------------------------------------------------------- -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking isnan" >&5 -$as_echo_n "checking isnan... " >&6; } -if ${tcl_cv_isnan+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking isnan" >&5 +echo $ECHO_N "checking isnan... $ECHO_C" >&6 +if test "${tcl_cv_isnan+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { @@ -9492,123 +16880,848 @@ ; return 0; } _ACEOF -if ac_fn_c_try_link "$LINENO"; then : +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_isnan=yes else - tcl_cv_isnan=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_isnan=no fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_isnan" >&5 -$as_echo "$tcl_cv_isnan" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_isnan" >&5 +echo "${ECHO_T}$tcl_cv_isnan" >&6 if test $tcl_cv_isnan = no; then -$as_echo "#define NO_ISNAN 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define NO_ISNAN 1 +_ACEOF fi #-------------------------------------------------------------------- # Darwin specific API checks and defines #-------------------------------------------------------------------- if test "`uname -s`" = "Darwin" ; then - for ac_func in getattrlist -do : - ac_fn_c_check_func "$LINENO" "getattrlist" "ac_cv_func_getattrlist" -if test "x$ac_cv_func_getattrlist" = xyes; then : - cat >>confdefs.h <<_ACEOF -#define HAVE_GETATTRLIST 1 -_ACEOF - -fi -done - - for ac_header in copyfile.h -do : - ac_fn_c_check_header_mongrel "$LINENO" "copyfile.h" "ac_cv_header_copyfile_h" "$ac_includes_default" -if test "x$ac_cv_header_copyfile_h" = xyes; then : - cat >>confdefs.h <<_ACEOF -#define HAVE_COPYFILE_H 1 -_ACEOF - -fi - -done - - for ac_func in copyfile -do : - ac_fn_c_check_func "$LINENO" "copyfile" "ac_cv_func_copyfile" -if test "x$ac_cv_func_copyfile" = xyes; then : - cat >>confdefs.h <<_ACEOF -#define HAVE_COPYFILE 1 + +for ac_func in getattrlist +do +as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` +echo "$as_me:$LINENO: checking for $ac_func" >&5 +echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 +if eval "test \"\${$as_ac_var+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define $ac_func to an innocuous variant, in case declares $ac_func. + For example, HP-UX 11i declares gettimeofday. */ +#define $ac_func innocuous_$ac_func + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char $ac_func (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef $ac_func + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char $ac_func (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_$ac_func) || defined (__stub___$ac_func) +choke me +#else +char (*f) () = $ac_func; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != $ac_func; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + eval "$as_ac_var=yes" +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +eval "$as_ac_var=no" +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 +if test `eval echo '${'$as_ac_var'}'` = yes; then + cat >>confdefs.h <<_ACEOF +#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 +_ACEOF + +fi +done + + +for ac_header in copyfile.h +do +as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo "$as_me:$LINENO: checking for $ac_header" >&5 +echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 +else + # Is the header compilable? +echo "$as_me:$LINENO: checking $ac_header usability" >&5 +echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +#include <$ac_header> +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_header_compiler=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_header_compiler=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 +echo "${ECHO_T}$ac_header_compiler" >&6 + +# Is the header present? +echo "$as_me:$LINENO: checking $ac_header presence" >&5 +echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include <$ac_header> +_ACEOF +if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 + (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null; then + if test -s conftest.err; then + ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag + else + ac_cpp_err= + fi +else + ac_cpp_err=yes +fi +if test -z "$ac_cpp_err"; then + ac_header_preproc=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_header_preproc=no +fi +rm -f conftest.err conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 +echo "${ECHO_T}$ac_header_preproc" >&6 + +# So? What about this header? +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) + { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 +echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes + ;; + no:yes:* ) + { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 +echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 +echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} + ( + cat <<\_ASBOX +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## +_ASBOX + ) | + sed "s/^/$as_me: WARNING: /" >&2 + ;; +esac +echo "$as_me:$LINENO: checking for $ac_header" >&5 +echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + eval "$as_ac_Header=\$ac_header_preproc" +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 + +fi +if test `eval echo '${'$as_ac_Header'}'` = yes; then + cat >>confdefs.h <<_ACEOF +#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1 +_ACEOF + +fi + +done + + +for ac_func in copyfile +do +as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` +echo "$as_me:$LINENO: checking for $ac_func" >&5 +echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 +if eval "test \"\${$as_ac_var+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define $ac_func to an innocuous variant, in case declares $ac_func. + For example, HP-UX 11i declares gettimeofday. */ +#define $ac_func innocuous_$ac_func + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char $ac_func (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef $ac_func + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char $ac_func (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_$ac_func) || defined (__stub___$ac_func) +choke me +#else +char (*f) () = $ac_func; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != $ac_func; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + eval "$as_ac_var=yes" +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +eval "$as_ac_var=no" +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 +if test `eval echo '${'$as_ac_var'}'` = yes; then + cat >>confdefs.h <<_ACEOF +#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done if test $tcl_corefoundation = yes; then - for ac_header in libkern/OSAtomic.h -do : - ac_fn_c_check_header_mongrel "$LINENO" "libkern/OSAtomic.h" "ac_cv_header_libkern_OSAtomic_h" "$ac_includes_default" -if test "x$ac_cv_header_libkern_OSAtomic_h" = xyes; then : - cat >>confdefs.h <<_ACEOF -#define HAVE_LIBKERN_OSATOMIC_H 1 -_ACEOF - -fi - -done - - for ac_func in OSSpinLockLock -do : - ac_fn_c_check_func "$LINENO" "OSSpinLockLock" "ac_cv_func_OSSpinLockLock" -if test "x$ac_cv_func_OSSpinLockLock" = xyes; then : - cat >>confdefs.h <<_ACEOF -#define HAVE_OSSPINLOCKLOCK 1 -_ACEOF - -fi -done - - fi - -$as_echo "#define USE_VFORK 1" >>confdefs.h - - -$as_echo "#define TCL_DEFAULT_ENCODING \"utf-8\"" >>confdefs.h - - -$as_echo "#define TCL_LOAD_FROM_MEMORY 1" >>confdefs.h - - -$as_echo "#define TCL_WIDE_CLICKS 1" >>confdefs.h - - for ac_header in AvailabilityMacros.h -do : - ac_fn_c_check_header_mongrel "$LINENO" "AvailabilityMacros.h" "ac_cv_header_AvailabilityMacros_h" "$ac_includes_default" -if test "x$ac_cv_header_AvailabilityMacros_h" = xyes; then : - cat >>confdefs.h <<_ACEOF -#define HAVE_AVAILABILITYMACROS_H 1 + +for ac_header in libkern/OSAtomic.h +do +as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo "$as_me:$LINENO: checking for $ac_header" >&5 +echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 +else + # Is the header compilable? +echo "$as_me:$LINENO: checking $ac_header usability" >&5 +echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +#include <$ac_header> +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_header_compiler=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_header_compiler=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 +echo "${ECHO_T}$ac_header_compiler" >&6 + +# Is the header present? +echo "$as_me:$LINENO: checking $ac_header presence" >&5 +echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include <$ac_header> +_ACEOF +if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 + (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null; then + if test -s conftest.err; then + ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag + else + ac_cpp_err= + fi +else + ac_cpp_err=yes +fi +if test -z "$ac_cpp_err"; then + ac_header_preproc=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_header_preproc=no +fi +rm -f conftest.err conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 +echo "${ECHO_T}$ac_header_preproc" >&6 + +# So? What about this header? +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) + { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 +echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes + ;; + no:yes:* ) + { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 +echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 +echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} + ( + cat <<\_ASBOX +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## +_ASBOX + ) | + sed "s/^/$as_me: WARNING: /" >&2 + ;; +esac +echo "$as_me:$LINENO: checking for $ac_header" >&5 +echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + eval "$as_ac_Header=\$ac_header_preproc" +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 + +fi +if test `eval echo '${'$as_ac_Header'}'` = yes; then + cat >>confdefs.h <<_ACEOF +#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1 +_ACEOF + +fi + +done + + +for ac_func in OSSpinLockLock +do +as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` +echo "$as_me:$LINENO: checking for $ac_func" >&5 +echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 +if eval "test \"\${$as_ac_var+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define $ac_func to an innocuous variant, in case declares $ac_func. + For example, HP-UX 11i declares gettimeofday. */ +#define $ac_func innocuous_$ac_func + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char $ac_func (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef $ac_func + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char $ac_func (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_$ac_func) || defined (__stub___$ac_func) +choke me +#else +char (*f) () = $ac_func; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != $ac_func; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + eval "$as_ac_var=yes" +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +eval "$as_ac_var=no" +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 +if test `eval echo '${'$as_ac_var'}'` = yes; then + cat >>confdefs.h <<_ACEOF +#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 +_ACEOF + +fi +done + + fi + +cat >>confdefs.h <<\_ACEOF +#define USE_VFORK 1 +_ACEOF + + +cat >>confdefs.h <<\_ACEOF +#define TCL_DEFAULT_ENCODING "utf-8" +_ACEOF + + +cat >>confdefs.h <<\_ACEOF +#define TCL_LOAD_FROM_MEMORY 1 +_ACEOF + + +cat >>confdefs.h <<\_ACEOF +#define TCL_WIDE_CLICKS 1 +_ACEOF + + +for ac_header in AvailabilityMacros.h +do +as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo "$as_me:$LINENO: checking for $ac_header" >&5 +echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 +else + # Is the header compilable? +echo "$as_me:$LINENO: checking $ac_header usability" >&5 +echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +#include <$ac_header> +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_header_compiler=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_header_compiler=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 +echo "${ECHO_T}$ac_header_compiler" >&6 + +# Is the header present? +echo "$as_me:$LINENO: checking $ac_header presence" >&5 +echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include <$ac_header> +_ACEOF +if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 + (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null; then + if test -s conftest.err; then + ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag + else + ac_cpp_err= + fi +else + ac_cpp_err=yes +fi +if test -z "$ac_cpp_err"; then + ac_header_preproc=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_header_preproc=no +fi +rm -f conftest.err conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 +echo "${ECHO_T}$ac_header_preproc" >&6 + +# So? What about this header? +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) + { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 +echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes + ;; + no:yes:* ) + { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 +echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 +echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} + ( + cat <<\_ASBOX +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## +_ASBOX + ) | + sed "s/^/$as_me: WARNING: /" >&2 + ;; +esac +echo "$as_me:$LINENO: checking for $ac_header" >&5 +echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + eval "$as_ac_Header=\$ac_header_preproc" +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 + +fi +if test `eval echo '${'$as_ac_Header'}'` = yes; then + cat >>confdefs.h <<_ACEOF +#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done if test "$ac_cv_header_AvailabilityMacros_h" = yes; then - { $as_echo "$as_me:${as_lineno-$LINENO}: checking if weak import is available" >&5 -$as_echo_n "checking if weak import is available... " >&6; } -if ${tcl_cv_cc_weak_import+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking if weak import is available" >&5 +echo $ECHO_N "checking if weak import is available... $ECHO_C" >&6 +if test "${tcl_cv_cc_weak_import+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #ifdef __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ #if __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ < 1020 #error __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ < 1020 @@ -9624,34 +17737,64 @@ rand(); ; return 0; } _ACEOF -if ac_fn_c_try_link "$LINENO"; then : +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_cc_weak_import=yes else - tcl_cv_cc_weak_import=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_cc_weak_import=no fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext CFLAGS=$hold_cflags fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_weak_import" >&5 -$as_echo "$tcl_cv_cc_weak_import" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_cc_weak_import" >&5 +echo "${ECHO_T}$tcl_cv_cc_weak_import" >&6 if test $tcl_cv_cc_weak_import = yes; then -$as_echo "#define HAVE_WEAK_IMPORT 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_WEAK_IMPORT 1 +_ACEOF fi - { $as_echo "$as_me:${as_lineno-$LINENO}: checking if Darwin SUSv3 extensions are available" >&5 -$as_echo_n "checking if Darwin SUSv3 extensions are available... " >&6; } -if ${tcl_cv_cc_darwin_c_source+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking if Darwin SUSv3 extensions are available" >&5 +echo $ECHO_N "checking if Darwin SUSv3 extensions are available... $ECHO_C" >&6 +if test "${tcl_cv_cc_darwin_c_source+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #ifdef __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ #if __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ < 1050 #error __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ < 1050 @@ -9668,23 +17811,49 @@ ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_cc_darwin_c_source=yes else - tcl_cv_cc_darwin_c_source=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_cc_darwin_c_source=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext CFLAGS=$hold_cflags fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_darwin_c_source" >&5 -$as_echo "$tcl_cv_cc_darwin_c_source" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_cc_darwin_c_source" >&5 +echo "${ECHO_T}$tcl_cv_cc_darwin_c_source" >&6 if test $tcl_cv_cc_darwin_c_source = yes; then -$as_echo "#define _DARWIN_C_SOURCE 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define _DARWIN_C_SOURCE 1 +_ACEOF fi fi # Build .bundle dltest binaries in addition to .dylib DLTEST_LD='${CC} -bundle -Wl,-w ${CFLAGS} ${LDFLAGS}' @@ -9696,17 +17865,21 @@ #-------------------------------------------------------------------- # Check for support of fts functions (readdir replacement) #-------------------------------------------------------------------- -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for fts" >&5 -$as_echo_n "checking for fts... " >&6; } -if ${tcl_cv_api_fts+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for fts" >&5 +echo $ECHO_N "checking for fts... $ECHO_C" >&6 +if test "${tcl_cv_api_fts+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include @@ -9721,23 +17894,49 @@ ; return 0; } _ACEOF -if ac_fn_c_try_link "$LINENO"; then : +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_api_fts=yes else - tcl_cv_api_fts=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_api_fts=no fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_fts" >&5 -$as_echo "$tcl_cv_api_fts" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_api_fts" >&5 +echo "${ECHO_T}$tcl_cv_api_fts" >&6 if test $tcl_cv_api_fts = yes; then -$as_echo "#define HAVE_FTS 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_FTS 1 +_ACEOF fi #-------------------------------------------------------------------- # The statements below check for systems where POSIX-style non-blocking @@ -9744,128 +17943,426 @@ # I/O (O_NONBLOCK) doesn't work or is unimplemented. On these systems # (mostly older ones), use the old BSD-style FIONBIO approach instead. #-------------------------------------------------------------------- - for ac_header in sys/ioctl.h -do : - ac_fn_c_check_header_mongrel "$LINENO" "sys/ioctl.h" "ac_cv_header_sys_ioctl_h" "$ac_includes_default" -if test "x$ac_cv_header_sys_ioctl_h" = xyes; then : - cat >>confdefs.h <<_ACEOF -#define HAVE_SYS_IOCTL_H 1 -_ACEOF - -fi - -done - - for ac_header in sys/filio.h -do : - ac_fn_c_check_header_mongrel "$LINENO" "sys/filio.h" "ac_cv_header_sys_filio_h" "$ac_includes_default" -if test "x$ac_cv_header_sys_filio_h" = xyes; then : - cat >>confdefs.h <<_ACEOF -#define HAVE_SYS_FILIO_H 1 -_ACEOF - -fi - -done - - - { $as_echo "$as_me:${as_lineno-$LINENO}: checking system version" >&5 -$as_echo_n "checking system version... " >&6; } -if ${tcl_cv_sys_version+:} false; then : - $as_echo_n "(cached) " >&6 -else - - if test "${TEA_PLATFORM}" = "windows" ; then - tcl_cv_sys_version=windows - else - tcl_cv_sys_version=`uname -s`-`uname -r` - if test "$?" -ne 0 ; then - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: can't find uname command" >&5 -$as_echo "$as_me: WARNING: can't find uname command" >&2;} - tcl_cv_sys_version=unknown - else - if test "`uname -s`" = "AIX" ; then - tcl_cv_sys_version=AIX-`uname -v`.`uname -r` - fi - fi - fi - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_sys_version" >&5 -$as_echo "$tcl_cv_sys_version" >&6; } - system=$tcl_cv_sys_version - - { $as_echo "$as_me:${as_lineno-$LINENO}: checking FIONBIO vs. O_NONBLOCK for nonblocking I/O" >&5 -$as_echo_n "checking FIONBIO vs. O_NONBLOCK for nonblocking I/O... " >&6; } - case $system in - OSF*) - -$as_echo "#define USE_FIONBIO 1" >>confdefs.h - - { $as_echo "$as_me:${as_lineno-$LINENO}: result: FIONBIO" >&5 -$as_echo "FIONBIO" >&6; } - ;; - *) - { $as_echo "$as_me:${as_lineno-$LINENO}: result: O_NONBLOCK" >&5 -$as_echo "O_NONBLOCK" >&6; } + +for ac_header in sys/ioctl.h +do +as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo "$as_me:$LINENO: checking for $ac_header" >&5 +echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 +else + # Is the header compilable? +echo "$as_me:$LINENO: checking $ac_header usability" >&5 +echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +#include <$ac_header> +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_header_compiler=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_header_compiler=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 +echo "${ECHO_T}$ac_header_compiler" >&6 + +# Is the header present? +echo "$as_me:$LINENO: checking $ac_header presence" >&5 +echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include <$ac_header> +_ACEOF +if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 + (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null; then + if test -s conftest.err; then + ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag + else + ac_cpp_err= + fi +else + ac_cpp_err=yes +fi +if test -z "$ac_cpp_err"; then + ac_header_preproc=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_header_preproc=no +fi +rm -f conftest.err conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 +echo "${ECHO_T}$ac_header_preproc" >&6 + +# So? What about this header? +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) + { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 +echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes + ;; + no:yes:* ) + { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 +echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 +echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} + ( + cat <<\_ASBOX +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## +_ASBOX + ) | + sed "s/^/$as_me: WARNING: /" >&2 + ;; +esac +echo "$as_me:$LINENO: checking for $ac_header" >&5 +echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + eval "$as_ac_Header=\$ac_header_preproc" +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 + +fi +if test `eval echo '${'$as_ac_Header'}'` = yes; then + cat >>confdefs.h <<_ACEOF +#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1 +_ACEOF + +fi + +done + + +for ac_header in sys/filio.h +do +as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo "$as_me:$LINENO: checking for $ac_header" >&5 +echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 +else + # Is the header compilable? +echo "$as_me:$LINENO: checking $ac_header usability" >&5 +echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +#include <$ac_header> +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_header_compiler=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_header_compiler=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 +echo "${ECHO_T}$ac_header_compiler" >&6 + +# Is the header present? +echo "$as_me:$LINENO: checking $ac_header presence" >&5 +echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include <$ac_header> +_ACEOF +if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 + (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null; then + if test -s conftest.err; then + ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag + else + ac_cpp_err= + fi +else + ac_cpp_err=yes +fi +if test -z "$ac_cpp_err"; then + ac_header_preproc=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_header_preproc=no +fi +rm -f conftest.err conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 +echo "${ECHO_T}$ac_header_preproc" >&6 + +# So? What about this header? +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) + { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 +echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes + ;; + no:yes:* ) + { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 +echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 +echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} + ( + cat <<\_ASBOX +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## +_ASBOX + ) | + sed "s/^/$as_me: WARNING: /" >&2 + ;; +esac +echo "$as_me:$LINENO: checking for $ac_header" >&5 +echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + eval "$as_ac_Header=\$ac_header_preproc" +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 + +fi +if test `eval echo '${'$as_ac_Header'}'` = yes; then + cat >>confdefs.h <<_ACEOF +#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1 +_ACEOF + +fi + +done + + + echo "$as_me:$LINENO: checking system version" >&5 +echo $ECHO_N "checking system version... $ECHO_C" >&6 +if test "${tcl_cv_sys_version+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + + if test -f /usr/lib/NextStep/software_version; then + tcl_cv_sys_version=NEXTSTEP-`awk '/3/,/3/' /usr/lib/NextStep/software_version` + else + tcl_cv_sys_version=`uname -s`-`uname -r` + if test "$?" -ne 0 ; then + { echo "$as_me:$LINENO: WARNING: can't find uname command" >&5 +echo "$as_me: WARNING: can't find uname command" >&2;} + tcl_cv_sys_version=unknown + else + # Special check for weird MP-RAS system (uname returns weird + # results, and the version is kept in special file). + + if test -r /etc/.relid -a "X`uname -n`" = "X`uname -s`" ; then + tcl_cv_sys_version=MP-RAS-`awk '{print $3}' /etc/.relid` + fi + if test "`uname -s`" = "AIX" ; then + tcl_cv_sys_version=AIX-`uname -v`.`uname -r` + fi + if test "`uname -s`" = "NetBSD" -a -f /etc/debian_version ; then + tcl_cv_sys_version=NetBSD-Debian + fi + fi + fi + +fi +echo "$as_me:$LINENO: result: $tcl_cv_sys_version" >&5 +echo "${ECHO_T}$tcl_cv_sys_version" >&6 + system=$tcl_cv_sys_version + + echo "$as_me:$LINENO: checking FIONBIO vs. O_NONBLOCK for nonblocking I/O" >&5 +echo $ECHO_N "checking FIONBIO vs. O_NONBLOCK for nonblocking I/O... $ECHO_C" >&6 + case $system in + OSF*) + +cat >>confdefs.h <<\_ACEOF +#define USE_FIONBIO 1 +_ACEOF + + echo "$as_me:$LINENO: result: FIONBIO" >&5 +echo "${ECHO_T}FIONBIO" >&6 + ;; + SunOS-4*) + +cat >>confdefs.h <<\_ACEOF +#define USE_FIONBIO 1 +_ACEOF + + echo "$as_me:$LINENO: result: FIONBIO" >&5 +echo "${ECHO_T}FIONBIO" >&6 + ;; + *) + echo "$as_me:$LINENO: result: O_NONBLOCK" >&5 +echo "${ECHO_T}O_NONBLOCK" >&6 ;; esac #------------------------------------------------------------------------ -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to use dll unloading" >&5 -$as_echo_n "checking whether to use dll unloading... " >&6; } -# Check whether --enable-dll-unloading was given. -if test "${enable_dll_unloading+set}" = set; then : - enableval=$enable_dll_unloading; tcl_ok=$enableval +echo "$as_me:$LINENO: checking whether to use dll unloading" >&5 +echo $ECHO_N "checking whether to use dll unloading... $ECHO_C" >&6 +# Check whether --enable-dll-unloading or --disable-dll-unloading was given. +if test "${enable_dll_unloading+set}" = set; then + enableval="$enable_dll_unloading" + tcl_ok=$enableval else tcl_ok=yes -fi - +fi; if test $tcl_ok = yes; then -$as_echo "#define TCL_UNLOAD_DLLS 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define TCL_UNLOAD_DLLS 1 +_ACEOF fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_ok" >&5 -$as_echo "$tcl_ok" >&6; } +echo "$as_me:$LINENO: result: $tcl_ok" >&5 +echo "${ECHO_T}$tcl_ok" >&6 #------------------------------------------------------------------------ # Check whether the timezone data is supplied by the OS or has # to be installed by Tcl. The default is autodetection, but can -# be overriden on the configure command line either way. +# be overridden on the configure command line either way. #------------------------------------------------------------------------ -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for timezone data" >&5 -$as_echo_n "checking for timezone data... " >&6; } +echo "$as_me:$LINENO: checking for timezone data" >&5 +echo $ECHO_N "checking for timezone data... $ECHO_C" >&6 -# Check whether --with-tzdata was given. -if test "${with_tzdata+set}" = set; then : - withval=$with_tzdata; tcl_ok=$withval +# Check whether --with-tzdata or --without-tzdata was given. +if test "${with_tzdata+set}" = set; then + withval="$with_tzdata" + tcl_ok=$withval else tcl_ok=auto -fi - +fi; # # Any directories that get added here must also be added to the # search path in ::tcl::clock::Initialize (library/clock.tcl). # case $tcl_ok in no) - { $as_echo "$as_me:${as_lineno-$LINENO}: result: supplied by OS vendor" >&5 -$as_echo "supplied by OS vendor" >&6; } + echo "$as_me:$LINENO: result: supplied by OS vendor" >&5 +echo "${ECHO_T}supplied by OS vendor" >&6 ;; yes) # nothing to do here ;; auto*) - if ${tcl_cv_dir_zoneinfo+:} false; then : - $as_echo_n "(cached) " >&6 + if test "${tcl_cv_dir_zoneinfo+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else for dir in /usr/share/zoneinfo \ /usr/share/lib/zoneinfo \ /usr/lib/zoneinfo @@ -9878,41 +18375,179 @@ done fi if test -n "$tcl_cv_dir_zoneinfo"; then tcl_ok=no - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $dir" >&5 -$as_echo "$dir" >&6; } + echo "$as_me:$LINENO: result: $dir" >&5 +echo "${ECHO_T}$dir" >&6 else tcl_ok=yes fi ;; *) - as_fn_error $? "invalid argument: $tcl_ok" "$LINENO" 5 + { { echo "$as_me:$LINENO: error: invalid argument: $tcl_ok" >&5 +echo "$as_me: error: invalid argument: $tcl_ok" >&2;} + { (exit 1); exit 1; }; } ;; esac if test $tcl_ok = yes then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: supplied by Tcl" >&5 -$as_echo "supplied by Tcl" >&6; } + echo "$as_me:$LINENO: result: supplied by Tcl" >&5 +echo "${ECHO_T}supplied by Tcl" >&6 INSTALL_TZDATA=install-tzdata fi #-------------------------------------------------------------------- # DTrace support #-------------------------------------------------------------------- -# Check whether --enable-dtrace was given. -if test "${enable_dtrace+set}" = set; then : - enableval=$enable_dtrace; tcl_ok=$enableval +# Check whether --enable-dtrace or --disable-dtrace was given. +if test "${enable_dtrace+set}" = set; then + enableval="$enable_dtrace" + tcl_ok=$enableval else tcl_ok=no -fi - +fi; if test $tcl_ok = yes; then - ac_fn_c_check_header_mongrel "$LINENO" "sys/sdt.h" "ac_cv_header_sys_sdt_h" "$ac_includes_default" -if test "x$ac_cv_header_sys_sdt_h" = xyes; then : + if test "${ac_cv_header_sys_sdt_h+set}" = set; then + echo "$as_me:$LINENO: checking for sys/sdt.h" >&5 +echo $ECHO_N "checking for sys/sdt.h... $ECHO_C" >&6 +if test "${ac_cv_header_sys_sdt_h+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +fi +echo "$as_me:$LINENO: result: $ac_cv_header_sys_sdt_h" >&5 +echo "${ECHO_T}$ac_cv_header_sys_sdt_h" >&6 +else + # Is the header compilable? +echo "$as_me:$LINENO: checking sys/sdt.h usability" >&5 +echo $ECHO_N "checking sys/sdt.h usability... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +#include +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_header_compiler=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_header_compiler=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 +echo "${ECHO_T}$ac_header_compiler" >&6 + +# Is the header present? +echo "$as_me:$LINENO: checking sys/sdt.h presence" >&5 +echo $ECHO_N "checking sys/sdt.h presence... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include +_ACEOF +if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 + (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null; then + if test -s conftest.err; then + ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag + else + ac_cpp_err= + fi +else + ac_cpp_err=yes +fi +if test -z "$ac_cpp_err"; then + ac_header_preproc=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_header_preproc=no +fi +rm -f conftest.err conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 +echo "${ECHO_T}$ac_header_preproc" >&6 + +# So? What about this header? +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) + { echo "$as_me:$LINENO: WARNING: sys/sdt.h: accepted by the compiler, rejected by the preprocessor!" >&5 +echo "$as_me: WARNING: sys/sdt.h: accepted by the compiler, rejected by the preprocessor!" >&2;} + { echo "$as_me:$LINENO: WARNING: sys/sdt.h: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: sys/sdt.h: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes + ;; + no:yes:* ) + { echo "$as_me:$LINENO: WARNING: sys/sdt.h: present but cannot be compiled" >&5 +echo "$as_me: WARNING: sys/sdt.h: present but cannot be compiled" >&2;} + { echo "$as_me:$LINENO: WARNING: sys/sdt.h: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: sys/sdt.h: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: sys/sdt.h: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: sys/sdt.h: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: sys/sdt.h: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: sys/sdt.h: section \"Present But Cannot Be Compiled\"" >&2;} + { echo "$as_me:$LINENO: WARNING: sys/sdt.h: proceeding with the preprocessor's result" >&5 +echo "$as_me: WARNING: sys/sdt.h: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: sys/sdt.h: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: sys/sdt.h: in the future, the compiler will take precedence" >&2;} + ( + cat <<\_ASBOX +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## +_ASBOX + ) | + sed "s/^/$as_me: WARNING: /" >&2 + ;; +esac +echo "$as_me:$LINENO: checking for sys/sdt.h" >&5 +echo $ECHO_N "checking for sys/sdt.h... $ECHO_C" >&6 +if test "${ac_cv_header_sys_sdt_h+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_cv_header_sys_sdt_h=$ac_header_preproc +fi +echo "$as_me:$LINENO: result: $ac_cv_header_sys_sdt_h" >&5 +echo "${ECHO_T}$ac_cv_header_sys_sdt_h" >&6 + +fi +if test $ac_cv_header_sys_sdt_h = yes; then tcl_ok=yes else tcl_ok=no fi @@ -9919,14 +18554,14 @@ fi if test $tcl_ok = yes; then # Extract the first word of "dtrace", so it can be a program name with args. set dummy dtrace; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_path_DTRACE+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_path_DTRACE+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else case $DTRACE in [\\/]* | ?:[\\/]*) ac_cv_path_DTRACE="$DTRACE" # Let the user override the test with a path. ;; @@ -9935,41 +18570,42 @@ as_dummy="$PATH:/usr/sbin" for as_dir in $as_dummy do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_path_DTRACE="$as_dir/$ac_word$ac_exec_ext" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done - done -IFS=$as_save_IFS +done ;; esac fi DTRACE=$ac_cv_path_DTRACE + if test -n "$DTRACE"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $DTRACE" >&5 -$as_echo "$DTRACE" >&6; } + echo "$as_me:$LINENO: result: $DTRACE" >&5 +echo "${ECHO_T}$DTRACE" >&6 else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 fi - test -z "$ac_cv_path_DTRACE" && tcl_ok=no fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to enable DTrace support" >&5 -$as_echo_n "checking whether to enable DTrace support... " >&6; } +echo "$as_me:$LINENO: checking whether to enable DTrace support" >&5 +echo $ECHO_N "checking whether to enable DTrace support... $ECHO_C" >&6 MAKEFILE_SHELL='/bin/sh' if test $tcl_ok = yes; then -$as_echo "#define USE_DTRACE 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define USE_DTRACE 1 +_ACEOF DTRACE_SRC="\${DTRACE_SRC}" DTRACE_HDR="\${DTRACE_HDR}" if test "`uname -s`" != "Darwin" ; then DTRACE_OBJ="\${DTRACE_OBJ}" @@ -9983,189 +18619,28 @@ AR='/usr/ccs/bin/ar' RANLIB='/usr/ccs/bin/ranlib' fi fi fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_ok" >&5 -$as_echo "$tcl_ok" >&6; } - -#-------------------------------------------------------------------- -# Zipfs support - Tip 430 -#-------------------------------------------------------------------- -# Check whether --enable-zipfs was given. -if test "${enable_zipfs+set}" = set; then : - enableval=$enable_zipfs; tcl_ok=$enableval -else - tcl_ok=yes -fi - -if test "$tcl_ok" = "yes" ; then - # - # Find a native compiler - # - # Put a plausible default for CC_FOR_BUILD in Makefile. - if test -z "$CC_FOR_BUILD"; then - if test "x$cross_compiling" = "xno"; then - CC_FOR_BUILD='$(CC)' - else - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for gcc" >&5 -$as_echo_n "checking for gcc... " >&6; } - if ${ac_cv_path_cc+:} false; then : - $as_echo_n "(cached) " >&6 -else - - search_path=`echo ${PATH} | sed -e 's/:/ /g'` - for dir in $search_path ; do - for j in `ls -r $dir/gcc 2> /dev/null` \ - `ls -r $dir/gcc 2> /dev/null` ; do - if test x"$ac_cv_path_cc" = x ; then - if test -f "$j" ; then - ac_cv_path_cc=$j - break - fi - fi - done - done - -fi - - fi - fi - - # Also set EXEEXT_FOR_BUILD. - if test "x$cross_compiling" = "xno"; then - EXEEXT_FOR_BUILD='$(EXEEXT)' - OBJEXT_FOR_BUILD='$(OBJEXT)' - else - OBJEXT_FOR_BUILD='.no' - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for build system executable suffix" >&5 -$as_echo_n "checking for build system executable suffix... " >&6; } -if ${bfd_cv_build_exeext+:} false; then : - $as_echo_n "(cached) " >&6 -else - rm -f conftest* - echo 'int main () { return 0; }' > conftest.c - bfd_cv_build_exeext= - ${CC_FOR_BUILD} -o conftest conftest.c 1>&5 2>&5 - for file in conftest.*; do - case $file in - *.c | *.o | *.obj | *.ilk | *.pdb) ;; - *) bfd_cv_build_exeext=`echo $file | sed -e s/conftest//` ;; - esac - done - rm -f conftest* - test x"${bfd_cv_build_exeext}" = x && bfd_cv_build_exeext=no -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $bfd_cv_build_exeext" >&5 -$as_echo "$bfd_cv_build_exeext" >&6; } - EXEEXT_FOR_BUILD="" - test x"${bfd_cv_build_exeext}" != xno && EXEEXT_FOR_BUILD=${bfd_cv_build_exeext} - fi - - # - # Find a native zip implementation - # - - ZIP_PROG="" - ZIP_PROG_OPTIONS="" - ZIP_PROG_VFSSEARCH="" - ZIP_INSTALL_OBJS="" - - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for zip" >&5 -$as_echo_n "checking for zip... " >&6; } - if ${ac_cv_path_zip+:} false; then : - $as_echo_n "(cached) " >&6 -else - - search_path=`echo ${PATH} | sed -e 's/:/ /g'` - for dir in $search_path ; do - for j in `ls -r $dir/zip 2> /dev/null` \ - `ls -r $dir/zip 2> /dev/null` ; do - if test x"$ac_cv_path_zip" = x ; then - if test -f "$j" ; then - ac_cv_path_zip=$j - break - fi - fi - done - done - -fi - - if test -f "$ac_cv_path_zip" ; then - ZIP_PROG="$ac_cv_path_zip" - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ZIP_PROG" >&5 -$as_echo "$ZIP_PROG" >&6; } - ZIP_PROG_OPTIONS="-rq" - ZIP_PROG_VFSSEARCH="*" - { $as_echo "$as_me:${as_lineno-$LINENO}: result: Found INFO Zip in environment" >&5 -$as_echo "Found INFO Zip in environment" >&6; } - # Use standard arguments for zip - else - # It is not an error if an installed version of Zip can't be located. - # We can use the locally distributed minizip instead - ZIP_PROG="./minizip${EXEEXT_FOR_BUILD}" - ZIP_PROG_OPTIONS="-o -r" - ZIP_PROG_VFSSEARCH="*" - ZIP_INSTALL_OBJS="minizip${EXEEXT_FOR_BUILD}" - { $as_echo "$as_me:${as_lineno-$LINENO}: result: No zip found on PATH. Building minizip" >&5 -$as_echo "No zip found on PATH. Building minizip" >&6; } - fi - - - - - - ZIPFS_BUILD=1 - TCL_ZIP_FILE=libtcl_${TCL_MAJOR_VERSION}_${TCL_MINOR_VERSION}_${TCL_PATCH_LEVEL}.zip -else - ZIPFS_BUILD=0 - TCL_ZIP_FILE= -fi -# Do checking message here to not mess up interleaved configure output -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for building with zipfs" >&5 -$as_echo_n "checking for building with zipfs... " >&6; } -if test "${ZIPFS_BUILD}" = 1; then - if test "${SHARED_BUILD}" = 0; then - ZIPFS_BUILD=2; - -$as_echo "#define ZIPFS_BUILD 2" >>confdefs.h - - INSTALL_LIBRARIES=install-libraries-zipfs-static - { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -$as_echo "yes" >&6; } - else - -$as_echo "#define ZIPFS_BUILD 1" >>confdefs.h -\ - INSTALL_LIBRARIES=install-libraries-zipfs-shared - { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -$as_echo "yes" >&6; } - fi -else -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -INSTALL_LIBRARIES=install-libraries -INSTALL_MSGS=install-msgs -fi - - - - - +echo "$as_me:$LINENO: result: $tcl_ok" >&5 +echo "${ECHO_T}$tcl_ok" >&6 #-------------------------------------------------------------------- # The check below checks whether the cpuid instruction is usable. #-------------------------------------------------------------------- -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the cpuid instruction is usable" >&5 -$as_echo_n "checking whether the cpuid instruction is usable... " >&6; } -if ${tcl_cv_cpuid+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking whether the cpuid instruction is usable" >&5 +echo $ECHO_N "checking whether the cpuid instruction is usable... $ECHO_C" >&6 +if test "${tcl_cv_cpuid+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { @@ -10180,23 +18655,49 @@ ; return 0; } _ACEOF -if ac_fn_c_try_link "$LINENO"; then : +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_cpuid=yes else - tcl_cv_cpuid=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_cpuid=no fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cpuid" >&5 -$as_echo "$tcl_cv_cpuid" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_cpuid" >&5 +echo "${ECHO_T}$tcl_cv_cpuid" >&6 if test $tcl_cv_cpuid = yes; then -$as_echo "#define HAVE_CPUID 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_CPUID 1 +_ACEOF fi #-------------------------------------------------------------------- # The statements below define a collection of symbols related to @@ -10211,11 +18712,11 @@ # since on some platforms TCL_LIB_FILE contains shell escapes. # (See also: TCL_TRIM_DOTS). eval "TCL_LIB_FILE=${TCL_LIB_FILE}" -TCL_LIBRARY='$(prefix)/lib/tcl$(VERSION)' +test -z "$TCL_LIBRARY" && TCL_LIBRARY='$(prefix)/lib/tcl$(VERSION)' PRIVATE_INCLUDE_DIR='$(includedir)' HTML_DIR='$(DISTDIR)/html' # Note: in the following variable, it's important to use the absolute # path name of the Tcl directory rather than "..": this is because @@ -10223,65 +18724,67 @@ # up the Tcl library. if test "`uname -s`" = "Darwin" ; then if test "`uname -s`" = "Darwin" ; then - { $as_echo "$as_me:${as_lineno-$LINENO}: checking how to package libraries" >&5 -$as_echo_n "checking how to package libraries... " >&6; } - # Check whether --enable-framework was given. -if test "${enable_framework+set}" = set; then : - enableval=$enable_framework; enable_framework=$enableval -else - enable_framework=no -fi - - if test $enable_framework = yes; then - if test $SHARED_BUILD = 0; then - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Frameworks can only be built if --enable-shared is yes" >&5 -$as_echo "$as_me: WARNING: Frameworks can only be built if --enable-shared is yes" >&2;} - enable_framework=no - fi - if test $tcl_corefoundation = no; then - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Frameworks can only be used when CoreFoundation is available" >&5 -$as_echo "$as_me: WARNING: Frameworks can only be used when CoreFoundation is available" >&2;} - enable_framework=no - fi - fi - if test $enable_framework = yes; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: framework" >&5 -$as_echo "framework" >&6; } - FRAMEWORK_BUILD=1 - else - if test $SHARED_BUILD = 1; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: shared library" >&5 -$as_echo "shared library" >&6; } - else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: static library" >&5 -$as_echo "static library" >&6; } + echo "$as_me:$LINENO: checking how to package libraries" >&5 +echo $ECHO_N "checking how to package libraries... $ECHO_C" >&6 + # Check whether --enable-framework or --disable-framework was given. +if test "${enable_framework+set}" = set; then + enableval="$enable_framework" + enable_framework=$enableval +else + enable_framework=no +fi; + if test $enable_framework = yes; then + if test $SHARED_BUILD = 0; then + { echo "$as_me:$LINENO: WARNING: Frameworks can only be built if --enable-shared is yes" >&5 +echo "$as_me: WARNING: Frameworks can only be built if --enable-shared is yes" >&2;} + enable_framework=no + fi + if test $tcl_corefoundation = no; then + { echo "$as_me:$LINENO: WARNING: Frameworks can only be used when CoreFoundation is available" >&5 +echo "$as_me: WARNING: Frameworks can only be used when CoreFoundation is available" >&2;} + enable_framework=no + fi + fi + if test $enable_framework = yes; then + echo "$as_me:$LINENO: result: framework" >&5 +echo "${ECHO_T}framework" >&6 + FRAMEWORK_BUILD=1 + else + if test $SHARED_BUILD = 1; then + echo "$as_me:$LINENO: result: shared library" >&5 +echo "${ECHO_T}shared library" >&6 + else + echo "$as_me:$LINENO: result: static library" >&5 +echo "${ECHO_T}static library" >&6 fi FRAMEWORK_BUILD=0 fi fi TCL_SHLIB_LD_EXTRAS="-compatibility_version ${TCL_VERSION} -current_version ${TCL_VERSION}`echo ${TCL_PATCH_LEVEL} | awk '{match($0, "\\\.[0-9]+"); print substr($0,RSTART,RLENGTH)}'`" TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -install_name "${DYLIB_INSTALL_DIR}"/${TCL_LIB_FILE}' - echo "$LDFLAGS " | grep -q -- '-prebind ' && TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -seg1addr 0xa000000' + echo "$LDFLAGS " | grep -q -- '-prebind ' && TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -seg1addr 0xA000000' TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -sectcreate __TEXT __info_plist Tcl-Info.plist' EXTRA_TCLSH_LIBS='-sectcreate __TEXT __info_plist Tclsh-Info.plist' EXTRA_APP_CC_SWITCHES='-mdynamic-no-pic' - ac_config_files="$ac_config_files Tcl-Info.plist:../macosx/Tcl-Info.plist.in Tclsh-Info.plist:../macosx/Tclsh-Info.plist.in" + ac_config_files="$ac_config_files Tcl-Info.plist:../macosx/Tcl-Info.plist.in Tclsh-Info.plist:../macosx/Tclsh-Info.plist.in" TCL_YEAR="`date +%Y`" fi if test "$FRAMEWORK_BUILD" = "1" ; then -$as_echo "#define TCL_FRAMEWORK 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define TCL_FRAMEWORK 1 +_ACEOF # Construct a fake local framework structure to make linking with # '-framework Tcl' and running of tcltest work - ac_config_commands="$ac_config_commands Tcl.framework" + ac_config_commands="$ac_config_commands Tcl.framework" LD_LIBRARY_PATH_VAR="DYLD_FRAMEWORK_PATH" # default install directory for bundled packages if test "${libdir}" = '${exec_prefix}/lib' -o "`basename ${libdir}`" = 'Frameworks'; then PACKAGE_DIR="/Library/Tcl" @@ -10300,11 +18803,11 @@ TCL_LIBRARY="${libdir}/Resources/Scripts" includedir="${libdir}/Headers" PRIVATE_INCLUDE_DIR="${libdir}/PrivateHeaders" HTML_DIR="${libdir}/Resources/Documentation/Reference/Tcl" EXTRA_INSTALL="install-private-headers html-tcl" - EXTRA_BUILD_HTML='@ln -fs contents.htm "$(HTML_INSTALL_DIR)"/TclTOC.html' + EXTRA_BUILD_HTML='@ln -fs contents.htm "$(HTML_INSTALL_DIR)/TclTOC.html"' EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA_DIR) "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"' EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing license.terms to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA) "$(TOP_DIR)/license.terms" "$(LIB_INSTALL_DIR)/Resources"' EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Finalizing Tcl.framework" && rm -f "$(LIB_INSTALL_DIR)/../Current" && ln -s "$(VERSION)" "$(LIB_INSTALL_DIR)/../Current" && for f in "$(LIB_FILE)" tclConfig.sh Resources Headers PrivateHeaders; do rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/Current/$$f" "$(LIB_INSTALL_DIR)/../.."; done && f="$(STUB_LIB_FILE)" && rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/$(VERSION)/$$f" "$(LIB_INSTALL_DIR)/../.."' # Don't use AC_DEFINE for the following as the framework version define # needs to go into the Makefile even when using autoheader, so that we @@ -10336,17 +18839,17 @@ # another for platform-independent scripts. #-------------------------------------------------------------------- if test "$FRAMEWORK_BUILD" = "1" ; then test -z "$TCL_PACKAGE_PATH" && \ - TCL_PACKAGE_PATH="~/Library/Tcl /Library/Tcl /System/Library/Tcl ~/Library/Frameworks /Library/Frameworks /System/Library/Frameworks" + TCL_PACKAGE_PATH="~/Library/Tcl /Library/Tcl ~/Library/Frameworks /Library/Frameworks" test -z "$TCL_MODULE_PATH" && \ - TCL_MODULE_PATH="~/Library/Tcl /Library/Tcl /System/Library/Tcl" + TCL_MODULE_PATH="~/Library/Tcl /Library/Tcl" elif test "$prefix/lib" != "$libdir"; then - TCL_PACKAGE_PATH="${libdir} ${prefix}/lib ${TCL_PACKAGE_PATH}" + test -z "$TCL_PACKAGE_PATH" && TCL_PACKAGE_PATH="{${libdir}} {${prefix}/lib} ${TCL_PACKAGE_PATH}" else - TCL_PACKAGE_PATH="${prefix}/lib ${TCL_PACKAGE_PATH}" + test -z "$TCL_PACKAGE_PATH" && TCL_PACKAGE_PATH="{${prefix}/lib} ${TCL_PACKAGE_PATH}" fi #-------------------------------------------------------------------- # The statements below define various symbols relating to Tcl # stub support. @@ -10355,11 +18858,11 @@ # Replace ${VERSION} with contents of ${TCL_VERSION} # double-eval to account for TCL_TRIM_DOTS. # eval "TCL_STUB_LIB_FILE=libtclstub${TCL_UNSHARED_LIB_SUFFIX}" eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\"" -eval "TCL_STUB_LIB_DIR=${libdir}" +eval "TCL_STUB_LIB_DIR=\"${libdir}\"" if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then TCL_STUB_LIB_FLAG="-ltclstub${TCL_VERSION}" else TCL_STUB_LIB_FLAG="-ltclstub`echo ${TCL_VERSION} | tr -d .`" @@ -10437,12 +18940,11 @@ - -ac_config_files="$ac_config_files Makefile:../unix/Makefile.in dltest/Makefile:../unix/dltest/Makefile.in tclConfig.sh:../unix/tclConfig.sh.in tcl.pc:../unix/tcl.pc.in" + ac_config_files="$ac_config_files Makefile:../unix/Makefile.in dltest/Makefile:../unix/dltest/Makefile.in tclConfig.sh:../unix/tclConfig.sh.in tcl.pc:../unix/tcl.pc.in" cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure # scripts and configure runs, see configure's option --config-cache. @@ -10458,643 +18960,502 @@ _ACEOF # The following way of writing the cache mishandles newlines in values, # but we know of no workaround that is simple, portable, and efficient. -# So, we kill variables containing newlines. +# So, don't put newlines in cache variables' values. # Ultrix sh set writes to stderr and can't be redirected directly, # and sets the high bit in the cache file unless we assign to the vars. -( - for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do - eval ac_val=\$$ac_var - case $ac_val in #( - *${as_nl}*) - case $ac_var in #( - *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 -$as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; - esac - case $ac_var in #( - _ | IFS | as_nl) ;; #( - BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( - *) { eval $ac_var=; unset $ac_var;} ;; - esac ;; - esac - done - +{ (set) 2>&1 | - case $as_nl`(ac_space=' '; set) 2>&1` in #( - *${as_nl}ac_space=\ *) - # `set' does not quote correctly, so add quotes: double-quote - # substitution turns \\\\ into \\, and sed turns \\ into \. + case `(ac_space=' '; set | grep ac_space) 2>&1` in + *ac_space=\ *) + # `set' does not quote correctly, so add quotes (double-quote + # substitution turns \\\\ into \\, and sed turns \\ into \). sed -n \ "s/'/'\\\\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" - ;; #( + ;; *) # `set' quotes correctly as required by POSIX, so do not add quotes. - sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" + sed -n \ + "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p" ;; - esac | - sort -) | + esac; +} | sed ' - /^ac_cv_env_/b end t clear - :clear + : clear s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ t end - s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ - :end' >>confcache -if diff "$cache_file" confcache >/dev/null 2>&1; then :; else - if test -w "$cache_file"; then - if test "x$cache_file" != "x/dev/null"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 -$as_echo "$as_me: updating cache $cache_file" >&6;} - if test ! -f "$cache_file" || test -h "$cache_file"; then - cat confcache >"$cache_file" - else - case $cache_file in #( - */* | ?:*) - mv -f confcache "$cache_file"$$ && - mv -f "$cache_file"$$ "$cache_file" ;; #( - *) - mv -f confcache "$cache_file" ;; - esac - fi - fi - else - { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 -$as_echo "$as_me: not updating unwritable cache $cache_file" >&6;} + /^ac_cv_env/!s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ + : end' >>confcache +if diff $cache_file confcache >/dev/null 2>&1; then :; else + if test -w $cache_file; then + test "x$cache_file" != "x/dev/null" && echo "updating cache $cache_file" + cat confcache >$cache_file + else + echo "not updating unwritable cache $cache_file" fi fi rm -f confcache test "x$prefix" = xNONE && prefix=$ac_default_prefix # Let make expand exec_prefix. test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' + +# VPATH may cause trouble with some makes, so we remove $(srcdir), +# ${srcdir} and @srcdir@ from VPATH if srcdir is ".", strip leading and +# trailing colons and then remove the whole line if VPATH becomes empty +# (actually we leave an empty line to preserve line numbers). +if test "x$srcdir" = x.; then + ac_vpsub='/^[ ]*VPATH[ ]*=/{ +s/:*\$(srcdir):*/:/; +s/:*\${srcdir}:*/:/; +s/:*@srcdir@:*/:/; +s/^\([^=]*=[ ]*\):*/\1/; +s/:*$//; +s/^[^=]*=[ ]*$//; +}' +fi # Transform confdefs.h into DEFS. # Protect against shell expansion while executing Makefile rules. # Protect against Makefile macro expansion. # # If the first sed substitution is executed (which looks for macros that -# take arguments), then branch to the quote section. Otherwise, -# look for a macro that doesn't take arguments. -ac_script=' -:mline -/\\$/{ - N - s,\\\n,, - b mline -} -t clear -:clear -s/^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\)/-D\1=\2/g -t quote -s/^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\)/-D\1=\2/g -t quote -b any -:quote -s/[ `~#$^&*(){}\\|;'\''"<>?]/\\&/g -s/\[/\\&/g -s/\]/\\&/g -s/\$/$$/g -H -:any -${ - g - s/^\n// - s/\n/ /g - p -} -' -DEFS=`sed -n "$ac_script" confdefs.h` +# take arguments), then we branch to the quote section. Otherwise, +# look for a macro that doesn't take arguments. +cat >confdef2opt.sed <<\_ACEOF +t clear +: clear +s,^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\),-D\1=\2,g +t quote +s,^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\),-D\1=\2,g +t quote +d +: quote +s,[ `~#$^&*(){}\\|;'"<>?],\\&,g +s,\[,\\&,g +s,\],\\&,g +s,\$,$$,g +p +_ACEOF +# We use echo to avoid assuming a particular line-breaking character. +# The extra dot is to prevent the shell from consuming trailing +# line-breaks from the sub-command output. A line-break within +# single-quotes doesn't work because, if this script is created in a +# platform that uses two characters for line-breaks (e.g., DOS), tr +# would break. +ac_LF_and_DOT=`echo; echo .` +DEFS=`sed -n -f confdef2opt.sed confdefs.h | tr "$ac_LF_and_DOT" ' .'` +rm -f confdef2opt.sed CFLAGS="${CFLAGS} ${CPPFLAGS}"; CPPFLAGS="" - -: "${CONFIG_STATUS=./config.status}" -ac_write_fail=0 +: ${CONFIG_STATUS=./config.status} ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files $CONFIG_STATUS" -{ $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 -$as_echo "$as_me: creating $CONFIG_STATUS" >&6;} -as_write_fail=0 -cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 +{ echo "$as_me:$LINENO: creating $CONFIG_STATUS" >&5 +echo "$as_me: creating $CONFIG_STATUS" >&6;} +cat >$CONFIG_STATUS <<_ACEOF #! $SHELL # Generated by $as_me. # Run this file to recreate the current configuration. # Compiler output produced by configure, useful for debugging # configure, is in config.log if it exists. debug=false ac_cs_recheck=false ac_cs_silent=false - SHELL=\${CONFIG_SHELL-$SHELL} -export SHELL -_ASEOF -cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 -## -------------------- ## -## M4sh Initialization. ## -## -------------------- ## - -# Be more Bourne compatible -DUALCASE=1; export DUALCASE # for MKS sh -if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF +## --------------------- ## +## M4sh Initialization. ## +## --------------------- ## + +# Be Bourne compatible +if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then emulate sh NULLCMD=: - # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which + # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' - setopt NO_GLOB_SUBST -else - case `(set -o) 2>/dev/null` in #( - *posix*) : - set -o posix ;; #( - *) : - ;; -esac -fi - - -as_nl=' -' -export as_nl -# Printing a long string crashes Solaris 7 /usr/bin/printf. -as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' -as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo -as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo -# Prefer a ksh shell builtin over an external printf program on Solaris, -# but without wasting forks for bash or zsh. -if test -z "$BASH_VERSION$ZSH_VERSION" \ - && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then - as_echo='print -r --' - as_echo_n='print -rn --' -elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then - as_echo='printf %s\n' - as_echo_n='printf %s' -else - if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then - as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' - as_echo_n='/usr/ucb/echo -n' - else - as_echo_body='eval expr "X$1" : "X\\(.*\\)"' - as_echo_n_body='eval - arg=$1; - case $arg in #( - *"$as_nl"*) - expr "X$arg" : "X\\(.*\\)$as_nl"; - arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; - esac; - expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" - ' - export as_echo_n_body - as_echo_n='sh -c $as_echo_n_body as_echo' - fi - export as_echo_body - as_echo='sh -c $as_echo_body as_echo' -fi - -# The user is always right. -if test "${PATH_SEPARATOR+set}" != set; then - PATH_SEPARATOR=: - (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { - (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || - PATH_SEPARATOR=';' - } -fi - - -# IFS -# We need space, tab and new line, in precisely that order. Quoting is -# there to prevent editors from complaining about space-tab. -# (If _AS_PATH_WALK were called with IFS unset, it would disable word -# splitting by setting IFS to empty value.) -IFS=" "" $as_nl" - -# Find who we are. Look in the path if we contain no directory separator. -as_myself= -case $0 in #(( - *[\\/]* ) as_myself=$0 ;; - *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break - done -IFS=$as_save_IFS - - ;; -esac -# We did not find ourselves, most probably we were run as `sh COMMAND' -# in which case we are not to be found in the path. -if test "x$as_myself" = x; then - as_myself=$0 -fi -if test ! -f "$as_myself"; then - $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 - exit 1 -fi - -# Unset variables that we do not need and which cause bugs (e.g. in -# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" -# suppresses any "Segmentation fault" message there. '((' could -# trigger a bug in pdksh 5.2.14. -for as_var in BASH_ENV ENV MAIL MAILPATH -do eval test x\${$as_var+set} = xset \ - && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : -done +elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then + set -o posix +fi +DUALCASE=1; export DUALCASE # for MKS sh + +# Support unset when possible. +if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then + as_unset=unset +else + as_unset=false +fi + + +# Work around bugs in pre-3.0 UWIN ksh. +$as_unset ENV MAIL MAILPATH PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. -LC_ALL=C -export LC_ALL -LANGUAGE=C -export LANGUAGE - -# CDPATH. -(unset CDPATH) >/dev/null 2>&1 && unset CDPATH - - -# as_fn_error STATUS ERROR [LINENO LOG_FD] -# ---------------------------------------- -# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are -# provided, also output the error to LOG_FD, referencing LINENO. Then exit the -# script with STATUS, using 1 if that was 0. -as_fn_error () -{ - as_status=$1; test $as_status -eq 0 && as_status=1 - if test "$4"; then - as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 +for as_var in \ + LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \ + LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \ + LC_TELEPHONE LC_TIME +do + if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then + eval $as_var=C; export $as_var + else + $as_unset $as_var fi - $as_echo "$as_me: error: $2" >&2 - as_fn_exit $as_status -} # as_fn_error - - -# as_fn_set_status STATUS -# ----------------------- -# Set $? to STATUS, without forking. -as_fn_set_status () -{ - return $1 -} # as_fn_set_status - -# as_fn_exit STATUS -# ----------------- -# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. -as_fn_exit () -{ - set +e - as_fn_set_status $1 - exit $1 -} # as_fn_exit - -# as_fn_unset VAR -# --------------- -# Portably unset VAR. -as_fn_unset () -{ - { eval $1=; unset $1;} -} -as_unset=as_fn_unset -# as_fn_append VAR VALUE -# ---------------------- -# Append the text in VALUE to the end of the definition contained in VAR. Take -# advantage of any shell optimizations that allow amortized linear growth over -# repeated appends, instead of the typical quadratic growth present in naive -# implementations. -if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : - eval 'as_fn_append () - { - eval $1+=\$2 - }' -else - as_fn_append () - { - eval $1=\$$1\$2 - } -fi # as_fn_append - -# as_fn_arith ARG... -# ------------------ -# Perform arithmetic evaluation on the ARGs, and store the result in the -# global $as_val. Take advantage of shells that can avoid forks. The arguments -# must be portable across $(()) and expr. -if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : - eval 'as_fn_arith () - { - as_val=$(( $* )) - }' -else - as_fn_arith () - { - as_val=`expr "$@" || test $? -eq 1` - } -fi # as_fn_arith - - -if expr a : '\(a\)' >/dev/null 2>&1 && - test "X`expr 00001 : '.*\(...\)'`" = X001; then +done + +# Required to use basename. +if expr a : '\(a\)' >/dev/null 2>&1; then as_expr=expr else as_expr=false fi -if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then +if (basename /) >/dev/null 2>&1 && test "X`basename / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi -if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then - as_dirname=dirname -else - as_dirname=false -fi -as_me=`$as_basename -- "$0" || +# Name of the executable. +as_me=`$as_basename "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ - X"$0" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X/"$0" | - sed '/^.*\/\([^/][^/]*\)\/*$/{ - s//\1/ - q - } - /^X\/\(\/\/\)$/{ - s//\1/ - q - } - /^X\/\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - + X"$0" : 'X\(/\)$' \| \ + . : '\(.\)' 2>/dev/null || +echo X/"$0" | + sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/; q; } + /^X\/\(\/\/\)$/{ s//\1/; q; } + /^X\/\(\/\).*/{ s//\1/; q; } + s/.*/./; q'` + + +# PATH needs CR, and LINENO needs CR and PATH. # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits -ECHO_C= ECHO_N= ECHO_T= -case `echo -n x` in #((((( --n*) - case `echo 'xy\c'` in - *c*) ECHO_T=' ';; # ECHO_T is single tab character. - xy) ECHO_C='\c';; - *) echo `echo ksh88 bug on AIX 6.1` > /dev/null - ECHO_T=' ';; - esac;; -*) - ECHO_N='-n';; -esac - -rm -f conf$$ conf$$.exe conf$$.file -if test -d conf$$.dir; then - rm -f conf$$.dir/conf$$.file -else - rm -f conf$$.dir - mkdir conf$$.dir 2>/dev/null -fi -if (echo >conf$$.file) 2>/dev/null; then - if ln -s conf$$.file conf$$ 2>/dev/null; then - as_ln_s='ln -s' - # ... but there are two gotchas: - # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. - # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. - # In both cases, we have to default to `cp -pR'. - ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || - as_ln_s='cp -pR' - elif ln conf$$.file conf$$ 2>/dev/null; then - as_ln_s=ln - else - as_ln_s='cp -pR' - fi -else - as_ln_s='cp -pR' -fi -rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file -rmdir conf$$.dir 2>/dev/null - - -# as_fn_mkdir_p -# ------------- -# Create "$as_dir" as a directory, including parents if necessary. -as_fn_mkdir_p () -{ - - case $as_dir in #( - -*) as_dir=./$as_dir;; - esac - test -d "$as_dir" || eval $as_mkdir_p || { - as_dirs= - while :; do - case $as_dir in #( - *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( - *) as_qdir=$as_dir;; - esac - as_dirs="'$as_qdir' $as_dirs" - as_dir=`$as_dirname -- "$as_dir" || -$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$as_dir" : 'X\(//\)[^/]' \| \ - X"$as_dir" : 'X\(//\)$' \| \ - X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X"$as_dir" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - test -d "$as_dir" && break - done - test -z "$as_dirs" || eval "mkdir $as_dirs" - } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" - - -} # as_fn_mkdir_p -if mkdir -p . 2>/dev/null; then - as_mkdir_p='mkdir -p "$as_dir"' +# The user is always right. +if test "${PATH_SEPARATOR+set}" != set; then + echo "#! /bin/sh" >conf$$.sh + echo "exit 0" >>conf$$.sh + chmod +x conf$$.sh + if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then + PATH_SEPARATOR=';' + else + PATH_SEPARATOR=: + fi + rm -f conf$$.sh +fi + + + as_lineno_1=$LINENO + as_lineno_2=$LINENO + as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` + test "x$as_lineno_1" != "x$as_lineno_2" && + test "x$as_lineno_3" = "x$as_lineno_2" || { + # Find who we are. Look in the path if we contain no path at all + # relative or not. + case $0 in + *[\\/]* ) as_myself=$0 ;; + *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break +done + + ;; + esac + # We did not find ourselves, most probably we were run as `sh COMMAND' + # in which case we are not to be found in the path. + if test "x$as_myself" = x; then + as_myself=$0 + fi + if test ! -f "$as_myself"; then + { { echo "$as_me:$LINENO: error: cannot find myself; rerun with an absolute path" >&5 +echo "$as_me: error: cannot find myself; rerun with an absolute path" >&2;} + { (exit 1); exit 1; }; } + fi + case $CONFIG_SHELL in + '') + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for as_base in sh bash ksh sh5; do + case $as_dir in + /*) + if ("$as_dir/$as_base" -c ' + as_lineno_1=$LINENO + as_lineno_2=$LINENO + as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` + test "x$as_lineno_1" != "x$as_lineno_2" && + test "x$as_lineno_3" = "x$as_lineno_2" ') 2>/dev/null; then + $as_unset BASH_ENV || test "${BASH_ENV+set}" != set || { BASH_ENV=; export BASH_ENV; } + $as_unset ENV || test "${ENV+set}" != set || { ENV=; export ENV; } + CONFIG_SHELL=$as_dir/$as_base + export CONFIG_SHELL + exec "$CONFIG_SHELL" "$0" ${1+"$@"} + fi;; + esac + done +done +;; + esac + + # Create $as_me.lineno as a copy of $as_myself, but with $LINENO + # uniformly replaced by the line number. The first 'sed' inserts a + # line-number line before each line; the second 'sed' does the real + # work. The second script uses 'N' to pair each line-number line + # with the numbered line, and appends trailing '-' during + # substitution so that $LINENO is not a special case at line end. + # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the + # second 'sed' script. Blame Lee E. McMahon for sed's syntax. :-) + sed '=' <$as_myself | + sed ' + N + s,$,-, + : loop + s,^\(['$as_cr_digits']*\)\(.*\)[$]LINENO\([^'$as_cr_alnum'_]\),\1\2\1\3, + t loop + s,-$,, + s,^['$as_cr_digits']*\n,, + ' >$as_me.lineno && + chmod +x $as_me.lineno || + { { echo "$as_me:$LINENO: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&5 +echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2;} + { (exit 1); exit 1; }; } + + # Don't try to exec as it changes $[0], causing all sort of problems + # (the dirname of $[0] is not the place where we might find the + # original and so on. Autoconf is especially sensible to this). + . ./$as_me.lineno + # Exit status is that of the last command. + exit +} + + +case `echo "testing\c"; echo 1,2,3`,`echo -n testing; echo 1,2,3` in + *c*,-n*) ECHO_N= ECHO_C=' +' ECHO_T=' ' ;; + *c*,* ) ECHO_N=-n ECHO_C= ECHO_T= ;; + *) ECHO_N= ECHO_C='\c' ECHO_T= ;; +esac + +if expr a : '\(a\)' >/dev/null 2>&1; then + as_expr=expr +else + as_expr=false +fi + +rm -f conf$$ conf$$.exe conf$$.file +echo >conf$$.file +if ln -s conf$$.file conf$$ 2>/dev/null; then + # We could just check for DJGPP; but this test a) works b) is more generic + # and c) will remain valid once DJGPP supports symlinks (DJGPP 2.04). + if test -f conf$$.exe; then + # Don't use ln at all; we don't have any links + as_ln_s='cp -p' + else + as_ln_s='ln -s' + fi +elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln +else + as_ln_s='cp -p' +fi +rm -f conf$$ conf$$.exe conf$$.file + +if mkdir -p . 2>/dev/null; then + as_mkdir_p=: else test -d ./-p && rmdir ./-p as_mkdir_p=false fi - -# as_fn_executable_p FILE -# ----------------------- -# Test if FILE is an executable regular file. -as_fn_executable_p () -{ - test -f "$1" && test -x "$1" -} # as_fn_executable_p -as_test_x='test -x' -as_executable_p=as_fn_executable_p +as_executable_p="test -f" # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" +# IFS +# We need space, tab and new line, in precisely that order. +as_nl=' +' +IFS=" $as_nl" + +# CDPATH. +$as_unset CDPATH + exec 6>&1 -## ----------------------------------- ## -## Main body of $CONFIG_STATUS script. ## -## ----------------------------------- ## -_ASEOF -test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 - -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -# Save the log message, to keep $0 and so on meaningful, and to + +# Open the log real soon, 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.0, which was -generated by GNU Autoconf 2.69. Invocation command line was +# values after options handling. Logging --version etc. is OK. +exec 5>>config.log +{ + echo + sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX +## Running $as_me. ## +_ASBOX +} >&5 +cat >&5 <<_CSEOF + +This file was extended by tcl $as_me 8.6, which was +generated by GNU Autoconf 2.59. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS CONFIG_COMMANDS = $CONFIG_COMMANDS $ $0 $@ -on `(hostname || uname -n) 2>/dev/null | sed 1q` -" - +_CSEOF +echo "on `(hostname || uname -n) 2>/dev/null | sed 1q`" >&5 +echo >&5 _ACEOF -case $ac_config_files in *" -"*) set x $ac_config_files; shift; ac_config_files=$*;; -esac - - - -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 # Files that config.status was made for. -config_files="$ac_config_files" -config_commands="$ac_config_commands" +if test -n "$ac_config_files"; then + echo "config_files=\"$ac_config_files\"" >>$CONFIG_STATUS +fi + +if test -n "$ac_config_headers"; then + echo "config_headers=\"$ac_config_headers\"" >>$CONFIG_STATUS +fi + +if test -n "$ac_config_links"; then + echo "config_links=\"$ac_config_links\"" >>$CONFIG_STATUS +fi -_ACEOF +if test -n "$ac_config_commands"; then + echo "config_commands=\"$ac_config_commands\"" >>$CONFIG_STATUS +fi -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +cat >>$CONFIG_STATUS <<\_ACEOF + ac_cs_usage="\ -\`$as_me' instantiates files and other configuration actions -from templates according to the current configuration. Unless the files -and actions are specified as TAGs, all are instantiated by default. +\`$as_me' instantiates files from templates according to the +current configuration. -Usage: $0 [OPTION]... [TAG]... +Usage: $0 [OPTIONS] [FILE]... -h, --help print this help, then exit - -V, --version print version number and configuration settings, then exit - --config print configuration, then exit - -q, --quiet, --silent - do not print progress messages + -V, --version print version number, then exit + -q, --quiet do not print progress messages -d, --debug don't remove temporary files --recheck update $as_me by reconfiguring in the same conditions - --file=FILE[:TEMPLATE] - instantiate the configuration file FILE + --file=FILE[:TEMPLATE] + instantiate the configuration file FILE Configuration files: $config_files Configuration commands: $config_commands -Report bugs to the package provider." - +Report bugs to ." _ACEOF -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" + +cat >>$CONFIG_STATUS <<_ACEOF ac_cs_version="\\ -tcl config.status 9.0 -configured by $0, generated by GNU Autoconf 2.69, - with options \\"\$ac_cs_config\\" +tcl config.status 8.6 +configured by $0, generated by GNU Autoconf 2.59, + with options \\"`echo "$ac_configure_args" | sed 's/[\\""\`\$]/\\\\&/g'`\\" -Copyright (C) 2012 Free Software Foundation, Inc. +Copyright (C) 2003 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." - -ac_pwd='$ac_pwd' -srcdir='$srcdir' -test -n "\$AWK" || AWK=awk +srcdir=$srcdir _ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -# The default lists apply if the user does not specify any file. +cat >>$CONFIG_STATUS <<\_ACEOF +# If no file are specified by the user, then we need to provide default +# value. By we need to know if files were specified by the user. ac_need_defaults=: while test $# != 0 do case $1 in - --*=?*) - ac_option=`expr "X$1" : 'X\([^=]*\)='` - ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` + --*=*) + ac_option=`expr "x$1" : 'x\([^=]*\)='` + ac_optarg=`expr "x$1" : 'x[^=]*=\(.*\)'` ac_shift=: ;; - --*=) - ac_option=`expr "X$1" : 'X\([^=]*\)='` - ac_optarg= - ac_shift=: - ;; - *) + -*) ac_option=$1 ac_optarg=$2 ac_shift=shift ;; + *) # This is not an option, so the user has probably given explicit + # arguments. + ac_option=$1 + ac_need_defaults=false;; esac case $ac_option in # Handling of the options. +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) ac_cs_recheck=: ;; - --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) - $as_echo "$ac_cs_version"; exit ;; - --config | --confi | --conf | --con | --co | --c ) - $as_echo "$ac_cs_config"; exit ;; - --debug | --debu | --deb | --de | --d | -d ) + --version | --vers* | -V ) + echo "$ac_cs_version"; exit 0 ;; + --he | --h) + # Conflict between --help and --header + { { echo "$as_me:$LINENO: error: ambiguous option: $1 +Try \`$0 --help' for more information." >&5 +echo "$as_me: error: ambiguous option: $1 +Try \`$0 --help' for more information." >&2;} + { (exit 1); exit 1; }; };; + --help | --hel | -h ) + echo "$ac_cs_usage"; exit 0 ;; + --debug | --d* | -d ) debug=: ;; --file | --fil | --fi | --f ) $ac_shift - case $ac_optarg in - *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; - '') as_fn_error $? "missing file argument" ;; - esac - as_fn_append CONFIG_FILES " '$ac_optarg'" + CONFIG_FILES="$CONFIG_FILES $ac_optarg" ac_need_defaults=false;; - --he | --h | --help | --hel | -h ) - $as_echo "$ac_cs_usage"; exit ;; + --header | --heade | --head | --hea ) + $ac_shift + CONFIG_HEADERS="$CONFIG_HEADERS $ac_optarg" + ac_need_defaults=false;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil | --si | --s) ac_cs_silent=: ;; # This is an error. - -*) as_fn_error $? "unrecognized option: \`$1' -Try \`$0 --help' for more information." ;; + -*) { { echo "$as_me:$LINENO: error: unrecognized option: $1 +Try \`$0 --help' for more information." >&5 +echo "$as_me: error: unrecognized option: $1 +Try \`$0 --help' for more information." >&2;} + { (exit 1); exit 1; }; } ;; - *) as_fn_append ac_config_targets " $1" - ac_need_defaults=false ;; + *) ac_config_targets="$ac_config_targets $1" ;; esac shift done @@ -11104,58 +19465,46 @@ exec 6>/dev/null ac_configure_extra_args="$ac_configure_extra_args --silent" fi _ACEOF -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +cat >>$CONFIG_STATUS <<_ACEOF if \$ac_cs_recheck; then - set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion - shift - \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6 - CONFIG_SHELL='$SHELL' - export CONFIG_SHELL - exec "\$@" + echo "running $SHELL $0 " $ac_configure_args \$ac_configure_extra_args " --no-create --no-recursion" >&6 + exec $SHELL $0 $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion fi _ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -exec 5>>config.log -{ - echo - sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX -## Running $as_me. ## -_ASBOX - $as_echo "$ac_log" -} >&5 - -_ACEOF -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -# -# INIT-COMMANDS -# + +cat >>$CONFIG_STATUS <<_ACEOF +# +# INIT-COMMANDS section. +# + VERSION=${TCL_VERSION} _ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 + -# Handling of arguments. +cat >>$CONFIG_STATUS <<\_ACEOF for ac_config_target in $ac_config_targets do - case $ac_config_target in - "Tcl-Info.plist") CONFIG_FILES="$CONFIG_FILES Tcl-Info.plist:../macosx/Tcl-Info.plist.in" ;; - "Tclsh-Info.plist") CONFIG_FILES="$CONFIG_FILES Tclsh-Info.plist:../macosx/Tclsh-Info.plist.in" ;; - "Tcl.framework") CONFIG_COMMANDS="$CONFIG_COMMANDS Tcl.framework" ;; - "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile:../unix/Makefile.in" ;; - "dltest/Makefile") CONFIG_FILES="$CONFIG_FILES dltest/Makefile:../unix/dltest/Makefile.in" ;; - "tclConfig.sh") CONFIG_FILES="$CONFIG_FILES tclConfig.sh:../unix/tclConfig.sh.in" ;; - "tcl.pc") CONFIG_FILES="$CONFIG_FILES tcl.pc:../unix/tcl.pc.in" ;; - - *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; + case "$ac_config_target" in + # Handling of arguments. + "Tcl-Info.plist" ) CONFIG_FILES="$CONFIG_FILES Tcl-Info.plist:../macosx/Tcl-Info.plist.in" ;; + "Tclsh-Info.plist" ) CONFIG_FILES="$CONFIG_FILES Tclsh-Info.plist:../macosx/Tclsh-Info.plist.in" ;; + "Makefile" ) CONFIG_FILES="$CONFIG_FILES Makefile:../unix/Makefile.in" ;; + "dltest/Makefile" ) CONFIG_FILES="$CONFIG_FILES dltest/Makefile:../unix/dltest/Makefile.in" ;; + "tclConfig.sh" ) CONFIG_FILES="$CONFIG_FILES tclConfig.sh:../unix/tclConfig.sh.in" ;; + "tcl.pc" ) CONFIG_FILES="$CONFIG_FILES tcl.pc:../unix/tcl.pc.in" ;; + "Tcl.framework" ) CONFIG_COMMANDS="$CONFIG_COMMANDS Tcl.framework" ;; + *) { { echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5 +echo "$as_me: error: invalid argument: $ac_config_target" >&2;} + { (exit 1); exit 1; }; };; esac done - # If the user did not use the arguments to specify the items to instantiate, # then the envvar interface is used. Set only those that are not. # We use the long form for the default assignment because of an extremely # bizarre bug on SunOS 4.1.3. @@ -11163,430 +19512,536 @@ test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files test "${CONFIG_COMMANDS+set}" = set || CONFIG_COMMANDS=$config_commands fi # Have a temporary directory for convenience. Make it in the build tree -# simply because there is no reason against having it here, and in addition, +# simply because there is no reason to put it here, and in addition, # creating and moving files from /tmp can sometimes cause problems. -# Hook for its removal unless debugging. -# Note that there is a small window in which the directory will not be cleaned: -# after its creation but before its name has been assigned to `$tmp'. +# Create a temporary directory, and hook for its removal unless debugging. $debug || { - tmp= ac_tmp= - trap 'exit_status=$? - : "${ac_tmp:=$tmp}" - { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status -' 0 - trap 'as_fn_exit 1' 1 2 13 15 + trap 'exit_status=$?; rm -rf $tmp && exit $exit_status' 0 + trap '{ (exit 1); exit 1; }' 1 2 13 15 } + # Create a (secure) tmp directory for tmp files. { - tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && - test -d "$tmp" + tmp=`(umask 077 && mktemp -d -q "./confstatXXXXXX") 2>/dev/null` && + test -n "$tmp" && test -d "$tmp" } || { - tmp=./conf$$-$RANDOM - (umask 077 && mkdir "$tmp") -} || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 -ac_tmp=$tmp - -# Set up the scripts for CONFIG_FILES section. -# No need to generate them if there are no CONFIG_FILES. -# This happens for instance with `./config.status config.h'. -if test -n "$CONFIG_FILES"; then - - -ac_cr=`echo X | tr X '\015'` -# On cygwin, bash can eat \r inside `` if the user requested igncr. -# But we know of no other shell where ac_cr would be empty at this -# point, so we can use a bashism as a fallback. -if test "x$ac_cr" = x; then - eval ac_cr=\$\'\\r\' -fi -ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` -if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then - ac_cs_awk_cr='\\r' -else - ac_cs_awk_cr=$ac_cr -fi - -echo 'BEGIN {' >"$ac_tmp/subs1.awk" && -_ACEOF - - -{ - echo "cat >conf$$subs.awk <<_ACEOF" && - echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && - echo "_ACEOF" -} >conf$$subs.sh || - as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 -ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` -ac_delim='%!_!# ' -for ac_last_try in false false false false false :; do - . ./conf$$subs.sh || - as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 - - ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` - if test $ac_delim_n = $ac_delim_num; then - break - elif $ac_last_try; then - as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 - else - ac_delim="$ac_delim!$ac_delim _$ac_delim!! " - fi -done -rm -f conf$$subs.sh - -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && -_ACEOF -sed -n ' -h -s/^/S["/; s/!.*/"]=/ -p -g -s/^[^!]*!// -:repl -t repl -s/'"$ac_delim"'$// -t delim -:nl -h -s/\(.\{148\}\)..*/\1/ -t more1 -s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ -p -n -b repl -:more1 -s/["\\]/\\&/g; s/^/"/; s/$/"\\/ -p -g -s/.\{148\}// -t nl -:delim -h -s/\(.\{148\}\)..*/\1/ -t more2 -s/["\\]/\\&/g; s/^/"/; s/$/"/ -p -b -:more2 -s/["\\]/\\&/g; s/^/"/; s/$/"\\/ -p -g -s/.\{148\}// -t delim -' >$CONFIG_STATUS || ac_write_fail=1 -rm -f conf$$subs.awk -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -_ACAWK -cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && - for (key in S) S_is_set[key] = 1 - FS = "" - -} -{ - line = $ 0 - nfields = split(line, field, "@") - substed = 0 - len = length(field[1]) - for (i = 2; i < nfields; i++) { - key = field[i] - keylen = length(key) - if (S_is_set[key]) { - value = S[key] - line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) - len += length(value) + length(field[++i]) - substed = 1 - } else - len += 1 + keylen - } - - print line -} - -_ACAWK -_ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then - sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" -else - cat -fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ - || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 -_ACEOF - -# VPATH may cause trouble with some makes, so we remove sole $(srcdir), -# ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and -# trailing colons and then remove the whole line if VPATH becomes empty -# (actually we leave an empty line to preserve line numbers). -if test "x$srcdir" = x.; then - ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ -h -s/// -s/^/:/ -s/[ ]*$/:/ -s/:\$(srcdir):/:/g -s/:\${srcdir}:/:/g -s/:@srcdir@:/:/g -s/^:*// -s/:*$// -x -s/\(=[ ]*\).*/\1/ -G -s/\n// -s/^[^=]*=[ ]*$// -}' -fi - -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 + tmp=./confstat$$-$RANDOM + (umask 077 && mkdir $tmp) +} || +{ + echo "$me: cannot create a temporary directory in ." >&2 + { (exit 1); exit 1; } +} + +_ACEOF + +cat >>$CONFIG_STATUS <<_ACEOF + +# +# CONFIG_FILES section. +# + +# No need to generate the scripts if there are no CONFIG_FILES. +# This happens for instance when ./config.status config.h +if test -n "\$CONFIG_FILES"; then + # Protect against being on the right side of a sed subst in config.status. + sed 's/,@/@@/; s/@,/@@/; s/,;t t\$/@;t t/; /@;t t\$/s/[\\\\&,]/\\\\&/g; + s/@@/,@/; s/@@/@,/; s/@;t t\$/,;t t/' >\$tmp/subs.sed <<\\CEOF +s,@SHELL@,$SHELL,;t t +s,@PATH_SEPARATOR@,$PATH_SEPARATOR,;t t +s,@PACKAGE_NAME@,$PACKAGE_NAME,;t t +s,@PACKAGE_TARNAME@,$PACKAGE_TARNAME,;t t +s,@PACKAGE_VERSION@,$PACKAGE_VERSION,;t t +s,@PACKAGE_STRING@,$PACKAGE_STRING,;t t +s,@PACKAGE_BUGREPORT@,$PACKAGE_BUGREPORT,;t t +s,@exec_prefix@,$exec_prefix,;t t +s,@prefix@,$prefix,;t t +s,@program_transform_name@,$program_transform_name,;t t +s,@bindir@,$bindir,;t t +s,@sbindir@,$sbindir,;t t +s,@libexecdir@,$libexecdir,;t t +s,@datadir@,$datadir,;t t +s,@sysconfdir@,$sysconfdir,;t t +s,@sharedstatedir@,$sharedstatedir,;t t +s,@localstatedir@,$localstatedir,;t t +s,@libdir@,$libdir,;t t +s,@includedir@,$includedir,;t t +s,@oldincludedir@,$oldincludedir,;t t +s,@infodir@,$infodir,;t t +s,@mandir@,$mandir,;t t +s,@build_alias@,$build_alias,;t t +s,@host_alias@,$host_alias,;t t +s,@target_alias@,$target_alias,;t t +s,@DEFS@,$DEFS,;t t +s,@ECHO_C@,$ECHO_C,;t t +s,@ECHO_N@,$ECHO_N,;t t +s,@ECHO_T@,$ECHO_T,;t t +s,@LIBS@,$LIBS,;t t +s,@MAN_FLAGS@,$MAN_FLAGS,;t t +s,@CC@,$CC,;t t +s,@CFLAGS@,$CFLAGS,;t t +s,@LDFLAGS@,$LDFLAGS,;t t +s,@CPPFLAGS@,$CPPFLAGS,;t t +s,@ac_ct_CC@,$ac_ct_CC,;t t +s,@EXEEXT@,$EXEEXT,;t t +s,@OBJEXT@,$OBJEXT,;t t +s,@CPP@,$CPP,;t t +s,@EGREP@,$EGREP,;t t +s,@TCL_THREADS@,$TCL_THREADS,;t t +s,@TCLSH_PROG@,$TCLSH_PROG,;t t +s,@ZLIB_OBJS@,$ZLIB_OBJS,;t t +s,@ZLIB_SRCS@,$ZLIB_SRCS,;t t +s,@ZLIB_INCLUDE@,$ZLIB_INCLUDE,;t t +s,@RANLIB@,$RANLIB,;t t +s,@ac_ct_RANLIB@,$ac_ct_RANLIB,;t t +s,@AR@,$AR,;t t +s,@ac_ct_AR@,$ac_ct_AR,;t t +s,@LIBOBJS@,$LIBOBJS,;t t +s,@TCL_LIBS@,$TCL_LIBS,;t t +s,@DL_LIBS@,$DL_LIBS,;t t +s,@DL_OBJS@,$DL_OBJS,;t t +s,@PLAT_OBJS@,$PLAT_OBJS,;t t +s,@PLAT_SRCS@,$PLAT_SRCS,;t t +s,@LDAIX_SRC@,$LDAIX_SRC,;t t +s,@CFLAGS_DEBUG@,$CFLAGS_DEBUG,;t t +s,@CFLAGS_OPTIMIZE@,$CFLAGS_OPTIMIZE,;t t +s,@CFLAGS_WARNING@,$CFLAGS_WARNING,;t t +s,@LDFLAGS_DEBUG@,$LDFLAGS_DEBUG,;t t +s,@LDFLAGS_OPTIMIZE@,$LDFLAGS_OPTIMIZE,;t t +s,@CC_SEARCH_FLAGS@,$CC_SEARCH_FLAGS,;t t +s,@LD_SEARCH_FLAGS@,$LD_SEARCH_FLAGS,;t t +s,@STLIB_LD@,$STLIB_LD,;t t +s,@SHLIB_LD@,$SHLIB_LD,;t t +s,@TCL_SHLIB_LD_EXTRAS@,$TCL_SHLIB_LD_EXTRAS,;t t +s,@TK_SHLIB_LD_EXTRAS@,$TK_SHLIB_LD_EXTRAS,;t t +s,@SHLIB_LD_LIBS@,$SHLIB_LD_LIBS,;t t +s,@SHLIB_CFLAGS@,$SHLIB_CFLAGS,;t t +s,@SHLIB_SUFFIX@,$SHLIB_SUFFIX,;t t +s,@MAKE_LIB@,$MAKE_LIB,;t t +s,@MAKE_STUB_LIB@,$MAKE_STUB_LIB,;t t +s,@INSTALL_LIB@,$INSTALL_LIB,;t t +s,@DLL_INSTALL_DIR@,$DLL_INSTALL_DIR,;t t +s,@INSTALL_STUB_LIB@,$INSTALL_STUB_LIB,;t t +s,@CFLAGS_DEFAULT@,$CFLAGS_DEFAULT,;t t +s,@LDFLAGS_DEFAULT@,$LDFLAGS_DEFAULT,;t t +s,@DTRACE@,$DTRACE,;t t +s,@TCL_VERSION@,$TCL_VERSION,;t t +s,@TCL_MAJOR_VERSION@,$TCL_MAJOR_VERSION,;t t +s,@TCL_MINOR_VERSION@,$TCL_MINOR_VERSION,;t t +s,@TCL_PATCH_LEVEL@,$TCL_PATCH_LEVEL,;t t +s,@TCL_YEAR@,$TCL_YEAR,;t t +s,@PKG_CFG_ARGS@,$PKG_CFG_ARGS,;t t +s,@TCL_LIB_FILE@,$TCL_LIB_FILE,;t t +s,@TCL_LIB_FLAG@,$TCL_LIB_FLAG,;t t +s,@TCL_LIB_SPEC@,$TCL_LIB_SPEC,;t t +s,@TCL_STUB_LIB_FILE@,$TCL_STUB_LIB_FILE,;t t +s,@TCL_STUB_LIB_FLAG@,$TCL_STUB_LIB_FLAG,;t t +s,@TCL_STUB_LIB_SPEC@,$TCL_STUB_LIB_SPEC,;t t +s,@TCL_STUB_LIB_PATH@,$TCL_STUB_LIB_PATH,;t t +s,@TCL_INCLUDE_SPEC@,$TCL_INCLUDE_SPEC,;t t +s,@TCL_BUILD_STUB_LIB_SPEC@,$TCL_BUILD_STUB_LIB_SPEC,;t t +s,@TCL_BUILD_STUB_LIB_PATH@,$TCL_BUILD_STUB_LIB_PATH,;t t +s,@TCL_SRC_DIR@,$TCL_SRC_DIR,;t t +s,@CFG_TCL_SHARED_LIB_SUFFIX@,$CFG_TCL_SHARED_LIB_SUFFIX,;t t +s,@CFG_TCL_UNSHARED_LIB_SUFFIX@,$CFG_TCL_UNSHARED_LIB_SUFFIX,;t t +s,@TCL_SHARED_BUILD@,$TCL_SHARED_BUILD,;t t +s,@LD_LIBRARY_PATH_VAR@,$LD_LIBRARY_PATH_VAR,;t t +s,@TCL_BUILD_LIB_SPEC@,$TCL_BUILD_LIB_SPEC,;t t +s,@TCL_LIB_VERSIONS_OK@,$TCL_LIB_VERSIONS_OK,;t t +s,@TCL_SHARED_LIB_SUFFIX@,$TCL_SHARED_LIB_SUFFIX,;t t +s,@TCL_UNSHARED_LIB_SUFFIX@,$TCL_UNSHARED_LIB_SUFFIX,;t t +s,@TCL_HAS_LONGLONG@,$TCL_HAS_LONGLONG,;t t +s,@INSTALL_TZDATA@,$INSTALL_TZDATA,;t t +s,@DTRACE_SRC@,$DTRACE_SRC,;t t +s,@DTRACE_HDR@,$DTRACE_HDR,;t t +s,@DTRACE_OBJ@,$DTRACE_OBJ,;t t +s,@MAKEFILE_SHELL@,$MAKEFILE_SHELL,;t t +s,@BUILD_DLTEST@,$BUILD_DLTEST,;t t +s,@TCL_PACKAGE_PATH@,$TCL_PACKAGE_PATH,;t t +s,@TCL_MODULE_PATH@,$TCL_MODULE_PATH,;t t +s,@TCL_LIBRARY@,$TCL_LIBRARY,;t t +s,@PRIVATE_INCLUDE_DIR@,$PRIVATE_INCLUDE_DIR,;t t +s,@HTML_DIR@,$HTML_DIR,;t t +s,@PACKAGE_DIR@,$PACKAGE_DIR,;t t +s,@EXTRA_CC_SWITCHES@,$EXTRA_CC_SWITCHES,;t t +s,@EXTRA_APP_CC_SWITCHES@,$EXTRA_APP_CC_SWITCHES,;t t +s,@EXTRA_INSTALL@,$EXTRA_INSTALL,;t t +s,@EXTRA_INSTALL_BINARIES@,$EXTRA_INSTALL_BINARIES,;t t +s,@EXTRA_BUILD_HTML@,$EXTRA_BUILD_HTML,;t t +s,@EXTRA_TCLSH_LIBS@,$EXTRA_TCLSH_LIBS,;t t +s,@DLTEST_LD@,$DLTEST_LD,;t t +s,@DLTEST_SUFFIX@,$DLTEST_SUFFIX,;t t +CEOF + +_ACEOF + + cat >>$CONFIG_STATUS <<\_ACEOF + # Split the substitutions into bite-sized pieces for seds with + # small command number limits, like on Digital OSF/1 and HP-UX. + ac_max_sed_lines=48 + ac_sed_frag=1 # Number of current file. + ac_beg=1 # First line for current file. + ac_end=$ac_max_sed_lines # Line after last line for current file. + ac_more_lines=: + ac_sed_cmds= + while $ac_more_lines; do + if test $ac_beg -gt 1; then + sed "1,${ac_beg}d; ${ac_end}q" $tmp/subs.sed >$tmp/subs.frag + else + sed "${ac_end}q" $tmp/subs.sed >$tmp/subs.frag + fi + if test ! -s $tmp/subs.frag; then + ac_more_lines=false + else + # The purpose of the label and of the branching condition is to + # speed up the sed processing (if there are no `@' at all, there + # is no need to browse any of the substitutions). + # These are the two extra sed commands mentioned above. + (echo ':t + /@[a-zA-Z_][a-zA-Z_0-9]*@/!b' && cat $tmp/subs.frag) >$tmp/subs-$ac_sed_frag.sed + if test -z "$ac_sed_cmds"; then + ac_sed_cmds="sed -f $tmp/subs-$ac_sed_frag.sed" + else + ac_sed_cmds="$ac_sed_cmds | sed -f $tmp/subs-$ac_sed_frag.sed" + fi + ac_sed_frag=`expr $ac_sed_frag + 1` + ac_beg=$ac_end + ac_end=`expr $ac_end + $ac_max_sed_lines` + fi + done + if test -z "$ac_sed_cmds"; then + ac_sed_cmds=cat + fi fi # test -n "$CONFIG_FILES" - -eval set X " :F $CONFIG_FILES :C $CONFIG_COMMANDS" -shift -for ac_tag -do - case $ac_tag in - :[FHLC]) ac_mode=$ac_tag; continue;; - esac - case $ac_mode$ac_tag in - :[FHL]*:*);; - :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; - :[FH]-) ac_tag=-:-;; - :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; - esac - ac_save_IFS=$IFS - IFS=: - set x $ac_tag - IFS=$ac_save_IFS - shift - ac_file=$1 - shift - - case $ac_mode in - :L) ac_source=$1;; - :[FH]) - ac_file_inputs= - for ac_f - do - case $ac_f in - -) ac_f="$ac_tmp/stdin";; - *) # Look for the file first in the build tree, then in the source tree - # (if the path is not absolute). The absolute path cannot be DOS-style, - # because $ac_f cannot contain `:'. - test -f "$ac_f" || - case $ac_f in - [\\/$]*) false;; - *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; - esac || - as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; - esac - case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac - as_fn_append ac_file_inputs " '$ac_f'" - done - - # Let's still pretend it is `configure' which instantiates (i.e., don't - # use $as_me), people would be surprised to read: - # /* config.h. Generated by config.status. */ - configure_input='Generated from '` - $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' - `' by configure.' - if test x"$ac_file" != x-; then - configure_input="$ac_file. $configure_input" - { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 -$as_echo "$as_me: creating $ac_file" >&6;} - fi - # Neutralize special characters interpreted by sed in replacement strings. - case $configure_input in #( - *\&* | *\|* | *\\* ) - ac_sed_conf_input=`$as_echo "$configure_input" | - sed 's/[\\\\&|]/\\\\&/g'`;; #( - *) ac_sed_conf_input=$configure_input;; - esac - - case $ac_tag in - *:-:* | *:-) cat >"$ac_tmp/stdin" \ - || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; - esac - ;; - esac - - ac_dir=`$as_dirname -- "$ac_file" || +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF +for ac_file in : $CONFIG_FILES; do test "x$ac_file" = x: && continue + # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in". + case $ac_file in + - | *:- | *:-:* ) # input from stdin + cat >$tmp/stdin + ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'` + ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; + *:* ) ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'` + ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; + * ) ac_file_in=$ac_file.in ;; + esac + + # Compute @srcdir@, @top_srcdir@, and @INSTALL@ for subdirectories. + ac_dir=`(dirname "$ac_file") 2>/dev/null || $as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$ac_file" : 'X\(//\)[^/]' \| \ X"$ac_file" : 'X\(//\)$' \| \ - X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X"$ac_file" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - as_dir="$ac_dir"; as_fn_mkdir_p + X"$ac_file" : 'X\(/\)' \| \ + . : '\(.\)' 2>/dev/null || +echo X"$ac_file" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } + /^X\(\/\/\)[^/].*/{ s//\1/; q; } + /^X\(\/\/\)$/{ s//\1/; q; } + /^X\(\/\).*/{ s//\1/; q; } + s/.*/./; q'` + { if $as_mkdir_p; then + mkdir -p "$ac_dir" + else + as_dir="$ac_dir" + as_dirs= + while test ! -d "$as_dir"; do + as_dirs="$as_dir $as_dirs" + as_dir=`(dirname "$as_dir") 2>/dev/null || +$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_dir" : 'X\(//\)[^/]' \| \ + X"$as_dir" : 'X\(//\)$' \| \ + X"$as_dir" : 'X\(/\)' \| \ + . : '\(.\)' 2>/dev/null || +echo X"$as_dir" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } + /^X\(\/\/\)[^/].*/{ s//\1/; q; } + /^X\(\/\/\)$/{ s//\1/; q; } + /^X\(\/\).*/{ s//\1/; q; } + s/.*/./; q'` + done + test ! -n "$as_dirs" || mkdir $as_dirs + fi || { { echo "$as_me:$LINENO: error: cannot create directory \"$ac_dir\"" >&5 +echo "$as_me: error: cannot create directory \"$ac_dir\"" >&2;} + { (exit 1); exit 1; }; }; } + ac_builddir=. -case "$ac_dir" in -.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; -*) - ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` - # A ".." for each directory in $ac_dir_suffix. - ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` - case $ac_top_builddir_sub in - "") ac_top_builddir_sub=. ac_top_build_prefix= ;; - *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; - esac ;; -esac -ac_abs_top_builddir=$ac_pwd -ac_abs_builddir=$ac_pwd$ac_dir_suffix -# for backward compatibility: -ac_top_builddir=$ac_top_build_prefix +if test "$ac_dir" != .; then + ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'` + # A "../" for each directory in $ac_dir_suffix. + ac_top_builddir=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,../,g'` +else + ac_dir_suffix= ac_top_builddir= +fi case $srcdir in - .) # We are building in place. - ac_srcdir=. - ac_top_srcdir=$ac_top_builddir_sub - ac_abs_top_srcdir=$ac_pwd ;; - [\\/]* | ?:[\\/]* ) # Absolute name. - ac_srcdir=$srcdir$ac_dir_suffix; - ac_top_srcdir=$srcdir - ac_abs_top_srcdir=$srcdir ;; - *) # Relative name. - ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix - ac_top_srcdir=$ac_top_build_prefix$srcdir - ac_abs_top_srcdir=$ac_pwd/$srcdir ;; -esac -ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix - - - case $ac_mode in - :F) - # - # CONFIG_FILE - # - -_ACEOF - -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -# If the template does not know about datarootdir, expand it. -# FIXME: This hack should be removed a few years after 2.60. -ac_datarootdir_hack=; ac_datarootdir_seen= -ac_sed_dataroot=' -/datarootdir/ { - p - q -} -/@datadir@/p -/@docdir@/p -/@infodir@/p -/@localedir@/p -/@mandir@/p' -case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in -*datarootdir*) ac_datarootdir_seen=yes;; -*@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 -$as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} -_ACEOF -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 - ac_datarootdir_hack=' - s&@datadir@&$datadir&g - s&@docdir@&$docdir&g - s&@infodir@&$infodir&g - s&@localedir@&$localedir&g - s&@mandir@&$mandir&g - s&\\\${datarootdir}&$datarootdir&g' ;; -esac -_ACEOF - -# Neutralize VPATH when `$srcdir' = `.'. -# Shell code in configure.ac might set extrasub. -# FIXME: do we really want to maintain this feature? -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -ac_sed_extra="$ac_vpsub + .) # No --srcdir option. We are building in place. + ac_srcdir=. + if test -z "$ac_top_builddir"; then + ac_top_srcdir=. + else + ac_top_srcdir=`echo $ac_top_builddir | sed 's,/$,,'` + fi ;; + [\\/]* | ?:[\\/]* ) # Absolute path. + ac_srcdir=$srcdir$ac_dir_suffix; + ac_top_srcdir=$srcdir ;; + *) # Relative path. + ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix + ac_top_srcdir=$ac_top_builddir$srcdir ;; +esac + +# Do not use `cd foo && pwd` to compute absolute paths, because +# the directories may not exist. +case `pwd` in +.) ac_abs_builddir="$ac_dir";; +*) + case "$ac_dir" in + .) ac_abs_builddir=`pwd`;; + [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";; + *) ac_abs_builddir=`pwd`/"$ac_dir";; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_top_builddir=${ac_top_builddir}.;; +*) + case ${ac_top_builddir}. in + .) ac_abs_top_builddir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;; + *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_srcdir=$ac_srcdir;; +*) + case $ac_srcdir in + .) ac_abs_srcdir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;; + *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_top_srcdir=$ac_top_srcdir;; +*) + case $ac_top_srcdir in + .) ac_abs_top_srcdir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;; + *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;; + esac;; +esac + + + + if test x"$ac_file" != x-; then + { echo "$as_me:$LINENO: creating $ac_file" >&5 +echo "$as_me: creating $ac_file" >&6;} + rm -f "$ac_file" + fi + # Let's still pretend it is `configure' which instantiates (i.e., don't + # use $as_me), people would be surprised to read: + # /* config.h. Generated by config.status. */ + if test x"$ac_file" = x-; then + configure_input= + else + configure_input="$ac_file. " + fi + configure_input=$configure_input"Generated from `echo $ac_file_in | + sed 's,.*/,,'` by configure." + + # First look for the input files in the build tree, otherwise in the + # src tree. + ac_file_inputs=`IFS=: + for f in $ac_file_in; do + case $f in + -) echo $tmp/stdin ;; + [\\/$]*) + # Absolute (can't be DOS-style, as IFS=:) + test -f "$f" || { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 +echo "$as_me: error: cannot find input file: $f" >&2;} + { (exit 1); exit 1; }; } + echo "$f";; + *) # Relative + if test -f "$f"; then + # Build tree + echo "$f" + elif test -f "$srcdir/$f"; then + # Source tree + echo "$srcdir/$f" + else + # /dev/null tree + { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 +echo "$as_me: error: cannot find input file: $f" >&2;} + { (exit 1); exit 1; }; } + fi;; + esac + done` || { (exit 1); exit 1; } +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF + sed "$ac_vpsub $extrasub _ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +cat >>$CONFIG_STATUS <<\_ACEOF :t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b -s|@configure_input@|$ac_sed_conf_input|;t t -s&@top_builddir@&$ac_top_builddir_sub&;t t -s&@top_build_prefix@&$ac_top_build_prefix&;t t -s&@srcdir@&$ac_srcdir&;t t -s&@abs_srcdir@&$ac_abs_srcdir&;t t -s&@top_srcdir@&$ac_top_srcdir&;t t -s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t -s&@builddir@&$ac_builddir&;t t -s&@abs_builddir@&$ac_abs_builddir&;t t -s&@abs_top_builddir@&$ac_abs_top_builddir&;t t -$ac_datarootdir_hack -" -eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ - >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 - -test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && - { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && - { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ - "$ac_tmp/out"`; test -z "$ac_out"; } && - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' -which seems to be undefined. Please make sure it is defined" >&5 -$as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' -which seems to be undefined. Please make sure it is defined" >&2;} - - rm -f "$ac_tmp/stdin" - case $ac_file in - -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; - *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; - esac \ - || as_fn_error $? "could not create $ac_file" "$LINENO" 5 - ;; - - - :C) { $as_echo "$as_me:${as_lineno-$LINENO}: executing $ac_file commands" >&5 -$as_echo "$as_me: executing $ac_file commands" >&6;} - ;; - esac - - - case $ac_file$ac_mode in - "Tcl.framework":C) n=Tcl && +s,@configure_input@,$configure_input,;t t +s,@srcdir@,$ac_srcdir,;t t +s,@abs_srcdir@,$ac_abs_srcdir,;t t +s,@top_srcdir@,$ac_top_srcdir,;t t +s,@abs_top_srcdir@,$ac_abs_top_srcdir,;t t +s,@builddir@,$ac_builddir,;t t +s,@abs_builddir@,$ac_abs_builddir,;t t +s,@top_builddir@,$ac_top_builddir,;t t +s,@abs_top_builddir@,$ac_abs_top_builddir,;t t +" $ac_file_inputs | (eval "$ac_sed_cmds") >$tmp/out + rm -f $tmp/stdin + if test x"$ac_file" != x-; then + mv $tmp/out $ac_file + else + cat $tmp/out + rm -f $tmp/out + fi + +done +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF + +# +# CONFIG_COMMANDS section. +# +for ac_file in : $CONFIG_COMMANDS; do test "x$ac_file" = x: && continue + ac_dest=`echo "$ac_file" | sed 's,:.*,,'` + ac_source=`echo "$ac_file" | sed 's,[^:]*:,,'` + ac_dir=`(dirname "$ac_dest") 2>/dev/null || +$as_expr X"$ac_dest" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$ac_dest" : 'X\(//\)[^/]' \| \ + X"$ac_dest" : 'X\(//\)$' \| \ + X"$ac_dest" : 'X\(/\)' \| \ + . : '\(.\)' 2>/dev/null || +echo X"$ac_dest" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } + /^X\(\/\/\)[^/].*/{ s//\1/; q; } + /^X\(\/\/\)$/{ s//\1/; q; } + /^X\(\/\).*/{ s//\1/; q; } + s/.*/./; q'` + { if $as_mkdir_p; then + mkdir -p "$ac_dir" + else + as_dir="$ac_dir" + as_dirs= + while test ! -d "$as_dir"; do + as_dirs="$as_dir $as_dirs" + as_dir=`(dirname "$as_dir") 2>/dev/null || +$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_dir" : 'X\(//\)[^/]' \| \ + X"$as_dir" : 'X\(//\)$' \| \ + X"$as_dir" : 'X\(/\)' \| \ + . : '\(.\)' 2>/dev/null || +echo X"$as_dir" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } + /^X\(\/\/\)[^/].*/{ s//\1/; q; } + /^X\(\/\/\)$/{ s//\1/; q; } + /^X\(\/\).*/{ s//\1/; q; } + s/.*/./; q'` + done + test ! -n "$as_dirs" || mkdir $as_dirs + fi || { { echo "$as_me:$LINENO: error: cannot create directory \"$ac_dir\"" >&5 +echo "$as_me: error: cannot create directory \"$ac_dir\"" >&2;} + { (exit 1); exit 1; }; }; } + + ac_builddir=. + +if test "$ac_dir" != .; then + ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'` + # A "../" for each directory in $ac_dir_suffix. + ac_top_builddir=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,../,g'` +else + ac_dir_suffix= ac_top_builddir= +fi + +case $srcdir in + .) # No --srcdir option. We are building in place. + ac_srcdir=. + if test -z "$ac_top_builddir"; then + ac_top_srcdir=. + else + ac_top_srcdir=`echo $ac_top_builddir | sed 's,/$,,'` + fi ;; + [\\/]* | ?:[\\/]* ) # Absolute path. + ac_srcdir=$srcdir$ac_dir_suffix; + ac_top_srcdir=$srcdir ;; + *) # Relative path. + ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix + ac_top_srcdir=$ac_top_builddir$srcdir ;; +esac + +# Do not use `cd foo && pwd` to compute absolute paths, because +# the directories may not exist. +case `pwd` in +.) ac_abs_builddir="$ac_dir";; +*) + case "$ac_dir" in + .) ac_abs_builddir=`pwd`;; + [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";; + *) ac_abs_builddir=`pwd`/"$ac_dir";; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_top_builddir=${ac_top_builddir}.;; +*) + case ${ac_top_builddir}. in + .) ac_abs_top_builddir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;; + *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_srcdir=$ac_srcdir;; +*) + case $ac_srcdir in + .) ac_abs_srcdir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;; + *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_top_srcdir=$ac_top_srcdir;; +*) + case $ac_top_srcdir in + .) ac_abs_top_srcdir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;; + *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;; + esac;; +esac + + + { echo "$as_me:$LINENO: executing $ac_dest commands" >&5 +echo "$as_me: executing $ac_dest commands" >&6;} + case $ac_dest in + Tcl.framework ) n=Tcl && f=$n.framework && v=Versions/$VERSION && rm -rf $f && mkdir -p $f/$v/Resources && ln -s $v/$n $v/Resources $f && ln -s ../../../$n $f/$v && ln -s ../../../../$n-Info.plist $f/$v/Resources/Info.plist && unset n f v ;; - - esac -done # for ac_tag - - -as_fn_exit 0 -_ACEOF -ac_clean_files=$ac_clean_files_save - -test $ac_write_fail = 0 || - as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 + esac +done +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF + +{ (exit 0); exit 0; } +_ACEOF +chmod +x $CONFIG_STATUS +ac_clean_files=$ac_clean_files_save # configure is writing to config.log, and then calls config.status. # config.status does its own redirection, appending to config.log. # Unfortunately, on DOS this fails, as config.log is still kept open @@ -11603,13 +20058,9 @@ exec 5>/dev/null $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false exec 5>>config.log # Use ||, not &&, to avoid exiting from the if with $? = 1, which # would make configure fail if this is the last instruction. - $ac_cs_success || as_fn_exit 1 -fi -if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 -$as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} + $ac_cs_success || { (exit 1); exit 1; } fi DELETED unix/configure.ac Index: unix/configure.ac ================================================================== --- unix/configure.ac +++ /dev/null @@ -1,1047 +0,0 @@ -#! /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.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"]) - AH_TOP([ - #ifndef _TCLCONFIG - #define _TCLCONFIG]) - AH_BOTTOM([ - /* Undef unused package specific autoheader defines so that we can - * include both tclConfig.h and tkConfig.h at the same time: */ - /* override */ #undef PACKAGE_NAME - /* override */ #undef PACKAGE_STRING - /* override */ #undef PACKAGE_TARNAME - #endif /* _TCLCONFIG */]) -]) - -TCL_VERSION=9.0 -TCL_MAJOR_VERSION=9 -TCL_MINOR_VERSION=0 -TCL_PATCH_LEVEL="a0" -VERSION=${TCL_VERSION} - -EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} -EXTRA_BUILD_HTML=${EXTRA_BUILD_HTML:-"@:"} - -#------------------------------------------------------------------------ -# Setup configure arguments for bundled packages -#------------------------------------------------------------------------ - -PKG_CFG_ARGS="$ac_configure_args ${PKG_CFG_ARGS}" - -if test -r "$cache_file" -a -f "$cache_file"; then - case $cache_file in - [[\\/]]* | ?:[[\\/]]* ) pkg_cache_file=$cache_file ;; - *) pkg_cache_file=../../$cache_file ;; - esac - PKG_CFG_ARGS="${PKG_CFG_ARGS} --cache-file=$pkg_cache_file" -fi - -#------------------------------------------------------------------------ -# Empty slate for bundled packages, to avoid stale configuration -#------------------------------------------------------------------------ -#rm -Rf pkgs -if test -f Makefile; then - make distclean-packages -fi - -#------------------------------------------------------------------------ -# Handle the --prefix=... option -#------------------------------------------------------------------------ - -if test "${prefix}" = "NONE"; then - prefix=/usr/local -fi -if test "${exec_prefix}" = "NONE"; then - exec_prefix=$prefix -fi -# Make sure srcdir is fully qualified! -srcdir="`cd "$srcdir" ; pwd`" -TCL_SRC_DIR="`cd "$srcdir"/..; pwd`" - -#------------------------------------------------------------------------ -# Compress and/or soft link the manpages? -#------------------------------------------------------------------------ - -SC_CONFIG_MANPAGES - -#------------------------------------------------------------------------ -# Standard compiler checks -#------------------------------------------------------------------------ - -# If the user did not set CFLAGS, set it now to keep -# the AC_PROG_CC macro from adding "-g -O2". -if test "${CFLAGS+set}" != "set" ; then - CFLAGS="" -fi - -AC_PROG_CC -AC_C_INLINE - - -#-------------------------------------------------------------------- -# Supply substitutes for missing POSIX header files. Special notes: -# - stdlib.h doesn't define strtol, strtoul, or -# strtod insome versions of SunOS -# - some versions of string.h don't declare procedures such -# as strstr -# Do this early, otherwise an autoconf bug throws errors on configure -#-------------------------------------------------------------------- - -SC_MISSING_POSIX_HEADERS - -#-------------------------------------------------------------------- -# Determines the correct executable file extension (.exe) -#-------------------------------------------------------------------- - -AC_EXEEXT - -#------------------------------------------------------------------------ -# If we're using GCC, see if the compiler understands -pipe. If so, use it. -# It makes compiling go faster. (This is only a performance feature.) -#------------------------------------------------------------------------ - -if test -z "$no_pipe" && test -n "$GCC"; then - AC_CACHE_CHECK([if the compiler understands -pipe], - tcl_cv_cc_pipe, [ - hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -pipe" - AC_TRY_COMPILE(,, tcl_cv_cc_pipe=yes, tcl_cv_cc_pipe=no) - CFLAGS=$hold_cflags]) - if test $tcl_cv_cc_pipe = yes; then - CFLAGS="$CFLAGS -pipe" - fi -fi - -#------------------------------------------------------------------------ -# Embedded configuration information, encoding to use for the values, TIP #59 -#------------------------------------------------------------------------ - -SC_TCL_CFG_ENCODING - -#-------------------------------------------------------------------- -# Look for libraries that we will need when compiling the Tcl shell -#-------------------------------------------------------------------- - -SC_TCL_LINK_LIBS - -# Add the threads support libraries -LIBS="$LIBS$THREADS_LIBS" - -SC_ENABLE_SHARED - -#-------------------------------------------------------------------- -# Look for a native installed tclsh binary (if available) -# If one cannot be found then use the binary we build (fails for -# cross compiling). This is used for NATIVE_TCLSH in Makefile. -#-------------------------------------------------------------------- - -SC_PROG_TCLSH -if test "$TCLSH_PROG" = ""; then - TCLSH_PROG='./${TCL_EXE}' -fi - -#------------------------------------------------------------------------ -# Add stuff for zlib -#------------------------------------------------------------------------ - -zlib_ok=yes -AC_CHECK_HEADER([zlib.h],[ - AC_CHECK_TYPE([gz_header],[],[zlib_ok=no],[#include ])],[ - zlib_ok=no]) -AS_IF([test $zlib_ok = yes], [ - AC_SEARCH_LIBS([deflateSetHeader],[z],[],[ - zlib_ok=no - ])]) -AS_IF([test $zlib_ok = no], [ - AC_SUBST(ZLIB_OBJS,[\${ZLIB_OBJS}]) - AC_SUBST(ZLIB_SRCS,[\${ZLIB_SRCS}]) - AC_SUBST(ZLIB_INCLUDE,[-I\${ZLIB_DIR}]) -]) -AC_DEFINE(HAVE_ZLIB, 1, [Is there an installed zlib?]) - -#-------------------------------------------------------------------- -# The statements below define a collection of compile flags. This -# macro depends on the value of SHARED_BUILD, and should be called -# after SC_ENABLE_SHARED checks the configure switches. -#-------------------------------------------------------------------- - -SC_CONFIG_CFLAGS - -SC_ENABLE_SYMBOLS(bccdebug) - -AC_DEFINE(MP_PREC, 4, [Default libtommath precision.]) - -#-------------------------------------------------------------------- -# Detect what compiler flags to set for 64-bit support. -#-------------------------------------------------------------------- - -SC_TCL_EARLY_FLAGS - -SC_TCL_64BIT_FLAGS - -#-------------------------------------------------------------------- -# Check endianness because we can optimize comparisons of -# Tcl_UniChar strings to memcmp on big-endian systems. -#-------------------------------------------------------------------- - -AC_C_BIGENDIAN - -#-------------------------------------------------------------------- -# Supply substitutes for missing POSIX library procedures, or -# set flags so Tcl uses alternate procedures. -#-------------------------------------------------------------------- - -# Check if Posix compliant getcwd exists, if not we'll use getwd. -AC_CHECK_FUNCS(getcwd, , [AC_DEFINE(USEGETWD, 1, [Is getcwd Posix-compliant?])]) -# Nb: if getcwd uses popen and pwd(1) (like SunOS 4) we should really -# define USEGETWD even if the posix getcwd exists. Add a test ? - -AC_REPLACE_FUNCS(mkstemp opendir strtol waitpid) -AC_CHECK_FUNC(strerror, , [AC_DEFINE(NO_STRERROR, 1, [Do we have strerror()])]) -AC_CHECK_FUNC(getwd, , [AC_DEFINE(NO_GETWD, 1, [Do we have getwd()])]) -AC_CHECK_FUNC(wait3, , [AC_DEFINE(NO_WAIT3, 1, [Do we have wait3()])]) -AC_CHECK_FUNC(uname, , [AC_DEFINE(NO_UNAME, 1, [Do we have uname()])]) - -if test "`uname -s`" = "Darwin" && \ - test "`uname -r | awk -F. '{print [$]1}'`" -lt 7; then - # prior to Darwin 7, realpath is not threadsafe, so don't - # use it when threads are enabled, c.f. bug # 711232 - ac_cv_func_realpath=no -fi -AC_CHECK_FUNC(realpath, , [AC_DEFINE(NO_REALPATH, 1, [Do we have realpath()])]) - -SC_TCL_IPV6 - -#-------------------------------------------------------------------- -# Look for thread-safe variants of some library functions. -#-------------------------------------------------------------------- - -SC_TCL_GETPWUID_R -SC_TCL_GETPWNAM_R -SC_TCL_GETGRGID_R -SC_TCL_GETGRNAM_R -if test "`uname -s`" = "Darwin" && \ - test "`uname -r | awk -F. '{print [$]1}'`" -gt 5; then - # Starting with Darwin 6 (Mac OSX 10.2), gethostbyX - # are actually MT-safe as they always return pointers - # from TSD instead of static storage. - AC_DEFINE(HAVE_MTSAFE_GETHOSTBYNAME, 1, - [Do we have MT-safe gethostbyname() ?]) - AC_DEFINE(HAVE_MTSAFE_GETHOSTBYADDR, 1, - [Do we have MT-safe gethostbyaddr() ?]) - -elif test "`uname -s`" = "HP-UX" && \ - test "`uname -r|sed -e 's|B\.||' -e 's|\..*$||'`" -gt 10; then - # Starting with HPUX 11.00 (we believe), gethostbyX - # are actually MT-safe as they always return pointers - # from TSD instead of static storage. - AC_DEFINE(HAVE_MTSAFE_GETHOSTBYNAME, 1, - [Do we have MT-safe gethostbyname() ?]) - AC_DEFINE(HAVE_MTSAFE_GETHOSTBYADDR, 1, - [Do we have MT-safe gethostbyaddr() ?]) - -else - SC_TCL_GETHOSTBYNAME_R - SC_TCL_GETHOSTBYADDR_R -fi - -#--------------------------------------------------------------------------- -# Check for serial port interface. -# -# termios.h is present on all POSIX systems. -# sys/ioctl.h is almost always present, though what it contains -# is system-specific. -# sys/modem.h is needed on HP-UX. -#--------------------------------------------------------------------------- - -AC_CHECK_HEADERS(termios.h) -AC_CHECK_HEADERS(sys/ioctl.h) -AC_CHECK_HEADERS(sys/modem.h) - -#-------------------------------------------------------------------- -# Include sys/select.h if it exists and if it supplies things -# that appear to be useful and aren't already in sys/types.h. -# This appears to be true only on the RS/6000 under AIX. Some -# systems like OSF/1 have a sys/select.h that's of no use, and -# other systems like SCO UNIX have a sys/select.h that's -# pernicious. If "fd_set" isn't defined anywhere then set a -# special flag. -#-------------------------------------------------------------------- - -AC_CACHE_CHECK([for fd_set in sys/types], tcl_cv_type_fd_set, [ - AC_TRY_COMPILE([#include ],[fd_set readMask, writeMask;], - tcl_cv_type_fd_set=yes, tcl_cv_type_fd_set=no)]) -tcl_ok=$tcl_cv_type_fd_set -if test $tcl_ok = no; then - AC_CACHE_CHECK([for fd_mask in sys/select], tcl_cv_grep_fd_mask, [ - AC_EGREP_HEADER(fd_mask, sys/select.h, - tcl_cv_grep_fd_mask=present, tcl_cv_grep_fd_mask=missing)]) - if test $tcl_cv_grep_fd_mask = present; then - AC_DEFINE(HAVE_SYS_SELECT_H, 1, [Should we include ?]) - tcl_ok=yes - fi -fi -if test $tcl_ok = no; then - AC_DEFINE(NO_FD_SET, 1, [Do we have fd_set?]) -fi - -#------------------------------------------------------------------------ -# Options for the notifier. Checks for epoll(7) on Linux, and -# kqueue(2) on {DragonFly,Free,Net,Open}BSD -#------------------------------------------------------------------------ - -AC_MSG_CHECKING([for advanced notifier support]) -case x`uname -s` in - xLinux) - AC_MSG_RESULT([epoll(7)]) - AC_CHECK_HEADERS([sys/epoll.h], - [AC_DEFINE(NOTIFIER_EPOLL, [1], [Is epoll(7) supported?])]) - AC_CHECK_HEADERS([sys/eventfd.h], - [AC_DEFINE(HAVE_EVENTFD, [1], [Is eventfd(2) supported?])]);; - xDragonFlyBSD|xFreeBSD|xNetBSD|xOpenBSD) - AC_MSG_RESULT([kqueue(2)]) - # Messy because we want to check if *all* the headers are present, and not - # just *any* - tcl_kqueue_headers=x - AC_CHECK_HEADERS([sys/types.h sys/event.h sys/time.h], - [tcl_kqueue_headers=${tcl_kqueue_headers}y]) - AS_IF([test $tcl_kqueue_headers = xyyy], [ - AC_DEFINE(NOTIFIER_KQUEUE, [1], [Is kqueue(2) supported?])]);; - xDarwin) - # Assume that we've got CoreFoundation present (checked elsewhere because - # of wider impact). - AC_MSG_RESULT([OSX]);; - *) - AC_MSG_RESULT([none]);; -esac - -#------------------------------------------------------------------------------ -# Find out all about time handling differences. -#------------------------------------------------------------------------------ - -SC_TIME_HANDLER - -#-------------------------------------------------------------------- -# Some systems (e.g., IRIX 4.0.5) lack some fields in struct stat. But -# we might be able to use fstatfs instead. Some systems (OpenBSD?) also -# lack blkcnt_t. -#-------------------------------------------------------------------- - -if test "$ac_cv_cygwin" != "yes"; then - AC_CHECK_MEMBERS([struct stat.st_blocks, struct stat.st_blksize]) -fi -AC_CHECK_TYPES([blkcnt_t]) -AC_CHECK_FUNC(fstatfs, , [AC_DEFINE(NO_FSTATFS, 1, [Do we have fstatfs()?])]) - -#-------------------------------------------------------------------- -# Some system have no memcmp or it does not work with 8 bit data, this -# checks it and add memcmp.o to LIBOBJS if needed -#-------------------------------------------------------------------- - -AC_FUNC_MEMCMP - -#-------------------------------------------------------------------- -# Some system like SunOS 4 and other BSD like systems have no memmove -# (we assume they have bcopy instead). {The replacement define is in -# compat/string.h} -#-------------------------------------------------------------------- - -AC_CHECK_FUNC(memmove, , [ - AC_DEFINE(NO_MEMMOVE, 1, [Do we have memmove()?]) - AC_DEFINE(NO_STRING_H, 1, [Do we have ?]) ]) - -#-------------------------------------------------------------------- -# On some systems strstr is broken: it returns a pointer even even if -# the original string is empty. -#-------------------------------------------------------------------- - -SC_TCL_CHECK_BROKEN_FUNC(strstr, [ - extern int strstr(); - exit(strstr("\0test", "test") ? 1 : 0); -]) - -#-------------------------------------------------------------------- -# Check for strtoul function. This is tricky because under some -# versions of AIX strtoul returns an incorrect terminator -# pointer for the string "0". -#-------------------------------------------------------------------- - -SC_TCL_CHECK_BROKEN_FUNC(strtoul, [ - extern int strtoul(); - char *term, *string = "0"; - exit(strtoul(string,&term,0) != 0 || term != string+1); -]) - -#-------------------------------------------------------------------- -# Check for various typedefs and provide substitutes if -# they don't exist. -#-------------------------------------------------------------------- - -AC_TYPE_MODE_T -AC_TYPE_PID_T -AC_TYPE_SIZE_T -AC_TYPE_UID_T - -AC_CACHE_CHECK([for socklen_t], tcl_cv_type_socklen_t, [ - AC_TRY_COMPILE([ - #include - #include - ],[ - socklen_t foo; - ],[tcl_cv_type_socklen_t=yes],[tcl_cv_type_socklen_t=no])]) -if test $tcl_cv_type_socklen_t = no; then - AC_DEFINE(socklen_t, int, [Define as int if socklen_t is not available]) -fi - -AC_CHECK_TYPE([intptr_t], [ - AC_DEFINE([HAVE_INTPTR_T], 1, [Do we have the intptr_t type?])], [ - AC_CACHE_CHECK([for pointer-size signed integer type], tcl_cv_intptr_t, [ - for tcl_cv_intptr_t in "int" "long" "long long" none; do - if test "$tcl_cv_intptr_t" != none; then - AC_COMPILE_IFELSE([AC_LANG_BOOL_COMPILE_TRY([AC_INCLUDES_DEFAULT], - [[sizeof (void *) <= sizeof ($tcl_cv_intptr_t)]])], - [tcl_ok=yes], [tcl_ok=no]) - test "$tcl_ok" = yes && break; fi - done]) - if test "$tcl_cv_intptr_t" != none; then - AC_DEFINE_UNQUOTED([intptr_t], [$tcl_cv_intptr_t], [Signed integer - type wide enough to hold a pointer.]) - fi -]) -AC_CHECK_TYPE([uintptr_t], [ - AC_DEFINE([HAVE_UINTPTR_T], 1, [Do we have the uintptr_t type?])], [ - AC_CACHE_CHECK([for pointer-size unsigned integer type], tcl_cv_uintptr_t, [ - for tcl_cv_uintptr_t in "unsigned int" "unsigned long" "unsigned long long" \ - none; do - if test "$tcl_cv_uintptr_t" != none; then - AC_COMPILE_IFELSE([AC_LANG_BOOL_COMPILE_TRY([AC_INCLUDES_DEFAULT], - [[sizeof (void *) <= sizeof ($tcl_cv_uintptr_t)]])], - [tcl_ok=yes], [tcl_ok=no]) - test "$tcl_ok" = yes && break; fi - done]) - if test "$tcl_cv_uintptr_t" != none; then - AC_DEFINE_UNQUOTED([uintptr_t], [$tcl_cv_uintptr_t], [Unsigned integer - type wide enough to hold a pointer.]) - fi -]) - -#-------------------------------------------------------------------- -# If a system doesn't have an opendir function (man, that's old!) -# then we have to supply a different version of dirent.h which -# is compatible with the substitute version of opendir that's -# provided. This version only works with V7-style directories. -#-------------------------------------------------------------------- - -AC_CHECK_FUNC(opendir, , [AC_DEFINE(USE_DIRENT2_H, 1, [May we include ?])]) - -#-------------------------------------------------------------------- -# The check below checks whether defines the type -# "union wait" correctly. It's needed because of weirdness in -# HP-UX where "union wait" is defined in both the BSD and SYS-V -# environments. Checking the usability of WIFEXITED seems to do -# the trick. -#-------------------------------------------------------------------- - -AC_CACHE_CHECK([union wait], tcl_cv_union_wait, [ - AC_TRY_LINK([#include -#include ], [ -union wait x; -WIFEXITED(x); /* Generates compiler error if WIFEXITED - * uses an int. */ - ], tcl_cv_union_wait=yes, tcl_cv_union_wait=no)]) -if test $tcl_cv_union_wait = no; then - AC_DEFINE(NO_UNION_WAIT, 1, [Do we have a usable 'union wait'?]) -fi - -#-------------------------------------------------------------------- -# Check whether there is an strncasecmp function on this system. -# This is a bit tricky because under SCO it's in -lsocket and -# under Sequent Dynix it's in -linet. -#-------------------------------------------------------------------- - -AC_CHECK_FUNC(strncasecmp, tcl_ok=1, tcl_ok=0) -if test "$tcl_ok" = 0; then - AC_CHECK_LIB(socket, strncasecmp, tcl_ok=1, tcl_ok=0) -fi -if test "$tcl_ok" = 0; then - AC_CHECK_LIB(inet, strncasecmp, tcl_ok=1, tcl_ok=0) -fi -if test "$tcl_ok" = 0; then - AC_LIBOBJ([strncasecmp]) - USE_COMPAT=1 -fi - -#-------------------------------------------------------------------- -# The code below deals with several issues related to gettimeofday: -# 1. Some systems don't provide a gettimeofday function at all -# (set NO_GETTOD if this is the case). -# 2. See if gettimeofday is declared in the header file. -# if not, set the GETTOD_NOT_DECLARED flag so that tclPort.h can -# declare it. -#-------------------------------------------------------------------- - -AC_CHECK_FUNC(gettimeofday,[],[ - AC_DEFINE(NO_GETTOD, 1, [Do we have gettimeofday()?]) -]) -AC_CACHE_CHECK([for gettimeofday declaration], tcl_cv_grep_gettimeofday, [ - AC_EGREP_HEADER(gettimeofday, sys/time.h, - tcl_cv_grep_gettimeofday=present, tcl_cv_grep_gettimeofday=missing)]) -if test $tcl_cv_grep_gettimeofday = missing ; then - AC_DEFINE(GETTOD_NOT_DECLARED, 1, [Is gettimeofday() actually declared in ?]) -fi - -#-------------------------------------------------------------------- -# The following code checks to see whether it is possible to get -# signed chars on this platform. This is needed in order to -# properly generate sign-extended ints from character values. -#-------------------------------------------------------------------- - -AC_C_CHAR_UNSIGNED -AC_CACHE_CHECK([signed char declarations], tcl_cv_char_signed, [ - AC_TRY_COMPILE(, [ - signed char *p; - p = 0; - ], tcl_cv_char_signed=yes, tcl_cv_char_signed=no)]) -if test $tcl_cv_char_signed = yes; then - AC_DEFINE(HAVE_SIGNED_CHAR, 1, [Are characters signed?]) -fi - -#-------------------------------------------------------------------- -# Does putenv() copy or not? We need to know to avoid memory leaks. -#-------------------------------------------------------------------- - -AC_CACHE_CHECK([for a putenv() that copies the buffer], tcl_cv_putenv_copy, [ - AC_TRY_RUN([ - #include - #define OURVAR "havecopy=yes" - int main (int argc, char *argv[]) - { - char *foo, *bar; - foo = (char *)strdup(OURVAR); - putenv(foo); - strcpy((char *)(strchr(foo, '=') + 1), "no"); - bar = getenv("havecopy"); - if (!strcmp(bar, "no")) { - /* doesnt copy */ - return 0; - } else { - /* does copy */ - return 1; - } - } - ], - tcl_cv_putenv_copy=no, - tcl_cv_putenv_copy=yes, - tcl_cv_putenv_copy=no)]) -if test $tcl_cv_putenv_copy = yes; then - AC_DEFINE(HAVE_PUTENV_THAT_COPIES, 1, - [Does putenv() copy strings or incorporate them by reference?]) -fi - -#-------------------------------------------------------------------- -# Check for support of nl_langinfo function -#-------------------------------------------------------------------- - -SC_ENABLE_LANGINFO - -#-------------------------------------------------------------------- -# Check for support of cfmakeraw, chflags and mkstemps functions -#-------------------------------------------------------------------- - -AC_CHECK_FUNCS(cfmakeraw chflags mkstemps) - -#-------------------------------------------------------------------- -# Check for support of isnan() function or macro -#-------------------------------------------------------------------- - -AC_CACHE_CHECK([isnan], tcl_cv_isnan, [ - AC_TRY_LINK([#include ], [ -isnan(0.0); /* Generates an error if isnan is missing */ -], tcl_cv_isnan=yes, tcl_cv_isnan=no)]) -if test $tcl_cv_isnan = no; then - AC_DEFINE(NO_ISNAN, 1, [Do we have a usable 'isnan'?]) -fi - -#-------------------------------------------------------------------- -# Darwin specific API checks and defines -#-------------------------------------------------------------------- - -if test "`uname -s`" = "Darwin" ; then - AC_CHECK_FUNCS(getattrlist) - AC_CHECK_HEADERS(copyfile.h) - AC_CHECK_FUNCS(copyfile) - if test $tcl_corefoundation = yes; then - AC_CHECK_HEADERS(libkern/OSAtomic.h) - AC_CHECK_FUNCS(OSSpinLockLock) - fi - AC_DEFINE(USE_VFORK, 1, [Should we use vfork() instead of fork()?]) - AC_DEFINE(TCL_DEFAULT_ENCODING, "utf-8", - [Are we to override what our default encoding is?]) - AC_DEFINE(TCL_LOAD_FROM_MEMORY, 1, - [Can this platform load code from memory?]) - AC_DEFINE(TCL_WIDE_CLICKS, 1, - [Does this platform have wide high-resolution clicks?]) - AC_CHECK_HEADERS(AvailabilityMacros.h) - if test "$ac_cv_header_AvailabilityMacros_h" = yes; then - AC_CACHE_CHECK([if weak import is available], tcl_cv_cc_weak_import, [ - hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror" - AC_TRY_LINK([ - #ifdef __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ - #if __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ < 1020 - #error __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ < 1020 - #endif - #elif MAC_OS_X_VERSION_MIN_REQUIRED < 1020 - #error MAC_OS_X_VERSION_MIN_REQUIRED < 1020 - #endif - int rand(void) __attribute__((weak_import)); - ], [rand();], - tcl_cv_cc_weak_import=yes, tcl_cv_cc_weak_import=no) - CFLAGS=$hold_cflags]) - if test $tcl_cv_cc_weak_import = yes; then - AC_DEFINE(HAVE_WEAK_IMPORT, 1, [Is weak import available?]) - fi - AC_CACHE_CHECK([if Darwin SUSv3 extensions are available], - tcl_cv_cc_darwin_c_source, [ - hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror" - AC_TRY_COMPILE([ - #ifdef __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ - #if __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ < 1050 - #error __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ < 1050 - #endif - #elif MAC_OS_X_VERSION_MIN_REQUIRED < 1050 - #error MAC_OS_X_VERSION_MIN_REQUIRED < 1050 - #endif - #define _DARWIN_C_SOURCE 1 - #include - ],,tcl_cv_cc_darwin_c_source=yes, tcl_cv_cc_darwin_c_source=no) - CFLAGS=$hold_cflags]) - if test $tcl_cv_cc_darwin_c_source = yes; then - AC_DEFINE(_DARWIN_C_SOURCE, 1, - [Are Darwin SUSv3 extensions available?]) - fi - fi - # Build .bundle dltest binaries in addition to .dylib - DLTEST_LD='${CC} -bundle -Wl,-w ${CFLAGS} ${LDFLAGS}' - DLTEST_SUFFIX=".bundle" -else - DLTEST_LD='${SHLIB_LD}' - DLTEST_SUFFIX="" -fi - -#-------------------------------------------------------------------- -# Check for support of fts functions (readdir replacement) -#-------------------------------------------------------------------- - -AC_CACHE_CHECK([for fts], tcl_cv_api_fts, [ - AC_TRY_LINK([ - #include - #include - #include - ], [ - char*const p[2] = {"/", NULL}; - FTS *f = fts_open(p, FTS_PHYSICAL|FTS_NOCHDIR|FTS_NOSTAT, NULL); - FTSENT *e = fts_read(f); fts_close(f); - ], tcl_cv_api_fts=yes, tcl_cv_api_fts=no)]) -if test $tcl_cv_api_fts = yes; then - AC_DEFINE(HAVE_FTS, 1, [Do we have fts functions?]) -fi - -#-------------------------------------------------------------------- -# The statements below check for systems where POSIX-style non-blocking -# I/O (O_NONBLOCK) doesn't work or is unimplemented. On these systems -# (mostly older ones), use the old BSD-style FIONBIO approach instead. -#-------------------------------------------------------------------- - -SC_BLOCKING_STYLE - -#------------------------------------------------------------------------ - -AC_MSG_CHECKING([whether to use dll unloading]) -AC_ARG_ENABLE(dll-unloading, - AC_HELP_STRING([--enable-dll-unloading], - [enable the 'unload' command (default: on)]), - [tcl_ok=$enableval], [tcl_ok=yes]) -if test $tcl_ok = yes; then - AC_DEFINE(TCL_UNLOAD_DLLS, 1, [Do we allow unloading of shared libraries?]) -fi -AC_MSG_RESULT([$tcl_ok]) - -#------------------------------------------------------------------------ -# Check whether the timezone data is supplied by the OS or has -# to be installed by Tcl. The default is autodetection, but can -# be overriden on the configure command line either way. -#------------------------------------------------------------------------ - -AC_MSG_CHECKING([for timezone data]) -AC_ARG_WITH(tzdata, - AC_HELP_STRING([--with-tzdata], - [install timezone data (default: autodetect)]), - [tcl_ok=$withval], [tcl_ok=auto]) -# -# Any directories that get added here must also be added to the -# search path in ::tcl::clock::Initialize (library/clock.tcl). -# -case $tcl_ok in - no) - AC_MSG_RESULT([supplied by OS vendor]) - ;; - yes) - # nothing to do here - ;; - auto*) - AC_CACHE_VAL([tcl_cv_dir_zoneinfo], [ - for dir in /usr/share/zoneinfo \ - /usr/share/lib/zoneinfo \ - /usr/lib/zoneinfo - do - if test -f $dir/UTC -o -f $dir/GMT - then - tcl_cv_dir_zoneinfo="$dir" - break - fi - done]) - if test -n "$tcl_cv_dir_zoneinfo"; then - tcl_ok=no - AC_MSG_RESULT([$dir]) - else - tcl_ok=yes - fi - ;; - *) - AC_MSG_ERROR([invalid argument: $tcl_ok]) - ;; -esac -if test $tcl_ok = yes -then - AC_MSG_RESULT([supplied by Tcl]) - INSTALL_TZDATA=install-tzdata -fi - -#-------------------------------------------------------------------- -# DTrace support -#-------------------------------------------------------------------- - -AC_ARG_ENABLE(dtrace, - AC_HELP_STRING([--enable-dtrace], - [build with DTrace support (default: off)]), - [tcl_ok=$enableval], [tcl_ok=no]) -if test $tcl_ok = yes; then - AC_CHECK_HEADER(sys/sdt.h, [tcl_ok=yes], [tcl_ok=no]) -fi -if test $tcl_ok = yes; then - AC_PATH_PROG(DTRACE, dtrace,, [$PATH:/usr/sbin]) - test -z "$ac_cv_path_DTRACE" && tcl_ok=no -fi -AC_MSG_CHECKING([whether to enable DTrace support]) -MAKEFILE_SHELL='/bin/sh' -if test $tcl_ok = yes; then - AC_DEFINE(USE_DTRACE, 1, [Are we building with DTrace support?]) - DTRACE_SRC="\${DTRACE_SRC}" - DTRACE_HDR="\${DTRACE_HDR}" - if test "`uname -s`" != "Darwin" ; then - DTRACE_OBJ="\${DTRACE_OBJ}" - if test "`uname -s`" = "SunOS" -a "$SHARED_BUILD" = "0" ; then - # Need to create an intermediate object file to ensure tclDTrace.o - # gets included when linking against the static tcl library. - STLIB_LD='stlib_ld () { /usr/ccs/bin/ld -r -o $${1%.a}.o "$${@:2}" && '"${STLIB_LD}"' $${1} $${1%.a}.o ; } && stlib_ld' - MAKEFILE_SHELL='/bin/bash' - # Force use of Sun ar and ranlib, the GNU versions choke on - # tclDTrace.o and the combined object file above. - AR='/usr/ccs/bin/ar' - RANLIB='/usr/ccs/bin/ranlib' - fi - fi -fi -AC_MSG_RESULT([$tcl_ok]) - -#-------------------------------------------------------------------- -# Zipfs support - Tip 430 -#-------------------------------------------------------------------- -AC_ARG_ENABLE(zipfs, - AC_HELP_STRING([--enable-zipfs], - [build with Zipfs support (default: on)]), - [tcl_ok=$enableval], [tcl_ok=yes]) -if test "$tcl_ok" = "yes" ; then - # - # Find a native compiler - # - AX_CC_FOR_BUILD - # - # Find a native zip implementation - # - SC_ZIPFS_SUPPORT - ZIPFS_BUILD=1 - TCL_ZIP_FILE=libtcl_${TCL_MAJOR_VERSION}_${TCL_MINOR_VERSION}_${TCL_PATCH_LEVEL}.zip -else - ZIPFS_BUILD=0 - TCL_ZIP_FILE= -fi -# Do checking message here to not mess up interleaved configure output -AC_MSG_CHECKING([for building with zipfs]) -if test "${ZIPFS_BUILD}" = 1; then - if test "${SHARED_BUILD}" = 0; then - ZIPFS_BUILD=2; - AC_DEFINE(ZIPFS_BUILD, 2, [Are we building with zipfs enabled?]) - INSTALL_LIBRARIES=install-libraries-zipfs-static - AC_MSG_RESULT([yes]) - else - AC_DEFINE(ZIPFS_BUILD, 1, [Are we building with zipfs enabled?])\ - INSTALL_LIBRARIES=install-libraries-zipfs-shared - AC_MSG_RESULT([yes]) - fi -else -AC_MSG_RESULT([no]) -INSTALL_LIBRARIES=install-libraries -INSTALL_MSGS=install-msgs -fi -AC_SUBST(ZIPFS_BUILD) -AC_SUBST(TCL_ZIP_FILE) -AC_SUBST(INSTALL_LIBRARIES) -AC_SUBST(INSTALL_MSGS) - - -#-------------------------------------------------------------------- -# The check below checks whether the cpuid instruction is usable. -#-------------------------------------------------------------------- - -AC_CACHE_CHECK([whether the cpuid instruction is usable], tcl_cv_cpuid, [ - AC_TRY_LINK(, [ - int index,regsPtr[4]; - __asm__ __volatile__("mov %%ebx, %%edi \n\t" - "cpuid \n\t" - "mov %%ebx, %%esi \n\t" - "mov %%edi, %%ebx \n\t" - : "=a"(regsPtr[0]), "=S"(regsPtr[1]), "=c"(regsPtr[2]), "=d"(regsPtr[3]) - : "a"(index) : "edi"); - ], tcl_cv_cpuid=yes, tcl_cv_cpuid=no)]) -if test $tcl_cv_cpuid = yes; then - AC_DEFINE(HAVE_CPUID, 1, [Is the cpuid instruction usable?]) -fi - -#-------------------------------------------------------------------- -# The statements below define a collection of symbols related to -# building libtcl as a shared library instead of a static library. -#-------------------------------------------------------------------- - -TCL_UNSHARED_LIB_SUFFIX=${UNSHARED_LIB_SUFFIX} -TCL_SHARED_LIB_SUFFIX=${SHARED_LIB_SUFFIX} -eval "TCL_LIB_FILE=libtcl${LIB_SUFFIX}" - -# tclConfig.sh needs a version of the _LIB_SUFFIX that has been eval'ed -# since on some platforms TCL_LIB_FILE contains shell escapes. -# (See also: TCL_TRIM_DOTS). - -eval "TCL_LIB_FILE=${TCL_LIB_FILE}" - -TCL_LIBRARY='$(prefix)/lib/tcl$(VERSION)' -PRIVATE_INCLUDE_DIR='$(includedir)' -HTML_DIR='$(DISTDIR)/html' - -# Note: in the following variable, it's important to use the absolute -# path name of the Tcl directory rather than "..": this is because -# AIX remembers this path and will attempt to use it at run-time to look -# up the Tcl library. - -if test "`uname -s`" = "Darwin" ; then - SC_ENABLE_FRAMEWORK - TCL_SHLIB_LD_EXTRAS="-compatibility_version ${TCL_VERSION} -current_version ${TCL_VERSION}`echo ${TCL_PATCH_LEVEL} | awk ['{match($0, "\\\.[0-9]+"); print substr($0,RSTART,RLENGTH)}']`" - TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -install_name "${DYLIB_INSTALL_DIR}"/${TCL_LIB_FILE}' - echo "$LDFLAGS " | grep -q -- '-prebind ' && TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -seg1addr 0xa000000' - TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -sectcreate __TEXT __info_plist Tcl-Info.plist' - EXTRA_TCLSH_LIBS='-sectcreate __TEXT __info_plist Tclsh-Info.plist' - EXTRA_APP_CC_SWITCHES='-mdynamic-no-pic' - AC_CONFIG_FILES([Tcl-Info.plist:../macosx/Tcl-Info.plist.in Tclsh-Info.plist:../macosx/Tclsh-Info.plist.in]) - TCL_YEAR="`date +%Y`" -fi - -if test "$FRAMEWORK_BUILD" = "1" ; then - AC_DEFINE(TCL_FRAMEWORK, 1, [Is Tcl built as a framework?]) - # Construct a fake local framework structure to make linking with - # '-framework Tcl' and running of tcltest work - AC_CONFIG_COMMANDS([Tcl.framework], [n=Tcl && - f=$n.framework && v=Versions/$VERSION && - rm -rf $f && mkdir -p $f/$v/Resources && - ln -s $v/$n $v/Resources $f && ln -s ../../../$n $f/$v && - ln -s ../../../../$n-Info.plist $f/$v/Resources/Info.plist && - unset n f v - ], VERSION=${TCL_VERSION}) - LD_LIBRARY_PATH_VAR="DYLD_FRAMEWORK_PATH" - # default install directory for bundled packages - if test "${libdir}" = '${exec_prefix}/lib' -o "`basename ${libdir}`" = 'Frameworks'; then - PACKAGE_DIR="/Library/Tcl" - else - PACKAGE_DIR="$libdir" - fi - if test "${libdir}" = '${exec_prefix}/lib'; then - # override libdir default - libdir="/Library/Frameworks" - fi - TCL_LIB_FILE="Tcl" - TCL_LIB_FLAG="-framework Tcl" - TCL_BUILD_LIB_SPEC="-F`pwd | sed -e 's/ /\\\\ /g'` -framework Tcl" - TCL_LIB_SPEC="-F${libdir} -framework Tcl" - libdir="${libdir}/Tcl.framework/Versions/\${VERSION}" - TCL_LIBRARY="${libdir}/Resources/Scripts" - includedir="${libdir}/Headers" - PRIVATE_INCLUDE_DIR="${libdir}/PrivateHeaders" - HTML_DIR="${libdir}/Resources/Documentation/Reference/Tcl" - EXTRA_INSTALL="install-private-headers html-tcl" - EXTRA_BUILD_HTML='@ln -fs contents.htm "$(HTML_INSTALL_DIR)"/TclTOC.html' - EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA_DIR) "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"' - EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing license.terms to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA) "$(TOP_DIR)/license.terms" "$(LIB_INSTALL_DIR)/Resources"' - EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Finalizing Tcl.framework" && rm -f "$(LIB_INSTALL_DIR)/../Current" && ln -s "$(VERSION)" "$(LIB_INSTALL_DIR)/../Current" && for f in "$(LIB_FILE)" tclConfig.sh Resources Headers PrivateHeaders; do rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/Current/$$f" "$(LIB_INSTALL_DIR)/../.."; done && f="$(STUB_LIB_FILE)" && rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/$(VERSION)/$$f" "$(LIB_INSTALL_DIR)/../.."' - # Don't use AC_DEFINE for the following as the framework version define - # needs to go into the Makefile even when using autoheader, so that we - # can pick up a potential make override of VERSION. Also, don't put this - # into CFLAGS as it should not go into tclConfig.sh - EXTRA_CC_SWITCHES='-DTCL_FRAMEWORK_VERSION=\"$(VERSION)\"' -else - # libdir must be a fully qualified path and not ${exec_prefix}/lib - eval libdir="$libdir" - # default install directory for bundled packages - PACKAGE_DIR="$libdir" - if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then - TCL_LIB_FLAG="-ltcl${TCL_VERSION}" - else - TCL_LIB_FLAG="-ltcl`echo ${TCL_VERSION} | tr -d .`" - fi - TCL_BUILD_LIB_SPEC="-L`pwd | sed -e 's/ /\\\\ /g'` ${TCL_LIB_FLAG}" - TCL_LIB_SPEC="-L${libdir} ${TCL_LIB_FLAG}" -fi -VERSION='${VERSION}' -eval "CFG_TCL_SHARED_LIB_SUFFIX=${TCL_SHARED_LIB_SUFFIX}" -eval "CFG_TCL_UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX}" -VERSION=${TCL_VERSION} - -#-------------------------------------------------------------------- -# The statements below define the symbol TCL_PACKAGE_PATH, which -# gives a list of directories that may contain packages. The list -# consists of one directory for machine-dependent binaries and -# another for platform-independent scripts. -#-------------------------------------------------------------------- - -if test "$FRAMEWORK_BUILD" = "1" ; then - test -z "$TCL_PACKAGE_PATH" && \ - TCL_PACKAGE_PATH="~/Library/Tcl /Library/Tcl /System/Library/Tcl ~/Library/Frameworks /Library/Frameworks /System/Library/Frameworks" - test -z "$TCL_MODULE_PATH" && \ - TCL_MODULE_PATH="~/Library/Tcl /Library/Tcl /System/Library/Tcl" -elif test "$prefix/lib" != "$libdir"; then - TCL_PACKAGE_PATH="${libdir} ${prefix}/lib ${TCL_PACKAGE_PATH}" -else - TCL_PACKAGE_PATH="${prefix}/lib ${TCL_PACKAGE_PATH}" -fi - -#-------------------------------------------------------------------- -# The statements below define various symbols relating to Tcl -# stub support. -#-------------------------------------------------------------------- - -# Replace ${VERSION} with contents of ${TCL_VERSION} -# double-eval to account for TCL_TRIM_DOTS. -# -eval "TCL_STUB_LIB_FILE=libtclstub${TCL_UNSHARED_LIB_SUFFIX}" -eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\"" -eval "TCL_STUB_LIB_DIR=${libdir}" - -if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then - TCL_STUB_LIB_FLAG="-ltclstub${TCL_VERSION}" -else - TCL_STUB_LIB_FLAG="-ltclstub`echo ${TCL_VERSION} | tr -d .`" -fi - -TCL_BUILD_STUB_LIB_SPEC="-L`pwd | sed -e 's/ /\\\\ /g'` ${TCL_STUB_LIB_FLAG}" -TCL_STUB_LIB_SPEC="-L${TCL_STUB_LIB_DIR} ${TCL_STUB_LIB_FLAG}" -TCL_BUILD_STUB_LIB_PATH="`pwd`/${TCL_STUB_LIB_FILE}" -TCL_STUB_LIB_PATH="${TCL_STUB_LIB_DIR}/${TCL_STUB_LIB_FILE}" - -# Install time header dir can be set via --includedir -eval "TCL_INCLUDE_SPEC=\"-I${includedir}\"" - -#------------------------------------------------------------------------ -# tclConfig.sh refers to this by a different name -#------------------------------------------------------------------------ - -TCL_SHARED_BUILD=${SHARED_BUILD} - -AC_SUBST(TCL_VERSION) -AC_SUBST(TCL_MAJOR_VERSION) -AC_SUBST(TCL_MINOR_VERSION) -AC_SUBST(TCL_PATCH_LEVEL) -AC_SUBST(TCL_YEAR) -AC_SUBST(PKG_CFG_ARGS) - -AC_SUBST(TCL_ZIP_FILE) -AC_SUBST(TCL_LIB_FILE) -AC_SUBST(TCL_LIB_FLAG) -AC_SUBST(TCL_LIB_SPEC) -AC_SUBST(TCL_STUB_LIB_FILE) -AC_SUBST(TCL_STUB_LIB_FLAG) -AC_SUBST(TCL_STUB_LIB_SPEC) -AC_SUBST(TCL_STUB_LIB_PATH) -AC_SUBST(TCL_INCLUDE_SPEC) -AC_SUBST(TCL_BUILD_STUB_LIB_SPEC) -AC_SUBST(TCL_BUILD_STUB_LIB_PATH) - -AC_SUBST(TCL_SRC_DIR) -AC_SUBST(CFG_TCL_SHARED_LIB_SUFFIX) -AC_SUBST(CFG_TCL_UNSHARED_LIB_SUFFIX) - -AC_SUBST(TCL_SHARED_BUILD) -AC_SUBST(LD_LIBRARY_PATH_VAR) - -AC_SUBST(TCL_BUILD_LIB_SPEC) - -AC_SUBST(TCL_LIB_VERSIONS_OK) -AC_SUBST(TCL_SHARED_LIB_SUFFIX) -AC_SUBST(TCL_UNSHARED_LIB_SUFFIX) - -AC_SUBST(TCL_HAS_LONGLONG) - -AC_SUBST(INSTALL_TZDATA) - -AC_SUBST(DTRACE_SRC) -AC_SUBST(DTRACE_HDR) -AC_SUBST(DTRACE_OBJ) -AC_SUBST(MAKEFILE_SHELL) - -AC_SUBST(BUILD_DLTEST) -AC_SUBST(TCL_PACKAGE_PATH) -AC_SUBST(TCL_MODULE_PATH) - -AC_SUBST(TCL_LIBRARY) -AC_SUBST(PRIVATE_INCLUDE_DIR) -AC_SUBST(HTML_DIR) -AC_SUBST(PACKAGE_DIR) - -AC_SUBST(EXTRA_CC_SWITCHES) -AC_SUBST(EXTRA_APP_CC_SWITCHES) -AC_SUBST(EXTRA_INSTALL) -AC_SUBST(EXTRA_INSTALL_BINARIES) -AC_SUBST(EXTRA_BUILD_HTML) -AC_SUBST(EXTRA_TCLSH_LIBS) - -AC_SUBST(DLTEST_LD) -AC_SUBST(DLTEST_SUFFIX) - -dnl Disable the automake-friendly normalization of LIBOBJS -dnl performed by autoconf 2.53 and later. It's not correct for us. -define([_AC_LIBOBJS_NORMALIZE],[]) -AC_CONFIG_FILES([ - Makefile:../unix/Makefile.in - dltest/Makefile:../unix/dltest/Makefile.in - tclConfig.sh:../unix/tclConfig.sh.in - tcl.pc:../unix/tcl.pc.in -]) -AC_OUTPUT - -dnl Local Variables: -dnl mode: autoconf -dnl End: ADDED unix/configure.in Index: unix/configure.in ================================================================== --- /dev/null +++ unix/configure.in @@ -0,0 +1,977 @@ +#! /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],[8.6]) +AC_PREREQ(2.59) + +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"]) + AH_TOP([ + #ifndef _TCLCONFIG + #define _TCLCONFIG]) + AH_BOTTOM([ + /* Undef unused package specific autoheader defines so that we can + * include both tclConfig.h and tkConfig.h at the same time: */ + /* override */ #undef PACKAGE_NAME + /* override */ #undef PACKAGE_STRING + /* override */ #undef PACKAGE_TARNAME + #endif /* _TCLCONFIG */]) +]) + +TCL_VERSION=8.6 +TCL_MAJOR_VERSION=8 +TCL_MINOR_VERSION=6 +TCL_PATCH_LEVEL=".10" +VERSION=${TCL_VERSION} + +EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} +EXTRA_BUILD_HTML=${EXTRA_BUILD_HTML:-"@:"} + +#------------------------------------------------------------------------ +# Setup configure arguments for bundled packages +#------------------------------------------------------------------------ + +PKG_CFG_ARGS="$ac_configure_args ${PKG_CFG_ARGS}" + +if test -r "$cache_file" -a -f "$cache_file"; then + case $cache_file in + [[\\/]]* | ?:[[\\/]]* ) pkg_cache_file=$cache_file ;; + *) pkg_cache_file=../../$cache_file ;; + esac + PKG_CFG_ARGS="${PKG_CFG_ARGS} --cache-file=$pkg_cache_file" +fi + +#------------------------------------------------------------------------ +# Empty slate for bundled packages, to avoid stale configuration +#------------------------------------------------------------------------ +#rm -Rf pkgs +if test -f Makefile; then + make distclean-packages +fi + +#------------------------------------------------------------------------ +# Handle the --prefix=... option +#------------------------------------------------------------------------ + +if test "${prefix}" = "NONE"; then + prefix=/usr/local +fi +if test "${exec_prefix}" = "NONE"; then + exec_prefix=$prefix +fi +# Make sure srcdir is fully qualified! +srcdir="`cd "$srcdir" ; pwd`" +TCL_SRC_DIR="`cd "$srcdir"/..; pwd`" + +#------------------------------------------------------------------------ +# Compress and/or soft link the manpages? +#------------------------------------------------------------------------ + +SC_CONFIG_MANPAGES + +#------------------------------------------------------------------------ +# Standard compiler checks +#------------------------------------------------------------------------ + +# If the user did not set CFLAGS, set it now to keep +# the AC_PROG_CC macro from adding "-g -O2". +if test "${CFLAGS+set}" != "set" ; then + CFLAGS="" +fi + +AC_PROG_CC +AC_C_INLINE + +#-------------------------------------------------------------------- +# Supply substitutes for missing POSIX header files. Special notes: +# - stdlib.h doesn't define strtol, strtoul, or +# strtod insome versions of SunOS +# - some versions of string.h don't declare procedures such +# as strstr +# Do this early, otherwise an autoconf bug throws errors on configure +#-------------------------------------------------------------------- + +SC_MISSING_POSIX_HEADERS + +#-------------------------------------------------------------------- +# Determines the correct executable file extension (.exe) +#-------------------------------------------------------------------- + +AC_EXEEXT + +#------------------------------------------------------------------------ +# If we're using GCC, see if the compiler understands -pipe. If so, use it. +# It makes compiling go faster. (This is only a performance feature.) +#------------------------------------------------------------------------ + +if test -z "$no_pipe" && test -n "$GCC"; then + AC_CACHE_CHECK([if the compiler understands -pipe], + tcl_cv_cc_pipe, [ + hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -pipe" + AC_TRY_COMPILE(,, tcl_cv_cc_pipe=yes, tcl_cv_cc_pipe=no) + CFLAGS=$hold_cflags]) + if test $tcl_cv_cc_pipe = yes; then + CFLAGS="$CFLAGS -pipe" + fi +fi + +#------------------------------------------------------------------------ +# Threads support +#------------------------------------------------------------------------ + +SC_ENABLE_THREADS + +#------------------------------------------------------------------------ +# Embedded configuration information, encoding to use for the values, TIP #59 +#------------------------------------------------------------------------ + +SC_TCL_CFG_ENCODING + +#-------------------------------------------------------------------- +# Look for libraries that we will need when compiling the Tcl shell +#-------------------------------------------------------------------- + +SC_TCL_LINK_LIBS + +# Add the threads support libraries +LIBS="$LIBS$THREADS_LIBS" + +SC_ENABLE_SHARED + +#-------------------------------------------------------------------- +# Look for a native installed tclsh binary (if available) +# If one cannot be found then use the binary we build (fails for +# cross compiling). This is used for NATIVE_TCLSH in Makefile. +#-------------------------------------------------------------------- + +SC_PROG_TCLSH +if test "$TCLSH_PROG" = ""; then + TCLSH_PROG='./${TCL_EXE}' +fi + +#------------------------------------------------------------------------ +# Add stuff for zlib +#------------------------------------------------------------------------ + +zlib_ok=yes +AC_CHECK_HEADER([zlib.h],[ + AC_CHECK_TYPE([gz_header],[],[zlib_ok=no],[#include ])],[ + zlib_ok=no]) +AS_IF([test $zlib_ok = yes], [ + AC_SEARCH_LIBS([deflateSetHeader],[z],[],[ + zlib_ok=no + ])]) +AS_IF([test $zlib_ok = no], [ + AC_SUBST(ZLIB_OBJS,[\${ZLIB_OBJS}]) + AC_SUBST(ZLIB_SRCS,[\${ZLIB_SRCS}]) + AC_SUBST(ZLIB_INCLUDE,[-I\${ZLIB_DIR}]) +]) +AC_DEFINE(HAVE_ZLIB, 1, [Is there an installed zlib?]) + +#-------------------------------------------------------------------- +# The statements below define a collection of compile flags. This +# macro depends on the value of SHARED_BUILD, and should be called +# after SC_ENABLE_SHARED checks the configure switches. +#-------------------------------------------------------------------- + +SC_CONFIG_CFLAGS + +SC_ENABLE_SYMBOLS(bccdebug) + +AC_DEFINE(TCL_TOMMATH, 1, [Build libtommath?]) +AC_DEFINE(MP_PREC, 4, [Default libtommath precision.]) + +#-------------------------------------------------------------------- +# Detect what compiler flags to set for 64-bit support. +#-------------------------------------------------------------------- + +SC_TCL_EARLY_FLAGS + +SC_TCL_64BIT_FLAGS + +#-------------------------------------------------------------------- +# Check endianness because we can optimize comparisons of +# Tcl_UniChar strings to memcmp on big-endian systems. +#-------------------------------------------------------------------- + +AC_C_BIGENDIAN + +#-------------------------------------------------------------------- +# Supply substitutes for missing POSIX library procedures, or +# set flags so Tcl uses alternate procedures. +#-------------------------------------------------------------------- + +# Check if Posix compliant getcwd exists, if not we'll use getwd. +AC_CHECK_FUNCS(getcwd, , [AC_DEFINE(USEGETWD, 1, [Is getcwd Posix-compliant?])]) +# Nb: if getcwd uses popen and pwd(1) (like SunOS 4) we should really +# define USEGETWD even if the posix getcwd exists. Add a test ? + +AC_REPLACE_FUNCS(mkstemp opendir strtol waitpid) +AC_CHECK_FUNC(strerror, , [AC_DEFINE(NO_STRERROR, 1, [Do we have strerror()])]) +AC_CHECK_FUNC(getwd, , [AC_DEFINE(NO_GETWD, 1, [Do we have getwd()])]) +AC_CHECK_FUNC(wait3, , [AC_DEFINE(NO_WAIT3, 1, [Do we have wait3()])]) +AC_CHECK_FUNC(uname, , [AC_DEFINE(NO_UNAME, 1, [Do we have uname()])]) + +if test "`uname -s`" = "Darwin" && test "${TCL_THREADS}" = 1 && \ + test "`uname -r | awk -F. '{print [$]1}'`" -lt 7; then + # prior to Darwin 7, realpath is not threadsafe, so don't + # use it when threads are enabled, c.f. bug # 711232 + ac_cv_func_realpath=no +fi +AC_CHECK_FUNC(realpath, , [AC_DEFINE(NO_REALPATH, 1, [Do we have realpath()])]) + +SC_TCL_IPV6 + +#-------------------------------------------------------------------- +# Look for thread-safe variants of some library functions. +#-------------------------------------------------------------------- + +if test "${TCL_THREADS}" = 1; then + SC_TCL_GETPWUID_R + SC_TCL_GETPWNAM_R + SC_TCL_GETGRGID_R + SC_TCL_GETGRNAM_R + if test "`uname -s`" = "Darwin" && \ + test "`uname -r | awk -F. '{print [$]1}'`" -gt 5; then + # Starting with Darwin 6 (Mac OSX 10.2), gethostbyX + # are actually MT-safe as they always return pointers + # from TSD instead of static storage. + AC_DEFINE(HAVE_MTSAFE_GETHOSTBYNAME, 1, + [Do we have MT-safe gethostbyname() ?]) + AC_DEFINE(HAVE_MTSAFE_GETHOSTBYADDR, 1, + [Do we have MT-safe gethostbyaddr() ?]) + + elif test "`uname -s`" = "HP-UX" && \ + test "`uname -r|sed -e 's|B\.||' -e 's|\..*$||'`" -gt 10; then + # Starting with HPUX 11.00 (we believe), gethostbyX + # are actually MT-safe as they always return pointers + # from TSD instead of static storage. + AC_DEFINE(HAVE_MTSAFE_GETHOSTBYNAME, 1, + [Do we have MT-safe gethostbyname() ?]) + AC_DEFINE(HAVE_MTSAFE_GETHOSTBYADDR, 1, + [Do we have MT-safe gethostbyaddr() ?]) + + else + SC_TCL_GETHOSTBYNAME_R + SC_TCL_GETHOSTBYADDR_R + fi +fi + +#--------------------------------------------------------------------------- +# Check for serial port interface. +# +# termios.h is present on all POSIX systems. +# sys/ioctl.h is almost always present, though what it contains +# is system-specific. +# sys/modem.h is needed on HP-UX. +#--------------------------------------------------------------------------- + +AC_CHECK_HEADERS(termios.h) +AC_CHECK_HEADERS(sys/ioctl.h) +AC_CHECK_HEADERS(sys/modem.h) + +#-------------------------------------------------------------------- +# Include sys/select.h if it exists and if it supplies things +# that appear to be useful and aren't already in sys/types.h. +# This appears to be true only on the RS/6000 under AIX. Some +# systems like OSF/1 have a sys/select.h that's of no use, and +# other systems like SCO UNIX have a sys/select.h that's +# pernicious. If "fd_set" isn't defined anywhere then set a +# special flag. +#-------------------------------------------------------------------- + +AC_CACHE_CHECK([for fd_set in sys/types], tcl_cv_type_fd_set, [ + AC_TRY_COMPILE([#include ],[fd_set readMask, writeMask;], + tcl_cv_type_fd_set=yes, tcl_cv_type_fd_set=no)]) +tcl_ok=$tcl_cv_type_fd_set +if test $tcl_ok = no; then + AC_CACHE_CHECK([for fd_mask in sys/select], tcl_cv_grep_fd_mask, [ + AC_EGREP_HEADER(fd_mask, sys/select.h, + tcl_cv_grep_fd_mask=present, tcl_cv_grep_fd_mask=missing)]) + if test $tcl_cv_grep_fd_mask = present; then + AC_DEFINE(HAVE_SYS_SELECT_H, 1, [Should we include ?]) + tcl_ok=yes + fi +fi +if test $tcl_ok = no; then + AC_DEFINE(NO_FD_SET, 1, [Do we have fd_set?]) +fi + +#------------------------------------------------------------------------------ +# Find out all about time handling differences. +#------------------------------------------------------------------------------ + +SC_TIME_HANDLER + +#-------------------------------------------------------------------- +# Some systems (e.g., IRIX 4.0.5) lack some fields in struct stat. But +# we might be able to use fstatfs instead. Some systems (OpenBSD?) also +# lack blkcnt_t. +#-------------------------------------------------------------------- + +if test "$ac_cv_cygwin" != "yes"; then + AC_CHECK_MEMBERS([struct stat.st_blocks, struct stat.st_blksize]) +fi +AC_CHECK_TYPES([blkcnt_t]) +AC_CHECK_FUNC(fstatfs, , [AC_DEFINE(NO_FSTATFS, 1, [Do we have fstatfs()?])]) + +#-------------------------------------------------------------------- +# Some system have no memcmp or it does not work with 8 bit data, this +# checks it and add memcmp.o to LIBOBJS if needed +#-------------------------------------------------------------------- + +AC_FUNC_MEMCMP + +#-------------------------------------------------------------------- +# Some system like SunOS 4 and other BSD like systems have no memmove +# (we assume they have bcopy instead). {The replacement define is in +# compat/string.h} +#-------------------------------------------------------------------- + +AC_CHECK_FUNC(memmove, , [ + AC_DEFINE(NO_MEMMOVE, 1, [Do we have memmove()?]) + AC_DEFINE(NO_STRING_H, 1, [Do we have ?]) ]) + +#-------------------------------------------------------------------- +# On some systems strstr is broken: it returns a pointer even even if +# the original string is empty. +#-------------------------------------------------------------------- + +SC_TCL_CHECK_BROKEN_FUNC(strstr, [ + exit(strstr("\0test", "test") ? 1 : 0); +]) + +#-------------------------------------------------------------------- +# Check for strtoul function. This is tricky because under some +# versions of AIX strtoul returns an incorrect terminator +# pointer for the string "0". +#-------------------------------------------------------------------- + +SC_TCL_CHECK_BROKEN_FUNC(strtoul, [ + char *term, *string = "0"; + exit(strtoul(string,&term,0) != 0 || term != string+1); +]) + +#-------------------------------------------------------------------- +# Check for various typedefs and provide substitutes if +# they don't exist. +#-------------------------------------------------------------------- + +AC_TYPE_MODE_T +AC_TYPE_PID_T +AC_TYPE_SIZE_T +AC_TYPE_UID_T + +AC_CACHE_CHECK([for socklen_t], tcl_cv_type_socklen_t, [ + AC_TRY_COMPILE([ + #include + #include + ],[ + socklen_t foo; + ],[tcl_cv_type_socklen_t=yes],[tcl_cv_type_socklen_t=no])]) +if test $tcl_cv_type_socklen_t = no; then + AC_DEFINE(socklen_t, int, [Define as int if socklen_t is not available]) +fi + +AC_CHECK_TYPE([intptr_t], [ + AC_DEFINE([HAVE_INTPTR_T], 1, [Do we have the intptr_t type?])], [ + AC_CACHE_CHECK([for pointer-size signed integer type], tcl_cv_intptr_t, [ + for tcl_cv_intptr_t in "int" "long" "long long" none; do + if test "$tcl_cv_intptr_t" != none; then + AC_COMPILE_IFELSE([AC_LANG_BOOL_COMPILE_TRY([AC_INCLUDES_DEFAULT], + [[sizeof (void *) <= sizeof ($tcl_cv_intptr_t)]])], + [tcl_ok=yes], [tcl_ok=no]) + test "$tcl_ok" = yes && break; fi + done]) + if test "$tcl_cv_intptr_t" != none; then + AC_DEFINE_UNQUOTED([intptr_t], [$tcl_cv_intptr_t], [Signed integer + type wide enough to hold a pointer.]) + fi +]) +AC_CHECK_TYPE([uintptr_t], [ + AC_DEFINE([HAVE_UINTPTR_T], 1, [Do we have the uintptr_t type?])], [ + AC_CACHE_CHECK([for pointer-size unsigned integer type], tcl_cv_uintptr_t, [ + for tcl_cv_uintptr_t in "unsigned int" "unsigned long" "unsigned long long" \ + none; do + if test "$tcl_cv_uintptr_t" != none; then + AC_COMPILE_IFELSE([AC_LANG_BOOL_COMPILE_TRY([AC_INCLUDES_DEFAULT], + [[sizeof (void *) <= sizeof ($tcl_cv_uintptr_t)]])], + [tcl_ok=yes], [tcl_ok=no]) + test "$tcl_ok" = yes && break; fi + done]) + if test "$tcl_cv_uintptr_t" != none; then + AC_DEFINE_UNQUOTED([uintptr_t], [$tcl_cv_uintptr_t], [Unsigned integer + type wide enough to hold a pointer.]) + fi +]) + +#-------------------------------------------------------------------- +# If a system doesn't have an opendir function (man, that's old!) +# then we have to supply a different version of dirent.h which +# is compatible with the substitute version of opendir that's +# provided. This version only works with V7-style directories. +#-------------------------------------------------------------------- + +AC_CHECK_FUNC(opendir, , [AC_DEFINE(USE_DIRENT2_H, 1, [May we include ?])]) + +#-------------------------------------------------------------------- +# The check below checks whether defines the type +# "union wait" correctly. It's needed because of weirdness in +# HP-UX where "union wait" is defined in both the BSD and SYS-V +# environments. Checking the usability of WIFEXITED seems to do +# the trick. +#-------------------------------------------------------------------- + +AC_CACHE_CHECK([union wait], tcl_cv_union_wait, [ + AC_TRY_LINK([#include +#include ], [ +union wait x; +WIFEXITED(x); /* Generates compiler error if WIFEXITED + * uses an int. */ + ], tcl_cv_union_wait=yes, tcl_cv_union_wait=no)]) +if test $tcl_cv_union_wait = no; then + AC_DEFINE(NO_UNION_WAIT, 1, [Do we have a usable 'union wait'?]) +fi + +#-------------------------------------------------------------------- +# Check whether there is an strncasecmp function on this system. +# This is a bit tricky because under SCO it's in -lsocket and +# under Sequent Dynix it's in -linet. +#-------------------------------------------------------------------- + +AC_CHECK_FUNC(strncasecmp, tcl_ok=1, tcl_ok=0) +if test "$tcl_ok" = 0; then + AC_CHECK_LIB(socket, strncasecmp, tcl_ok=1, tcl_ok=0) +fi +if test "$tcl_ok" = 0; then + AC_CHECK_LIB(inet, strncasecmp, tcl_ok=1, tcl_ok=0) +fi +if test "$tcl_ok" = 0; then + AC_LIBOBJ([strncasecmp]) + USE_COMPAT=1 +fi + +#-------------------------------------------------------------------- +# The code below deals with several issues related to gettimeofday: +# 1. Some systems don't provide a gettimeofday function at all +# (set NO_GETTOD if this is the case). +# 2. See if gettimeofday is declared in the header file. +# if not, set the GETTOD_NOT_DECLARED flag so that tclPort.h can +# declare it. +#-------------------------------------------------------------------- + +AC_CHECK_FUNC(gettimeofday,[],[ + AC_DEFINE(NO_GETTOD, 1, [Do we have gettimeofday()?]) +]) +AC_CACHE_CHECK([for gettimeofday declaration], tcl_cv_grep_gettimeofday, [ + AC_EGREP_HEADER(gettimeofday, sys/time.h, + tcl_cv_grep_gettimeofday=present, tcl_cv_grep_gettimeofday=missing)]) +if test $tcl_cv_grep_gettimeofday = missing ; then + AC_DEFINE(GETTOD_NOT_DECLARED, 1, [Is gettimeofday() actually declared in ?]) +fi + +#-------------------------------------------------------------------- +# The following code checks to see whether it is possible to get +# signed chars on this platform. This is needed in order to +# properly generate sign-extended ints from character values. +#-------------------------------------------------------------------- + +AC_C_CHAR_UNSIGNED +AC_CACHE_CHECK([signed char declarations], tcl_cv_char_signed, [ + AC_TRY_COMPILE(, [ + signed char *p; + p = 0; + ], tcl_cv_char_signed=yes, tcl_cv_char_signed=no)]) +if test $tcl_cv_char_signed = yes; then + AC_DEFINE(HAVE_SIGNED_CHAR, 1, [Are characters signed?]) +fi + +#-------------------------------------------------------------------- +# Does putenv() copy or not? We need to know to avoid memory leaks. +#-------------------------------------------------------------------- + +AC_CACHE_CHECK([for a putenv() that copies the buffer], tcl_cv_putenv_copy, [ + AC_TRY_RUN([ + #include + #include + #define OURVAR "havecopy=yes" + int main (int argc, char *argv[]) + { + char *foo, *bar; + foo = (char *)strdup(OURVAR); + putenv(foo); + strcpy((char *)(strchr(foo, '=') + 1), "no"); + bar = getenv("havecopy"); + if (!strcmp(bar, "no")) { + /* doesnt copy */ + return 0; + } else { + /* does copy */ + return 1; + } + } + ], + tcl_cv_putenv_copy=no, + tcl_cv_putenv_copy=yes, + tcl_cv_putenv_copy=no)]) +if test $tcl_cv_putenv_copy = yes; then + AC_DEFINE(HAVE_PUTENV_THAT_COPIES, 1, + [Does putenv() copy strings or incorporate them by reference?]) +fi + +#-------------------------------------------------------------------- +# Check for support of nl_langinfo function +#-------------------------------------------------------------------- + +SC_ENABLE_LANGINFO + +#-------------------------------------------------------------------- +# Check for support of chflags and mkstemps functions +#-------------------------------------------------------------------- + +AC_CHECK_FUNCS(chflags mkstemps) + +#-------------------------------------------------------------------- +# Check for support of isnan() function or macro +#-------------------------------------------------------------------- + +AC_CACHE_CHECK([isnan], tcl_cv_isnan, [ + AC_TRY_LINK([#include ], [ +isnan(0.0); /* Generates an error if isnan is missing */ +], tcl_cv_isnan=yes, tcl_cv_isnan=no)]) +if test $tcl_cv_isnan = no; then + AC_DEFINE(NO_ISNAN, 1, [Do we have a usable 'isnan'?]) +fi + +#-------------------------------------------------------------------- +# Darwin specific API checks and defines +#-------------------------------------------------------------------- + +if test "`uname -s`" = "Darwin" ; then + AC_CHECK_FUNCS(getattrlist) + AC_CHECK_HEADERS(copyfile.h) + AC_CHECK_FUNCS(copyfile) + if test $tcl_corefoundation = yes; then + AC_CHECK_HEADERS(libkern/OSAtomic.h) + AC_CHECK_FUNCS(OSSpinLockLock) + fi + AC_DEFINE(USE_VFORK, 1, [Should we use vfork() instead of fork()?]) + AC_DEFINE(TCL_DEFAULT_ENCODING, "utf-8", + [Are we to override what our default encoding is?]) + AC_DEFINE(TCL_LOAD_FROM_MEMORY, 1, + [Can this platform load code from memory?]) + AC_DEFINE(TCL_WIDE_CLICKS, 1, + [Does this platform have wide high-resolution clicks?]) + AC_CHECK_HEADERS(AvailabilityMacros.h) + if test "$ac_cv_header_AvailabilityMacros_h" = yes; then + AC_CACHE_CHECK([if weak import is available], tcl_cv_cc_weak_import, [ + hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror" + AC_TRY_LINK([ + #ifdef __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ + #if __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ < 1020 + #error __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ < 1020 + #endif + #elif MAC_OS_X_VERSION_MIN_REQUIRED < 1020 + #error MAC_OS_X_VERSION_MIN_REQUIRED < 1020 + #endif + int rand(void) __attribute__((weak_import)); + ], [rand();], + tcl_cv_cc_weak_import=yes, tcl_cv_cc_weak_import=no) + CFLAGS=$hold_cflags]) + if test $tcl_cv_cc_weak_import = yes; then + AC_DEFINE(HAVE_WEAK_IMPORT, 1, [Is weak import available?]) + fi + AC_CACHE_CHECK([if Darwin SUSv3 extensions are available], + tcl_cv_cc_darwin_c_source, [ + hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror" + AC_TRY_COMPILE([ + #ifdef __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ + #if __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ < 1050 + #error __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ < 1050 + #endif + #elif MAC_OS_X_VERSION_MIN_REQUIRED < 1050 + #error MAC_OS_X_VERSION_MIN_REQUIRED < 1050 + #endif + #define _DARWIN_C_SOURCE 1 + #include + ],,tcl_cv_cc_darwin_c_source=yes, tcl_cv_cc_darwin_c_source=no) + CFLAGS=$hold_cflags]) + if test $tcl_cv_cc_darwin_c_source = yes; then + AC_DEFINE(_DARWIN_C_SOURCE, 1, + [Are Darwin SUSv3 extensions available?]) + fi + fi + # Build .bundle dltest binaries in addition to .dylib + DLTEST_LD='${CC} -bundle -Wl,-w ${CFLAGS} ${LDFLAGS}' + DLTEST_SUFFIX=".bundle" +else + DLTEST_LD='${SHLIB_LD}' + DLTEST_SUFFIX="" +fi + +#-------------------------------------------------------------------- +# Check for support of fts functions (readdir replacement) +#-------------------------------------------------------------------- + +AC_CACHE_CHECK([for fts], tcl_cv_api_fts, [ + AC_TRY_LINK([ + #include + #include + #include + ], [ + char*const p[2] = {"/", NULL}; + FTS *f = fts_open(p, FTS_PHYSICAL|FTS_NOCHDIR|FTS_NOSTAT, NULL); + FTSENT *e = fts_read(f); fts_close(f); + ], tcl_cv_api_fts=yes, tcl_cv_api_fts=no)]) +if test $tcl_cv_api_fts = yes; then + AC_DEFINE(HAVE_FTS, 1, [Do we have fts functions?]) +fi + +#-------------------------------------------------------------------- +# The statements below check for systems where POSIX-style non-blocking +# I/O (O_NONBLOCK) doesn't work or is unimplemented. On these systems +# (mostly older ones), use the old BSD-style FIONBIO approach instead. +#-------------------------------------------------------------------- + +SC_BLOCKING_STYLE + +#------------------------------------------------------------------------ + +AC_MSG_CHECKING([whether to use dll unloading]) +AC_ARG_ENABLE(dll-unloading, + AC_HELP_STRING([--enable-dll-unloading], + [enable the 'unload' command (default: on)]), + [tcl_ok=$enableval], [tcl_ok=yes]) +if test $tcl_ok = yes; then + AC_DEFINE(TCL_UNLOAD_DLLS, 1, [Do we allow unloading of shared libraries?]) +fi +AC_MSG_RESULT([$tcl_ok]) + +#------------------------------------------------------------------------ +# Check whether the timezone data is supplied by the OS or has +# to be installed by Tcl. The default is autodetection, but can +# be overridden on the configure command line either way. +#------------------------------------------------------------------------ + +AC_MSG_CHECKING([for timezone data]) +AC_ARG_WITH(tzdata, + AC_HELP_STRING([--with-tzdata], + [install timezone data (default: autodetect)]), + [tcl_ok=$withval], [tcl_ok=auto]) +# +# Any directories that get added here must also be added to the +# search path in ::tcl::clock::Initialize (library/clock.tcl). +# +case $tcl_ok in + no) + AC_MSG_RESULT([supplied by OS vendor]) + ;; + yes) + # nothing to do here + ;; + auto*) + AC_CACHE_VAL([tcl_cv_dir_zoneinfo], [ + for dir in /usr/share/zoneinfo \ + /usr/share/lib/zoneinfo \ + /usr/lib/zoneinfo + do + if test -f $dir/UTC -o -f $dir/GMT + then + tcl_cv_dir_zoneinfo="$dir" + break + fi + done]) + if test -n "$tcl_cv_dir_zoneinfo"; then + tcl_ok=no + AC_MSG_RESULT([$dir]) + else + tcl_ok=yes + fi + ;; + *) + AC_MSG_ERROR([invalid argument: $tcl_ok]) + ;; +esac +if test $tcl_ok = yes +then + AC_MSG_RESULT([supplied by Tcl]) + INSTALL_TZDATA=install-tzdata +fi + +#-------------------------------------------------------------------- +# DTrace support +#-------------------------------------------------------------------- + +AC_ARG_ENABLE(dtrace, + AC_HELP_STRING([--enable-dtrace], + [build with DTrace support (default: off)]), + [tcl_ok=$enableval], [tcl_ok=no]) +if test $tcl_ok = yes; then + AC_CHECK_HEADER(sys/sdt.h, [tcl_ok=yes], [tcl_ok=no]) +fi +if test $tcl_ok = yes; then + AC_PATH_PROG(DTRACE, dtrace,, [$PATH:/usr/sbin]) + test -z "$ac_cv_path_DTRACE" && tcl_ok=no +fi +AC_MSG_CHECKING([whether to enable DTrace support]) +MAKEFILE_SHELL='/bin/sh' +if test $tcl_ok = yes; then + AC_DEFINE(USE_DTRACE, 1, [Are we building with DTrace support?]) + DTRACE_SRC="\${DTRACE_SRC}" + DTRACE_HDR="\${DTRACE_HDR}" + if test "`uname -s`" != "Darwin" ; then + DTRACE_OBJ="\${DTRACE_OBJ}" + if test "`uname -s`" = "SunOS" -a "$SHARED_BUILD" = "0" ; then + # Need to create an intermediate object file to ensure tclDTrace.o + # gets included when linking against the static tcl library. + STLIB_LD='stlib_ld () { /usr/ccs/bin/ld -r -o $${1%.a}.o "$${@:2}" && '"${STLIB_LD}"' $${1} $${1%.a}.o ; } && stlib_ld' + MAKEFILE_SHELL='/bin/bash' + # Force use of Sun ar and ranlib, the GNU versions choke on + # tclDTrace.o and the combined object file above. + AR='/usr/ccs/bin/ar' + RANLIB='/usr/ccs/bin/ranlib' + fi + fi +fi +AC_MSG_RESULT([$tcl_ok]) + +#-------------------------------------------------------------------- +# The check below checks whether the cpuid instruction is usable. +#-------------------------------------------------------------------- + +AC_CACHE_CHECK([whether the cpuid instruction is usable], tcl_cv_cpuid, [ + AC_TRY_LINK(, [ + int index,regsPtr[4]; + __asm__ __volatile__("mov %%ebx, %%edi \n\t" + "cpuid \n\t" + "mov %%ebx, %%esi \n\t" + "mov %%edi, %%ebx \n\t" + : "=a"(regsPtr[0]), "=S"(regsPtr[1]), "=c"(regsPtr[2]), "=d"(regsPtr[3]) + : "a"(index) : "edi"); + ], tcl_cv_cpuid=yes, tcl_cv_cpuid=no)]) +if test $tcl_cv_cpuid = yes; then + AC_DEFINE(HAVE_CPUID, 1, [Is the cpuid instruction usable?]) +fi + +#-------------------------------------------------------------------- +# The statements below define a collection of symbols related to +# building libtcl as a shared library instead of a static library. +#-------------------------------------------------------------------- + +TCL_UNSHARED_LIB_SUFFIX=${UNSHARED_LIB_SUFFIX} +TCL_SHARED_LIB_SUFFIX=${SHARED_LIB_SUFFIX} +eval "TCL_LIB_FILE=libtcl${LIB_SUFFIX}" + +# tclConfig.sh needs a version of the _LIB_SUFFIX that has been eval'ed +# since on some platforms TCL_LIB_FILE contains shell escapes. +# (See also: TCL_TRIM_DOTS). + +eval "TCL_LIB_FILE=${TCL_LIB_FILE}" + +test -z "$TCL_LIBRARY" && TCL_LIBRARY='$(prefix)/lib/tcl$(VERSION)' +PRIVATE_INCLUDE_DIR='$(includedir)' +HTML_DIR='$(DISTDIR)/html' + +# Note: in the following variable, it's important to use the absolute +# path name of the Tcl directory rather than "..": this is because +# AIX remembers this path and will attempt to use it at run-time to look +# up the Tcl library. + +if test "`uname -s`" = "Darwin" ; then + SC_ENABLE_FRAMEWORK + TCL_SHLIB_LD_EXTRAS="-compatibility_version ${TCL_VERSION} -current_version ${TCL_VERSION}`echo ${TCL_PATCH_LEVEL} | awk ['{match($0, "\\\.[0-9]+"); print substr($0,RSTART,RLENGTH)}']`" + TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -install_name "${DYLIB_INSTALL_DIR}"/${TCL_LIB_FILE}' + echo "$LDFLAGS " | grep -q -- '-prebind ' && TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -seg1addr 0xA000000' + TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -sectcreate __TEXT __info_plist Tcl-Info.plist' + EXTRA_TCLSH_LIBS='-sectcreate __TEXT __info_plist Tclsh-Info.plist' + EXTRA_APP_CC_SWITCHES='-mdynamic-no-pic' + AC_CONFIG_FILES([Tcl-Info.plist:../macosx/Tcl-Info.plist.in Tclsh-Info.plist:../macosx/Tclsh-Info.plist.in]) + TCL_YEAR="`date +%Y`" +fi + +if test "$FRAMEWORK_BUILD" = "1" ; then + AC_DEFINE(TCL_FRAMEWORK, 1, [Is Tcl built as a framework?]) + # Construct a fake local framework structure to make linking with + # '-framework Tcl' and running of tcltest work + AC_CONFIG_COMMANDS([Tcl.framework], [n=Tcl && + f=$n.framework && v=Versions/$VERSION && + rm -rf $f && mkdir -p $f/$v/Resources && + ln -s $v/$n $v/Resources $f && ln -s ../../../$n $f/$v && + ln -s ../../../../$n-Info.plist $f/$v/Resources/Info.plist && + unset n f v + ], VERSION=${TCL_VERSION}) + LD_LIBRARY_PATH_VAR="DYLD_FRAMEWORK_PATH" + # default install directory for bundled packages + if test "${libdir}" = '${exec_prefix}/lib' -o "`basename ${libdir}`" = 'Frameworks'; then + PACKAGE_DIR="/Library/Tcl" + else + PACKAGE_DIR="$libdir" + fi + if test "${libdir}" = '${exec_prefix}/lib'; then + # override libdir default + libdir="/Library/Frameworks" + fi + TCL_LIB_FILE="Tcl" + TCL_LIB_FLAG="-framework Tcl" + TCL_BUILD_LIB_SPEC="-F`pwd | sed -e 's/ /\\\\ /g'` -framework Tcl" + TCL_LIB_SPEC="-F${libdir} -framework Tcl" + libdir="${libdir}/Tcl.framework/Versions/\${VERSION}" + TCL_LIBRARY="${libdir}/Resources/Scripts" + includedir="${libdir}/Headers" + PRIVATE_INCLUDE_DIR="${libdir}/PrivateHeaders" + HTML_DIR="${libdir}/Resources/Documentation/Reference/Tcl" + EXTRA_INSTALL="install-private-headers html-tcl" + EXTRA_BUILD_HTML='@ln -fs contents.htm "$(HTML_INSTALL_DIR)/TclTOC.html"' + EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA_DIR) "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"' + EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing license.terms to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA) "$(TOP_DIR)/license.terms" "$(LIB_INSTALL_DIR)/Resources"' + EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Finalizing Tcl.framework" && rm -f "$(LIB_INSTALL_DIR)/../Current" && ln -s "$(VERSION)" "$(LIB_INSTALL_DIR)/../Current" && for f in "$(LIB_FILE)" tclConfig.sh Resources Headers PrivateHeaders; do rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/Current/$$f" "$(LIB_INSTALL_DIR)/../.."; done && f="$(STUB_LIB_FILE)" && rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/$(VERSION)/$$f" "$(LIB_INSTALL_DIR)/../.."' + # Don't use AC_DEFINE for the following as the framework version define + # needs to go into the Makefile even when using autoheader, so that we + # can pick up a potential make override of VERSION. Also, don't put this + # into CFLAGS as it should not go into tclConfig.sh + EXTRA_CC_SWITCHES='-DTCL_FRAMEWORK_VERSION=\"$(VERSION)\"' +else + # libdir must be a fully qualified path and not ${exec_prefix}/lib + eval libdir="$libdir" + # default install directory for bundled packages + PACKAGE_DIR="$libdir" + if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then + TCL_LIB_FLAG="-ltcl${TCL_VERSION}" + else + TCL_LIB_FLAG="-ltcl`echo ${TCL_VERSION} | tr -d .`" + fi + TCL_BUILD_LIB_SPEC="-L`pwd | sed -e 's/ /\\\\ /g'` ${TCL_LIB_FLAG}" + TCL_LIB_SPEC="-L${libdir} ${TCL_LIB_FLAG}" +fi +VERSION='${VERSION}' +eval "CFG_TCL_SHARED_LIB_SUFFIX=${TCL_SHARED_LIB_SUFFIX}" +eval "CFG_TCL_UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX}" +VERSION=${TCL_VERSION} + +#-------------------------------------------------------------------- +# The statements below define the symbol TCL_PACKAGE_PATH, which +# gives a list of directories that may contain packages. The list +# consists of one directory for machine-dependent binaries and +# another for platform-independent scripts. +#-------------------------------------------------------------------- + +if test "$FRAMEWORK_BUILD" = "1" ; then + test -z "$TCL_PACKAGE_PATH" && \ + TCL_PACKAGE_PATH="~/Library/Tcl /Library/Tcl ~/Library/Frameworks /Library/Frameworks" + 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} ${TCL_PACKAGE_PATH}" +else + test -z "$TCL_PACKAGE_PATH" && TCL_PACKAGE_PATH="{${prefix}/lib} ${TCL_PACKAGE_PATH}" +fi + +#-------------------------------------------------------------------- +# The statements below define various symbols relating to Tcl +# stub support. +#-------------------------------------------------------------------- + +# Replace ${VERSION} with contents of ${TCL_VERSION} +# double-eval to account for TCL_TRIM_DOTS. +# +eval "TCL_STUB_LIB_FILE=libtclstub${TCL_UNSHARED_LIB_SUFFIX}" +eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\"" +eval "TCL_STUB_LIB_DIR=\"${libdir}\"" + +if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then + TCL_STUB_LIB_FLAG="-ltclstub${TCL_VERSION}" +else + TCL_STUB_LIB_FLAG="-ltclstub`echo ${TCL_VERSION} | tr -d .`" +fi + +TCL_BUILD_STUB_LIB_SPEC="-L`pwd | sed -e 's/ /\\\\ /g'` ${TCL_STUB_LIB_FLAG}" +TCL_STUB_LIB_SPEC="-L${TCL_STUB_LIB_DIR} ${TCL_STUB_LIB_FLAG}" +TCL_BUILD_STUB_LIB_PATH="`pwd`/${TCL_STUB_LIB_FILE}" +TCL_STUB_LIB_PATH="${TCL_STUB_LIB_DIR}/${TCL_STUB_LIB_FILE}" + +# Install time header dir can be set via --includedir +eval "TCL_INCLUDE_SPEC=\"-I${includedir}\"" + +#------------------------------------------------------------------------ +# tclConfig.sh refers to this by a different name +#------------------------------------------------------------------------ + +TCL_SHARED_BUILD=${SHARED_BUILD} + +AC_SUBST(TCL_VERSION) +AC_SUBST(TCL_MAJOR_VERSION) +AC_SUBST(TCL_MINOR_VERSION) +AC_SUBST(TCL_PATCH_LEVEL) +AC_SUBST(TCL_YEAR) +AC_SUBST(PKG_CFG_ARGS) + +AC_SUBST(TCL_LIB_FILE) +AC_SUBST(TCL_LIB_FLAG) +AC_SUBST(TCL_LIB_SPEC) +AC_SUBST(TCL_STUB_LIB_FILE) +AC_SUBST(TCL_STUB_LIB_FLAG) +AC_SUBST(TCL_STUB_LIB_SPEC) +AC_SUBST(TCL_STUB_LIB_PATH) +AC_SUBST(TCL_INCLUDE_SPEC) +AC_SUBST(TCL_BUILD_STUB_LIB_SPEC) +AC_SUBST(TCL_BUILD_STUB_LIB_PATH) + +AC_SUBST(TCL_SRC_DIR) +AC_SUBST(CFG_TCL_SHARED_LIB_SUFFIX) +AC_SUBST(CFG_TCL_UNSHARED_LIB_SUFFIX) + +AC_SUBST(TCL_SHARED_BUILD) +AC_SUBST(LD_LIBRARY_PATH_VAR) + +AC_SUBST(TCL_BUILD_LIB_SPEC) + +AC_SUBST(TCL_LIB_VERSIONS_OK) +AC_SUBST(TCL_SHARED_LIB_SUFFIX) +AC_SUBST(TCL_UNSHARED_LIB_SUFFIX) + +AC_SUBST(TCL_HAS_LONGLONG) + +AC_SUBST(INSTALL_TZDATA) + +AC_SUBST(DTRACE_SRC) +AC_SUBST(DTRACE_HDR) +AC_SUBST(DTRACE_OBJ) +AC_SUBST(MAKEFILE_SHELL) + +AC_SUBST(BUILD_DLTEST) +AC_SUBST(TCL_PACKAGE_PATH) +AC_SUBST(TCL_MODULE_PATH) + +AC_SUBST(TCL_LIBRARY) +AC_SUBST(PRIVATE_INCLUDE_DIR) +AC_SUBST(HTML_DIR) +AC_SUBST(PACKAGE_DIR) + +AC_SUBST(EXTRA_CC_SWITCHES) +AC_SUBST(EXTRA_APP_CC_SWITCHES) +AC_SUBST(EXTRA_INSTALL) +AC_SUBST(EXTRA_INSTALL_BINARIES) +AC_SUBST(EXTRA_BUILD_HTML) +AC_SUBST(EXTRA_TCLSH_LIBS) + +AC_SUBST(DLTEST_LD) +AC_SUBST(DLTEST_SUFFIX) + +dnl Disable the automake-friendly normalization of LIBOBJS +dnl performed by autoconf 2.53 and later. It's not correct for us. +define([_AC_LIBOBJS_NORMALIZE],[]) +AC_CONFIG_FILES([ + Makefile:../unix/Makefile.in + dltest/Makefile:../unix/dltest/Makefile.in + tclConfig.sh:../unix/tclConfig.sh.in + tcl.pc:../unix/tcl.pc.in +]) +AC_OUTPUT + +dnl Local Variables: +dnl mode: autoconf +dnl End: Index: unix/dltest/Makefile.in ================================================================== --- unix/dltest/Makefile.in +++ unix/dltest/Makefile.in @@ -15,11 +15,11 @@ BUILD_DIR = @builddir@ TCL_VERSION= @TCL_VERSION@ CFLAGS_DEBUG = @CFLAGS_DEBUG@ CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@ -CFLAGS = @CFLAGS_DEFAULT@ @CFLAGS@ -DTCL_NO_DEPRECATED=1 +CFLAGS = @CFLAGS_DEFAULT@ @CFLAGS@ LDFLAGS_DEBUG = @LDFLAGS_DEBUG@ LDFLAGS_OPTIMIZE = @LDFLAGS_OPTIMIZE@ LDFLAGS = @LDFLAGS_DEFAULT@ @LDFLAGS@ CC_SWITCHES = $(CFLAGS) -I${SRC_DIR}/../../generic -DTCL_MEM_DEBUG \ Index: unix/dltest/pkga.c ================================================================== --- unix/dltest/pkga.c +++ unix/dltest/pkga.c @@ -11,10 +11,18 @@ */ #undef STATIC_BUILD #include "tcl.h" +/* + * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the + * Pkga_Init declaration is in the source file itself, which is only + * accessed when we are building a library. + */ +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLEXPORT + /* * Prototypes for procedures defined later in this file: */ static int Pkga_EqObjCmd(ClientData clientData, @@ -114,18 +122,18 @@ * None. * *---------------------------------------------------------------------- */ -DLLEXPORT int +EXTERN int Pkga_Init( Tcl_Interp *interp) /* Interpreter in which the package is to be * made available. */ { int code; - if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { + if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) { return TCL_ERROR; } code = Tcl_PkgProvide(interp, "Pkga", "1.0"); if (code != TCL_OK) { return code; Index: unix/dltest/pkgc.c ================================================================== --- unix/dltest/pkgc.c +++ unix/dltest/pkgc.c @@ -12,10 +12,18 @@ */ #undef STATIC_BUILD #include "tcl.h" +/* + * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the + * Pkgc_Init declaration is in the source file itself, which is only + * accessed when we are building a library. + */ +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLEXPORT + /* * Prototypes for procedures defined later in this file: */ static int Pkgc_SubObjCmd(ClientData clientData, @@ -104,18 +112,18 @@ * None. * *---------------------------------------------------------------------- */ -DLLEXPORT int +EXTERN int Pkgc_Init( Tcl_Interp *interp) /* Interpreter in which the package is to be * made available. */ { int code; - if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { + if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) { return TCL_ERROR; } code = Tcl_PkgProvide(interp, "Pkgc", "1.7.2"); if (code != TCL_OK) { return code; @@ -141,22 +149,22 @@ * None. * *---------------------------------------------------------------------- */ -DLLEXPORT int +EXTERN int Pkgc_SafeInit( Tcl_Interp *interp) /* Interpreter in which the package is to be * made available. */ { int code; - if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { + if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) { return TCL_ERROR; } code = Tcl_PkgProvide(interp, "Pkgc", "1.7.2"); if (code != TCL_OK) { return code; } Tcl_CreateObjCommand(interp, "pkgc_sub", Pkgc_SubObjCmd, NULL, NULL); return TCL_OK; } Index: unix/dltest/pkgd.c ================================================================== --- unix/dltest/pkgd.c +++ unix/dltest/pkgd.c @@ -12,10 +12,18 @@ */ #undef STATIC_BUILD #include "tcl.h" +/* + * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the + * Pkgd_Init declaration is in the source file itself, which is only + * accessed when we are building a library. + */ +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLEXPORT + /* * Prototypes for procedures defined later in this file: */ static int Pkgd_SubObjCmd(ClientData clientData, @@ -104,18 +112,18 @@ * None. * *---------------------------------------------------------------------- */ -DLLEXPORT int +EXTERN int Pkgd_Init( Tcl_Interp *interp) /* Interpreter in which the package is to be * made available. */ { int code; - if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { + if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) { return TCL_ERROR; } code = Tcl_PkgProvide(interp, "Pkgd", "7.3"); if (code != TCL_OK) { return code; @@ -141,22 +149,22 @@ * None. * *---------------------------------------------------------------------- */ -DLLEXPORT int +EXTERN int Pkgd_SafeInit( Tcl_Interp *interp) /* Interpreter in which the package is to be * made available. */ { int code; - if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { + if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) { return TCL_ERROR; } code = Tcl_PkgProvide(interp, "Pkgd", "7.3"); if (code != TCL_OK) { return code; } Tcl_CreateObjCommand(interp, "pkgd_sub", Pkgd_SubObjCmd, NULL, NULL); return TCL_OK; } Index: unix/dltest/pkge.c ================================================================== --- unix/dltest/pkge.c +++ unix/dltest/pkge.c @@ -11,10 +11,19 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #undef STATIC_BUILD #include "tcl.h" + +/* + * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the + * Pkge_Init declaration is in the source file itself, which is only + * accessed when we are building a library. + */ +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLEXPORT + /* *---------------------------------------------------------------------- * * Pkge_Init -- @@ -29,17 +38,17 @@ * None. * *---------------------------------------------------------------------- */ -DLLEXPORT int +EXTERN int Pkge_Init( Tcl_Interp *interp) /* Interpreter in which the package is to be * made available. */ { static const char script[] = "if 44 {open non_existent}"; - if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { + if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) { return TCL_ERROR; } return Tcl_EvalEx(interp, script, -1, 0); } Index: unix/dltest/pkgooa.c ================================================================== --- unix/dltest/pkgooa.c +++ unix/dltest/pkgooa.c @@ -94,11 +94,11 @@ * loadable in Tcl 8.5 as well, provided the * TclOO extension (for Tcl 8.5) is installed. * This worked in Tcl 8.6.0, and is expected * to keep working in all future Tcl 8.x releases. */ - if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { + if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { return TCL_ERROR; } if (tclStubsPtr == NULL) { Tcl_AppendResult(interp, "Tcl stubs are not inialized, " "did you compile using -DUSE_TCL_STUBS? "); Index: unix/dltest/pkgua.c ================================================================== --- unix/dltest/pkgua.c +++ unix/dltest/pkgua.c @@ -9,12 +9,21 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +#undef STATIC_BUILD #include "tcl.h" +/* + * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the + * Pkgua_Init declaration is in the source file itself, which is only + * accessed when we are building a library. + */ +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLEXPORT + /* * Prototypes for procedures defined later in this file: */ static int PkguaEqObjCmd(ClientData clientData, @@ -67,11 +76,11 @@ Tcl_Interp *interp) { int newEntry; Tcl_Command *cmdTokens; Tcl_HashEntry *entryPtr = - Tcl_CreateHashEntry(&interpTokenMap, interp, &newEntry); + Tcl_CreateHashEntry(&interpTokenMap, (char *) interp, &newEntry); if (newEntry) { cmdTokens = (Tcl_Command *) Tcl_Alloc(sizeof(Tcl_Command) * (MAX_REGISTERED_COMMANDS+1)); for (newEntry=0 ; newEntry&2 - exit 1;; - esac - shift;; + case $mode in + *' '* | *"$tab"* | *"$nl"* | *'*'* | *'?'* | *'['*) + echo "$0: invalid mode: $mode" >&2 + exit 1;; + esac + shift;; -o) chowncmd="$chownprog $2" - shift;; + shift;; -s) stripcmd=$stripprog;; -S) stripcmd="$stripprog $2" - shift;; + shift;; - -t) dst_arg=$2 - shift;; + -t) + is_target_a_directory=always + dst_arg=$2 + # Protect names problematic for 'test' and other utilities. + case $dst_arg in + -* | [=\(\)!]) dst_arg=./$dst_arg;; + esac + shift;; - -T) no_target_directory=true;; + -T) is_target_a_directory=never;; --version) echo "$0 $scriptversion"; exit $?;; - --) shift - break;; + --) shift + break;; - -*) echo "$0: invalid option: $1" >&2 - exit 1;; + -*) echo "$0: invalid option: $1" >&2 + exit 1;; *) break;; esac shift done + +# We allow the use of options -d and -T together, by making -d +# take the precedence; this is for compatibility with GNU install. + +if test -n "$dir_arg"; then + if test -n "$dst_arg"; then + echo "$0: target directory not allowed when installing a directory." >&2 + exit 1 + fi +fi if test $# -ne 0 && test -z "$dir_arg$dst_arg"; then # When -d is used, all remaining arguments are directories to create. # When -t is used, the destination is already specified. # Otherwise, the last argument is the destination. Remove it from $@. @@ -188,22 +192,35 @@ set fnord "$@" "$dst_arg" shift # fnord fi shift # arg dst_arg=$arg + # Protect names problematic for 'test' and other utilities. + case $dst_arg in + -* | [=\(\)!]) dst_arg=./$dst_arg;; + esac done fi if test $# -eq 0; then if test -z "$dir_arg"; then echo "$0: no input file specified." >&2 exit 1 fi - # It's OK to call `install-sh -d' without argument. + # It's OK to call 'install-sh -d' without argument. # This can happen when creating conditional directories. exit 0 fi + +if test -z "$dir_arg"; then + if test $# -gt 1 || test "$is_target_a_directory" = always; then + if test ! -d "$dst_arg"; then + echo "$0: $dst_arg: Is not a directory." >&2 + exit 1 + fi + fi +fi if test -z "$dir_arg"; then do_exit='(exit $ret); exit $ret' trap "ret=129; $do_exit" 1 trap "ret=130; $do_exit" 2 @@ -217,30 +234,30 @@ *644) cp_umask=133;; *755) cp_umask=22;; *[0-7]) if test -z "$stripcmd"; then - u_plus_rw= + u_plus_rw= else - u_plus_rw='% 200' + u_plus_rw='% 200' fi cp_umask=`expr '(' 777 - $mode % 1000 ')' $u_plus_rw`;; *) if test -z "$stripcmd"; then - u_plus_rw= + u_plus_rw= else - u_plus_rw=,u+rw + u_plus_rw=,u+rw fi cp_umask=$mode$u_plus_rw;; esac fi for src do - # Protect names starting with `-'. + # Protect names problematic for 'test' and other utilities. case $src in - -*) src=./$src;; + -* | [=\(\)!]) src=./$src;; esac if test -n "$dir_arg"; then dst=$src dstdir=$dst @@ -258,189 +275,154 @@ if test -z "$dst_arg"; then echo "$0: no destination specified." >&2 exit 1 fi - dst=$dst_arg - # Protect names starting with `-'. - case $dst in - -*) dst=./$dst;; - esac - # If destination is a directory, append the input filename; won't work - # if double slashes aren't ignored. + # If destination is a directory, append the input filename. if test -d "$dst"; then - if test -n "$no_target_directory"; then - echo "$0: $dst_arg: Is a directory" >&2 - exit 1 + if test "$is_target_a_directory" = never; then + echo "$0: $dst_arg: Is a directory" >&2 + exit 1 fi dstdir=$dst - dst=$dstdir/`basename "$src"` + dstbase=`basename "$src"` + case $dst in + */) dst=$dst$dstbase;; + *) dst=$dst/$dstbase;; + esac dstdir_status=0 else - # Prefer dirname, but fall back on a substitute if dirname fails. - dstdir=` - (dirname "$dst") 2>/dev/null || - expr X"$dst" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$dst" : 'X\(//\)[^/]' \| \ - X"$dst" : 'X\(//\)$' \| \ - X"$dst" : 'X\(/\)' \| . 2>/dev/null || - echo X"$dst" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q' - ` - + dstdir=`dirname "$dst"` test -d "$dstdir" dstdir_status=$? fi fi + + case $dstdir in + */) dstdirslash=$dstdir;; + *) dstdirslash=$dstdir/;; + esac obsolete_mkdir_used=false if test $dstdir_status != 0; then case $posix_mkdir in '') - # Create intermediate dirs using mode 755 as modified by the umask. - # This is like FreeBSD 'install' as of 1997-10-28. - umask=`umask` - case $stripcmd.$umask in - # Optimize common cases. - *[2367][2367]) mkdir_umask=$umask;; - .*0[02][02] | .[02][02] | .[02]) mkdir_umask=22;; - - *[0-7]) - mkdir_umask=`expr $umask + 22 \ - - $umask % 100 % 40 + $umask % 20 \ - - $umask % 10 % 4 + $umask % 2 - `;; - *) mkdir_umask=$umask,go-w;; - esac - - # With -d, create the new directory with the user-specified mode. - # Otherwise, rely on $mkdir_umask. - if test -n "$dir_arg"; then - mkdir_mode=-m$mode - else - mkdir_mode= - fi - - posix_mkdir=false - case $umask in - *[123567][0-7][0-7]) - # POSIX mkdir -p sets u+wx bits regardless of umask, which - # is incompatible with FreeBSD 'install' when (umask & 300) != 0. - ;; - *) - tmpdir=${TMPDIR-/tmp}/ins$RANDOM-$$ - trap 'ret=$?; rmdir "$tmpdir/d" "$tmpdir" 2>/dev/null; exit $ret' 0 - - if (umask $mkdir_umask && - exec $mkdirprog $mkdir_mode -p -- "$tmpdir/d") >/dev/null 2>&1 - then - if test -z "$dir_arg" || { - # Check for POSIX incompatibilities with -m. - # HP-UX 11.23 and IRIX 6.5 mkdir -m -p sets group- or - # other-writeable bit of parent directory when it shouldn't. - # FreeBSD 6.1 mkdir -m -p sets mode of existing directory. - ls_ld_tmpdir=`ls -ld "$tmpdir"` - case $ls_ld_tmpdir in - d????-?r-*) different_mode=700;; - d????-?--*) different_mode=755;; - *) false;; - esac && - $mkdirprog -m$different_mode -p -- "$tmpdir" && { - ls_ld_tmpdir_1=`ls -ld "$tmpdir"` - test "$ls_ld_tmpdir" = "$ls_ld_tmpdir_1" - } - } - then posix_mkdir=: - fi - rmdir "$tmpdir/d" "$tmpdir" - else - # Remove any dirs left behind by ancient mkdir implementations. - rmdir ./$mkdir_mode ./-p ./-- 2>/dev/null - fi - trap '' 0;; - esac;; + # With -d, create the new directory with the user-specified mode. + # Otherwise, rely on $mkdir_umask. + if test -n "$dir_arg"; then + mkdir_mode=-m$mode + else + mkdir_mode= + fi + + posix_mkdir=false + # The $RANDOM variable is not portable (e.g., dash). Use it + # here however when possible just to lower collision chance. + tmpdir=${TMPDIR-/tmp}/ins$RANDOM-$$ + + trap ' + ret=$? + rmdir "$tmpdir/a/b" "$tmpdir/a" "$tmpdir" 2>/dev/null + exit $ret + ' 0 + + # Because "mkdir -p" follows existing symlinks and we likely work + # directly in world-writeable /tmp, make sure that the '$tmpdir' + # directory is successfully created first before we actually test + # 'mkdir -p'. + if (umask $mkdir_umask && + $mkdirprog $mkdir_mode "$tmpdir" && + exec $mkdirprog $mkdir_mode -p -- "$tmpdir/a/b") >/dev/null 2>&1 + then + if test -z "$dir_arg" || { + # Check for POSIX incompatibilities with -m. + # HP-UX 11.23 and IRIX 6.5 mkdir -m -p sets group- or + # other-writable bit of parent directory when it shouldn't. + # FreeBSD 6.1 mkdir -m -p sets mode of existing directory. + test_tmpdir="$tmpdir/a" + ls_ld_tmpdir=`ls -ld "$test_tmpdir"` + case $ls_ld_tmpdir in + d????-?r-*) different_mode=700;; + d????-?--*) different_mode=755;; + *) false;; + esac && + $mkdirprog -m$different_mode -p -- "$test_tmpdir" && { + ls_ld_tmpdir_1=`ls -ld "$test_tmpdir"` + test "$ls_ld_tmpdir" = "$ls_ld_tmpdir_1" + } + } + then posix_mkdir=: + fi + rmdir "$tmpdir/a/b" "$tmpdir/a" "$tmpdir" + else + # Remove any dirs left behind by ancient mkdir implementations. + rmdir ./$mkdir_mode ./-p ./-- "$tmpdir" 2>/dev/null + fi + trap '' 0;; esac if $posix_mkdir && ( - umask $mkdir_umask && - $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir" + umask $mkdir_umask && + $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir" ) then : else - # The umask is ridiculous, or mkdir does not conform to POSIX, + # mkdir does not conform to POSIX, # or it failed possibly due to a race condition. Create the # directory the slow way, step by step, checking for races as we go. case $dstdir in - /*) prefix='/';; - -*) prefix='./';; - *) prefix='';; + /*) prefix='/';; + [-=\(\)!]*) prefix='./';; + *) prefix='';; esac - eval "$initialize_posix_glob" - oIFS=$IFS IFS=/ - $posix_glob set -f + set -f set fnord $dstdir shift - $posix_glob set +f + set +f IFS=$oIFS prefixes= for d do - test -z "$d" && continue - - prefix=$prefix$d - if test -d "$prefix"; then - prefixes= - else - if $posix_mkdir; then - (umask=$mkdir_umask && - $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir") && break - # Don't fail if two instances are running concurrently. - test -d "$prefix" || exit 1 - else - case $prefix in - *\'*) qprefix=`echo "$prefix" | sed "s/'/'\\\\\\\\''/g"`;; - *) qprefix=$prefix;; - esac - prefixes="$prefixes '$qprefix'" - fi - fi - prefix=$prefix/ + test X"$d" = X && continue + + prefix=$prefix$d + if test -d "$prefix"; then + prefixes= + else + if $posix_mkdir; then + (umask $mkdir_umask && + $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir") && break + # Don't fail if two instances are running concurrently. + test -d "$prefix" || exit 1 + else + case $prefix in + *\'*) qprefix=`echo "$prefix" | sed "s/'/'\\\\\\\\''/g"`;; + *) qprefix=$prefix;; + esac + prefixes="$prefixes '$qprefix'" + fi + fi + prefix=$prefix/ done if test -n "$prefixes"; then - # Don't fail if two instances are running concurrently. - (umask $mkdir_umask && - eval "\$doit_exec \$mkdirprog $prefixes") || - test -d "$dstdir" || exit 1 - obsolete_mkdir_used=true + # Don't fail if two instances are running concurrently. + (umask $mkdir_umask && + eval "\$doit_exec \$mkdirprog $prefixes") || + test -d "$dstdir" || exit 1 + obsolete_mkdir_used=true fi fi fi if test -n "$dir_arg"; then @@ -449,18 +431,29 @@ { test "$obsolete_mkdir_used$chowncmd$chgrpcmd" = false || test -z "$chmodcmd" || $doit $chmodcmd $mode "$dst"; } || exit 1 else # Make a couple of temp file names in the proper directory. - dsttmp=$dstdir/_inst.$$_ - rmtmp=$dstdir/_rm.$$_ + dsttmp=${dstdirslash}_inst.$$_ + rmtmp=${dstdirslash}_rm.$$_ # Trap to clean up those temp files at exit. trap 'ret=$?; rm -f "$dsttmp" "$rmtmp" && exit $ret' 0 # Copy the file name to the temp name. - (umask $cp_umask && $doit_exec $cpprog "$src" "$dsttmp") && + (umask $cp_umask && + { test -z "$stripcmd" || { + # Create $dsttmp read-write so that cp doesn't create it read-only, + # which would cause strip to fail. + if test -z "$doit"; then + : >"$dsttmp" # No need to fork-exec 'touch'. + else + $doit touch "$dsttmp" + fi + } + } && + $doit_exec $cpprog "$src" "$dsttmp") && # and set any options; do chmod last to preserve setuid bits. # # If any of these fail, we abort the whole thing. If we want to # ignore errors from any of these, just make sure not to ignore @@ -471,19 +464,16 @@ { test -z "$stripcmd" || $doit $stripcmd "$dsttmp"; } && { test -z "$chmodcmd" || $doit $chmodcmd $mode "$dsttmp"; } && # If -C, don't bother to copy if it wouldn't change the file. if $copy_on_change && - old=`LC_ALL=C ls -dlL "$dst" 2>/dev/null` && - new=`LC_ALL=C ls -dlL "$dsttmp" 2>/dev/null` && - - eval "$initialize_posix_glob" && - $posix_glob set -f && + old=`LC_ALL=C ls -dlL "$dst" 2>/dev/null` && + new=`LC_ALL=C ls -dlL "$dsttmp" 2>/dev/null` && + set -f && set X $old && old=:$2:$4:$5:$6 && set X $new && new=:$2:$4:$5:$6 && - $posix_glob set +f && - + set +f && test "$old" = "$new" && $cmpprog "$dst" "$dsttmp" >/dev/null 2>&1 then rm -f "$dsttmp" else @@ -492,37 +482,37 @@ # The rename failed, perhaps because mv can't rename something else # to itself, or perhaps because mv is so ancient that it does not # support -f. { - # Now remove or move aside any old file at destination location. - # We try this two ways since rm can't unlink itself on some - # systems and the destination file might be busy for other - # reasons. In this case, the final cleanup might fail but the new - # file should still install successfully. - { - test ! -f "$dst" || - $doit $rmcmd -f "$dst" 2>/dev/null || - { $doit $mvcmd -f "$dst" "$rmtmp" 2>/dev/null && - { $doit $rmcmd -f "$rmtmp" 2>/dev/null; :; } - } || - { echo "$0: cannot unlink or rename $dst" >&2 - (exit 1); exit 1 - } - } && - - # Now rename the file to the real destination. - $doit $mvcmd "$dsttmp" "$dst" + # Now remove or move aside any old file at destination location. + # We try this two ways since rm can't unlink itself on some + # systems and the destination file might be busy for other + # reasons. In this case, the final cleanup might fail but the new + # file should still install successfully. + { + test ! -f "$dst" || + $doit $rmcmd -f "$dst" 2>/dev/null || + { $doit $mvcmd -f "$dst" "$rmtmp" 2>/dev/null && + { $doit $rmcmd -f "$rmtmp" 2>/dev/null; :; } + } || + { echo "$0: cannot unlink or rename $dst" >&2 + (exit 1); exit 1 + } + } && + + # Now rename the file to the real destination. + $doit $mvcmd "$dsttmp" "$dst" } fi || exit 1 trap '' 0 fi done # Local variables: -# eval: (add-hook 'write-file-hooks 'time-stamp) +# eval: (add-hook 'before-save-hook 'time-stamp) # time-stamp-start: "scriptversion=" # time-stamp-format: "%:y-%02m-%02d.%02H" -# time-stamp-time-zone: "UTC" +# time-stamp-time-zone: "UTC0" # time-stamp-end: "; # UTC" # End: Index: unix/installManPage ================================================================== --- unix/installManPage +++ unix/installManPage @@ -41,11 +41,11 @@ Dir=$2 if test -f $ManPage ; then : ; else echo "source manual page file must exist" exit 1 fi -if test -d $Dir ; then : ; else +if test -d "$Dir" ; then : ; else echo "target directory must exist" exit 1 fi test -z "$SymOrLoc" && SymOrLoc="$Dir/" @@ -58,39 +58,24 @@ # Backslashes are trippled in the sed script, because it is in # backticks which doesn't pass backslashes literally. # Names=`sed -n ' # Look for a line that starts with .SH NAME - /^\.SH NAME/,/^\./{ - - - /^\./!{ - - # Remove all commas... - s/,//g - - # ... and backslash-escaped spaces. - s/\\\ //g - - /\\\-.*/{ - # Delete from \- to the end of line - s/ \\\-.*// - h - s/.*/./ - x - } - - # Convert all non-space non-alphanum sequences - # to single underscores. - s/[^ A-Za-z0-9][^ A-Za-z0-9]*/_/g - p - g - /^\./{ - q - } - } - + /^\.SH NAME/{ +# Read next line + n +# Remove all commas ... + s/,//g +# ... and backslash-escaped spaces. + s/\\\ //g +# Delete from \- to the end of line + s/ \\\-.*// +# Convert all non-space non-alphanum sequences +# to single underscores. + s/[^ A-Za-z0-9][^ A-Za-z0-9]*/_/g +# print the result and exit + p;q }' $ManPage` if test -z "$Names" ; then echo "warning: no target names found in $ManPage" fi @@ -105,28 +90,36 @@ *.n) Section=n ;; *) echo "unknown section for $ManPage" exit 2 ;; esac +Name=`basename $ManPage .$Section` SrcDir=`dirname $ManPage` ######################################################################## ### Process Page to Create Target Pages ### + +Specials="DString Thread Notifier RegExp library packagens pkgMkIndex safesock FindPhoto FontId MeasureChar" +for n in $Specials; do + if [ "$Name" = "$n" ] ; then + Names="$n $Names" + fi +done First="" for Target in $Names; do Target=$Target.$Section$Suffix - rm -f $Dir/$Target $Dir/$Target.* + rm -f "$Dir/$Target" "$Dir/$Target.*" if test -z "$First" ; then First=$Target sed -e "/man\.macros/r $SrcDir/man.macros" -e "/man\.macros/d" \ - $ManPage > $Dir/$First - chmod 644 $Dir/$First - $Gzip $Dir/$First + $ManPage > "$Dir/$First" + chmod 644 "$Dir/$First" + $Gzip "$Dir/$First" else - ln $SymOrLoc$First$Gz $Dir/$Target$Gz + ln "$SymOrLoc$First$Gz" "$Dir/$Target$Gz" fi done ######################################################################## exit 0 Index: unix/tcl.m4 ================================================================== --- unix/tcl.m4 +++ unix/tcl.m4 @@ -75,11 +75,10 @@ # on Darwin, check in Framework installation locations if test "`uname -s`" = "Darwin" -a x"${ac_cv_c_tclconfig}" = x ; then for i in `ls -d ~/Library/Frameworks 2>/dev/null` \ `ls -d /Library/Frameworks 2>/dev/null` \ `ls -d /Network/Library/Frameworks 2>/dev/null` \ - `ls -d /System/Library/Frameworks 2>/dev/null` \ ; do if test -f "$i/Tcl.framework/tclConfig.sh" ; then ac_cv_c_tclconfig="`(cd $i/Tcl.framework; pwd)`" break fi @@ -92,14 +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/tcl8.6 2>/dev/null` \ `ls -d /usr/lib 2>/dev/null` \ `ls -d /usr/lib64 2>/dev/null` \ - `ls -d /usr/local/lib/tcl9.0 2>/dev/null` \ - `ls -d /usr/local/lib/tcl/tcl9.0 2>/dev/null` \ + `ls -d /usr/local/lib/tcl8.6 2>/dev/null` \ + `ls -d /usr/local/lib/tcl/tcl8.6 2>/dev/null` \ ; do if test -f "$i/tclConfig.sh" ; then ac_cv_c_tclconfig="`(cd $i; pwd)`" break fi @@ -208,11 +208,10 @@ # on Darwin, check in Framework installation locations if test "`uname -s`" = "Darwin" -a x"${ac_cv_c_tkconfig}" = x ; then for i in `ls -d ~/Library/Frameworks 2>/dev/null` \ `ls -d /Library/Frameworks 2>/dev/null` \ `ls -d /Network/Library/Frameworks 2>/dev/null` \ - `ls -d /System/Library/Frameworks 2>/dev/null` \ ; do if test -f "$i/Tk.framework/tkConfig.sh" ; then ac_cv_c_tkconfig="`(cd $i/Tk.framework; pwd)`" break fi @@ -225,14 +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/tk8.6 2>/dev/null` \ `ls -d /usr/lib 2>/dev/null` \ `ls -d /usr/lib64 2>/dev/null` \ - `ls -d /usr/local/lib/tk9.0 2>/dev/null` \ - `ls -d /usr/local/lib/tcl/tk9.0 2>/dev/null` \ + `ls -d /usr/local/lib/tk8.6 2>/dev/null` \ + `ls -d /usr/local/lib/tcl/tk8.6 2>/dev/null` \ ; do if test -f "$i/tkConfig.sh" ; then ac_cv_c_tkconfig="`(cd $i; pwd)`" break fi @@ -291,14 +291,10 @@ . "${TCL_BIN_DIR}/tclConfig.sh" else AC_MSG_RESULT([could not find ${TCL_BIN_DIR}/tclConfig.sh]) fi - # eval is required to do the TCL_DBGX substitution - eval "TCL_LIB_FILE=\"${TCL_LIB_FILE}\"" - eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\"" - # If the TCL_BIN_DIR is the build directory (not the install directory), # then set the common variable name to the value of the build variables. # For example, the variable TCL_LIB_SPEC will be set to the value # of TCL_BUILD_LIB_SPEC. An extension should make use of TCL_LIB_SPEC # instead of TCL_BUILD_LIB_SPEC since it will work with both an @@ -328,16 +324,10 @@ fi ;; esac fi - # eval is required to do the TCL_DBGX substitution - eval "TCL_LIB_FLAG=\"${TCL_LIB_FLAG}\"" - eval "TCL_LIB_SPEC=\"${TCL_LIB_SPEC}\"" - eval "TCL_STUB_LIB_FLAG=\"${TCL_STUB_LIB_FLAG}\"" - eval "TCL_STUB_LIB_SPEC=\"${TCL_STUB_LIB_SPEC}\"" - AC_SUBST(TCL_VERSION) AC_SUBST(TCL_PATCH_LEVEL) AC_SUBST(TCL_BIN_DIR) AC_SUBST(TCL_SRC_DIR) @@ -374,14 +364,10 @@ . "${TK_BIN_DIR}/tkConfig.sh" else AC_MSG_RESULT([could not find ${TK_BIN_DIR}/tkConfig.sh]) fi - # eval is required to do the TK_DBGX substitution - eval "TK_LIB_FILE=\"${TK_LIB_FILE}\"" - eval "TK_STUB_LIB_FILE=\"${TK_STUB_LIB_FILE}\"" - # If the TK_BIN_DIR is the build directory (not the install directory), # then set the common variable name to the value of the build variables. # For example, the variable TK_LIB_SPEC will be set to the value # of TK_BUILD_LIB_SPEC. An extension should make use of TK_LIB_SPEC # instead of TK_BUILD_LIB_SPEC since it will work with both an @@ -411,16 +397,10 @@ fi ;; esac fi - # eval is required to do the TK_DBGX substitution - eval "TK_LIB_FLAG=\"${TK_LIB_FLAG}\"" - eval "TK_LIB_SPEC=\"${TK_LIB_SPEC}\"" - eval "TK_STUB_LIB_FLAG=\"${TK_STUB_LIB_FLAG}\"" - eval "TK_STUB_LIB_SPEC=\"${TK_STUB_LIB_SPEC}\"" - AC_SUBST(TK_VERSION) AC_SUBST(TK_BIN_DIR) AC_SUBST(TK_SRC_DIR) AC_SUBST(TK_LIB_FILE) @@ -545,11 +525,10 @@ else AC_MSG_RESULT([static]) SHARED_BUILD=0 AC_DEFINE(STATIC_BUILD, 1, [Is this a static build?]) fi - AC_SUBST(SHARED_BUILD) ]) #------------------------------------------------------------------------ # SC_ENABLE_FRAMEWORK -- # @@ -595,10 +574,117 @@ fi FRAMEWORK_BUILD=0 fi fi ]) + +#------------------------------------------------------------------------ +# SC_ENABLE_THREADS -- +# +# Specify if thread support should be enabled +# +# Arguments: +# none +# +# Results: +# +# Adds the following arguments to configure: +# --enable-threads +# +# Sets the following vars: +# THREADS_LIBS Thread library(s) +# +# Defines the following vars: +# TCL_THREADS +# _REENTRANT +# _THREAD_SAFE +#------------------------------------------------------------------------ + +AC_DEFUN([SC_ENABLE_THREADS], [ + AC_ARG_ENABLE(threads, + AC_HELP_STRING([--enable-threads], + [build with threads (default: on)]), + [tcl_ok=$enableval], [tcl_ok=yes]) + + if test "${TCL_THREADS}" = 1; then + tcl_threaded_core=1; + fi + + if test "$tcl_ok" = "yes" -o "${TCL_THREADS}" = 1; then + TCL_THREADS=1 + # USE_THREAD_ALLOC tells us to try the special thread-based + # allocator that significantly reduces lock contention + AC_DEFINE(USE_THREAD_ALLOC, 1, + [Do we want to use the threaded memory allocator?]) + AC_DEFINE(_REENTRANT, 1, [Do we want the reentrant OS API?]) + if test "`uname -s`" = "SunOS" ; then + AC_DEFINE(_POSIX_PTHREAD_SEMANTICS, 1, + [Do we really want to follow the standard? Yes we do!]) + fi + AC_DEFINE(_THREAD_SAFE, 1, [Do we want the thread-safe OS API?]) + AC_CHECK_LIB(pthread,pthread_mutex_init,tcl_ok=yes,tcl_ok=no) + if test "$tcl_ok" = "no"; then + # Check a little harder for __pthread_mutex_init in the same + # library, as some systems hide it there until pthread.h is + # defined. We could alternatively do an AC_TRY_COMPILE with + # pthread.h, but that will work with libpthread really doesn't + # exist, like AIX 4.2. [Bug: 4359] + AC_CHECK_LIB(pthread, __pthread_mutex_init, + tcl_ok=yes, tcl_ok=no) + fi + + if test "$tcl_ok" = "yes"; then + # The space is needed + THREADS_LIBS=" -lpthread" + else + AC_CHECK_LIB(pthreads, pthread_mutex_init, + tcl_ok=yes, tcl_ok=no) + if test "$tcl_ok" = "yes"; then + # The space is needed + THREADS_LIBS=" -lpthreads" + else + AC_CHECK_LIB(c, pthread_mutex_init, + tcl_ok=yes, tcl_ok=no) + if test "$tcl_ok" = "no"; then + AC_CHECK_LIB(c_r, pthread_mutex_init, + tcl_ok=yes, tcl_ok=no) + if test "$tcl_ok" = "yes"; then + # The space is needed + THREADS_LIBS=" -pthread" + else + TCL_THREADS=0 + AC_MSG_WARN([Don't know how to find pthread lib on your system - you must disable thread support or edit the LIBS in the Makefile...]) + fi + fi + fi + fi + + # Does the pthread-implementation provide + # 'pthread_attr_setstacksize' ? + + ac_saved_libs=$LIBS + LIBS="$LIBS $THREADS_LIBS" + AC_CHECK_FUNCS(pthread_attr_setstacksize pthread_atfork) + LIBS=$ac_saved_libs + else + TCL_THREADS=0 + fi + # Do checking message here to not mess up interleaved configure output + AC_MSG_CHECKING([for building with threads]) + if test "${TCL_THREADS}" = 1; then + AC_DEFINE(TCL_THREADS, 1, [Are we building with threads enabled?]) + if test "${tcl_threaded_core}" = 1; then + AC_MSG_RESULT([yes (threaded core)]) + else + AC_MSG_RESULT([yes]) + fi + else + AC_MSG_RESULT([no]) + fi + + AC_SUBST(TCL_THREADS) +]) #------------------------------------------------------------------------ # SC_ENABLE_SYMBOLS -- # # Specify if debugging symbols should be used. @@ -622,22 +708,19 @@ # Defines the following vars: # CFLAGS_DEFAULT Sets to $(CFLAGS_DEBUG) if true # Sets to $(CFLAGS_OPTIMIZE) if false # LDFLAGS_DEFAULT Sets to $(LDFLAGS_DEBUG) if true # Sets to $(LDFLAGS_OPTIMIZE) if false -# DBGX Formerly used as debug library extension; -# always blank now. #------------------------------------------------------------------------ AC_DEFUN([SC_ENABLE_SYMBOLS], [ AC_MSG_CHECKING([for build with symbols]) AC_ARG_ENABLE(symbols, AC_HELP_STRING([--enable-symbols], [build with debugging symbols (default: off)]), [tcl_ok=$enableval], [tcl_ok=no]) # FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT. - DBGX="" if test "$tcl_ok" = "no"; then CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)' LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)' AC_DEFINE(NDEBUG, 1, [Is no debugging enabled?]) AC_MSG_RESULT([no]) @@ -788,33 +871,44 @@ #-------------------------------------------------------------------- # SC_CONFIG_SYSTEM # # Determine what the system is (some things cannot be easily checked # on a feature-driven basis, alas). This can usually be done via the -# "uname" command. +# "uname" command, but there are a few systems, like Next, where +# this doesn't work. # # Arguments: # none # # Results: # Defines the following var: # # system - System/platform/version identification code. +# #-------------------------------------------------------------------- AC_DEFUN([SC_CONFIG_SYSTEM], [ AC_CACHE_CHECK([system version], tcl_cv_sys_version, [ - if test "${TEA_PLATFORM}" = "windows" ; then - tcl_cv_sys_version=windows + if test -f /usr/lib/NextStep/software_version; then + tcl_cv_sys_version=NEXTSTEP-`awk '/3/,/3/' /usr/lib/NextStep/software_version` else tcl_cv_sys_version=`uname -s`-`uname -r` if test "$?" -ne 0 ; then AC_MSG_WARN([can't find uname command]) tcl_cv_sys_version=unknown else + # Special check for weird MP-RAS system (uname returns weird + # results, and the version is kept in special file). + + if test -r /etc/.relid -a "X`uname -n`" = "X`uname -s`" ; then + tcl_cv_sys_version=MP-RAS-`awk '{print $[3]}' /etc/.relid` + fi if test "`uname -s`" = "AIX" ; then tcl_cv_sys_version=AIX-`uname -v`.`uname -r` + fi + if test "`uname -s`" = "NetBSD" -a -f /etc/debian_version ; then + tcl_cv_sys_version=NetBSD-Debian fi fi fi ]) system=$tcl_cv_sys_version @@ -868,12 +962,12 @@ # creating shared libraries. This symbol typically # goes at the end of the "ld" commands that build # shared libraries. The value of the symbol defaults to # "${LIBS}" if all of the dependent libraries should # be specified when creating a shared library. If -# dependent libraries should not be specified (as on some -# SunOS systems, where they cause the link to fail, or in +# dependent libraries should not be specified (as on +# SunOS 4.x, where they cause the link to fail, or in # general if Tcl and Tk aren't themselves shared # libraries), then this symbol has an empty string # as its value. # SHLIB_SUFFIX - Suffix to use for the names of dynamically loadable # extensions. An empty string means we don't know how @@ -984,11 +1078,11 @@ ECHO_VERSION='`echo ${VERSION}`' TCL_LIB_VERSIONS_OK=ok CFLAGS_DEBUG=-g AS_IF([test "$GCC" = yes], [ CFLAGS_OPTIMIZE=-O2 - CFLAGS_WARNING="-Wall -Wwrite-strings -Wsign-compare -Wdeclaration-after-statement -Wpointer-arith" + CFLAGS_WARNING="-Wall -Wpointer-arith" ], [ CFLAGS_OPTIMIZE=-O CFLAGS_WARNING="" ]) AC_CHECK_TOOL(AR, ar) @@ -995,14 +1089,14 @@ STLIB_LD='${AR} cr' LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH" PLAT_OBJS="" PLAT_SRCS="" LDAIX_SRC="" - AS_IF([test "x${SHLIB_VERSION}" = x], [SHLIB_VERSION="1.0"]) + AS_IF([test "x${SHLIB_VERSION}" = x],[SHLIB_VERSION=".1.0"],[SHLIB_VERSION=".${SHLIB_VERSION}"]) case $system in AIX-*) - AS_IF([test "$GCC" != "yes"], [ + AS_IF([test "${TCL_THREADS}" = "1" -a "$GCC" != "yes"], [ # AIX requires the _r compiler when gcc isn't being used case "${CC}" in *_r|*_r\ *) # ok ... ;; @@ -1093,11 +1187,11 @@ DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -export-dynamic" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; - CYGWIN_*) + CYGWIN_*|MINGW32*) SHLIB_CFLAGS="" SHLIB_LD='${CC} -shared' SHLIB_SUFFIX=".dll" DL_OBJS="tclLoadDl.o" PLAT_OBJS='${CYGWIN_OBJS}' @@ -1104,11 +1198,11 @@ PLAT_SRCS='${CYGWIN_SRCS}' DL_LIBS="-ldl" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" TCL_NEEDS_EXP_FILE=1 - TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.dll.a' + TCL_EXPORT_FILE_SUFFIX='${VERSION}.dll.a' SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,--out-implib,\$[@].a" AC_CACHE_CHECK(for Cygwin version of gcc, ac_cv_cygwin, AC_TRY_COMPILE([ #ifdef __CYGWIN__ @@ -1119,10 +1213,13 @@ ac_cv_cygwin=yes) ) if test "$ac_cv_cygwin" = "no"; then AC_MSG_ERROR([${CC} is not a cygwin compiler.]) fi + if test "x${TCL_THREADS}" = "x0"; then + AC_MSG_ERROR([CYGWIN compile is only supported with --enable-threads]) + fi do64bit_ok=yes if test "x${SHARED_BUILD}" = "x1"; then echo "running cd ../win; ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args" # The eval makes quoting arguments work. if cd ../win; eval ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args; cd ../unix @@ -1190,11 +1287,11 @@ hppa64*) # 64-bit gcc in use. Fix flags for GNU ld. do64bit_ok=yes SHLIB_LD='${CC} -shared' AS_IF([test $doRpath = yes], [ - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}']) + CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"']) LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} ;; *) AC_MSG_WARN([64bit mode not supported with GCC on $system]) ;; @@ -1225,11 +1322,11 @@ SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" AC_LIBOBJ(mkstemp) AS_IF([test $doRpath = yes], [ - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"' LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}']) ;; IRIX-6.*) SHLIB_CFLAGS="" SHLIB_LD="ld -n32 -shared -rdata_shared" @@ -1236,11 +1333,11 @@ SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" AC_LIBOBJ(mkstemp) AS_IF([test $doRpath = yes], [ - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"' LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}']) AS_IF([test "$GCC" = yes], [ CFLAGS="$CFLAGS -mabi=n32" LDFLAGS="$LDFLAGS -mabi=n32" ], [ @@ -1262,11 +1359,11 @@ SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" AC_LIBOBJ(mkstemp) AS_IF([test $doRpath = yes], [ - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"' LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}']) # Check to enable 64-bit flags for compiler/linker AS_IF([test "$do64bit" = yes], [ @@ -1293,11 +1390,11 @@ SHLIB_LD='${CC} ${CFLAGS} ${LDFLAGS} -shared' DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -Wl,--export-dynamic" AS_IF([test $doRpath = yes], [ - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}']) + CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"']) LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} AS_IF([test "`uname -m`" = "alpha"], [CFLAGS="$CFLAGS -mieee"]) AS_IF([test $do64bit = yes], [ AC_CACHE_CHECK([if compiler accepts -m64 flag], tcl_cv_cc_m64, [ hold_cflags=$CFLAGS @@ -1325,12 +1422,33 @@ SHLIB_LD='${CC} -shared' DL_OBJS="tclLoadDl.o" DL_LIBS="-mshared -ldl" LD_FLAGS="-Wl,--export-dynamic" AS_IF([test $doRpath = yes], [ - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}']) + CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"' + LD_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"']) + ;; + MP-RAS-02*) + SHLIB_CFLAGS="-K PIC" + SHLIB_LD='${CC} -G' + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + CC_SEARCH_FLAGS="" + LD_SEARCH_FLAGS="" + ;; + MP-RAS-*) + SHLIB_CFLAGS="-K PIC" + SHLIB_LD='${CC} -G' + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LDFLAGS="$LDFLAGS -Wl,-Bexport" + CC_SEARCH_FLAGS="" + LD_SEARCH_FLAGS="" ;; OpenBSD-*) arch=`arch -s` case "$arch" in alpha|sparc64) @@ -1343,19 +1461,21 @@ SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" AS_IF([test $doRpath = yes], [ - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}']) + CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"']) LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.${SHLIB_VERSION}' + SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so${SHLIB_VERSION}' LDFLAGS="-Wl,-export-dynamic" CFLAGS_OPTIMIZE="-O2" - # On OpenBSD: Compile with -pthread - # Don't link with -lpthread - LIBS=`echo $LIBS | sed s/-lpthread//` - CFLAGS="$CFLAGS -pthread" + AS_IF([test "${TCL_THREADS}" = "1"], [ + # On OpenBSD: Compile with -pthread + # Don't link with -lpthread + LIBS=`echo $LIBS | sed s/-lpthread//` + CFLAGS="$CFLAGS -pthread" + ]) # OpenBSD doesn't do version numbers with dots. UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' TCL_LIB_VERSIONS_OK=nodots ;; NetBSD-*) @@ -1365,33 +1485,35 @@ SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" LDFLAGS="$LDFLAGS -export-dynamic" AS_IF([test $doRpath = yes], [ - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}']) + CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"']) LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - # The -pthread needs to go in the CFLAGS, not LIBS - LIBS=`echo $LIBS | sed s/-pthread//` - CFLAGS="$CFLAGS -pthread" - LDFLAGS="$LDFLAGS -pthread" + AS_IF([test "${TCL_THREADS}" = "1"], [ + # The -pthread needs to go in the CFLAGS, not LIBS + LIBS=`echo $LIBS | sed s/-pthread//` + CFLAGS="$CFLAGS -pthread" + LDFLAGS="$LDFLAGS -pthread" + ]) ;; DragonFly-*|FreeBSD-*) # This configuration from FreeBSD Ports. SHLIB_CFLAGS="-fPIC" SHLIB_LD="${CC} -shared" SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,-soname,\$[@]" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" - LDFLAGS="" AS_IF([test $doRpath = yes], [ - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}']) - # The -pthread needs to go in the LDFLAGS, not LIBS - LIBS=`echo $LIBS | sed s/-pthread//` - CFLAGS="$CFLAGS $PTHREAD_CFLAGS" - LDFLAGS="$LDFLAGS $PTHREAD_LIBS" + CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"' + LD_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"']) + AS_IF([test "${TCL_THREADS}" = "1"], [ + # The -pthread needs to go in the LDFLAGS, not LIBS + LIBS=`echo $LIBS | sed s/-pthread//` + CFLAGS="$CFLAGS $PTHREAD_CFLAGS" + LDFLAGS="$LDFLAGS $PTHREAD_LIBS"]) case $system in FreeBSD-3.*) # Version numbers are dot-stripped by system policy. TCL_TRIM_DOTS=`echo ${VERSION} | tr -d .` UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' @@ -1471,10 +1593,11 @@ LDFLAGS="$LDFLAGS -Wl,-search_paths_first" ]) AS_IF([test "$tcl_cv_cc_visibility_hidden" != yes], [ AC_DEFINE(MODULE_SCOPE, [__private_extern__], [Compiler support for module scope symbols]) + tcl_cv_cc_visibility_hidden=yes ]) CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH" AC_DEFINE(MAC_OSX_TCL, 1, [Is this a Mac I see before me?]) @@ -1532,15 +1655,50 @@ LDFLAGS="$LDFLAGS -Wl,-no_arch_warnings" ]) ]) ]) ;; + NEXTSTEP-*) + SHLIB_CFLAGS="" + SHLIB_LD='${CC} -nostdlib -r' + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadNext.o" + DL_LIBS="" + CC_SEARCH_FLAGS="" + LD_SEARCH_FLAGS="" + ;; OS/390-*) SHLIB_LD_LIBS="" CFLAGS_OPTIMIZE="" # Optimizer is buggy AC_DEFINE(_OE_SOCKETS, 1, # needed in sys/socket.h [Should OS/390 do the right thing with sockets?]) + ;; + OSF1-1.0|OSF1-1.1|OSF1-1.2) + # OSF/1 1.[012] from OSF, and derivatives, including Paragon OSF/1 + SHLIB_CFLAGS="" + # Hack: make package name same as library name + SHLIB_LD='ld -R -export $@:' + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadOSF.o" + DL_LIBS="" + CC_SEARCH_FLAGS="" + LD_SEARCH_FLAGS="" + ;; + OSF1-1.*) + # OSF/1 1.3 from OSF using ELF, and derivatives, including AD2 + SHLIB_CFLAGS="-fPIC" + AS_IF([test "$SHARED_BUILD" = 1], [SHLIB_LD="ld -shared"], [ + SHLIB_LD="ld -non_shared" + ]) + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="" + CC_SEARCH_FLAGS="" + LD_SEARCH_FLAGS="" ;; OSF1-V*) # Digital OSF/1 SHLIB_CFLAGS="" AS_IF([test "$SHARED_BUILD" = 1], [ @@ -1550,23 +1708,25 @@ ]) SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" AS_IF([test $doRpath = yes], [ - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"' LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}']) AS_IF([test "$GCC" = yes], [CFLAGS="$CFLAGS -mieee"], [ CFLAGS="$CFLAGS -DHAVE_TZSET -std1 -ieee"]) # see pthread_intro(3) for pthread support on osf1, k.furukawa - CFLAGS="$CFLAGS -DHAVE_PTHREAD_ATTR_SETSTACKSIZE" - CFLAGS="$CFLAGS -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64" - LIBS=`echo $LIBS | sed s/-lpthreads//` - AS_IF([test "$GCC" = yes], [ - LIBS="$LIBS -lpthread -lmach -lexc" - ], [ - CFLAGS="$CFLAGS -pthread" - LDFLAGS="$LDFLAGS -pthread" + AS_IF([test "${TCL_THREADS}" = 1], [ + CFLAGS="$CFLAGS -DHAVE_PTHREAD_ATTR_SETSTACKSIZE" + CFLAGS="$CFLAGS -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64" + LIBS=`echo $LIBS | sed s/-lpthreads//` + AS_IF([test "$GCC" = yes], [ + LIBS="$LIBS -lpthread -lmach -lexc" + ], [ + CFLAGS="$CFLAGS -pthread" + LDFLAGS="$LDFLAGS -pthread" + ]) ]) ;; QNX-6*) # QNX RTP # This may work for all QNX, but it was only reported for v6. @@ -1597,10 +1757,39 @@ DL_OBJS="tclLoadDl.o" DL_LIBS="" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; + SINIX*5.4*) + SHLIB_CFLAGS="-K PIC" + SHLIB_LD='${CC} -G' + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + CC_SEARCH_FLAGS="" + LD_SEARCH_FLAGS="" + ;; + SunOS-4*) + SHLIB_CFLAGS="-PIC" + SHLIB_LD="ld" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' + LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} + + # SunOS can't handle version numbers with dots in them in library + # specs, like -ltcl7.5, so use -ltcl75 instead. Also, it + # requires an extra version number at the end of .so file names. + # So, the library has to have a name like libtcl75.so.1.0 + + SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so${SHLIB_VERSION}' + UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' + TCL_LIB_VERSIONS_OK=nodots + ;; SunOS-5.[[0-6]]) # Careful to not let 5.10+ fall into this case # Note: If _REENTRANT isn't defined, then Solaris # won't define thread-safe library routines. @@ -1816,11 +2005,11 @@ UNSHARED_LIB_SUFFIX='${VERSION}.a']) DLL_INSTALL_DIR="\$(LIB_INSTALL_DIR)" AS_IF([test "${SHARED_BUILD}" = 1 -a "${SHLIB_SUFFIX}" != ""], [ LIB_SUFFIX=${SHARED_LIB_SUFFIX} - MAKE_LIB='${SHLIB_LD} -o [$]@ ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}' + MAKE_LIB='${SHLIB_LD} -o [$]@ ${OBJS} ${LDFLAGS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}' AS_IF([test "${SHLIB_SUFFIX}" = ".dll"], [ INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(BIN_INSTALL_DIR)/$(LIB_FILE)";if test -f $(LIB_FILE).a; then $(INSTALL_DATA) $(LIB_FILE).a "$(LIB_INSTALL_DIR)"; fi;' DLL_INSTALL_DIR="\$(BIN_INSTALL_DIR)" ], [ INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(LIB_INSTALL_DIR)/$(LIB_FILE)"' @@ -1923,16 +2112,17 @@ # # Results: # # Defines some of the following vars: # NO_DIRENT_H +# NO_FLOAT_H +# NO_VALUES_H # NO_STDLIB_H # NO_STRING_H # NO_SYS_WAIT_H # NO_DLFCN_H # HAVE_SYS_PARAM_H -# # HAVE_STRING_H ? # #-------------------------------------------------------------------- AC_DEFUN([SC_MISSING_POSIX_HEADERS], [ @@ -1960,10 +2150,12 @@ if test $tcl_cv_dirent_h = no; then AC_DEFINE(NO_DIRENT_H, 1, [Do we have ?]) fi + AC_CHECK_HEADER(float.h, , [AC_DEFINE(NO_FLOAT_H, 1, [Do we have ?])]) + AC_CHECK_HEADER(values.h, , [AC_DEFINE(NO_VALUES_H, 1, [Do we have ?])]) AC_CHECK_HEADER(stdlib.h, tcl_ok=1, tcl_ok=0) AC_EGREP_HEADER(strtol, stdlib.h, , tcl_ok=0) AC_EGREP_HEADER(strtoul, stdlib.h, , tcl_ok=0) AC_EGREP_HEADER(strtod, stdlib.h, , tcl_ok=0) if test $tcl_ok = 0; then @@ -2102,10 +2294,14 @@ case $system in OSF*) AC_DEFINE(USE_FIONBIO, 1, [Should we use FIONBIO?]) AC_MSG_RESULT([FIONBIO]) ;; + SunOS-4*) + AC_DEFINE(USE_FIONBIO, 1, [Should we use FIONBIO?]) + AC_MSG_RESULT([FIONBIO]) + ;; *) AC_MSG_RESULT([O_NONBLOCK]) ;; esac ]) @@ -2141,11 +2337,11 @@ if test $tcl_cv_member_tm_tzadj = yes ; then AC_DEFINE(HAVE_TM_TZADJ, 1, [Should we use the tm_tzadj field of struct tm?]) fi AC_CACHE_CHECK([tm_gmtoff in struct tm], tcl_cv_member_tm_gmtoff, [ - AC_TRY_COMPILE([#include ], [struct tm tm; tm.tm_gmtoff;], + AC_TRY_COMPILE([#include ], [struct tm tm; (void)tm.tm_gmtoff;], tcl_cv_member_tm_gmtoff=yes, tcl_cv_member_tm_gmtoff=no)]) if test $tcl_cv_member_tm_gmtoff = yes ; then AC_DEFINE(HAVE_TM_GMTOFF, 1, [Should we use the tm_gmtoff field of struct tm?]) fi @@ -2180,24 +2376,17 @@ #-------------------------------------------------------------------- # SC_TCL_LINK_LIBS # # Search for the libraries needed to link the Tcl shell. # Things like the math library (-lm) and socket stuff (-lsocket vs. -# -lnsl) or thread library (-lpthread) are dealt with here. +# -lnsl) are dealt with here. # # Arguments: # None. # # Results: # -# Sets the following vars: -# THREADS_LIBS Thread library(s) -# -# Defines the following vars: -# _REENTRANT -# _THREAD_SAFE -# # Might append to the following vars: # LIBS # MATH_LIBS # # Might define the following vars: @@ -2251,59 +2440,10 @@ LIBS="$LIBS -lsocket -lnsl" AC_CHECK_FUNC(accept, tcl_checkNsl=0, [LIBS=$tk_oldLibs]) fi AC_CHECK_FUNC(gethostbyname, , [AC_CHECK_LIB(nsl, gethostbyname, [LIBS="$LIBS -lnsl"])]) - - AC_DEFINE(_REENTRANT, 1, [Do we want the reentrant OS API?]) - AC_DEFINE(_THREAD_SAFE, 1, [Do we want the thread-safe OS API?]) - AC_CHECK_LIB(pthread,pthread_mutex_init,tcl_ok=yes,tcl_ok=no) - if test "$tcl_ok" = "no"; then - # Check a little harder for __pthread_mutex_init in the same - # library, as some systems hide it there until pthread.h is - # defined. We could alternatively do an AC_TRY_COMPILE with - # pthread.h, but that will work with libpthread really doesn't - # exist, like AIX 4.2. [Bug: 4359] - AC_CHECK_LIB(pthread, __pthread_mutex_init, - tcl_ok=yes, tcl_ok=no) - fi - - if test "$tcl_ok" = "yes"; then - # The space is needed - THREADS_LIBS=" -lpthread" - else - AC_CHECK_LIB(pthreads, pthread_mutex_init, - _ok=yes, tcl_ok=no) - if test "$tcl_ok" = "yes"; then - # The space is needed - THREADS_LIBS=" -lpthreads" - else - AC_CHECK_LIB(c, pthread_mutex_init, - tcl_ok=yes, tcl_ok=no) - if test "$tcl_ok" = "no"; then - AC_CHECK_LIB(c_r, pthread_mutex_init, - tcl_ok=yes, tcl_ok=no) - if test "$tcl_ok" = "yes"; then - # The space is needed - THREADS_LIBS=" -pthread" - else - AC_MSG_WARN([Don't know how to find pthread lib on your system - you must edit the LIBS in the Makefile...]) - fi - fi - fi - fi - - # Does the pthread-implementation provide - # 'pthread_attr_setstacksize' ? - - ac_saved_libs=$LIBS - LIBS="$LIBS $THREADS_LIBS" - AC_CHECK_FUNCS(pthread_attr_setstacksize pthread_atfork) - LIBS=$ac_saved_libs - - # TIP #509 - AC_CHECK_DECLS([PTHREAD_MUTEX_RECURSIVE],tcl_ok=yes,tcl_ok=no, [[#include ]]) ]) #-------------------------------------------------------------------- # SC_TCL_EARLY_FLAGS # @@ -2375,19 +2515,19 @@ AC_CACHE_VAL(tcl_cv_type_64bit,[ tcl_cv_type_64bit=none # See if the compiler knows natively about __int64 AC_TRY_COMPILE(,[__int64 value = (__int64) 0;], tcl_type_64bit=__int64, tcl_type_64bit="long long") - # See if we could use long anyway Note that we substitute in the + # See if we should use long anyway Note that we substitute in the # type that is our current guess for a 64-bit type inside this check # program, so it should be modified only carefully... AC_TRY_COMPILE(,[switch (0) { case 1: case (sizeof(]${tcl_type_64bit}[)==sizeof(long)): ; }],tcl_cv_type_64bit=${tcl_type_64bit})]) if test "${tcl_cv_type_64bit}" = none ; then - AC_DEFINE(TCL_WIDE_INT_IS_LONG, 1, [Do 'long' and 'long long' have the same size (64-bit)?]) - AC_MSG_RESULT([yes]) + AC_DEFINE(TCL_WIDE_INT_IS_LONG, 1, [Are wide integers to be implemented with C 'long's?]) + AC_MSG_RESULT([using long]) else AC_DEFINE_UNQUOTED(TCL_WIDE_INT_TYPE,${tcl_cv_type_64bit}, [What type should be used to define wide integers?]) AC_MSG_RESULT([${tcl_cv_type_64bit}]) @@ -2486,11 +2626,14 @@ AC_DEFUN([SC_TCL_CHECK_BROKEN_FUNC],[ AC_CHECK_FUNC($1, tcl_ok=1, tcl_ok=0) if test ["$tcl_ok"] = 1; then AC_CACHE_CHECK([proper ]$1[ implementation], [tcl_cv_]$1[_unbroken], - AC_TRY_RUN([[int main() {]$2[}]],[tcl_cv_]$1[_unbroken]=ok, + AC_TRY_RUN([[ +#include +#include +int main() {]$2[}]],[tcl_cv_]$1[_unbroken]=ok, [tcl_cv_]$1[_unbroken]=broken,[tcl_cv_]$1[_unbroken]=unknown)) if test ["$tcl_cv_]$1[_unbroken"] = "ok"; then tcl_ok=1 else tcl_ok=0 @@ -2517,11 +2660,24 @@ # HAVE_GETHOSTBYADDR_R_7 # HAVE_GETHOSTBYADDR_R_8 # #-------------------------------------------------------------------- -AC_DEFUN([SC_TCL_GETHOSTBYADDR_R], [AC_CHECK_FUNC(gethostbyaddr_r, [ +AC_DEFUN([SC_TCL_GETHOSTBYADDR_R], [ + # Avoids picking hidden internal symbol from libc + SC_TCL_GETHOSTBYADDR_R_DECL + + if test "$tcl_cv_api_gethostbyaddr_r" = yes; then + SC_TCL_GETHOSTBYADDR_R_TYPE + fi +]) + +AC_DEFUN([SC_TCL_GETHOSTBYADDR_R_DECL], [AC_CHECK_DECLS(gethostbyaddr_r, [ + tcl_cv_api_gethostbyaddr_r=yes],[tcl_cv_api_gethostbyaddr_r=no],[#include ]) +]) + +AC_DEFUN([SC_TCL_GETHOSTBYADDR_R_TYPE], [AC_CHECK_FUNC(gethostbyaddr_r, [ AC_CACHE_CHECK([for gethostbyaddr_r with 7 args], tcl_cv_api_gethostbyaddr_r_7, [ AC_TRY_COMPILE([ #include ], [ char *addr; @@ -2578,18 +2734,31 @@ # None # # Results: # # Might define the following vars: -# HAVE_GETHOSTBYADDR_R -# HAVE_GETHOSTBYADDR_R_3 -# HAVE_GETHOSTBYADDR_R_5 -# HAVE_GETHOSTBYADDR_R_6 +# HAVE_GETHOSTBYNAME_R +# HAVE_GETHOSTBYNAME_R_3 +# HAVE_GETHOSTBYNAME_R_5 +# HAVE_GETHOSTBYNAME_R_6 # #-------------------------------------------------------------------- -AC_DEFUN([SC_TCL_GETHOSTBYNAME_R], [AC_CHECK_FUNC(gethostbyname_r, [ +AC_DEFUN([SC_TCL_GETHOSTBYNAME_R], [ + # Avoids picking hidden internal symbol from libc + SC_TCL_GETHOSTBYNAME_R_DECL + + if test "$tcl_cv_api_gethostbyname_r" = yes; then + SC_TCL_GETHOSTBYNAME_R_TYPE + fi +]) + +AC_DEFUN([SC_TCL_GETHOSTBYNAME_R_DECL], [AC_CHECK_DECLS(gethostbyname_r, [ + tcl_cv_api_gethostbyname_r=yes],[tcl_cv_api_gethostbyname_r=no],[#include ]) +]) + +AC_DEFUN([SC_TCL_GETHOSTBYNAME_R_TYPE], [AC_CHECK_FUNC(gethostbyname_r, [ AC_CACHE_CHECK([for gethostbyname_r with 6 args], tcl_cv_api_gethostbyname_r_6, [ AC_TRY_COMPILE([ #include ], [ char *name; @@ -2903,131 +3072,8 @@ [Use compat implementation of getaddrinfo() and friends]) AC_LIBOBJ([fake-rfc2553]) AC_CHECK_FUNC(strlcpy) fi ]) - -#------------------------------------------------------------------------ -# SC_CC_FOR_BUILD -# For cross compiles, locate a C compiler that can generate native binaries. -# -# Arguments: -# none -# -# Results: -# Substitutes the following vars: -# CC_FOR_BUILD -# EXEEXT_FOR_BUILD -#------------------------------------------------------------------------ - -dnl Get a default for CC_FOR_BUILD to put into Makefile. -AC_DEFUN([AX_CC_FOR_BUILD],[# Put a plausible default for CC_FOR_BUILD in Makefile. - if test -z "$CC_FOR_BUILD"; then - if test "x$cross_compiling" = "xno"; then - CC_FOR_BUILD='$(CC)' - else - AC_MSG_CHECKING([for gcc]) - AC_CACHE_VAL(ac_cv_path_cc, [ - search_path=`echo ${PATH} | sed -e 's/:/ /g'` - for dir in $search_path ; do - for j in `ls -r $dir/gcc 2> /dev/null` \ - `ls -r $dir/gcc 2> /dev/null` ; do - if test x"$ac_cv_path_cc" = x ; then - if test -f "$j" ; then - ac_cv_path_cc=$j - break - fi - fi - done - done - ]) - fi - fi - AC_SUBST(CC_FOR_BUILD) - # Also set EXEEXT_FOR_BUILD. - if test "x$cross_compiling" = "xno"; then - EXEEXT_FOR_BUILD='$(EXEEXT)' - OBJEXT_FOR_BUILD='$(OBJEXT)' - else - OBJEXT_FOR_BUILD='.no' - AC_CACHE_CHECK([for build system executable suffix], bfd_cv_build_exeext, - [rm -f conftest* - echo 'int main () { return 0; }' > conftest.c - bfd_cv_build_exeext= - ${CC_FOR_BUILD} -o conftest conftest.c 1>&5 2>&5 - for file in conftest.*; do - case $file in - *.c | *.o | *.obj | *.ilk | *.pdb) ;; - *) bfd_cv_build_exeext=`echo $file | sed -e s/conftest//` ;; - esac - done - rm -f conftest* - test x"${bfd_cv_build_exeext}" = x && bfd_cv_build_exeext=no]) - EXEEXT_FOR_BUILD="" - test x"${bfd_cv_build_exeext}" != xno && EXEEXT_FOR_BUILD=${bfd_cv_build_exeext} - fi - AC_SUBST(EXEEXT_FOR_BUILD)])dnl - AC_SUBST(OBJEXT_FOR_BUILD)])dnl -]) - - -#------------------------------------------------------------------------ -# SC_ZIPFS_SUPPORT -# Locate a zip encoder installed on the system path, or none. -# -# Arguments: -# none -# -# Results: -# Substitutes the following vars: -# ZIP_PROG -# ZIP_PROG_OPTIONS -# ZIP_PROG_VFSSEARCH -# ZIP_INSTALL_OBJS -#------------------------------------------------------------------------ - -AC_DEFUN([SC_ZIPFS_SUPPORT], [ - ZIP_PROG="" - ZIP_PROG_OPTIONS="" - ZIP_PROG_VFSSEARCH="" - ZIP_INSTALL_OBJS="" - - AC_MSG_CHECKING([for zip]) - AC_CACHE_VAL(ac_cv_path_zip, [ - search_path=`echo ${PATH} | sed -e 's/:/ /g'` - for dir in $search_path ; do - for j in `ls -r $dir/zip 2> /dev/null` \ - `ls -r $dir/zip 2> /dev/null` ; do - if test x"$ac_cv_path_zip" = x ; then - if test -f "$j" ; then - ac_cv_path_zip=$j - break - fi - fi - done - done - ]) - if test -f "$ac_cv_path_zip" ; then - ZIP_PROG="$ac_cv_path_zip" - AC_MSG_RESULT([$ZIP_PROG]) - ZIP_PROG_OPTIONS="-rq" - ZIP_PROG_VFSSEARCH="*" - AC_MSG_RESULT([Found INFO Zip in environment]) - # Use standard arguments for zip - else - # It is not an error if an installed version of Zip can't be located. - # We can use the locally distributed minizip instead - ZIP_PROG="./minizip${EXEEXT_FOR_BUILD}" - ZIP_PROG_OPTIONS="-o -r" - ZIP_PROG_VFSSEARCH="*" - ZIP_INSTALL_OBJS="minizip${EXEEXT_FOR_BUILD}" - AC_MSG_RESULT([No zip found on PATH. Building minizip]) - fi - AC_SUBST(ZIP_PROG) - AC_SUBST(ZIP_PROG_OPTIONS) - AC_SUBST(ZIP_PROG_VFSSEARCH) - AC_SUBST(ZIP_INSTALL_OBJS) -]) - # Local Variables: # mode: autoconf # End: Index: unix/tcl.pc.in ================================================================== --- unix/tcl.pc.in +++ unix/tcl.pc.in @@ -2,12 +2,10 @@ prefix=@prefix@ exec_prefix=@exec_prefix@ libdir=@libdir@ includedir=@includedir@ -libfile=@TCL_LIB_FILE@ -zipfile=@TCL_ZIP_FILE@ Name: Tool Command Language Description: Tcl is a powerful, easy-to-learn dynamic programming language, suitable for a wide range of uses. URL: http://www.tcl.tk/ Version: @TCL_VERSION@@TCL_PATCH_LEVEL@ 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.0a0 +Version: 8.6.10 Release: 2 License: BSD Group: Development/Languages Source: http://prdownloads.sourceforge.net/tcl/tcl%{version}-src.tar.gz URL: http://www.tcl.tk/ Index: unix/tclAppInit.c ================================================================== --- unix/tclAppInit.c +++ unix/tclAppInit.c @@ -77,12 +77,10 @@ XtToolkitInitialize(); #endif #ifdef TCL_LOCAL_MAIN_HOOK TCL_LOCAL_MAIN_HOOK(&argc, &argv); -#else - TclZipfs_AppHook(&argc, &argv); #endif Tcl_Main(argc, argv, TCL_LOCAL_APPINIT); return 0; /* Needed only to prevent compiler warning. */ } Index: unix/tclConfig.h.in ================================================================== --- unix/tclConfig.h.in +++ unix/tclConfig.h.in @@ -1,10 +1,13 @@ /* ../unix/tclConfig.h.in. Generated from configure.ac by autoheader. */ #ifndef _TCLCONFIG #define _TCLCONFIG + +/* Define if building universal (internal helper macro) */ +#undef AC_APPLE_UNIVERSAL_BUILD /* Is gettimeofday() actually declared in ? */ #undef GETTOD_NOT_DECLARED /* Define to 1 if you have the header file. */ @@ -28,10 +31,18 @@ /* Do we have access to Darwin CoreFoundation.framework? */ #undef HAVE_COREFOUNDATION /* Is the cpuid instruction usable? */ #undef HAVE_CPUID + +/* Define to 1 if you have the declaration of `gethostbyaddr_r', and to 0 if + you don't. */ +#undef HAVE_DECL_GETHOSTBYADDR_R + +/* Define to 1 if you have the declaration of `gethostbyname_r', and to 0 if + you don't. */ +#undef HAVE_DECL_GETHOSTBYNAME_R /* Is 'DIR64' in ? */ #undef HAVE_DIR64 /* Define to 1 if you have the `freeaddrinfo' function. */ @@ -209,14 +220,14 @@ #undef HAVE_STRUCT_SOCKADDR_STORAGE /* Is 'struct stat64' in ? */ #undef HAVE_STRUCT_STAT64 -/* Define to 1 if `st_blksize' is member of `struct stat'. */ +/* Define to 1 if `st_blksize' is a member of `struct stat'. */ #undef HAVE_STRUCT_STAT_ST_BLKSIZE -/* Define to 1 if `st_blocks' is member of `struct stat'. */ +/* Define to 1 if `st_blocks' is a member of `struct stat'. */ #undef HAVE_STRUCT_STAT_ST_BLOCKS /* Define to 1 if you have the header file. */ #undef HAVE_SYS_FILIO_H @@ -295,10 +306,13 @@ /* Do we have ? */ #undef NO_DLFCN_H /* Do we have fd_set? */ #undef NO_FD_SET + +/* Do we have ? */ +#undef NO_FLOAT_H /* Do we have fstatfs()? */ #undef NO_FSTATFS /* Do we have gettimeofday()? */ @@ -331,10 +345,13 @@ /* Do we have uname() */ #undef NO_UNAME /* Do we have a usable 'union wait'? */ #undef NO_UNION_WAIT + +/* Do we have ? */ +#undef NO_VALUES_H /* Do we have wait3() */ #undef NO_WAIT3 /* Define to the address where bug reports for this package should be sent. */ @@ -346,10 +363,13 @@ /* Define to the full name and version of this package. */ #undef PACKAGE_STRING /* Define to the one symbol short name of this package. */ #undef PACKAGE_TARNAME + +/* Define to the home page for this package. */ +#undef PACKAGE_URL /* Define to the version of this package. */ #undef PACKAGE_VERSION /* Is this a static build? */ @@ -385,18 +405,24 @@ /* Is memory debugging enabled? */ #undef TCL_MEM_DEBUG /* What is the default extension for shared libraries? */ #undef TCL_SHLIB_EXT + +/* Are we building with threads enabled? */ +#undef TCL_THREADS + +/* Build libtommath? */ +#undef TCL_TOMMATH /* Do we allow unloading of shared libraries? */ #undef TCL_UNLOAD_DLLS /* Does this platform have wide high-resolution clicks? */ #undef TCL_WIDE_CLICKS -/* Do Tcl_WideInt, 'long' and 'long long' all have the same size (64-bit) ? */ +/* Are wide integers to be implemented with C 'long's? */ #undef TCL_WIDE_INT_IS_LONG /* What type should be used to define wide integers? */ #undef TCL_WIDE_INT_TYPE @@ -419,13 +445,21 @@ #undef USE_THREAD_ALLOC /* Should we use vfork() instead of fork()? */ #undef USE_VFORK -/* Define to 1 if your processor stores words with the most significant byte - first (like Motorola and SPARC, unlike Intel and VAX). */ -#undef WORDS_BIGENDIAN +/* Define WORDS_BIGENDIAN to 1 if your processor stores words with the most + significant byte first (like Motorola and SPARC, unlike Intel). */ +#if defined AC_APPLE_UNIVERSAL_BUILD +# if defined __BIG_ENDIAN__ +# define WORDS_BIGENDIAN 1 +# endif +#else +# ifndef WORDS_BIGENDIAN +# undef WORDS_BIGENDIAN +# endif +#endif /* Are Darwin SUSv3 extensions available? */ #undef _DARWIN_C_SOURCE /* Add the _ISOC99_SOURCE flag when building */ @@ -476,11 +510,11 @@ #undef mode_t /* Define to `int' if does not define. */ #undef pid_t -/* Define to `unsigned' if does not define. */ +/* Define to `unsigned int' if does not define. */ #undef size_t /* Define as int if socklen_t is not available */ #undef socklen_t Index: unix/tclConfig.sh.in ================================================================== --- unix/tclConfig.sh.in +++ unix/tclConfig.sh.in @@ -37,13 +37,10 @@ TCL_SHARED_BUILD=@TCL_SHARED_BUILD@ # The name of the Tcl library (may be either a .a file or a shared library): TCL_LIB_FILE='@TCL_LIB_FILE@' -# The name of a zip containing the /library and /encodings (may be either a .zip file or a shared library): -TCL_ZIP_FILE='@TCL_ZIP_FILE@' - # Additional libraries to use when linking Tcl. TCL_LIBS='@TCL_LIBS@' # Top-level directory in which Tcl's platform-independent files are # installed. @@ -67,11 +64,11 @@ # Base command to use for combining object files into a static library: TCL_STLIB_LD='@STLIB_LD@' # Either '$LIBS' (if dependent libraries should be included when linking -# shared libraries) or an empty string. See Tcl's configure.ac for more +# shared libraries) or an empty string. See Tcl's configure.in for more # explanation. TCL_SHLIB_LD_LIBS='@SHLIB_LD_LIBS@' # Suffix to use for the name of a shared library. TCL_SHLIB_SUFFIX='@SHLIB_SUFFIX@' @@ -165,5 +162,8 @@ # Path to the Tcl stub library in the build directory. TCL_BUILD_STUB_LIB_PATH='@TCL_BUILD_STUB_LIB_PATH@' # Path to the Tcl stub library in the install directory. TCL_STUB_LIB_PATH='@TCL_STUB_LIB_PATH@' + +# Flag, 1: we built Tcl with threads enabled, 0 we didn't +TCL_THREADS=@TCL_THREADS@ DELETED unix/tclEpollNotfy.c Index: unix/tclEpollNotfy.c ================================================================== --- unix/tclEpollNotfy.c +++ /dev/null @@ -1,835 +0,0 @@ -/* - * tclEpollNotfy.c -- - * - * This file contains the implementation of the epoll()-based - * Linux-specific notifier, which is the lowest-level part of the Tcl - * event loop. This file works together with generic/tclNotify.c. - * - * Copyright (c) 1995-1997 Sun Microsystems, Inc. - * Copyright (c) 2016 Lucio Andrés Illanes Albornoz - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#include "tclInt.h" -#ifndef HAVE_COREFOUNDATION /* Darwin/Mac OS X CoreFoundation notifier is - * in tclMacOSXNotify.c */ -#if defined(NOTIFIER_EPOLL) && TCL_THREADS -#define _GNU_SOURCE /* For pipe2(2) */ -#include -#include -#include -#ifdef HAVE_EVENTFD -#include -#endif /* HAVE_EVENTFD */ -#include - -/* - * This structure is used to keep track of the notifier info for a registered - * file. - */ - -struct PlatformEventData; -typedef struct FileHandler { - int fd; - int mask; /* Mask of desired events: TCL_READABLE, - * etc. */ - 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. */ - ClientData 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. */ - struct PlatformEventData *pedPtr; - /* Pointer to PlatformEventData associating this - * FileHandler with epoll(7) events. */ -} FileHandler; - -/* - * The following structure associates a FileHandler and the thread that owns - * it with the file descriptors of interest and their event masks passed to - * epoll_ctl(2) and their corresponding event(s) returned by epoll_wait(2). - */ - -struct ThreadSpecificData; -struct PlatformEventData { - FileHandler *filePtr; - struct ThreadSpecificData *tsdPtr; -}; - -/* - * The following structure is what is added to the Tcl event queue when file - * handlers are ready to fire. - */ - -typedef struct { - Tcl_Event header; /* Information that is standard for all - * events. */ - int fd; /* File descriptor that is ready. Used to find - * the FileHandler structure for the file - * (can't point directly to the FileHandler - * structure because it could go away while - * the event is queued). */ -} FileHandlerEvent; - -/* - * The following static structure contains the state information for the - * epoll based implementation of the Tcl notifier. One of these structures is - * created for each thread that is using the notifier. - */ - -LIST_HEAD(PlatformReadyFileHandlerList, FileHandler); -typedef struct ThreadSpecificData { - FileHandler *triggerFilePtr; - FileHandler *firstFileHandlerPtr; - /* Pointer to head of file handler list. */ - struct PlatformReadyFileHandlerList firstReadyFileHandlerPtr; - /* Pointer to head of list of FileHandlers - * associated with regular files (S_IFREG) - * that are ready for I/O. */ - pthread_mutex_t notifierMutex; - /* Mutex protecting notifier termination in - * PlatformEventsFinalize. */ -#ifdef HAVE_EVENTFD - int triggerEventFd; /* eventfd(2) used by other threads to wake - * up this thread for inter-thread IPC. */ -#else - int triggerPipe[2]; /* pipe(2) used by other threads to wake - * up this thread for inter-thread IPC. */ -#endif /* HAVE_EVENTFD */ - int eventsFd; /* epoll(7) file descriptor used to wait for - * fds */ - struct epoll_event *readyEvents; - /* Pointer to at most maxReadyEvents events - * returned by epoll_wait(2). */ - size_t maxReadyEvents; /* Count of epoll_events in readyEvents. */ -} ThreadSpecificData; - -static Tcl_ThreadDataKey dataKey; - -/* - * Forward declarations. - */ - -static void PlatformEventsControl(FileHandler *filePtr, - ThreadSpecificData *tsdPtr, int op, int isNew); -static void PlatformEventsFinalize(void); -static void PlatformEventsInit(void); -static int PlatformEventsTranslate(struct epoll_event *event); -static int PlatformEventsWait(struct epoll_event *events, - size_t numEvents, struct timeval *timePtr); - -/* - * Incorporate the base notifier API. - */ - -#include "tclUnixNotfy.c" - -/* - *---------------------------------------------------------------------- - * - * Tcl_InitNotifier -- - * - * Initializes the platform specific notifier state. - * - * Results: - * Returns a handle to the notifier state for this thread. - * - * Side effects: - * If no initNotifierProc notifier hook exists, PlatformEventsInit - * is called. - * - *---------------------------------------------------------------------- - */ - -ClientData -Tcl_InitNotifier(void) -{ - if (tclNotifierHooks.initNotifierProc) { - return tclNotifierHooks.initNotifierProc(); - } else { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - PlatformEventsInit(); - return tsdPtr; - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_FinalizeNotifier -- - * - * This function is called to cleanup the notifier state before a thread - * is terminated. - * - * Results: - * None. - * - * Side effects: - * If no finalizeNotifierProc notifier hook exists, PlatformEvents- - * Finalize is called. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_FinalizeNotifier( - ClientData clientData) /* Not used. */ -{ - if (tclNotifierHooks.finalizeNotifierProc) { - tclNotifierHooks.finalizeNotifierProc(clientData); - return; - } else { - PlatformEventsFinalize(); - } -} - -/* - *---------------------------------------------------------------------- - * - * PlatformEventsControl -- - * - * This function registers interest for the file descriptor and the mask - * of TCL_* bits associated with filePtr on the epoll file descriptor - * associated with tsdPtr. - * - * Future calls to epoll_wait will return filePtr and tsdPtr alongside - * with the event registered here via the PlatformEventData struct. - * - * Results: - * None. - * - * Side effects: - * - If adding a new file descriptor, a PlatformEventData struct will be - * allocated and associated with filePtr. - * - fstat is called on the file descriptor; if it is associated with a - * regular file (S_IFREG,) filePtr is considered to be ready for I/O - * and added to or deleted from the corresponding list in tsdPtr. - * - If it is not associated with a regular file, the file descriptor is - * added, modified concerning its mask of events of interest, or - * deleted from the epoll file descriptor of the calling thread. - * - *---------------------------------------------------------------------- - */ - -void -PlatformEventsControl( - FileHandler *filePtr, - ThreadSpecificData *tsdPtr, - int op, - int isNew) -{ - struct epoll_event newEvent; - struct PlatformEventData *newPedPtr; - struct stat fdStat; - - newEvent.events = 0; - if (filePtr->mask & (TCL_READABLE | TCL_EXCEPTION)) { - newEvent.events |= EPOLLIN; - } - if (filePtr->mask & TCL_WRITABLE) { - newEvent.events |= EPOLLOUT; - } - if (isNew) { - newPedPtr = Tcl_Alloc(sizeof(*newPedPtr)); - newPedPtr->filePtr = filePtr; - newPedPtr->tsdPtr = tsdPtr; - filePtr->pedPtr = newPedPtr; - } - newEvent.data.ptr = filePtr->pedPtr; - - /* - * N.B. As discussed in Tcl_WaitForEvent(), epoll(7) does not support - * regular files (S_IFREG.) Therefore, filePtr is in these cases simply - * added or deleted from the list of FileHandlers associated with regular - * files belonging to tsdPtr. - */ - - if (fstat(filePtr->fd, &fdStat) == -1) { - Tcl_Panic("fstat: %s", strerror(errno)); - } else if ((fdStat.st_mode & S_IFMT) == S_IFREG) { - switch (op) { - case EPOLL_CTL_ADD: - if (isNew) { - LIST_INSERT_HEAD(&tsdPtr->firstReadyFileHandlerPtr, filePtr, - readyNode); - } - break; - case EPOLL_CTL_DEL: - LIST_REMOVE(filePtr, readyNode); - break; - } - return; - } else if (epoll_ctl(tsdPtr->eventsFd, op, filePtr->fd, &newEvent) == -1) { - Tcl_Panic("epoll_ctl: %s", strerror(errno)); - } -} - -/* - *---------------------------------------------------------------------- - * - * PlatformEventsFinalize -- - * - * This function closes the eventfd and the epoll file descriptor and - * frees the epoll_event structs owned by the thread of the caller. The - * above operations are protected by tsdPtr->notifierMutex, which is - * destroyed thereafter. - * - * Results: - * None. - * - * Side effects: - * While tsdPtr->notifierMutex is held: - * - The per-thread eventfd(2) is closed, if non-zero, and set to -1. - * - The per-thread epoll(7) fd is closed, if non-zero, and set to 0. - * - The per-thread epoll_event structs are freed, if any, and set to 0. - * - * tsdPtr->notifierMutex is destroyed. - * - *---------------------------------------------------------------------- - */ - -void -PlatformEventsFinalize( - void) -{ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - pthread_mutex_lock(&tsdPtr->notifierMutex); -#ifdef HAVE_EVENTFD - if (tsdPtr->triggerEventFd) { - close(tsdPtr->triggerEventFd); - tsdPtr->triggerEventFd = -1; - } -#else /* !HAVE_EVENTFD */ - if (tsdPtr->triggerPipe[0]) { - close(tsdPtr->triggerPipe[0]); - tsdPtr->triggerPipe[0] = -1; - } - if (tsdPtr->triggerPipe[1]) { - close(tsdPtr->triggerPipe[1]); - tsdPtr->triggerPipe[1] = -1; - } -#endif /* HAVE_EVENTFD */ - Tcl_Free(tsdPtr->triggerFilePtr->pedPtr); - Tcl_Free(tsdPtr->triggerFilePtr); - if (tsdPtr->eventsFd > 0) { - close(tsdPtr->eventsFd); - tsdPtr->eventsFd = 0; - } - if (tsdPtr->readyEvents) { - Tcl_Free(tsdPtr->readyEvents); - tsdPtr->maxReadyEvents = 0; - } - pthread_mutex_unlock(&tsdPtr->notifierMutex); - if ((errno = pthread_mutex_destroy(&tsdPtr->notifierMutex))) { - Tcl_Panic("pthread_mutex_destroy: %s", strerror(errno)); - } -} - -/* - *---------------------------------------------------------------------- - * - * PlatformEventsInit -- - * - * This function abstracts creating a kqueue fd via the epoll_create - * system call and allocating memory for the epoll_event structs in - * tsdPtr for the thread of the caller. - * - * Results: - * None. - * - * Side effects: - * The following per-thread entities are initialised: - * - notifierMutex is initialised. - * - The eventfd(2) is created w/ EFD_CLOEXEC and EFD_NONBLOCK. - * - The epoll(7) fd is created w/ EPOLL_CLOEXEC. - * - A FileHandler struct is allocated and initialised for the - * eventfd(2), registering interest for TCL_READABLE on it via - * PlatformEventsControl(). - * - readyEvents and maxReadyEvents are initialised with 512 - * epoll_events. - * - *---------------------------------------------------------------------- - */ - -void -PlatformEventsInit(void) -{ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - FileHandler *filePtr; - - errno = pthread_mutex_init(&tsdPtr->notifierMutex, NULL); - if (errno) { - Tcl_Panic("Tcl_InitNotifier: %s", "could not create mutex"); - } - filePtr = Tcl_Alloc(sizeof(*filePtr)); -#ifdef HAVE_EVENTFD - tsdPtr->triggerEventFd = eventfd(0, EFD_CLOEXEC | EFD_NONBLOCK); - if (tsdPtr->triggerEventFd <= 0) { - Tcl_Panic("Tcl_InitNotifier: %s", "could not create trigger eventfd"); - } - filePtr->fd = tsdPtr->triggerEventFd; -#else /* !HAVE_EVENTFD */ - if (pipe2(tsdPtr->triggerPipe, O_CLOEXEC | O_NONBLOCK) != 0) { - Tcl_Panic("Tcl_InitNotifier: %s", "could not create trigger pipe"); - } - filePtr->fd = tsdPtr->triggerPipe[0]; -#endif /* HAVE_EVENTFD */ - tsdPtr->triggerFilePtr = filePtr; - if ((tsdPtr->eventsFd = epoll_create1(EPOLL_CLOEXEC)) == -1) { - Tcl_Panic("epoll_create1: %s", strerror(errno)); - } - filePtr->mask = TCL_READABLE; - PlatformEventsControl(filePtr, tsdPtr, EPOLL_CTL_ADD, 1); - if (!tsdPtr->readyEvents) { - tsdPtr->maxReadyEvents = 512; - tsdPtr->readyEvents = Tcl_Alloc( - tsdPtr->maxReadyEvents * sizeof(tsdPtr->readyEvents[0])); - } - LIST_INIT(&tsdPtr->firstReadyFileHandlerPtr); -} - -/* - *---------------------------------------------------------------------- - * - * PlatformEventsTranslate -- - * - * This function translates the platform-specific mask of returned events - * in eventPtr to a mask of TCL_* bits. - * - * Results: - * Returns the translated mask. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -PlatformEventsTranslate( - struct epoll_event *eventPtr) -{ - int mask; - - mask = 0; - if (eventPtr->events & (EPOLLIN | EPOLLHUP)) { - mask |= TCL_READABLE; - } - if (eventPtr->events & EPOLLOUT) { - mask |= TCL_WRITABLE; - } - if (eventPtr->events & EPOLLERR) { - mask |= TCL_EXCEPTION; - } - return mask; -} - -/* - *---------------------------------------------------------------------- - * - * PlatformEventsWait -- - * - * This function abstracts waiting for I/O events via epoll_wait. - * - * Results: - * Returns -1 if epoll_wait failed. Returns 0 if polling and if no events - * became available whilst polling. Returns a pointer to and the count of - * all returned events in all other cases. - * - * Side effects: - * gettimeofday(2), epoll_wait(2), and gettimeofday(2) are called, in the - * specified order. - * If timePtr specifies a positive value, it is updated to reflect the - * amount of time that has passed; if its value would {under, over}flow, - * it is set to zero. - * - *---------------------------------------------------------------------- - */ - -int -PlatformEventsWait( - struct epoll_event *events, - size_t numEvents, - struct timeval *timePtr) -{ - int numFound; - struct timeval tv0, tv1, tv_delta; - int timeout; - - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - /* - * If timePtr is NULL, epoll_wait(2) will wait indefinitely. If it - * specifies a timeout of {0,0}, epoll_wait(2) will poll. Otherwise, the - * timeout will simply be converted to milliseconds. - */ - - if (!timePtr) { - timeout = -1; - } else if (!timePtr->tv_sec && !timePtr->tv_usec) { - timeout = 0; - } else { - timeout = (int)timePtr->tv_sec * 1000; - if (timePtr->tv_usec) { - timeout += (int)timePtr->tv_usec / 1000; - } - } - - /* - * Call (and possibly block on) epoll_wait(2) and substract the delta of - * gettimeofday(2) before and after the call from timePtr if the latter is - * not NULL. Return the number of events returned by epoll_wait(2). - */ - - gettimeofday(&tv0, NULL); - numFound = epoll_wait(tsdPtr->eventsFd, events, (int)numEvents, timeout); - gettimeofday(&tv1, NULL); - if (timePtr && (timePtr->tv_sec && timePtr->tv_usec)) { - timersub(&tv1, &tv0, &tv_delta); - if (!timercmp(&tv_delta, timePtr, >)) { - timersub(timePtr, &tv_delta, timePtr); - } else { - timePtr->tv_sec = 0; - timePtr->tv_usec = 0; - } - } - return numFound; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_CreateFileHandler -- - * - * This function registers a file handler with the epoll notifier of the - * thread of the caller. - * - * Results: - * None. - * - * Side effects: - * Creates a new file handler structure. - * PlatformEventsControl() is called for the new file handler structure. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_CreateFileHandler( - int fd, /* Handle of stream to watch. */ - int mask, /* OR'ed combination of TCL_READABLE, - * TCL_WRITABLE, and TCL_EXCEPTION: indicates - * conditions under which proc should be - * called. */ - Tcl_FileProc *proc, /* Function to call for each selected - * event. */ - ClientData clientData) /* Arbitrary data to pass to proc. */ -{ - int isNew; - - if (tclNotifierHooks.createFileHandlerProc) { - tclNotifierHooks.createFileHandlerProc(fd, mask, proc, clientData); - return; - } else { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - FileHandler *filePtr; - - for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL; - filePtr = filePtr->nextPtr) { - if (filePtr->fd == fd) { - break; - } - } - if (filePtr == NULL) { - filePtr = Tcl_Alloc(sizeof(FileHandler)); - filePtr->fd = fd; - filePtr->readyMask = 0; - filePtr->nextPtr = tsdPtr->firstFileHandlerPtr; - tsdPtr->firstFileHandlerPtr = filePtr; - isNew = 1; - } else { - isNew = 0; - } - filePtr->proc = proc; - filePtr->clientData = clientData; - filePtr->mask = mask; - - PlatformEventsControl(filePtr, tsdPtr, - isNew ? EPOLL_CTL_ADD : EPOLL_CTL_MOD, isNew); - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_DeleteFileHandler -- - * - * Cancel a previously-arranged callback arrangement for a file on the - * epoll file descriptor of the thread of the caller. - * - * Results: - * None. - * - * Side effects: - * If a callback was previously registered on file, remove it. - * PlatformEventsControl() is called for the file handler structure. - * The PlatformEventData struct associated with the new file handler - * structure is freed. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_DeleteFileHandler( - int fd) /* Stream id for which to remove callback - * function. */ -{ - if (tclNotifierHooks.deleteFileHandlerProc) { - tclNotifierHooks.deleteFileHandlerProc(fd); - return; - } else { - FileHandler *filePtr, *prevPtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - /* - * Find the entry for the given file (and return if there isn't one). - */ - - for (prevPtr = NULL, filePtr = tsdPtr->firstFileHandlerPtr; ; - prevPtr = filePtr, filePtr = filePtr->nextPtr) { - if (filePtr == NULL) { - return; - } - if (filePtr->fd == fd) { - break; - } - } - - /* - * Update the check masks for this file. - */ - - PlatformEventsControl(filePtr, tsdPtr, EPOLL_CTL_DEL, 0); - if (filePtr->pedPtr) { - Tcl_Free(filePtr->pedPtr); - } - - /* - * Clean up information in the callback record. - */ - - if (prevPtr == NULL) { - tsdPtr->firstFileHandlerPtr = filePtr->nextPtr; - } else { - prevPtr->nextPtr = filePtr->nextPtr; - } - Tcl_Free(filePtr); - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_WaitForEvent -- - * - * This function is called by Tcl_DoOneEvent to wait for new events on - * the message queue. If the block time is 0, then Tcl_WaitForEvent just - * polls without blocking. - * - * The waiting logic is implemented in PlatformEventsWait. - * - * Results: - * Returns -1 if PlatformEventsWait() would block forever, otherwise - * returns 0. - * - * Side effects: - * Queues file events that are detected by PlatformEventsWait(). - * - *---------------------------------------------------------------------- - */ - -int -Tcl_WaitForEvent( - const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ -{ - if (tclNotifierHooks.waitForEventProc) { - return tclNotifierHooks.waitForEventProc(timePtr); - } else { - FileHandler *filePtr; - int mask; - Tcl_Time vTime; - /* - * Impl. notes: timeout & timeoutPtr are used if, and only if threads - * are not enabled. They are the arguments for the regular epoll_wait() - * used when the core is not thread-enabled. - */ - - struct timeval timeout, *timeoutPtr; - int numFound, numEvent; - struct PlatformEventData *pedPtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - int numQueued; - ssize_t i; - - /* - * Set up the timeout structure. Note that if there are no events to - * check for, we return with a negative result rather than blocking - * forever. - */ - - if (timePtr != NULL) { - /* - * TIP #233 (Virtualized Time). Is virtual time in effect? And do - * we actually have something to scale? If yes to both then we - * call the handler to do this scaling. - */ - - if (timePtr->sec != 0 || timePtr->usec != 0) { - vTime = *timePtr; - tclScaleTimeProcPtr(&vTime, tclTimeClientData); - timePtr = &vTime; - } - timeout.tv_sec = timePtr->sec; - timeout.tv_usec = timePtr->usec; - timeoutPtr = &timeout; - } else { - timeoutPtr = NULL; - } - - /* - * Walk the list of FileHandlers associated with regular files - * (S_IFREG) belonging to tsdPtr, queue Tcl events for them, and - * update their mask of events of interest. - * - * As epoll(7) does not support regular files, the behaviour of - * {select,poll}(2) is simply simulated here: fds associated with - * regular files are added to this list by PlatformEventsControl() and - * processed here before calling (and possibly blocking) on - * PlatformEventsWait(). - */ - - numQueued = 0; - LIST_FOREACH(filePtr, &tsdPtr->firstReadyFileHandlerPtr, readyNode) { - mask = 0; - if (filePtr->mask & TCL_READABLE) { - mask |= TCL_READABLE; - } - if (filePtr->mask & TCL_WRITABLE) { - mask |= TCL_WRITABLE; - } - - /* - * Don't bother to queue an event if the mask was previously - * non-zero since an event must still be on the queue. - */ - - if (filePtr->readyMask == 0) { - FileHandlerEvent *fileEvPtr = - Tcl_Alloc(sizeof(FileHandlerEvent)); - - fileEvPtr->header.proc = FileHandlerEventProc; - fileEvPtr->fd = filePtr->fd; - Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL); - numQueued++; - } - filePtr->readyMask = mask; - } - - /* - * If any events were queued in the above loop, force - * PlatformEventsWait() to poll as there already are events that need - * to be processed at this point. - */ - - if (numQueued) { - timeout.tv_sec = 0; - timeout.tv_usec = 0; - timeoutPtr = &timeout; - } - - /* - * Wait or poll for new events, queue Tcl events for the FileHandlers - * corresponding to them, and update the FileHandlers' mask of events - * of interest registered by the last call to Tcl_CreateFileHandler(). - * - * Events for the eventfd(2)/trigger pipe are processed here in order - * to facilitate inter-thread IPC. If another thread intends to wake - * up this thread whilst it's blocking on PlatformEventsWait(), it - * write(2)s to the eventfd(2)/trigger pipe (see Tcl_AlertNotifier(),) - * which in turn will cause PlatformEventsWait() to return - * immediately. - */ - - numFound = PlatformEventsWait(tsdPtr->readyEvents, - tsdPtr->maxReadyEvents, timeoutPtr); - for (numEvent = 0; numEvent < numFound; numEvent++) { - pedPtr = tsdPtr->readyEvents[numEvent].data.ptr; - filePtr = pedPtr->filePtr; - mask = PlatformEventsTranslate(&tsdPtr->readyEvents[numEvent]); -#ifdef HAVE_EVENTFD - if (filePtr->fd == tsdPtr->triggerEventFd) { - uint64_t eventFdVal; - i = read(tsdPtr->triggerEventFd, &eventFdVal, - sizeof(eventFdVal)); - if ((i != sizeof(eventFdVal)) && (errno != EAGAIN)) { - Tcl_Panic( - "Tcl_WaitForEvent: read from %p->triggerEventFd: %s", - (void *) tsdPtr, strerror(errno)); - } - continue; - } -#else /* !HAVE_EVENTFD */ - if (filePtr->fd == tsdPtr->triggerPipe[0]) { - char triggerPipeVal; - i = read(tsdPtr->triggerPipe[0], &triggerPipeVal, - sizeof(triggerPipeVal)); - if ((i != sizeof(triggerPipeVal)) && (errno != EAGAIN)) { - Tcl_Panic( - "Tcl_WaitForEvent: read from %p->triggerPipe[0]: %s", - (void *) tsdPtr, strerror(errno)); - } - continue; - } -#endif /* HAVE_EVENTFD */ - if (!mask) { - continue; - } - - /* - * Don't bother to queue an event if the mask was previously - * non-zero since an event must still be on the queue. - */ - - if (filePtr->readyMask == 0) { - FileHandlerEvent *fileEvPtr = - Tcl_Alloc(sizeof(FileHandlerEvent)); - - fileEvPtr->header.proc = FileHandlerEventProc; - fileEvPtr->fd = filePtr->fd; - Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL); - } - filePtr->readyMask = mask; - } - return 0; - } -} - -#endif /* NOTIFIER_EPOLL && TCL_THREADS */ -#endif /* !HAVE_COREFOUNDATION */ - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ DELETED unix/tclKqueueNotfy.c Index: unix/tclKqueueNotfy.c ================================================================== --- unix/tclKqueueNotfy.c +++ /dev/null @@ -1,853 +0,0 @@ -/* - * tclKqueueNotfy.c -- - * - * This file contains the implementation of the kqueue()-based - * DragonFly/Free/Net/OpenBSD-specific notifier, which is the lowest- - * level part of the Tcl event loop. This file works together with - * generic/tclNotify.c. - * - * Copyright (c) 1995-1997 Sun Microsystems, Inc. - * Copyright (c) 2016 Lucio Andrés Illanes Albornoz - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#include "tclInt.h" -#ifndef HAVE_COREFOUNDATION /* Darwin/Mac OS X CoreFoundation notifier is - * in tclMacOSXNotify.c */ -#if defined(NOTIFIER_KQUEUE) && TCL_THREADS - -#include -#include -#include -#include -#include - -/* - * This structure is used to keep track of the notifier info for a registered - * file. - */ - -struct PlatformEventData; -typedef struct FileHandler { - int fd; - int mask; /* Mask of desired events: TCL_READABLE, - * etc. */ - 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. */ - ClientData 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. */ - struct PlatformEventData *pedPtr; - /* Pointer to PlatformEventData associating this - * FileHandler with kevent(2) events. */ -} FileHandler; - -/* - * The following structure associates a FileHandler and the thread that owns - * it with the file descriptors of interest and their event masks passed to - * kevent(2) and their corresponding event(s) returned by kevent(2). - */ - -struct ThreadSpecificData; -struct PlatformEventData { - FileHandler *filePtr; - struct ThreadSpecificData *tsdPtr; -}; - -/* - * The following structure is what is added to the Tcl event queue when file - * handlers are ready to fire. - */ - -typedef struct { - Tcl_Event header; /* Information that is standard for all - * events. */ - int fd; /* File descriptor that is ready. Used to find - * the FileHandler structure for the file - * (can't point directly to the FileHandler - * structure because it could go away while - * the event is queued). */ -} FileHandlerEvent; - -/* - * The following static structure contains the state information for the - * kqueue based implementation of the Tcl notifier. One of these structures is - * created for each thread that is using the notifier. - */ - -LIST_HEAD(PlatformReadyFileHandlerList, FileHandler); -typedef struct ThreadSpecificData { - FileHandler *firstFileHandlerPtr; - /* Pointer to head of file handler list. */ - struct PlatformReadyFileHandlerList firstReadyFileHandlerPtr; - /* Pointer to head of list of FileHandlers - * associated with regular files (S_IFREG) - * that are ready for I/O. */ - pthread_mutex_t notifierMutex; - /* Mutex protecting notifier termination in - * PlatformEventsFinalize. */ - int triggerPipe[2]; /* pipe(2) used by other threads to wake - * up this thread for inter-thread IPC. */ - int eventsFd; /* kqueue(2) file descriptor used to wait for - * fds. */ - struct kevent *readyEvents; /* Pointer to at most maxReadyEvents events - * returned by kevent(2). */ - size_t maxReadyEvents; /* Count of kevents in readyEvents. */ -} ThreadSpecificData; - -static Tcl_ThreadDataKey dataKey; - -/* - * Forward declarations of internal functions. - */ - -static void PlatformEventsControl(FileHandler *filePtr, - ThreadSpecificData *tsdPtr, int op, int isNew); -static void PlatformEventsFinalize(void); -static void PlatformEventsInit(void); -static int PlatformEventsTranslate(struct kevent *eventPtr); -static int PlatformEventsWait(struct kevent *events, - size_t numEvents, struct timeval *timePtr); - -#include "tclUnixNotfy.c" - -/* - *---------------------------------------------------------------------- - * - * Tcl_InitNotifier -- - * - * Initializes the platform specific notifier state. - * - * Results: - * Returns a handle to the notifier state for this thread. - * - * Side effects: - * If no initNotifierProc notifier hook exists, PlatformEventsInit - * is called. - * - *---------------------------------------------------------------------- - */ - -ClientData -Tcl_InitNotifier(void) -{ - if (tclNotifierHooks.initNotifierProc) { - return tclNotifierHooks.initNotifierProc(); - } else { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - PlatformEventsInit(); - return tsdPtr; - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_FinalizeNotifier -- - * - * This function is called to cleanup the notifier state before a thread - * is terminated. - * - * Results: - * None. - * - * Side effects: - * If no finalizeNotifierProc notifier hook exists, PlatformEvents- - * Finalize is called. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_FinalizeNotifier( - ClientData clientData) /* Not used. */ -{ - if (tclNotifierHooks.finalizeNotifierProc) { - tclNotifierHooks.finalizeNotifierProc(clientData); - return; - } else { - PlatformEventsFinalize(); - } -} - -/* - *---------------------------------------------------------------------- - * - * PlatformEventsControl -- - * - * This function registers interest for the file descriptor and the mask - * of TCL_* bits associated with filePtr on the kqueue file descriptor - * associated with tsdPtr. - * - * Future calls to kevent will return filePtr and tsdPtr alongside with - * the event registered here via the PlatformEventData struct. - * - * Results: - * None. - * - * Side effects: - * - If adding a new file descriptor, a PlatformEventData struct will be - * allocated and associated with filePtr. - * - fstat is called on the file descriptor; if it is associated with - * a regular file (S_IFREG,) filePtr is considered to be ready for I/O - * and added to or deleted from the corresponding list in tsdPtr. - * - If it is not associated with a regular file, the file descriptor is - * added, modified concerning its mask of events of interest, or - * deleted from the epoll file descriptor of the calling thread. - * - If deleting a file descriptor, kevent(2) is called twice specifying - * EVFILT_READ first and then EVFILT_WRITE (see note below.) - * - *---------------------------------------------------------------------- - */ - -void -PlatformEventsControl( - FileHandler *filePtr, - ThreadSpecificData *tsdPtr, - int op, - int isNew) -{ - int numChanges; - struct kevent changeList[2]; - struct PlatformEventData *newPedPtr; - struct stat fdStat; - - if (isNew) { - newPedPtr = Tcl_Alloc(sizeof(*newPedPtr)); - newPedPtr->filePtr = filePtr; - newPedPtr->tsdPtr = tsdPtr; - filePtr->pedPtr = newPedPtr; - } - - /* - * N.B. As discussed in Tcl_WaitForEvent(), kqueue(2) does not reproduce - * the `always ready' {select,poll}(2) behaviour for regular files - * (S_IFREG) prior to FreeBSD 11.0-RELEASE. Therefore, filePtr is in these - * cases simply added or deleted from the list of FileHandlers associated - * with regular files belonging to tsdPtr. - */ - - if (fstat(filePtr->fd, &fdStat) == -1) { - Tcl_Panic("fstat: %s", strerror(errno)); - } else if ((fdStat.st_mode & S_IFMT) == S_IFREG) { - switch (op) { - case EV_ADD: - if (isNew) { - LIST_INSERT_HEAD(&tsdPtr->firstReadyFileHandlerPtr, filePtr, - readyNode); - } - break; - case EV_DELETE: - LIST_REMOVE(filePtr, readyNode); - break; - } - return; - } - - numChanges = 0; - switch (op) { - case EV_ADD: - if (filePtr->mask & (TCL_READABLE | TCL_EXCEPTION)) { - EV_SET(&changeList[numChanges], (uintptr_t)filePtr->fd, - EVFILT_READ, op, 0, 0, filePtr->pedPtr); - numChanges++; - } - if (filePtr->mask & TCL_WRITABLE) { - EV_SET(&changeList[numChanges], (uintptr_t)filePtr->fd, - EVFILT_WRITE, op, 0, 0, filePtr->pedPtr); - numChanges++; - } - if (numChanges) { - if (kevent(tsdPtr->eventsFd, changeList, numChanges, NULL, 0, - NULL) == -1) { - Tcl_Panic("kevent: %s", strerror(errno)); - } - } - break; - case EV_DELETE: - /* - * N.B. kqueue(2) has separate filters for readability and writability - * fd events. We therefore need to ensure that fds are ompletely - * removed from the kqueue(2) fd when deleting. This is exacerbated - * by changes to filePtr->mask w/o calls to PlatforEventsControl() - * after e.g. an exec(3) in a child process. - * - * As one of these calls can fail, two separate kevent(2) calls are - * made for EVFILT_{READ,WRITE}. - */ - EV_SET(&changeList[0], (uintptr_t)filePtr->fd, EVFILT_READ, op, 0, 0, - NULL); - if ((kevent(tsdPtr->eventsFd, changeList, 1, NULL, 0, NULL) == -1) - && (errno != ENOENT)) { - Tcl_Panic("kevent: %s", strerror(errno)); - } - EV_SET(&changeList[0], (uintptr_t)filePtr->fd, EVFILT_WRITE, op, 0, 0, - NULL); - if ((kevent(tsdPtr->eventsFd, changeList, 1, NULL, 0, NULL) == -1) - && (errno != ENOENT)) { - Tcl_Panic("kevent: %s", strerror(errno)); - } - break; - } -} - -/* - *---------------------------------------------------------------------- - * - * PlatformEventsFinalize -- - * - * This function closes the pipe and the kqueue file descriptors and - * frees the kevent structs owned by the thread of the caller. The above - * operations are protected by tsdPtr->notifierMutex, which is destroyed - * thereafter. - * - * Results: - * None. - * - * Side effects: - * While tsdPtr->notifierMutex is held: - * The per-thread pipe(2) fds are closed, if non-zero, and set to -1. - * The per-thread kqueue(2) fd is closed, if non-zero, and set to 0. - * The per-thread kevent structs are freed, if any, and set to 0. - * - * tsdPtr->notifierMutex is destroyed. - * - *---------------------------------------------------------------------- - */ - -void -PlatformEventsFinalize( - void) -{ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - pthread_mutex_lock(&tsdPtr->notifierMutex); - if (tsdPtr->triggerPipe[0]) { - close(tsdPtr->triggerPipe[0]); - tsdPtr->triggerPipe[0] = -1; - } - if (tsdPtr->triggerPipe[1]) { - close(tsdPtr->triggerPipe[1]); - tsdPtr->triggerPipe[1] = -1; - } - if (tsdPtr->eventsFd > 0) { - close(tsdPtr->eventsFd); - tsdPtr->eventsFd = 0; - } - if (tsdPtr->readyEvents) { - Tcl_Free(tsdPtr->readyEvents); - tsdPtr->maxReadyEvents = 0; - } - pthread_mutex_unlock(&tsdPtr->notifierMutex); - if ((errno = pthread_mutex_destroy(&tsdPtr->notifierMutex))) { - Tcl_Panic("pthread_mutex_destroy: %s", strerror(errno)); - } -} - -/* - *---------------------------------------------------------------------- - * - * PlatformEventsInit -- - * - * This function abstracts creating a kqueue fd via the kqueue system - * call and allocating memory for the kevents structs in tsdPtr for the - * thread of the caller. - * - * Results: - * None. - * - * Side effects: - * The following per-thread entities are initialised: - * - notifierMutex is initialised. - * - The pipe(2) is created; fcntl(2) is called on both fds to set - * FD_CLOEXEC and O_NONBLOCK. - * - The kqueue(2) fd is created; fcntl(2) is called on it to set - * FD_CLOEXEC. - * - A FileHandler struct is allocated and initialised for the event- - * fd(2), registering interest for TCL_READABLE on it via Platform- - * EventsControl(). - * - readyEvents and maxReadyEvents are initialised with 512 kevents. - * - *---------------------------------------------------------------------- - */ - -void -PlatformEventsInit(void) -{ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - int i, fdFl; - FileHandler *filePtr; - - errno = pthread_mutex_init(&tsdPtr->notifierMutex, NULL); - if (errno) { - Tcl_Panic("Tcl_InitNotifier: %s", "could not create mutex"); - } - if (pipe(tsdPtr->triggerPipe) != 0) { - Tcl_Panic("Tcl_InitNotifier: %s", "could not create trigger pipe"); - } else for (i = 0; i < 2; i++) { - if (fcntl(tsdPtr->triggerPipe[i], F_SETFD, FD_CLOEXEC) == -1) { - Tcl_Panic("fcntl: %s", strerror(errno)); - } else { - fdFl = fcntl(tsdPtr->triggerPipe[i], F_GETFL); - fdFl |= O_NONBLOCK; - } - if (fcntl(tsdPtr->triggerPipe[i], F_SETFL, fdFl) == -1) { - Tcl_Panic("fcntl: %s", strerror(errno)); - } - } - if ((tsdPtr->eventsFd = kqueue()) == -1) { - Tcl_Panic("kqueue: %s", strerror(errno)); - } else if (fcntl(tsdPtr->eventsFd, F_SETFD, FD_CLOEXEC) == -1) { - Tcl_Panic("fcntl: %s", strerror(errno)); - } - filePtr = Tcl_Alloc(sizeof(*filePtr)); - filePtr->fd = tsdPtr->triggerPipe[0]; - filePtr->mask = TCL_READABLE; - PlatformEventsControl(filePtr, tsdPtr, EV_ADD, 1); - if (!tsdPtr->readyEvents) { - tsdPtr->maxReadyEvents = 512; - tsdPtr->readyEvents = Tcl_Alloc( - tsdPtr->maxReadyEvents * sizeof(tsdPtr->readyEvents[0])); - } - LIST_INIT(&tsdPtr->firstReadyFileHandlerPtr); -} - -/* - *---------------------------------------------------------------------- - * - * PlatformEventsTranslate -- - * - * This function translates the platform-specific mask of returned - * events in eventPtr to a mask of TCL_* bits. - * - * Results: - * Returns the translated mask. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -PlatformEventsTranslate( - struct kevent *eventPtr) -{ - int mask; - - mask = 0; - if (eventPtr->filter == EVFILT_READ) { - mask |= TCL_READABLE; - if (eventPtr->flags & EV_ERROR) { - mask |= TCL_EXCEPTION; - } - } - if (eventPtr->filter == EVFILT_WRITE) { - mask |= TCL_WRITABLE; - if (eventPtr->flags & EV_ERROR) { - mask |= TCL_EXCEPTION; - } - } - return mask; -} - -/* - *---------------------------------------------------------------------- - * - * PlatformEventsWait -- - * - * This function abstracts waiting for I/O events via the kevent system - * call. - * - * Results: - * Returns -1 if kevent failed. Returns 0 if polling and if no events - * became available whilst polling. Returns a pointer to and the count of - * all returned events in all other cases. - * - * Side effects: - * gettimeofday(2), kevent(2), and gettimeofday(2) are called, in the - * specified order. - * If timePtr specifies a positive value, it is updated to reflect the - * amount of time that has passed; if its value would {under, over}flow, - * it is set to zero. - * - *---------------------------------------------------------------------- - */ - -int -PlatformEventsWait( - struct kevent *events, - size_t numEvents, - struct timeval *timePtr) -{ - int numFound; - struct timeval tv0, tv1, tv_delta; - struct timespec timeout, *timeoutPtr; - - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - /* - * If timePtr is NULL, kevent(2) will wait indefinitely. If it specifies a - * timeout of {0,0}, kevent(2) will poll. Otherwise, the timeout will - * simply be converted to a timespec. - */ - - if (!timePtr) { - timeoutPtr = NULL; - } else if (!timePtr->tv_sec && !timePtr->tv_usec) { - timeout.tv_sec = 0; - timeout.tv_nsec = 0; - timeoutPtr = &timeout; - } else { - timeout.tv_sec = timePtr->tv_sec; - timeout.tv_nsec = timePtr->tv_usec * 1000; - timeoutPtr = &timeout; - } - - /* - * Call (and possibly block on) kevent(2) and substract the delta of - * gettimeofday(2) before and after the call from timePtr if the latter is - * not NULL. Return the number of events returned by kevent(2). - */ - - gettimeofday(&tv0, NULL); - numFound = kevent(tsdPtr->eventsFd, NULL, 0, events, (int) numEvents, - timeoutPtr); - gettimeofday(&tv1, NULL); - if (timePtr && (timePtr->tv_sec && timePtr->tv_usec)) { - timersub(&tv1, &tv0, &tv_delta); - if (!timercmp(&tv_delta, timePtr, >)) { - timersub(timePtr, &tv_delta, timePtr); - } else { - timePtr->tv_sec = 0; - timePtr->tv_usec = 0; - } - } - return numFound; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_CreateFileHandler -- - * - * This function registers a file handler with the kqueue notifier - * of the thread of the caller. - * - * Results: - * None. - * - * Side effects: - * Creates a new file handler structure. - * PlatformEventsControl() is called for the new file handler structure. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_CreateFileHandler( - int fd, /* Handle of stream to watch. */ - int mask, /* OR'ed combination of TCL_READABLE, - * TCL_WRITABLE, and TCL_EXCEPTION: indicates - * conditions under which proc should be - * called. */ - Tcl_FileProc *proc, /* Function to call for each selected - * event. */ - ClientData clientData) /* Arbitrary data to pass to proc. */ -{ - int isNew; - - if (tclNotifierHooks.createFileHandlerProc) { - tclNotifierHooks.createFileHandlerProc(fd, mask, proc, clientData); - return; - } else { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - FileHandler *filePtr; - - for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL; - filePtr = filePtr->nextPtr) { - if (filePtr->fd == fd) { - break; - } - } - if (filePtr == NULL) { - filePtr = Tcl_Alloc(sizeof(FileHandler)); - filePtr->fd = fd; - filePtr->readyMask = 0; - filePtr->nextPtr = tsdPtr->firstFileHandlerPtr; - tsdPtr->firstFileHandlerPtr = filePtr; - isNew = 1; - } else { - isNew = 0; - } - filePtr->proc = proc; - filePtr->clientData = clientData; - filePtr->mask = mask; - - PlatformEventsControl(filePtr, tsdPtr, EV_ADD, isNew); - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_DeleteFileHandler -- - * - * Cancel a previously-arranged callback arrangement for a file on the - * kqueue of the thread of the caller. - * - * Results: - * None. - * - * Side effects: - * If a callback was previously registered on file, remove it. - * PlatformEventsControl() is called for the file handler structure. - * The PlatformEventData struct associated with the new file handler - * structure is freed. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_DeleteFileHandler( - int fd) /* Stream id for which to remove callback - * function. */ -{ - if (tclNotifierHooks.deleteFileHandlerProc) { - tclNotifierHooks.deleteFileHandlerProc(fd); - return; - } else { - FileHandler *filePtr, *prevPtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - /* - * Find the entry for the given file (and return if there isn't one). - */ - - for (prevPtr = NULL, filePtr = tsdPtr->firstFileHandlerPtr; ; - prevPtr = filePtr, filePtr = filePtr->nextPtr) { - if (filePtr == NULL) { - return; - } - if (filePtr->fd == fd) { - break; - } - } - - /* - * Update the check masks for this file. - */ - - PlatformEventsControl(filePtr, tsdPtr, EV_DELETE, 0); - if (filePtr->pedPtr) { - Tcl_Free(filePtr->pedPtr); - } - - /* - * Clean up information in the callback record. - */ - - if (prevPtr == NULL) { - tsdPtr->firstFileHandlerPtr = filePtr->nextPtr; - } else { - prevPtr->nextPtr = filePtr->nextPtr; - } - Tcl_Free(filePtr); - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_WaitForEvent -- - * - * This function is called by Tcl_DoOneEvent to wait for new events on - * the message queue. If the block time is 0, then Tcl_WaitForEvent just - * polls without blocking. - * - * The waiting logic is implemented in PlatformEventsWait. - * - * Results: - * Returns -1 if PlatformEventsWait() would block forever, otherwise - * returns 0. - * - * Side effects: - * Queues file events that are detected by PlatformEventsWait(). - * - *---------------------------------------------------------------------- - */ - -int -Tcl_WaitForEvent( - const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ -{ - if (tclNotifierHooks.waitForEventProc) { - return tclNotifierHooks.waitForEventProc(timePtr); - } else { - FileHandler *filePtr; - int mask; - Tcl_Time vTime; - /* - * Impl. notes: timeout & timeoutPtr are used if, and only if threads - * are not enabled. They are the arguments for the regular epoll_wait() - * used when the core is not thread-enabled. - */ - - struct timeval timeout, *timeoutPtr; - int numFound, numEvent; - struct PlatformEventData *pedPtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - int numQueued; - ssize_t i; - char buf[1]; - - /* - * Set up the timeout structure. Note that if there are no events to - * check for, we return with a negative result rather than blocking - * forever. - */ - - if (timePtr != NULL) { - /* - * TIP #233 (Virtualized Time). Is virtual time in effect? And do - * we actually have something to scale? If yes to both then we - * call the handler to do this scaling. - */ - - if (timePtr->sec != 0 || timePtr->usec != 0) { - vTime = *timePtr; - tclScaleTimeProcPtr(&vTime, tclTimeClientData); - timePtr = &vTime; - } - timeout.tv_sec = timePtr->sec; - timeout.tv_usec = timePtr->usec; - timeoutPtr = &timeout; - } else { - timeoutPtr = NULL; - } - - /* - * Walk the list of FileHandlers associated with regular files - * (S_IFREG) belonging to tsdPtr, queue Tcl events for them, and - * update their mask of events of interest. - * - * kqueue(2), unlike epoll(7), does support regular files, but - * EVFILT_READ only `[r]eturns when the file pointer is not at the end - * of file' as opposed to unconditionally. While FreeBSD 11.0-RELEASE - * adds support for this mode (NOTE_FILE_POLL,) this is not used for - * reasons of compatibility. - * - * Therefore, the behaviour of {select,poll}(2) is simply simulated - * here: fds associated with regular files are added to this list by - * PlatformEventsControl() and processed here before calling (and - * possibly blocking) on PlatformEventsWait(). - */ - - numQueued = 0; - LIST_FOREACH(filePtr, &tsdPtr->firstReadyFileHandlerPtr, readyNode) { - mask = 0; - if (filePtr->mask & TCL_READABLE) { - mask |= TCL_READABLE; - } - if (filePtr->mask & TCL_WRITABLE) { - mask |= TCL_WRITABLE; - } - - /* - * Don't bother to queue an event if the mask was previously - * non-zero since an event must still be on the queue. - */ - - if (filePtr->readyMask == 0) { - FileHandlerEvent *fileEvPtr = - Tcl_Alloc(sizeof(FileHandlerEvent)); - - fileEvPtr->header.proc = FileHandlerEventProc; - fileEvPtr->fd = filePtr->fd; - Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL); - numQueued++; - } - filePtr->readyMask = mask; - } - - /* - * If any events were queued in the above loop, force PlatformEvents- - * Wait() to poll as there already are events that need to be processed - * at this point. - */ - - if (numQueued) { - timeout.tv_sec = 0; - timeout.tv_usec = 0; - timeoutPtr = &timeout; - } - - /* - * Wait or poll for new events, queue Tcl events for the FileHandlers - * corresponding to them, and update the FileHandlers' mask of events - * of interest registered by the last call to Tcl_CreateFileHandler(). - * - * Events for the trigger pipe are processed here in order to facilitate - * inter-thread IPC. If another thread intends to wake up this thread - * whilst it's blocking on PlatformEventsWait(), it write(2)s to the - * other end of the pipe (see Tcl_AlertNotifier(),) which in turn will - * cause PlatformEventsWait() to return immediately. - */ - - numFound = PlatformEventsWait(tsdPtr->readyEvents, - tsdPtr->maxReadyEvents, timeoutPtr); - for (numEvent = 0; numEvent < numFound; numEvent++) { - pedPtr = (struct PlatformEventData *) - tsdPtr->readyEvents[numEvent].udata; - filePtr = pedPtr->filePtr; - mask = PlatformEventsTranslate(&tsdPtr->readyEvents[numEvent]); - if (filePtr->fd == tsdPtr->triggerPipe[0]) { - i = read(tsdPtr->triggerPipe[0], buf, 1); - if ((i == -1) && (errno != EAGAIN)) { - Tcl_Panic("Tcl_WaitForEvent: read from %p->triggerPipe: %s", - (void *) tsdPtr, strerror(errno)); - } - continue; - } - if (!mask) { - continue; - } - - /* - * Don't bother to queue an event if the mask was previously - * non-zero since an event must still be on the queue. - */ - - if (filePtr->readyMask == 0) { - FileHandlerEvent *fileEvPtr = - Tcl_Alloc(sizeof(FileHandlerEvent)); - - fileEvPtr->header.proc = FileHandlerEventProc; - fileEvPtr->fd = filePtr->fd; - Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL); - } - filePtr->readyMask |= mask; - } - return 0; - } -} - -#endif /* NOTIFIER_KQUEUE && TCL_THREADS */ -#endif /* !HAVE_COREFOUNDATION */ - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ Index: unix/tclLoadAix.c ================================================================== --- unix/tclLoadAix.c +++ unix/tclLoadAix.c @@ -96,11 +96,11 @@ void * dlopen( const char *path, int mode) { - register ModulePtr mp; + ModulePtr mp; static void *mainModule; /* * Upon the first call register a terminate handler that will close all * libraries. Also get a reference to the main module for use with @@ -189,11 +189,11 @@ * If the user wants global binding, loadbind against all other loaded * modules. */ if (mode & RTLD_GLOBAL) { - register ModulePtr mp1; + ModulePtr mp1; for (mp1 = mp->next; mp1; mp1 = mp1->next) { if (loadbind(0, mp1->entry, mp->entry) == -1) { goto loadbindFailure; } @@ -241,11 +241,11 @@ static void caterr( char *s) { - register char *p = s; + char *p = s; while (*p >= '0' && *p <= '9') { p++; } switch (atoi(s)) { /* INTL: "C", UTF safe. */ @@ -280,13 +280,13 @@ void * dlsym( void *handle, const char *symbol) { - register ModulePtr mp = (ModulePtr)handle; - register ExportPtr ep; - register int i; + ModulePtr mp = (ModulePtr)handle; + ExportPtr ep; + int i; /* * Could speed up the search, but I assume that one assigns the result to * function pointers anyways. */ @@ -315,13 +315,13 @@ int dlclose( void *handle) { - register ModulePtr mp = (ModulePtr)handle; + ModulePtr mp = (ModulePtr)handle; int result; - register ModulePtr mp1; + ModulePtr mp1; if (--mp->refCnt > 0) { return 0; } @@ -341,12 +341,12 @@ errvalid++; strcpy(errbuf, strerror(errno)); } if (mp->exports) { - register ExportPtr ep; - register int i; + ExportPtr ep; + int i; for (ep = mp->exports, i = mp->nExports; i; i--, ep++) { if (ep->name) { free(ep->name); } } Index: unix/tclLoadDl.c ================================================================== --- unix/tclLoadDl.c +++ unix/tclLoadDl.c @@ -104,11 +104,11 @@ * string the user gave us which hopefully refers to a file on the * binary path. */ Tcl_DString ds; - const char *fileName = TclGetString(pathPtr); + const char *fileName = Tcl_GetString(pathPtr); native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); /* * Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070] */ @@ -125,15 +125,15 @@ const char *errorStr = dlerror(); if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't load file \"%s\": %s", - TclGetString(pathPtr), errorStr)); + Tcl_GetString(pathPtr), errorStr)); } return TCL_ERROR; } - newHandle = Tcl_Alloc(sizeof(*newHandle)); + newHandle = ckalloc(sizeof(*newHandle)); newHandle->clientData = handle; newHandle->findSymbolProcPtr = &FindSymbol; newHandle->unloadFileProcPtr = &UnloadFile; *unloadProcPtr = &UnloadFile; *loadHandle = newHandle; @@ -230,11 +230,11 @@ * that represents the loaded file. */ { void *handle = loadHandle->clientData; dlclose(handle); - Tcl_Free(loadHandle); + ckfree(loadHandle); } /* *---------------------------------------------------------------------- * Index: unix/tclLoadDyld.c ================================================================== --- unix/tclLoadDyld.c +++ unix/tclLoadDyld.c @@ -182,11 +182,11 @@ * important if the cwd is inside a vfs, and we are trying to load using a * relative path. */ nativePath = Tcl_FSGetNativePath(pathPtr); - nativeFileName = Tcl_UtfToExternalDString(NULL, TclGetString(pathPtr), + nativeFileName = Tcl_UtfToExternalDString(NULL, Tcl_GetString(pathPtr), -1, &ds); #if TCL_DYLD_USE_DLFCN /* * Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070] @@ -256,11 +256,11 @@ if (!(flags & 1)) nsflags |= NSLINKMODULE_OPTION_PRIVATE; if (!(flags & 2)) nsflags |= NSLINKMODULE_OPTION_BINDNOW; module = NSLinkModule(dyldObjFileImage, nativePath, nsflags); NSDestroyObjectFileImage(dyldObjFileImage); if (module) { - modulePtr = Tcl_Alloc(sizeof(Tcl_DyldModuleHandle)); + modulePtr = ckalloc(sizeof(Tcl_DyldModuleHandle)); modulePtr->module = module; modulePtr->nextPtr = NULL; } else { NSLinkEditError(&editError, &errorNumber, &errorName, &errMsg); @@ -276,26 +276,27 @@ if (dlHandle #if TCL_DYLD_USE_NSMODULE || dyldLibHeader || modulePtr #endif /* TCL_DYLD_USE_NSMODULE */ ) { - dyldLoadHandle = Tcl_Alloc(sizeof(Tcl_DyldLoadHandle)); + dyldLoadHandle = ckalloc(sizeof(Tcl_DyldLoadHandle)); dyldLoadHandle->dlHandle = dlHandle; #if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY) dyldLoadHandle->dyldLibHeader = dyldLibHeader; dyldLoadHandle->modulePtr = modulePtr; #endif /* TCL_DYLD_USE_NSMODULE || TCL_LOAD_FROM_MEMORY */ - newHandle = Tcl_Alloc(sizeof(*newHandle)); + newHandle = ckalloc(sizeof(*newHandle)); newHandle->clientData = dyldLoadHandle; newHandle->findSymbolProcPtr = &FindSymbol; newHandle->unloadFileProcPtr = &UnloadFile; *unloadProcPtr = &UnloadFile; *loadHandle = newHandle; result = TCL_OK; } else { - Tcl_Obj *errObj = Tcl_NewObj(); + Tcl_Obj *errObj; + TclNewObj(errObj); if (errMsg != NULL) { Tcl_AppendToObj(errObj, errMsg, -1); } #if TCL_DYLD_USE_NSMODULE if (objFileImageErrMsg) { @@ -379,11 +380,11 @@ break; } modulePtr = modulePtr->nextPtr; } if (modulePtr == NULL) { - modulePtr = Tcl_Alloc(sizeof(Tcl_DyldModuleHandle)); + modulePtr = ckalloc(sizeof(Tcl_DyldModuleHandle)); modulePtr->module = module; modulePtr->nextPtr = dyldLoadHandle->modulePtr; dyldLoadHandle->modulePtr = modulePtr; } #endif /* DYLD_SUPPORTS_DYLIB_UNLOADING */ @@ -454,16 +455,16 @@ void *ptr = modulePtr; (void) NSUnLinkModule(modulePtr->module, NSUNLINKMODULE_OPTION_RESET_LAZY_REFERENCES); modulePtr = modulePtr->nextPtr; - Tcl_Free(ptr); + ckfree(ptr); } #endif /* TCL_DYLD_USE_NSMODULE */ } - Tcl_Free(dyldLoadHandle); - Tcl_Free(loadHandle); + ckfree(dyldLoadHandle); + ckfree(loadHandle); } /* *---------------------------------------------------------------------- * @@ -691,18 +692,18 @@ /* * Stash the module reference within the load handle we create and return. */ - modulePtr = Tcl_Alloc(sizeof(Tcl_DyldModuleHandle)); + modulePtr = ckalloc(sizeof(Tcl_DyldModuleHandle)); modulePtr->module = module; modulePtr->nextPtr = NULL; - dyldLoadHandle = Tcl_Alloc(sizeof(Tcl_DyldLoadHandle)); + dyldLoadHandle = ckalloc(sizeof(Tcl_DyldLoadHandle)); dyldLoadHandle->dlHandle = NULL; dyldLoadHandle->dyldLibHeader = NULL; dyldLoadHandle->modulePtr = modulePtr; - newHandle = Tcl_Alloc(sizeof(*newHandle)); + newHandle = ckalloc(sizeof(*newHandle)); newHandle->clientData = dyldLoadHandle; newHandle->findSymbolProcPtr = &FindSymbol; newHandle->unloadFileProcPtr = &UnloadFile; *loadHandle = newHandle; *unloadProcPtr = &UnloadFile; Index: unix/tclLoadNext.c ================================================================== --- unix/tclLoadNext.c +++ unix/tclLoadNext.c @@ -59,11 +59,11 @@ const char *native; int result = 1; NXStream *errorStream = NXOpenMemory(0,0,NX_READWRITE); - fileName = TclGetString(pathPtr); + fileName = Tcl_GetString(pathPtr); /* * First try the full path the user gave us. This is particularly * important if the cwd is inside a vfs, and we are trying to load using a * relative path. @@ -99,11 +99,11 @@ NXCloseMemory(errorStream, NX_FREEBUFFER); return TCL_ERROR; } NXCloseMemory(errorStream, NX_FREEBUFFER); - newHandle = Tcl_Alloc(sizeof(Tcl_LoadHandle)); + newHandle = ckalloc(sizeof(Tcl_LoadHandle)); newHandle->clientData = INT2PTR(1); newHandle->findSymbolProcPtr = &FindSymbol; newHandle->unloadFileProcPtr = &UnloadFile; *loadHandle = newHandle; *unloadProcPtr = &UnloadFile; @@ -173,11 +173,11 @@ UnloadFile( Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to * TclpDlopen(). The loadHandle is a token * that represents the loaded file. */ { - Tcl_Free(loadHandle); + ckfree(loadHandle); } /* *---------------------------------------------------------------------- * Index: unix/tclLoadOSF.c ================================================================== --- unix/tclLoadOSF.c +++ unix/tclLoadOSF.c @@ -77,11 +77,11 @@ int flags) { Tcl_LoadHandle newHandle; ldr_module_t lm; char *pkg; - char *fileName = TclGetString(pathPtr); + char *fileName = Tcl_GetString(pathPtr); const char *native; /* * First try the full path the user gave us. This is particularly * important if the cwd is inside a vfs, and we are trying to load using a @@ -126,11 +126,11 @@ if ((pkg = strrchr(fileName, '/')) == NULL) { pkg = fileName; } else { pkg++; } - newHandle = Tcl_Alloc(sizeof(*newHandle)); + newHandle = ckalloc(sizeof(*newHandle)); newHandle->clientData = pkg; newHandle->findSymbolProcPtr = &FindSymbol; newHandle->unloadFileProcPtr = &UnloadFile; *loadHandle = newHandle; *unloadProcPtr = &UnloadFile; @@ -191,11 +191,11 @@ UnloadFile( Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to * TclpDlopen(). The loadHandle is a token * that represents the loaded file. */ { - Tcl_Free(loadHandle); + ckfree(loadHandle); } /* *---------------------------------------------------------------------- * Index: unix/tclLoadShl.c ================================================================== --- unix/tclLoadShl.c +++ unix/tclLoadShl.c @@ -55,11 +55,11 @@ int flags) { shl_t handle; Tcl_LoadHandle newHandle; const char *native; - char *fileName = TclGetString(pathPtr); + char *fileName = Tcl_GetString(pathPtr); /* * The flags below used to be BIND_IMMEDIATE; they were changed at the * suggestion of Wolfgang Kechel (wolfgang@prs.de): "This enables * verbosity for missing symbols when loading a shared lib and allows to @@ -95,11 +95,11 @@ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't load file \"%s\": %s", fileName, Tcl_PosixError(interp))); return TCL_ERROR; } - newHandle = Tcl_Alloc(sizeof(*newHandle)); + newHandle = ckalloc(sizeof(*newHandle)); newHandle->clientData = handle; newHandle->findSymbolProcPtr = &FindSymbol; newHandle->unloadFileProcPtr = *unloadProcPtr = &UnloadFile; *loadHandle = newHandle; return TCL_OK; @@ -180,11 +180,11 @@ * that represents the loaded file. */ { shl_t handle = (shl_t) loadHandle->clientData; shl_unload(handle); - Tcl_Free(loadHandle); + ckfree(loadHandle); } /* *---------------------------------------------------------------------- * DELETED unix/tclSelectNotfy.c Index: unix/tclSelectNotfy.c ================================================================== --- unix/tclSelectNotfy.c +++ /dev/null @@ -1,1114 +0,0 @@ -/* - * tclSelectNotfy.c -- - * - * This file contains the implementation of the select()-based generic - * Unix notifier, which is the lowest-level part of the Tcl event loop. - * This file works together with generic/tclNotify.c. - * - * Copyright (c) 1995-1997 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#include "tclInt.h" -#ifndef HAVE_COREFOUNDATION /* Darwin/Mac OS X CoreFoundation notifier is - * in tclMacOSXNotify.c */ -#if (!defined(NOTIFIER_EPOLL) && !defined(NOTIFIER_KQUEUE)) || !TCL_THREADS - -#include - -/* - * This structure is used to keep track of the notifier info for a registered - * file. - */ - -typedef struct FileHandler { - int fd; - int mask; /* Mask of desired events: TCL_READABLE, - * etc. */ - 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. */ - ClientData clientData; /* Argument to pass to proc. */ - struct FileHandler *nextPtr;/* Next in list of all files we care about. */ -} FileHandler; - -/* - * The following structure contains a set of select() masks to track readable, - * writable, and exception conditions. - */ - -typedef struct { - fd_set readable; - fd_set writable; - fd_set exception; -} SelectMasks; - -/* - * The following structure is what is added to the Tcl event queue when file - * handlers are ready to fire. - */ - -typedef struct { - Tcl_Event header; /* Information that is standard for all - * events. */ - int fd; /* File descriptor that is ready. Used to find - * the FileHandler structure for the file - * (can't point directly to the FileHandler - * structure because it could go away while - * the event is queued). */ -} FileHandlerEvent; - -/* - * The following static structure contains the state information for the - * select based implementation of the Tcl notifier. One of these structures is - * created for each thread that is using the notifier. - */ - -typedef struct ThreadSpecificData { - FileHandler *firstFileHandlerPtr; - /* Pointer to head of file handler list. */ - SelectMasks checkMasks; /* This structure is used to build up the - * masks to be used in the next call to - * select. Bits are set in response to calls - * to Tcl_CreateFileHandler. */ - SelectMasks readyMasks; /* This array reflects the readable/writable - * conditions that were found to exist by the - * last call to select. */ - int numFdBits; /* Number of valid bits in checkMasks (one - * more than highest fd for which - * Tcl_WatchFile has been called). */ -#if TCL_THREADS - int onList; /* True if it is in this list */ - unsigned int pollState; /* pollState is used to implement a polling - * handshake between each thread and the - * notifier thread. Bits defined below. */ - struct ThreadSpecificData *nextPtr, *prevPtr; - /* All threads that are currently waiting on - * an event have their ThreadSpecificData - * structure on a doubly-linked listed formed - * from these pointers. You must hold the - * notifierMutex lock before accessing these - * fields. */ -#ifdef __CYGWIN__ - void *event; /* Any other thread alerts a notifier that an - * event is ready to be processed by sending - * this event. */ - void *hwnd; /* Messaging window. */ -#else /* !__CYGWIN__ */ - pthread_cond_t waitCV; /* Any other thread alerts a notifier that an - * event is ready to be processed by signaling - * this condition variable. */ -#endif /* __CYGWIN__ */ - int waitCVinitialized; /* Variable to flag initialization of the - * structure. */ - int eventReady; /* True if an event is ready to be processed. - * Used as condition flag together with waitCV - * above. */ -#endif /* TCL_THREADS */ -} ThreadSpecificData; - -static Tcl_ThreadDataKey dataKey; - -#if TCL_THREADS -/* - * The following static indicates the number of threads that have initialized - * notifiers. - * - * You must hold the notifierMutex lock before accessing this variable. - */ - -static int notifierCount = 0; - -/* - * The following variable points to the head of a doubly-linked list of - * ThreadSpecificData structures for all threads that are currently waiting on - * an event. - * - * You must hold the notifierMutex lock before accessing this list. - */ - -static ThreadSpecificData *waitingListPtr = NULL; - -/* - * The notifier thread spends all its time in select() waiting for a file - * descriptor associated with one of the threads on the waitingListPtr list to - * do something interesting. But if the contents of the waitingListPtr list - * ever changes, we need to wake up and restart the select() system call. You - * can wake up the notifier thread by writing a single byte to the file - * descriptor defined below. This file descriptor is the input-end of a pipe - * and the notifier thread is listening for data on the output-end of the same - * pipe. Hence writing to this file descriptor will cause the select() system - * call to return and wake up the notifier thread. - * - * You must hold the notifierMutex lock before writing to the pipe. - */ - -static int triggerPipe = -1; - -/* - * The notifierMutex locks access to all of the global notifier state. - */ - -static pthread_mutex_t notifierInitMutex = PTHREAD_MUTEX_INITIALIZER; -static pthread_mutex_t notifierMutex = PTHREAD_MUTEX_INITIALIZER; -/* - * The following static indicates if the notifier thread is running. - * - * You must hold the notifierInitMutex before accessing this variable. - */ - -static int notifierThreadRunning = 0; - -/* - * The notifier thread signals the notifierCV when it has finished - * initializing the triggerPipe and right before the notifier thread - * terminates. - */ - -static pthread_cond_t notifierCV = PTHREAD_COND_INITIALIZER; - -/* - * The pollState bits: - * - * POLL_WANT is set by each thread before it waits on its condition variable. - * It is checked by the notifier before it does select. - * - * POLL_DONE is set by the notifier if it goes into select after seeing - * POLL_WANT. The idea is to ensure it tries a select with the same bits - * the initial thread had set. - */ - -#define POLL_WANT 0x1 -#define POLL_DONE 0x2 - -/* - * This is the thread ID of the notifier thread that does select. - */ - -static Tcl_ThreadId notifierThread; -#endif /* TCL_THREADS */ - -/* - * Static routines defined in this file. - */ - -#if TCL_THREADS -static TCL_NORETURN void NotifierThreadProc(ClientData clientData); -#if defined(HAVE_PTHREAD_ATFORK) -static int atForkInit = 0; -static void AtForkChild(void); -#endif /* HAVE_PTHREAD_ATFORK */ -#endif /* TCL_THREADS */ -static int FileHandlerEventProc(Tcl_Event *evPtr, int flags); - -/* - * Import of critical bits of Windows API when building threaded with Cygwin. - */ - -#if defined(__CYGWIN__) -typedef struct { - void *hwnd; /* Messaging window. */ - unsigned int *message; /* Message payload. */ - int wParam; /* Event-specific "word" parameter. */ - int lParam; /* Event-specific "long" parameter. */ - int time; /* Event timestamp. */ - int x; /* Event location (where meaningful). */ - int y; -} MSG; - -typedef struct { - unsigned int style; - void *lpfnWndProc; - int cbClsExtra; - int cbWndExtra; - void *hInstance; - void *hIcon; - void *hCursor; - void *hbrBackground; - void *lpszMenuName; - const void *lpszClassName; -} WNDCLASS; - -extern void __stdcall CloseHandle(void *); -extern void *__stdcall CreateEventW(void *, unsigned char, unsigned char, - void *); -extern void *__stdcall CreateWindowExW(void *, const void *, const void *, - DWORD, int, int, int, int, void *, void *, void *, - void *); -extern DWORD __stdcall DefWindowProcW(void *, int, void *, void *); -extern unsigned char __stdcall DestroyWindow(void *); -extern int __stdcall DispatchMessageW(const MSG *); -extern unsigned char __stdcall GetMessageW(MSG *, void *, int, int); -extern void __stdcall MsgWaitForMultipleObjects(DWORD, void *, - unsigned char, DWORD, DWORD); -extern unsigned char __stdcall PeekMessageW(MSG *, void *, int, int, int); -extern unsigned char __stdcall PostMessageW(void *, unsigned int, void *, - void *); -extern void __stdcall PostQuitMessage(int); -extern void *__stdcall RegisterClassW(const WNDCLASS *); -extern unsigned char __stdcall ResetEvent(void *); -extern unsigned char __stdcall TranslateMessage(const MSG *); - -/* - * Threaded-cygwin specific constants and functions in this file: - */ - -static const WCHAR className[] = L"TclNotifier"; -static DWORD __stdcall NotifierProc(void *hwnd, unsigned int message, - void *wParam, void *lParam); -#endif /* TCL_THREADS && __CYGWIN__ */ - - -#include "tclUnixNotfy.c" - -/* - *---------------------------------------------------------------------- - * - * Tcl_InitNotifier -- - * - * Initializes the platform specific notifier state. - * - * Results: - * Returns a handle to the notifier state for this thread. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -ClientData -Tcl_InitNotifier(void) -{ - if (tclNotifierHooks.initNotifierProc) { - return tclNotifierHooks.initNotifierProc(); - } else { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - -#if TCL_THREADS - tsdPtr->eventReady = 0; - - /* - * Initialize thread specific condition variable for this thread. - */ - if (tsdPtr->waitCVinitialized == 0) { -#ifdef __CYGWIN__ - WNDCLASS class; - - class.style = 0; - class.cbClsExtra = 0; - class.cbWndExtra = 0; - class.hInstance = TclWinGetTclInstance(); - class.hbrBackground = NULL; - class.lpszMenuName = NULL; - class.lpszClassName = className; - class.lpfnWndProc = NotifierProc; - class.hIcon = NULL; - class.hCursor = NULL; - - RegisterClassW(&class); - tsdPtr->hwnd = CreateWindowExW(NULL, class.lpszClassName, - class.lpszClassName, 0, 0, 0, 0, 0, NULL, NULL, - TclWinGetTclInstance(), NULL); - tsdPtr->event = CreateEventW(NULL, 1 /* manual */, - 0 /* !signaled */, NULL); -#else - pthread_cond_init(&tsdPtr->waitCV, NULL); -#endif /* __CYGWIN__ */ - tsdPtr->waitCVinitialized = 1; - } - - pthread_mutex_lock(¬ifierInitMutex); -#if defined(HAVE_PTHREAD_ATFORK) - /* - * Install pthread_atfork handlers to clean up the notifier in the - * child of a fork. - */ - - if (!atForkInit) { - int result = pthread_atfork(NULL, NULL, AtForkChild); - - if (result) { - Tcl_Panic("Tcl_InitNotifier: pthread_atfork failed"); - } - atForkInit = 1; - } -#endif /* HAVE_PTHREAD_ATFORK */ - - notifierCount++; - pthread_mutex_unlock(¬ifierInitMutex); - -#endif /* TCL_THREADS */ - return tsdPtr; - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_FinalizeNotifier -- - * - * This function is called to cleanup the notifier state before a thread - * is terminated. - * - * Results: - * None. - * - * Side effects: - * May terminate the background notifier thread if this is the last - * notifier instance. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_FinalizeNotifier( - ClientData clientData) /* Not used. */ -{ - if (tclNotifierHooks.finalizeNotifierProc) { - tclNotifierHooks.finalizeNotifierProc(clientData); - return; - } else { -#if TCL_THREADS - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - pthread_mutex_lock(¬ifierInitMutex); - notifierCount--; - - /* - * If this is the last thread to use the notifier, close the notifier - * pipe and wait for the background thread to terminate. - */ - - if (notifierCount == 0 && triggerPipe != -1) { - if (write(triggerPipe, "q", 1) != 1) { - Tcl_Panic("Tcl_FinalizeNotifier: %s", - "unable to write 'q' to triggerPipe"); - } - close(triggerPipe); - pthread_mutex_lock(¬ifierMutex); - while(triggerPipe != -1) { - pthread_cond_wait(¬ifierCV, ¬ifierMutex); - } - pthread_mutex_unlock(¬ifierMutex); - if (notifierThreadRunning) { - int result = pthread_join((pthread_t) notifierThread, NULL); - - if (result) { - Tcl_Panic("Tcl_FinalizeNotifier: %s", - "unable to join notifier thread"); - } - notifierThreadRunning = 0; - } - } - - /* - * Clean up any synchronization objects in the thread local storage. - */ - -#ifdef __CYGWIN__ - DestroyWindow(tsdPtr->hwnd); - CloseHandle(tsdPtr->event); -#else /* __CYGWIN__ */ - pthread_cond_destroy(&tsdPtr->waitCV); -#endif /* __CYGWIN__ */ - tsdPtr->waitCVinitialized = 0; - - pthread_mutex_unlock(¬ifierInitMutex); -#endif /* TCL_THREADS */ - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_CreateFileHandler -- - * - * This function registers a file handler with the select notifier. - * - * Results: - * None. - * - * Side effects: - * Creates a new file handler structure. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_CreateFileHandler( - int fd, /* Handle of stream to watch. */ - int mask, /* OR'ed combination of TCL_READABLE, - * TCL_WRITABLE, and TCL_EXCEPTION: indicates - * conditions under which proc should be - * called. */ - Tcl_FileProc *proc, /* Function to call for each selected - * event. */ - ClientData clientData) /* Arbitrary data to pass to proc. */ -{ - if (tclNotifierHooks.createFileHandlerProc) { - tclNotifierHooks.createFileHandlerProc(fd, mask, proc, clientData); - return; - } else { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - FileHandler *filePtr; - - for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL; - filePtr = filePtr->nextPtr) { - if (filePtr->fd == fd) { - break; - } - } - if (filePtr == NULL) { - filePtr = Tcl_Alloc(sizeof(FileHandler)); - filePtr->fd = fd; - filePtr->readyMask = 0; - filePtr->nextPtr = tsdPtr->firstFileHandlerPtr; - tsdPtr->firstFileHandlerPtr = filePtr; - } - filePtr->proc = proc; - filePtr->clientData = clientData; - filePtr->mask = mask; - - /* - * Update the check masks for this file. - */ - - if (mask & TCL_READABLE) { - FD_SET(fd, &tsdPtr->checkMasks.readable); - } else { - FD_CLR(fd, &tsdPtr->checkMasks.readable); - } - if (mask & TCL_WRITABLE) { - FD_SET(fd, &tsdPtr->checkMasks.writable); - } else { - FD_CLR(fd, &tsdPtr->checkMasks.writable); - } - if (mask & TCL_EXCEPTION) { - FD_SET(fd, &tsdPtr->checkMasks.exception); - } else { - FD_CLR(fd, &tsdPtr->checkMasks.exception); - } - if (tsdPtr->numFdBits <= fd) { - tsdPtr->numFdBits = fd+1; - } - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_DeleteFileHandler -- - * - * Cancel a previously-arranged callback arrangement for a file. - * - * Results: - * None. - * - * Side effects: - * If a callback was previously registered on file, remove it. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_DeleteFileHandler( - int fd) /* Stream id for which to remove callback - * function. */ -{ - if (tclNotifierHooks.deleteFileHandlerProc) { - tclNotifierHooks.deleteFileHandlerProc(fd); - return; - } else { - FileHandler *filePtr, *prevPtr; - int i; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - /* - * Find the entry for the given file (and return if there isn't one). - */ - - for (prevPtr = NULL, filePtr = tsdPtr->firstFileHandlerPtr; ; - prevPtr = filePtr, filePtr = filePtr->nextPtr) { - if (filePtr == NULL) { - return; - } - if (filePtr->fd == fd) { - break; - } - } - - /* - * Update the check masks for this file. - */ - - if (filePtr->mask & TCL_READABLE) { - FD_CLR(fd, &tsdPtr->checkMasks.readable); - } - if (filePtr->mask & TCL_WRITABLE) { - FD_CLR(fd, &tsdPtr->checkMasks.writable); - } - if (filePtr->mask & TCL_EXCEPTION) { - FD_CLR(fd, &tsdPtr->checkMasks.exception); - } - - /* - * Find current max fd. - */ - - if (fd+1 == tsdPtr->numFdBits) { - int numFdBits = 0; - - for (i = fd-1; i >= 0; i--) { - if (FD_ISSET(i, &tsdPtr->checkMasks.readable) - || FD_ISSET(i, &tsdPtr->checkMasks.writable) - || FD_ISSET(i, &tsdPtr->checkMasks.exception)) { - numFdBits = i+1; - break; - } - } - tsdPtr->numFdBits = numFdBits; - } - - /* - * Clean up information in the callback record. - */ - - if (prevPtr == NULL) { - tsdPtr->firstFileHandlerPtr = filePtr->nextPtr; - } else { - prevPtr->nextPtr = filePtr->nextPtr; - } - Tcl_Free(filePtr); - } -} - -#if defined(__CYGWIN__) - -static DWORD __stdcall -NotifierProc( - void *hwnd, - unsigned int message, - void *wParam, - void *lParam) -{ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - if (message != 1024) { - return DefWindowProcW(hwnd, message, wParam, lParam); - } - - /* - * Process all of the runnable events. - */ - - tsdPtr->eventReady = 1; - Tcl_ServiceAll(); - return 0; -} -#endif /* TCL_THREADS && __CYGWIN__ */ - -/* - *---------------------------------------------------------------------- - * - * Tcl_WaitForEvent -- - * - * This function is called by Tcl_DoOneEvent to wait for new events on - * the message queue. If the block time is 0, then Tcl_WaitForEvent just - * polls without blocking. - * - * Results: - * Returns -1 if the select would block forever, otherwise returns 0. - * - * Side effects: - * Queues file events that are detected by the select. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_WaitForEvent( - const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ -{ - if (tclNotifierHooks.waitForEventProc) { - return tclNotifierHooks.waitForEventProc(timePtr); - } else { - FileHandler *filePtr; - int mask; - Tcl_Time vTime; -#if TCL_THREADS - int waitForFiles; -# ifdef __CYGWIN__ - MSG msg; -# endif /* __CYGWIN__ */ -#else /* !TCL_THREADS */ - /* - * Impl. notes: timeout & timeoutPtr are used if, and only if threads - * are not enabled. They are the arguments for the regular select() - * used when the core is not thread-enabled. - */ - - struct timeval timeout, *timeoutPtr; - int numFound; -#endif /* TCL_THREADS */ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - /* - * Set up the timeout structure. Note that if there are no events to - * check for, we return with a negative result rather than blocking - * forever. - */ - - if (timePtr != NULL) { - /* - * TIP #233 (Virtualized Time). Is virtual time in effect? And do - * we actually have something to scale? If yes to both then we - * call the handler to do this scaling. - */ - - if (timePtr->sec != 0 || timePtr->usec != 0) { - vTime = *timePtr; - tclScaleTimeProcPtr(&vTime, tclTimeClientData); - timePtr = &vTime; - } -#if !TCL_THREADS - timeout.tv_sec = timePtr->sec; - timeout.tv_usec = timePtr->usec; - timeoutPtr = &timeout; - } else if (tsdPtr->numFdBits == 0) { - /* - * If there are no threads, no timeout, and no fds registered, - * then there are no events possible and we must avoid deadlock. - * Note that this is not entirely correct because there might be a - * signal that could interrupt the select call, but we don't - * handle that case if we aren't using threads. - */ - - return -1; - } else { - timeoutPtr = NULL; -#endif /* !TCL_THREADS */ - } - -#if TCL_THREADS - /* - * Start notifier thread and place this thread on the list of - * interested threads, signal the notifier thread, and wait for a - * response or a timeout. - */ - StartNotifierThread("Tcl_WaitForEvent"); - - pthread_mutex_lock(¬ifierMutex); - - if (timePtr != NULL && timePtr->sec == 0 && (timePtr->usec == 0 -#if defined(__APPLE__) && defined(__LP64__) - /* - * On 64-bit Darwin, pthread_cond_timedwait() appears to have - * a bug that causes it to wait forever when passed an - * absolute time which has already been exceeded by the system - * time; as a workaround, when given a very brief timeout, - * just do a poll. [Bug 1457797] - */ - || timePtr->usec < 10 -#endif /* __APPLE__ && __LP64__ */ - )) { - /* - * Cannot emulate a polling select with a polling condition - * variable. Instead, pretend to wait for files and tell the - * notifier thread what we are doing. The notifier thread makes - * sure it goes through select with its select mask in the same - * state as ours currently is. We block until that happens. - */ - - waitForFiles = 1; - tsdPtr->pollState = POLL_WANT; - timePtr = NULL; - } else { - waitForFiles = (tsdPtr->numFdBits > 0); - tsdPtr->pollState = 0; - } - - if (waitForFiles) { - /* - * Add the ThreadSpecificData structure of this thread to the list - * of ThreadSpecificData structures of all threads that are - * waiting on file events. - */ - - tsdPtr->nextPtr = waitingListPtr; - if (waitingListPtr) { - waitingListPtr->prevPtr = tsdPtr; - } - tsdPtr->prevPtr = 0; - waitingListPtr = tsdPtr; - tsdPtr->onList = 1; - - if ((write(triggerPipe, "", 1) == -1) && (errno != EAGAIN)) { - Tcl_Panic("Tcl_WaitForEvent: %s", - "unable to write to triggerPipe"); - } - } - - FD_ZERO(&tsdPtr->readyMasks.readable); - FD_ZERO(&tsdPtr->readyMasks.writable); - FD_ZERO(&tsdPtr->readyMasks.exception); - - if (!tsdPtr->eventReady) { -#ifdef __CYGWIN__ - if (!PeekMessageW(&msg, NULL, 0, 0, 0)) { - DWORD timeout; - - if (timePtr) { - timeout = timePtr->sec * 1000 + timePtr->usec / 1000; - } else { - timeout = 0xFFFFFFFF; - } - pthread_mutex_unlock(¬ifierMutex); - MsgWaitForMultipleObjects(1, &tsdPtr->event, 0, timeout, 1279); - pthread_mutex_lock(¬ifierMutex); - } -#else /* !__CYGWIN__ */ - if (timePtr != NULL) { - Tcl_Time now; - struct timespec ptime; - - Tcl_GetTime(&now); - ptime.tv_sec = timePtr->sec + now.sec + - (timePtr->usec + now.usec) / 1000000; - ptime.tv_nsec = 1000 * ((timePtr->usec + now.usec) % 1000000); - - pthread_cond_timedwait(&tsdPtr->waitCV, ¬ifierMutex, &ptime); - } else { - pthread_cond_wait(&tsdPtr->waitCV, ¬ifierMutex); - } -#endif /* __CYGWIN__ */ - } - tsdPtr->eventReady = 0; - -#ifdef __CYGWIN__ - while (PeekMessageW(&msg, NULL, 0, 0, 0)) { - /* - * Retrieve and dispatch the message. - */ - - DWORD result = GetMessageW(&msg, NULL, 0, 0); - - if (result == 0) { - PostQuitMessage(msg.wParam); - /* What to do here? */ - } else if (result != (DWORD) -1) { - TranslateMessage(&msg); - DispatchMessageW(&msg); - } - } - ResetEvent(tsdPtr->event); -#endif /* __CYGWIN__ */ - - if (waitForFiles && tsdPtr->onList) { - /* - * Remove the ThreadSpecificData structure of this thread from the - * waiting list. Alert the notifier thread to recompute its select - * masks - skipping this caused a hang when trying to close a pipe - * which the notifier thread was still doing a select on. - */ - - if (tsdPtr->prevPtr) { - tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr; - } else { - waitingListPtr = tsdPtr->nextPtr; - } - if (tsdPtr->nextPtr) { - tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr; - } - tsdPtr->nextPtr = tsdPtr->prevPtr = NULL; - tsdPtr->onList = 0; - if ((write(triggerPipe, "", 1) == -1) && (errno != EAGAIN)) { - Tcl_Panic("Tcl_WaitForEvent: %s", - "unable to write to triggerPipe"); - } - } -#else /* !TCL_THREADS */ - tsdPtr->readyMasks = tsdPtr->checkMasks; - numFound = select(tsdPtr->numFdBits, &tsdPtr->readyMasks.readable, - &tsdPtr->readyMasks.writable, &tsdPtr->readyMasks.exception, - timeoutPtr); - - /* - * Some systems don't clear the masks after an error, so we have to do - * it here. - */ - - if (numFound == -1) { - FD_ZERO(&tsdPtr->readyMasks.readable); - FD_ZERO(&tsdPtr->readyMasks.writable); - FD_ZERO(&tsdPtr->readyMasks.exception); - } -#endif /* TCL_THREADS */ - - /* - * Queue all detected file events before returning. - */ - - for (filePtr = tsdPtr->firstFileHandlerPtr; (filePtr != NULL); - filePtr = filePtr->nextPtr) { - mask = 0; - if (FD_ISSET(filePtr->fd, &tsdPtr->readyMasks.readable)) { - mask |= TCL_READABLE; - } - if (FD_ISSET(filePtr->fd, &tsdPtr->readyMasks.writable)) { - mask |= TCL_WRITABLE; - } - if (FD_ISSET(filePtr->fd, &tsdPtr->readyMasks.exception)) { - mask |= TCL_EXCEPTION; - } - - if (!mask) { - continue; - } - - /* - * Don't bother to queue an event if the mask was previously - * non-zero since an event must still be on the queue. - */ - - if (filePtr->readyMask == 0) { - FileHandlerEvent *fileEvPtr = - Tcl_Alloc(sizeof(FileHandlerEvent)); - - fileEvPtr->header.proc = FileHandlerEventProc; - fileEvPtr->fd = filePtr->fd; - Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL); - } - filePtr->readyMask = mask; - } -#if TCL_THREADS - pthread_mutex_unlock(¬ifierMutex); -#endif /* TCL_THREADS */ - return 0; - } -} - -/* - *---------------------------------------------------------------------- - * - * NotifierThreadProc -- - * - * This routine is the initial (and only) function executed by the - * special notifier thread. Its job is to wait for file descriptors to - * become readable or writable or to have an exception condition and then - * to notify other threads who are interested in this information by - * signalling a condition variable. Other threads can signal this - * notifier thread of a change in their interests by writing a single - * byte to a special pipe that the notifier thread is monitoring. - * - * Result: - * None. Once started, this routine never exits. It dies with the overall - * process. - * - * Side effects: - * The trigger pipe used to signal the notifier thread is created when - * the notifier thread first starts. - * - *---------------------------------------------------------------------- - */ - -#if TCL_THREADS -static TCL_NORETURN void -NotifierThreadProc( - ClientData clientData) /* Not used. */ -{ - ThreadSpecificData *tsdPtr; - fd_set readableMask; - fd_set writableMask; - fd_set exceptionMask; - int i; - int fds[2], receivePipe; - long found; - struct timeval poll = {0., 0.}, *timePtr; - char buf[2]; - int numFdBits = 0; - - if (pipe(fds) != 0) { - Tcl_Panic("NotifierThreadProc: %s", "could not create trigger pipe"); - } - - receivePipe = fds[0]; - - if (TclUnixSetBlockingMode(receivePipe, TCL_MODE_NONBLOCKING) < 0) { - Tcl_Panic("NotifierThreadProc: %s", - "could not make receive pipe non blocking"); - } - if (TclUnixSetBlockingMode(fds[1], TCL_MODE_NONBLOCKING) < 0) { - Tcl_Panic("NotifierThreadProc: %s", - "could not make trigger pipe non blocking"); - } - if (fcntl(receivePipe, F_SETFD, FD_CLOEXEC) < 0) { - Tcl_Panic("NotifierThreadProc: %s", - "could not make receive pipe close-on-exec"); - } - if (fcntl(fds[1], F_SETFD, FD_CLOEXEC) < 0) { - Tcl_Panic("NotifierThreadProc: %s", - "could not make trigger pipe close-on-exec"); - } - - /* - * Install the write end of the pipe into the global variable. - */ - - pthread_mutex_lock(¬ifierMutex); - triggerPipe = fds[1]; - - /* - * Signal any threads that are waiting. - */ - - pthread_cond_broadcast(¬ifierCV); - pthread_mutex_unlock(¬ifierMutex); - - /* - * Look for file events and report them to interested threads. - */ - - while (1) { - FD_ZERO(&readableMask); - FD_ZERO(&writableMask); - FD_ZERO(&exceptionMask); - - /* - * Compute the logical OR of the masks from all the waiting - * notifiers. - */ - - pthread_mutex_lock(¬ifierMutex); - timePtr = NULL; - for (tsdPtr = waitingListPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) { - for (i = tsdPtr->numFdBits-1; i >= 0; --i) { - if (FD_ISSET(i, &tsdPtr->checkMasks.readable)) { - FD_SET(i, &readableMask); - } - if (FD_ISSET(i, &tsdPtr->checkMasks.writable)) { - FD_SET(i, &writableMask); - } - if (FD_ISSET(i, &tsdPtr->checkMasks.exception)) { - FD_SET(i, &exceptionMask); - } - } - if (tsdPtr->numFdBits > numFdBits) { - numFdBits = tsdPtr->numFdBits; - } - if (tsdPtr->pollState & POLL_WANT) { - /* - * Here we make sure we go through select() with the same mask - * bits that were present when the thread tried to poll. - */ - - tsdPtr->pollState |= POLL_DONE; - timePtr = &poll; - } - } - pthread_mutex_unlock(¬ifierMutex); - - /* - * Set up the mask to include the receive pipe. - */ - - if (receivePipe >= numFdBits) { - numFdBits = receivePipe + 1; - } - FD_SET(receivePipe, &readableMask); - - if (select(numFdBits, &readableMask, &writableMask, &exceptionMask, - timePtr) == -1) { - /* - * Try again immediately on an error. - */ - - continue; - } - - /* - * Alert any threads that are waiting on a ready file descriptor. - */ - - pthread_mutex_lock(¬ifierMutex); - for (tsdPtr = waitingListPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) { - found = 0; - - for (i = tsdPtr->numFdBits-1; i >= 0; --i) { - if (FD_ISSET(i, &tsdPtr->checkMasks.readable) - && FD_ISSET(i, &readableMask)) { - FD_SET(i, &tsdPtr->readyMasks.readable); - found = 1; - } - if (FD_ISSET(i, &tsdPtr->checkMasks.writable) - && FD_ISSET(i, &writableMask)) { - FD_SET(i, &tsdPtr->readyMasks.writable); - found = 1; - } - if (FD_ISSET(i, &tsdPtr->checkMasks.exception) - && FD_ISSET(i, &exceptionMask)) { - FD_SET(i, &tsdPtr->readyMasks.exception); - found = 1; - } - } - - if (found || (tsdPtr->pollState & POLL_DONE)) { - AlertSingleThread(tsdPtr); - } - } - pthread_mutex_unlock(¬ifierMutex); - - /* - * Consume the next byte from the notifier pipe if the pipe was - * readable. Note that there may be multiple bytes pending, but to - * avoid a race condition we only read one at a time. - */ - - do { - i = read(receivePipe, buf, 1); - if (i <= 0) { - break; - } else if ((i == 0) || ((i == 1) && (buf[0] == 'q'))) { - /* - * Someone closed the write end of the pipe or sent us a Quit - * message [Bug: 4139] and then closed the write end of the - * pipe so we need to shut down the notifier thread. - */ - - break; - } - } while (1); - if ((i == 0) || (buf[0] == 'q')) { - break; - } - } - - /* - * Clean up the read end of the pipe and signal any threads waiting on - * termination of the notifier thread. - */ - - close(receivePipe); - pthread_mutex_lock(¬ifierMutex); - triggerPipe = -1; - pthread_cond_broadcast(¬ifierCV); - pthread_mutex_unlock(¬ifierMutex); - - TclpThreadExit(0); -} -#endif /* TCL_THREADS */ - -#endif /* (!NOTIFIER_EPOLL && !NOTIFIER_KQUEUE) || !TCL_THREADS */ -#endif /* !HAVE_COREFOUNDATION */ - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ Index: unix/tclUnixChan.c ================================================================== --- unix/tclUnixChan.c +++ unix/tclUnixChan.c @@ -46,20 +46,10 @@ # define PAREXT CMSPAR # endif /* !PAREXT&&CMSPAR */ #endif /* HAVE_TERMIOS_H */ -/* - * The bits supported for describing the closeMode field of TtyState. - */ - -enum CloseModeBits { - CLOSE_DEFAULT, - CLOSE_DRAIN, - CLOSE_DISCARD -}; - /* * Helper macros to make parts of this file clearer. The macros do exactly * what they say on the tin. :-) They also only ever refer to their arguments * once, and so can be used without regard to side effects. */ @@ -66,49 +56,36 @@ #define SET_BITS(var, bits) ((var) |= (bits)) #define CLEAR_BITS(var, bits) ((var) &= ~(bits)) /* - * These structures describe per-instance state of file-based and serial-based - * channels. + * This structure describes per-instance state of a file based channel. */ -typedef struct { +typedef struct FileState { Tcl_Channel channel; /* Channel associated with this file. */ int fd; /* File handle. */ int validMask; /* OR'ed combination of TCL_READABLE, * TCL_WRITABLE, or TCL_EXCEPTION: indicates * which operations are valid on the file. */ } FileState; -typedef struct { - FileState fileState; -#ifdef SUPPORTS_TTY - int closeMode; /* One of CLOSE_DEFAULT, CLOSE_DRAIN or - * CLOSE_DISCARD. */ - int doReset; /* Whether we should do a terminal reset on - * close. */ - struct termios initState; /* The state of the terminal when it was - * opened. */ -#endif /* SUPPORTS_TTY */ -} TtyState; - #ifdef SUPPORTS_TTY /* * The following structure is used to set or get the serial port attributes in - * a platform-independant manner. + * a platform-independent manner. */ -typedef struct { +typedef struct TtyAttrs { int baud; int parity; int data; int stop; } TtyAttrs; -#endif /* SUPPORTS_TTY */ +#endif /* !SUPPORTS_TTY */ #define UNSUPPORTED_OPTION(detail) \ if (interp) { \ Tcl_SetObjResult(interp, Tcl_ObjPrintf( \ "%s not supported for this platform", (detail))); \ @@ -120,10 +97,12 @@ */ static int FileBlockModeProc(ClientData instanceData, int mode); static int FileCloseProc(ClientData instanceData, Tcl_Interp *interp); +static int FileClose2Proc(ClientData instanceData, + Tcl_Interp *interp, int flags); static int FileGetHandleProc(ClientData instanceData, int direction, ClientData *handlePtr); static int FileInputProc(ClientData instanceData, char *buf, int toRead, int *errorCode); static int FileOutputProc(ClientData instanceData, @@ -134,12 +113,10 @@ Tcl_WideInt length); static Tcl_WideInt FileWideSeekProc(ClientData instanceData, Tcl_WideInt offset, int mode, int *errorCode); static void FileWatchProc(ClientData instanceData, int mask); #ifdef SUPPORTS_TTY -static int TtyCloseProc(ClientData instanceData, - Tcl_Interp *interp); static void TtyGetAttributes(int fd, TtyAttrs *ttyPtr); static int TtyGetOptionProc(ClientData instanceData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr); static int TtyGetBaud(speed_t speed); @@ -167,11 +144,11 @@ FileSeekProc, /* Seek proc. */ NULL, /* Set option proc. */ NULL, /* Get option proc. */ FileWatchProc, /* Initialize notifier. */ FileGetHandleProc, /* Get OS handles out of channel. */ - NULL, /* close2proc. */ + FileClose2Proc, /* close2proc. */ FileBlockModeProc, /* Set blocking or non-blocking mode.*/ NULL, /* flush proc. */ NULL, /* handler proc. */ FileWideSeekProc, /* wide seek proc. */ NULL, @@ -185,19 +162,19 @@ */ static const Tcl_ChannelType ttyChannelType = { "tty", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ - TtyCloseProc, /* Close proc. */ + FileCloseProc, /* Close proc. */ FileInputProc, /* Input proc. */ FileOutputProc, /* Output proc. */ NULL, /* Seek proc. */ TtySetOptionProc, /* Set option proc. */ TtyGetOptionProc, /* Get option proc. */ FileWatchProc, /* Initialize notifier. */ FileGetHandleProc, /* Get OS handles out of channel. */ - NULL, /* close2proc. */ + FileClose2Proc, /* close2proc. */ FileBlockModeProc, /* Set blocking or non-blocking mode.*/ NULL, /* flush proc. */ NULL, /* handler proc. */ NULL, /* wide seek proc. */ NULL, /* thread action proc. */ @@ -220,11 +197,10 @@ * Sets the device into blocking or non-blocking mode. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int FileBlockModeProc( ClientData instanceData, /* File state. */ int mode) /* The mode to set. Can be TCL_MODE_BLOCKING * or TCL_MODE_NONBLOCKING. */ @@ -275,11 +251,11 @@ * appropriately, and read will unblock as soon as a short read is * possible, if the channel is in blocking mode. If the channel is * nonblocking, the read will never block. */ - bytesRead = read(fsPtr->fd, buf, toRead); + bytesRead = read(fsPtr->fd, buf, (size_t) toRead); if (bytesRead > -1) { return bytesRead; } *errorCodePtr = errno; return -1; @@ -322,11 +298,11 @@ * pipe behind the file). */ return 0; } - written = write(fsPtr->fd, buf, toWrite); + written = write(fsPtr->fd, buf, (size_t) toWrite); if (written > -1) { return written; } *errorCodePtr = errno; return -1; @@ -333,15 +309,14 @@ } /* *---------------------------------------------------------------------- * - * FileCloseProc, TtyCloseProc -- + * FileCloseProc -- * - * These functions are called from the generic IO level to perform - * channel-type-specific cleanup when a file- or tty-based channel is - * closed. + * This function is called from the generic IO level to perform + * channel-type-specific cleanup when a file based channel is closed. * * Results: * 0 if successful, errno if failed. * * Side effects: @@ -368,53 +343,24 @@ || ((fsPtr->fd != 0) && (fsPtr->fd != 1) && (fsPtr->fd != 2))) { if (close(fsPtr->fd) < 0) { errorCode = errno; } } - Tcl_Free(fsPtr); + ckfree(fsPtr); return errorCode; } - -#ifdef SUPPORTS_TTY static int -TtyCloseProc( - ClientData instanceData, - Tcl_Interp *interp) -{ - TtyState *ttyPtr = instanceData; - - /* - * If we've been asked by the user to drain or flush, do so now. - */ - - switch (ttyPtr->closeMode) { - case CLOSE_DRAIN: - tcdrain(ttyPtr->fileState.fd); - break; - case CLOSE_DISCARD: - tcflush(ttyPtr->fileState.fd, TCIOFLUSH); - break; - default: - /* Do nothing */ - break; - } - - /* - * If we've had our state changed from the default, reset now. - */ - - if (ttyPtr->doReset) { - tcsetattr(ttyPtr->fileState.fd, TCSANOW, &ttyPtr->initState); - } - - /* - * Delegate to close for files. - */ - - return FileCloseProc(instanceData, interp); -} -#endif /* SUPPORTS_TTY */ +FileClose2Proc( + ClientData instanceData, /* File state. */ + Tcl_Interp *interp, /* For error reporting - unused. */ + int flags) +{ + if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) == 0) { + return FileCloseProc(instanceData, interp); + } + return EINVAL; +} /* *---------------------------------------------------------------------- * * FileSeekProc -- @@ -447,11 +393,11 @@ /* * Save our current place in case we need to roll-back the seek. */ oldLoc = TclOSseek(fsPtr->fd, (Tcl_SeekOffset) 0, SEEK_CUR); - if (oldLoc == -1) { + if (oldLoc == Tcl_LongAsWide(-1)) { /* * Bad things are happening. Error out... */ *errorCodePtr = errno; @@ -462,18 +408,18 @@ /* * Check for expressability in our return type, and roll-back otherwise. */ - if (newLoc > INT_MAX) { + if (newLoc > Tcl_LongAsWide(INT_MAX)) { *errorCodePtr = EOVERFLOW; TclOSseek(fsPtr->fd, (Tcl_SeekOffset) oldLoc, SEEK_SET); return -1; } else { - *errorCodePtr = (newLoc == -1) ? errno : 0; + *errorCodePtr = (newLoc == Tcl_LongAsWide(-1)) ? errno : 0; } - return (int) newLoc; + return (int) Tcl_WideAsLong(newLoc); } /* *---------------------------------------------------------------------- * @@ -642,12 +588,12 @@ ClientData instanceData, /* File state. */ Tcl_Interp *interp, /* For error reporting - can be NULL. */ const char *optionName, /* Which option to set? */ const char *value) /* New value for option. */ { - TtyState *fsPtr = instanceData; - size_t len, vlen; + FileState *fsPtr = instanceData; + unsigned int len, vlen; TtyAttrs tty; int argc; const char **argv; struct termios iostate; @@ -665,13 +611,14 @@ /* * system calls results should be checked there. - dl */ - TtySetAttributes(fsPtr->fileState.fd, &tty); + TtySetAttributes(fsPtr->fd, &tty); return TCL_OK; } + /* * Option -handshake none|xonxoff|rtscts|dtrdsr */ @@ -678,11 +625,11 @@ if ((len > 1) && (strncmp(optionName, "-handshake", len) == 0)) { /* * Reset all handshake options. DTR and RTS are ON by default. */ - tcgetattr(fsPtr->fileState.fd, &iostate); + tcgetattr(fsPtr->fd, &iostate); CLEAR_BITS(iostate.c_iflag, IXON | IXOFF | IXANY); #ifdef CRTSCTS CLEAR_BITS(iostate.c_cflag, CRTSCTS); #endif /* CRTSCTS */ if (Tcl_UtfNcasecmp(value, "NONE", vlen) == 0) { @@ -709,55 +656,47 @@ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "VALUE", NULL); } return TCL_ERROR; } - tcsetattr(fsPtr->fileState.fd, TCSADRAIN, &iostate); + tcsetattr(fsPtr->fd, TCSADRAIN, &iostate); return TCL_OK; } /* * Option -xchar {\x11 \x13} */ if ((len > 1) && (strncmp(optionName, "-xchar", len) == 0)) { - if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) { - return TCL_ERROR; - } else if (argc != 2) { - badXchar: - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "bad value for -xchar: should be a list of" - " two elements with each a single 8-bit character", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "XCHAR", NULL); - } - Tcl_Free(argv); - return TCL_ERROR; - } - - tcgetattr(fsPtr->fileState.fd, &iostate); - - iostate.c_cc[VSTART] = argv[0][0]; - iostate.c_cc[VSTOP] = argv[1][0]; - if (argv[0][0] & 0x80 || argv[1][0] & 0x80) { - Tcl_UniChar character = 0; - int charLen; - - charLen = Tcl_UtfToUniChar(argv[0], &character); - if ((character > 0xFF) || argv[0][charLen]) { - goto badXchar; - } - iostate.c_cc[VSTART] = character; - charLen = Tcl_UtfToUniChar(argv[1], &character); - if ((character > 0xFF) || argv[1][charLen]) { - goto badXchar; - } - iostate.c_cc[VSTOP] = character; - } - Tcl_Free(argv); - - tcsetattr(fsPtr->fileState.fd, TCSADRAIN, &iostate); + Tcl_DString ds; + + if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) { + return TCL_ERROR; + } else if (argc != 2) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad value for -xchar: should be a list of" + " two elements", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", + "VALUE", NULL); + } + ckfree(argv); + return TCL_ERROR; + } + + tcgetattr(fsPtr->fd, &iostate); + + Tcl_UtfToExternalDString(NULL, argv[0], -1, &ds); + iostate.c_cc[VSTART] = *(const cc_t *) Tcl_DStringValue(&ds); + TclDStringClear(&ds); + + Tcl_UtfToExternalDString(NULL, argv[1], -1, &ds); + iostate.c_cc[VSTOP] = *(const cc_t *) Tcl_DStringValue(&ds); + Tcl_DStringFree(&ds); + ckfree(argv); + + tcsetattr(fsPtr->fd, TCSADRAIN, &iostate); return TCL_OK; } /* * Option -timeout msec @@ -764,24 +703,23 @@ */ if ((len > 2) && (strncmp(optionName, "-timeout", len) == 0)) { int msec; - tcgetattr(fsPtr->fileState.fd, &iostate); + tcgetattr(fsPtr->fd, &iostate); if (Tcl_GetInt(interp, value, &msec) != TCL_OK) { return TCL_ERROR; } iostate.c_cc[VMIN] = 0; iostate.c_cc[VTIME] = (msec==0) ? 0 : (msec<100) ? 1 : (msec+50)/100; - tcsetattr(fsPtr->fileState.fd, TCSADRAIN, &iostate); + tcsetattr(fsPtr->fd, TCSADRAIN, &iostate); return TCL_OK; } /* * Option -ttycontrol {DTR 1 RTS 0 BREAK 0} */ - if ((len > 4) && (strncmp(optionName, "-ttycontrol", len) == 0)) { #if defined(TIOCMGET) && defined(TIOCMSET) int i, control, flag; if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) { @@ -793,18 +731,18 @@ "bad value for -ttycontrol: should be a list of" " signal,value pairs", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "VALUE", NULL); } - Tcl_Free(argv); + ckfree(argv); return TCL_ERROR; } - ioctl(fsPtr->fileState.fd, TIOCMGET, &control); + ioctl(fsPtr->fd, TIOCMGET, &control); for (i = 0; i < argc-1; i += 2) { if (Tcl_GetBoolean(interp, argv[i+1], &flag) == TCL_ERROR) { - Tcl_Free(argv); + ckfree(argv); return TCL_ERROR; } if (Tcl_UtfNcasecmp(argv[i], "DTR", strlen(argv[i])) == 0) { if (flag) { SET_BITS(control, TIOCM_DTR); @@ -818,17 +756,17 @@ CLEAR_BITS(control, TIOCM_RTS); } } else if (Tcl_UtfNcasecmp(argv[i], "BREAK", strlen(argv[i])) == 0) { #if defined(TIOCSBRK) && defined(TIOCCBRK) if (flag) { - ioctl(fsPtr->fileState.fd, TIOCSBRK, NULL); + ioctl(fsPtr->fd, TIOCSBRK, NULL); } else { - ioctl(fsPtr->fileState.fd, TIOCCBRK, NULL); + ioctl(fsPtr->fd, TIOCCBRK, NULL); } #else /* TIOCSBRK & TIOCCBRK */ UNSUPPORTED_OPTION("-ttycontrol BREAK"); - Tcl_Free(argv); + ckfree(argv); return TCL_ERROR; #endif /* TIOCSBRK & TIOCCBRK */ } else { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -835,129 +773,25 @@ "bad signal \"%s\" for -ttycontrol: must be" " DTR, RTS or BREAK", argv[i])); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "VALUE", NULL); } - Tcl_Free(argv); + ckfree(argv); return TCL_ERROR; } } /* -ttycontrol options loop */ - ioctl(fsPtr->fileState.fd, TIOCMSET, &control); - Tcl_Free(argv); + ioctl(fsPtr->fd, TIOCMSET, &control); + ckfree(argv); return TCL_OK; #else /* TIOCMGET&TIOCMSET */ UNSUPPORTED_OPTION("-ttycontrol"); #endif /* TIOCMGET&TIOCMSET */ } - /* - * Option -closemode drain|discard - */ - - if ((len > 2) && (strncmp(optionName, "-closemode", len) == 0)) { - if (Tcl_UtfNcasecmp(value, "DEFAULT", vlen) == 0) { - fsPtr->closeMode = CLOSE_DEFAULT; - } else if (Tcl_UtfNcasecmp(value, "DRAIN", vlen) == 0) { - fsPtr->closeMode = CLOSE_DRAIN; - } else if (Tcl_UtfNcasecmp(value, "DISCARD", vlen) == 0) { - fsPtr->closeMode = CLOSE_DISCARD; - } else { - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad mode \"%s\" for -closemode: must be" - " default, discard, or drain", value)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", - "VALUE", NULL); - } - return TCL_ERROR; - } - return TCL_OK; - } - - /* - * Option -inputmode normal|password|raw - */ - - if ((len > 2) && (strncmp(optionName, "-inputmode", len) == 0)) { - if (tcgetattr(fsPtr->fileState.fd, &iostate) < 0) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't read serial terminal control state: %s", - Tcl_PosixError(interp))); - } - return TCL_ERROR; - } - if (Tcl_UtfNcasecmp(value, "NORMAL", vlen) == 0) { - SET_BITS(iostate.c_iflag, BRKINT | IGNPAR | ISTRIP | ICRNL | IXON); - SET_BITS(iostate.c_oflag, OPOST); - SET_BITS(iostate.c_lflag, ECHO | ECHONL | ICANON | ISIG); - } else if (Tcl_UtfNcasecmp(value, "PASSWORD", vlen) == 0) { - SET_BITS(iostate.c_iflag, BRKINT | IGNPAR | ISTRIP | ICRNL | IXON); - SET_BITS(iostate.c_oflag, OPOST); - CLEAR_BITS(iostate.c_lflag, ECHO); - /* - * Note: password input turns out to be best if you echo the - * newline that the user types. Theoretically we could get users - * to do the processing of this in their scripts, but it always - * feels highly unnatural to do so in practice. - */ - SET_BITS(iostate.c_lflag, ECHONL | ICANON | ISIG); - } else if (Tcl_UtfNcasecmp(value, "RAW", vlen) == 0) { -#ifdef HAVE_CFMAKERAW - cfmakeraw(&iostate); -#else /* !HAVE_CFMAKERAW */ - CLEAR_BITS(iostate.c_iflag, IGNBRK | BRKINT | PARMRK | ISTRIP - | INLCR | IGNCR | ICRNL | IXON); - CLEAR_BITS(iostate.c_oflag, OPOST); - CLEAR_BITS(iostate.c_lflag, ECHO | ECHONL | ICANON | ISIG | IEXTEN); - CLEAR_BITS(iostate.c_cflag, CSIZE | PARENB); - SET_BITS(iostate.c_cflag, CS8); -#endif /* HAVE_CFMAKERAW */ - } else if (Tcl_UtfNcasecmp(value, "RESET", vlen) == 0) { - /* - * Reset to the initial state, whatever that is. - */ - - memcpy(&iostate, &fsPtr->initState, sizeof(struct termios)); - } else { - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad mode \"%s\" for -inputmode: must be" - " normal, password, raw, or reset", value)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", - "VALUE", NULL); - } - return TCL_ERROR; - } - if (tcsetattr(fsPtr->fileState.fd, TCSADRAIN, &iostate) < 0) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't update serial terminal control state: %s", - Tcl_PosixError(interp))); - } - return TCL_ERROR; - } - - /* - * If we've changed the state from default, schedule a reset later. - * Note that this specifically does not detect changes made by calling - * an external stty program; that is deliberate, as it maintains - * compatibility with existing code! - * - * This mechanism in Tcl is not intended to be a full replacement for - * what stty does; it just handles a few common cases and tries not to - * leave things in a broken state. - */ - - fsPtr->doReset = (memcmp(&iostate, &fsPtr->initState, - sizeof(struct termios)) != 0); - return TCL_OK; - } - return Tcl_BadChannelOption(interp, optionName, - "closemode inputmode mode handshake timeout ttycontrol xchar"); + "mode handshake timeout ttycontrol xchar"); } /* *---------------------------------------------------------------------- * @@ -981,86 +815,28 @@ ClientData instanceData, /* File state. */ Tcl_Interp *interp, /* For error reporting - can be NULL. */ const char *optionName, /* Option to get. */ Tcl_DString *dsPtr) /* Where to store value(s). */ { - TtyState *fsPtr = instanceData; - size_t len; + FileState *fsPtr = instanceData; + unsigned int len; char buf[3*TCL_INTEGER_SPACE + 16]; int valid = 0; /* Flag if valid option parsed. */ - struct termios iostate; if (optionName == NULL) { len = 0; } else { len = strlen(optionName); } - - /* - * Get option -closemode - */ - - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-closemode"); - } - if (len==0 || (len>1 && strncmp(optionName, "-closemode", len)==0)) { - switch (fsPtr->closeMode) { - case CLOSE_DRAIN: - Tcl_DStringAppendElement(dsPtr, "drain"); - break; - case CLOSE_DISCARD: - Tcl_DStringAppendElement(dsPtr, "discard"); - break; - default: - Tcl_DStringAppendElement(dsPtr, "default"); - break; - } - } - - /* - * Get option -inputmode - * - * This is a great simplification of the underlying reality, but actually - * represents what almost all scripts really want to know. - */ - - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-inputmode"); - } - if (len==0 || (len>1 && strncmp(optionName, "-inputmode", len)==0)) { - valid = 1; - if (tcgetattr(fsPtr->fileState.fd, &iostate) < 0) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't read serial terminal control state: %s", - Tcl_PosixError(interp))); - } - return TCL_ERROR; - } - if (iostate.c_lflag & ICANON) { - if (iostate.c_lflag & ECHO) { - Tcl_DStringAppendElement(dsPtr, "normal"); - } else { - Tcl_DStringAppendElement(dsPtr, "password"); - } - } else { - Tcl_DStringAppendElement(dsPtr, "raw"); - } - } - - /* - * Get option -mode - */ - if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-mode"); } if (len==0 || (len>2 && strncmp(optionName, "-mode", len)==0)) { TtyAttrs tty; valid = 1; - TtyGetAttributes(fsPtr->fileState.fd, &tty); + TtyGetAttributes(fsPtr->fd, &tty); sprintf(buf, "%d,%c,%d,%d", tty.baud, tty.parity, tty.data, tty.stop); Tcl_DStringAppendElement(dsPtr, buf); } /* @@ -1070,14 +846,15 @@ if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-xchar"); Tcl_DStringStartSublist(dsPtr); } if (len==0 || (len>1 && strncmp(optionName, "-xchar", len)==0)) { + struct termios iostate; Tcl_DString ds; valid = 1; - tcgetattr(fsPtr->fileState.fd, &iostate); + tcgetattr(fsPtr->fd, &iostate); Tcl_DStringInit(&ds); Tcl_ExternalToUtfDString(NULL, (char *) &iostate.c_cc[VSTART], 1, &ds); Tcl_DStringAppendElement(dsPtr, Tcl_DStringValue(&ds)); TclDStringClear(&ds); @@ -1098,14 +875,14 @@ if ((len > 1) && (strncmp(optionName, "-queue", len) == 0)) { int inQueue=0, outQueue=0, inBuffered, outBuffered; valid = 1; - GETREADQUEUE(fsPtr->fileState.fd, inQueue); - GETWRITEQUEUE(fsPtr->fileState.fd, outQueue); - inBuffered = Tcl_InputBuffered(fsPtr->fileState.channel); - outBuffered = Tcl_OutputBuffered(fsPtr->fileState.channel); + GETREADQUEUE(fsPtr->fd, inQueue); + GETWRITEQUEUE(fsPtr->fd, outQueue); + inBuffered = Tcl_InputBuffered(fsPtr->channel); + outBuffered = Tcl_OutputBuffered(fsPtr->channel); sprintf(buf, "%d", inBuffered+inQueue); Tcl_DStringAppendElement(dsPtr, buf); sprintf(buf, "%d", outBuffered+outQueue); Tcl_DStringAppendElement(dsPtr, buf); @@ -1115,53 +892,28 @@ /* * Get option -ttystatus * Option is readonly and returned by [fconfigure chan -ttystatus] but not * returned by unnamed [fconfigure chan]. */ - if ((len > 4) && (strncmp(optionName, "-ttystatus", len) == 0)) { int status; valid = 1; - ioctl(fsPtr->fileState.fd, TIOCMGET, &status); + ioctl(fsPtr->fd, TIOCMGET, &status); TtyModemStatusStr(status, dsPtr); } #endif /* TIOCMGET */ -#if defined(TIOCGWINSZ) - /* - * Get option -winsize - * Option is readonly and returned by [fconfigure chan -winsize] but not - * returned by [fconfigure chan] without explicit option name. - */ - - if ((len > 1) && (strncmp(optionName, "-winsize", len) == 0)) { - struct winsize ws; - - valid = 1; - if (ioctl(fsPtr->fileState.fd, TIOCGWINSZ, &ws) < 0) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't read terminal size: %s", - Tcl_PosixError(interp))); - } - return TCL_ERROR; - } - sprintf(buf, "%d", ws.ws_col); - Tcl_DStringAppendElement(dsPtr, buf); - sprintf(buf, "%d", ws.ws_row); - Tcl_DStringAppendElement(dsPtr, buf); - } -#endif /* TIOCGWINSZ */ - if (valid) { return TCL_OK; } - return Tcl_BadChannelOption(interp, optionName, - "closemode inputmode mode queue ttystatus winsize xchar"); + return Tcl_BadChannelOption(interp, optionName, "mode" + " queue ttystatus xchar" + ); } + static const struct {int baud; speed_t speed;} speeds[] = { #ifdef B0 {0, B0}, #endif #ifdef B50 @@ -1281,11 +1033,11 @@ #ifdef B4000000 {4000000,B4000000}, #endif {-1, 0} }; - + /* *--------------------------------------------------------------------------- * * TtyGetSpeed -- * @@ -1573,22 +1325,22 @@ *--------------------------------------------------------------------------- */ static void TtyInit( - int fd) /* Open file descriptor for serial port to be - * initialized. */ + int fd) /* Open file descriptor for serial port to be initialized. */ { struct termios iostate; tcgetattr(fd, &iostate); if (iostate.c_iflag != IGNBRK || iostate.c_oflag != 0 || iostate.c_lflag != 0 || iostate.c_cflag & CREAD || iostate.c_cc[VMIN] != 1 - || iostate.c_cc[VTIME] != 0) { + || iostate.c_cc[VTIME] != 0) + { iostate.c_iflag = IGNBRK; iostate.c_oflag = 0; iostate.c_lflag = 0; iostate.c_cflag |= CREAD; iostate.c_cc[VMIN] = 1; @@ -1626,11 +1378,11 @@ int mode, /* POSIX open mode. */ int permissions) /* If the open involves creating a file, with * what modes to create it? */ { int fd, channelPermissions; - TtyState *fsPtr; + FileState *fsPtr; const char *native, *translation; char channelName[16 + TCL_INTEGER_SPACE]; const Tcl_ChannelType *channelTypePtr; switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) { @@ -1682,10 +1434,12 @@ * inherit this fd. */ fcntl(fd, F_SETFD, FD_CLOEXEC); + sprintf(channelName, "file%d", fd); + #ifdef SUPPORTS_TTY if (strcmp(native, "/dev/tty") != 0 && isatty(fd)) { /* * Initialize the serial port to a set of sane parameters. Especially * important if the remote device is set to echo and the serial port @@ -1701,31 +1455,22 @@ */ translation = "auto crlf"; channelTypePtr = &ttyChannelType; TtyInit(fd); - sprintf(channelName, "serial%d", fd); } else #endif /* SUPPORTS_TTY */ { translation = NULL; channelTypePtr = &fileChannelType; - sprintf(channelName, "file%d", fd); - } - - fsPtr = Tcl_Alloc(sizeof(TtyState)); - fsPtr->fileState.validMask = channelPermissions | TCL_EXCEPTION; - fsPtr->fileState.fd = fd; -#ifdef SUPPORTS_TTY - if (channelTypePtr == &ttyChannelType) { - fsPtr->closeMode = CLOSE_DEFAULT; - fsPtr->doReset = 0; - tcgetattr(fsPtr->fileState.fd, &fsPtr->initState); - } -#endif /* SUPPORTS_TTY */ - - fsPtr->fileState.channel = Tcl_CreateChannel(channelTypePtr, channelName, + } + + fsPtr = ckalloc(sizeof(FileState)); + fsPtr->validMask = channelPermissions | TCL_EXCEPTION; + fsPtr->fd = fd; + + fsPtr->channel = Tcl_CreateChannel(channelTypePtr, channelName, fsPtr, channelPermissions); if (translation != NULL) { /* * Gotcha. Most modems need a "\r" at the end of the command sequence. @@ -1733,18 +1478,18 @@ * because it never got a "\r" to actually invoke the command. So, by * default, newlines are translated to "\r\n" on output to avoid "bug" * reports that the serial port isn't working. */ - if (Tcl_SetChannelOption(interp, fsPtr->fileState.channel, - "-translation", translation) != TCL_OK) { - Tcl_Close(NULL, fsPtr->fileState.channel); + if (Tcl_SetChannelOption(interp, fsPtr->channel, "-translation", + translation) != TCL_OK) { + Tcl_Close(NULL, fsPtr->channel); return NULL; } } - return fsPtr->fileState.channel; + return fsPtr->channel; } /* *---------------------------------------------------------------------- * @@ -1765,58 +1510,45 @@ Tcl_MakeFileChannel( ClientData handle, /* OS level handle. */ int mode) /* ORed combination of TCL_READABLE and * TCL_WRITABLE to indicate file mode. */ { - TtyState *fsPtr; + FileState *fsPtr; char channelName[16 + TCL_INTEGER_SPACE]; int fd = PTR2INT(handle); const Tcl_ChannelType *channelTypePtr; - struct stat buf; + struct sockaddr sockaddr; + socklen_t sockaddrLen = sizeof(sockaddr); if (mode == 0) { return NULL; } + + sockaddr.sa_family = AF_UNSPEC; #ifdef SUPPORTS_TTY if (isatty(fd)) { channelTypePtr = &ttyChannelType; sprintf(channelName, "serial%d", fd); } else #endif /* SUPPORTS_TTY */ - if (fstat(fd, &buf) == 0 && S_ISSOCK(buf.st_mode)) { - struct sockaddr sockaddr; - socklen_t sockaddrLen = sizeof(sockaddr); - - sockaddr.sa_family = AF_UNSPEC; - if ((getsockname(fd, (struct sockaddr *)&sockaddr, &sockaddrLen) == 0) - && (sockaddrLen > 0) - && (sockaddr.sa_family == AF_INET - || sockaddr.sa_family == AF_INET6)) { - return TclpMakeTcpClientChannelMode(INT2PTR(fd), mode); - } - goto normalChannelAfterAll; + if ((getsockname(fd, (struct sockaddr *)&sockaddr, &sockaddrLen) == 0) + && (sockaddrLen > 0) + && (sockaddr.sa_family == AF_INET || sockaddr.sa_family == AF_INET6)) { + return TclpMakeTcpClientChannelMode(INT2PTR(fd), mode); } else { - normalChannelAfterAll: channelTypePtr = &fileChannelType; sprintf(channelName, "file%d", fd); } - fsPtr = Tcl_Alloc(sizeof(TtyState)); - fsPtr->fileState.fd = fd; - fsPtr->fileState.validMask = mode | TCL_EXCEPTION; - fsPtr->fileState.channel = Tcl_CreateChannel(channelTypePtr, channelName, + fsPtr = ckalloc(sizeof(FileState)); + fsPtr->fd = fd; + fsPtr->validMask = mode | TCL_EXCEPTION; + fsPtr->channel = Tcl_CreateChannel(channelTypePtr, channelName, fsPtr, mode); -#ifdef SUPPORTS_TTY - if (channelTypePtr == &ttyChannelType) { - fsPtr->closeMode = CLOSE_DEFAULT; - fsPtr->doReset = 0; - tcgetattr(fsPtr->fileState.fd, &fsPtr->initState); - } -#endif /* SUPPORTS_TTY */ - - return fsPtr->fileState.channel; + + return fsPtr->channel; } /* *---------------------------------------------------------------------- * @@ -2003,10 +1735,170 @@ "\"%s\" cannot be used to get a FILE *", chanID)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "NO_DESCRIPTOR", NULL); return TCL_ERROR; } + +#ifndef HAVE_COREFOUNDATION /* Darwin/Mac OS X CoreFoundation notifier is + * in tclMacOSXNotify.c */ +/* + *---------------------------------------------------------------------- + * + * TclUnixWaitForFile -- + * + * This function waits synchronously for a file to become readable or + * writable, with an optional timeout. + * + * Results: + * The return value is an OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, and TCL_EXCEPTION, indicating the conditions that are + * present on file at the time of the return. This function will not + * return until either "timeout" milliseconds have elapsed or at least + * one of the conditions given by mask has occurred for file (a return + * value of 0 means that a timeout occurred). No normal events will be + * serviced during the execution of this function. + * + * Side effects: + * Time passes. + * + *---------------------------------------------------------------------- + */ + +int +TclUnixWaitForFile( + int fd, /* Handle for file on which to wait. */ + int mask, /* What to wait for: OR'ed combination of + * TCL_READABLE, TCL_WRITABLE, and + * TCL_EXCEPTION. */ + int timeout) /* Maximum amount of time to wait for one of + * the conditions in mask to occur, in + * milliseconds. A value of 0 means don't wait + * at all, and a value of -1 means wait + * forever. */ +{ + Tcl_Time abortTime = {0, 0}, now; /* silence gcc 4 warning */ + struct timeval blockTime, *timeoutPtr; + int numFound, result = 0; + fd_set readableMask; + fd_set writableMask; + fd_set exceptionMask; + +#ifndef _DARWIN_C_SOURCE + /* + * Sanity check fd. + */ + + if (fd >= FD_SETSIZE) { + Tcl_Panic("TclUnixWaitForFile can't handle file id %d", fd); + /* must never get here, or select masks overrun will occur below */ + } +#endif + + /* + * If there is a non-zero finite timeout, compute the time when we give + * up. + */ + + if (timeout > 0) { + Tcl_GetTime(&now); + abortTime.sec = now.sec + timeout/1000; + abortTime.usec = now.usec + (timeout%1000)*1000; + if (abortTime.usec >= 1000000) { + abortTime.usec -= 1000000; + abortTime.sec += 1; + } + timeoutPtr = &blockTime; + } else if (timeout == 0) { + timeoutPtr = &blockTime; + blockTime.tv_sec = 0; + blockTime.tv_usec = 0; + } else { + timeoutPtr = NULL; + } + + /* + * Initialize the select masks. + */ + + FD_ZERO(&readableMask); + FD_ZERO(&writableMask); + FD_ZERO(&exceptionMask); + + /* + * Loop in a mini-event loop of our own, waiting for either the file to + * become ready or a timeout to occur. + */ + + while (1) { + if (timeout > 0) { + blockTime.tv_sec = abortTime.sec - now.sec; + blockTime.tv_usec = abortTime.usec - now.usec; + if (blockTime.tv_usec < 0) { + blockTime.tv_sec -= 1; + blockTime.tv_usec += 1000000; + } + if (blockTime.tv_sec < 0) { + blockTime.tv_sec = 0; + blockTime.tv_usec = 0; + } + } + + /* + * Setup the select masks for the fd. + */ + + if (mask & TCL_READABLE) { + FD_SET(fd, &readableMask); + } + if (mask & TCL_WRITABLE) { + FD_SET(fd, &writableMask); + } + if (mask & TCL_EXCEPTION) { + FD_SET(fd, &exceptionMask); + } + + /* + * Wait for the event or a timeout. + */ + + numFound = select(fd + 1, &readableMask, &writableMask, + &exceptionMask, timeoutPtr); + if (numFound == 1) { + if (FD_ISSET(fd, &readableMask)) { + SET_BITS(result, TCL_READABLE); + } + if (FD_ISSET(fd, &writableMask)) { + SET_BITS(result, TCL_WRITABLE); + } + if (FD_ISSET(fd, &exceptionMask)) { + SET_BITS(result, TCL_EXCEPTION); + } + result &= mask; + if (result) { + break; + } + } + if (timeout == 0) { + break; + } + if (timeout < 0) { + continue; + } + + /* + * The select returned early, so we need to recompute the timeout. + */ + + Tcl_GetTime(&now); + if ((abortTime.sec < now.sec) + || (abortTime.sec==now.sec && abortTime.usec<=now.usec)) { + break; + } + } + return result; +} +#endif /* HAVE_COREFOUNDATION */ /* *---------------------------------------------------------------------- * * FileTruncateProc -- Index: unix/tclUnixCompat.c ================================================================== --- unix/tclUnixCompat.c +++ unix/tclUnixCompat.c @@ -6,10 +6,12 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" +#include +#include #include #include /* * See also: SC_BLOCKING_STYLE in unix/tcl.m4 @@ -43,11 +45,11 @@ /* * Per-thread private storage used to store values returned from MT-unsafe * library calls. */ -#if TCL_THREADS +#ifdef TCL_THREADS typedef struct { struct passwd pwd; #if defined(HAVE_GETPWNAM_R_5) || defined(HAVE_GETPWUID_R_5) #define NEED_PW_CLEANER 1 @@ -114,14 +116,14 @@ static int CopyString(const char *src, char *buf, int buflen); #endif #ifdef NEED_PW_CLEANER -static void FreePwBuf(ClientData ignored); +static void FreePwBuf(ClientData dummy); #endif #ifdef NEED_GR_CLEANER -static void FreeGrBuf(ClientData ignored); +static void FreeGrBuf(ClientData dummy); #endif #endif /* TCL_THREADS */ /* *--------------------------------------------------------------------------- @@ -178,11 +180,11 @@ struct passwd * TclpGetPwNam( const char *name) { -#if !TCL_THREADS +#if !defined(TCL_THREADS) return getpwnam(name); #else ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); #if defined(HAVE_GETPWNAM_R_5) @@ -197,11 +199,11 @@ if (tsdPtr->pbuf == NULL) { tsdPtr->pbuflen = (int) sysconf(_SC_GETPW_R_SIZE_MAX); if (tsdPtr->pbuflen < 1) { tsdPtr->pbuflen = 1024; } - tsdPtr->pbuf = Tcl_Alloc(tsdPtr->pbuflen); + tsdPtr->pbuf = (char *)ckalloc(tsdPtr->pbuflen); Tcl_CreateThreadExitHandler(FreePwBuf, NULL); } while (1) { int e = getpwnam_r(name, &tsdPtr->pwd, tsdPtr->pbuf, tsdPtr->pbuflen, &pwPtr); @@ -210,11 +212,11 @@ break; } else if (e != ERANGE) { return NULL; } tsdPtr->pbuflen *= 2; - tsdPtr->pbuf = Tcl_Realloc(tsdPtr->pbuf, tsdPtr->pbuflen); + tsdPtr->pbuf = (char *)ckrealloc(tsdPtr->pbuf, tsdPtr->pbuflen); } return (pwPtr != NULL ? &tsdPtr->pwd : NULL); #elif defined(HAVE_GETPWNAM_R_4) return getpwnam_r(name, &tsdPtr->pwd, tsdPtr->pbuf, sizeof(tsdPtr->pbuf)); @@ -258,11 +260,11 @@ struct passwd * TclpGetPwUid( uid_t uid) { -#if !TCL_THREADS +#if !defined(TCL_THREADS) return getpwuid(uid); #else ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); #if defined(HAVE_GETPWUID_R_5) @@ -277,11 +279,11 @@ if (tsdPtr->pbuf == NULL) { tsdPtr->pbuflen = (int) sysconf(_SC_GETPW_R_SIZE_MAX); if (tsdPtr->pbuflen < 1) { tsdPtr->pbuflen = 1024; } - tsdPtr->pbuf = Tcl_Alloc(tsdPtr->pbuflen); + tsdPtr->pbuf = (char *)ckalloc(tsdPtr->pbuflen); Tcl_CreateThreadExitHandler(FreePwBuf, NULL); } while (1) { int e = getpwuid_r(uid, &tsdPtr->pwd, tsdPtr->pbuf, tsdPtr->pbuflen, &pwPtr); @@ -290,11 +292,11 @@ break; } else if (e != ERANGE) { return NULL; } tsdPtr->pbuflen *= 2; - tsdPtr->pbuf = Tcl_Realloc(tsdPtr->pbuf, tsdPtr->pbuflen); + tsdPtr->pbuf = (char *)ckrealloc(tsdPtr->pbuf, tsdPtr->pbuflen); } return (pwPtr != NULL ? &tsdPtr->pwd : NULL); #elif defined(HAVE_GETPWUID_R_4) return getpwuid_r(uid, &tsdPtr->pwd, tsdPtr->pbuf, sizeof(tsdPtr->pbuf)); @@ -332,15 +334,16 @@ */ #ifdef NEED_PW_CLEANER static void FreePwBuf( - ClientData ignored) + ClientData dummy) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + (void)dummy; - Tcl_Free(tsdPtr->pbuf); + ckfree(tsdPtr->pbuf); } #endif /* NEED_PW_CLEANER */ /* *--------------------------------------------------------------------------- @@ -361,11 +364,11 @@ struct group * TclpGetGrNam( const char *name) { -#if !TCL_THREADS +#if !defined(TCL_THREADS) return getgrnam(name); #else ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); #if defined(HAVE_GETGRNAM_R_5) @@ -380,11 +383,11 @@ if (tsdPtr->gbuf == NULL) { tsdPtr->gbuflen = (int) sysconf(_SC_GETGR_R_SIZE_MAX); if (tsdPtr->gbuflen < 1) { tsdPtr->gbuflen = 1024; } - tsdPtr->gbuf = Tcl_Alloc(tsdPtr->gbuflen); + tsdPtr->gbuf = (char *)ckalloc(tsdPtr->gbuflen); Tcl_CreateThreadExitHandler(FreeGrBuf, NULL); } while (1) { int e = getgrnam_r(name, &tsdPtr->grp, tsdPtr->gbuf, tsdPtr->gbuflen, &grPtr); @@ -393,11 +396,11 @@ break; } else if (e != ERANGE) { return NULL; } tsdPtr->gbuflen *= 2; - tsdPtr->gbuf = Tcl_Realloc(tsdPtr->gbuf, tsdPtr->gbuflen); + tsdPtr->gbuf = (char *)ckrealloc(tsdPtr->gbuf, tsdPtr->gbuflen); } return (grPtr != NULL ? &tsdPtr->grp : NULL); #elif defined(HAVE_GETGRNAM_R_4) return getgrnam_r(name, &tsdPtr->grp, tsdPtr->gbuf, sizeof(tsdPtr->gbuf)); @@ -441,11 +444,11 @@ struct group * TclpGetGrGid( gid_t gid) { -#if !TCL_THREADS +#if !defined(TCL_THREADS) return getgrgid(gid); #else ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); #if defined(HAVE_GETGRGID_R_5) @@ -460,11 +463,11 @@ if (tsdPtr->gbuf == NULL) { tsdPtr->gbuflen = (int) sysconf(_SC_GETGR_R_SIZE_MAX); if (tsdPtr->gbuflen < 1) { tsdPtr->gbuflen = 1024; } - tsdPtr->gbuf = Tcl_Alloc(tsdPtr->gbuflen); + tsdPtr->gbuf = (char *)ckalloc(tsdPtr->gbuflen); Tcl_CreateThreadExitHandler(FreeGrBuf, NULL); } while (1) { int e = getgrgid_r(gid, &tsdPtr->grp, tsdPtr->gbuf, tsdPtr->gbuflen, &grPtr); @@ -473,11 +476,11 @@ break; } else if (e != ERANGE) { return NULL; } tsdPtr->gbuflen *= 2; - tsdPtr->gbuf = Tcl_Realloc(tsdPtr->gbuf, tsdPtr->gbuflen); + tsdPtr->gbuf = (char *)ckrealloc(tsdPtr->gbuf, tsdPtr->gbuflen); } return (grPtr != NULL ? &tsdPtr->grp : NULL); #elif defined(HAVE_GETGRGID_R_4) return getgrgid_r(gid, &tsdPtr->grp, tsdPtr->gbuf, sizeof(tsdPtr->gbuf)); @@ -515,15 +518,16 @@ */ #ifdef NEED_GR_CLEANER static void FreeGrBuf( - ClientData ignored) + ClientData dummy) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + (void)dummy; - Tcl_Free(tsdPtr->gbuf); + ckfree(tsdPtr->gbuf); } #endif /* NEED_GR_CLEANER */ /* *--------------------------------------------------------------------------- @@ -544,11 +548,11 @@ struct hostent * TclpGetHostByName( const char *name) { -#if !TCL_THREADS || defined(HAVE_MTSAFE_GETHOSTBYNAME) +#if !defined(TCL_THREADS) || defined(HAVE_MTSAFE_GETHOSTBYNAME) return gethostbyname(name); #else ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); #if defined(HAVE_GETHOSTBYNAME_R_5) @@ -614,11 +618,11 @@ TclpGetHostByAddr( const char *addr, int length, int type) { -#if !TCL_THREADS || defined(HAVE_MTSAFE_GETHOSTBYADDR) +#if !defined(TCL_THREADS) || defined(HAVE_MTSAFE_GETHOSTBYADDR) return gethostbyaddr(addr, length, type); #else ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); #if defined(HAVE_GETHOSTBYADDR_R_7) @@ -681,12 +685,12 @@ CopyGrp( struct group *tgtPtr, char *buf, int buflen) { - register char *p = buf; - register int copied, len = 0; + char *p = buf; + int copied, len = 0; /* * Copy username. */ @@ -883,11 +887,11 @@ * length. */ char *buf, /* Buffer to copy into. */ int buflen) /* Size of buffer. */ { int i, j, len = 0; - char *p, **new; + char *p, **newBuffer; if (src == NULL) { return 0; } @@ -899,11 +903,11 @@ len = sizeof(char *) * (i + 1); /* Leave place for the array. */ if (len > buflen) { return -1; } - new = (char **) buf; + newBuffer = (char **)buf; p = buf + len; for (j = 0; j < i; j++) { int sz = (elsize<0 ? (int) strlen(src[j]) + 1 : elsize); @@ -910,14 +914,14 @@ len += sz; if (len > buflen) { return -1; } memcpy(p, src[j], sz); - new[j] = p; + newBuffer[j] = p; p = buf + len; } - new[j] = NULL; + newBuffer[j] = NULL; return len; } #endif /* NEED_COPYARRAY */ @@ -984,12 +988,12 @@ *---------------------------------------------------------------------- */ int TclWinCPUID( - int index, /* Which CPUID value to retrieve. */ - int *regsPtr) /* Registers after the CPUID. */ + unsigned int index, /* Which CPUID value to retrieve. */ + unsigned int *regsPtr) /* Registers after the CPUID. */ { int status = TCL_ERROR; /* See: */ #if defined(HAVE_CPUID) Index: unix/tclUnixFCmd.c ================================================================== --- unix/tclUnixFCmd.c +++ unix/tclUnixFCmd.c @@ -39,10 +39,12 @@ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH * DAMAGE. */ #include "tclInt.h" +#include +#include #ifndef HAVE_STRUCT_STAT_ST_BLKSIZE #ifndef NO_FSTATFS #include #endif #endif /* !HAVE_STRUCT_STAT_ST_BLKSIZE */ @@ -252,11 +254,11 @@ #else # define Realpath realpath #endif /* PURIFY */ #ifndef NO_REALPATH -#if defined(__APPLE__) && TCL_THREADS && \ +#if defined(__APPLE__) && defined(TCL_THREADS) && \ defined(MAC_OS_X_VERSION_MIN_REQUIRED) && \ MAC_OS_X_VERSION_MIN_REQUIRED < 1030 /* * Prior to Darwin 7, realpath is not thread-safe, c.f. Bug 711232; if we * might potentially be running on pre-10.3 OSX, check Darwin release at @@ -550,11 +552,11 @@ const Tcl_StatBuf *statBufPtr, /* Used to determine mode and blocksize. */ int dontCopyAtts) /* If flag set, don't copy attributes. */ { int srcFd, dstFd; - size_t blockSize; /* Optimal I/O blocksize for filesystem */ + unsigned blockSize; /* Optimal I/O blocksize for filesystem */ char *buffer; /* Data buffer for copy */ size_t nread; #ifdef DJGPP #define BINMODE |O_BINARY @@ -606,25 +608,25 @@ */ if (blockSize <= 0) { blockSize = DEFAULT_COPY_BLOCK_SIZE; } - buffer = Tcl_Alloc(blockSize); + buffer = ckalloc(blockSize); while (1) { - nread = read(srcFd, buffer, blockSize); - if ((nread == TCL_IO_FAILURE) || (nread == 0)) { + nread = (size_t) read(srcFd, buffer, blockSize); + if ((nread == (size_t) -1) || (nread == 0)) { break; } if ((size_t) write(dstFd, buffer, nread) != nread) { - nread = TCL_IO_FAILURE; + nread = (size_t) -1; break; } } - Tcl_Free(buffer); + ckfree(buffer); close(srcFd); - if ((close(dstFd) != 0) || (nread == TCL_IO_FAILURE)) { + if ((close(dstFd) != 0) || (nread == (size_t) -1)) { unlink(dst); /* INTL: Native. */ return TCL_ERROR; } if (!dontCopyAtts && CopyFileAtts(src, dst, statBufPtr) == TCL_ERROR) { /* @@ -956,12 +958,12 @@ * source hierarchy, e.g. by deleting * files. */ { Tcl_StatBuf statBuf; const char *source, *errfile; - int result; - size_t targetLen, sourceLen; + int result, sourceLen; + int targetLen; #ifndef HAVE_FTS int numProcessed = 0; Tcl_DirEntry *dirEntPtr; TclDIR *dirPtr; #else @@ -1365,11 +1367,11 @@ } groupPtr = TclpGetGrGid(statBuf.st_gid); if (groupPtr == NULL) { - *attributePtrPtr = Tcl_NewWideIntObj(statBuf.st_gid); + TclNewIntObj(*attributePtrPtr, (int) statBuf.st_gid); } else { Tcl_DString ds; const char *utf; utf = Tcl_ExternalToUtfDString(NULL, groupPtr->gr_name, -1, &ds); @@ -1419,11 +1421,11 @@ } pwPtr = TclpGetPwUid(statBuf.st_uid); if (pwPtr == NULL) { - *attributePtrPtr = Tcl_NewWideIntObj(statBuf.st_uid); + TclNewIntObj(*attributePtrPtr, (int) statBuf.st_uid); } else { Tcl_DString ds; (void) Tcl_ExternalToUtfDString(NULL, pwPtr->pw_name, -1, &ds); *attributePtrPtr = TclDStringToObj(&ds); @@ -1495,21 +1497,21 @@ Tcl_Interp *interp, /* The interp for error reporting. */ int objIndex, /* The index of the attribute. */ Tcl_Obj *fileName, /* The name of the file (UTF-8). */ Tcl_Obj *attributePtr) /* New group for file. */ { - Tcl_WideInt gid; + long gid; int result; const char *native; - if (Tcl_GetWideIntFromObj(NULL, attributePtr, &gid) != TCL_OK) { + if (Tcl_GetLongFromObj(NULL, attributePtr, &gid) != TCL_OK) { Tcl_DString ds; struct group *groupPtr = NULL; const char *string; - size_t length; + int length; - string = TclGetStringFromObj(attributePtr, &length); + string = Tcl_GetStringFromObj(attributePtr, &length); native = Tcl_UtfToExternalDString(NULL, string, length, &ds); groupPtr = TclpGetGrNam(native); /* INTL: Native. */ Tcl_DStringFree(&ds); @@ -1562,21 +1564,21 @@ Tcl_Interp *interp, /* The interp for error reporting. */ int objIndex, /* The index of the attribute. */ Tcl_Obj *fileName, /* The name of the file (UTF-8). */ Tcl_Obj *attributePtr) /* New owner for file. */ { - Tcl_WideInt uid; + long uid; int result; const char *native; - if (Tcl_GetWideIntFromObj(NULL, attributePtr, &uid) != TCL_OK) { + if (Tcl_GetLongFromObj(NULL, attributePtr, &uid) != TCL_OK) { Tcl_DString ds; struct passwd *pwPtr = NULL; const char *string; - size_t length; + int length; - string = TclGetStringFromObj(attributePtr, &length); + string = Tcl_GetStringFromObj(attributePtr, &length); native = Tcl_UtfToExternalDString(NULL, string, length, &ds); pwPtr = TclpGetPwNam(native); /* INTL: Native. */ Tcl_DStringFree(&ds); @@ -1629,11 +1631,11 @@ Tcl_Interp *interp, /* The interp we are using for errors. */ int objIndex, /* The index of the attribute. */ Tcl_Obj *fileName, /* The name of the file (UTF-8). */ Tcl_Obj *attributePtr) /* The attribute to set. */ { - Tcl_WideInt mode; + long mode; mode_t newMode; int result = TCL_ERROR; const char *native; const char *modeStringPtr = TclGetString(attributePtr); int scanned = TclParseAllWhiteSpace(modeStringPtr, -1); @@ -1648,15 +1650,15 @@ /* Leading zero - attempt octal interpretation */ Tcl_Obj *modeObj; TclNewLiteralStringObj(modeObj, "0o"); Tcl_AppendToObj(modeObj, modeStringPtr+scanned+1, -1); - result = Tcl_GetWideIntFromObj(NULL, modeObj, &mode); + result = Tcl_GetLongFromObj(NULL, modeObj, &mode); Tcl_DecrRefCount(modeObj); } if (result == TCL_OK - || Tcl_GetWideIntFromObj(NULL, attributePtr, &mode) == TCL_OK) { + || Tcl_GetLongFromObj(NULL, attributePtr, &mode) == TCL_OK) { newMode = (mode_t) (mode & 0x00007FFF); } else { Tcl_StatBuf buf; /* @@ -1837,26 +1839,26 @@ for (i = 0 ; *(modeStringPtr+n+i) != '\0' ; i++ ) { if (!who_found) { /* who */ switch (*(modeStringPtr+n+i)) { case 'u': - who |= 0x9c0; + who |= 0x9C0; continue; case 'g': who |= 0x438; continue; case 'o': who |= 0x207; continue; case 'a': - who |= 0xfff; + who |= 0xFFF; continue; } } who_found = 1; if (who == 0) { - who = 0xfff; + who = 0xFFF; } if (!op_found) { /* op */ switch (*(modeStringPtr+n+i)) { case '+': @@ -1885,11 +1887,11 @@ continue; case 'x': what |= 0x49; continue; case 's': - what |= 0xc00; + what |= 0xC00; continue; case 't': what |= 0x200; continue; case ',': @@ -1942,13 +1944,13 @@ Tcl_Interp *interp, Tcl_Obj *pathPtr, int nextCheckpoint) { const char *currentPathEndPosition; + int pathLen; char cur; - size_t pathLen; - const char *path = TclGetStringFromObj(pathPtr, &pathLen); + const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen); Tcl_DString ds; const char *nativePath; #ifndef NO_REALPATH char normPath[MAXPATHLEN]; #endif @@ -2052,11 +2054,11 @@ return 0; } nativePath = Tcl_UtfToExternalDString(NULL, path,nextCheckpoint, &ds); if (Realpath(nativePath, normPath) != NULL) { - size_t newNormLen; + int newNormLen; wholeStringOk: newNormLen = strlen(normPath); if ((newNormLen == Tcl_DStringLength(&ds)) && (strcmp(normPath, nativePath) == 0)) { @@ -2086,11 +2088,11 @@ * Free up the native path and put in its place the converted, * normalized path. */ Tcl_DStringFree(&ds); - Tcl_ExternalToUtfDString(NULL, normPath, newNormLen, &ds); + Tcl_ExternalToUtfDString(NULL, normPath, (int) newNormLen, &ds); if (path[nextCheckpoint] != '\0') { /* * Not at end, append remaining path. */ @@ -2173,30 +2175,29 @@ Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj) { Tcl_DString template, tmp; const char *string; - int fd; - size_t length; + int len, fd; /* * We should also check against making more then TMP_MAX of these. */ if (dirObj) { - string = TclGetStringFromObj(dirObj, &length); - Tcl_UtfToExternalDString(NULL, string, length, &template); + string = Tcl_GetStringFromObj(dirObj, &len); + Tcl_UtfToExternalDString(NULL, string, len, &template); } else { Tcl_DStringInit(&template); Tcl_DStringAppend(&template, DefaultTempDir(), -1); /* INTL: native */ } TclDStringAppendLiteral(&template, "/"); if (basenameObj) { - string = TclGetStringFromObj(basenameObj, &length); - Tcl_UtfToExternalDString(NULL, string, length, &tmp); + string = Tcl_GetStringFromObj(basenameObj, &len); + Tcl_UtfToExternalDString(NULL, string, len, &tmp); TclDStringAppendDString(&template, &tmp); Tcl_DStringFree(&tmp); } else { TclDStringAppendLiteral(&template, "tcl"); } @@ -2203,12 +2204,12 @@ TclDStringAppendLiteral(&template, "_XXXXXX"); #ifdef HAVE_MKSTEMPS if (extensionObj) { - string = TclGetStringFromObj(extensionObj, &length); - Tcl_UtfToExternalDString(NULL, string, length, &tmp); + string = Tcl_GetStringFromObj(extensionObj, &len); + Tcl_UtfToExternalDString(NULL, string, len, &tmp); TclDStringAppendDString(&template, &tmp); fd = mkstemps(Tcl_DStringValue(&template), Tcl_DStringLength(&tmp)); Tcl_DStringFree(&tmp); } else #endif @@ -2271,89 +2272,10 @@ * isn't. */ return TCL_TEMPORARY_FILE_DIRECTORY; } - -/* - *---------------------------------------------------------------------- - * - * TclpCreateTemporaryDirectory -- - * - * Creates a temporary directory, possibly based on the supplied bits and - * pieces of template supplied in the arguments. - * - * Results: - * An object (refcount 0) containing the name of the newly-created - * directory, or NULL on failure. - * - * Side effects: - * Accesses the native filesystem. Makes a directory. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclpCreateTemporaryDirectory( - Tcl_Obj *dirObj, - Tcl_Obj *basenameObj) -{ - Tcl_DString template, tmp; - const char *string; - -#define DEFAULT_TEMP_DIR_PREFIX "tcl" - - /* - * Build the template in writable memory from the user-supplied pieces and - * some defaults. - */ - - if (dirObj) { - string = TclGetString(dirObj); - Tcl_UtfToExternalDString(NULL, string, dirObj->length, &template); - } else { - Tcl_DStringInit(&template); - Tcl_DStringAppend(&template, DefaultTempDir(), -1); /* INTL: native */ - } - - if (Tcl_DStringValue(&template)[Tcl_DStringLength(&template) - 1] != '/') { - TclDStringAppendLiteral(&template, "/"); - } - - if (basenameObj) { - string = TclGetString(basenameObj); - if (basenameObj->length) { - Tcl_UtfToExternalDString(NULL, string, basenameObj->length, &tmp); - TclDStringAppendDString(&template, &tmp); - Tcl_DStringFree(&tmp); - } else { - TclDStringAppendLiteral(&template, DEFAULT_TEMP_DIR_PREFIX); - } - } else { - TclDStringAppendLiteral(&template, DEFAULT_TEMP_DIR_PREFIX); - } - - TclDStringAppendLiteral(&template, "_XXXXXX"); - - /* - * Make the temporary directory. - */ - - if (mkdtemp(Tcl_DStringValue(&template)) == NULL) { - Tcl_DStringFree(&template); - return NULL; - } - - /* - * The template has been updated. Tell the caller what it was. - */ - - Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&template), - Tcl_DStringLength(&template), &tmp); - Tcl_DStringFree(&template); - return TclDStringToObj(&tmp); -} #if defined(__CYGWIN__) static void StatError( @@ -2368,24 +2290,23 @@ static WCHAR * winPathFromObj( Tcl_Obj *fileName) { - size_t size; + int size; const char *native = Tcl_FSGetNativePath(fileName); WCHAR *winPath; size = cygwin_conv_path(1, native, NULL, 0); - winPath = Tcl_Alloc(size); + winPath = ckalloc(size); cygwin_conv_path(1, native, winPath, size); return winPath; } static const int attributeArray[] = { - 0x20, 0, 2, 0, 0, 1, 4 -}; + 0x20, 0, 2, 0, 0, 1, 4}; /* *---------------------------------------------------------------------- * * GetUnixFileAttributes @@ -2411,19 +2332,19 @@ { int fileAttributes; WCHAR *winPath = winPathFromObj(fileName); fileAttributes = GetFileAttributesW(winPath); - Tcl_Free(winPath); + ckfree(winPath); if (fileAttributes == -1) { StatError(interp, fileName); return TCL_ERROR; } - *attributePtrPtr = Tcl_NewWideIntObj( - (fileAttributes & attributeArray[objIndex]) != 0); + TclNewIntObj(*attributePtrPtr, (fileAttributes&attributeArray[objIndex])!=0); + return TCL_OK; } /* *--------------------------------------------------------------------------- @@ -2458,11 +2379,11 @@ winPath = winPathFromObj(fileName); fileAttributes = old = GetFileAttributesW(winPath); if (fileAttributes == -1) { - Tcl_Free(winPath); + ckfree(winPath); StatError(interp, fileName); return TCL_ERROR; } if (yesNo) { @@ -2471,16 +2392,16 @@ fileAttributes &= ~attributeArray[objIndex]; } if ((fileAttributes != old) && !SetFileAttributesW(winPath, fileAttributes)) { - Tcl_Free(winPath); + ckfree(winPath); StatError(interp, fileName); return TCL_ERROR; } - Tcl_Free(winPath); + ckfree(winPath); return TCL_OK; } #elif defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) /* *---------------------------------------------------------------------- @@ -2518,11 +2439,12 @@ TclGetString(fileName), Tcl_PosixError(interp))); } return TCL_ERROR; } - *attributePtrPtr = Tcl_NewWideIntObj((statBuf.st_flags & UF_IMMUTABLE) != 0); + *attributePtrPtr = Tcl_NewBooleanObj(statBuf.st_flags&UF_IMMUTABLE); + return TCL_OK; } /* *--------------------------------------------------------------------------- Index: unix/tclUnixFile.c ================================================================== --- unix/tclUnixFile.c +++ unix/tclUnixFile.c @@ -39,11 +39,11 @@ const char *argv0) /* The value of the application's argv[0] * (native). */ { Tcl_Encoding encoding; #ifdef __CYGWIN__ - size_t length; + int length; char buf[PATH_MAX * 2]; char name[PATH_MAX * TCL_UTF_MAX + 1]; GetModuleFileNameW(NULL, buf, PATH_MAX); cygwin_conv_path(3, buf, name, PATH_MAX); length = strlen(name); @@ -96,11 +96,11 @@ * Search through all the directories named in the PATH variable to see if * argv[0] is in one of them. If so, use that file name. */ while (1) { - while (TclIsSpaceProc(*p)) { + while (TclIsSpaceProcM(*p)) { p++; } name = p; while ((*p != ':') && (*p != 0)) { p++; @@ -260,18 +260,18 @@ Tcl_DecrRefCount(fileNamePtr); } else { TclDIR *d; Tcl_DirEntry *entryPtr; const char *dirName; - size_t dirLength, nativeDirLen; + int dirLength, nativeDirLen; int matchHidden, matchHiddenPat; Tcl_StatBuf statBuf; Tcl_DString ds; /* native encoding of dir */ Tcl_DString dsOrig; /* utf-8 encoding of dir */ Tcl_DStringInit(&dsOrig); - dirName = TclGetStringFromObj(fileNamePtr, &dirLength); + dirName = Tcl_GetStringFromObj(fileNamePtr, &dirLength); Tcl_DStringAppend(&dsOrig, dirName, dirLength); /* * Make sure that the directory part of the name really is a * directory. If the directory name is "", use the name "." instead, @@ -717,11 +717,11 @@ return NULL; } #endif /* USEGETWD */ if ((clientData == NULL) || strcmp(buffer, (const char *) clientData)) { - char *newCd = Tcl_Alloc(strlen(buffer) + 1); + char *newCd = ckalloc(strlen(buffer) + 1); strcpy(newCd, buffer); return newCd; } @@ -935,13 +935,13 @@ /* * Check symbolic link flag first, since we prefer to create these. */ if (linkAction & TCL_CREATE_SYMBOLIC_LINK) { + int targetLen; Tcl_DString ds; Tcl_Obj *transPtr; - size_t length; /* * Now we don't want to link to the absolute, normalized path. * Relative links are quite acceptable (but links to ~user are not * -- these must be expanded first). @@ -949,12 +949,12 @@ transPtr = Tcl_FSGetTranslatedPath(NULL, toPtr); if (transPtr == NULL) { return NULL; } - target = TclGetStringFromObj(transPtr, &length); - target = Tcl_UtfToExternalDString(NULL, target, length, &ds); + target = Tcl_GetStringFromObj(transPtr, &targetLen); + target = Tcl_UtfToExternalDString(NULL, target, targetLen, &ds); Tcl_DecrRefCount(transPtr); if (symlink(target, src) != 0) { toPtr = NULL; } @@ -1078,11 +1078,11 @@ { char *nativePathPtr; const char *str; Tcl_DString ds; Tcl_Obj *validPathPtr; - size_t len; + int len; if (TclFSCwdIsNative()) { /* * The cwd is native, which means we can use the translated path * without worrying about normalization (this will also usually be @@ -1103,21 +1103,21 @@ return NULL; } Tcl_IncrRefCount(validPathPtr); } - str = TclGetStringFromObj(validPathPtr, &len); + str = Tcl_GetStringFromObj(validPathPtr, &len); Tcl_UtfToExternalDString(NULL, str, len, &ds); len = Tcl_DStringLength(&ds) + sizeof(char); if (strlen(Tcl_DStringValue(&ds)) < len - sizeof(char)) { /* See bug [3118489]: NUL in filenames */ Tcl_DecrRefCount(validPathPtr); Tcl_DStringFree(&ds); return NULL; } Tcl_DecrRefCount(validPathPtr); - nativePathPtr = Tcl_Alloc(len); + nativePathPtr = ckalloc(len); memcpy(nativePathPtr, Tcl_DStringValue(&ds), len); Tcl_DStringFree(&ds); return nativePathPtr; } @@ -1154,11 +1154,11 @@ * ASCII representation when running on Unix. */ len = (strlen((const char*) clientData) + 1) * sizeof(char); - copy = Tcl_Alloc(len); + copy = ckalloc(len); memcpy(copy, clientData, len); return copy; } /* Index: unix/tclUnixInit.c ================================================================== --- unix/tclUnixInit.c +++ unix/tclUnixInit.c @@ -31,47 +31,56 @@ # include # endif #endif #ifdef __CYGWIN__ +#ifdef __cplusplus +extern "C" { +#endif +#ifdef __clang__ +#pragma clang diagnostic ignored "-Wignored-attributes" +#endif DLLIMPORT extern __stdcall unsigned char GetVersionExW(void *); DLLIMPORT extern __stdcall void *GetModuleHandleW(const void *); DLLIMPORT extern __stdcall void FreeLibrary(void *); DLLIMPORT extern __stdcall void *GetProcAddress(void *, const char *); DLLIMPORT extern __stdcall void GetSystemInfo(void *); +#ifdef __cplusplus +} +#endif #define NUMPROCESSORS 11 static const char *const processors[NUMPROCESSORS] = { "intel", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil", "amd64", "ia32_on_win64" }; typedef struct { union { - DWORD dwOemId; + unsigned int dwOemId; struct { int wProcessorArchitecture; int wReserved; }; }; - DWORD dwPageSize; + unsigned int dwPageSize; void *lpMinimumApplicationAddress; void *lpMaximumApplicationAddress; void *dwActiveProcessorMask; - DWORD dwNumberOfProcessors; - DWORD dwProcessorType; - DWORD dwAllocationGranularity; + unsigned int dwNumberOfProcessors; + unsigned int dwProcessorType; + unsigned int dwAllocationGranularity; int wProcessorLevel; int wProcessorRevision; } SYSTEM_INFO; typedef struct { - DWORD dwOSVersionInfoSize; - DWORD dwMajorVersion; - DWORD dwMinorVersion; - DWORD dwBuildNumber; - DWORD dwPlatformId; + unsigned int dwOSVersionInfoSize; + unsigned int dwMajorVersion; + unsigned int dwMinorVersion; + unsigned int dwBuildNumber; + unsigned int dwPlatformId; wchar_t szCSDVersion[128]; } OSVERSIONINFOW; #endif #ifdef HAVE_COREFOUNDATION @@ -124,13 +133,13 @@ * "bug fixes" that have been added to deal with the wide variability seen * among existing platforms. */ static const LocaleTable localeTable[] = { - {"", "iso8859-1"}, - {"ansi-1251", "cp1251"}, - {"ansi_x3.4-1968", "iso8859-1"}, + {"", "iso8859-1"}, + {"ansi-1251", "cp1251"}, + {"ansi_x3.4-1968", "iso8859-1"}, {"ascii", "ascii"}, {"big5", "big5"}, {"cp1250", "cp1250"}, {"cp1251", "cp1251"}, {"cp1252", "cp1252"}, @@ -163,65 +172,65 @@ {"dingbats", "dingbats"}, {"ebcdic", "ebcdic"}, {"euc-cn", "euc-cn"}, {"euc-jp", "euc-jp"}, {"euc-kr", "euc-kr"}, - {"eucjp", "euc-jp"}, - {"euckr", "euc-kr"}, - {"euctw", "euc-cn"}, + {"eucjp", "euc-jp"}, + {"euckr", "euc-kr"}, + {"euctw", "euc-cn"}, {"gb12345", "gb12345"}, {"gb1988", "gb1988"}, {"gb2312", "gb2312"}, - {"gb2312-1980", "gb2312"}, + {"gb2312-1980", "gb2312"}, {"gb2312-raw", "gb2312-raw"}, - {"greek8", "cp869"}, - {"ibm1250", "cp1250"}, - {"ibm1251", "cp1251"}, - {"ibm1252", "cp1252"}, - {"ibm1253", "cp1253"}, - {"ibm1254", "cp1254"}, - {"ibm1255", "cp1255"}, - {"ibm1256", "cp1256"}, - {"ibm1257", "cp1257"}, - {"ibm1258", "cp1258"}, - {"ibm437", "cp437"}, - {"ibm737", "cp737"}, - {"ibm775", "cp775"}, - {"ibm850", "cp850"}, - {"ibm852", "cp852"}, - {"ibm855", "cp855"}, - {"ibm857", "cp857"}, - {"ibm860", "cp860"}, - {"ibm861", "cp861"}, - {"ibm862", "cp862"}, - {"ibm863", "cp863"}, - {"ibm864", "cp864"}, - {"ibm865", "cp865"}, - {"ibm866", "cp866"}, - {"ibm869", "cp869"}, - {"ibm874", "cp874"}, - {"ibm932", "cp932"}, - {"ibm936", "cp936"}, - {"ibm949", "cp949"}, - {"ibm950", "cp950"}, - {"iso-2022", "iso2022"}, - {"iso-2022-jp", "iso2022-jp"}, - {"iso-2022-kr", "iso2022-kr"}, - {"iso-8859-1", "iso8859-1"}, - {"iso-8859-10", "iso8859-10"}, - {"iso-8859-13", "iso8859-13"}, - {"iso-8859-14", "iso8859-14"}, - {"iso-8859-15", "iso8859-15"}, - {"iso-8859-16", "iso8859-16"}, - {"iso-8859-2", "iso8859-2"}, - {"iso-8859-3", "iso8859-3"}, - {"iso-8859-4", "iso8859-4"}, - {"iso-8859-5", "iso8859-5"}, - {"iso-8859-6", "iso8859-6"}, - {"iso-8859-7", "iso8859-7"}, - {"iso-8859-8", "iso8859-8"}, - {"iso-8859-9", "iso8859-9"}, + {"greek8", "cp869"}, + {"ibm1250", "cp1250"}, + {"ibm1251", "cp1251"}, + {"ibm1252", "cp1252"}, + {"ibm1253", "cp1253"}, + {"ibm1254", "cp1254"}, + {"ibm1255", "cp1255"}, + {"ibm1256", "cp1256"}, + {"ibm1257", "cp1257"}, + {"ibm1258", "cp1258"}, + {"ibm437", "cp437"}, + {"ibm737", "cp737"}, + {"ibm775", "cp775"}, + {"ibm850", "cp850"}, + {"ibm852", "cp852"}, + {"ibm855", "cp855"}, + {"ibm857", "cp857"}, + {"ibm860", "cp860"}, + {"ibm861", "cp861"}, + {"ibm862", "cp862"}, + {"ibm863", "cp863"}, + {"ibm864", "cp864"}, + {"ibm865", "cp865"}, + {"ibm866", "cp866"}, + {"ibm869", "cp869"}, + {"ibm874", "cp874"}, + {"ibm932", "cp932"}, + {"ibm936", "cp936"}, + {"ibm949", "cp949"}, + {"ibm950", "cp950"}, + {"iso-2022", "iso2022"}, + {"iso-2022-jp", "iso2022-jp"}, + {"iso-2022-kr", "iso2022-kr"}, + {"iso-8859-1", "iso8859-1"}, + {"iso-8859-10", "iso8859-10"}, + {"iso-8859-13", "iso8859-13"}, + {"iso-8859-14", "iso8859-14"}, + {"iso-8859-15", "iso8859-15"}, + {"iso-8859-16", "iso8859-16"}, + {"iso-8859-2", "iso8859-2"}, + {"iso-8859-3", "iso8859-3"}, + {"iso-8859-4", "iso8859-4"}, + {"iso-8859-5", "iso8859-5"}, + {"iso-8859-6", "iso8859-6"}, + {"iso-8859-7", "iso8859-7"}, + {"iso-8859-8", "iso8859-8"}, + {"iso-8859-9", "iso8859-9"}, {"iso2022", "iso2022"}, {"iso2022-jp", "iso2022-jp"}, {"iso2022-kr", "iso2022-kr"}, {"iso8859-1", "iso8859-1"}, {"iso8859-10", "iso8859-10"}, @@ -235,51 +244,51 @@ {"iso8859-5", "iso8859-5"}, {"iso8859-6", "iso8859-6"}, {"iso8859-7", "iso8859-7"}, {"iso8859-8", "iso8859-8"}, {"iso8859-9", "iso8859-9"}, - {"iso88591", "iso8859-1"}, - {"iso885915", "iso8859-15"}, - {"iso88592", "iso8859-2"}, - {"iso88595", "iso8859-5"}, - {"iso88596", "iso8859-6"}, - {"iso88597", "iso8859-7"}, - {"iso88598", "iso8859-8"}, - {"iso88599", "iso8859-9"}, -#ifdef hpux - {"ja", "shiftjis"}, -#else - {"ja", "euc-jp"}, -#endif - {"ja_jp", "euc-jp"}, - {"ja_jp.euc", "euc-jp"}, - {"ja_jp.eucjp", "euc-jp"}, - {"ja_jp.jis", "iso2022-jp"}, - {"ja_jp.mscode", "shiftjis"}, - {"ja_jp.sjis", "shiftjis"}, - {"ja_jp.ujis", "euc-jp"}, - {"japan", "euc-jp"}, -#ifdef hpux - {"japanese", "shiftjis"}, -#else - {"japanese", "euc-jp"}, -#endif - {"japanese-sjis", "shiftjis"}, - {"japanese-ujis", "euc-jp"}, - {"japanese.euc", "euc-jp"}, - {"japanese.sjis", "shiftjis"}, + {"iso88591", "iso8859-1"}, + {"iso885915", "iso8859-15"}, + {"iso88592", "iso8859-2"}, + {"iso88595", "iso8859-5"}, + {"iso88596", "iso8859-6"}, + {"iso88597", "iso8859-7"}, + {"iso88598", "iso8859-8"}, + {"iso88599", "iso8859-9"}, +#ifdef hpux + {"ja", "shiftjis"}, +#else + {"ja", "euc-jp"}, +#endif + {"ja_jp", "euc-jp"}, + {"ja_jp.euc", "euc-jp"}, + {"ja_jp.eucjp", "euc-jp"}, + {"ja_jp.jis", "iso2022-jp"}, + {"ja_jp.mscode", "shiftjis"}, + {"ja_jp.sjis", "shiftjis"}, + {"ja_jp.ujis", "euc-jp"}, + {"japan", "euc-jp"}, +#ifdef hpux + {"japanese", "shiftjis"}, +#else + {"japanese", "euc-jp"}, +#endif + {"japanese-sjis", "shiftjis"}, + {"japanese-ujis", "euc-jp"}, + {"japanese.euc", "euc-jp"}, + {"japanese.sjis", "shiftjis"}, {"jis0201", "jis0201"}, {"jis0208", "jis0208"}, {"jis0212", "jis0212"}, - {"jp_jp", "shiftjis"}, - {"ko", "euc-kr"}, - {"ko_kr", "euc-kr"}, - {"ko_kr.euc", "euc-kr"}, - {"ko_kw.euckw", "euc-kr"}, + {"jp_jp", "shiftjis"}, + {"ko", "euc-kr"}, + {"ko_kr", "euc-kr"}, + {"ko_kr.euc", "euc-kr"}, + {"ko_kw.euckw", "euc-kr"}, {"koi8-r", "koi8-r"}, {"koi8-u", "koi8-u"}, - {"korean", "euc-kr"}, + {"korean", "euc-kr"}, {"ksc5601", "ksc5601"}, {"maccenteuro", "macCentEuro"}, {"maccroatian", "macCroatian"}, {"maccyrillic", "macCyrillic"}, {"macdingbats", "macDingbats"}, @@ -289,36 +298,36 @@ {"macroman", "macRoman"}, {"macromania", "macRomania"}, {"macthai", "macThai"}, {"macturkish", "macTurkish"}, {"macukraine", "macUkraine"}, - {"roman8", "iso8859-1"}, - {"ru", "iso8859-5"}, - {"ru_ru", "iso8859-5"}, - {"ru_su", "iso8859-5"}, + {"roman8", "iso8859-1"}, + {"ru", "iso8859-5"}, + {"ru_ru", "iso8859-5"}, + {"ru_su", "iso8859-5"}, {"shiftjis", "shiftjis"}, - {"sjis", "shiftjis"}, + {"sjis", "shiftjis"}, {"symbol", "symbol"}, {"tis-620", "tis-620"}, - {"tis620", "tis-620"}, - {"turkish8", "cp857"}, - {"utf8", "utf-8"}, - {"zh", "cp936"}, - {"zh_cn.gb2312", "euc-cn"}, - {"zh_cn.gbk", "euc-cn"}, - {"zh_cz.gb2312", "euc-cn"}, - {"zh_tw", "euc-tw"}, - {"zh_tw.big5", "big5"}, + {"tis620", "tis-620"}, + {"turkish8", "cp857"}, + {"utf8", "utf-8"}, + {"zh", "cp936"}, + {"zh_cn.gb2312", "euc-cn"}, + {"zh_cn.gbk", "euc-cn"}, + {"zh_cz.gb2312", "euc-cn"}, + {"zh_tw", "euc-tw"}, + {"zh_tw.big5", "big5"}, }; #ifdef HAVE_COREFOUNDATION static int MacOSXGetLibraryPath(Tcl_Interp *interp, int maxPathLen, char *tclLibPath); #endif /* HAVE_COREFOUNDATION */ #if defined(__APPLE__) && (defined(TCL_LOAD_FROM_MEMORY) || ( \ defined(MAC_OS_X_VERSION_MIN_REQUIRED) && ( \ - (TCL_THREADS && MAC_OS_X_VERSION_MIN_REQUIRED < 1030) || \ + (defined(TCL_THREADS) && MAC_OS_X_VERSION_MIN_REQUIRED < 1030) || \ (defined(__LP64__) && MAC_OS_X_VERSION_MIN_REQUIRED < 1050) || \ (defined(HAVE_COREFOUNDATION) && MAC_OS_X_VERSION_MIN_REQUIRED < 1050)\ ))) /* * Need to check Darwin release at runtime in tclUnixFCmd.c and tclLoadDyld.c: @@ -333,11 +342,11 @@ /* *--------------------------------------------------------------------------- * * TclpInitPlatform -- * - * Initialize all the platform-dependant things like signals and + * Initialize all the platform-dependent things like signals and * floating-point error handling. * * Called at process initialization time. * * Results: @@ -384,10 +393,18 @@ #ifdef SIGPIPE (void) signal(SIGPIPE, SIG_IGN); #endif /* SIGPIPE */ #if defined(__FreeBSD__) && defined(__GNUC__) + /* + * Adjust the rounding mode to be more conventional. Note that FreeBSD + * only provides the __fpsetreg() used by the following two for the GNU + * Compiler. When using, say, Intel's icc they break. (Partially based on + * patch in BSD ports system from root@celsius.bychok.com) + */ + + fpsetround(FP_RN); (void) fpsetmask(0L); #endif #if defined(__bsdi__) && (_BSDI_VERSION > 199501) /* @@ -446,19 +463,19 @@ */ void TclpInitLibraryPath( char **valuePtr, - size_t *lengthPtr, + int *lengthPtr, Tcl_Encoding *encodingPtr) { #define LIBRARY_SIZE 32 Tcl_Obj *pathPtr, *objPtr; const char *str; Tcl_DString buffer; - pathPtr = Tcl_NewObj(); + TclNewObj(pathPtr); /* * Look for the library relative to the TCL_LIBRARY env variable. If the * last dirname in the TCL_LIBRARY path does not match the last dirname in * the installLib variable, use the last dir name of installLib in @@ -503,11 +520,11 @@ pathv[pathc - 1] = installLib + 4; str = Tcl_JoinPath(pathc, pathv, &ds); Tcl_ListObjAppendElement(NULL, pathPtr, TclDStringToObj(&ds)); } - Tcl_Free(pathv); + ckfree(pathv); } /* * Finally, look for the library relative to the compiled-in path. This is * needed when users install Tcl with an exec-prefix that is different @@ -535,12 +552,12 @@ } } Tcl_DStringFree(&buffer); *encodingPtr = Tcl_GetEncoding(NULL, NULL); - str = TclGetStringFromObj(pathPtr, lengthPtr); - *valuePtr = Tcl_Alloc(*lengthPtr + 1); + str = Tcl_GetStringFromObj(pathPtr, lengthPtr); + *valuePtr = (char *)ckalloc(*lengthPtr + 1); memcpy(*valuePtr, str, *lengthPtr + 1); Tcl_DecrRefCount(pathPtr); } /* @@ -864,11 +881,11 @@ unameOK = 0; #ifdef __CYGWIN__ unameOK = 1; if (!osInfoInitialized) { - HANDLE handle = GetModuleHandleW(L"NTDLL"); + void *handle = GetModuleHandleW(L"NTDLL"); int(__stdcall *getversion)(void *) = (int(__stdcall *)(void *))GetProcAddress(handle, "RtlGetVersion"); osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW); if (!getversion || getversion(&osInfo)) { GetVersionExW(&osInfo); @@ -876,11 +893,12 @@ osInfoInitialized = 1; } GetSystemInfo(&sysInfo); - Tcl_SetVar2(interp, "tcl_platform", "os", "Windows NT", TCL_GLOBAL_ONLY); + Tcl_SetVar2(interp, "tcl_platform", "os", + "Windows NT", TCL_GLOBAL_ONLY); sprintf(buffer, "%d.%d", osInfo.dwMajorVersion, osInfo.dwMinorVersion); Tcl_SetVar2(interp, "tcl_platform", "osVersion", buffer, TCL_GLOBAL_ONLY); if (sysInfo.wProcessorArchitecture < NUMPROCESSORS) { Tcl_SetVar2(interp, "tcl_platform", "machine", processors[sysInfo.wProcessorArchitecture], @@ -978,31 +996,31 @@ * Locate the entry in environ for a given name. On Unix this routine is * case sensetive, on Windows this matches mixed case. * * Results: * The return value is the index in environ of an entry with the name - * "name", or TCL_IO_FAILURE if there is no such entry. The integer at *lengthPtr is + * "name", or -1 if there is no such entry. The integer at *lengthPtr is * filled in with the length of name (if a matching entry is found) or * the length of the environ array (if no matching entry is found). * * Side effects: * None. * *---------------------------------------------------------------------- */ -size_t +int TclpFindVariable( const char *name, /* Name of desired environment variable * (native). */ - size_t *lengthPtr) /* Used to return length of name (for + int *lengthPtr) /* Used to return length of name (for * successful searches) or number of non-NULL * entries in environ (for unsuccessful * searches). */ { - size_t i, result = TCL_IO_FAILURE; - register const char *env, *p1, *p2; + int i, result = -1; + const char *env, *p1, *p2; Tcl_DString envString; Tcl_DStringInit(&envString); for (i = 0, env = environ[i]; env != NULL; i++, env = environ[i]) { p1 = Tcl_ExternalToUtfDString(NULL, env, -1, &envString); Index: unix/tclUnixNotfy.c ================================================================== --- unix/tclUnixNotfy.c +++ unix/tclUnixNotfy.c @@ -1,43 +1,278 @@ +#define AT_FORK_INIT_VALUE 0 +#define RESET_ATFORK_MUTEX 1 /* - * tclUnixNotfy.c -- + * tclUnixNotify.c -- * - * This file contains subroutines shared by all notifier backend - * implementations on *nix platforms. + * This file contains the implementation of the select()-based + * Unix-specific notifier, which is the lowest-level part of the Tcl + * event loop. This file works together with generic/tclNotify.c. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. - * Copyright (c) 2016 Lucio Andrés Illanes Albornoz * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#include #include "tclInt.h" +#ifndef HAVE_COREFOUNDATION /* Darwin/Mac OS X CoreFoundation notifier is + * in tclMacOSXNotify.c */ +#include + +/* + * This structure is used to keep track of the notifier info for a registered + * file. + */ + +typedef struct FileHandler { + int fd; + int mask; /* Mask of desired events: TCL_READABLE, + * etc. */ + 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. */ + 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 + * handlers are ready to fire. + */ + +typedef struct FileHandlerEvent { + Tcl_Event header; /* Information that is standard for all + * events. */ + int fd; /* File descriptor that is ready. Used to find + * the FileHandler structure for the file + * (can't point directly to the FileHandler + * structure because it could go away while + * the event is queued). */ +} FileHandlerEvent; + +/* + * The following structure contains a set of select() masks to track readable, + * writable, and exception conditions. + */ + +typedef struct SelectMasks { + fd_set readable; + fd_set writable; + fd_set exception; +} SelectMasks; + +/* + * The following static structure contains the state information for the + * select based implementation of the Tcl notifier. One of these structures is + * created for each thread that is using the notifier. + */ + +typedef struct ThreadSpecificData { + FileHandler *firstFileHandlerPtr; + /* Pointer to head of file handler list. */ + SelectMasks checkMasks; /* This structure is used to build up the + * masks to be used in the next call to + * select. Bits are set in response to calls + * to Tcl_CreateFileHandler. */ + SelectMasks readyMasks; /* This array reflects the readable/writable + * conditions that were found to exist by the + * last call to select. */ + int numFdBits; /* Number of valid bits in checkMasks (one + * more than highest fd for which + * Tcl_WatchFile has been called). */ +#ifdef TCL_THREADS + int onList; /* True if it is in this list */ + unsigned int pollState; /* pollState is used to implement a polling + * handshake between each thread and the + * notifier thread. Bits defined below. */ + struct ThreadSpecificData *nextPtr, *prevPtr; + /* All threads that are currently waiting on + * an event have their ThreadSpecificData + * structure on a doubly-linked listed formed + * from these pointers. You must hold the + * notifierMutex lock before accessing these + * fields. */ +#ifdef __CYGWIN__ + void *event; /* Any other thread alerts a notifier that an + * event is ready to be processed by sending + * this event. */ + void *hwnd; /* Messaging window. */ +#else /* !__CYGWIN__ */ + pthread_cond_t waitCV; /* Any other thread alerts a notifier that an + * event is ready to be processed by signaling + * this condition variable. */ +#endif /* __CYGWIN__ */ + int waitCVinitialized; /* Variable to flag initialization of the + * structure. */ + int eventReady; /* True if an event is ready to be processed. + * Used as condition flag together with waitCV + * above. */ +#endif /* TCL_THREADS */ +} ThreadSpecificData; + +static Tcl_ThreadDataKey dataKey; + +#ifdef TCL_THREADS +/* + * The following static indicates the number of threads that have initialized + * notifiers. + * + * You must hold the notifierMutex lock before accessing this variable. + */ + +static int notifierCount = 0; + +/* + * The following variable points to the head of a doubly-linked list of + * ThreadSpecificData structures for all threads that are currently waiting on + * an event. + * + * You must hold the notifierMutex lock before accessing this list. + */ + +static ThreadSpecificData *waitingListPtr = NULL; + +/* + * The notifier thread spends all its time in select() waiting for a file + * descriptor associated with one of the threads on the waitingListPtr list to + * do something interesting. But if the contents of the waitingListPtr list + * ever changes, we need to wake up and restart the select() system call. You + * can wake up the notifier thread by writing a single byte to the file + * descriptor defined below. This file descriptor is the input-end of a pipe + * and the notifier thread is listening for data on the output-end of the same + * pipe. Hence writing to this file descriptor will cause the select() system + * call to return and wake up the notifier thread. + * + * You must hold the notifierMutex lock before writing to the pipe. + */ + +static int triggerPipe = -1; + +/* + * The notifierMutex locks access to all of the global notifier state. + */ + +static pthread_mutex_t notifierInitMutex = PTHREAD_MUTEX_INITIALIZER; +static pthread_mutex_t notifierMutex = PTHREAD_MUTEX_INITIALIZER; +/* + * The following static indicates if the notifier thread is running. + * + * You must hold the notifierInitMutex before accessing this variable. + */ + +static int notifierThreadRunning = 0; + +/* + * The notifier thread signals the notifierCV when it has finished + * initializing the triggerPipe and right before the notifier thread + * terminates. + */ + +static pthread_cond_t notifierCV = PTHREAD_COND_INITIALIZER; + +/* + * The pollState bits: + * + * POLL_WANT is set by each thread before it waits on its condition variable. + * It is checked by the notifier before it does select. + * + * POLL_DONE is set by the notifier if it goes into select after seeing + * POLL_WANT. The idea is to ensure it tries a select with the same bits + * the initial thread had set. + */ + +#define POLL_WANT 0x1 +#define POLL_DONE 0x2 + +/* + * This is the thread ID of the notifier thread that does select. + */ + +static Tcl_ThreadId notifierThread; +#endif /* TCL_THREADS */ /* * Static routines defined in this file. */ -static int FileHandlerEventProc(Tcl_Event *evPtr, int flags); -#if !TCL_THREADS -# undef NOTIFIER_EPOLL -# undef NOTIFIER_KQUEUE -# define NOTIFIER_SELECT -#elif !defined(NOTIFIER_EPOLL) && !defined(NOTIFIER_KQUEUE) -# define NOTIFIER_SELECT -static TCL_NORETURN void NotifierThreadProc(ClientData clientData); -# if defined(HAVE_PTHREAD_ATFORK) -static void AtForkChild(void); -# endif /* HAVE_PTHREAD_ATFORK */ - +#ifdef TCL_THREADS +static void NotifierThreadProc(void *clientData); +#if defined(HAVE_PTHREAD_ATFORK) +static int atForkInit = AT_FORK_INIT_VALUE; +static void AtForkPrepare(void); +static void AtForkParent(void); +static void AtForkChild(void); +#endif /* HAVE_PTHREAD_ATFORK */ +#endif /* TCL_THREADS */ +static int FileHandlerEventProc(Tcl_Event *evPtr, int flags); + +/* + * Import of Windows API when building threaded with Cygwin. + */ + +#if defined(TCL_THREADS) && defined(__CYGWIN__) +typedef struct { + void *hwnd; /* Messaging window. */ + unsigned int *message; /* Message payload. */ + size_t wParam; /* Event-specific "word" parameter. */ + size_t lParam; /* Event-specific "long" parameter. */ + int time; /* Event timestamp. */ + int x; /* Event location (where meaningful). */ + int y; + int lPrivate; +} MSG; + +typedef struct { + unsigned int style; + void *lpfnWndProc; + int cbClsExtra; + int cbWndExtra; + void *hInstance; + void *hIcon; + void *hCursor; + void *hbrBackground; + const void *lpszMenuName; + const void *lpszClassName; +} WNDCLASSW; + +extern void __stdcall CloseHandle(void *); +extern void *__stdcall CreateEventW(void *, unsigned char, unsigned char, + void *); +extern void * __stdcall CreateWindowExW(void *, const void *, const void *, + unsigned int, int, int, int, int, void *, void *, void *, void *); +extern unsigned int __stdcall DefWindowProcW(void *, int, void *, void *); +extern unsigned char __stdcall DestroyWindow(void *); +extern int __stdcall DispatchMessageW(const MSG *); +extern unsigned char __stdcall GetMessageW(MSG *, void *, int, int); +extern void __stdcall MsgWaitForMultipleObjects(unsigned int, void *, + unsigned char, unsigned int, unsigned int); +extern unsigned char __stdcall PeekMessageW(MSG *, void *, int, int, int); +extern unsigned char __stdcall PostMessageW(void *, unsigned int, void *, + void *); +extern void __stdcall PostQuitMessage(int); +extern void *__stdcall RegisterClassW(const WNDCLASSW *); +extern unsigned char __stdcall ResetEvent(void *); +extern unsigned char __stdcall TranslateMessage(const MSG *); + +/* + * Threaded-cygwin specific constants and functions in this file: + */ + +static const wchar_t *NotfyClassName = L"TclNotifier"; +static unsigned int __stdcall NotifierProc(void *hwnd, unsigned int message, + void *wParam, void *lParam); +#endif /* TCL_THREADS && __CYGWIN__ */ + +#if TCL_THREADS /* *---------------------------------------------------------------------- * * StartNotifierThread -- * - * Start a notifier thread and wait for the notifier pipe to be created. + * Start a notfier thread and wait for the notifier pipe to be created. * * Results: * None. * * Side effects: @@ -69,11 +304,169 @@ notifierThreadRunning = 1; } pthread_mutex_unlock(¬ifierInitMutex); } } -#endif /* NOTIFIER_SELECT */ +#endif /* TCL_THREADS */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_InitNotifier -- + * + * Initializes the platform specific notifier state. + * + * Results: + * Returns a handle to the notifier state for this thread. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void * +Tcl_InitNotifier(void) +{ + if (tclNotifierHooks.initNotifierProc) { + return tclNotifierHooks.initNotifierProc(); + } else { + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + +#ifdef TCL_THREADS + tsdPtr->eventReady = 0; + + /* + * Initialize thread specific condition variable for this thread. + */ + if (tsdPtr->waitCVinitialized == 0) { +#ifdef __CYGWIN__ + WNDCLASSW clazz; + + clazz.style = 0; + clazz.cbClsExtra = 0; + clazz.cbWndExtra = 0; + clazz.hInstance = TclWinGetTclInstance(); + clazz.hbrBackground = NULL; + clazz.lpszMenuName = NULL; + clazz.lpszClassName = NotfyClassName; + clazz.lpfnWndProc = (void *)NotifierProc; + clazz.hIcon = NULL; + clazz.hCursor = NULL; + + RegisterClassW(&clazz); + tsdPtr->hwnd = CreateWindowExW(NULL, clazz.lpszClassName, + clazz.lpszClassName, 0, 0, 0, 0, 0, NULL, NULL, + clazz.hInstance, NULL); + tsdPtr->event = CreateEventW(NULL, 1 /* manual */, + 0 /* !signaled */, NULL); +#else + pthread_cond_init(&tsdPtr->waitCV, NULL); +#endif /* __CYGWIN__ */ + tsdPtr->waitCVinitialized = 1; + } + + pthread_mutex_lock(¬ifierInitMutex); +#if defined(HAVE_PTHREAD_ATFORK) + /* + * Install pthread_atfork handlers to clean up the notifier in the + * child of a fork. + */ + + if (!atForkInit) { + int result = pthread_atfork(AtForkPrepare, AtForkParent, AtForkChild); + + if (result) { + Tcl_Panic("Tcl_InitNotifier: pthread_atfork failed"); + } + atForkInit = 1; + } +#endif /* HAVE_PTHREAD_ATFORK */ + + notifierCount++; + pthread_mutex_unlock(¬ifierInitMutex); + +#endif /* TCL_THREADS */ + return tsdPtr; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FinalizeNotifier -- + * + * This function is called to cleanup the notifier state before a thread + * is terminated. + * + * Results: + * None. + * + * Side effects: + * May terminate the background notifier thread if this is the last + * notifier instance. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_FinalizeNotifier( + void *clientData) +{ + if (tclNotifierHooks.finalizeNotifierProc) { + tclNotifierHooks.finalizeNotifierProc(clientData); + return; + } else { +#ifdef TCL_THREADS + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + pthread_mutex_lock(¬ifierInitMutex); + notifierCount--; + + /* + * If this is the last thread to use the notifier, close the notifier + * pipe and wait for the background thread to terminate. + */ + + if (notifierCount == 0 && triggerPipe != -1) { + if (write(triggerPipe, "q", 1) != 1) { + Tcl_Panic("Tcl_FinalizeNotifier: %s", + "unable to write 'q' to triggerPipe"); + } + close(triggerPipe); + pthread_mutex_lock(¬ifierMutex); + while(triggerPipe != -1) { + pthread_cond_wait(¬ifierCV, ¬ifierMutex); + } + pthread_mutex_unlock(¬ifierMutex); + if (notifierThreadRunning) { + int result = pthread_join((pthread_t) notifierThread, NULL); + + if (result) { + Tcl_Panic("Tcl_FinalizeNotifier: %s", + "unable to join notifier thread"); + } + notifierThreadRunning = 0; + } + } + + /* + * Clean up any synchronization objects in the thread local storage. + */ + +#ifdef __CYGWIN__ + DestroyWindow(tsdPtr->hwnd); + CloseHandle(tsdPtr->event); +#else /* __CYGWIN__ */ + pthread_cond_destroy(&tsdPtr->waitCV); +#endif /* __CYGWIN__ */ + tsdPtr->waitCVinitialized = 0; + + pthread_mutex_unlock(¬ifierInitMutex); +#endif /* TCL_THREADS */ + } +} /* *---------------------------------------------------------------------- * * Tcl_AlertNotifier -- @@ -85,32 +478,25 @@ * * Results: * None. * * Side effects: - * select(2) notifier: - * signals the notifier condition variable for the specified - * notifier. - * epoll(7) notifier: - * write(2)s to the eventfd(2) of the specified thread. - * kqueue(2) notifier: - * write(2)s to the trigger pipe(2) of the specified thread. + * Signals the notifier condition variable for the specified notifier. * *---------------------------------------------------------------------- */ void Tcl_AlertNotifier( - ClientData clientData) + void *clientData) { if (tclNotifierHooks.alertNotifierProc) { tclNotifierHooks.alertNotifierProc(clientData); return; } else { -#ifdef NOTIFIER_SELECT -#if TCL_THREADS - ThreadSpecificData *tsdPtr = clientData; +#ifdef TCL_THREADS + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)clientData; pthread_mutex_lock(¬ifierMutex); tsdPtr->eventReady = 1; # ifdef __CYGWIN__ @@ -118,26 +504,10 @@ # else pthread_cond_broadcast(&tsdPtr->waitCV); # endif /* __CYGWIN__ */ pthread_mutex_unlock(¬ifierMutex); #endif /* TCL_THREADS */ -#else /* !NOTIFIER_SELECT */ - ThreadSpecificData *tsdPtr = clientData; -#if defined(NOTIFIER_EPOLL) && defined(HAVE_EVENTFD) - uint64_t eventFdVal = 1; - if (write(tsdPtr->triggerEventFd, &eventFdVal, - sizeof(eventFdVal)) != sizeof(eventFdVal)) { - Tcl_Panic("Tcl_AlertNotifier: unable to write to %p->triggerEventFd", - (void *)tsdPtr); - } -#else - if (write(tsdPtr->triggerPipe[1], "", 1) != 1) { - Tcl_Panic("Tcl_AlertNotifier: unable to write to %p->triggerPipe", - (void *)tsdPtr); - } -#endif /* NOTIFIER_EPOLL && HAVE_EVENTFD */ -#endif /* NOTIFIER_SELECT */ } } /* *---------------------------------------------------------------------- @@ -196,15 +566,177 @@ { if (tclNotifierHooks.serviceModeHookProc) { tclNotifierHooks.serviceModeHookProc(mode); return; } else if (mode == TCL_SERVICE_ALL) { -#ifdef NOTIFIER_SELECT #if TCL_THREADS StartNotifierThread("Tcl_ServiceModeHook"); #endif -#endif /* NOTIFIER_SELECT */ + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateFileHandler -- + * + * This function registers a file handler with the select notifier. + * + * Results: + * None. + * + * Side effects: + * Creates a new file handler structure. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_CreateFileHandler( + int fd, /* Handle of stream to watch. */ + int mask, /* OR'ed combination of TCL_READABLE, + * 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. */ +{ + if (tclNotifierHooks.createFileHandlerProc) { + tclNotifierHooks.createFileHandlerProc(fd, mask, proc, clientData); + return; + } else { + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + FileHandler *filePtr; + + for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL; + filePtr = filePtr->nextPtr) { + if (filePtr->fd == fd) { + break; + } + } + if (filePtr == NULL) { + filePtr = (FileHandler *)ckalloc(sizeof(FileHandler)); + filePtr->fd = fd; + filePtr->readyMask = 0; + filePtr->nextPtr = tsdPtr->firstFileHandlerPtr; + tsdPtr->firstFileHandlerPtr = filePtr; + } + filePtr->proc = proc; + filePtr->clientData = clientData; + filePtr->mask = mask; + + /* + * Update the check masks for this file. + */ + + if (mask & TCL_READABLE) { + FD_SET(fd, &tsdPtr->checkMasks.readable); + } else { + FD_CLR(fd, &tsdPtr->checkMasks.readable); + } + if (mask & TCL_WRITABLE) { + FD_SET(fd, &tsdPtr->checkMasks.writable); + } else { + FD_CLR(fd, &tsdPtr->checkMasks.writable); + } + if (mask & TCL_EXCEPTION) { + FD_SET(fd, &tsdPtr->checkMasks.exception); + } else { + FD_CLR(fd, &tsdPtr->checkMasks.exception); + } + if (tsdPtr->numFdBits <= fd) { + tsdPtr->numFdBits = fd+1; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteFileHandler -- + * + * Cancel a previously-arranged callback arrangement for a file. + * + * Results: + * None. + * + * Side effects: + * If a callback was previously registered on file, remove it. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteFileHandler( + int fd) /* Stream id for which to remove callback + * function. */ +{ + if (tclNotifierHooks.deleteFileHandlerProc) { + tclNotifierHooks.deleteFileHandlerProc(fd); + return; + } else { + FileHandler *filePtr, *prevPtr; + int i; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + /* + * Find the entry for the given file (and return if there isn't one). + */ + + for (prevPtr = NULL, filePtr = tsdPtr->firstFileHandlerPtr; ; + prevPtr = filePtr, filePtr = filePtr->nextPtr) { + if (filePtr == NULL) { + return; + } + if (filePtr->fd == fd) { + break; + } + } + + /* + * Update the check masks for this file. + */ + + if (filePtr->mask & TCL_READABLE) { + FD_CLR(fd, &tsdPtr->checkMasks.readable); + } + if (filePtr->mask & TCL_WRITABLE) { + FD_CLR(fd, &tsdPtr->checkMasks.writable); + } + if (filePtr->mask & TCL_EXCEPTION) { + FD_CLR(fd, &tsdPtr->checkMasks.exception); + } + + /* + * Find current max fd. + */ + + if (fd+1 == tsdPtr->numFdBits) { + int numFdBits = 0; + + for (i = fd-1; i >= 0; i--) { + if (FD_ISSET(i, &tsdPtr->checkMasks.readable) + || FD_ISSET(i, &tsdPtr->checkMasks.writable) + || FD_ISSET(i, &tsdPtr->checkMasks.exception)) { + numFdBits = i+1; + break; + } + } + tsdPtr->numFdBits = numFdBits; + } + + /* + * Clean up information in the callback record. + */ + + if (prevPtr == NULL) { + tsdPtr->firstFileHandlerPtr = filePtr->nextPtr; + } else { + prevPtr->nextPtr = filePtr->nextPtr; + } + ckfree(filePtr); } } /* *---------------------------------------------------------------------- @@ -278,63 +810,595 @@ break; } return 1; } -#ifdef NOTIFIER_SELECT -#if TCL_THREADS +#if defined(TCL_THREADS) && defined(__CYGWIN__) + +static unsigned int __stdcall +NotifierProc( + void *hwnd, + unsigned int message, + void *wParam, + void *lParam) +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + if (message != 1024) { + return DefWindowProcW(hwnd, message, wParam, lParam); + } + + /* + * Process all of the runnable events. + */ + + tsdPtr->eventReady = 1; + Tcl_ServiceAll(); + return 0; +} +#endif /* TCL_THREADS && __CYGWIN__ */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_WaitForEvent -- + * + * This function is called by Tcl_DoOneEvent to wait for new events on + * the message queue. If the block time is 0, then Tcl_WaitForEvent just + * polls without blocking. + * + * Results: + * Returns -1 if the select would block forever, otherwise returns 0. + * + * Side effects: + * Queues file events that are detected by the select. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_WaitForEvent( + const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ +{ + if (tclNotifierHooks.waitForEventProc) { + return tclNotifierHooks.waitForEventProc(timePtr); + } else { + FileHandler *filePtr; + int mask; + Tcl_Time vTime; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); +#ifdef TCL_THREADS + int waitForFiles; +# ifdef __CYGWIN__ + MSG msg; +# endif /* __CYGWIN__ */ +#else /* !TCL_THREADS */ + /* + * Impl. notes: timeout & timeoutPtr are used if, and only if threads + * are not enabled. They are the arguments for the regular select() + * used when the core is not thread-enabled. + */ + + struct timeval timeout, *timeoutPtr; + int numFound; +#endif /* TCL_THREADS */ + + /* + * Set up the timeout structure. Note that if there are no events to + * check for, we return with a negative result rather than blocking + * forever. + */ + + if (timePtr != NULL) { + /* + * TIP #233 (Virtualized Time). Is virtual time in effect? And do + * we actually have something to scale? If yes to both then we + * call the handler to do this scaling. + */ + + if (timePtr->sec != 0 || timePtr->usec != 0) { + vTime = *timePtr; + tclScaleTimeProcPtr(&vTime, tclTimeClientData); + timePtr = &vTime; + } +#ifndef TCL_THREADS + timeout.tv_sec = timePtr->sec; + timeout.tv_usec = timePtr->usec; + timeoutPtr = &timeout; + } else if (tsdPtr->numFdBits == 0) { + /* + * If there are no threads, no timeout, and no fds registered, + * then there are no events possible and we must avoid deadlock. + * Note that this is not entirely correct because there might be a + * signal that could interrupt the select call, but we don't + * handle that case if we aren't using threads. + */ + + return -1; + } else { + timeoutPtr = NULL; +#endif /* !TCL_THREADS */ + } + +#ifdef TCL_THREADS + /* + * Start notifier thread and place this thread on the list of + * interested threads, signal the notifier thread, and wait for a + * response or a timeout. + */ + StartNotifierThread("Tcl_WaitForEvent"); + + pthread_mutex_lock(¬ifierMutex); + + if (timePtr != NULL && timePtr->sec == 0 && (timePtr->usec == 0 +#if defined(__APPLE__) && defined(__LP64__) + /* + * On 64-bit Darwin, pthread_cond_timedwait() appears to have + * a bug that causes it to wait forever when passed an + * absolute time which has already been exceeded by the system + * time; as a workaround, when given a very brief timeout, + * just do a poll. [Bug 1457797] + */ + || timePtr->usec < 10 +#endif /* __APPLE__ && __LP64__ */ + )) { + /* + * Cannot emulate a polling select with a polling condition + * variable. Instead, pretend to wait for files and tell the + * notifier thread what we are doing. The notifier thread makes + * sure it goes through select with its select mask in the same + * state as ours currently is. We block until that happens. + */ + + waitForFiles = 1; + tsdPtr->pollState = POLL_WANT; + timePtr = NULL; + } else { + waitForFiles = (tsdPtr->numFdBits > 0); + tsdPtr->pollState = 0; + } + + if (waitForFiles) { + /* + * Add the ThreadSpecificData structure of this thread to the list + * of ThreadSpecificData structures of all threads that are + * waiting on file events. + */ + + tsdPtr->nextPtr = waitingListPtr; + if (waitingListPtr) { + waitingListPtr->prevPtr = tsdPtr; + } + tsdPtr->prevPtr = 0; + waitingListPtr = tsdPtr; + tsdPtr->onList = 1; + + if ((write(triggerPipe, "", 1) == -1) && (errno != EAGAIN)) { + Tcl_Panic("Tcl_WaitForEvent: %s", + "unable to write to triggerPipe"); + } + } + + FD_ZERO(&tsdPtr->readyMasks.readable); + FD_ZERO(&tsdPtr->readyMasks.writable); + FD_ZERO(&tsdPtr->readyMasks.exception); + + if (!tsdPtr->eventReady) { +#ifdef __CYGWIN__ + if (!PeekMessageW(&msg, NULL, 0, 0, 0)) { + unsigned int timeout; + + if (timePtr) { + timeout = timePtr->sec * 1000 + timePtr->usec / 1000; + } else { + timeout = 0xFFFFFFFF; + } + pthread_mutex_unlock(¬ifierMutex); + MsgWaitForMultipleObjects(1, &tsdPtr->event, 0, timeout, 1279); + pthread_mutex_lock(¬ifierMutex); + } +#else /* !__CYGWIN__ */ + if (timePtr != NULL) { + Tcl_Time now; + struct timespec ptime; + + Tcl_GetTime(&now); + ptime.tv_sec = timePtr->sec + now.sec + + (timePtr->usec + now.usec) / 1000000; + ptime.tv_nsec = 1000 * ((timePtr->usec + now.usec) % 1000000); + + pthread_cond_timedwait(&tsdPtr->waitCV, ¬ifierMutex, &ptime); + } else { + pthread_cond_wait(&tsdPtr->waitCV, ¬ifierMutex); + } +#endif /* __CYGWIN__ */ + } + tsdPtr->eventReady = 0; + +#ifdef __CYGWIN__ + while (PeekMessageW(&msg, NULL, 0, 0, 0)) { + /* + * Retrieve and dispatch the message. + */ + + unsigned int result = GetMessageW(&msg, NULL, 0, 0); + + if (result == 0) { + PostQuitMessage(msg.wParam); + /* What to do here? */ + } else if (result != (unsigned int) -1) { + TranslateMessage(&msg); + DispatchMessageW(&msg); + } + } + ResetEvent(tsdPtr->event); +#endif /* __CYGWIN__ */ + + if (waitForFiles && tsdPtr->onList) { + /* + * Remove the ThreadSpecificData structure of this thread from the + * waiting list. Alert the notifier thread to recompute its select + * masks - skipping this caused a hang when trying to close a pipe + * which the notifier thread was still doing a select on. + */ + + if (tsdPtr->prevPtr) { + tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr; + } else { + waitingListPtr = tsdPtr->nextPtr; + } + if (tsdPtr->nextPtr) { + tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr; + } + tsdPtr->nextPtr = tsdPtr->prevPtr = NULL; + tsdPtr->onList = 0; + if ((write(triggerPipe, "", 1) == -1) && (errno != EAGAIN)) { + Tcl_Panic("Tcl_WaitForEvent: %s", + "unable to write to triggerPipe"); + } + } +#else /* !TCL_THREADS */ + tsdPtr->readyMasks = tsdPtr->checkMasks; + numFound = select(tsdPtr->numFdBits, &tsdPtr->readyMasks.readable, + &tsdPtr->readyMasks.writable, &tsdPtr->readyMasks.exception, + timeoutPtr); + + /* + * Some systems don't clear the masks after an error, so we have to do + * it here. + */ + + if (numFound == -1) { + FD_ZERO(&tsdPtr->readyMasks.readable); + FD_ZERO(&tsdPtr->readyMasks.writable); + FD_ZERO(&tsdPtr->readyMasks.exception); + } +#endif /* TCL_THREADS */ + + /* + * Queue all detected file events before returning. + */ + + for (filePtr = tsdPtr->firstFileHandlerPtr; (filePtr != NULL); + filePtr = filePtr->nextPtr) { + mask = 0; + if (FD_ISSET(filePtr->fd, &tsdPtr->readyMasks.readable)) { + mask |= TCL_READABLE; + } + if (FD_ISSET(filePtr->fd, &tsdPtr->readyMasks.writable)) { + mask |= TCL_WRITABLE; + } + if (FD_ISSET(filePtr->fd, &tsdPtr->readyMasks.exception)) { + mask |= TCL_EXCEPTION; + } + + if (!mask) { + continue; + } + + /* + * Don't bother to queue an event if the mask was previously + * non-zero since an event must still be on the queue. + */ + + if (filePtr->readyMask == 0) { + FileHandlerEvent *fileEvPtr = + (FileHandlerEvent *)ckalloc(sizeof(FileHandlerEvent)); + + fileEvPtr->header.proc = FileHandlerEventProc; + fileEvPtr->fd = filePtr->fd; + Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL); + } + filePtr->readyMask = mask; + } +#ifdef TCL_THREADS + pthread_mutex_unlock(¬ifierMutex); +#endif /* TCL_THREADS */ + return 0; + } +} + +#ifdef TCL_THREADS +/* + *---------------------------------------------------------------------- + * + * NotifierThreadProc -- + * + * This routine is the initial (and only) function executed by the + * special notifier thread. Its job is to wait for file descriptors to + * become readable or writable or to have an exception condition and then + * to notify other threads who are interested in this information by + * signalling a condition variable. Other threads can signal this + * notifier thread of a change in their interests by writing a single + * byte to a special pipe that the notifier thread is monitoring. + * + * Result: + * None. Once started, this routine never exits. It dies with the overall + * process. + * + * Side effects: + * The trigger pipe used to signal the notifier thread is created when + * the notifier thread first starts. + * + *---------------------------------------------------------------------- + */ + +static void +NotifierThreadProc( + void *dummy) /* Not used. */ +{ + ThreadSpecificData *tsdPtr; + fd_set readableMask; + fd_set writableMask; + fd_set exceptionMask; + int i; + int fds[2], receivePipe; + long found; + struct timeval poll = {0, 0}, *timePtr; + char buf[2]; + int numFdBits = 0; + (void)dummy; + + if (pipe(fds) != 0) { + Tcl_Panic("NotifierThreadProc: %s", "could not create trigger pipe"); + } + + receivePipe = fds[0]; + + if (TclUnixSetBlockingMode(receivePipe, TCL_MODE_NONBLOCKING) < 0) { + Tcl_Panic("NotifierThreadProc: %s", + "could not make receive pipe non blocking"); + } + if (TclUnixSetBlockingMode(fds[1], TCL_MODE_NONBLOCKING) < 0) { + Tcl_Panic("NotifierThreadProc: %s", + "could not make trigger pipe non blocking"); + } + if (fcntl(receivePipe, F_SETFD, FD_CLOEXEC) < 0) { + Tcl_Panic("NotifierThreadProc: %s", + "could not make receive pipe close-on-exec"); + } + if (fcntl(fds[1], F_SETFD, FD_CLOEXEC) < 0) { + Tcl_Panic("NotifierThreadProc: %s", + "could not make trigger pipe close-on-exec"); + } + + /* + * Install the write end of the pipe into the global variable. + */ + + pthread_mutex_lock(¬ifierMutex); + triggerPipe = fds[1]; + + /* + * Signal any threads that are waiting. + */ + + pthread_cond_broadcast(¬ifierCV); + pthread_mutex_unlock(¬ifierMutex); + + /* + * Look for file events and report them to interested threads. + */ + + while (1) { + FD_ZERO(&readableMask); + FD_ZERO(&writableMask); + FD_ZERO(&exceptionMask); + + /* + * Compute the logical OR of the masks from all the waiting + * notifiers. + */ + + pthread_mutex_lock(¬ifierMutex); + timePtr = NULL; + for (tsdPtr = waitingListPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) { + for (i = tsdPtr->numFdBits-1; i >= 0; --i) { + if (FD_ISSET(i, &tsdPtr->checkMasks.readable)) { + FD_SET(i, &readableMask); + } + if (FD_ISSET(i, &tsdPtr->checkMasks.writable)) { + FD_SET(i, &writableMask); + } + if (FD_ISSET(i, &tsdPtr->checkMasks.exception)) { + FD_SET(i, &exceptionMask); + } + } + if (tsdPtr->numFdBits > numFdBits) { + numFdBits = tsdPtr->numFdBits; + } + if (tsdPtr->pollState & POLL_WANT) { + /* + * Here we make sure we go through select() with the same mask + * bits that were present when the thread tried to poll. + */ + + tsdPtr->pollState |= POLL_DONE; + timePtr = &poll; + } + } + pthread_mutex_unlock(¬ifierMutex); + + /* + * Set up the select mask to include the receive pipe. + */ + + if (receivePipe >= numFdBits) { + numFdBits = receivePipe + 1; + } + FD_SET(receivePipe, &readableMask); + + if (select(numFdBits, &readableMask, &writableMask, &exceptionMask, + timePtr) == -1) { + /* + * Try again immediately on an error. + */ + + continue; + } + + /* + * Alert any threads that are waiting on a ready file descriptor. + */ + + pthread_mutex_lock(¬ifierMutex); + for (tsdPtr = waitingListPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) { + found = 0; + + for (i = tsdPtr->numFdBits-1; i >= 0; --i) { + if (FD_ISSET(i, &tsdPtr->checkMasks.readable) + && FD_ISSET(i, &readableMask)) { + FD_SET(i, &tsdPtr->readyMasks.readable); + found = 1; + } + if (FD_ISSET(i, &tsdPtr->checkMasks.writable) + && FD_ISSET(i, &writableMask)) { + FD_SET(i, &tsdPtr->readyMasks.writable); + found = 1; + } + if (FD_ISSET(i, &tsdPtr->checkMasks.exception) + && FD_ISSET(i, &exceptionMask)) { + FD_SET(i, &tsdPtr->readyMasks.exception); + found = 1; + } + } + + if (found || (tsdPtr->pollState & POLL_DONE)) { + tsdPtr->eventReady = 1; + if (tsdPtr->onList) { + /* + * Remove the ThreadSpecificData structure of this thread + * from the waiting list. This prevents us from + * continuously spining on select until the other threads + * runs and services the file event. + */ + + if (tsdPtr->prevPtr) { + tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr; + } else { + waitingListPtr = tsdPtr->nextPtr; + } + if (tsdPtr->nextPtr) { + tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr; + } + tsdPtr->nextPtr = tsdPtr->prevPtr = NULL; + tsdPtr->onList = 0; + tsdPtr->pollState = 0; + } +#ifdef __CYGWIN__ + PostMessageW(tsdPtr->hwnd, 1024, 0, 0); +#else /* __CYGWIN__ */ + pthread_cond_broadcast(&tsdPtr->waitCV); +#endif /* __CYGWIN__ */ + } + } + pthread_mutex_unlock(¬ifierMutex); + + /* + * Consume the next byte from the notifier pipe if the pipe was + * readable. Note that there may be multiple bytes pending, but to + * avoid a race condition we only read one at a time. + */ + + if (FD_ISSET(receivePipe, &readableMask)) { + i = read(receivePipe, buf, 1); + + if ((i == 0) || ((i == 1) && (buf[0] == 'q'))) { + /* + * Someone closed the write end of the pipe or sent us a Quit + * message [Bug: 4139] and then closed the write end of the + * pipe so we need to shut down the notifier thread. + */ + + break; + } + } + } + + /* + * Clean up the read end of the pipe and signal any threads waiting on + * termination of the notifier thread. + */ + + close(receivePipe); + pthread_mutex_lock(¬ifierMutex); + triggerPipe = -1; + pthread_cond_broadcast(¬ifierCV); + pthread_mutex_unlock(¬ifierMutex); + + TclpThreadExit(0); +} + +#if defined(HAVE_PTHREAD_ATFORK) +/* + *---------------------------------------------------------------------- + * + * AtForkPrepare -- + * + * Lock the notifier in preparation for a fork. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +AtForkPrepare(void) +{ +#if RESET_ATFORK_MUTEX == 0 + pthread_mutex_lock(¬ifierInitMutex); +#endif +} + /* *---------------------------------------------------------------------- * - * AlertSingleThread -- + * AtForkParent -- + * + * Unlock the notifier in the parent after a fork. * - * Notify a single thread that is waiting on a file descriptor to become - * readable or writable or to have an exception condition. - * notifierMutex must be held. - * - * Result: + * Results: * None. * * Side effects: - * The condition variable associated with the thread is broadcasted. + * None. * *---------------------------------------------------------------------- */ static void -AlertSingleThread( - ThreadSpecificData *tsdPtr) -{ - tsdPtr->eventReady = 1; - if (tsdPtr->onList) { - /* - * Remove the ThreadSpecificData structure of this thread from the - * waiting list. This prevents us from continuously spinning on - * epoll_wait until the other threads runs and services the file - * event. - */ - - if (tsdPtr->prevPtr) { - tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr; - } else { - waitingListPtr = tsdPtr->nextPtr; - } - if (tsdPtr->nextPtr) { - tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr; - } - tsdPtr->nextPtr = tsdPtr->prevPtr = NULL; - tsdPtr->onList = 0; - tsdPtr->pollState = 0; - } -#ifdef __CYGWIN__ - PostMessageW(tsdPtr->hwnd, 1024, 0, 0); -#else /* !__CYGWIN__ */ - pthread_cond_broadcast(&tsdPtr->waitCV); -#endif /* __CYGWIN__ */ -} - -#if defined(HAVE_PTHREAD_ATFORK) +AtForkParent(void) +{ +#if RESET_ATFORK_MUTEX == 0 + pthread_mutex_unlock(¬ifierInitMutex); +#endif +} + /* *---------------------------------------------------------------------- * * AtForkChild -- * @@ -353,19 +1417,22 @@ AtForkChild(void) { if (notifierThreadRunning == 1) { pthread_cond_destroy(¬ifierCV); } +#if RESET_ATFORK_MUTEX == 0 + pthread_mutex_unlock(¬ifierInitMutex); +#else pthread_mutex_init(¬ifierInitMutex, NULL); pthread_mutex_init(¬ifierMutex, NULL); +#endif pthread_cond_init(¬ifierCV, NULL); /* - * notifierThreadRunning == 1: thread is running, (there might be data in - * notifier lists) + * notifierThreadRunning == 1: thread is running, (there might be data in notifier lists) * atForkInit == 0: InitNotifier was never called - * notifierCount != 0: unbalanced InitNotifier() / FinalizeNotifier calls + * notifierCount != 0: unbalanced InitNotifier() / FinalizeNotifier calls * waitingListPtr != 0: there are threads currently waiting for events. */ if (atForkInit == 1) { @@ -382,24 +1449,23 @@ * unreasonable. */ waitingListPtr = NULL; /* - * The tsdPtr from before the fork is copied as well. But since we - * are paranoic, we don't trust its condvar and reset it. + * The tsdPtr from before the fork is copied as well. But since + * we are paranoic, we don't trust its condvar and reset it. */ #ifdef __CYGWIN__ DestroyWindow(tsdPtr->hwnd); - tsdPtr->hwnd = CreateWindowExW(NULL, className, - className, 0, 0, 0, 0, 0, NULL, NULL, + tsdPtr->hwnd = CreateWindowExW(NULL, NotfyClassName, + NotfyClassName, 0, 0, 0, 0, 0, NULL, NULL, TclWinGetTclInstance(), NULL); ResetEvent(tsdPtr->event); -#else /* !__CYGWIN__ */ +#else pthread_cond_destroy(&tsdPtr->waitCV); pthread_cond_init(&tsdPtr->waitCV, NULL); -#endif /* __CYGWIN__ */ - +#endif /* * In case, we had multiple threads running before the fork, * make sure, we don't try to reach out to their thread local data. */ tsdPtr->nextPtr = tsdPtr->prevPtr = NULL; @@ -415,161 +1481,14 @@ } #endif /* HAVE_PTHREAD_ATFORK */ #endif /* TCL_THREADS */ -#endif /* NOTIFIER_SELECT */ -#ifndef HAVE_COREFOUNDATION /* Darwin/Mac OS X CoreFoundation notifier is - * in tclMacOSXNotify.c */ -/* - *---------------------------------------------------------------------- - * - * TclUnixWaitForFile -- - * - * This function waits synchronously for a file to become readable or - * writable, with an optional timeout. - * - * Results: - * The return value is an OR'ed combination of TCL_READABLE, - * TCL_WRITABLE, and TCL_EXCEPTION, indicating the conditions that are - * present on file at the time of the return. This function will not - * return until either "timeout" milliseconds have elapsed or at least - * one of the conditions given by mask has occurred for file (a return - * value of 0 means that a timeout occurred). No normal events will be - * serviced during the execution of this function. - * - * Side effects: - * Time passes. - * - *---------------------------------------------------------------------- - */ - -int -TclUnixWaitForFile( - int fd, /* Handle for file on which to wait. */ - int mask, /* What to wait for: OR'ed combination of - * TCL_READABLE, TCL_WRITABLE, and - * TCL_EXCEPTION. */ - int timeout) /* Maximum amount of time to wait for one of - * the conditions in mask to occur, in - * milliseconds. A value of 0 means don't wait - * at all, and a value of -1 means wait - * forever. */ -{ - Tcl_Time abortTime = {0, 0}, now; /* silence gcc 4 warning */ - struct timeval blockTime, *timeoutPtr; - struct pollfd pollFds[1]; - int numFound, result = 0, pollTimeout; - - /* - * If there is a non-zero finite timeout, compute the time when we give - * up. - */ - - if (timeout > 0) { - Tcl_GetTime(&now); - abortTime.sec = now.sec + timeout / 1000; - abortTime.usec = now.usec + (timeout % 1000) * 1000; - if (abortTime.usec >= 1000000) { - abortTime.usec -= 1000000; - abortTime.sec += 1; - } - timeoutPtr = &blockTime; - } else if (timeout == 0) { - timeoutPtr = &blockTime; - blockTime.tv_sec = 0; - blockTime.tv_usec = 0; - } else { - timeoutPtr = NULL; - } - - /* - * Setup the pollfd structure for the fd. - */ - - pollFds[0].fd = fd; - pollFds[0].events = pollFds[0].revents = 0; - if (mask & TCL_READABLE) { - pollFds[0].events |= (POLLIN | POLLHUP); - } - if (mask & TCL_WRITABLE) { - pollFds[0].events |= POLLOUT; - } - if (mask & TCL_EXCEPTION) { - pollFds[0].events |= POLLERR; - } - - /* - * Loop in a mini-event loop of our own, waiting for either the file to - * become ready or a timeout to occur. - */ - - do { - if (timeout > 0) { - blockTime.tv_sec = abortTime.sec - now.sec; - blockTime.tv_usec = abortTime.usec - now.usec; - if (blockTime.tv_usec < 0) { - blockTime.tv_sec -= 1; - blockTime.tv_usec += 1000000; - } - if (blockTime.tv_sec < 0) { - blockTime.tv_sec = 0; - blockTime.tv_usec = 0; - } - } - - /* - * Wait for the event or a timeout. - */ - - if (!timeoutPtr) { - pollTimeout = -1; - } else if (!timeoutPtr->tv_sec && !timeoutPtr->tv_usec) { - pollTimeout = 0; - } else { - pollTimeout = (int) timeoutPtr->tv_sec * 1000; - if (timeoutPtr->tv_usec) { - pollTimeout += (int) timeoutPtr->tv_usec / 1000; - } - } - numFound = poll(pollFds, 1, pollTimeout); - if (numFound == 1) { - result = 0; - if (pollFds[0].revents & (POLLIN | POLLHUP)) { - result |= TCL_READABLE; - } - if (pollFds[0].revents & POLLOUT) { - result |= TCL_WRITABLE; - } - if (pollFds[0].revents & POLLERR) { - result |= TCL_EXCEPTION; - } - if (result) { - break; - } - } - if (timeout == 0) { - break; - } - if (timeout < 0) { - continue; - } - - /* - * The select returned early, so we need to recompute the timeout. - */ - - Tcl_GetTime(&now); - } while ((abortTime.sec > now.sec) - || (abortTime.sec == now.sec && abortTime.usec > now.usec)); - return result; -} - #endif /* !HAVE_COREFOUNDATION */ - + /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: unix/tclUnixPipe.c ================================================================== --- unix/tclUnixPipe.c +++ unix/tclUnixPipe.c @@ -28,11 +28,11 @@ /* * This structure describes per-instance state of a pipe based channel. */ -typedef struct { +typedef struct PipeState { Tcl_Channel channel; /* Channel associated with this file. */ TclFile inFile; /* Output from pipe. */ TclFile outFile; /* Input to pipe. */ TclFile errorFile; /* Error output from pipe. */ int numPids; /* How many processes are attached to this @@ -227,13 +227,14 @@ */ Tcl_Obj * TclpTempFileName(void) { - Tcl_Obj *retVal, *nameObj = Tcl_NewObj(); + Tcl_Obj *retVal, *nameObj; int fd; + TclNewObj(nameObj); Tcl_IncrRefCount(nameObj); fd = TclUnixOpenTemporaryFile(NULL, NULL, NULL, nameObj); if (fd == -1) { Tcl_DecrRefCount(nameObj); return NULL; @@ -372,11 +373,10 @@ * A process is created. * *--------------------------------------------------------------------------- */ - /* ARGSUSED */ int TclpCreateProcess( Tcl_Interp *interp, /* Interpreter in which to leave errors that * occurred when creating the child process. * Error messages from the child process @@ -522,11 +522,11 @@ TclpCloseFile(errPipeOut); errPipeOut = NULL; fd = GetFd(errPipeIn); - count = read(fd, errSpace, sizeof(errSpace) - 1); + count = read(fd, errSpace, (size_t) (sizeof(errSpace) - 1)); if (count > 0) { char *end; errSpace[count] = 0; errno = strtol(errSpace, &end, 10); @@ -742,11 +742,11 @@ * closed or the processes are detached (in a * background exec). */ { char channelName[16 + TCL_INTEGER_SPACE]; int channelId; - PipeState *statePtr = Tcl_Alloc(sizeof(PipeState)); + PipeState *statePtr = ckalloc(sizeof(PipeState)); int mode; statePtr->inFile = readFile; statePtr->outFile = writeFile; statePtr->errorFile = errorFile; @@ -870,17 +870,17 @@ } pipePtr = Tcl_GetChannelInstanceData(chan); TclNewObj(pidsObj); for (i = 0; i < pipePtr->numPids; i++) { - Tcl_ListObjAppendElement(NULL, pidsObj, Tcl_NewWideIntObj( + Tcl_ListObjAppendElement(NULL, pidsObj, Tcl_NewIntObj( PTR2INT(pipePtr->pidPtr[i]))); Tcl_DetachPids(1, &pipePtr->pidPtr[i]); } Tcl_SetObjResult(interp, pidsObj); if (pipePtr->numPids > 0) { - Tcl_Free(pipePtr->pidPtr); + ckfree(pipePtr->pidPtr); pipePtr->numPids = 0; } } /* @@ -898,11 +898,10 @@ * Sets the device into blocking or non-blocking mode. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int PipeBlockModeProc( ClientData instanceData, /* Pipe state. */ int mode) /* The mode to set. Can be one of * TCL_MODE_BLOCKING or @@ -1007,13 +1006,13 @@ result = TclCleanupChildren(interp, pipePtr->numPids, pipePtr->pidPtr, errChan); } if (pipePtr->numPids != 0) { - Tcl_Free(pipePtr->pidPtr); + ckfree(pipePtr->pidPtr); } - Tcl_Free(pipePtr); + ckfree(pipePtr); if (errorCode == 0) { return result; } return errorCode; } @@ -1057,11 +1056,11 @@ * nonblocking, the read will never block. Some OSes can throw an * interrupt error, for which we should immediately retry. [Bug #415131] */ do { - bytesRead = read(GetFd(psPtr->inFile), buf, toRead); + bytesRead = read(GetFd(psPtr->inFile), buf, (size_t) toRead); } while ((bytesRead < 0) && (errno == EINTR)); if (bytesRead < 0) { *errorCodePtr = errno; return -1; @@ -1103,11 +1102,11 @@ * Some OSes can throw an interrupt error, for which we should immediately * retry. [Bug #415131] */ do { - written = write(GetFd(psPtr->outFile), buf, toWrite); + written = write(GetFd(psPtr->outFile), buf, (size_t) toWrite); } while ((written < 0) && (errno == EINTR)); if (written < 0) { *errorCodePtr = errno; return -1; @@ -1247,11 +1246,10 @@ * See the user documentation. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ int Tcl_PidObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ @@ -1266,17 +1264,17 @@ Tcl_WrongNumArgs(interp, 1, objv, "?channelId?"); return TCL_ERROR; } if (objc == 1) { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(getpid())); + Tcl_SetObjResult(interp, Tcl_NewLongObj((long) getpid())); } else { /* * Get the channel and make sure that it refers to a pipe. */ - chan = Tcl_GetChannel(interp, TclGetString(objv[1]), NULL); + chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL); if (chan == NULL) { return TCL_ERROR; } if (Tcl_GetChannelType(chan) != &pipeChannelType) { return TCL_OK; @@ -1285,14 +1283,14 @@ /* * Extract the process IDs from the pipe structure. */ pipePtr = Tcl_GetChannelInstanceData(chan); - resultPtr = Tcl_NewObj(); + TclNewObj(resultPtr); for (i = 0; i < pipePtr->numPids; i++) { Tcl_ListObjAppendElement(NULL, resultPtr, - Tcl_NewWideIntObj(PTR2INT(TclpGetPid(pipePtr->pidPtr[i])))); + Tcl_NewIntObj(PTR2INT(TclpGetPid(pipePtr->pidPtr[i])))); } Tcl_SetObjResult(interp, resultPtr); } return TCL_OK; } Index: unix/tclUnixPort.h ================================================================== --- unix/tclUnixPort.h +++ unix/tclUnixPort.h @@ -84,11 +84,10 @@ # define TclOSseek lseek # define TclOSopen open #endif #ifdef __CYGWIN__ - /* Make some symbols available without including */ # define DWORD unsigned int # define CP_UTF8 65001 # define GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS 0x00000004 # define HANDLE void * @@ -101,30 +100,24 @@ __declspec(dllimport) extern __stdcall int WideCharToMultiByte(int, int, const void *, int, char *, int, const char *, void *); __declspec(dllimport) extern __stdcall int MultiByteToWideChar(int, int, const char *, int, WCHAR *, int); __declspec(dllimport) extern __stdcall void OutputDebugStringW(const WCHAR *); - __declspec(dllimport) extern __stdcall int IsDebuggerPresent(); - __declspec(dllimport) extern __stdcall int GetLastError(); + __declspec(dllimport) extern __stdcall int IsDebuggerPresent(void); + __declspec(dllimport) extern __stdcall int GetLastError(void); __declspec(dllimport) extern __stdcall int GetFileAttributesW(const WCHAR *); __declspec(dllimport) extern __stdcall int SetFileAttributesW(const WCHAR *, int); - __declspec(dllimport) extern int cygwin_conv_path(int, const void *, void *, int); -/* On Cygwin, the environment is imported from the Cygwin DLL. */ -#ifndef __x86_64__ -# define environ __cygwin_environ - extern char **__cygwin_environ; -#endif # define timezone _timezone extern int TclOSstat(const char *name, void *statBuf); extern int TclOSlstat(const char *name, void *statBuf); #elif defined(HAVE_STRUCT_STAT64) && !defined(__APPLE__) -# define TclOSstat stat64 -# define TclOSlstat lstat64 +# define TclOSstat(name, buf) stat64(name, (struct stat64 *)buf) +# define TclOSlstat(name,buf) lstat64(name, (struct stat64 *)buf) #else -# define TclOSstat stat -# define TclOSlstat lstat +# define TclOSstat(name, buf) stat(name, (struct stat *)buf) +# define TclOSlstat(name, buf) lstat(name, (struct stat *)buf) #endif /* *--------------------------------------------------------------------------- * Miscellaneous includes that might be missing. @@ -154,13 +147,17 @@ #endif #include #ifdef HAVE_STDINT_H # include #endif -#include +#ifdef HAVE_UNISTD_H +# include +#else +# include "../compat/unistd.h" +#endif -MODULE_SCOPE int TclUnixSetBlockingMode(int fd, int mode); +extern int TclUnixSetBlockingMode(int fd, int mode); #include /* *--------------------------------------------------------------------------- @@ -186,11 +183,17 @@ * for an alternative definition. If no other alternative is available we use * a reasonable guess. *--------------------------------------------------------------------------- */ -#include +#ifndef NO_FLOAT_H +# include +#else +#ifndef NO_VALUES_H +# include +#endif +#endif #ifndef FLT_MAX # ifdef MAXFLOAT # define FLT_MAX MAXFLOAT # else @@ -238,33 +241,33 @@ * in header files above. *--------------------------------------------------------------------------- */ #ifndef WIFEXITED -# define WIFEXITED(stat) (((*((int *) &(stat))) & 0xff) == 0) +# define WIFEXITED(stat) (((*((int *) &(stat))) & 0xFF) == 0) #endif #ifndef WEXITSTATUS -# define WEXITSTATUS(stat) (((*((int *) &(stat))) >> 8) & 0xff) +# define WEXITSTATUS(stat) (((*((int *) &(stat))) >> 8) & 0xFF) #endif #ifndef WIFSIGNALED # define WIFSIGNALED(stat) \ (((*((int *) &(stat)))) && ((*((int *) &(stat))) \ - == ((*((int *) &(stat))) & 0x00ff))) + == ((*((int *) &(stat))) & 0x00FF))) #endif #ifndef WTERMSIG -# define WTERMSIG(stat) ((*((int *) &(stat))) & 0x7f) +# define WTERMSIG(stat) ((*((int *) &(stat))) & 0x7F) #endif #ifndef WIFSTOPPED -# define WIFSTOPPED(stat) (((*((int *) &(stat))) & 0xff) == 0177) +# define WIFSTOPPED(stat) (((*((int *) &(stat))) & 0xFF) == 0177) #endif #ifndef WSTOPSIG -# define WSTOPSIG(stat) (((*((int *) &(stat))) >> 8) & 0xff) +# define WSTOPSIG(stat) (((*((int *) &(stat))) >> 8) & 0xFF) #endif /* *--------------------------------------------------------------------------- * Define constants for waitpid() system call if they aren't defined by a @@ -607,12 +610,14 @@ # undef HAVE_OSSPINLOCKLOCK # undef HAVE_PTHREAD_ATFORK # undef HAVE_COPYFILE # endif # if MAC_OS_X_VERSION_MAX_ALLOWED < 1030 - /* prior to 10.3, realpath is not threadsafe, c.f. bug 711232 */ -# define NO_REALPATH 1 +# ifdef TCL_THREADS + /* prior to 10.3, realpath is not threadsafe, c.f. bug 711232 */ +# define NO_REALPATH 1 +# endif # undef HAVE_LANGINFO # endif # endif /* MAC_OS_X_VERSION_MAX_ALLOWED */ # if defined(HAVE_COREFOUNDATION) && defined(__LP64__) && \ defined(HAVE_WEAK_IMPORT) && MAC_OS_X_VERSION_MIN_REQUIRED < 1050 @@ -669,23 +674,23 @@ *--------------------------------------------------------------------------- * The following defines wrap the system memory allocation routines. *--------------------------------------------------------------------------- */ -#define TclpSysAlloc(size) malloc(size) -#define TclpSysFree(ptr) free(ptr) -#define TclpSysRealloc(ptr, size) realloc(ptr, size) +#define TclpSysAlloc(size, isBin) malloc((size_t)(size)) +#define TclpSysFree(ptr) free((char *)(ptr)) +#define TclpSysRealloc(ptr, size) realloc((char *)(ptr), (size_t)(size)) /* *--------------------------------------------------------------------------- * The following macros and declaration wrap the C runtime library functions. *--------------------------------------------------------------------------- */ #define TclpExit exit -#if !defined(TCL_THREADS) || TCL_THREADS +#ifdef TCL_THREADS # include #endif /* TCL_THREADS */ /* FIXME - Hyper-enormous platform assumption! */ #ifndef AF_INET6 @@ -701,18 +706,18 @@ */ #include #include -MODULE_SCOPE struct passwd * TclpGetPwNam(const char *name); -MODULE_SCOPE struct group * TclpGetGrNam(const char *name); -MODULE_SCOPE struct passwd * TclpGetPwUid(uid_t uid); -MODULE_SCOPE struct group * TclpGetGrGid(gid_t gid); -MODULE_SCOPE struct hostent * TclpGetHostByName(const char *name); -MODULE_SCOPE struct hostent * TclpGetHostByAddr(const char *addr, +extern struct passwd * TclpGetPwNam(const char *name); +extern struct group * TclpGetGrNam(const char *name); +extern struct passwd * TclpGetPwUid(uid_t uid); +extern struct group * TclpGetGrGid(gid_t gid); +extern struct hostent * TclpGetHostByName(const char *name); +extern struct hostent * TclpGetHostByAddr(const char *addr, int length, int type); -MODULE_SCOPE void *TclpMakeTcpClientChannelMode( +extern void *TclpMakeTcpClientChannelMode( void *tcpSocket, int mode); #endif /* _TCLUNIXPORT */ /* Index: unix/tclUnixSock.c ================================================================== --- unix/tclUnixSock.c +++ unix/tclUnixSock.c @@ -51,12 +51,10 @@ struct TcpFdList *next; } TcpFdList; struct TcpState { Tcl_Channel channel; /* Channel associated with this file. */ - int testFlags; /* bit field for tests. Is set by testsocket - * test procedure */ TcpFdList fds; /* The file descriptors of the sockets. */ int flags; /* ORed combination of the bitfields defined * below. */ int interest; /* Event types of interest */ @@ -93,19 +91,10 @@ * process an async connect. This * flag indicates that reentry is * still pending */ #define TCP_ASYNC_FAILED (1<<5) /* An async connect finally failed */ -/* - * These bits may be ORed together into the "testFlags" field of a TcpState - * structure. - */ - -#define TCP_ASYNC_TEST_MODE (1<<0) /* Async testing activated. Do not - * automatically continue connection - * process. */ - /* * The following defines the maximum length of the listen queue. This is the * number of outstanding yet-to-be-serviced requests for a connection on a * server socket, more than this number of outstanding requests and the * connection request will fail. @@ -127,10 +116,11 @@ /* * Static routines for this file: */ +static void TcpAsyncCallback(ClientData clientData, int mask); static int TcpConnect(Tcl_Interp *interp, TcpState *state); static void TcpAccept(ClientData data, int mask); static int TcpBlockModeProc(ClientData data, int mode); static int TcpCloseProc(ClientData instanceData, Tcl_Interp *interp); @@ -143,10 +133,11 @@ Tcl_DString *dsPtr); static int TcpInputProc(ClientData instanceData, char *buf, int toRead, int *errorCode); static int TcpOutputProc(ClientData instanceData, const char *buf, int toWrite, int *errorCode); +static void TcpThreadActionProc(ClientData instanceData, int action); static void TcpWatchProc(ClientData instanceData, int mask); static int WaitForConnect(TcpState *statePtr, int *errorCodePtr); static void WrapNotify(ClientData clientData, int mask); /* @@ -168,11 +159,11 @@ TcpClose2Proc, /* Close2 proc. */ TcpBlockModeProc, /* Set blocking or non-blocking mode.*/ NULL, /* flush proc. */ NULL, /* handler proc. */ NULL, /* wide seek proc. */ - NULL, /* thread action proc. */ + TcpThreadActionProc, /* thread action proc. */ NULL /* truncate proc. */ }; /* * The following variable holds the network name of this host. @@ -215,11 +206,11 @@ */ static void InitializeHostName( char **valuePtr, - size_t *lengthPtr, + int *lengthPtr, Tcl_Encoding *encodingPtr) { const char *native = NULL; #ifndef NO_UNAME @@ -237,24 +228,27 @@ */ char *dot = strchr(u.nodename, '.'); if (dot != NULL) { - char *node = Tcl_Alloc(dot - u.nodename + 1); + char *node = (char *)ckalloc(dot - u.nodename + 1); memcpy(node, u.nodename, dot - u.nodename); node[dot - u.nodename] = '\0'; hp = TclpGetHostByName(node); - Tcl_Free(node); + ckfree(node); } } if (hp != NULL) { native = hp->h_name; } else { native = u.nodename; } } + if (native == NULL) { + native = tclEmptyStringRep; + } #else /* !NO_UNAME */ /* * Uname doesn't exist; try gethostname instead. * * There is no portable macro for the maximum length of host names @@ -279,19 +273,13 @@ native = buffer; } #endif /* NO_UNAME */ *encodingPtr = Tcl_GetEncoding(NULL, NULL); - if (native) { - *lengthPtr = strlen(native); - *valuePtr = Tcl_Alloc(*lengthPtr + 1); - memcpy(*valuePtr, native, *lengthPtr + 1); - } else { - *lengthPtr = 0; - *valuePtr = Tcl_Alloc(1); - *valuePtr[0] = '\0'; - } + *lengthPtr = strlen(native); + *valuePtr = ckalloc(*lengthPtr + 1); + memcpy(*valuePtr, native, *lengthPtr + 1); } /* * ---------------------------------------------------------------------- * @@ -311,12 +299,11 @@ */ const char * Tcl_GetHostName(void) { - Tcl_Obj *tclObj = TclGetProcessGlobalValue(&hostName); - return TclGetString(tclObj); + return Tcl_GetString(TclGetProcessGlobalValue(&hostName)); } /* * ---------------------------------------------------------------------- * @@ -333,12 +320,14 @@ * ---------------------------------------------------------------------- */ int TclpHasSockets( - Tcl_Interp *interp) /* Not used. */ + Tcl_Interp *dummy) /* Not used. */ { + (void)dummy; + return TCL_OK; } /* * ---------------------------------------------------------------------- @@ -377,19 +366,18 @@ * Sets the device into blocking or nonblocking mode. * * ---------------------------------------------------------------------- */ - /* ARGSUSED */ static int TcpBlockModeProc( ClientData instanceData, /* Socket state. */ int mode) /* The mode to set. Can be one of * TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ { - TcpState *statePtr = instanceData; + TcpState *statePtr = (TcpState *)instanceData; if (mode == TCL_MODE_BLOCKING) { CLEAR_BITS(statePtr->flags, TCP_NONBLOCKING); } else { SET_BITS(statePtr->flags, TCP_NONBLOCKING); @@ -458,24 +446,10 @@ if (!GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) { return 0; } - /* - * In socket test mode do not continue with the connect. - * Exceptions are: - * - Call by recv/send and blocking socket - * (errorCodePtr != NULL && !GOT_BITS(flags, TCP_NONBLOCKING)) - */ - - if (GOT_BITS(statePtr->testFlags, TCP_ASYNC_TEST_MODE) - && !(errorCodePtr != NULL - && !GOT_BITS(statePtr->flags, TCP_NONBLOCKING))) { - *errorCodePtr = EWOULDBLOCK; - return -1; - } - if (errorCodePtr == NULL || GOT_BITS(statePtr->flags, TCP_NONBLOCKING)) { timeout = 0; } else { timeout = -1; } @@ -523,27 +497,26 @@ * Reads input from the input device of the channel. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int TcpInputProc( ClientData instanceData, /* Socket state. */ char *buf, /* Where to store data read. */ int bufSize, /* How much space is available in the * buffer? */ int *errorCodePtr) /* Where to store error code. */ { - TcpState *statePtr = instanceData; + TcpState *statePtr = (TcpState *)instanceData; int bytesRead; *errorCodePtr = 0; if (WaitForConnect(statePtr, errorCodePtr) != 0) { return -1; } - bytesRead = recv(statePtr->fds.fd, buf, bufSize, 0); + bytesRead = recv(statePtr->fds.fd, buf, (size_t) bufSize, 0); if (bytesRead > -1) { return bytesRead; } if (errno == ECONNRESET) { /* @@ -582,18 +555,18 @@ ClientData instanceData, /* Socket state. */ const char *buf, /* The data buffer. */ int toWrite, /* How many bytes to write? */ int *errorCodePtr) /* Where to store error code. */ { - TcpState *statePtr = instanceData; + TcpState *statePtr = (TcpState *)instanceData; int written; *errorCodePtr = 0; if (WaitForConnect(statePtr, errorCodePtr) != 0) { return -1; } - written = send(statePtr->fds.fd, buf, toWrite, 0); + written = send(statePtr->fds.fd, buf, (size_t) toWrite, 0); if (written > -1) { return written; } *errorCodePtr = errno; @@ -616,19 +589,19 @@ * Closes the socket of the channel. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int TcpCloseProc( ClientData instanceData, /* The socket to close. */ - Tcl_Interp *interp) /* For error reporting - unused. */ + Tcl_Interp *dummy) /* For error reporting - unused. */ { - TcpState *statePtr = instanceData; + TcpState *statePtr = (TcpState *)instanceData; int errorCode = 0; TcpFdList *fds; + (void)dummy; /* * Delete a file handler that may be active for this socket if this is a * server socket - the file handler was created automatically by Tcl as * part of the mechanism to accept new client connections. Channel @@ -648,20 +621,20 @@ } fds = statePtr->fds.next; while (fds != NULL) { TcpFdList *next = fds->next; - Tcl_Free(fds); + ckfree(fds); fds = next; } if (statePtr->addrlist != NULL) { freeaddrinfo(statePtr->addrlist); } if (statePtr->myaddrlist != NULL) { freeaddrinfo(statePtr->myaddrlist); } - Tcl_Free(statePtr); + ckfree(statePtr); return errorCode; } /* *---------------------------------------------------------------------- @@ -681,40 +654,31 @@ */ static int TcpClose2Proc( ClientData instanceData, /* The socket to close. */ - Tcl_Interp *interp, /* For error reporting. */ + Tcl_Interp *dummy, /* For error reporting. */ int flags) /* Flags that indicate which side to close. */ { - TcpState *statePtr = instanceData; - int errorCode = 0; - int sd; + TcpState *statePtr = (TcpState *)instanceData; + int readError = 0; + int writeError = 0; + (void)dummy; /* * Shutdown the OS socket handle. */ - - switch(flags) { - case TCL_CLOSE_READ: - sd = SHUT_RD; - break; - case TCL_CLOSE_WRITE: - sd = SHUT_WR; - break; - default: - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "socket close2proc called bidirectionally", -1)); - } - return TCL_ERROR; - } - if (shutdown(statePtr->fds.fd,sd) < 0) { - errorCode = errno; - } - - return errorCode; + if ((flags & (TCL_CLOSE_READ|TCL_CLOSE_WRITE)) == 0) { + return TcpCloseProc(instanceData, NULL); + } + if ((flags & TCL_CLOSE_READ) && (shutdown(statePtr->fds.fd, SHUT_RD) < 0)) { + readError = errno; + } + if ((flags & TCL_CLOSE_WRITE) && (shutdown(statePtr->fds.fd, SHUT_WR) < 0)) { + writeError = errno; + } + return (readError != 0) ? readError : writeError; } /* *---------------------------------------------------------------------- * @@ -849,11 +813,11 @@ * for, or NULL to get all options and their * values. */ Tcl_DString *dsPtr) /* Where to store the computed value; * initialized by caller. */ { - TcpState *statePtr = instanceData; + TcpState *statePtr = (TcpState *)instanceData; size_t len = 0; WaitForConnect(statePtr, NULL); if (optionName != NULL) { @@ -991,10 +955,55 @@ } /* * ---------------------------------------------------------------------- * + * TcpThreadActionProc -- + * + * Handles detach/attach for asynchronously connecting socket. + * + * Reassigning the file handler associated with thread-related channel + * notification, responsible for callbacks (signaling that asynchronous + * connection attempt has succeeded or failed). + * + * Results: + * None. + * + * ---------------------------------------------------------------------- + */ + +static void +TcpThreadActionProc( + ClientData instanceData, + int action) +{ + TcpState *statePtr = (TcpState *)instanceData; + + if (GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) { + /* + * Async-connecting socket must get reassigned handler if it have been + * transferred to another thread. Remove the handler if the socket is + * not managed by this thread anymore and create new handler (TSD related) + * so the callback will run in the correct thread, bug [f583715154]. + */ + switch (action) { + case TCL_CHANNEL_THREAD_REMOVE: + CLEAR_BITS(statePtr->flags, TCP_ASYNC_PENDING); + Tcl_DeleteFileHandler(statePtr->fds.fd); + break; + case TCL_CHANNEL_THREAD_INSERT: + Tcl_CreateFileHandler(statePtr->fds.fd, + TCL_WRITABLE | TCL_EXCEPTION, TcpAsyncCallback, statePtr); + SET_BITS(statePtr->flags, TCP_ASYNC_PENDING); + break; + } + } +} + +/* + * ---------------------------------------------------------------------- + * * TcpWatchProc -- * * Initialize the notifier to watch the fd from this channel. * * Results: @@ -1041,11 +1050,11 @@ ClientData instanceData, /* The socket state. */ int mask) /* Events of interest; an OR-ed combination of * TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ { - TcpState *statePtr = instanceData; + TcpState *statePtr = (TcpState *)instanceData; if (statePtr->acceptProc != NULL) { /* * Make sure we don't mess with server sockets since they will never * be readable or writable at the Tcl level. This keeps Tcl scripts @@ -1107,18 +1116,18 @@ * None. * * ---------------------------------------------------------------------- */ - /* ARGSUSED */ static int TcpGetHandleProc( ClientData instanceData, /* The socket state. */ int direction, /* Not used. */ ClientData *handlePtr) /* Where to store the handle. */ { - TcpState *statePtr = instanceData; + TcpState *statePtr = (TcpState *)instanceData; + (void)direction; *handlePtr = INT2PTR(statePtr->fds.fd); return TCL_OK; } @@ -1139,11 +1148,13 @@ ClientData clientData, /* The socket state. */ int mask) /* Events of interest; an OR-ed combination of * TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ { - TcpConnect(NULL, clientData); + (void)mask; + + TcpConnect(NULL, (TcpState *)clientData); } /* * ---------------------------------------------------------------------- * @@ -1398,11 +1409,11 @@ /* * Allocate a new TcpState for this socket. */ - statePtr = Tcl_Alloc(sizeof(TcpState)); + statePtr = (TcpState *)ckalloc(sizeof(TcpState)); memset(statePtr, 0, sizeof(TcpState)); statePtr->flags = async ? TCP_ASYNC_CONNECT : 0; statePtr->cachedBlocking = TCL_MODE_BLOCKING; statePtr->addrlist = addrlist; statePtr->myaddrlist = myaddrlist; @@ -1477,11 +1488,11 @@ * TCL_WRITABLE to indicate file mode. */ { TcpState *statePtr; char channelName[SOCK_CHAN_LENGTH]; - statePtr = Tcl_Alloc(sizeof(TcpState)); + statePtr = (TcpState *)ckalloc(sizeof(TcpState)); memset(statePtr, 0, sizeof(TcpState)); statePtr->fds.fd = PTR2INT(sock); statePtr->flags = 0; sprintf(channelName, SOCK_TEMPLATE, (long)statePtr); @@ -1497,11 +1508,11 @@ } /* *---------------------------------------------------------------------- * - * Tcl_OpenTcpServerEx -- + * Tcl_OpenTcpServer -- * * Opens a TCP server socket and creates a channel around it. * * Results: * The channel or NULL if failed. If an error occurred, an error message @@ -1512,21 +1523,20 @@ * *---------------------------------------------------------------------- */ Tcl_Channel -Tcl_OpenTcpServerEx( +Tcl_OpenTcpServer( Tcl_Interp *interp, /* For error reporting - may be NULL. */ - const char *service, /* Port number to open. */ + int port, /* Port number to open. */ const char *myHost, /* Name of local host. */ - unsigned int flags, /* Flags. */ Tcl_TcpAcceptProc *acceptProc, /* Callback for accepting connections from new * clients. */ ClientData acceptProcData) /* Data for the callback. */ { - int status = 0, sock = -1, optvalue, port, chosenport; + int status = 0, sock = -1, reuseaddr = 1, chosenport = 0; struct addrinfo *addrlist = NULL, *addrPtr; /* socket address */ TcpState *statePtr = NULL; char channelName[SOCK_CHAN_LENGTH]; const char *errorMsg = NULL; TcpFdList *fds = NULL, *newfds; @@ -1537,49 +1547,11 @@ */ enum { LOOKUP, SOCKET, BIND, LISTEN } howfar = LOOKUP; int my_errno = 0; - /* - * If we were called with port 0 to listen on a random port number, we - * copy the port number from the first member of the addrinfo list to all - * subsequent members, so that IPv4 and IPv6 listen on the same port. This - * might fail to bind() with EADDRINUSE if a port is free on the first - * address family in the list but already used on the other. In this case - * we revert everything we've done so far and start from scratch hoping - * that next time we'll find a port number that is usable on all address - * families. We try this at most MAXRETRY times to avoid an endless loop - * if all ports are taken. - */ - - int retry = 0; -#define MAXRETRY 10 - - repeat: - if (retry > 0) { - if (statePtr != NULL) { - TcpCloseProc(statePtr, NULL); - statePtr = NULL; - } - if (addrlist != NULL) { - freeaddrinfo(addrlist); - addrlist = NULL; - } - if (retry >= MAXRETRY) { - goto error; - } - } - retry++; - chosenport = 0; - - if (TclSockGetPort(interp, service, "tcp", &port) != TCL_OK) { - errorMsg = "invalid port number"; - goto error; - } - - if (!TclCreateSocketAddress(interp, &addrlist, myHost, port, 1, - &errorMsg)) { + if (!TclCreateSocketAddress(interp, &addrlist, myHost, port, 1, &errorMsg)) { my_errno = errno; goto error; } for (addrPtr = addrlist; addrPtr != NULL; addrPtr = addrPtr->ai_next) { @@ -1605,34 +1577,16 @@ */ TclSockMinimumBuffers(INT2PTR(sock), SOCKET_BUFSIZE); /* - * Set up to reuse server addresses and/or ports if requested. - */ - - if (GOT_BITS(flags, TCL_TCPSERVER_REUSEADDR)) { - optvalue = 1; - (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, - (char *) &optvalue, sizeof(optvalue)); - } - - if (GOT_BITS(flags, TCL_TCPSERVER_REUSEPORT)) { -#ifndef SO_REUSEPORT - /* - * If the platform doesn't support the SO_REUSEPORT flag we can't - * do much beside erroring out. - */ - - errorMsg = "SO_REUSEPORT isn't supported by this platform"; - goto error; -#else - optvalue = 1; - (void) setsockopt(sock, SOL_SOCKET, SO_REUSEPORT, - (char *) &optvalue, sizeof(optvalue)); -#endif - } + * Set up to reuse server addresses automatically and bind to the + * specified port. + */ + + (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, + (char *) &reuseaddr, sizeof(reuseaddr)); /* * Make sure we use the same port number when opening two server * sockets for IPv4 and IPv6 on a random port. * @@ -1664,13 +1618,10 @@ howfar = BIND; my_errno = errno; } close(sock); sock = -1; - if (port == 0 && errno == EADDRINUSE) { - goto repeat; - } continue; } if (port == 0 && chosenport == 0) { address sockname; socklen_t namelen = sizeof(sockname); @@ -1690,28 +1641,25 @@ howfar = LISTEN; my_errno = errno; } close(sock); sock = -1; - if (port == 0 && errno == EADDRINUSE) { - goto repeat; - } continue; } if (statePtr == NULL) { /* * Allocate a new TcpState for this socket. */ - statePtr = Tcl_Alloc(sizeof(TcpState)); + statePtr = (TcpState *)ckalloc(sizeof(TcpState)); memset(statePtr, 0, sizeof(TcpState)); statePtr->acceptProc = acceptProc; statePtr->acceptProcData = acceptProcData; sprintf(channelName, SOCK_TEMPLATE, (long) statePtr); newfds = &statePtr->fds; } else { - newfds = Tcl_Alloc(sizeof(TcpFdList)); + newfds = (TcpFdList *)ckalloc(sizeof(TcpFdList)); memset(newfds, (int) 0, sizeof(TcpFdList)); fds->next = newfds; } newfds->fd = sock; newfds->statePtr = statePtr; @@ -1765,23 +1713,23 @@ * connection acceptance mechanism. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ static void TcpAccept( ClientData data, /* Callback token. */ int mask) /* Not used. */ { - TcpFdList *fds = data; /* Client data of server socket. */ + TcpFdList *fds = (TcpFdList *)data; /* Client data of server socket. */ int newsock; /* The new client socket */ TcpState *newSockState; /* State for new socket. */ address addr; /* The remote address */ socklen_t len; /* For accept interface */ char channelName[SOCK_CHAN_LENGTH]; char host[NI_MAXHOST], port[NI_MAXSERV]; + (void)mask; len = sizeof(addr); newsock = accept(fds->fd, &addr.sa, &len); if (newsock < 0) { return; @@ -1792,11 +1740,11 @@ * inherited by child processes. */ (void) fcntl(newsock, F_SETFD, FD_CLOEXEC); - newSockState = Tcl_Alloc(sizeof(TcpState)); + newSockState = (TcpState *)ckalloc(sizeof(TcpState)); memset(newSockState, 0, sizeof(TcpState)); newSockState->flags = 0; newSockState->fds.fd = newsock; sprintf(channelName, SOCK_TEMPLATE, (long) newSockState); Index: unix/tclUnixTest.c ================================================================== --- unix/tclUnixTest.c +++ unix/tclUnixTest.c @@ -35,11 +35,11 @@ /* * The stuff below is used to keep track of file handlers created and * exercised by the "testfilehandler" command. */ -typedef struct { +typedef struct Pipe { TclFile readFile; /* File handle for reading from the pipe. NULL * means pipe doesn't exist yet. */ TclFile writeFile; /* File handle for writing from the pipe. */ int readCount; /* Number of times the file handler for this * file has triggered and the file was @@ -66,14 +66,14 @@ static Tcl_ObjCmdProc TestchmodCmd; static Tcl_CmdProc TestfilehandlerCmd; static Tcl_CmdProc TestfilewaitCmd; static Tcl_CmdProc TestfindexecutableCmd; static Tcl_ObjCmdProc TestforkObjCmd; -static Tcl_ObjCmdProc TestgetencpathObjCmd; +static Tcl_CmdProc TestgetdefencdirCmd; static Tcl_CmdProc TestgetopenfileCmd; static Tcl_CmdProc TestgotsigCmd; -static Tcl_ObjCmdProc TestsetencpathObjCmd; +static Tcl_CmdProc TestsetdefencdirCmd; static Tcl_FileProc TestFileHandlerProc; static void AlarmHandler(int signum); /* *---------------------------------------------------------------------- @@ -106,13 +106,13 @@ NULL, NULL); Tcl_CreateObjCommand(interp, "testfork", TestforkObjCmd, NULL, NULL); Tcl_CreateCommand(interp, "testgetopenfile", TestgetopenfileCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testgetencpath", TestgetencpathObjCmd, + Tcl_CreateCommand(interp, "testgetdefenc", TestgetdefencdirCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testsetencpath", TestsetencpathObjCmd, + Tcl_CreateCommand(interp, "testsetdefenc", TestsetdefencdirCmd, NULL, NULL); Tcl_CreateCommand(interp, "testalarm", TestalarmCmd, NULL, NULL); Tcl_CreateCommand(interp, "testgotsig", TestgotsigCmd, NULL, NULL); @@ -497,13 +497,13 @@ } /* *---------------------------------------------------------------------- * - * TestsetencpathCmd -- + * TestsetdefencdirCmd -- * - * This function implements the "testsetencpath" command. It is used to + * This function implements the "testsetdefenc" command. It is used to * test Tcl_SetDefaultEncodingDir(). * * Results: * A standard Tcl result. * @@ -512,22 +512,23 @@ * *---------------------------------------------------------------------- */ static int -TestsetencpathObjCmd( +TestsetdefencdirCmd( ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const *objv) /* Argument strings. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "defaultDir"); + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " defaultDir\"", NULL); return TCL_ERROR; } - Tcl_SetEncodingSearchPath(objv[1]); + Tcl_SetDefaultEncodingDir(argv[1]); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -549,11 +550,11 @@ static int TestforkObjCmd( ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *const *objv) /* Argument strings. */ + Tcl_Obj *const *objv) /* Argument strings. */ { pid_t pid; if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, ""); @@ -568,21 +569,21 @@ /* Only needed when pthread_atfork is not present, * should not hurt otherwise. */ if (pid==0) { Tcl_InitNotifier(); } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(pid)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(pid)); return TCL_OK; } /* *---------------------------------------------------------------------- * - * TestgetencpathObjCmd -- + * TestgetdefencdirCmd -- * - * This function implements the "testgetencpath" command. It is used to - * test Tcl_GetEncodingSearchPath(). + * This function implements the "testgetdefenc" command. It is used to + * test Tcl_GetDefaultEncodingDir(). * * Results: * A standard Tcl result. * * Side effects: @@ -590,22 +591,22 @@ * *---------------------------------------------------------------------- */ static int -TestgetencpathObjCmd( +TestgetdefencdirCmd( ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const *objv) /* Argument strings. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { - if (objc != 1) { - Tcl_WrongNumArgs(interp, 1, objv, ""); + if (argc != 1) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], NULL); return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_GetEncodingSearchPath()); + Tcl_AppendResult(interp, Tcl_GetDefaultEncodingDir(), NULL); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -759,11 +760,11 @@ translated = Tcl_TranslateFileName(interp, Tcl_GetString(objv[i]), &buffer); if (translated == NULL) { return TCL_ERROR; } - if (chmod(translated, mode) != 0) { + if (chmod(translated, (unsigned) mode) != 0) { Tcl_AppendResult(interp, translated, ": ", Tcl_PosixError(interp), NULL); return TCL_ERROR; } Tcl_DStringFree(&buffer); Index: unix/tclUnixThrd.c ================================================================== --- unix/tclUnixThrd.c +++ unix/tclUnixThrd.c @@ -11,186 +11,47 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" -#if TCL_THREADS - -/* - * TIP #509. Ensures that Tcl's mutexes are reentrant. - * - *---------------------------------------------------------------------- - * - * PMutexInit -- - * - * Sets up the memory pointed to by its argument so that it contains the - * implementation of a recursive lock. Caller supplies the space. - * - *---------------------------------------------------------------------- - * - * PMutexDestroy -- - * - * Tears down the implementation of a recursive lock (but does not - * deallocate the space holding the lock). - * - *---------------------------------------------------------------------- - * - * PMutexLock -- - * - * Locks a recursive lock. (Similar to pthread_mutex_lock) - * - *---------------------------------------------------------------------- - * - * PMutexUnlock -- - * - * Unlocks a recursive lock. (Similar to pthread_mutex_unlock) - * - *---------------------------------------------------------------------- - * - * PCondWait -- - * - * Waits on a condition variable linked a recursive lock. (Similar to - * pthread_cond_wait) - * - *---------------------------------------------------------------------- - * - * PCondTimedWait -- - * - * Waits for a limited amount of time on a condition variable linked to a - * recursive lock. (Similar to pthread_cond_timedwait) - * - *---------------------------------------------------------------------- - */ - -#ifndef HAVE_DECL_PTHREAD_MUTEX_RECURSIVE -#define HAVE_DECL_PTHREAD_MUTEX_RECURSIVE 0 -#endif - -#if HAVE_DECL_PTHREAD_MUTEX_RECURSIVE -/* - * Pthread has native reentrant (AKA recursive) mutexes. Use them for - * Tcl_Mutex. - */ - -typedef pthread_mutex_t PMutex; - -static void -PMutexInit( - PMutex *pmutexPtr) -{ - pthread_mutexattr_t attr; - - pthread_mutexattr_init(&attr); - pthread_mutexattr_settype(&attr, PTHREAD_MUTEX_RECURSIVE); - pthread_mutex_init(pmutexPtr, &attr); -} - -#define PMutexDestroy pthread_mutex_destroy -#define PMutexLock pthread_mutex_lock -#define PMutexUnlock pthread_mutex_unlock -#define PCondWait pthread_cond_wait -#define PCondTimedWait pthread_cond_timedwait - -#else /* !HAVE_PTHREAD_MUTEX_RECURSIVE */ - -/* - * No native support for reentrant mutexes. Emulate them with regular mutexes - * and thread-local counters. - */ - -typedef struct PMutex { - pthread_mutex_t mutex; - pthread_t thread; - int counter; -} PMutex; - -static void -PMutexInit( - PMutex *pmutexPtr) -{ - pthread_mutex_init(&pmutexPtr->mutex, NULL); - pmutexPtr->thread = 0; - pmutexPtr->counter = 0; -} - -static void -PMutexDestroy( - PMutex *pmutexPtr) -{ - pthread_mutex_destroy(&pmutexPtr->mutex); -} - -static void -PMutexLock( - PMutex *pmutexPtr) -{ - if (pmutexPtr->thread != pthread_self() || pmutexPtr->counter == 0) { - pthread_mutex_lock(&pmutexPtr->mutex); - pmutexPtr->thread = pthread_self(); - pmutexPtr->counter = 0; - } - pmutexPtr->counter++; -} - -static void -PMutexUnlock( - PMutex *pmutexPtr) -{ - pmutexPtr->counter--; - if (pmutexPtr->counter == 0) { - pmutexPtr->thread = 0; - pthread_mutex_unlock(&pmutexPtr->mutex); - } -} - -static void -PCondWait( - pthread_cond_t *pcondPtr, - PMutex *pmutexPtr) -{ - pthread_cond_wait(pcondPtr, &pmutexPtr->mutex); -} - -static void -PCondTimedWait( - pthread_cond_t *pcondPtr, - PMutex *pmutexPtr, - struct timespec *ptime) -{ - pthread_cond_timedwait(pcondPtr, &pmutexPtr->mutex, ptime); -} -#endif /* HAVE_PTHREAD_MUTEX_RECURSIVE */ - -/* - * masterLock is used to serialize creation of mutexes, condition variables, +#ifdef TCL_THREADS + +typedef struct ThreadSpecificData { + char nabuf[16]; +} ThreadSpecificData; + +static Tcl_ThreadDataKey dataKey; + +/* + * globalLock is used to serialize creation of mutexes, condition variables, * and thread local storage. This is the only place that can count on the * ability to statically initialize the mutex. */ -static pthread_mutex_t masterLock = PTHREAD_MUTEX_INITIALIZER; +static pthread_mutex_t globalLock = PTHREAD_MUTEX_INITIALIZER; /* * initLock is used to serialize initialization and finalization of Tcl. It - * cannot use any dyamically allocated storage. + * cannot use any dynamically allocated storage. */ static pthread_mutex_t initLock = PTHREAD_MUTEX_INITIALIZER; /* * allocLock is used by Tcl's version of malloc for synchronization. For - * obvious reasons, cannot use any dyamically allocated storage. + * obvious reasons, cannot use any dynamically allocated storage. + */ + +static pthread_mutex_t allocLock = PTHREAD_MUTEX_INITIALIZER; +static pthread_mutex_t *allocLockPtr = &allocLock; + +/* + * These are for the critical sections inside this file. */ -static PMutex allocLock; -static pthread_once_t allocLockInitOnce = PTHREAD_ONCE_INIT; - -static void -allocLockInit(void) -{ - PMutexInit(&allocLock); -} -static PMutex *allocLockPtr = &allocLock; +#define GLOBAL_LOCK pthread_mutex_lock(&globalLock) +#define GLOBAL_UNLOCK pthread_mutex_unlock(&globalLock) #endif /* TCL_THREADS */ /* *---------------------------------------------------------------------- @@ -212,15 +73,15 @@ int TclpThreadCreate( Tcl_ThreadId *idPtr, /* Return, the ID of the thread */ Tcl_ThreadCreateProc *proc, /* Main() function of the thread */ ClientData clientData, /* The one argument to Main() */ - size_t stackSize, /* Size of stack for the new thread */ + int stackSize, /* Size of stack for the new thread */ int flags) /* Flags controlling behaviour of the new * thread. */ { -#if TCL_THREADS +#ifdef TCL_THREADS pthread_attr_t attr; pthread_t theThread; int result; pthread_attr_init(&attr); @@ -256,16 +117,16 @@ if (!(flags & TCL_THREAD_JOINABLE)) { pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED); } if (pthread_create(&theThread, &attr, - (void * (*)(void *)) proc, (void *) clientData) && + (void * (*)(void *))(void *)proc, (void *)clientData) && pthread_create(&theThread, NULL, - (void * (*)(void *)) proc, (void *) clientData)) { + (void * (*)(void *))(void *)proc, (void *)clientData)) { result = TCL_ERROR; } else { - *idPtr = (Tcl_ThreadId) theThread; + *idPtr = (Tcl_ThreadId)theThread; result = TCL_OK; } pthread_attr_destroy(&attr); return result; #else @@ -294,11 +155,11 @@ Tcl_ThreadId threadId, /* Id of the thread to wait upon. */ int *state) /* Reference to the storage the result of the * thread we wait upon will be written into. * May be NULL. */ { -#if TCL_THREADS +#ifdef TCL_THREADS int result; unsigned long retcode, *retcodePtr = &retcode; result = pthread_join((pthread_t) threadId, (void**) retcodePtr); if (state) { @@ -308,10 +169,11 @@ #else return TCL_ERROR; #endif } +#ifdef TCL_THREADS /* *---------------------------------------------------------------------- * * TclpThreadExit -- * @@ -328,16 +190,13 @@ void TclpThreadExit( int status) { -#if TCL_THREADS pthread_exit(INT2PTR(status)); -#else /* TCL_THREADS */ - exit(status); -#endif /* TCL_THREADS */ } +#endif /* TCL_THREADS */ /* *---------------------------------------------------------------------- * * Tcl_GetCurrentThread -- @@ -354,11 +213,11 @@ */ Tcl_ThreadId Tcl_GetCurrentThread(void) { -#if TCL_THREADS +#ifdef TCL_THREADS return (Tcl_ThreadId) pthread_self(); #else return (Tcl_ThreadId) 0; #endif } @@ -383,11 +242,11 @@ */ void TclpInitLock(void) { -#if TCL_THREADS +#ifdef TCL_THREADS pthread_mutex_lock(&initLock); #endif } /* @@ -409,15 +268,15 @@ */ void TclFinalizeLock(void) { -#if TCL_THREADS +#ifdef TCL_THREADS /* * You do not need to destroy mutexes that were created with the * PTHREAD_MUTEX_INITIALIZER macro. These mutexes do not need any - * destruction: masterLock, allocLock, and initLock. + * destruction: globalLock, allocLock, and initLock. */ pthread_mutex_unlock(&initLock); #endif } @@ -440,19 +299,19 @@ */ void TclpInitUnlock(void) { -#if TCL_THREADS +#ifdef TCL_THREADS pthread_mutex_unlock(&initLock); #endif } /* *---------------------------------------------------------------------- * - * TclpMasterLock + * TclpGlobalLock * * This procedure is used to grab a lock that serializes creation and * finalization of serialization objects. This interface is only needed * in finalization; it is hidden during creation of the objects. * @@ -461,55 +320,55 @@ * * Results: * None. * * Side effects: - * Acquire the master mutex. + * Acquire the global mutex. * *---------------------------------------------------------------------- */ void -TclpMasterLock(void) +TclpGlobalLock(void) { -#if TCL_THREADS - pthread_mutex_lock(&masterLock); +#ifdef TCL_THREADS + pthread_mutex_lock(&globalLock); #endif } /* *---------------------------------------------------------------------- * - * TclpMasterUnlock + * TclpGlobalUnlock * * This procedure is used to release a lock that serializes creation and * finalization of synchronization objects. * * Results: * None. * * Side effects: - * Release the master mutex. + * Release the global mutex. * *---------------------------------------------------------------------- */ void -TclpMasterUnlock(void) +TclpGlobalUnlock(void) { -#if TCL_THREADS - pthread_mutex_unlock(&masterLock); +#ifdef TCL_THREADS + pthread_mutex_unlock(&globalLock); #endif } /* *---------------------------------------------------------------------- * * Tcl_GetAllocMutex * * This procedure returns a pointer to a statically initialized mutex for - * use by the memory allocator. The alloctor must use this lock, because + * use by the memory allocator. The allocator must use this lock, because * all other locks are allocated... * * Results: * A pointer to a mutex that is suitable for passing to Tcl_MutexLock and * Tcl_MutexUnlock. @@ -521,21 +380,19 @@ */ Tcl_Mutex * Tcl_GetAllocMutex(void) { -#if TCL_THREADS - PMutex **allocLockPtrPtr = &allocLockPtr; - - pthread_once(&allocLockInitOnce, allocLockInit); +#ifdef TCL_THREADS + pthread_mutex_t **allocLockPtrPtr = &allocLockPtr; return (Tcl_Mutex *) allocLockPtrPtr; #else return NULL; #endif } -#if TCL_THREADS +#ifdef TCL_THREADS /* *---------------------------------------------------------------------- * * Tcl_MutexLock -- @@ -556,30 +413,30 @@ *---------------------------------------------------------------------- */ void Tcl_MutexLock( - Tcl_Mutex *mutexPtr) /* Really (PMutex **) */ + Tcl_Mutex *mutexPtr) /* Really (pthread_mutex_t **) */ { - PMutex *pmutexPtr; + pthread_mutex_t *pmutexPtr; if (*mutexPtr == NULL) { - pthread_mutex_lock(&masterLock); + GLOBAL_LOCK; if (*mutexPtr == NULL) { /* - * Double inside master lock check to avoid a race condition. + * Double inside global lock check to avoid a race condition. */ - pmutexPtr = Tcl_Alloc(sizeof(PMutex)); - PMutexInit(pmutexPtr); - *mutexPtr = (Tcl_Mutex) pmutexPtr; + pmutexPtr = (pthread_mutex_t *)ckalloc(sizeof(pthread_mutex_t)); + pthread_mutex_init(pmutexPtr, NULL); + *mutexPtr = (Tcl_Mutex)pmutexPtr; TclRememberMutex(mutexPtr); } - pthread_mutex_unlock(&masterLock); + GLOBAL_UNLOCK; } - pmutexPtr = *((PMutex **) mutexPtr); - PMutexLock(pmutexPtr); + pmutexPtr = *((pthread_mutex_t **)mutexPtr); + pthread_mutex_lock(pmutexPtr); } /* *---------------------------------------------------------------------- * @@ -597,15 +454,15 @@ *---------------------------------------------------------------------- */ void Tcl_MutexUnlock( - Tcl_Mutex *mutexPtr) /* Really (PMutex **) */ + Tcl_Mutex *mutexPtr) /* Really (pthread_mutex_t **) */ { - PMutex *pmutexPtr = *(PMutex **) mutexPtr; + pthread_mutex_t *pmutexPtr = *(pthread_mutex_t **) mutexPtr; - PMutexUnlock(pmutexPtr); + pthread_mutex_unlock(pmutexPtr); } /* *---------------------------------------------------------------------- * @@ -612,11 +469,11 @@ * TclpFinalizeMutex -- * * This procedure is invoked to clean up one mutex. This is only safe to * call at the end of time. * - * This assumes the Master Lock is held. + * This assumes the Global Lock is held. * * Results: * None. * * Side effects: @@ -627,15 +484,15 @@ void TclpFinalizeMutex( Tcl_Mutex *mutexPtr) { - PMutex *pmutexPtr = *(PMutex **) mutexPtr; + pthread_mutex_t *pmutexPtr = *(pthread_mutex_t **) mutexPtr; if (pmutexPtr != NULL) { - PMutexDestroy(pmutexPtr); - Tcl_Free(pmutexPtr); + pthread_mutex_destroy(pmutexPtr); + ckfree(pmutexPtr); *mutexPtr = NULL; } } /* @@ -661,37 +518,37 @@ */ void Tcl_ConditionWait( Tcl_Condition *condPtr, /* Really (pthread_cond_t **) */ - Tcl_Mutex *mutexPtr, /* Really (PMutex **) */ + Tcl_Mutex *mutexPtr, /* Really (pthread_mutex_t **) */ const Tcl_Time *timePtr) /* Timeout on waiting period */ { pthread_cond_t *pcondPtr; - PMutex *pmutexPtr; + pthread_mutex_t *pmutexPtr; struct timespec ptime; if (*condPtr == NULL) { - pthread_mutex_lock(&masterLock); + GLOBAL_LOCK; /* * Double check inside mutex to avoid race, then initialize condition * variable if necessary. */ if (*condPtr == NULL) { - pcondPtr = Tcl_Alloc(sizeof(pthread_cond_t)); + pcondPtr = (pthread_cond_t *)ckalloc(sizeof(pthread_cond_t)); pthread_cond_init(pcondPtr, NULL); *condPtr = (Tcl_Condition) pcondPtr; TclRememberCondition(condPtr); } - pthread_mutex_unlock(&masterLock); + GLOBAL_UNLOCK; } - pmutexPtr = *((PMutex **) mutexPtr); - pcondPtr = *((pthread_cond_t **) condPtr); + pmutexPtr = *((pthread_mutex_t **)mutexPtr); + pcondPtr = *((pthread_cond_t **)condPtr); if (timePtr == NULL) { - PCondWait(pcondPtr, pmutexPtr); + pthread_cond_wait(pcondPtr, pmutexPtr); } else { Tcl_Time now; /* * Make sure to take into account the microsecond component of the @@ -700,11 +557,11 @@ Tcl_GetTime(&now); ptime.tv_sec = timePtr->sec + now.sec + (timePtr->usec + now.usec) / 1000000; ptime.tv_nsec = 1000 * ((timePtr->usec + now.usec) % 1000000); - PCondTimedWait(pcondPtr, pmutexPtr, &ptime); + pthread_cond_timedwait(pcondPtr, pmutexPtr, &ptime); } } /* *---------------------------------------------------------------------- @@ -727,11 +584,11 @@ void Tcl_ConditionNotify( Tcl_Condition *condPtr) { - pthread_cond_t *pcondPtr = *((pthread_cond_t **) condPtr); + pthread_cond_t *pcondPtr = *((pthread_cond_t **)condPtr); if (pcondPtr != NULL) { pthread_cond_broadcast(pcondPtr); } else { /* @@ -746,11 +603,11 @@ * TclpFinalizeCondition -- * * This procedure is invoked to clean up a condition variable. This is * only safe to call at the end of time. * - * This assumes the Master Lock is held. + * This assumes the Global Lock is held. * * Results: * None. * * Side effects: @@ -761,66 +618,107 @@ void TclpFinalizeCondition( Tcl_Condition *condPtr) { - pthread_cond_t *pcondPtr = *(pthread_cond_t **) condPtr; + pthread_cond_t *pcondPtr = *(pthread_cond_t **)condPtr; if (pcondPtr != NULL) { pthread_cond_destroy(pcondPtr); - Tcl_Free(pcondPtr); + ckfree(pcondPtr); *condPtr = NULL; } } +#endif /* TCL_THREADS */ + +/* + *---------------------------------------------------------------------- + * + * TclpReaddir, TclpInetNtoa -- + * + * These procedures replace core C versions to be used in a threaded + * environment. + * + * Results: + * See documentation of C functions. + * + * Side effects: + * See documentation of C functions. + * + * Notes: + * TclpReaddir is no longer used by the core (see 1095909), but it + * appears in the internal stubs table (see #589526). + * + *---------------------------------------------------------------------- + */ + +Tcl_DirEntry * +TclpReaddir( + TclDIR * dir) +{ + return TclOSreaddir(dir); +} + +#undef TclpInetNtoa +char * +TclpInetNtoa( + struct in_addr addr) +{ +#ifdef TCL_THREADS + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + unsigned char *b = (unsigned char*) &addr.s_addr; + + sprintf(tsdPtr->nabuf, "%u.%u.%u.%u", b[0], b[1], b[2], b[3]); + return tsdPtr->nabuf; +#else + return inet_ntoa(addr); +#endif +} +#ifdef TCL_THREADS /* * Additions by AOL for specialized thread memory allocator. */ #ifdef USE_THREAD_ALLOC +static volatile int initialized = 0; static pthread_key_t key; typedef struct { Tcl_Mutex tlock; - PMutex plock; + pthread_mutex_t plock; } AllocMutex; Tcl_Mutex * TclpNewAllocMutex(void) { AllocMutex *lockPtr; - register PMutex *plockPtr; + pthread_mutex_t *plockPtr; - lockPtr = malloc(sizeof(AllocMutex)); + lockPtr = (AllocMutex *)malloc(sizeof(AllocMutex)); if (lockPtr == NULL) { Tcl_Panic("could not allocate lock"); } plockPtr = &lockPtr->plock; lockPtr->tlock = (Tcl_Mutex) plockPtr; - PMutexInit(&lockPtr->plock); + pthread_mutex_init(&lockPtr->plock, NULL); return &lockPtr->tlock; } void TclpFreeAllocMutex( Tcl_Mutex *mutex) /* The alloc mutex to free. */ { - AllocMutex *lockPtr = (AllocMutex *) mutex; + AllocMutex *lockPtr = (AllocMutex *)mutex; if (!lockPtr) { return; } - PMutexDestroy(&lockPtr->plock); + pthread_mutex_destroy(&lockPtr->plock); free(lockPtr); } -void -TclpInitAllocCache(void) -{ - pthread_key_create(&key, NULL); -} - void TclpFreeAllocCache( void *ptr) { if (ptr != NULL) { @@ -830,23 +728,32 @@ */ TclFreeAllocCache(ptr); pthread_setspecific(key, NULL); - } else { + } else if (initialized) { /* * Called by TclFinalizeThreadAlloc() during the process * finalization initiated from Tcl_Finalize() */ pthread_key_delete(key); + initialized = 0; } } void * TclpGetAllocCache(void) { + if (!initialized) { + pthread_mutex_lock(allocLockPtr); + if (!initialized) { + pthread_key_create(&key, NULL); + initialized = 1; + } + pthread_mutex_unlock(allocLockPtr); + } return pthread_getspecific(key); } void TclpSetAllocCache( @@ -859,11 +766,11 @@ void * TclpThreadCreateKey(void) { pthread_key_t *ptkeyPtr; - ptkeyPtr = TclpSysAlloc(sizeof(pthread_key_t)); + ptkeyPtr = (pthread_key_t *)TclpSysAlloc(sizeof(pthread_key_t), 0); if (NULL == ptkeyPtr) { Tcl_Panic("unable to allocate thread key!"); } if (pthread_key_create(ptkeyPtr, NULL)) { @@ -875,36 +782,36 @@ void TclpThreadDeleteKey( void *keyPtr) { - pthread_key_t *ptkeyPtr = keyPtr; + pthread_key_t *ptkeyPtr = (pthread_key_t *)keyPtr; if (pthread_key_delete(*ptkeyPtr)) { Tcl_Panic("unable to delete key!"); } TclpSysFree(keyPtr); } void -TclpThreadSetMasterTSD( +TclpThreadSetGlobalTSD( void *tsdKeyPtr, void *ptr) { - pthread_key_t *ptkeyPtr = tsdKeyPtr; + pthread_key_t *ptkeyPtr = (pthread_key_t *)tsdKeyPtr; if (pthread_setspecific(*ptkeyPtr, ptr)) { - Tcl_Panic("unable to set master TSD value"); + Tcl_Panic("unable to set global TSD value"); } } void * -TclpThreadGetMasterTSD( +TclpThreadGetGlobalTSD( void *tsdKeyPtr) { - pthread_key_t *ptkeyPtr = tsdKeyPtr; + pthread_key_t *ptkeyPtr = (pthread_key_t *)tsdKeyPtr; return pthread_getspecific(*ptkeyPtr); } #endif /* TCL_THREADS */ ADDED unix/tclUnixThrd.h Index: unix/tclUnixThrd.h ================================================================== --- /dev/null +++ unix/tclUnixThrd.h @@ -0,0 +1,19 @@ +/* + * tclUnixThrd.h -- + * + * This header file defines things for thread support. + * + * Copyright (c) 1998 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#ifndef _TCLUNIXTHRD +#define _TCLUNIXTHRD + +#ifdef TCL_THREADS + + +#endif /* TCL_THREADS */ +#endif /* _TCLUNIXTHRD */ Index: unix/tclUnixTime.c ================================================================== --- unix/tclUnixTime.c +++ unix/tclUnixTime.c @@ -14,14 +14,39 @@ #include #if defined(TCL_WIDE_CLICKS) && defined(MAC_OSX_TCL) #include #endif +/* + * TclpGetDate is coded to return a pointer to a 'struct tm'. For thread + * safety, this structure must be in thread-specific data. The 'tmKey' + * variable is the key to this buffer. + */ + +static Tcl_ThreadDataKey tmKey; +typedef struct ThreadSpecificData { + struct tm gmtime_buf; + struct tm localtime_buf; +} ThreadSpecificData; + +/* + * If we fall back on the thread-unsafe versions of gmtime and localtime, use + * this mutex to try to protect them. + */ + +TCL_DECLARE_MUTEX(tmMutex) + +static char *lastTZ = NULL; /* Holds the last setting of the TZ + * environment variable, or an empty string if + * the variable was not set. */ + /* * Static functions declared in this file. */ +static void SetTZIfNecessary(void); +static void CleanupMemory(ClientData clientData); static void NativeScaleTime(Tcl_Time *timebuf, ClientData clientData); static void NativeGetTime(Tcl_Time *timebuf, ClientData clientData); @@ -48,11 +73,11 @@ * None. * *---------------------------------------------------------------------- */ -Tcl_WideUInt +unsigned long TclpGetSeconds(void) { return time(NULL); } @@ -88,11 +113,11 @@ * TclpGetClicks -- * * This procedure returns a value that represents the highest resolution * clock available on the system. There are no garantees on what the * resolution will be. In Tcl we will call this value a "click". The - * start time is also system dependant. + * start time is also system dependent. * * Results: * Number of clicks from some start time. * * Side effects: @@ -99,34 +124,34 @@ * None. * *---------------------------------------------------------------------- */ -Tcl_WideUInt +unsigned long TclpGetClicks(void) { - Tcl_WideUInt now; + unsigned long now; #ifdef NO_GETTOD if (tclGetTimeProcPtr != NativeGetTime) { Tcl_Time time; tclGetTimeProcPtr(&time, tclTimeClientData); - now = (Tcl_WideUInt)time.sec*1000000 + time.usec; + now = time.sec*1000000 + time.usec; } else { /* * A semi-NativeGetTime, specialized to clicks. */ struct tms dummy; - now = (Tcl_WideUInt) times(&dummy); + now = (unsigned long) times(&dummy); } #else Tcl_Time time; tclGetTimeProcPtr(&time, tclTimeClientData); - now = (Tcl_WideUInt)time.sec*1000000 + time.usec; + now = time.sec*1000000 + time.usec; #endif return now; } #ifdef TCL_WIDE_CLICKS @@ -135,11 +160,11 @@ *---------------------------------------------------------------------- * * TclpGetWideClicks -- * * This procedure returns a WideInt value that represents the highest - * resolution clock available on the system. There are no guarantees on + * resolution clock available on the system. There are no garantees on * what the resolution will be. In Tcl we will call this value a "click". * The start time is also system dependent. * * Results: * Number of WideInt clicks from some start time. @@ -292,10 +317,118 @@ } /* *---------------------------------------------------------------------- * + * TclpGetDate -- + * + * This function converts between seconds and struct tm. If useGMT is + * true, then the returned date will be in Greenwich Mean Time (GMT). + * Otherwise, it will be in the local time zone. + * + * Results: + * Returns a static tm structure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +struct tm * +TclpGetDate( + const time_t *time, + int useGMT) +{ + if (useGMT) { + return TclpGmtime(time); + } else { + return TclpLocaltime(time); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclpGmtime -- + * + * Wrapper around the 'gmtime' library function to make it thread safe. + * + * Results: + * Returns a pointer to a 'struct tm' in thread-specific data. + * + * Side effects: + * Invokes gmtime or gmtime_r as appropriate. + * + *---------------------------------------------------------------------- + */ + +struct tm * +TclpGmtime( + const time_t *timePtr) /* Pointer to the number of seconds since the + * local system's epoch */ +{ + /* + * Get a thread-local buffer to hold the returned time. + */ + + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tmKey); + +#ifdef HAVE_GMTIME_R + gmtime_r(timePtr, &tsdPtr->gmtime_buf); +#else + Tcl_MutexLock(&tmMutex); + memcpy(&tsdPtr->gmtime_buf, gmtime(timePtr), sizeof(struct tm)); + Tcl_MutexUnlock(&tmMutex); +#endif + + return &tsdPtr->gmtime_buf; +} + +/* + *---------------------------------------------------------------------- + * + * TclpLocaltime -- + * + * Wrapper around the 'localtime' library function to make it thread + * safe. + * + * Results: + * Returns a pointer to a 'struct tm' in thread-specific data. + * + * Side effects: + * Invokes localtime or localtime_r as appropriate. + * + *---------------------------------------------------------------------- + */ + +struct tm * +TclpLocaltime( + const time_t *timePtr) /* Pointer to the number of seconds since the + * local system's epoch */ +{ + /* + * Get a thread-local buffer to hold the returned time. + */ + + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tmKey); + + SetTZIfNecessary(); +#ifdef HAVE_LOCALTIME_R + localtime_r(timePtr, &tsdPtr->localtime_buf); +#else + Tcl_MutexLock(&tmMutex); + memcpy(&tsdPtr->localtime_buf, localtime(timePtr), sizeof(struct tm)); + Tcl_MutexUnlock(&tmMutex); +#endif + + return &tsdPtr->localtime_buf; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_SetTimeProc -- * * TIP #233 (Virtualized Time): Registers two handlers for the * virtualization of Tcl's access to time information. * @@ -403,13 +536,77 @@ (void) gettimeofday(&tv, NULL); timePtr->sec = tv.tv_sec; timePtr->usec = tv.tv_usec; } +/* + *---------------------------------------------------------------------- + * + * SetTZIfNecessary -- + * + * Determines whether a call to 'tzset' is needed prior to the next call + * to 'localtime' or examination of the 'timezone' variable. + * + * Results: + * None. + * + * Side effects: + * If 'tzset' has never been called in the current process, or if the + * value of the environment variable TZ has changed since the last call + * to 'tzset', then 'tzset' is called again. + * + *---------------------------------------------------------------------- + */ + +static void +SetTZIfNecessary(void) +{ + const char *newTZ = getenv("TZ"); + + Tcl_MutexLock(&tmMutex); + if (newTZ == NULL) { + newTZ = ""; + } + if (lastTZ == NULL || strcmp(lastTZ, newTZ)) { + tzset(); + if (lastTZ == NULL) { + Tcl_CreateExitHandler(CleanupMemory, NULL); + } else { + ckfree(lastTZ); + } + lastTZ = ckalloc(strlen(newTZ) + 1); + strcpy(lastTZ, newTZ); + } + Tcl_MutexUnlock(&tmMutex); +} + +/* + *---------------------------------------------------------------------- + * + * CleanupMemory -- + * + * Releases the private copy of the TZ environment variable upon exit + * from Tcl. + * + * Results: + * None. + * + * Side effects: + * Frees allocated memory. + * + *---------------------------------------------------------------------- + */ + +static void +CleanupMemory( + ClientData ignored) +{ + ckfree(lastTZ); +} /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: unix/tclXtNotify.c ================================================================== --- unix/tclXtNotify.c +++ unix/tclXtNotify.c @@ -40,11 +40,11 @@ /* * The following structure is what is added to the Tcl event queue when file * handlers are ready to fire. */ -typedef struct { +typedef struct FileHandlerEvent { Tcl_Event header; /* Information that is standard for all * events. */ int fd; /* File descriptor that is ready. Used to find * the FileHandler structure for the file * (can't point directly to the FileHandler @@ -266,11 +266,11 @@ static void SetTimer( const Tcl_Time *timePtr) /* Timeout value, may be NULL. */ { - unsigned long timeout; + long timeout; if (!initialized) { InitNotifier(); } @@ -279,11 +279,11 @@ XtRemoveTimeOut(notifier.currentTimeout); } if (timePtr) { timeout = timePtr->sec * 1000 + timePtr->usec / 1000; notifier.currentTimeout = XtAppAddTimeOut(notifier.appContext, - timeout, TimerProc, NULL); + (unsigned long) timeout, TimerProc, NULL); } else { notifier.currentTimeout = 0; } } @@ -357,11 +357,11 @@ if (filePtr->fd == fd) { break; } } if (filePtr == NULL) { - filePtr = Tcl_Alloc(sizeof(FileHandler)); + filePtr = ckalloc(sizeof(FileHandler)); filePtr->fd = fd; filePtr->read = 0; filePtr->write = 0; filePtr->except = 0; filePtr->readyMask = 0; @@ -468,11 +468,11 @@ XtRemoveInput(filePtr->write); } if (filePtr->mask & TCL_EXCEPTION) { XtRemoveInput(filePtr->except); } - Tcl_Free(filePtr); + ckfree(filePtr); } /* *---------------------------------------------------------------------- * @@ -523,11 +523,11 @@ /* * This is an interesting event, so put it onto the event queue. */ filePtr->readyMask |= mask; - fileEvPtr = Tcl_Alloc(sizeof(FileHandlerEvent)); + fileEvPtr = ckalloc(sizeof(FileHandlerEvent)); fileEvPtr->header.proc = FileHandlerEventProc; fileEvPtr->fd = filePtr->fd; Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL); /* Index: unix/tclXtTest.c ================================================================== --- unix/tclXtTest.c +++ unix/tclXtTest.c @@ -46,11 +46,11 @@ int Tclxttest_Init( Tcl_Interp *interp) /* Interpreter for application. */ { - if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { + if (Tcl_InitStubs(interp, "8.1", 0) == NULL) { return TCL_ERROR; } XtToolkitInitialize(); InitNotifier(); Tcl_CreateObjCommand(interp, "testeventloop", TesteventloopCmd, Index: unix/tclooConfig.sh ================================================================== --- unix/tclooConfig.sh +++ unix/tclooConfig.sh @@ -14,6 +14,6 @@ TCLOO_LIB_SPEC="" TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS="" -TCLOO_VERSION=1.2.0 +TCLOO_VERSION=1.1.0 Index: win/Makefile.in ================================================================== --- win/Makefile.in +++ win/Makefile.in @@ -21,10 +21,11 @@ exec_prefix = @exec_prefix@ bindir = @bindir@ libdir = @libdir@ includedir = @includedir@ datarootdir = @datarootdir@ +runstatedir = @runstatedir@ mandir = @mandir@ # The following definition can be set to non-null for special systems like AFS # with replication. It allows the pathnames used for installation to be # different than those used for actually reference files at run-time. @@ -46,10 +47,13 @@ LIB_INSTALL_DIR = $(INSTALL_ROOT)$(libdir) # Path name to use when installing library scripts. SCRIPT_INSTALL_DIR = $(INSTALL_ROOT)$(TCL_LIBRARY) +# Path name to use when installing Tcl modules. +MODULE_INSTALL_DIR = $(SCRIPT_INSTALL_DIR)/../tcl8 + # Directory in which to install the include file tcl.h: INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) # Directory in which to (optionally) install the private tcl headers: PRIVATE_INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) @@ -79,11 +83,11 @@ # To change the compiler switches, for example to change from optimization to # debugging symbols, change the following line: #CFLAGS = $(CFLAGS_DEBUG) #CFLAGS = $(CFLAGS_OPTIMIZE) #CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE) -CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@ -DUNICODE -D_UNICODE -D_ATL_XP_TARGETING +CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@ -D_ATL_XP_TARGETING=1 -D__USE_MINGW_ANSI_STDIO=0 -DMP_FIXED_CUTOFFS -DMP_NO_STDINT # To compile without backward compatibility and deprecated code uncomment the # following NO_DEPRECATED_FLAGS = #NO_DEPRECATED_FLAGS = -DTCL_NO_DEPRECATED @@ -94,11 +98,11 @@ #COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_DEBUG #COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS SRC_DIR = @srcdir@ ROOT_DIR = @srcdir@/.. -TOP_DIR = $(shell cd @srcdir@/..; pwd -P) +TOP_DIR = $(shell cd @srcdir@/..; pwd -W 2>/dev/null || pwd -P) GENERIC_DIR = $(TOP_DIR)/generic TOMMATH_DIR = $(TOP_DIR)/libtommath WIN_DIR = $(TOP_DIR)/win COMPAT_DIR = $(TOP_DIR)/compat PKGS_DIR = $(TOP_DIR)/pkgs @@ -114,11 +118,14 @@ TCL_LIBRARY_NATIVE = $(shell $(CYGPATH) '$(TCL_LIBRARY)') GENERIC_DIR_NATIVE = $(shell $(CYGPATH) '$(GENERIC_DIR)') TOMMATH_DIR_NATIVE = $(shell $(CYGPATH) '$(TOMMATH_DIR)') WIN_DIR_NATIVE = $(shell $(CYGPATH) '$(WIN_DIR)') ROOT_DIR_NATIVE = $(shell $(CYGPATH) '$(ROOT_DIR)') -ROOT_DIR_WIN_NATIVE = $(shell cd '$(ROOT_DIR)' ; pwd -W || pwd -P) +SCRIPT_INSTALL_DIR_NATIVE = $(shell $(CYGPATH) '$(SCRIPT_INSTALL_DIR)') +INCLUDE_INSTALL_DIR_NATIVE = $(shell $(CYGPATH) '$(INCLUDE_INSTALL_DIR)') +MAN_INSTALL_DIR_NATIVE = $(shell $(CYGPATH) '$(MAN_INSTALL_DIR)') +ROOT_DIR_WIN_NATIVE = $(shell cd '$(ROOT_DIR)' ; pwd -W 2>/dev/null || pwd -P) ZLIB_DIR_NATIVE = $(shell $(CYGPATH) '$(ZLIB_DIR)') #GENERIC_DIR_NATIVE = $(GENERIC_DIR) #TOMMATH_DIR_NATIVE = $(TOMMATH_DIR) #WIN_DIR_NATIVE = $(WIN_DIR) #ROOT_DIR_NATIVE = $(ROOT_DIR) @@ -135,38 +142,31 @@ DOTVER = @TCL_MAJOR_VERSION@.@TCL_MINOR_VERSION@ DDEVER = @TCL_DDE_MAJOR_VERSION@@TCL_DDE_MINOR_VERSION@ DDEDOTVER = @TCL_DDE_MAJOR_VERSION@.@TCL_DDE_MINOR_VERSION@ REGVER = @TCL_REG_MAJOR_VERSION@@TCL_REG_MINOR_VERSION@ REGDOTVER = @TCL_REG_MAJOR_VERSION@.@TCL_REG_MINOR_VERSION@ - -TCL_ZIP_FILE = @TCL_ZIP_FILE@ -TCL_VFS_PATH = libtcl.vfs/tcl_library -TCL_VFS_ROOT = libtcl.vfs - TCL_STUB_LIB_FILE = @TCL_STUB_LIB_FILE@ TCL_DLL_FILE = @TCL_DLL_FILE@ TCL_LIB_FILE = @TCL_LIB_FILE@ DDE_DLL_FILE = tcldde$(DDEVER)${DLLSUFFIX} -DDE_LIB_FILE = @LIBPREFIX@tcldde$(DDEVER)${LIBSUFFIX} +DDE_LIB_FILE = @LIBPREFIX@tcldde$(DDEVER)${DLLSUFFIX}${LIBSUFFIX} REG_DLL_FILE = tclreg$(REGVER)${DLLSUFFIX} -REG_LIB_FILE = @LIBPREFIX@tclreg$(REGVER)${LIBSUFFIX} +REG_LIB_FILE = @LIBPREFIX@tclreg$(REGVER)${DLLSUFFIX}${LIBSUFFIX} TEST_DLL_FILE = tcltest$(VER)${DLLSUFFIX} TEST_EXE_FILE = tcltest${EXESUFFIX} -TEST_LIB_FILE = @LIBPREFIX@tcltest$(VER)${LIBSUFFIX} -TEST_LOAD_PRMS = lappend ::auto_path {$(ROOT_DIR_WIN_NATIVE)/tests};\ - package ifneeded dde 1.4.1 [list load [file normalize ${DDE_DLL_FILE}] dde];\ - package ifneeded registry 1.3.3 [list load [file normalize ${REG_DLL_FILE}] registry] -TEST_LOAD_FACILITIES = package ifneeded Tcltest ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}] Tcltest];\ +TEST_LIB_FILE = @LIBPREFIX@tcltest$(VER)${DLLSUFFIX}${LIBSUFFIX} +TEST_LOAD_PRMS = package ifneeded dde 1.4.3 [list load [file normalize ${DDE_DLL_FILE}] Dde];\ + package ifneeded registry 1.3.5 [list load [file normalize ${REG_DLL_FILE}] Registry] +TEST_LOAD_FACILITIES = package ifneeded Tcltest ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}]];\ $(TEST_LOAD_PRMS) ZLIB_DLL_FILE = zlib1.dll SHARED_LIBRARIES = $(TCL_DLL_FILE) @ZLIB_DLL_FILE@ STATIC_LIBRARIES = $(TCL_LIB_FILE) TCLSH = tclsh$(VER)${EXESUFFIX} -WINE = @WINE@ CAT32 = cat32$(EXEEXT) MAN2TCL = man2tcl$(EXEEXT) # For cross-compiled builds, TCL_EXE is the name of a tclsh executable that is # available *BEFORE* running make for the first time. Certain build targets @@ -206,61 +206,21 @@ RMDIR = rm -rf MKDIR = mkdir -p SHELL = @SHELL@ RM = rm -f COPY = cp -LN = ln - -### -# Tip 430 - ZipFS Modifications -### - -TCL_ZIP_FILE = @TCL_ZIP_FILE@ -TCL_VFS_PATH = libtcl.vfs/tcl_library -TCL_VFS_ROOT = libtcl.vfs - -HOST_CC = @CC_FOR_BUILD@ -HOST_EXEEXT = @EXEEXT_FOR_BUILD@ -HOST_OBJEXT = @OBJEXT_FOR_BUILD@ -ZIPFS_BUILD = @ZIPFS_BUILD@ -NATIVE_ZIP = @ZIP_PROG@ -ZIP_PROG_OPTIONS = @ZIP_PROG_OPTIONS@ -ZIP_PROG_VFSSEARCH = @ZIP_PROG_VFSSEARCH@ -SHARED_BUILD = @SHARED_BUILD@ -INSTALL_MSGS = @INSTALL_MSGS@ -INSTALL_LIBRARIES = @INSTALL_LIBRARIES@ - -# Minizip -MINIZIP_OBJS = \ - adler32.$(HOST_OBJEXT) \ - compress.$(HOST_OBJEXT) \ - crc32.$(HOST_OBJEXT) \ - deflate.$(HOST_OBJEXT) \ - infback.$(HOST_OBJEXT) \ - inffast.$(HOST_OBJEXT) \ - inflate.$(HOST_OBJEXT) \ - inftrees.$(HOST_OBJEXT) \ - ioapi.$(HOST_OBJEXT) \ - iowin32.$(HOST_OBJEXT) \ - trees.$(HOST_OBJEXT) \ - uncompr.$(HOST_OBJEXT) \ - zip.$(HOST_OBJEXT) \ - zutil.$(HOST_OBJEXT) \ - minizip.$(HOST_OBJEXT) - -ZIP_INSTALL_OBJS = @ZIP_INSTALL_OBJS@ - -CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${TCL_SHLIB_CFLAGS} \ --I"${ZLIB_DIR_NATIVE}" -I"${GENERIC_DIR_NATIVE}" \ + +CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \ +-I"${ZLIB_DIR_NATIVE}" -I"${GENERIC_DIR_NATIVE}" -DTCL_TOMMATH \ -DMP_PREC=4 -I"${TOMMATH_DIR_NATIVE}" -I"${WIN_DIR_NATIVE}" \ ${AC_FLAGS} ${COMPILE_DEBUG_FLAGS} ${NO_DEPRECATED_FLAGS} CC_OBJNAME = @CC_OBJNAME@ CC_EXENAME = @CC_EXENAME@ STUB_CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \ --I"${GENERIC_DIR_NATIVE}" -DMP_PREC=4 -I"${TOMMATH_DIR_NATIVE}" \ +-I"${GENERIC_DIR_NATIVE}" -DTCL_TOMMATH -DMP_PREC=4 -I"${TOMMATH_DIR_NATIVE}" \ -I"${WIN_DIR_NATIVE}" ${AC_FLAGS} \ ${COMPILE_DEBUG_FLAGS} TCLTEST_OBJS = \ tclTest.$(OBJEXT) \ @@ -314,12 +274,12 @@ tclIOUtil.$(OBJEXT) \ tclLink.$(OBJEXT) \ tclLiteral.$(OBJEXT) \ tclListObj.$(OBJEXT) \ tclLoad.$(OBJEXT) \ + tclMainW.$(OBJEXT) \ tclMain.$(OBJEXT) \ - tclMain2.$(OBJEXT) \ tclNamesp.$(OBJEXT) \ tclNotify.$(OBJEXT) \ tclOO.$(OBJEXT) \ tclOOBasic.$(OBJEXT) \ tclOOCall.$(OBJEXT) \ @@ -336,11 +296,10 @@ tclPkg.$(OBJEXT) \ tclPkgConfig.$(OBJEXT) \ tclPosixStr.$(OBJEXT) \ tclPreserve.$(OBJEXT) \ tclProc.$(OBJEXT) \ - tclProcess.$(OBJEXT) \ tclRegexp.$(OBJEXT) \ tclResolve.$(OBJEXT) \ tclResult.$(OBJEXT) \ tclScan.$(OBJEXT) \ tclStringObj.$(OBJEXT) \ @@ -354,17 +313,13 @@ tclTomMathInterface.$(OBJEXT) \ tclTrace.$(OBJEXT) \ tclUtf.$(OBJEXT) \ tclUtil.$(OBJEXT) \ tclVar.$(OBJEXT) \ - tclZipfs.$(OBJEXT) \ tclZlib.$(OBJEXT) TOMMATH_OBJS = \ - bn_reverse.${OBJEXT} \ - bn_fast_s_mp_mul_digs.${OBJEXT} \ - bn_fast_s_mp_sqr.${OBJEXT} \ bn_mp_add.${OBJEXT} \ bn_mp_add_d.${OBJEXT} \ bn_mp_and.${OBJEXT} \ bn_mp_clamp.${OBJEXT} \ bn_mp_clear.${OBJEXT} \ @@ -379,25 +334,17 @@ bn_mp_div_d.${OBJEXT} \ bn_mp_div_2.${OBJEXT} \ bn_mp_div_2d.${OBJEXT} \ bn_mp_div_3.${OBJEXT} \ bn_mp_exch.${OBJEXT} \ - bn_mp_expt_d.${OBJEXT} \ - bn_mp_expt_d_ex.${OBJEXT} \ - bn_s_mp_get_bit.${OBJEXT} \ - bn_mp_get_int.${OBJEXT} \ - bn_mp_get_long.${OBJEXT} \ - bn_mp_get_long_long.${OBJEXT} \ + bn_mp_expt_u32.${OBJEXT} \ bn_mp_grow.${OBJEXT} \ bn_mp_init.${OBJEXT} \ bn_mp_init_copy.${OBJEXT} \ bn_mp_init_multi.${OBJEXT} \ bn_mp_init_set.${OBJEXT} \ - bn_mp_init_set_int.${OBJEXT} \ bn_mp_init_size.${OBJEXT} \ - bn_mp_karatsuba_mul.${OBJEXT} \ - bn_mp_karatsuba_sqr.$(OBJEXT) \ bn_mp_lshd.${OBJEXT} \ bn_mp_mod.${OBJEXT} \ bn_mp_mod_2d.${OBJEXT} \ bn_mp_mul.${OBJEXT} \ bn_mp_mul_2.${OBJEXT} \ @@ -408,31 +355,33 @@ bn_mp_radix_size.${OBJEXT} \ bn_mp_radix_smap.${OBJEXT} \ bn_mp_read_radix.${OBJEXT} \ bn_mp_rshd.${OBJEXT} \ bn_mp_set.${OBJEXT} \ - bn_mp_set_int.${OBJEXT} \ - bn_mp_set_long.${OBJEXT} \ - bn_mp_set_long_long.${OBJEXT} \ bn_mp_shrink.${OBJEXT} \ bn_mp_sqr.${OBJEXT} \ bn_mp_sqrt.${OBJEXT} \ bn_mp_sub.${OBJEXT} \ bn_mp_sub_d.${OBJEXT} \ bn_mp_signed_rsh.${OBJEXT} \ - bn_mp_to_unsigned_bin.${OBJEXT} \ - bn_mp_to_unsigned_bin_n.${OBJEXT} \ - bn_mp_toom_mul.${OBJEXT} \ - bn_mp_toom_sqr.${OBJEXT} \ - bn_mp_toradix_n.${OBJEXT} \ - bn_mp_unsigned_bin_size.${OBJEXT} \ + bn_mp_to_ubin.${OBJEXT} \ + bn_mp_to_radix.${OBJEXT} \ + bn_mp_ubin_size.${OBJEXT} \ bn_mp_xor.${OBJEXT} \ bn_mp_zero.${OBJEXT} \ bn_s_mp_add.${OBJEXT} \ + bn_s_mp_balance_mul.$(OBJEXT) \ + bn_s_mp_karatsuba_mul.${OBJEXT} \ + bn_s_mp_karatsuba_sqr.$(OBJEXT) \ bn_s_mp_mul_digs.${OBJEXT} \ + bn_s_mp_mul_digs_fast.${OBJEXT} \ + bn_s_mp_reverse.${OBJEXT} \ + bn_s_mp_sqr_fast.${OBJEXT} \ bn_s_mp_sqr.${OBJEXT} \ - bn_s_mp_sub.${OBJEXT} + bn_s_mp_sub.${OBJEXT} \ + bn_s_mp_toom_mul.${OBJEXT} \ + bn_s_mp_toom_sqr.${OBJEXT} WIN_OBJS = \ tclWin32Dll.$(OBJEXT) \ tclWinChan.$(OBJEXT) \ @@ -454,12 +403,11 @@ REG_OBJS = tclWinReg.$(OBJEXT) STUB_OBJS = \ tclStubLib.$(OBJEXT) \ tclTomMathStubLib.$(OBJEXT) \ - tclOOStubLib.$(OBJEXT) \ - tclWinPanic.$(OBJEXT) + tclOOStubLib.$(OBJEXT) TCLSH_OBJS = tclAppInit.$(OBJEXT) ZLIB_OBJS = \ adler32.$(OBJEXT) \ @@ -484,76 +432,51 @@ # To start from windows shell use: # > tcltest.cmd -verbose bps -file fileName.test # or from mingw/msys shell: # $ ./tcltest -verbose bps -file fileName.test -tcltest.cmd: +tcltest.cmd: Makefile @echo 'Create tcltest.cmd helpers'; @(\ echo '@echo off'; \ echo 'rem set LANG=en_US'; \ echo 'set BDP=%~dp0'; \ echo 'set OWD=%CD%'; \ echo 'cd /d %TEMP%'; \ - echo 'rem "%BDP%\$(TCLSH)" "$(ROOT_DIR_WIN_NATIVE)/tests/all.tcl" $(TESTFLAGS) -load "$(TEST_LOAD_FACILITIES)" %*'; \ - echo '"%BDP%\$(TEST_EXE_FILE)" "$(ROOT_DIR_WIN_NATIVE)/tests/all.tcl" $(TESTFLAGS) -load "$(TEST_LOAD_PRMS)" %*'; \ + echo 'rem "%BDP%\$(TCLSH)" "$(ROOT_DIR_WIN_NATIVE)/tests/all.tcl" %TESTFLAGS% -load "$(TEST_LOAD_FACILITIES)" %*'; \ + echo '"%BDP%\$(TEST_EXE_FILE)" "$(ROOT_DIR_WIN_NATIVE)/tests/all.tcl" %TESTFLAGS% -load "$(TEST_LOAD_PRMS)" %*'; \ echo 'cd /d %OWD%'; \ ) > tcltest.cmd; @(\ echo '#!/bin/sh'; \ echo '#LANG=en_US'; \ echo 'BDP=$$(dirname $$(readlink -f %0))'; \ echo 'cd /tmp'; \ - echo '#"$$BDP/$(TCLSH)" "$(ROOT_DIR_WIN_NATIVE)/tests/all.tcl" $(TESTFLAGS) -load "$(TEST_LOAD_FACILITIES)" "$$@"'; \ - echo '"$$BDP/$(TEST_EXE_FILE)" "$(ROOT_DIR_WIN_NATIVE)/tests/all.tcl" $(TESTFLAGS) -load "$(TEST_LOAD_PRMS)" "$$@"'; \ - ) > tcltest; + echo '#"$$BDP/$(TCLSH)" "$(ROOT_DIR_WIN_NATIVE)/tests/all.tcl" $$TESTFLAGS -load "$(TEST_LOAD_FACILITIES)" "$$@"'; \ + echo '"$$BDP/$(TEST_EXE_FILE)" "$(ROOT_DIR_WIN_NATIVE)/tests/all.tcl" $$TESTFLAGS -load "$(TEST_LOAD_PRMS)" "$$@"'; \ + ) > tcltest.sh; -tcltest: $(TCLSH) $(TEST_EXE_FILE) $(TEST_DLL_FILE) tcltest.cmd +tcltest.sh: tcltest.cmd -binaries: $(TCL_STUB_LIB_FILE) @LIBRARIES@ winextensions ${TCL_ZIP_FILE} $(TCLSH) +tcltest: binaries $(TEST_EXE_FILE) $(TEST_DLL_FILE) $(CAT32) tcltest.cmd + +binaries: $(TCL_STUB_LIB_FILE) @LIBRARIES@ winextensions $(TCLSH) winextensions: ${DDE_DLL_FILE} ${REG_DLL_FILE} libraries: doc: -tclzipfile: ${TCL_ZIP_FILE} - -${TCL_ZIP_FILE}: ${ZIP_INSTALL_OBJS} ${DDE_DLL_FILE} ${REG_DLL_FILE} - @rm -rf ${TCL_VFS_ROOT} - @mkdir -p ${TCL_VFS_PATH} - @echo "creating ${TCL_VFS_PATH} (prepare compression)" - @( \ - $(LN) $$(find $(TOP_DIR)/library/* -maxdepth 0 -type f) ${TCL_VFS_PATH}/ && \ - (for D in $$(find $(TOP_DIR)/library/* -maxdepth 0 -type d); do \ - mkdir -p "${TCL_VFS_PATH}/$$(basename $$D)"; \ - $(LN) -s $$D/* ${TCL_VFS_PATH}/$$(basename $$D)/; \ - done) && \ - $(LN) ${TCL_VFS_PATH}/manifest.txt ${TCL_VFS_PATH}/pkgIndex.tcl && \ - $(LN) ${DDE_DLL_FILE} ${TCL_VFS_PATH}/dde/ && \ - $(LN) ${REG_DLL_FILE} ${TCL_VFS_PATH}/reg/ \ - ) || ( \ - $(COPY) -a $(TOP_DIR)/library/* ${TCL_VFS_PATH}; \ - $(COPY) -a ${TCL_VFS_PATH}/manifest.txt ${TCL_VFS_PATH}/pkgIndex.tcl; \ - $(COPY) ${DDE_DLL_FILE} ${TCL_VFS_PATH}/dde; \ - $(COPY) ${REG_DLL_FILE} ${TCL_VFS_PATH}/reg; \ - ) - (zip=`(realpath '${NATIVE_ZIP}' || readlink -m '${NATIVE_ZIP}') 2>/dev/null || \ - (echo '${NATIVE_ZIP}' | sed "s?^\./?$$(pwd)/?")`; \ - cd ${TCL_VFS_ROOT} && \ - $$zip ${ZIP_PROG_OPTIONS} ../${TCL_ZIP_FILE} ${ZIP_PROG_VFSSEARCH} >/dev/null && \ - echo "${TCL_ZIP_FILE} successful created with $$zip" && \ - cd ..) - $(TCLSH): $(TCLSH_OBJS) @LIBRARIES@ $(TCL_STUB_LIB_FILE) tclsh.$(RES) $(CC) $(CFLAGS) $(TCLSH_OBJS) $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \ - tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE) + tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE) + $(COPY) tclsh.exe.manifest $(TCLSH).manifest @VC_MANIFEST_EMBED_EXE@ cat32.$(OBJEXT): cat.c - $(CC) -c $(CC_SWITCHES) @DEPARG@ $(CC_OBJNAME) + $(CC) -c $(CC_SWITCHES) -DUNICODE -D_UNICODE @DEPARG@ $(CC_OBJNAME) $(CAT32): cat32.$(OBJEXT) $(CC) $(CFLAGS) cat32.$(OBJEXT) $(CC_EXENAME) $(LIBS) $(LDFLAGS_CONSOLE) # The following targets are configured by autoconf to generate either a shared @@ -562,39 +485,39 @@ ${TCL_STUB_LIB_FILE}: ${STUB_OBJS} @$(RM) ${TCL_STUB_LIB_FILE} @MAKE_STUB_LIB@ ${STUB_OBJS} @POST_MAKE_LIB@ -${TCL_DLL_FILE}: ${TCL_OBJS} tcl.$(RES) @ZLIB_DLL_FILE@ ${TCL_ZIP_FILE} +${TCL_DLL_FILE}: ${TCL_OBJS} tcl.$(RES) @$(RM) ${TCL_DLL_FILE} $(TCL_LIB_FILE) @MAKE_DLL@ ${TCL_OBJS} tcl.$(RES) $(SHLIB_LD_LIBS) + $(COPY) tclsh.exe.manifest ${TCL_DLL_FILE}.manifest @VC_MANIFEST_EMBED_DLL@ - @if test "${ZIPFS_BUILD}" = "1" ; then \ - cat ${TCL_ZIP_FILE} >> ${TCL_DLL_FILE}; \ - ${NATIVE_ZIP} -A ${TCL_DLL_FILE} \ - || echo 'ignore zip-error by adjust sfx process (not executable?)'; \ - fi ${TCL_LIB_FILE}: ${TCL_OBJS} ${DDE_OBJS} ${REG_OBJS} @$(RM) ${TCL_LIB_FILE} @MAKE_LIB@ ${TCL_OBJS} ${DDE_OBJS} ${REG_OBJS} @POST_MAKE_LIB@ ${DDE_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${DDE_OBJS} @MAKE_DLL@ ${DDE_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) + $(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 ${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 ${TEST_EXE_FILE}: ${TCL_STUB_LIB_FILE} ${TCLTEST_OBJS} tclTestMain.${OBJEXT} @$(RM) ${TEST_EXE_FILE} $(CC) $(CFLAGS) $(TCLTEST_OBJS) tclTestMain.$(OBJEXT) $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \ tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE) + $(COPY) tclsh.exe.manifest ${TEST_EXE_FILE}.manifest # use pre-built zlib1.dll ${ZLIB_DLL_FILE}: ${TCL_STUB_LIB_FILE} @if test "@ZLIB_LIBS@set" != "${ZLIB_DIR_NATIVE}/win32/zdll.libset" ; then \ $(COPY) $(ZLIB_DIR)/win64/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \ @@ -610,34 +533,29 @@ .SUFFIXES: .rc # Special case object targets tclTestMain.${OBJEXT}: tclAppInit.c - $(CC) -c $(CC_SWITCHES) -DTCL_TEST -DBUILD_tcl $(EXTFLAGS) $(CC_OBJNAME) $(WIN_DIR)/tclAppInit.c + $(CC) -c $(CC_SWITCHES) -DTCL_TEST -DUNICODE -D_UNICODE $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME) tclWinInit.${OBJEXT}: tclWinInit.c $(CC) -c $(CC_SWITCHES) -DBUILD_tcl $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME) tclWinPipe.${OBJEXT}: tclWinPipe.c $(CC) -c $(CC_SWITCHES) -DBUILD_tcl $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME) -testMain.${OBJEXT}: tclAppInit.c - $(CC) -c $(CC_SWITCHES) -DTCL_TEST @DEPARG@ $(CC_OBJNAME) - -tclMain2.${OBJEXT}: tclMain.c - $(CC) -c $(CC_SWITCHES) -DBUILD_tcl -DTCL_ASCII_MAIN @DEPARG@ $(CC_OBJNAME) - -# TIP #430, ZipFS Support -tclZipfs.${OBJEXT}: $(GENERIC_DIR)/tclZipfs.c - $(CC) -c $(CC_SWITCHES) -DBUILD_tcl \ - -DCFG_RUNTIME_PATH=\"$(bindir_native)\" \ - -DCFG_RUNTIME_DLLFILE="\"$(TCL_DLL_FILE)\"" \ - -DCFG_RUNTIME_ZIPFILE="\"$(TCL_ZIP_FILE)\"" \ - -DCFG_RUNTIME_LIBDIR="\"$(bindir_native)\"" \ - -DCFG_RUNTIME_SCRDIR="\"$(TCL_LIBRARY_NATIVE)\"" \ - $(ZLIB_INCLUDE) -I$(ZLIB_DIR)/contrib/minizip @DEPARG@ $(CC_OBJNAME) - +tclWinReg.${OBJEXT}: tclWinReg.c + $(CC) -c $(CC_SWITCHES) $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME) + +tclWinDde.${OBJEXT}: tclWinDde.c + $(CC) -c $(CC_SWITCHES) $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME) + +tclAppInit.${OBJEXT}: tclAppInit.c + $(CC) -c $(CC_SWITCHES) $(EXTFLAGS) -DUNICODE -D_UNICODE @DEPARG@ $(CC_OBJNAME) + +tclMainW.${OBJEXT}: tclMain.c + $(CC) -c $(CC_SWITCHES) -DBUILD_tcl -DUNICODE -D_UNICODE @DEPARG@ $(CC_OBJNAME) # TIP #59, embedding of configuration information into the binary library. # # Part of Tcl's configuration information are the paths where it was installed # and where it will look for its libraries (which can be different). We derive @@ -645,23 +563,21 @@ # every path can be configured separately we do not remember one general # prefix/exec_prefix but all the different paths individually. tclPkgConfig.${OBJEXT}: tclPkgConfig.c $(CC) -c $(CC_SWITCHES) \ - -DCFG_INSTALL_LIBDIR=\"$(LIB_INSTALL_DIR_NATIVE)\" \ - -DCFG_INSTALL_BINDIR=\"$(BIN_INSTALL_DIR_NATIVE)\" \ - -DCFG_INSTALL_SCRDIR=\"$(SCRIPT_INSTALL_DIR_NATIVE)\" \ - -DCFG_INSTALL_INCDIR=\"$(INCLUDE_INSTALL_DIR_NATIVE)\" \ - -DCFG_INSTALL_DOCDIR=\"$(MAN_INSTALL_DIR)\" \ - \ - -DCFG_RUNTIME_LIBDIR=\"$(libdir_native)\" \ - -DCFG_RUNTIME_BINDIR=\"$(bindir_native)\" \ - -DCFG_RUNTIME_SCRDIR=\"$(TCL_LIBRARY_NATIVE)\" \ - -DCFG_RUNTIME_INCDIR=\"$(includedir_native)\" \ - -DCFG_RUNTIME_DOCDIR=\"$(mandir_native)\" \ - -DCFG_RUNTIME_DLLFILE="\"$(TCL_DLL_FILE)\"" \ - -DCFG_RUNTIME_ZIPFILE="\"$(TCL_ZIP_FILE)\"" \ + -DCFG_INSTALL_LIBDIR="\"$(LIB_INSTALL_DIR_NATIVE)\"" \ + -DCFG_INSTALL_BINDIR="\"$(BIN_INSTALL_DIR_NATIVE)\"" \ + -DCFG_INSTALL_SCRDIR="\"$(SCRIPT_INSTALL_DIR_NATIVE)\"" \ + -DCFG_INSTALL_INCDIR="\"$(INCLUDE_INSTALL_DIR_NATIVE)\"" \ + -DCFG_INSTALL_DOCDIR="\"$(MAN_INSTALL_DIR_NATIVE)\"" \ + \ + -DCFG_RUNTIME_LIBDIR="\"$(libdir_native)\"" \ + -DCFG_RUNTIME_BINDIR="\"$(bindir_native)\"" \ + -DCFG_RUNTIME_SCRDIR="\"$(TCL_LIBRARY_NATIVE)\"" \ + -DCFG_RUNTIME_INCDIR="\"$(includedir_native)\"" \ + -DCFG_RUNTIME_DOCDIR="\"$(mandir_native)\"" \ -DBUILD_tcl \ @DEPARG@ $(CC_OBJNAME) # The following objects are part of the stub library and should not be built # as DLL objects but none of the symbols should be exported @@ -673,74 +589,18 @@ $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME) tclOOStubLib.${OBJEXT}: tclOOStubLib.c $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME) -tclWinPanic.${OBJEXT}: tclWinPanic.c - $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME) - # Implicit rule for all object files that will end up in the Tcl library %.${OBJEXT}: %.c $(CC) -c $(CC_SWITCHES) -DBUILD_tcl @DEPARG@ $(CC_OBJNAME) .rc.$(RES): $(RC) @RC_OUT@ $@ @RC_TYPE@ @RC_DEFINES@ @RC_INCLUDE@ "$(GENERIC_DIR_NATIVE)" @RC_INCLUDE@ "$(WIN_DIR_NATIVE)" @DEPARG@ - - -#-------------------------------------------------------------------------- -# Minizip implementation -#-------------------------------------------------------------------------- -adler32.$(HOST_OBJEXT): - $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/adler32.c - -compress.$(HOST_OBJEXT): - $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/compress.c - -crc32.$(HOST_OBJEXT): - $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/crc32.c - -deflate.$(HOST_OBJEXT): - $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/deflate.c - -ioapi.$(HOST_OBJEXT): - $(HOST_CC) -o $@ -DIOAPI_NO_64 -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip -c $(ZLIB_DIR)/contrib/minizip/ioapi.c - -iowin32.$(HOST_OBJEXT): - $(HOST_CC) -o $@ -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip -c $(ZLIB_DIR)/contrib/minizip/iowin32.c - -infback.$(HOST_OBJEXT): - $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/infback.c - -inffast.$(HOST_OBJEXT): - $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/inffast.c - -inflate.$(HOST_OBJEXT): - $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/inflate.c - -inftrees.$(HOST_OBJEXT): - $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/inftrees.c - -trees.$(HOST_OBJEXT): - $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/trees.c - -uncompr.$(HOST_OBJEXT): - $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/uncompr.c - -zip.$(HOST_OBJEXT): - $(HOST_CC) -o $@ -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip -c $(ZLIB_DIR)/contrib/minizip/zip.c - -zutil.$(HOST_OBJEXT): - $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/zutil.c - -minizip.$(HOST_OBJEXT): - $(HOST_CC) -o $@ -I$(ZLIB_DIR) -DIOAPI_NO_64 -I$(ZLIB_DIR)/contrib/minizip -c $(ZLIB_DIR)/contrib/minizip/minizip.c - -minizip${HOST_EXEEXT}: $(MINIZIP_OBJS) - $(HOST_CC) -o $@ $(MINIZIP_OBJS) - # The following target generates the file generic/tclDate.c from the yacc # grammar found in generic/tclGetDate.y. This is only run by hand as yacc is # not available in all environments. The name of the .c file is different than # the name of the .y file so that make doesn't try to automatically regenerate # the .c file. @@ -757,35 +617,27 @@ gentommath_h: $(TCL_EXE) "$(ROOT_DIR_NATIVE)/tools/fix_tommath_h.tcl" \ "$(TOMMATH_DIR_NATIVE)/tommath.h" \ > "$(GENERIC_DIR_NATIVE)/tclTomMath.h" -INSTALL_BASE_TARGETS = install-binaries $(INSTALL_LIBRARIES) $(INSTALL_MSGS) $(INSTALL_TZDATA) -INSTALL_DOC_TARGETS = install-doc -INSTALL_PACKAGE_TARGETS = install-packages -INSTALL_DEV_TARGETS = install-headers -INSTALL_EXTRA_TARGETS = -INSTALL_TARGETS = $(INSTALL_BASE_TARGETS) $(INSTALL_DOC_TARGETS) $(INSTALL_DEV_TARGETS) \ - $(INSTALL_PACKAGE_TARGETS) $(INSTALL_EXTRA_TARGETS) - -install: $(INSTALL_TARGETS) +install: all install-binaries install-libraries install-doc install-packages install-binaries: binaries @for i in "$(LIB_INSTALL_DIR)" "$(BIN_INSTALL_DIR)" ; \ do \ - if [ ! -d $$i ] ; then \ + if [ ! -d "$$i" ] ; then \ echo "Making directory $$i"; \ - $(MKDIR) $$i; \ - chmod 755 $$i; \ + $(MKDIR) "$$i"; \ + chmod 755 "$$i"; \ else true; \ fi; \ done; @for i in dde${DDEDOTVER} reg${REGDOTVER}; \ do \ - if [ ! -d $(LIB_INSTALL_DIR)/$$i ] ; then \ + if [ ! -d "$(LIB_INSTALL_DIR)/$$i" ] ; then \ echo "Making directory $(LIB_INSTALL_DIR)/$$i"; \ - $(MKDIR) $(LIB_INSTALL_DIR)/$$i; \ + $(MKDIR) "$(LIB_INSTALL_DIR)/$$i"; \ else true; \ fi; \ done; @for i in $(TCL_DLL_FILE) $(ZLIB_DLL_FILE) $(TCLSH); \ do \ @@ -801,109 +653,106 @@ $(COPY) $$i "$(LIB_INSTALL_DIR)"; \ fi; \ done @if [ -f $(DDE_DLL_FILE) ]; then \ echo Installing $(DDE_DLL_FILE); \ - $(COPY) $(DDE_DLL_FILE) $(LIB_INSTALL_DIR)/dde${DDEDOTVER}; \ + $(COPY) $(DDE_DLL_FILE) "$(LIB_INSTALL_DIR)/dde${DDEDOTVER}"; \ $(COPY) $(ROOT_DIR)/library/dde/pkgIndex.tcl \ - $(LIB_INSTALL_DIR)/dde${DDEDOTVER}; \ + "$(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}; \ + $(COPY) $(DDE_LIB_FILE) "$(LIB_INSTALL_DIR)/dde${DDEDOTVER}"; \ fi @if [ -f $(REG_DLL_FILE) ]; then \ echo Installing $(REG_DLL_FILE); \ - $(COPY) $(REG_DLL_FILE) $(LIB_INSTALL_DIR)/reg${REGDOTVER}; \ + $(COPY) $(REG_DLL_FILE) "$(LIB_INSTALL_DIR)/reg${REGDOTVER}"; \ $(COPY) $(ROOT_DIR)/library/reg/pkgIndex.tcl \ - $(LIB_INSTALL_DIR)/reg${REGDOTVER}; \ + "$(LIB_INSTALL_DIR)/reg${REGDOTVER}"; \ fi @if [ -f $(REG_LIB_FILE) ]; then \ echo Installing $(REG_LIB_FILE); \ - $(COPY) $(REG_LIB_FILE) $(LIB_INSTALL_DIR)/reg${REGDOTVER}; \ + $(COPY) $(REG_LIB_FILE) "$(LIB_INSTALL_DIR)/reg${REGDOTVER}"; \ fi -install-libraries-zipfs-shared: libraries - -install-libraries-zipfs-static: install-libraries-zipfs-shared - $(INSTALL_DATA) ${TCL_ZIP_FILE} "$(LIB_INSTALL_DIR)" - install-libraries: libraries install-tzdata install-msgs - @for i in "$$($(CYGPATH) $(prefix)/lib)" "$(INCLUDE_INSTALL_DIR)" \ - $(SCRIPT_INSTALL_DIR); \ + @for i in "$(prefix)/lib" "$(INCLUDE_INSTALL_DIR)" \ + "$(SCRIPT_INSTALL_DIR)" "$(MODULE_INSTALL_DIR)"; \ do \ - if [ ! -d $$i ] ; then \ + if [ ! -d "$$i" ] ; then \ echo "Making directory $$i"; \ - $(MKDIR) $$i; \ + $(MKDIR) "$$i"; \ + else true; \ + fi; \ + done; + @for i in http1.0 opt0.4 encoding; \ + do \ + if [ ! -d "$(SCRIPT_INSTALL_DIR)/$$i" ] ; then \ + echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ + $(MKDIR) "$(SCRIPT_INSTALL_DIR)/$$i"; \ + else true; \ + fi; \ + done; + @for i in 8.4 8.4/platform 8.5 8.6; \ + do \ + if [ ! -d "$(MODULE_INSTALL_DIR)/$$i" ] ; then \ + echo "Making directory $(MODULE_INSTALL_DIR)/$$i"; \ + $(MKDIR) "$(MODULE_INSTALL_DIR)/$$i"; \ else true; \ fi; \ done; - @for i in opt0.4 encoding ../tcl9 ../tcl9/9.0 ../tcl9/9.0/platform; \ + @echo "Installing header files"; + @for i in "$(GENERIC_DIR)/tcl.h" "$(GENERIC_DIR)/tclDecls.h" \ + "$(GENERIC_DIR)/tclOO.h" "$(GENERIC_DIR)/tclOODecls.h" \ + "$(GENERIC_DIR)/tclPlatDecls.h" \ + "$(GENERIC_DIR)/tclTomMath.h" \ + "$(GENERIC_DIR)/tclTomMathDecls.h"; \ do \ - if [ ! -d $(SCRIPT_INSTALL_DIR)/$$i ] ; then \ - echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ - $(MKDIR) $(SCRIPT_INSTALL_DIR)/$$i; \ - else true; \ - fi; \ + $(COPY) "$$i" "$(INCLUDE_INSTALL_DIR)"; \ done; @echo "Installing library files to $(SCRIPT_INSTALL_DIR)"; @for i in $(ROOT_DIR)/library/*.tcl $(ROOT_DIR)/library/tclIndex; \ do \ $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)"; \ done; - @echo "Installing package http 2.9.0 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl9/9.0/http-2.9.0.tm; + @echo "Installing library http1.0 directory"; + @for j in $(ROOT_DIR)/library/http1.0/*.tcl; \ + do \ + $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \ + done; + @echo "Installing package http 2.9.5 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.9.5.tm"; @echo "Installing library opt0.4 directory"; @for j in $(ROOT_DIR)/library/opt/*.tcl; \ do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ done; - @echo "Installing package msgcat 1.7.0 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl9/9.0/msgcat-1.7.0.tm; - @echo "Installing package tcltest 2.4.0 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl9/9.0/tcltest-2.4.0.tm; + @echo "Installing package msgcat 1.6.1 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl "$(MODULE_INSTALL_DIR)/8.5/msgcat-1.6.1.tm"; + @echo "Installing package tcltest 2.5.3 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl "$(MODULE_INSTALL_DIR)/8.5/tcltest-2.5.3.tm"; @echo "Installing package platform 1.0.14 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl9/9.0/platform-1.0.14.tm; + @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl "$(MODULE_INSTALL_DIR)/8.4/platform-1.0.14.tm"; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/platform/shell.tcl $(SCRIPT_INSTALL_DIR)/../tcl9/9.0/platform/shell-1.1.4.tm; + @$(COPY) $(ROOT_DIR)/library/platform/shell.tcl "$(MODULE_INSTALL_DIR)/8.4/platform/shell-1.1.4.tm"; @echo "Installing encodings"; @for i in $(ROOT_DIR)/library/encoding/*.enc ; do \ $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)/encoding"; \ done; install-tzdata: @echo "Installing time zone data" @$(TCL_EXE) "$(ROOT_DIR)/tools/installData.tcl" \ - "$(ROOT_DIR)/library/tzdata" "$(SCRIPT_INSTALL_DIR)/tzdata" + "$(ROOT_DIR)/library/tzdata" "$(SCRIPT_INSTALL_DIR_NATIVE)/tzdata" install-msgs: @echo "Installing message catalogs" - @$(TCL_EXE) "$(ROOT_DIR)/tools/installData.tcl" \ - "$(ROOT_DIR)/library/msgs" "$(SCRIPT_INSTALL_DIR)/msgs" + $(TCL_EXE) "$(ROOT_DIR)/tools/installData.tcl" \ + "$(ROOT_DIR)/library/msgs" "$(SCRIPT_INSTALL_DIR_NATIVE)/msgs" install-doc: doc -install-headers: - @for i in "$(INCLUDE_INSTALL_DIR)"; \ - do \ - if [ ! -d "$$i" ] ; then \ - echo "Making directory $$i"; \ - $(MKDIR) "$$i"; \ - chmod 755 "$$i"; \ - else true; \ - fi; \ - done; - @echo "Installing header files to $(INCLUDE_INSTALL_DIR)/"; - @for i in $(GENERIC_DIR)/tcl.h $(GENERIC_DIR)/tclDecls.h \ - $(GENERIC_DIR)/tclOO.h $(GENERIC_DIR)/tclOODecls.h \ - $(GENERIC_DIR)/tclPlatDecls.h \ - $(GENERIC_DIR)/tclTomMath.h \ - $(GENERIC_DIR)/tclTomMathDecls.h ; \ - do \ - $(COPY) $$i "$(INCLUDE_INSTALL_DIR)"; \ - done; - # Optional target to install private headers install-private-headers: libraries @for i in $(PRIVATE_INCLUDE_INSTALL_DIR); \ do \ if [ ! -d $$i ] ; then \ @@ -925,25 +774,25 @@ # tcltest, i.e.: # % make test TESTFLAGS="-verbose bps -file fileName.test" test: test-tcl test-packages -test-tcl: binaries $(TCLSH) $(CAT32) $(TEST_DLL_FILE) +test-tcl: tcltest TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ - $(WINE) ./$(TCLSH) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \ - -load "$(TEST_LOAD_FACILITIES)" | $(WINE) ./$(CAT32) + ./$(TCLSH) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \ + -load "$(TEST_LOAD_FACILITIES)" # Useful target to launch a built tclsh with the proper path,... -runtest: binaries $(TCLSH) $(TEST_DLL_FILE) +runtest: tcltest @TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ - $(WINE) ./$(TCLSH) $(TESTFLAGS) -load "$(TEST_LOAD_FACILITIES)" $(SCRIPT) + ./$(TCLSH) $(TESTFLAGS) -load "$(TEST_LOAD_FACILITIES)" $(SCRIPT) # This target can be used to run tclsh from the build directory via # `make shell SCRIPT=foo.tcl` shell: binaries @TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ - $(WINE) ./$(TCLSH) $(SCRIPT) + ./$(TCLSH) $(SCRIPT) # This target can be used to run tclsh inside either gdb or insight gdb: binaries @echo "set env TCL_LIBRARY=$(LIBRARY_DIR)" > gdb.run gdb ./$(TCLSH) --command=gdb.run @@ -957,19 +806,16 @@ cleanhelp: $(RM) *.hlp *.cnt *.GID *.rtf man2tcl.exe clean: cleanhelp clean-packages $(RM) *.lib *.a *.exp *.dll *.$(RES) *.${OBJEXT} *~ \#* TAGS a.out - $(RM) $(TCLSH) $(CAT32) $(TEST_EXE_FILE) $(TEST_DLL_FILE) tcltest.cmd tcltest + $(RM) $(TCLSH) $(CAT32) $(TEST_EXE_FILE) $(TEST_DLL_FILE) tcltest.cmd tcltest.sh $(RM) *.pch *.ilk *.pdb - $(RM) minizip${HOST_EXEEXT} *.${HOST_OBJEXT} - $(RM) *.zip - $(RMDIR) *.vfs distclean: distclean-packages clean $(RM) Makefile config.status config.cache config.log tclConfig.sh \ - tcl.hpj config.status.lineno tclsh.exe.manifest + tcl.hpj config.status.lineno # # Bundled package targets # @@ -984,11 +830,11 @@ pkg=`basename $$i`; \ mkdir -p $(PKG_DIR)/$$pkg; \ if [ ! -f $(PKG_DIR)/$$pkg/Makefile ]; then \ ( cd $(PKG_DIR)/$$pkg; \ echo "Configuring package '$$i' wd = `$(CYGPATH) $$(pwd -P)`"; \ - $$i/configure --with-tcl=$$builddir --with-tclinclude=$(GENERIC_DIR_NATIVE) $(PKG_CFG_ARGS) --enable-shared; ) \ + $$i/configure --with-tcl=$$builddir --with-tclinclude=$(GENERIC_DIR_NATIVE) $(PKG_CFG_ARGS) --enable-shared --enable-threads; ) \ fi ; \ echo "Building package '$$pkg'"; \ ( cd $(PKG_DIR)/$$pkg; $(MAKE); ) \ fi; \ fi; \ @@ -1068,11 +914,11 @@ "$(GENERIC_DIR_NATIVE)/tclOO.decls" # # This target creates the HTML folder for Tcl & Tk and places it in # DISTDIR/html. It uses the tcltk-man2html.tcl tool from the Tcl group's tool -# workspace. It depends on the Tcl & Tk being in directories called tcl9.* & +# workspace. It depends on the Tcl & Tk being in directories called tcl8.* & # tk8.* up two directories from the TOOL_DIR. # TOOL_DIR=$(ROOT_DIR)/tools HTML_INSTALL_DIR=$(ROOT_DIR)/html @@ -1094,8 +940,7 @@ .PHONY: install-binaries install-libraries install-tzdata install-msgs .PHONY: install-doc install-private-headers test test-tcl runtest shell .PHONY: gdb depend cleanhelp clean distclean packages install-packages .PHONY: test-packages clean-packages distclean-packages genstubs html .PHONY: html-tcl html-tk -.PHONY: iinstall-libraries-zipfs-shared install-libraries-zipfs-static tclzipfile # DO NOT DELETE THIS LINE -- make depend depends on it. Index: win/README ================================================================== --- win/README +++ win/README @@ -1,6 +1,6 @@ -Tcl 9.0 for Windows +Tcl 8.6 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.0 Source Distribution (plus any patches) + Tcl 8.6 Source Distribution (plus any patches) and Visual C++ 6 or newer @@ -77,13 +77,13 @@ Use the Makefile "install" target to install Tcl. It will install it according to the prefix options you provided in the correct directory structure. -Note that in order to run tclsh90.exe, you must ensure that tcl90.dll is +Note that in order to run tclsh86.exe, you must ensure that tcl86.dll is on your path, in the system directory, or in the directory containing -tclsh90.exe. +tclsh86.exe. Note: Tcl no longer provides support for Win32s. 3. Test suite ------------- @@ -91,9 +91,9 @@ This distribution contains an extensive test suite for Tcl. Some of the tests are timing dependent and will fail from time to time. If a test is failing consistently, please send us a bug report with as much detail as you can manage to our tracker: - http://core.tcl.tk/tcl/reportlist + https://core.tcl-lang.org/tcl/reportlist In order to run the test suite, you build the "test" target using the appropriate makefile for your compiler. Index: win/buildall.vc.bat ================================================================== --- win/buildall.vc.bat +++ win/buildall.vc.bat @@ -36,13 +36,11 @@ :: We need to run the development environment batch script that comes :: with developer studio (v4,5,6,7,etc...) All have it. This path :: might not be correct. You should call it yourself prior to running :: this batchfile. :: -REM call "C:\Program Files\Microsoft Developer Studio\vc98\bin\vcvars32.bat" -set "VSCMD_START_DIR=%CD%" -call "C:\Program Files (x86)\Microsoft Visual Studio\2017\Community\Common7\Tools\VsDevCmd.bat" +call "C:\Program Files\Microsoft Developer Studio\vc98\bin\vcvars32.bat" if errorlevel 1 (goto no_vcvars) :startBuilding echo. Index: win/cat.c ================================================================== --- win/cat.c +++ win/cat.c @@ -26,16 +26,16 @@ char buf[1024]; int n; const char *err; while (1) { - n = read(0, buf, sizeof(buf)); + n = _read(0, buf, sizeof(buf)); if (n <= 0) { break; } - write(1, buf, n); + _write(1, buf, n); } err = (sizeof(int) == 2) ? "stderr16" : "stderr32"; - write(2, err, strlen(err)); + _write(2, err, (unsigned int)strlen(err)); return 0; } ADDED win/coffbase.txt Index: win/coffbase.txt ================================================================== --- /dev/null +++ win/coffbase.txt @@ -0,0 +1,43 @@ +; +; This file defines the virtual base addresses for the Dynamic Link Libraries +; that are part of the Tcl system. The first token on a line is the key (or name +; of the DLL) and the second token is the virtual base address, in hexidecimal. +; The third token is the maximum size of the DLL image file, including symbols. +; +; Using a specified "prefered load address" should speed loading time by avoiding +; relocations (NT supported only). It is assumed extension authors will contribute +; their modules to this grand-master list. You can use the dumpbin utility with +; the /headers option to get the "size of image" data (already in hex). If the +; maximum size is too small a linker warning will occur. Modules can overlap when +; they're mutually exclusive. This info is placed in the DLL's PE header by the +; linker with the `-base:@$(TCLDIR)\win\coffbase.txt,` option. + +tcl 0x10000000 0x00200000 +tcldde 0x10200000 0x00010000 +tclreg 0x10210000 0x00010000 +tk 0x10220000 0x00200000 +expect 0x10480000 0x00080000 +itcl 0x10500000 0x00080000 +itk 0x10580000 0x00080000 +bltlite 0x10600000 0x00080000 +blt 0x10680000 0x00080000 +iocpsock 0x10700000 0x00080000 +tls 0x10780000 0x00100000 +winico 0x10880000 0x00010000 +sample 0x108B0000 0x00010000 +tile 0x10900000 0x00080000 +memchan 0x109D0000 0x00010000 +tdom 0x109E0000 0x00080000 +tclvfs 0x10A70000 0x00010000 +tkvideo 0x10B00000 0x00010000 +tclsdl 0x10B20000 0x00080000 +vqtcl 0x10C00000 0x00010000 +tdbc 0x10C40000 0x00010000 +thread 0x10C80000 0x00020000 +nsf 0x10ca0000 0x00080000 +; +; insert new packages here +; +snack 0x1E000000 0x00400000 +sound 0x1E400000 0x00400000 +snackogg 0x1E800000 0x00200000 Index: win/configure ================================================================== --- win/configure +++ win/configure @@ -1,806 +1,322 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.69. +# Generated by GNU Autoconf 2.59. # -# -# Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. -# -# +# Copyright (C) 2003 Free Software Foundation, Inc. # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. -## -------------------- ## -## M4sh Initialization. ## -## -------------------- ## +## --------------------- ## +## M4sh Initialization. ## +## --------------------- ## -# Be more Bourne compatible -DUALCASE=1; export DUALCASE # for MKS sh -if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : +# Be Bourne compatible +if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then emulate sh NULLCMD=: - # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which + # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' - setopt NO_GLOB_SUBST -else - case `(set -o) 2>/dev/null` in #( - *posix*) : - set -o posix ;; #( - *) : - ;; -esac -fi - - -as_nl=' -' -export as_nl -# Printing a long string crashes Solaris 7 /usr/bin/printf. -as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' -as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo -as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo -# Prefer a ksh shell builtin over an external printf program on Solaris, -# but without wasting forks for bash or zsh. -if test -z "$BASH_VERSION$ZSH_VERSION" \ - && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then - as_echo='print -r --' - as_echo_n='print -rn --' -elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then - as_echo='printf %s\n' - as_echo_n='printf %s' -else - if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then - as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' - as_echo_n='/usr/ucb/echo -n' - else - as_echo_body='eval expr "X$1" : "X\\(.*\\)"' - as_echo_n_body='eval - arg=$1; - case $arg in #( - *"$as_nl"*) - expr "X$arg" : "X\\(.*\\)$as_nl"; - arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; - esac; - expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" - ' - export as_echo_n_body - as_echo_n='sh -c $as_echo_n_body as_echo' - fi - export as_echo_body - as_echo='sh -c $as_echo_body as_echo' -fi - -# The user is always right. -if test "${PATH_SEPARATOR+set}" != set; then - PATH_SEPARATOR=: - (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { - (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || - PATH_SEPARATOR=';' - } -fi - - -# IFS -# We need space, tab and new line, in precisely that order. Quoting is -# there to prevent editors from complaining about space-tab. -# (If _AS_PATH_WALK were called with IFS unset, it would disable word -# splitting by setting IFS to empty value.) -IFS=" "" $as_nl" - -# Find who we are. Look in the path if we contain no directory separator. -as_myself= -case $0 in #(( - *[\\/]* ) as_myself=$0 ;; - *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break - done -IFS=$as_save_IFS - - ;; -esac -# We did not find ourselves, most probably we were run as `sh COMMAND' -# in which case we are not to be found in the path. -if test "x$as_myself" = x; then - as_myself=$0 -fi -if test ! -f "$as_myself"; then - $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 - exit 1 -fi - -# Unset variables that we do not need and which cause bugs (e.g. in -# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" -# suppresses any "Segmentation fault" message there. '((' could -# trigger a bug in pdksh 5.2.14. -for as_var in BASH_ENV ENV MAIL MAILPATH -do eval test x\${$as_var+set} = xset \ - && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : -done +elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then + set -o posix +fi +DUALCASE=1; export DUALCASE # for MKS sh + +# Support unset when possible. +if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then + as_unset=unset +else + as_unset=false +fi + + +# Work around bugs in pre-3.0 UWIN ksh. +$as_unset ENV MAIL MAILPATH PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. -LC_ALL=C -export LC_ALL -LANGUAGE=C -export LANGUAGE - -# CDPATH. -(unset CDPATH) >/dev/null 2>&1 && unset CDPATH - -# Use a proper internal environment variable to ensure we don't fall - # into an infinite loop, continuously re-executing ourselves. - if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then - _as_can_reexec=no; export _as_can_reexec; - # We cannot yet assume a decent shell, so we have to provide a -# neutralization value for shells without unset; and this also -# works around shells that cannot unset nonexistent variables. -# Preserve -v and -x to the replacement shell. -BASH_ENV=/dev/null -ENV=/dev/null -(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV -case $- in # (((( - *v*x* | *x*v* ) as_opts=-vx ;; - *v* ) as_opts=-v ;; - *x* ) as_opts=-x ;; - * ) as_opts= ;; -esac -exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} -# Admittedly, this is quite paranoid, since all the known shells bail -# out after a failed `exec'. -$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 -as_fn_exit 255 - fi - # We don't want this to propagate to other subprocesses. - { _as_can_reexec=; unset _as_can_reexec;} -if test "x$CONFIG_SHELL" = x; then - as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then : - emulate sh - NULLCMD=: - # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which - # is contrary to our usage. Disable this feature. - alias -g '\${1+\"\$@\"}'='\"\$@\"' - setopt NO_GLOB_SUBST -else - case \`(set -o) 2>/dev/null\` in #( - *posix*) : - set -o posix ;; #( - *) : - ;; -esac -fi -" - as_required="as_fn_return () { (exit \$1); } -as_fn_success () { as_fn_return 0; } -as_fn_failure () { as_fn_return 1; } -as_fn_ret_success () { return 0; } -as_fn_ret_failure () { return 1; } - -exitcode=0 -as_fn_success || { exitcode=1; echo as_fn_success failed.; } -as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } -as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } -as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } -if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then : - -else - exitcode=1; echo positional parameters were not saved. -fi -test x\$exitcode = x0 || exit 1 -test -x / || exit 1" - as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO - as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO - eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && - test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1 -test \$(( 1 + 1 )) = 2 || exit 1" - if (eval "$as_required") 2>/dev/null; then : - as_have_required=yes -else - as_have_required=no -fi - if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then : - -else - as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -as_found=false -for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - as_found=: - case $as_dir in #( - /*) - for as_base in sh bash ksh sh5; do - # Try only shells that exist, to save several forks. - as_shell=$as_dir/$as_base - if { test -f "$as_shell" || test -f "$as_shell.exe"; } && - { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then : - CONFIG_SHELL=$as_shell as_have_required=yes - if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then : - break 2 -fi -fi - done;; - esac - as_found=false -done -$as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } && - { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then : - CONFIG_SHELL=$SHELL as_have_required=yes -fi; } -IFS=$as_save_IFS - - - if test "x$CONFIG_SHELL" != x; then : - export CONFIG_SHELL - # We cannot yet assume a decent shell, so we have to provide a -# neutralization value for shells without unset; and this also -# works around shells that cannot unset nonexistent variables. -# Preserve -v and -x to the replacement shell. -BASH_ENV=/dev/null -ENV=/dev/null -(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV -case $- in # (((( - *v*x* | *x*v* ) as_opts=-vx ;; - *v* ) as_opts=-v ;; - *x* ) as_opts=-x ;; - * ) as_opts= ;; -esac -exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} -# Admittedly, this is quite paranoid, since all the known shells bail -# out after a failed `exec'. -$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 -exit 255 -fi - - if test x$as_have_required = xno; then : - $as_echo "$0: This script requires a shell more modern than all" - $as_echo "$0: the shells that I found on your system." - if test x${ZSH_VERSION+set} = xset ; then - $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should" - $as_echo "$0: be upgraded to zsh 4.3.4 or later." - else - $as_echo "$0: Please tell bug-autoconf@gnu.org about your system, -$0: including any error possibly output before this -$0: message. Then install a modern shell, or manually run -$0: the script under such a shell if you do have one." - fi - exit 1 -fi -fi -fi -SHELL=${CONFIG_SHELL-/bin/sh} -export SHELL -# Unset more variables known to interfere with behavior of common tools. -CLICOLOR_FORCE= GREP_OPTIONS= -unset CLICOLOR_FORCE GREP_OPTIONS - -## --------------------- ## -## M4sh Shell Functions. ## -## --------------------- ## -# as_fn_unset VAR -# --------------- -# Portably unset VAR. -as_fn_unset () -{ - { eval $1=; unset $1;} -} -as_unset=as_fn_unset - -# as_fn_set_status STATUS -# ----------------------- -# Set $? to STATUS, without forking. -as_fn_set_status () -{ - return $1 -} # as_fn_set_status - -# as_fn_exit STATUS -# ----------------- -# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. -as_fn_exit () -{ - set +e - as_fn_set_status $1 - exit $1 -} # as_fn_exit - -# as_fn_mkdir_p -# ------------- -# Create "$as_dir" as a directory, including parents if necessary. -as_fn_mkdir_p () -{ - - case $as_dir in #( - -*) as_dir=./$as_dir;; - esac - test -d "$as_dir" || eval $as_mkdir_p || { - as_dirs= - while :; do - case $as_dir in #( - *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( - *) as_qdir=$as_dir;; - esac - as_dirs="'$as_qdir' $as_dirs" - as_dir=`$as_dirname -- "$as_dir" || -$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$as_dir" : 'X\(//\)[^/]' \| \ - X"$as_dir" : 'X\(//\)$' \| \ - X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X"$as_dir" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - test -d "$as_dir" && break - done - test -z "$as_dirs" || eval "mkdir $as_dirs" - } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" - - -} # as_fn_mkdir_p - -# as_fn_executable_p FILE -# ----------------------- -# Test if FILE is an executable regular file. -as_fn_executable_p () -{ - test -f "$1" && test -x "$1" -} # as_fn_executable_p -# as_fn_append VAR VALUE -# ---------------------- -# Append the text in VALUE to the end of the definition contained in VAR. Take -# advantage of any shell optimizations that allow amortized linear growth over -# repeated appends, instead of the typical quadratic growth present in naive -# implementations. -if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : - eval 'as_fn_append () - { - eval $1+=\$2 - }' -else - as_fn_append () - { - eval $1=\$$1\$2 - } -fi # as_fn_append - -# as_fn_arith ARG... -# ------------------ -# Perform arithmetic evaluation on the ARGs, and store the result in the -# global $as_val. Take advantage of shells that can avoid forks. The arguments -# must be portable across $(()) and expr. -if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : - eval 'as_fn_arith () - { - as_val=$(( $* )) - }' -else - as_fn_arith () - { - as_val=`expr "$@" || test $? -eq 1` - } -fi # as_fn_arith - - -# as_fn_error STATUS ERROR [LINENO LOG_FD] -# ---------------------------------------- -# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are -# provided, also output the error to LOG_FD, referencing LINENO. Then exit the -# script with STATUS, using 1 if that was 0. -as_fn_error () -{ - as_status=$1; test $as_status -eq 0 && as_status=1 - if test "$4"; then - as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 - fi - $as_echo "$as_me: error: $2" >&2 - as_fn_exit $as_status -} # as_fn_error - -if expr a : '\(a\)' >/dev/null 2>&1 && - test "X`expr 00001 : '.*\(...\)'`" = X001; then +for as_var in \ + LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \ + LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \ + LC_TELEPHONE LC_TIME +do + if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then + eval $as_var=C; export $as_var + else + $as_unset $as_var + fi +done + +# Required to use basename. +if expr a : '\(a\)' >/dev/null 2>&1; then as_expr=expr else as_expr=false fi -if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then +if (basename /) >/dev/null 2>&1 && test "X`basename / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi -if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then - as_dirname=dirname -else - as_dirname=false -fi -as_me=`$as_basename -- "$0" || +# Name of the executable. +as_me=`$as_basename "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ - X"$0" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X/"$0" | - sed '/^.*\/\([^/][^/]*\)\/*$/{ - s//\1/ - q - } - /^X\/\(\/\/\)$/{ - s//\1/ - q - } - /^X\/\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - + X"$0" : 'X\(/\)$' \| \ + . : '\(.\)' 2>/dev/null || +echo X/"$0" | + sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/; q; } + /^X\/\(\/\/\)$/{ s//\1/; q; } + /^X\/\(\/\).*/{ s//\1/; q; } + s/.*/./; q'` + + +# PATH needs CR, and LINENO needs CR and PATH. # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits - - as_lineno_1=$LINENO as_lineno_1a=$LINENO - as_lineno_2=$LINENO as_lineno_2a=$LINENO - eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && - test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { - # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) - sed -n ' - p - /[$]LINENO/= - ' <$as_myself | - sed ' - s/[$]LINENO.*/&-/ - t lineno - b - :lineno - N - :loop - s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ - t loop - s/-\n.*// - ' >$as_me.lineno && - chmod +x "$as_me.lineno" || - { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } - - # If we had to re-execute with $CONFIG_SHELL, we're ensured to have - # already done that, so ensure we don't try to do so again and fall - # in an infinite loop. This has already happened in practice. - _as_can_reexec=no; export _as_can_reexec +# The user is always right. +if test "${PATH_SEPARATOR+set}" != set; then + echo "#! /bin/sh" >conf$$.sh + echo "exit 0" >>conf$$.sh + chmod +x conf$$.sh + if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then + PATH_SEPARATOR=';' + else + PATH_SEPARATOR=: + fi + rm -f conf$$.sh +fi + + + as_lineno_1=$LINENO + as_lineno_2=$LINENO + as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` + test "x$as_lineno_1" != "x$as_lineno_2" && + test "x$as_lineno_3" = "x$as_lineno_2" || { + # Find who we are. Look in the path if we contain no path at all + # relative or not. + case $0 in + *[\\/]* ) as_myself=$0 ;; + *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break +done + + ;; + esac + # We did not find ourselves, most probably we were run as `sh COMMAND' + # in which case we are not to be found in the path. + if test "x$as_myself" = x; then + as_myself=$0 + fi + if test ! -f "$as_myself"; then + { echo "$as_me: error: cannot find myself; rerun with an absolute path" >&2 + { (exit 1); exit 1; }; } + fi + case $CONFIG_SHELL in + '') + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for as_base in sh bash ksh sh5; do + case $as_dir in + /*) + if ("$as_dir/$as_base" -c ' + as_lineno_1=$LINENO + as_lineno_2=$LINENO + as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` + test "x$as_lineno_1" != "x$as_lineno_2" && + test "x$as_lineno_3" = "x$as_lineno_2" ') 2>/dev/null; then + $as_unset BASH_ENV || test "${BASH_ENV+set}" != set || { BASH_ENV=; export BASH_ENV; } + $as_unset ENV || test "${ENV+set}" != set || { ENV=; export ENV; } + CONFIG_SHELL=$as_dir/$as_base + export CONFIG_SHELL + exec "$CONFIG_SHELL" "$0" ${1+"$@"} + fi;; + esac + done +done +;; + esac + + # Create $as_me.lineno as a copy of $as_myself, but with $LINENO + # uniformly replaced by the line number. The first 'sed' inserts a + # line-number line before each line; the second 'sed' does the real + # work. The second script uses 'N' to pair each line-number line + # with the numbered line, and appends trailing '-' during + # substitution so that $LINENO is not a special case at line end. + # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the + # second 'sed' script. Blame Lee E. McMahon for sed's syntax. :-) + sed '=' <$as_myself | + sed ' + N + s,$,-, + : loop + s,^\(['$as_cr_digits']*\)\(.*\)[$]LINENO\([^'$as_cr_alnum'_]\),\1\2\1\3, + t loop + s,-$,, + s,^['$as_cr_digits']*\n,, + ' >$as_me.lineno && + chmod +x $as_me.lineno || + { echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2 + { (exit 1); exit 1; }; } + # Don't try to exec as it changes $[0], causing all sort of problems # (the dirname of $[0] is not the place where we might find the - # original and so on. Autoconf is especially sensitive to this). - . "./$as_me.lineno" + # original and so on. Autoconf is especially sensible to this). + . ./$as_me.lineno # Exit status is that of the last command. exit } -ECHO_C= ECHO_N= ECHO_T= -case `echo -n x` in #((((( --n*) - case `echo 'xy\c'` in - *c*) ECHO_T=' ';; # ECHO_T is single tab character. - xy) ECHO_C='\c';; - *) echo `echo ksh88 bug on AIX 6.1` > /dev/null - ECHO_T=' ';; - esac;; -*) - ECHO_N='-n';; + +case `echo "testing\c"; echo 1,2,3`,`echo -n testing; echo 1,2,3` in + *c*,-n*) ECHO_N= ECHO_C=' +' ECHO_T=' ' ;; + *c*,* ) ECHO_N=-n ECHO_C= ECHO_T= ;; + *) ECHO_N= ECHO_C='\c' ECHO_T= ;; esac + +if expr a : '\(a\)' >/dev/null 2>&1; then + as_expr=expr +else + as_expr=false +fi rm -f conf$$ conf$$.exe conf$$.file -if test -d conf$$.dir; then - rm -f conf$$.dir/conf$$.file -else - rm -f conf$$.dir - mkdir conf$$.dir 2>/dev/null -fi -if (echo >conf$$.file) 2>/dev/null; then - if ln -s conf$$.file conf$$ 2>/dev/null; then +echo >conf$$.file +if ln -s conf$$.file conf$$ 2>/dev/null; then + # We could just check for DJGPP; but this test a) works b) is more generic + # and c) will remain valid once DJGPP supports symlinks (DJGPP 2.04). + if test -f conf$$.exe; then + # Don't use ln at all; we don't have any links + as_ln_s='cp -p' + else as_ln_s='ln -s' - # ... but there are two gotchas: - # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. - # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. - # In both cases, we have to default to `cp -pR'. - ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || - as_ln_s='cp -pR' - elif ln conf$$.file conf$$ 2>/dev/null; then - as_ln_s=ln - else - as_ln_s='cp -pR' - fi -else - as_ln_s='cp -pR' -fi -rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file -rmdir conf$$.dir 2>/dev/null + fi +elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln +else + as_ln_s='cp -p' +fi +rm -f conf$$ conf$$.exe conf$$.file if mkdir -p . 2>/dev/null; then - as_mkdir_p='mkdir -p "$as_dir"' + as_mkdir_p=: else test -d ./-p && rmdir ./-p as_mkdir_p=false fi -as_test_x='test -x' -as_executable_p=as_fn_executable_p +as_executable_p="test -f" # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" -test -n "$DJDIR" || exec 7<&0 &1 +# IFS +# We need space, tab and new line, in precisely that order. +as_nl=' +' +IFS=" $as_nl" + +# CDPATH. +$as_unset CDPATH + # Name of the host. -# hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, +# hostname on some systems (SVR3.2, Linux) returns a bogus exit status, # so uname gets run too. ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` + +exec 6>&1 # # Initializations. # ac_default_prefix=/usr/local -ac_clean_files= ac_config_libobj_dir=. -LIBOBJS= cross_compiling=no subdirs= MFLAGS= MAKEFLAGS= +SHELL=${CONFIG_SHELL-/bin/sh} + +# Maximum number of lines to put in a shell here document. +# This variable seems obsolete. It should probably be removed, and +# only ac_max_sed_lines should be used. +: ${ac_max_here_lines=38} # Identity of this package. PACKAGE_NAME= PACKAGE_TARNAME= PACKAGE_VERSION= PACKAGE_STRING= PACKAGE_BUGREPORT= -PACKAGE_URL= ac_unique_file="../generic/tcl.h" # Factoring default headers for most tests. ac_includes_default="\ #include -#ifdef HAVE_SYS_TYPES_H +#if HAVE_SYS_TYPES_H # include #endif -#ifdef HAVE_SYS_STAT_H +#if HAVE_SYS_STAT_H # include #endif -#ifdef STDC_HEADERS +#if STDC_HEADERS # include # include #else -# ifdef HAVE_STDLIB_H +# if HAVE_STDLIB_H # include # endif #endif -#ifdef HAVE_STRING_H -# if !defined STDC_HEADERS && defined HAVE_MEMORY_H +#if HAVE_STRING_H +# if !STDC_HEADERS && HAVE_MEMORY_H # include # endif # include #endif -#ifdef HAVE_STRINGS_H +#if HAVE_STRINGS_H # include #endif -#ifdef HAVE_INTTYPES_H +#if HAVE_INTTYPES_H # include -#endif -#ifdef HAVE_STDINT_H -# include +#else +# if HAVE_STDINT_H +# include +# endif #endif -#ifdef HAVE_UNISTD_H +#if HAVE_UNISTD_H # include #endif" -ac_subst_vars='LTLIBOBJS -LIBOBJS -RES -RC_DEFINES -RC_DEFINE -RC_INCLUDE -RC_TYPE -RC_OUT -TCL_REG_MINOR_VERSION -TCL_REG_MAJOR_VERSION -TCL_REG_VERSION -TCL_DDE_MINOR_VERSION -TCL_DDE_MAJOR_VERSION -TCL_DDE_VERSION -TCL_PACKAGE_PATH -TCL_LIB_VERSIONS_OK -TCL_EXP_FILE -TCL_BUILD_EXP_FILE -TCL_NEEDS_EXP_FILE -TCL_LD_SEARCH_FLAGS -TCL_CC_SEARCH_FLAGS -TCL_BUILD_LIB_SPEC -MAKE_EXE -MAKE_DLL -POST_MAKE_LIB -MAKE_STUB_LIB -MAKE_LIB -LIBRARIES -EXESUFFIX -LIBSUFFIX -LIBPREFIX -DLLSUFFIX -LIBS_GUI -TCL_SHARED_BUILD -SHLIB_SUFFIX -SHLIB_CFLAGS -SHLIB_LD_LIBS -SHLIB_LD -STLIB_LD -LDFLAGS_WINDOW -LDFLAGS_CONSOLE -LDFLAGS_OPTIMIZE -LDFLAGS_DEBUG -CC_EXENAME -CC_OBJNAME -DEPARG -EXTRA_CFLAGS -CFG_TCL_EXPORT_FILE_SUFFIX -CFG_TCL_UNSHARED_LIB_SUFFIX -CFG_TCL_SHARED_LIB_SUFFIX -TCL_DBGX -TCL_BIN_DIR -TCL_SRC_DIR -TCL_DLL_FILE -TCL_BUILD_STUB_LIB_PATH -TCL_BUILD_STUB_LIB_SPEC -TCL_INCLUDE_SPEC -TCL_STUB_LIB_PATH -TCL_STUB_LIB_SPEC -TCL_STUB_LIB_FLAG -TCL_STUB_LIB_FILE -TCL_LIB_SPEC -TCL_IMPORT_LIB_FLAG -TCL_IMPORT_LIB_FILE -TCL_STATIC_LIB_FLAG -TCL_STATIC_LIB_FILE -TCL_LIB_FLAG -TCL_LIB_FILE -TCL_EXE -PKG_CFG_ARGS -TCL_PATCH_LEVEL -TCL_MINOR_VERSION -TCL_MAJOR_VERSION -TCL_VERSION -MACHINE -TCL_WIN_VERSION -VC_MANIFEST_EMBED_EXE -VC_MANIFEST_EMBED_DLL -LDFLAGS_DEFAULT -CFLAGS_DEFAULT -INSTALL_MSGS -INSTALL_LIBRARIES -TCL_ZIP_FILE -ZIPFS_BUILD -ZIP_INSTALL_OBJS -ZIP_PROG_VFSSEARCH -ZIP_PROG_OPTIONS -ZIP_PROG -TCLSH_PROG -EXEEXT_FOR_BUILD -CC_FOR_BUILD -ZLIB_OBJS -ZLIB_LIBS -ZLIB_DLL_FILE -CFLAGS_WARNING -CFLAGS_OPTIMIZE -CFLAGS_DEBUG -DL_LIBS -WINE -CYGPATH -SHARED_BUILD -SET_MAKE -RC -RANLIB -AR -EGREP -GREP -CPP -OBJEXT -EXEEXT -ac_ct_CC -CPPFLAGS -LDFLAGS -CFLAGS -CC -target_alias -host_alias -build_alias -LIBS -ECHO_T -ECHO_N -ECHO_C -DEFS -mandir -localedir -libdir -psdir -pdfdir -dvidir -htmldir -infodir -docdir -oldincludedir -includedir -localstatedir -sharedstatedir -sysconfdir -datadir -datarootdir -libexecdir -sbindir -bindir -program_transform_name -prefix -exec_prefix -PACKAGE_URL -PACKAGE_BUGREPORT -PACKAGE_STRING -PACKAGE_VERSION -PACKAGE_TARNAME -PACKAGE_NAME -PATH_SEPARATOR -SHELL -OBJEXT_FOR_BUILD' +ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS CC CFLAGS LDFLAGS CPPFLAGS ac_ct_CC EXEEXT OBJEXT CPP EGREP AR ac_ct_AR RANLIB ac_ct_RANLIB RC ac_ct_RC SET_MAKE TCL_THREADS CYGPATH CELIB_DIR DL_LIBS CFLAGS_DEBUG CFLAGS_OPTIMIZE CFLAGS_WARNING ZLIB_DLL_FILE ZLIB_LIBS ZLIB_OBJS CFLAGS_DEFAULT LDFLAGS_DEFAULT VC_MANIFEST_EMBED_DLL VC_MANIFEST_EMBED_EXE TCL_WIN_VERSION MACHINE TCL_VERSION TCL_MAJOR_VERSION TCL_MINOR_VERSION TCL_PATCH_LEVEL PKG_CFG_ARGS TCL_EXE TCL_LIB_FILE TCL_LIB_FLAG TCL_STATIC_LIB_FILE TCL_STATIC_LIB_FLAG TCL_IMPORT_LIB_FILE TCL_IMPORT_LIB_FLAG TCL_LIB_SPEC TCL_STUB_LIB_FILE TCL_STUB_LIB_FLAG TCL_STUB_LIB_SPEC TCL_STUB_LIB_PATH TCL_INCLUDE_SPEC TCL_BUILD_STUB_LIB_SPEC TCL_BUILD_STUB_LIB_PATH TCL_DLL_FILE TCL_SRC_DIR TCL_BIN_DIR TCL_DBGX CFG_TCL_SHARED_LIB_SUFFIX CFG_TCL_UNSHARED_LIB_SUFFIX CFG_TCL_EXPORT_FILE_SUFFIX EXTRA_CFLAGS DEPARG CC_OBJNAME CC_EXENAME LDFLAGS_DEBUG LDFLAGS_OPTIMIZE LDFLAGS_CONSOLE LDFLAGS_WINDOW STLIB_LD SHLIB_LD SHLIB_LD_LIBS SHLIB_CFLAGS SHLIB_SUFFIX TCL_SHARED_BUILD LIBS_GUI DLLSUFFIX LIBPREFIX LIBSUFFIX EXESUFFIX LIBRARIES MAKE_LIB MAKE_STUB_LIB POST_MAKE_LIB MAKE_DLL MAKE_EXE TCL_BUILD_LIB_SPEC TCL_CC_SEARCH_FLAGS TCL_LD_SEARCH_FLAGS TCL_NEEDS_EXP_FILE TCL_BUILD_EXP_FILE TCL_EXP_FILE TCL_LIB_VERSIONS_OK TCL_PACKAGE_PATH TCL_DDE_VERSION TCL_DDE_MAJOR_VERSION TCL_DDE_MINOR_VERSION TCL_REG_VERSION TCL_REG_MAJOR_VERSION TCL_REG_MINOR_VERSION RC_OUT RC_TYPE RC_INCLUDE RC_DEFINE RC_DEFINES RES LIBOBJS LTLIBOBJS' ac_subst_files='' -ac_user_opts=' -enable_option_checking -with_encoding -enable_shared -enable_64bit -enable_zipfs -enable_symbols -enable_embedded_manifest -' - ac_precious_vars='build_alias -host_alias -target_alias -CC -CFLAGS -LDFLAGS -LIBS -CPPFLAGS -CPP' - # Initialize some variables set by options. ac_init_help= ac_init_version=false -ac_unrecognized_opts= -ac_unrecognized_sep= # The variables have the same names as the options, with # dashes changed to underlines. cache_file=/dev/null exec_prefix=NONE no_create= @@ -819,53 +335,38 @@ # Installation directory options. # These are left unexpanded so users can "make install exec_prefix=/foo" # and all the variables that are supposed to be based on exec_prefix # by default will actually change. # Use braces instead of parens because sh, perl, etc. also accept them. -# (The list follows the same order as the GNU Coding Standards.) bindir='${exec_prefix}/bin' sbindir='${exec_prefix}/sbin' libexecdir='${exec_prefix}/libexec' -datarootdir='${prefix}/share' -datadir='${datarootdir}' +datadir='${prefix}/share' sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var' +libdir='${exec_prefix}/lib' includedir='${prefix}/include' oldincludedir='/usr/include' -docdir='${datarootdir}/doc/${PACKAGE}' -infodir='${datarootdir}/info' -htmldir='${docdir}' -dvidir='${docdir}' -pdfdir='${docdir}' -psdir='${docdir}' -libdir='${exec_prefix}/lib' -localedir='${datarootdir}/locale' -mandir='${datarootdir}/man' +infodir='${prefix}/info' +mandir='${prefix}/man' ac_prev= -ac_dashdash= for ac_option do # If the previous option needs an argument, assign it. if test -n "$ac_prev"; then - eval $ac_prev=\$ac_option + eval "$ac_prev=\$ac_option" ac_prev= continue fi - case $ac_option in - *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; - *=) ac_optarg= ;; - *) ac_optarg=yes ;; - esac + ac_optarg=`expr "x$ac_option" : 'x[^=]*=\(.*\)'` # Accept the important Cygnus configure options, so we can diagnose typos. - case $ac_dashdash$ac_option in - --) - ac_dashdash=yes ;; + case $ac_option in -bindir | --bindir | --bindi | --bind | --bin | --bi) ac_prev=bindir ;; -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) bindir=$ac_optarg ;; @@ -883,63 +384,37 @@ cache_file=$ac_optarg ;; --config-cache | -C) cache_file=config.cache ;; - -datadir | --datadir | --datadi | --datad) + -datadir | --datadir | --datadi | --datad | --data | --dat | --da) ac_prev=datadir ;; - -datadir=* | --datadir=* | --datadi=* | --datad=*) + -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \ + | --da=*) datadir=$ac_optarg ;; - -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ - | --dataroo | --dataro | --datar) - ac_prev=datarootdir ;; - -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ - | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) - datarootdir=$ac_optarg ;; - -disable-* | --disable-*) - ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` + ac_feature=`expr "x$ac_option" : 'x-*disable-\(.*\)'` # Reject names that are not valid shell variable names. - expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid feature name: $ac_useropt" - ac_useropt_orig=$ac_useropt - ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` - case $ac_user_opts in - *" -"enable_$ac_useropt" -"*) ;; - *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" - ac_unrecognized_sep=', ';; - esac - eval enable_$ac_useropt=no ;; - - -docdir | --docdir | --docdi | --doc | --do) - ac_prev=docdir ;; - -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) - docdir=$ac_optarg ;; - - -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) - ac_prev=dvidir ;; - -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) - dvidir=$ac_optarg ;; + expr "x$ac_feature" : ".*[^-_$as_cr_alnum]" >/dev/null && + { echo "$as_me: error: invalid feature name: $ac_feature" >&2 + { (exit 1); exit 1; }; } + ac_feature=`echo $ac_feature | sed 's/-/_/g'` + eval "enable_$ac_feature=no" ;; -enable-* | --enable-*) - ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` + ac_feature=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` # Reject names that are not valid shell variable names. - expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid feature name: $ac_useropt" - ac_useropt_orig=$ac_useropt - ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` - case $ac_user_opts in - *" -"enable_$ac_useropt" -"*) ;; - *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" - ac_unrecognized_sep=', ';; + expr "x$ac_feature" : ".*[^-_$as_cr_alnum]" >/dev/null && + { echo "$as_me: error: invalid feature name: $ac_feature" >&2 + { (exit 1); exit 1; }; } + ac_feature=`echo $ac_feature | sed 's/-/_/g'` + case $ac_option in + *=*) ac_optarg=`echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"`;; + *) ac_optarg=yes ;; esac - eval enable_$ac_useropt=\$ac_optarg ;; + eval "enable_$ac_feature='$ac_optarg'" ;; -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ | --exec | --exe | --ex) ac_prev=exec_prefix ;; @@ -962,16 +437,10 @@ -host | --host | --hos | --ho) ac_prev=host_alias ;; -host=* | --host=* | --hos=* | --ho=*) host_alias=$ac_optarg ;; - -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) - ac_prev=htmldir ;; - -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ - | --ht=*) - htmldir=$ac_optarg ;; - -includedir | --includedir | --includedi | --included | --include \ | --includ | --inclu | --incl | --inc) ac_prev=includedir ;; -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ | --includ=* | --inclu=* | --incl=* | --inc=*) @@ -992,20 +461,17 @@ ac_prev=libexecdir ;; -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ | --libexe=* | --libex=* | --libe=*) libexecdir=$ac_optarg ;; - -localedir | --localedir | --localedi | --localed | --locale) - ac_prev=localedir ;; - -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) - localedir=$ac_optarg ;; - -localstatedir | --localstatedir | --localstatedi | --localstated \ - | --localstate | --localstat | --localsta | --localst | --locals) + | --localstate | --localstat | --localsta | --localst \ + | --locals | --local | --loca | --loc | --lo) ac_prev=localstatedir ;; -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ - | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) + | --localstate=* | --localstat=* | --localsta=* | --localst=* \ + | --locals=* | --local=* | --loca=* | --loc=* | --lo=*) localstatedir=$ac_optarg ;; -mandir | --mandir | --mandi | --mand | --man | --ma | --m) ac_prev=mandir ;; -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) @@ -1066,20 +532,10 @@ | --program-transfo=* | --program-transf=* \ | --program-trans=* | --program-tran=* \ | --progr-tra=* | --program-tr=* | --program-t=*) program_transform_name=$ac_optarg ;; - -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) - ac_prev=pdfdir ;; - -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) - pdfdir=$ac_optarg ;; - - -psdir | --psdir | --psdi | --psd | --ps) - ac_prev=psdir ;; - -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) - psdir=$ac_optarg ;; - -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) silent=yes ;; -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) @@ -1126,40 +582,30 @@ -version | --version | --versio | --versi | --vers | -V) ac_init_version=: ;; -with-* | --with-*) - ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` + ac_package=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` # Reject names that are not valid shell variable names. - expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid package name: $ac_useropt" - ac_useropt_orig=$ac_useropt - ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` - case $ac_user_opts in - *" -"with_$ac_useropt" -"*) ;; - *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" - ac_unrecognized_sep=', ';; + expr "x$ac_package" : ".*[^-_$as_cr_alnum]" >/dev/null && + { echo "$as_me: error: invalid package name: $ac_package" >&2 + { (exit 1); exit 1; }; } + ac_package=`echo $ac_package| sed 's/-/_/g'` + case $ac_option in + *=*) ac_optarg=`echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"`;; + *) ac_optarg=yes ;; esac - eval with_$ac_useropt=\$ac_optarg ;; + eval "with_$ac_package='$ac_optarg'" ;; -without-* | --without-*) - ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` + ac_package=`expr "x$ac_option" : 'x-*without-\(.*\)'` # Reject names that are not valid shell variable names. - expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid package name: $ac_useropt" - ac_useropt_orig=$ac_useropt - ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` - case $ac_user_opts in - *" -"with_$ac_useropt" -"*) ;; - *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" - ac_unrecognized_sep=', ';; - esac - eval with_$ac_useropt=no ;; + expr "x$ac_package" : ".*[^-_$as_cr_alnum]" >/dev/null && + { echo "$as_me: error: invalid package name: $ac_package" >&2 + { (exit 1); exit 1; }; } + ac_package=`echo $ac_package | sed 's/-/_/g'` + eval "with_$ac_package=no" ;; --x) # Obsolete; use --with-x. with_x=yes ;; @@ -1175,67 +621,63 @@ ac_prev=x_libraries ;; -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) x_libraries=$ac_optarg ;; - -*) as_fn_error $? "unrecognized option: \`$ac_option' -Try \`$0 --help' for more information" + -*) { echo "$as_me: error: unrecognized option: $ac_option +Try \`$0 --help' for more information." >&2 + { (exit 1); exit 1; }; } ;; *=*) ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` # Reject names that are not valid shell variable names. - case $ac_envvar in #( - '' | [0-9]* | *[!_$as_cr_alnum]* ) - as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; - esac - eval $ac_envvar=\$ac_optarg + expr "x$ac_envvar" : ".*[^_$as_cr_alnum]" >/dev/null && + { echo "$as_me: error: invalid variable name: $ac_envvar" >&2 + { (exit 1); exit 1; }; } + ac_optarg=`echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` + eval "$ac_envvar='$ac_optarg'" export $ac_envvar ;; *) # FIXME: should be removed in autoconf 3.0. - $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 + echo "$as_me: WARNING: you should use --build, --host, --target" >&2 expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && - $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 - : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" + echo "$as_me: WARNING: invalid host type: $ac_option" >&2 + : ${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option} ;; esac done if test -n "$ac_prev"; then ac_option=--`echo $ac_prev | sed 's/_/-/g'` - as_fn_error $? "missing argument to $ac_option" -fi - -if test -n "$ac_unrecognized_opts"; then - case $enable_option_checking in - no) ;; - fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; - *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; - esac -fi - -# Check all directory arguments for consistency. -for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ - datadir sysconfdir sharedstatedir localstatedir includedir \ - oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ - libdir localedir mandir -do - eval ac_val=\$$ac_var - # Remove trailing slashes. - case $ac_val in - */ ) - ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` - eval $ac_var=\$ac_val;; - esac - # Be sure to have absolute directory names. - case $ac_val in - [\\/$]* | ?:[\\/]* ) continue;; - NONE | '' ) case $ac_var in *prefix ) continue;; esac;; - esac - as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" + { echo "$as_me: error: missing argument to $ac_option" >&2 + { (exit 1); exit 1; }; } +fi + +# Be sure to have absolute paths. +for ac_var in exec_prefix prefix +do + eval ac_val=$`echo $ac_var` + case $ac_val in + [\\/$]* | ?:[\\/]* | NONE | '' ) ;; + *) { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2 + { (exit 1); exit 1; }; };; + esac +done + +# Be sure to have absolute paths. +for ac_var in bindir sbindir libexecdir datadir sysconfdir sharedstatedir \ + localstatedir libdir includedir oldincludedir infodir mandir +do + eval ac_val=$`echo $ac_var` + case $ac_val in + [\\/$]* | ?:[\\/]* ) ;; + *) { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2 + { (exit 1); exit 1; }; };; + esac done # There might be people who depend on the old broken behavior: `$host' # used to hold the argument of --host etc. # FIXME: To remove some day. @@ -1245,10 +687,12 @@ # FIXME: To remove some day. if test "x$host_alias" != x; then if test "x$build_alias" = x; then cross_compiling=maybe + echo "$as_me: WARNING: If you wanted to set the --build type, don't use --host. + If a cross compiler is detected then cross compile mode will be used." >&2 elif test "x$build_alias" != "x$host_alias"; then cross_compiling=yes fi fi @@ -1255,77 +699,79 @@ ac_tool_prefix= test -n "$host_alias" && ac_tool_prefix=$host_alias- test "$silent" = yes && exec 6>/dev/null - -ac_pwd=`pwd` && test -n "$ac_pwd" && -ac_ls_di=`ls -di .` && -ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || - as_fn_error $? "working directory cannot be determined" -test "X$ac_ls_di" = "X$ac_pwd_ls_di" || - as_fn_error $? "pwd does not report name of working directory" - # Find the source files, if location was not specified. if test -z "$srcdir"; then ac_srcdir_defaulted=yes - # Try the directory containing this script, then the parent directory. - ac_confdir=`$as_dirname -- "$as_myself" || -$as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$as_myself" : 'X\(//\)[^/]' \| \ - X"$as_myself" : 'X\(//\)$' \| \ - X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X"$as_myself" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` + # Try the directory containing this script, then its parent. + ac_confdir=`(dirname "$0") 2>/dev/null || +$as_expr X"$0" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$0" : 'X\(//\)[^/]' \| \ + X"$0" : 'X\(//\)$' \| \ + X"$0" : 'X\(/\)' \| \ + . : '\(.\)' 2>/dev/null || +echo X"$0" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } + /^X\(\/\/\)[^/].*/{ s//\1/; q; } + /^X\(\/\/\)$/{ s//\1/; q; } + /^X\(\/\).*/{ s//\1/; q; } + s/.*/./; q'` srcdir=$ac_confdir - if test ! -r "$srcdir/$ac_unique_file"; then + if test ! -r $srcdir/$ac_unique_file; then srcdir=.. fi else ac_srcdir_defaulted=no fi -if test ! -r "$srcdir/$ac_unique_file"; then - test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." - as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" -fi -ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" -ac_abs_confdir=`( - cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" - pwd)` -# When building in place, set srcdir=. -if test "$ac_abs_confdir" = "$ac_pwd"; then - srcdir=. -fi -# Remove unnecessary trailing slashes from srcdir. -# Double slashes in file names in object file debugging info -# mess up M-x gdb in Emacs. -case $srcdir in -*/) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; -esac -for ac_var in $ac_precious_vars; do - eval ac_env_${ac_var}_set=\${${ac_var}+set} - eval ac_env_${ac_var}_value=\$${ac_var} - eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} - eval ac_cv_env_${ac_var}_value=\$${ac_var} -done +if test ! -r $srcdir/$ac_unique_file; then + if test "$ac_srcdir_defaulted" = yes; then + { echo "$as_me: error: cannot find sources ($ac_unique_file) in $ac_confdir or .." >&2 + { (exit 1); exit 1; }; } + else + { echo "$as_me: error: cannot find sources ($ac_unique_file) in $srcdir" >&2 + { (exit 1); exit 1; }; } + fi +fi +(cd $srcdir && test -r ./$ac_unique_file) 2>/dev/null || + { echo "$as_me: error: sources are in $srcdir, but \`cd $srcdir' does not work" >&2 + { (exit 1); exit 1; }; } +srcdir=`echo "$srcdir" | sed 's%\([^\\/]\)[\\/]*$%\1%'` +ac_env_build_alias_set=${build_alias+set} +ac_env_build_alias_value=$build_alias +ac_cv_env_build_alias_set=${build_alias+set} +ac_cv_env_build_alias_value=$build_alias +ac_env_host_alias_set=${host_alias+set} +ac_env_host_alias_value=$host_alias +ac_cv_env_host_alias_set=${host_alias+set} +ac_cv_env_host_alias_value=$host_alias +ac_env_target_alias_set=${target_alias+set} +ac_env_target_alias_value=$target_alias +ac_cv_env_target_alias_set=${target_alias+set} +ac_cv_env_target_alias_value=$target_alias +ac_env_CC_set=${CC+set} +ac_env_CC_value=$CC +ac_cv_env_CC_set=${CC+set} +ac_cv_env_CC_value=$CC +ac_env_CFLAGS_set=${CFLAGS+set} +ac_env_CFLAGS_value=$CFLAGS +ac_cv_env_CFLAGS_set=${CFLAGS+set} +ac_cv_env_CFLAGS_value=$CFLAGS +ac_env_LDFLAGS_set=${LDFLAGS+set} +ac_env_LDFLAGS_value=$LDFLAGS +ac_cv_env_LDFLAGS_set=${LDFLAGS+set} +ac_cv_env_LDFLAGS_value=$LDFLAGS +ac_env_CPPFLAGS_set=${CPPFLAGS+set} +ac_env_CPPFLAGS_value=$CPPFLAGS +ac_cv_env_CPPFLAGS_set=${CPPFLAGS+set} +ac_cv_env_CPPFLAGS_value=$CPPFLAGS +ac_env_CPP_set=${CPP+set} +ac_env_CPP_value=$CPP +ac_cv_env_CPP_set=${CPP+set} +ac_cv_env_CPP_value=$CPP # # Report the --help message. # if test "$ac_init_help" = "long"; then @@ -1344,49 +790,45 @@ Configuration: -h, --help display this help and exit --help=short display options specific to this package --help=recursive display the short help of all the included packages -V, --version display version information and exit - -q, --quiet, --silent do not print \`checking ...' messages + -q, --quiet, --silent do not print \`checking...' messages --cache-file=FILE cache test results in FILE [disabled] -C, --config-cache alias for \`--cache-file=config.cache' -n, --no-create do not create output files --srcdir=DIR find the sources in DIR [configure dir or \`..'] +_ACEOF + + cat <<_ACEOF Installation directories: --prefix=PREFIX install architecture-independent files in PREFIX - [$ac_default_prefix] + [$ac_default_prefix] --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX - [PREFIX] + [PREFIX] By default, \`make install' will install all the files in \`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify an installation prefix other than \`$ac_default_prefix' using \`--prefix', for instance \`--prefix=\$HOME'. For better control, use the options below. Fine tuning of the installation directories: - --bindir=DIR user executables [EPREFIX/bin] - --sbindir=DIR system admin executables [EPREFIX/sbin] - --libexecdir=DIR program executables [EPREFIX/libexec] - --sysconfdir=DIR read-only single-machine data [PREFIX/etc] - --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] - --localstatedir=DIR modifiable single-machine data [PREFIX/var] - --libdir=DIR object code libraries [EPREFIX/lib] - --includedir=DIR C header files [PREFIX/include] - --oldincludedir=DIR C header files for non-gcc [/usr/include] - --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] - --datadir=DIR read-only architecture-independent data [DATAROOTDIR] - --infodir=DIR info documentation [DATAROOTDIR/info] - --localedir=DIR locale-dependent data [DATAROOTDIR/locale] - --mandir=DIR man documentation [DATAROOTDIR/man] - --docdir=DIR documentation root [DATAROOTDIR/doc/PACKAGE] - --htmldir=DIR html documentation [DOCDIR] - --dvidir=DIR dvi documentation [DOCDIR] - --pdfdir=DIR pdf documentation [DOCDIR] - --psdir=DIR ps documentation [DOCDIR] + --bindir=DIR user executables [EPREFIX/bin] + --sbindir=DIR system admin executables [EPREFIX/sbin] + --libexecdir=DIR program executables [EPREFIX/libexec] + --datadir=DIR read-only architecture-independent data [PREFIX/share] + --sysconfdir=DIR read-only single-machine data [PREFIX/etc] + --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] + --localstatedir=DIR modifiable single-machine data [PREFIX/var] + --libdir=DIR object code libraries [EPREFIX/lib] + --includedir=DIR C header files [PREFIX/include] + --oldincludedir=DIR C header files for non-gcc [/usr/include] + --infodir=DIR info documentation [PREFIX/info] + --mandir=DIR man documentation [PREFIX/man] _ACEOF cat <<\_ACEOF _ACEOF fi @@ -1394,373 +836,152 @@ if test -n "$ac_init_help"; then cat <<\_ACEOF Optional Features: - --disable-option-checking ignore unrecognized --enable/--with options --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) --enable-FEATURE[=ARG] include FEATURE [ARG=yes] + --enable-threads build with threads (default: on) --enable-shared build and link with shared libraries (default: on) + --enable-time64bit force 64-bit time_t for 32-bit build (default: off) --enable-64bit enable 64bit support (where applicable) - --enable-zipfs build with Zipfs support (default: on) + --enable-wince enable Win/CE support (where applicable) --enable-symbols build with debugging symbols (default: off) --enable-embedded-manifest embed manifest if possible (default: yes) Optional Packages: --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) --with-encoding encoding for configuration values + --with-celib=DIR use Windows/CE support library from DIR Some influential environment variables: CC C compiler command CFLAGS C compiler flags LDFLAGS linker flags, e.g. -L if you have libraries in a nonstandard directory - LIBS libraries to pass to the linker, e.g. -l - CPPFLAGS (Objective) C/C++ preprocessor flags, e.g. -I if - you have headers in a nonstandard directory + CPPFLAGS C/C++ preprocessor flags, e.g. -I if you have + headers in a nonstandard directory CPP C preprocessor Use these variables to override the choices made by `configure' or to help it to find libraries and programs with nonstandard names/locations. -Report bugs to the package provider. _ACEOF -ac_status=$? fi if test "$ac_init_help" = "recursive"; then # If there are subdirs, report their specific --help. + ac_popdir=`pwd` for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue - test -d "$ac_dir" || - { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } || - continue + test -d $ac_dir || continue ac_builddir=. -case "$ac_dir" in -.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; -*) - ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` - # A ".." for each directory in $ac_dir_suffix. - ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` - case $ac_top_builddir_sub in - "") ac_top_builddir_sub=. ac_top_build_prefix= ;; - *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; - esac ;; -esac -ac_abs_top_builddir=$ac_pwd -ac_abs_builddir=$ac_pwd$ac_dir_suffix -# for backward compatibility: -ac_top_builddir=$ac_top_build_prefix +if test "$ac_dir" != .; then + ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'` + # A "../" for each directory in $ac_dir_suffix. + ac_top_builddir=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,../,g'` +else + ac_dir_suffix= ac_top_builddir= +fi case $srcdir in - .) # We are building in place. + .) # No --srcdir option. We are building in place. ac_srcdir=. - ac_top_srcdir=$ac_top_builddir_sub - ac_abs_top_srcdir=$ac_pwd ;; - [\\/]* | ?:[\\/]* ) # Absolute name. + if test -z "$ac_top_builddir"; then + ac_top_srcdir=. + else + ac_top_srcdir=`echo $ac_top_builddir | sed 's,/$,,'` + fi ;; + [\\/]* | ?:[\\/]* ) # Absolute path. ac_srcdir=$srcdir$ac_dir_suffix; - ac_top_srcdir=$srcdir - ac_abs_top_srcdir=$srcdir ;; - *) # Relative name. - ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix - ac_top_srcdir=$ac_top_build_prefix$srcdir - ac_abs_top_srcdir=$ac_pwd/$srcdir ;; + ac_top_srcdir=$srcdir ;; + *) # Relative path. + ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix + ac_top_srcdir=$ac_top_builddir$srcdir ;; +esac + +# Do not use `cd foo && pwd` to compute absolute paths, because +# the directories may not exist. +case `pwd` in +.) ac_abs_builddir="$ac_dir";; +*) + case "$ac_dir" in + .) ac_abs_builddir=`pwd`;; + [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";; + *) ac_abs_builddir=`pwd`/"$ac_dir";; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_top_builddir=${ac_top_builddir}.;; +*) + case ${ac_top_builddir}. in + .) ac_abs_top_builddir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;; + *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_srcdir=$ac_srcdir;; +*) + case $ac_srcdir in + .) ac_abs_srcdir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;; + *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_top_srcdir=$ac_top_srcdir;; +*) + case $ac_top_srcdir in + .) ac_abs_top_srcdir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;; + *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;; + esac;; esac -ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix - - cd "$ac_dir" || { ac_status=$?; continue; } - # Check for guested configure. - if test -f "$ac_srcdir/configure.gnu"; then - echo && - $SHELL "$ac_srcdir/configure.gnu" --help=recursive - elif test -f "$ac_srcdir/configure"; then - echo && - $SHELL "$ac_srcdir/configure" --help=recursive + + cd $ac_dir + # Check for guested configure; otherwise get Cygnus style configure. + if test -f $ac_srcdir/configure.gnu; then + echo + $SHELL $ac_srcdir/configure.gnu --help=recursive + elif test -f $ac_srcdir/configure; then + echo + $SHELL $ac_srcdir/configure --help=recursive + elif test -f $ac_srcdir/configure.ac || + test -f $ac_srcdir/configure.in; then + echo + $ac_configure --help else - $as_echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 - fi || ac_status=$? - cd "$ac_pwd" || { ac_status=$?; break; } + echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 + fi + cd $ac_popdir done fi -test -n "$ac_init_help" && exit $ac_status +test -n "$ac_init_help" && exit 0 if $ac_init_version; then cat <<\_ACEOF -configure -generated by GNU Autoconf 2.69 -Copyright (C) 2012 Free Software Foundation, Inc. +Copyright (C) 2003 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF - exit -fi - -## ------------------------ ## -## Autoconf initialization. ## -## ------------------------ ## - -# ac_fn_c_try_compile LINENO -# -------------------------- -# Try to compile conftest.$ac_ext, and return whether this succeeded. -ac_fn_c_try_compile () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - rm -f conftest.$ac_objext - if { { ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_compile") 2>conftest.err - ac_status=$? - if test -s conftest.err; then - grep -v '^ *+' conftest.err >conftest.er1 - cat conftest.er1 >&5 - mv -f conftest.er1 conftest.err - fi - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then : - ac_retval=0 -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_retval=1 -fi - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $ac_retval - -} # ac_fn_c_try_compile - -# ac_fn_c_try_cpp LINENO -# ---------------------- -# Try to preprocess conftest.$ac_ext, and return whether this succeeded. -ac_fn_c_try_cpp () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - if { { ac_try="$ac_cpp conftest.$ac_ext" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_cpp conftest.$ac_ext") 2>conftest.err - ac_status=$? - if test -s conftest.err; then - grep -v '^ *+' conftest.err >conftest.er1 - cat conftest.er1 >&5 - mv -f conftest.er1 conftest.err - fi - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } > conftest.i && { - test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || - test ! -s conftest.err - }; then : - ac_retval=0 -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_retval=1 -fi - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $ac_retval - -} # ac_fn_c_try_cpp - -# ac_fn_c_try_run LINENO -# ---------------------- -# Try to link conftest.$ac_ext, and return whether this succeeded. Assumes -# that executables *can* be run. -ac_fn_c_try_run () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - if { { ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_link") 2>&5 - ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } && { ac_try='./conftest$ac_exeext' - { { case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_try") 2>&5 - ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; }; }; then : - ac_retval=0 -else - $as_echo "$as_me: program exited with status $ac_status" >&5 - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_retval=$ac_status -fi - rm -rf conftest.dSYM conftest_ipa8_conftest.oo - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $ac_retval - -} # ac_fn_c_try_run - -# ac_fn_c_check_decl LINENO SYMBOL VAR INCLUDES -# --------------------------------------------- -# Tests whether SYMBOL is declared in INCLUDES, setting cache variable VAR -# accordingly. -ac_fn_c_check_decl () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - as_decl_name=`echo $2|sed 's/ *(.*//'` - as_decl_use=`echo $2|sed -e 's/(/((/' -e 's/)/) 0&/' -e 's/,/) 0& (/g'` - { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $as_decl_name is declared" >&5 -$as_echo_n "checking whether $as_decl_name is declared... " >&6; } -if eval \${$3+:} false; then : - $as_echo_n "(cached) " >&6 -else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -$4 -int -main () -{ -#ifndef $as_decl_name -#ifdef __cplusplus - (void) $as_decl_use; -#else - (void) $as_decl_name; -#endif -#endif - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - eval "$3=yes" -else - eval "$3=no" -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -fi -eval ac_res=\$$3 - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 -$as_echo "$ac_res" >&6; } - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - -} # ac_fn_c_check_decl - -# ac_fn_c_check_header_compile LINENO HEADER VAR INCLUDES -# ------------------------------------------------------- -# Tests whether HEADER exists and can be compiled using the include files in -# INCLUDES, setting the cache variable VAR accordingly. -ac_fn_c_check_header_compile () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 -$as_echo_n "checking for $2... " >&6; } -if eval \${$3+:} false; then : - $as_echo_n "(cached) " >&6 -else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -$4 -#include <$2> -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - eval "$3=yes" -else - eval "$3=no" -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -fi -eval ac_res=\$$3 - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 -$as_echo "$ac_res" >&6; } - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - -} # ac_fn_c_check_header_compile - -# ac_fn_c_check_type LINENO TYPE VAR INCLUDES -# ------------------------------------------- -# Tests whether TYPE exists after having included INCLUDES, setting cache -# variable VAR accordingly. -ac_fn_c_check_type () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 -$as_echo_n "checking for $2... " >&6; } -if eval \${$3+:} false; then : - $as_echo_n "(cached) " >&6 -else - eval "$3=no" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -$4 -int -main () -{ -if (sizeof ($2)) - return 0; - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -$4 -int -main () -{ -if (sizeof (($2))) - return 0; - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - -else - eval "$3=yes" -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -fi -eval ac_res=\$$3 - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 -$as_echo "$ac_res" >&6; } - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - -} # ac_fn_c_check_type -cat >config.log <<_ACEOF + exit 0 +fi +exec 5>config.log +cat >&5 <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. It was created by $as_me, which was -generated by GNU Autoconf 2.69. Invocation command line was +generated by GNU Autoconf 2.59. Invocation command line was $ $0 $@ _ACEOF -exec 5>>config.log { cat <<_ASUNAME ## --------- ## ## Platform. ## ## --------- ## @@ -1775,11 +996,11 @@ /bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` /bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` -/usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` +hostinfo = `(hostinfo) 2>/dev/null || echo unknown` /bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` /bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` _ASUNAME @@ -1787,13 +1008,12 @@ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - $as_echo "PATH: $as_dir" - done -IFS=$as_save_IFS + echo "PATH: $as_dir" +done } >&5 cat >&5 <<_ACEOF @@ -1811,10 +1031,11 @@ # Also quote any args containing shell meta-characters. # Make two passes to allow for proper duplicate-argument suppression. ac_configure_args= ac_configure_args0= ac_configure_args1= +ac_sep= ac_must_keep_next=false for ac_pass in 1 2 do for ac_arg do @@ -1821,17 +1042,17 @@ case $ac_arg in -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) continue ;; - *\'*) - ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; + *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?\"\']*) + ac_arg=`echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac case $ac_pass in - 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; + 1) ac_configure_args0="$ac_configure_args0 '$ac_arg'" ;; 2) - as_fn_append ac_configure_args1 " '$ac_arg'" + ac_configure_args1="$ac_configure_args1 '$ac_arg'" if test $ac_must_keep_next = true; then ac_must_keep_next=false # Got value, back to normal. else case $ac_arg in *=* | --config-cache | -C | -disable-* | --disable-* \ @@ -1843,276 +1064,257 @@ esac ;; -* ) ac_must_keep_next=true ;; esac fi - as_fn_append ac_configure_args " '$ac_arg'" + ac_configure_args="$ac_configure_args$ac_sep'$ac_arg'" + # Get rid of the leading space. + ac_sep=" " ;; esac done done -{ ac_configure_args0=; unset ac_configure_args0;} -{ ac_configure_args1=; unset ac_configure_args1;} +$as_unset ac_configure_args0 || test "${ac_configure_args0+set}" != set || { ac_configure_args0=; export ac_configure_args0; } +$as_unset ac_configure_args1 || test "${ac_configure_args1+set}" != set || { ac_configure_args1=; export ac_configure_args1; } # When interrupted or exit'd, cleanup temporary files, and complete # config.log. We remove comments because anyway the quotes in there # would cause problems or look ugly. -# WARNING: Use '\'' to represent an apostrophe within the trap. -# WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. +# WARNING: Be sure not to use single quotes in there, as some shells, +# such as our DU 5.0 friend, will then `close' the trap. trap 'exit_status=$? # Save into config.log some information that might help in debugging. { echo - $as_echo "## ---------------- ## + cat <<\_ASBOX +## ---------------- ## ## Cache variables. ## -## ---------------- ##" +## ---------------- ## +_ASBOX echo # The following way of writing the cache mishandles newlines in values, -( - for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do - eval ac_val=\$$ac_var - case $ac_val in #( - *${as_nl}*) - case $ac_var in #( - *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 -$as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; - esac - case $ac_var in #( - _ | IFS | as_nl) ;; #( - BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( - *) { eval $ac_var=; unset $ac_var;} ;; - esac ;; - esac - done +{ (set) 2>&1 | - case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( - *${as_nl}ac_space=\ *) + case `(ac_space='"'"' '"'"'; set | grep ac_space) 2>&1` in + *ac_space=\ *) + sed -n \ + "s/'"'"'/'"'"'\\\\'"'"''"'"'/g; + s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='"'"'\\2'"'"'/p" + ;; + *) sed -n \ - "s/'\''/'\''\\\\'\'''\''/g; - s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" - ;; #( - *) - sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" + "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p" ;; - esac | - sort -) + esac; +} echo - $as_echo "## ----------------- ## + cat <<\_ASBOX +## ----------------- ## ## Output variables. ## -## ----------------- ##" +## ----------------- ## +_ASBOX echo for ac_var in $ac_subst_vars do - eval ac_val=\$$ac_var - case $ac_val in - *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; - esac - $as_echo "$ac_var='\''$ac_val'\''" + eval ac_val=$`echo $ac_var` + echo "$ac_var='"'"'$ac_val'"'"'" done | sort echo if test -n "$ac_subst_files"; then - $as_echo "## ------------------- ## -## File substitutions. ## -## ------------------- ##" + cat <<\_ASBOX +## ------------- ## +## Output files. ## +## ------------- ## +_ASBOX echo for ac_var in $ac_subst_files do - eval ac_val=\$$ac_var - case $ac_val in - *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; - esac - $as_echo "$ac_var='\''$ac_val'\''" + eval ac_val=$`echo $ac_var` + echo "$ac_var='"'"'$ac_val'"'"'" done | sort echo fi if test -s confdefs.h; then - $as_echo "## ----------- ## + cat <<\_ASBOX +## ----------- ## ## confdefs.h. ## -## ----------- ##" +## ----------- ## +_ASBOX echo - cat confdefs.h + sed "/^$/d" confdefs.h | sort echo fi test "$ac_signal" != 0 && - $as_echo "$as_me: caught signal $ac_signal" - $as_echo "$as_me: exit $exit_status" + echo "$as_me: caught signal $ac_signal" + echo "$as_me: exit $exit_status" } >&5 - rm -f core *.core core.conftest.* && - rm -f -r conftest* confdefs* conf$$* $ac_clean_files && + rm -f core *.core && + rm -rf conftest* confdefs* conf$$* $ac_clean_files && exit $exit_status -' 0 + ' 0 for ac_signal in 1 2 13 15; do - trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal + trap 'ac_signal='$ac_signal'; { (exit 1); exit 1; }' $ac_signal done ac_signal=0 # confdefs.h avoids OS command line length limits that DEFS can exceed. -rm -f -r conftest* confdefs.h - -$as_echo "/* confdefs.h */" > confdefs.h +rm -rf conftest* confdefs.h +# AIX cpp loses on an empty file, so make sure it contains at least a newline. +echo >confdefs.h # Predefined preprocessor variables. cat >>confdefs.h <<_ACEOF #define PACKAGE_NAME "$PACKAGE_NAME" _ACEOF + cat >>confdefs.h <<_ACEOF #define PACKAGE_TARNAME "$PACKAGE_TARNAME" _ACEOF + cat >>confdefs.h <<_ACEOF #define PACKAGE_VERSION "$PACKAGE_VERSION" _ACEOF + cat >>confdefs.h <<_ACEOF #define PACKAGE_STRING "$PACKAGE_STRING" _ACEOF + cat >>confdefs.h <<_ACEOF #define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" _ACEOF -cat >>confdefs.h <<_ACEOF -#define PACKAGE_URL "$PACKAGE_URL" -_ACEOF - # Let the site file select an alternate cache file if it wants to. -# Prefer an explicitly selected file to automatically selected ones. -ac_site_file1=NONE -ac_site_file2=NONE -if test -n "$CONFIG_SITE"; then - # We do not want a PATH search for config.site. - case $CONFIG_SITE in #(( - -*) ac_site_file1=./$CONFIG_SITE;; - */*) ac_site_file1=$CONFIG_SITE;; - *) ac_site_file1=./$CONFIG_SITE;; - esac -elif test "x$prefix" != xNONE; then - ac_site_file1=$prefix/share/config.site - ac_site_file2=$prefix/etc/config.site -else - ac_site_file1=$ac_default_prefix/share/config.site - ac_site_file2=$ac_default_prefix/etc/config.site +# Prefer explicitly selected file to automatically selected ones. +if test -z "$CONFIG_SITE"; then + if test "x$prefix" != xNONE; then + CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site" + else + CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" + fi fi -for ac_site_file in "$ac_site_file1" "$ac_site_file2" -do - test "x$ac_site_file" = xNONE && continue - if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 -$as_echo "$as_me: loading site script $ac_site_file" >&6;} +for ac_site_file in $CONFIG_SITE; do + if test -r "$ac_site_file"; then + { echo "$as_me:$LINENO: loading site script $ac_site_file" >&5 +echo "$as_me: loading site script $ac_site_file" >&6;} sed 's/^/| /' "$ac_site_file" >&5 - . "$ac_site_file" \ - || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "failed to load site script $ac_site_file -See \`config.log' for more details" "$LINENO" 5; } + . "$ac_site_file" fi done if test -r "$cache_file"; then - # Some versions of bash will fail to source /dev/null (special files - # actually), so we avoid doing that. DJGPP emulates it as a regular file. - if test /dev/null != "$cache_file" && test -f "$cache_file"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 -$as_echo "$as_me: loading cache $cache_file" >&6;} + # Some versions of bash will fail to source /dev/null (special + # files actually), so we avoid doing that. + if test -f "$cache_file"; then + { echo "$as_me:$LINENO: loading cache $cache_file" >&5 +echo "$as_me: loading cache $cache_file" >&6;} case $cache_file in - [\\/]* | ?:[\\/]* ) . "$cache_file";; - *) . "./$cache_file";; + [\\/]* | ?:[\\/]* ) . $cache_file;; + *) . ./$cache_file;; esac fi else - { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 -$as_echo "$as_me: creating cache $cache_file" >&6;} + { echo "$as_me:$LINENO: creating cache $cache_file" >&5 +echo "$as_me: creating cache $cache_file" >&6;} >$cache_file fi # Check that the precious variables saved in the cache have kept the same # value. ac_cache_corrupted=false -for ac_var in $ac_precious_vars; do +for ac_var in `(set) 2>&1 | + sed -n 's/^ac_env_\([a-zA-Z_0-9]*\)_set=.*/\1/p'`; do eval ac_old_set=\$ac_cv_env_${ac_var}_set eval ac_new_set=\$ac_env_${ac_var}_set - eval ac_old_val=\$ac_cv_env_${ac_var}_value - eval ac_new_val=\$ac_env_${ac_var}_value + eval ac_old_val="\$ac_cv_env_${ac_var}_value" + eval ac_new_val="\$ac_env_${ac_var}_value" case $ac_old_set,$ac_new_set in set,) - { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 -$as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} + { echo "$as_me:$LINENO: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 +echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) - { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 -$as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} + { echo "$as_me:$LINENO: error: \`$ac_var' was not set in the previous run" >&5 +echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} ac_cache_corrupted=: ;; ,);; *) if test "x$ac_old_val" != "x$ac_new_val"; then - # differences in whitespace do not lead to failure. - ac_old_val_w=`echo x $ac_old_val` - ac_new_val_w=`echo x $ac_new_val` - if test "$ac_old_val_w" != "$ac_new_val_w"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 -$as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} - ac_cache_corrupted=: - else - { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 -$as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} - eval $ac_var=\$ac_old_val - fi - { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 -$as_echo "$as_me: former value: \`$ac_old_val'" >&2;} - { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 -$as_echo "$as_me: current value: \`$ac_new_val'" >&2;} + { echo "$as_me:$LINENO: error: \`$ac_var' has changed since the previous run:" >&5 +echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} + { echo "$as_me:$LINENO: former value: $ac_old_val" >&5 +echo "$as_me: former value: $ac_old_val" >&2;} + { echo "$as_me:$LINENO: current value: $ac_new_val" >&5 +echo "$as_me: current value: $ac_new_val" >&2;} + ac_cache_corrupted=: fi;; esac # Pass precious variables to config.status. if test "$ac_new_set" = set; then case $ac_new_val in - *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; + *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?\"\']*) + ac_arg=$ac_var=`echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; *) ac_arg=$ac_var=$ac_new_val ;; esac case " $ac_configure_args " in *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. - *) as_fn_append ac_configure_args " '$ac_arg'" ;; + *) ac_configure_args="$ac_configure_args '$ac_arg'" ;; esac fi done if $ac_cache_corrupted; then - { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} - { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 -$as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} - as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 + { echo "$as_me:$LINENO: error: changes in the environment can compromise the build" >&5 +echo "$as_me: error: changes in the environment can compromise the build" >&2;} + { { echo "$as_me:$LINENO: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&5 +echo "$as_me: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&2;} + { (exit 1); exit 1; }; } fi -## -------------------- ## -## Main body of script. ## -## -------------------- ## ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu + + + + + + + + + + + + + + + + + # The following define is needed when building with Cygwin since newer # versions of autoconf incorrectly set SHELL to /bin/bash instead of # /bin/sh. The bash shell seems to suffer from some strange failures. SHELL=/bin/sh -TCL_VERSION=9.0 -TCL_MAJOR_VERSION=9 -TCL_MINOR_VERSION=0 -TCL_PATCH_LEVEL="a0" +TCL_VERSION=8.6 +TCL_MAJOR_VERSION=8 +TCL_MINOR_VERSION=6 +TCL_PATCH_LEVEL=".10" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 TCL_DDE_MAJOR_VERSION=1 TCL_DDE_MINOR_VERSION=4 @@ -2159,147 +1361,174 @@ ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args. set dummy ${ac_tool_prefix}gcc; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_CC+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CC="${ac_tool_prefix}gcc" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done - done -IFS=$as_save_IFS +done fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 -$as_echo "$CC" >&6; } + echo "$as_me:$LINENO: result: $CC" >&5 +echo "${ECHO_T}$CC" >&6 else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 fi - fi if test -z "$ac_cv_prog_CC"; then ac_ct_CC=$CC # Extract the first word of "gcc", so it can be a program name with args. set dummy gcc; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_ac_ct_CC+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_ac_ct_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="gcc" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done - done -IFS=$as_save_IFS +done fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 -$as_echo "$ac_ct_CC" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - if test "x$ac_ct_CC" = x; then - CC="" - else - case $cross_compiling:$ac_tool_warned in -yes:) -{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 -$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} -ac_tool_warned=yes ;; -esac - CC=$ac_ct_CC - fi + echo "$as_me:$LINENO: result: $ac_ct_CC" >&5 +echo "${ECHO_T}$ac_ct_CC" >&6 +else + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 +fi + + CC=$ac_ct_CC else CC="$ac_cv_prog_CC" fi if test -z "$CC"; then - if test -n "$ac_tool_prefix"; then - # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args. + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args. set dummy ${ac_tool_prefix}cc; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_CC+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CC="${ac_tool_prefix}cc" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done - done -IFS=$as_save_IFS +done fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 -$as_echo "$CC" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - - fi + echo "$as_me:$LINENO: result: $CC" >&5 +echo "${ECHO_T}$CC" >&6 +else + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 +fi + +fi +if test -z "$ac_cv_prog_CC"; then + ac_ct_CC=$CC + # Extract the first word of "cc", so it can be a program name with args. +set dummy cc; ac_word=$2 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_ac_ct_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + if test -n "$ac_ct_CC"; then + ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_CC="cc" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done +done + +fi +fi +ac_ct_CC=$ac_cv_prog_ac_ct_CC +if test -n "$ac_ct_CC"; then + echo "$as_me:$LINENO: result: $ac_ct_CC" >&5 +echo "${ECHO_T}$ac_ct_CC" >&6 +else + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 +fi + + CC=$ac_ct_CC +else + CC="$ac_cv_prog_CC" +fi + fi if test -z "$CC"; then # Extract the first word of "cc", so it can be a program name with args. set dummy cc; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_CC+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else ac_prog_rejected=no @@ -2306,23 +1535,22 @@ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then if test "$as_dir/$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then ac_prog_rejected=yes continue fi ac_cv_prog_CC="cc" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done - done -IFS=$as_save_IFS +done if test $ac_prog_rejected = yes; then # We found a bogon in the path, so make sure we never use it. set dummy $ac_cv_prog_CC shift @@ -2336,154 +1564,139 @@ fi fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 -$as_echo "$CC" >&6; } + echo "$as_me:$LINENO: result: $CC" >&5 +echo "${ECHO_T}$CC" >&6 else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 fi - fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then - for ac_prog in cl.exe + for ac_prog in cl do # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. set dummy $ac_tool_prefix$ac_prog; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_CC+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CC="$ac_tool_prefix$ac_prog" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done - done -IFS=$as_save_IFS +done fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 -$as_echo "$CC" >&6; } + echo "$as_me:$LINENO: result: $CC" >&5 +echo "${ECHO_T}$CC" >&6 else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 fi - test -n "$CC" && break done fi if test -z "$CC"; then ac_ct_CC=$CC - for ac_prog in cl.exe + for ac_prog in cl do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_ac_ct_CC+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_ac_ct_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="$ac_prog" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done - done -IFS=$as_save_IFS +done fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 -$as_echo "$ac_ct_CC" >&6; } + echo "$as_me:$LINENO: result: $ac_ct_CC" >&5 +echo "${ECHO_T}$ac_ct_CC" >&6 else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 fi - test -n "$ac_ct_CC" && break done - if test "x$ac_ct_CC" = x; then - CC="" - else - case $cross_compiling:$ac_tool_warned in -yes:) -{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 -$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} -ac_tool_warned=yes ;; -esac - CC=$ac_ct_CC - fi + CC=$ac_ct_CC fi fi -test -z "$CC" && { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "no acceptable C compiler found in \$PATH -See \`config.log' for more details" "$LINENO" 5; } +test -z "$CC" && { { echo "$as_me:$LINENO: error: no acceptable C compiler found in \$PATH +See \`config.log' for more details." >&5 +echo "$as_me: error: no acceptable C compiler found in \$PATH +See \`config.log' for more details." >&2;} + { (exit 1); exit 1; }; } # Provide some information about the compiler. -$as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5 -set X $ac_compile -ac_compiler=$2 -for ac_option in --version -v -V -qversion; do - { { ac_try="$ac_compiler $ac_option >&5" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_compiler $ac_option >&5") 2>conftest.err +echo "$as_me:$LINENO:" \ + "checking for C compiler version" >&5 +ac_compiler=`set X $ac_compile; echo $2` +{ (eval echo "$as_me:$LINENO: \"$ac_compiler --version &5\"") >&5 + (eval $ac_compiler --version &5) 2>&5 ac_status=$? - if test -s conftest.err; then - sed '10a\ -... rest of stderr output deleted ... - 10q' conftest.err >conftest.er1 - cat conftest.er1 >&5 - fi - rm -f conftest.er1 conftest.err - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } -done - -cat confdefs.h - <<_ACEOF >conftest.$ac_ext + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } +{ (eval echo "$as_me:$LINENO: \"$ac_compiler -v &5\"") >&5 + (eval $ac_compiler -v &5) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } +{ (eval echo "$as_me:$LINENO: \"$ac_compiler -V &5\"") >&5 + (eval $ac_compiler -V &5) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } + +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { @@ -2491,203 +1704,155 @@ ; return 0; } _ACEOF ac_clean_files_save=$ac_clean_files -ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out" +ac_clean_files="$ac_clean_files a.out a.exe b.out" # Try to create an executable without -o first, disregard a.out. # It will help us diagnose broken compilers, and finding out an intuition # of exeext. -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the C compiler works" >&5 -$as_echo_n "checking whether the C compiler works... " >&6; } -ac_link_default=`$as_echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'` - -# The possible output files: -ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*" - -ac_rmfiles= -for ac_file in $ac_files -do - case $ac_file in - *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; - * ) ac_rmfiles="$ac_rmfiles $ac_file";; - esac -done -rm -f $ac_rmfiles - -if { { ac_try="$ac_link_default" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_link_default") 2>&5 - ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; }; then : - # Autoconf-2.13 could set the ac_cv_exeext variable to `no'. -# So ignore a value of `no', otherwise this would lead to `EXEEXT = no' -# in a Makefile. We should not override ac_cv_exeext if it was cached, -# so that the user can short-circuit this test for compilers unknown to -# Autoconf. -for ac_file in $ac_files '' +echo "$as_me:$LINENO: checking for C compiler default output file name" >&5 +echo $ECHO_N "checking for C compiler default output file name... $ECHO_C" >&6 +ac_link_default=`echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'` +if { (eval echo "$as_me:$LINENO: \"$ac_link_default\"") >&5 + (eval $ac_link_default) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; then + # Find the output, starting from the most likely. This scheme is +# not robust to junk in `.', hence go to wildcards (a.*) only as a last +# resort. + +# Be careful to initialize this variable, since it used to be cached. +# Otherwise an old cache value of `no' led to `EXEEXT = no' in a Makefile. +ac_cv_exeext= +# b.out is created by i960 compilers. +for ac_file in a_out.exe a.exe conftest.exe a.out conftest a.* conftest.* b.out do test -f "$ac_file" || continue case $ac_file in - *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj ) + ;; + conftest.$ac_ext ) + # This is the source file. ;; [ab].out ) # We found the default executable, but exeext='' is most # certainly right. break;; *.* ) - if test "${ac_cv_exeext+set}" = set && test "$ac_cv_exeext" != no; - then :; else - ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` - fi - # We set ac_cv_exeext here because the later test for it is not - # safe: cross compilers may not add the suffix if given an `-o' - # argument, so we may need to know it at that point already. - # Even if this section looks crufty: it has the advantage of - # actually working. + ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` + # FIXME: I believe we export ac_cv_exeext for Libtool, + # but it would be cool to find out if it's true. Does anybody + # maintain Libtool? --akim. + export ac_cv_exeext break;; * ) break;; esac done -test "$ac_cv_exeext" = no && ac_cv_exeext= - else - ac_file='' -fi -if test -z "$ac_file"; then : - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -$as_echo "$as_me: failed program was:" >&5 + echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error 77 "C compiler cannot create executables -See \`config.log' for more details" "$LINENO" 5; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -$as_echo "yes" >&6; } +{ { echo "$as_me:$LINENO: error: C compiler cannot create executables +See \`config.log' for more details." >&5 +echo "$as_me: error: C compiler cannot create executables +See \`config.log' for more details." >&2;} + { (exit 77); exit 77; }; } fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler default output file name" >&5 -$as_echo_n "checking for C compiler default output file name... " >&6; } -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5 -$as_echo "$ac_file" >&6; } + ac_exeext=$ac_cv_exeext +echo "$as_me:$LINENO: result: $ac_file" >&5 +echo "${ECHO_T}$ac_file" >&6 -rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out +# Check the compiler produces executables we can run. If not, either +# the compiler is broken, or we cross compile. +echo "$as_me:$LINENO: checking whether the C compiler works" >&5 +echo $ECHO_N "checking whether the C compiler works... $ECHO_C" >&6 +# FIXME: These cross compiler hacks should be removed for Autoconf 3.0 +# If not cross compiling, check that we can run a simple program. +if test "$cross_compiling" != yes; then + if { ac_try='./$ac_file' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + cross_compiling=no + else + if test "$cross_compiling" = maybe; then + cross_compiling=yes + else + { { echo "$as_me:$LINENO: error: cannot run C compiled programs. +If you meant to cross compile, use \`--host'. +See \`config.log' for more details." >&5 +echo "$as_me: error: cannot run C compiled programs. +If you meant to cross compile, use \`--host'. +See \`config.log' for more details." >&2;} + { (exit 1); exit 1; }; } + fi + fi +fi +echo "$as_me:$LINENO: result: yes" >&5 +echo "${ECHO_T}yes" >&6 + +rm -f a.out a.exe conftest$ac_cv_exeext b.out ac_clean_files=$ac_clean_files_save -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5 -$as_echo_n "checking for suffix of executables... " >&6; } -if { { ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_link") 2>&5 +# Check the compiler produces executables we can run. If not, either +# the compiler is broken, or we cross compile. +echo "$as_me:$LINENO: checking whether we are cross compiling" >&5 +echo $ECHO_N "checking whether we are cross compiling... $ECHO_C" >&6 +echo "$as_me:$LINENO: result: $cross_compiling" >&5 +echo "${ECHO_T}$cross_compiling" >&6 + +echo "$as_me:$LINENO: checking for suffix of executables" >&5 +echo $ECHO_N "checking for suffix of executables... $ECHO_C" >&6 +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>&5 ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; }; then : + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; then # If both `conftest.exe' and `conftest' are `present' (well, observable) # catch `conftest.exe'. For instance with Cygwin, `ls conftest' will # work properly (i.e., refer to `conftest.exe'), while it won't with # `rm'. for ac_file in conftest.exe conftest conftest.*; do test -f "$ac_file" || continue case $ac_file in - *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj ) ;; *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` + export ac_cv_exeext break;; * ) break;; esac done else - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "cannot compute suffix of executables: cannot compile and link -See \`config.log' for more details" "$LINENO" 5; } + { { echo "$as_me:$LINENO: error: cannot compute suffix of executables: cannot compile and link +See \`config.log' for more details." >&5 +echo "$as_me: error: cannot compute suffix of executables: cannot compile and link +See \`config.log' for more details." >&2;} + { (exit 1); exit 1; }; } fi -rm -f conftest conftest$ac_cv_exeext -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5 -$as_echo "$ac_cv_exeext" >&6; } + +rm -f conftest$ac_cv_exeext +echo "$as_me:$LINENO: result: $ac_cv_exeext" >&5 +echo "${ECHO_T}$ac_cv_exeext" >&6 rm -f conftest.$ac_ext EXEEXT=$ac_cv_exeext ac_exeext=$EXEEXT -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include -int -main () -{ -FILE *f = fopen ("conftest.out", "w"); - return ferror (f) || fclose (f) != 0; - - ; - return 0; -} +echo "$as_me:$LINENO: checking for suffix of object files" >&5 +echo $ECHO_N "checking for suffix of object files... $ECHO_C" >&6 +if test "${ac_cv_objext+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ _ACEOF -ac_clean_files="$ac_clean_files conftest.out" -# Check that the compiler produces executables we can run. If not, either -# the compiler is broken, or we cross compile. -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5 -$as_echo_n "checking whether we are cross compiling... " >&6; } -if test "$cross_compiling" != yes; then - { { ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_link") 2>&5 - ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } - if { ac_try='./conftest$ac_cv_exeext' - { { case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_try") 2>&5 - ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; }; }; then - cross_compiling=no - else - if test "$cross_compiling" = maybe; then - cross_compiling=yes - else - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "cannot run C compiled programs. -If you meant to cross compile, use \`--host'. -See \`config.log' for more details" "$LINENO" 5; } - fi - fi -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5 -$as_echo "$cross_compiling" >&6; } - -rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out -ac_clean_files=$ac_clean_files_save -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5 -$as_echo_n "checking for suffix of object files... " >&6; } -if ${ac_cv_objext+:} false; then : - $as_echo_n "(cached) " >&6 -else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { @@ -2695,50 +1860,49 @@ ; return 0; } _ACEOF rm -f conftest.o conftest.obj -if { { ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_compile") 2>&5 +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>&5 ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; }; then : - for ac_file in conftest.o conftest.obj conftest.*; do - test -f "$ac_file" || continue; + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; then + for ac_file in `(ls conftest.o conftest.obj; ls conftest.*) 2>/dev/null`; do case $ac_file in - *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;; + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg ) ;; *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` break;; esac done else - $as_echo "$as_me: failed program was:" >&5 + echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "cannot compute suffix of object files: cannot compile -See \`config.log' for more details" "$LINENO" 5; } +{ { echo "$as_me:$LINENO: error: cannot compute suffix of object files: cannot compile +See \`config.log' for more details." >&5 +echo "$as_me: error: cannot compute suffix of object files: cannot compile +See \`config.log' for more details." >&2;} + { (exit 1); exit 1; }; } fi + rm -f conftest.$ac_cv_objext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5 -$as_echo "$ac_cv_objext" >&6; } +echo "$as_me:$LINENO: result: $ac_cv_objext" >&5 +echo "${ECHO_T}$ac_cv_objext" >&6 OBJEXT=$ac_cv_objext ac_objext=$OBJEXT -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU C compiler" >&5 -$as_echo_n "checking whether we are using the GNU C compiler... " >&6; } -if ${ac_cv_c_compiler_gnu+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking whether we are using the GNU C compiler" >&5 +echo $ECHO_N "checking whether we are using the GNU C compiler... $ECHO_C" >&6 +if test "${ac_cv_c_compiler_gnu+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { @@ -2748,91 +1912,102 @@ ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then ac_compiler_gnu=yes else - ac_compiler_gnu=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_compiler_gnu=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext ac_cv_c_compiler_gnu=$ac_compiler_gnu fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5 -$as_echo "$ac_cv_c_compiler_gnu" >&6; } -if test $ac_compiler_gnu = yes; then - GCC=yes -else - GCC= -fi -ac_test_CFLAGS=${CFLAGS+set} -ac_save_CFLAGS=$CFLAGS -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5 -$as_echo_n "checking whether $CC accepts -g... " >&6; } -if ${ac_cv_prog_cc_g+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_save_c_werror_flag=$ac_c_werror_flag - ac_c_werror_flag=yes - ac_cv_prog_cc_g=no - CFLAGS="-g" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - ac_cv_prog_cc_g=yes -else - CFLAGS="" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - -else - ac_c_werror_flag=$ac_save_c_werror_flag - CFLAGS="-g" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - ac_cv_prog_cc_g=yes -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - ac_c_werror_flag=$ac_save_c_werror_flag -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5 -$as_echo "$ac_cv_prog_cc_g" >&6; } +echo "$as_me:$LINENO: result: $ac_cv_c_compiler_gnu" >&5 +echo "${ECHO_T}$ac_cv_c_compiler_gnu" >&6 +GCC=`test $ac_compiler_gnu = yes && echo yes` +ac_test_CFLAGS=${CFLAGS+set} +ac_save_CFLAGS=$CFLAGS +CFLAGS="-g" +echo "$as_me:$LINENO: checking whether $CC accepts -g" >&5 +echo $ECHO_N "checking whether $CC accepts -g... $ECHO_C" >&6 +if test "${ac_cv_prog_cc_g+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_prog_cc_g=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_prog_cc_g=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_prog_cc_g" >&5 +echo "${ECHO_T}$ac_cv_prog_cc_g" >&6 if test "$ac_test_CFLAGS" = set; then CFLAGS=$ac_save_CFLAGS elif test $ac_cv_prog_cc_g = yes; then if test "$GCC" = yes; then CFLAGS="-g -O2" @@ -2844,22 +2019,27 @@ CFLAGS="-O2" else CFLAGS= fi fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $CC option to accept ISO C89" >&5 -$as_echo_n "checking for $CC option to accept ISO C89... " >&6; } -if ${ac_cv_prog_cc_c89+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for $CC option to accept ANSI C" >&5 +echo $ECHO_N "checking for $CC option to accept ANSI C... $ECHO_C" >&6 +if test "${ac_cv_prog_cc_stdc+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - ac_cv_prog_cc_c89=no + ac_cv_prog_cc_stdc=no ac_save_CC=$CC -cat confdefs.h - <<_ACEOF >conftest.$ac_ext +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include -struct stat; +#include +#include /* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */ struct buf { int x; }; FILE * (*rcsopen) (struct buf *, struct stat *, int); static char *e (p, i) char **p; @@ -2878,21 +2058,16 @@ } /* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has function prototypes and stuff, but not '\xHH' hex character constants. These don't provoke an error unfortunately, instead are silently treated - as 'x'. The following induces an error, until -std is added to get + as 'x'. The following induces an error, until -std1 is added to get proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an array size at least. It's necessary to write '\x00'==0 to get something - that's true only with -std. */ + that's true only with -std1. */ int osf4_cc_array ['\x00' == 0 ? 1 : -1]; -/* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters - inside strings and character constants. */ -#define FOO(x) 'x' -int xlc6_cc_array[FOO(a) == 'x' ? 1 : -1]; - int test (int i, double x); struct s1 {int (*f) (int a);}; struct s2 {int (*f) (double a);}; int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int); int argc; @@ -2903,74 +2078,271 @@ return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]; ; return 0; } _ACEOF -for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std \ - -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" +# Don't try gcc -ansi; that turns off useful extensions and +# breaks some systems' header files. +# AIX -qlanglvl=ansi +# Ultrix and OSF/1 -std1 +# HP-UX 10.20 and later -Ae +# HP-UX older versions -Aa -D_HPUX_SOURCE +# SVR4 -Xc -D__EXTENSIONS__ +for ac_arg in "" -qlanglvl=ansi -std1 -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" do CC="$ac_save_CC $ac_arg" - if ac_fn_c_try_compile "$LINENO"; then : - ac_cv_prog_cc_c89=$ac_arg + rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_prog_cc_stdc=$ac_arg +break +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + fi -rm -f core conftest.err conftest.$ac_objext - test "x$ac_cv_prog_cc_c89" != "xno" && break +rm -f conftest.err conftest.$ac_objext done -rm -f conftest.$ac_ext +rm -f conftest.$ac_ext conftest.$ac_objext CC=$ac_save_CC fi -# AC_CACHE_VAL -case "x$ac_cv_prog_cc_c89" in - x) - { $as_echo "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 -$as_echo "none needed" >&6; } ;; - xno) - { $as_echo "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 -$as_echo "unsupported" >&6; } ;; + +case "x$ac_cv_prog_cc_stdc" in + x|xno) + echo "$as_me:$LINENO: result: none needed" >&5 +echo "${ECHO_T}none needed" >&6 ;; *) - CC="$CC $ac_cv_prog_cc_c89" - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 -$as_echo "$ac_cv_prog_cc_c89" >&6; } ;; + echo "$as_me:$LINENO: result: $ac_cv_prog_cc_stdc" >&5 +echo "${ECHO_T}$ac_cv_prog_cc_stdc" >&6 + CC="$CC $ac_cv_prog_cc_stdc" ;; esac -if test "x$ac_cv_prog_cc_c89" != xno; then : + +# Some people use a C++ compiler to compile C. Since we use `exit', +# in C++ we need to declare it. In case someone uses the same compiler +# for both compiling C and C++ we need to have the C++ compiler decide +# the declaration of exit, since it's the most demanding environment. +cat >conftest.$ac_ext <<_ACEOF +#ifndef __cplusplus + choke me +#endif +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + for ac_declaration in \ + '' \ + 'extern "C" void std::exit (int) throw (); using std::exit;' \ + 'extern "C" void std::exit (int); using std::exit;' \ + 'extern "C" void exit (int) throw ();' \ + 'extern "C" void exit (int);' \ + 'void exit (int);' +do + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_declaration +#include +int +main () +{ +exit (42); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + : +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +continue +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_declaration +int +main () +{ +exit (42); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + break +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +done +rm -f conftest* +if test -n "$ac_declaration"; then + echo '#ifdef __cplusplus' >>confdefs.h + echo $ac_declaration >>confdefs.h + echo '#endif' >>confdefs.h +fi +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for inline" >&5 -$as_echo_n "checking for inline... " >&6; } -if ${ac_cv_c_inline+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for inline" >&5 +echo $ECHO_N "checking for inline... $ECHO_C" >&6 +if test "${ac_cv_c_inline+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_cv_c_inline=no for ac_kw in inline __inline__ __inline; do - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #ifndef __cplusplus typedef int foo_t; static $ac_kw foo_t static_foo () {return 0; } $ac_kw foo_t foo () {return 0; } #endif _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - ac_cv_c_inline=$ac_kw +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_c_inline=$ac_kw; break +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - test "$ac_cv_c_inline" != no && break +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext done fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_inline" >&5 -$as_echo "$ac_cv_c_inline" >&6; } +echo "$as_me:$LINENO: result: $ac_cv_c_inline" >&5 +echo "${ECHO_T}$ac_cv_c_inline" >&6 + case $ac_cv_c_inline in inline | yes) ;; *) case $ac_cv_c_inline in @@ -2988,19 +2360,19 @@ ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking how to run the C preprocessor" >&5 -$as_echo_n "checking how to run the C preprocessor... " >&6; } +echo "$as_me:$LINENO: checking how to run the C preprocessor" >&5 +echo $ECHO_N "checking how to run the C preprocessor... $ECHO_C" >&6 # On Suns, sometimes $CPP names a directory. if test -n "$CPP" && test -d "$CPP"; then CPP= fi if test -z "$CPP"; then - if ${ac_cv_prog_CPP+:} false; then : - $as_echo_n "(cached) " >&6 + if test "${ac_cv_prog_CPP+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else # Double quotes because CPP needs to be expanded for CPP in "$CC -E" "$CC -E -traditional-cpp" "/lib/cpp" do ac_preproc_ok=false @@ -3010,47 +2382,95 @@ # with a fresh cross-compiler works. # Prefer to if __STDC__ is defined, since # exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #ifdef __STDC__ # include #else # include #endif Syntax error _ACEOF -if ac_fn_c_try_cpp "$LINENO"; then : +if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 + (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null; then + if test -s conftest.err; then + ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag + else + ac_cpp_err= + fi +else + ac_cpp_err=yes +fi +if test -z "$ac_cpp_err"; then + : +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 -else # Broken: fails on valid input. continue fi -rm -f conftest.err conftest.i conftest.$ac_ext +rm -f conftest.err conftest.$ac_ext - # OK, works on sane cases. Now check whether nonexistent headers + # OK, works on sane cases. Now check whether non-existent headers # can be detected and how. - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF -if ac_fn_c_try_cpp "$LINENO"; then : +if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 + (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null; then + if test -s conftest.err; then + ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag + else + ac_cpp_err= + fi +else + ac_cpp_err=yes +fi +if test -z "$ac_cpp_err"; then # Broken: success on invalid input. continue else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + # Passes both tests. ac_preproc_ok=: break fi -rm -f conftest.err conftest.i conftest.$ac_ext +rm -f conftest.err conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. -rm -f conftest.i conftest.err conftest.$ac_ext -if $ac_preproc_ok; then : +rm -f conftest.err conftest.$ac_ext +if $ac_preproc_ok; then break fi done ac_cv_prog_CPP=$CPP @@ -3058,209 +2478,147 @@ fi CPP=$ac_cv_prog_CPP else ac_cv_prog_CPP=$CPP fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $CPP" >&5 -$as_echo "$CPP" >&6; } +echo "$as_me:$LINENO: result: $CPP" >&5 +echo "${ECHO_T}$CPP" >&6 ac_preproc_ok=false for ac_c_preproc_warn_flag in '' yes do # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # Prefer to if __STDC__ is defined, since # exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #ifdef __STDC__ # include #else # include #endif Syntax error _ACEOF -if ac_fn_c_try_cpp "$LINENO"; then : +if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 + (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null; then + if test -s conftest.err; then + ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag + else + ac_cpp_err= + fi +else + ac_cpp_err=yes +fi +if test -z "$ac_cpp_err"; then + : +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 -else # Broken: fails on valid input. continue fi -rm -f conftest.err conftest.i conftest.$ac_ext +rm -f conftest.err conftest.$ac_ext - # OK, works on sane cases. Now check whether nonexistent headers + # OK, works on sane cases. Now check whether non-existent headers # can be detected and how. - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF -if ac_fn_c_try_cpp "$LINENO"; then : +if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 + (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null; then + if test -s conftest.err; then + ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag + else + ac_cpp_err= + fi +else + ac_cpp_err=yes +fi +if test -z "$ac_cpp_err"; then # Broken: success on invalid input. continue else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + # Passes both tests. ac_preproc_ok=: break fi -rm -f conftest.err conftest.i conftest.$ac_ext +rm -f conftest.err conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. -rm -f conftest.i conftest.err conftest.$ac_ext -if $ac_preproc_ok; then : - +rm -f conftest.err conftest.$ac_ext +if $ac_preproc_ok; then + : else - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "C preprocessor \"$CPP\" fails sanity check -See \`config.log' for more details" "$LINENO" 5; } + { { echo "$as_me:$LINENO: error: C preprocessor \"$CPP\" fails sanity check +See \`config.log' for more details." >&5 +echo "$as_me: error: C preprocessor \"$CPP\" fails sanity check +See \`config.log' for more details." >&2;} + { (exit 1); exit 1; }; } fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for grep that handles long lines and -e" >&5 -$as_echo_n "checking for grep that handles long lines and -e... " >&6; } -if ${ac_cv_path_GREP+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -z "$GREP"; then - ac_path_GREP_found=false - # Loop through the user's path and test for each of PROGNAME-LIST - as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_prog in grep ggrep; do - for ac_exec_ext in '' $ac_executable_extensions; do - ac_path_GREP="$as_dir/$ac_prog$ac_exec_ext" - as_fn_executable_p "$ac_path_GREP" || continue -# Check for GNU ac_path_GREP and select it if it is found. - # Check for GNU $ac_path_GREP -case `"$ac_path_GREP" --version 2>&1` in -*GNU*) - ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_found=:;; -*) - ac_count=0 - $as_echo_n 0123456789 >"conftest.in" - while : - do - cat "conftest.in" "conftest.in" >"conftest.tmp" - mv "conftest.tmp" "conftest.in" - cp "conftest.in" "conftest.nl" - $as_echo 'GREP' >> "conftest.nl" - "$ac_path_GREP" -e 'GREP$' -e '-(cannot match)-' < "conftest.nl" >"conftest.out" 2>/dev/null || break - diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break - as_fn_arith $ac_count + 1 && ac_count=$as_val - if test $ac_count -gt ${ac_path_GREP_max-0}; then - # Best one so far, save it but keep looking for a better one - ac_cv_path_GREP="$ac_path_GREP" - ac_path_GREP_max=$ac_count - fi - # 10*(2^10) chars as input seems more than enough - test $ac_count -gt 10 && break - done - rm -f conftest.in conftest.tmp conftest.nl conftest.out;; -esac - - $ac_path_GREP_found && break 3 - done - done - done -IFS=$as_save_IFS - if test -z "$ac_cv_path_GREP"; then - as_fn_error $? "no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 - fi -else - ac_cv_path_GREP=$GREP -fi - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_GREP" >&5 -$as_echo "$ac_cv_path_GREP" >&6; } - GREP="$ac_cv_path_GREP" - - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for egrep" >&5 -$as_echo_n "checking for egrep... " >&6; } -if ${ac_cv_path_EGREP+:} false; then : - $as_echo_n "(cached) " >&6 -else - if echo a | $GREP -E '(a|b)' >/dev/null 2>&1 - then ac_cv_path_EGREP="$GREP -E" - else - if test -z "$EGREP"; then - ac_path_EGREP_found=false - # Loop through the user's path and test for each of PROGNAME-LIST - as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_prog in egrep; do - for ac_exec_ext in '' $ac_executable_extensions; do - ac_path_EGREP="$as_dir/$ac_prog$ac_exec_ext" - as_fn_executable_p "$ac_path_EGREP" || continue -# Check for GNU ac_path_EGREP and select it if it is found. - # Check for GNU $ac_path_EGREP -case `"$ac_path_EGREP" --version 2>&1` in -*GNU*) - ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_found=:;; -*) - ac_count=0 - $as_echo_n 0123456789 >"conftest.in" - while : - do - cat "conftest.in" "conftest.in" >"conftest.tmp" - mv "conftest.tmp" "conftest.in" - cp "conftest.in" "conftest.nl" - $as_echo 'EGREP' >> "conftest.nl" - "$ac_path_EGREP" 'EGREP$' < "conftest.nl" >"conftest.out" 2>/dev/null || break - diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break - as_fn_arith $ac_count + 1 && ac_count=$as_val - if test $ac_count -gt ${ac_path_EGREP_max-0}; then - # Best one so far, save it but keep looking for a better one - ac_cv_path_EGREP="$ac_path_EGREP" - ac_path_EGREP_max=$ac_count - fi - # 10*(2^10) chars as input seems more than enough - test $ac_count -gt 10 && break - done - rm -f conftest.in conftest.tmp conftest.nl conftest.out;; -esac - - $ac_path_EGREP_found && break 3 - done - done - done -IFS=$as_save_IFS - if test -z "$ac_cv_path_EGREP"; then - as_fn_error $? "no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 - fi -else - ac_cv_path_EGREP=$EGREP -fi - - fi -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_EGREP" >&5 -$as_echo "$ac_cv_path_EGREP" >&6; } - EGREP="$ac_cv_path_EGREP" - - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for ANSI C header files" >&5 -$as_echo_n "checking for ANSI C header files... " >&6; } -if ${ac_cv_header_stdc+:} false; then : - $as_echo_n "(cached) " >&6 -else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext +echo "$as_me:$LINENO: checking for egrep" >&5 +echo $ECHO_N "checking for egrep... $ECHO_C" >&6 +if test "${ac_cv_prog_egrep+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + if echo a | (grep -E '(a|b)') >/dev/null 2>&1 + then ac_cv_prog_egrep='grep -E' + else ac_cv_prog_egrep='egrep' + fi +fi +echo "$as_me:$LINENO: result: $ac_cv_prog_egrep" >&5 +echo "${ECHO_T}$ac_cv_prog_egrep" >&6 + EGREP=$ac_cv_prog_egrep + + +echo "$as_me:$LINENO: checking for ANSI C header files" >&5 +echo $ECHO_N "checking for ANSI C header files... $ECHO_C" >&6 +if test "${ac_cv_header_stdc+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include @@ -3271,60 +2629,95 @@ ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then ac_cv_header_stdc=yes else - ac_cv_header_stdc=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_header_stdc=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext if test $ac_cv_header_stdc = yes; then # SunOS 4.x string.h does not declare mem*, contrary to ANSI. - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - $EGREP "memchr" >/dev/null 2>&1; then : - + $EGREP "memchr" >/dev/null 2>&1; then + : else ac_cv_header_stdc=no fi rm -f conftest* fi if test $ac_cv_header_stdc = yes; then # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - $EGREP "free" >/dev/null 2>&1; then : - + $EGREP "free" >/dev/null 2>&1; then + : else ac_cv_header_stdc=no fi rm -f conftest* fi if test $ac_cv_header_stdc = yes; then # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. - if test "$cross_compiling" = yes; then : + if test "$cross_compiling" = yes; then : else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include -#include #if ((' ' & 0x0FF) == 0x020) # define ISLOWER(c) ('a' <= (c) && (c) <= 'z') # define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) #else # define ISLOWER(c) \ @@ -3340,321 +2733,297 @@ { int i; for (i = 0; i < 256; i++) if (XOR (islower (i), ISLOWER (i)) || toupper (i) != TOUPPER (i)) - return 2; - return 0; + exit(2); + exit (0); } _ACEOF -if ac_fn_c_try_run "$LINENO"; then : - -else - ac_cv_header_stdc=no -fi -rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ - conftest.$ac_objext conftest.beam conftest.$ac_ext -fi - +rm -f conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { ac_try='./conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + : +else + echo "$as_me: program exited with status $ac_status" >&5 +echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +( exit $ac_status ) +ac_cv_header_stdc=no +fi +rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_header_stdc" >&5 -$as_echo "$ac_cv_header_stdc" >&6; } +fi +echo "$as_me:$LINENO: result: $ac_cv_header_stdc" >&5 +echo "${ECHO_T}$ac_cv_header_stdc" >&6 if test $ac_cv_header_stdc = yes; then -$as_echo "#define STDC_HEADERS 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define STDC_HEADERS 1 +_ACEOF fi if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}ar", so it can be a program name with args. set dummy ${ac_tool_prefix}ar; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_AR+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_AR+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$AR"; then ac_cv_prog_AR="$AR" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_AR="${ac_tool_prefix}ar" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done - done -IFS=$as_save_IFS +done fi fi AR=$ac_cv_prog_AR if test -n "$AR"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $AR" >&5 -$as_echo "$AR" >&6; } + echo "$as_me:$LINENO: result: $AR" >&5 +echo "${ECHO_T}$AR" >&6 else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 fi - fi if test -z "$ac_cv_prog_AR"; then ac_ct_AR=$AR # Extract the first word of "ar", so it can be a program name with args. set dummy ar; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_ac_ct_AR+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_ac_ct_AR+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$ac_ct_AR"; then ac_cv_prog_ac_ct_AR="$ac_ct_AR" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_AR="ar" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done - done -IFS=$as_save_IFS +done fi fi ac_ct_AR=$ac_cv_prog_ac_ct_AR if test -n "$ac_ct_AR"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_AR" >&5 -$as_echo "$ac_ct_AR" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - if test "x$ac_ct_AR" = x; then - AR="" - else - case $cross_compiling:$ac_tool_warned in -yes:) -{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 -$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} -ac_tool_warned=yes ;; -esac - AR=$ac_ct_AR - fi + echo "$as_me:$LINENO: result: $ac_ct_AR" >&5 +echo "${ECHO_T}$ac_ct_AR" >&6 +else + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 +fi + + AR=$ac_ct_AR else AR="$ac_cv_prog_AR" fi if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}ranlib", so it can be a program name with args. set dummy ${ac_tool_prefix}ranlib; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_RANLIB+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_RANLIB+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$RANLIB"; then ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_RANLIB="${ac_tool_prefix}ranlib" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done - done -IFS=$as_save_IFS +done fi fi RANLIB=$ac_cv_prog_RANLIB if test -n "$RANLIB"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $RANLIB" >&5 -$as_echo "$RANLIB" >&6; } + echo "$as_me:$LINENO: result: $RANLIB" >&5 +echo "${ECHO_T}$RANLIB" >&6 else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 fi - fi if test -z "$ac_cv_prog_RANLIB"; then ac_ct_RANLIB=$RANLIB # Extract the first word of "ranlib", so it can be a program name with args. set dummy ranlib; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_ac_ct_RANLIB+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_ac_ct_RANLIB+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$ac_ct_RANLIB"; then ac_cv_prog_ac_ct_RANLIB="$ac_ct_RANLIB" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_RANLIB="ranlib" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done - done -IFS=$as_save_IFS +done fi fi ac_ct_RANLIB=$ac_cv_prog_ac_ct_RANLIB if test -n "$ac_ct_RANLIB"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_RANLIB" >&5 -$as_echo "$ac_ct_RANLIB" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - if test "x$ac_ct_RANLIB" = x; then - RANLIB="" - else - case $cross_compiling:$ac_tool_warned in -yes:) -{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 -$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} -ac_tool_warned=yes ;; -esac - RANLIB=$ac_ct_RANLIB - fi + echo "$as_me:$LINENO: result: $ac_ct_RANLIB" >&5 +echo "${ECHO_T}$ac_ct_RANLIB" >&6 +else + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 +fi + + RANLIB=$ac_ct_RANLIB else RANLIB="$ac_cv_prog_RANLIB" fi if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}windres", so it can be a program name with args. set dummy ${ac_tool_prefix}windres; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_RC+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_RC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$RC"; then ac_cv_prog_RC="$RC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_RC="${ac_tool_prefix}windres" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done - done -IFS=$as_save_IFS +done fi fi RC=$ac_cv_prog_RC if test -n "$RC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $RC" >&5 -$as_echo "$RC" >&6; } + echo "$as_me:$LINENO: result: $RC" >&5 +echo "${ECHO_T}$RC" >&6 else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 fi - fi if test -z "$ac_cv_prog_RC"; then ac_ct_RC=$RC # Extract the first word of "windres", so it can be a program name with args. set dummy windres; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_ac_ct_RC+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_ac_ct_RC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$ac_ct_RC"; then ac_cv_prog_ac_ct_RC="$ac_ct_RC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_RC="windres" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done - done -IFS=$as_save_IFS +done fi fi ac_ct_RC=$ac_cv_prog_ac_ct_RC if test -n "$ac_ct_RC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_RC" >&5 -$as_echo "$ac_ct_RC" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - if test "x$ac_ct_RC" = x; then - RC="" - else - case $cross_compiling:$ac_tool_warned in -yes:) -{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 -$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} -ac_tool_warned=yes ;; -esac - RC=$ac_ct_RC - fi + echo "$as_me:$LINENO: result: $ac_ct_RC" >&5 +echo "${ECHO_T}$ac_ct_RC" >&6 +else + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 +fi + + RC=$ac_ct_RC else RC="$ac_cv_prog_RC" fi #-------------------------------------------------------------------- # Checks to see if the make program sets the $MAKE variable. #-------------------------------------------------------------------- -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether ${MAKE-make} sets \$(MAKE)" >&5 -$as_echo_n "checking whether ${MAKE-make} sets \$(MAKE)... " >&6; } +echo "$as_me:$LINENO: checking whether ${MAKE-make} sets \$(MAKE)" >&5 +echo $ECHO_N "checking whether ${MAKE-make} sets \$(MAKE)... $ECHO_C" >&6 set x ${MAKE-make} -ac_make=`$as_echo "$2" | sed 's/+/p/g; s/[^a-zA-Z0-9_]/_/g'` -if eval \${ac_cv_prog_make_${ac_make}_set+:} false; then : - $as_echo_n "(cached) " >&6 +ac_make=`echo "" | sed 'y,:./+-,___p_,'` +if eval "test \"\${ac_cv_prog_make_${ac_make}_set+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.make <<\_ACEOF SHELL = /bin/sh all: @echo '@@@%%%=$(MAKE)=@@@%%%' @@ -3667,16 +3036,16 @@ eval ac_cv_prog_make_${ac_make}_set=no;; esac rm -f conftest.make fi if eval test \$ac_cv_prog_make_${ac_make}_set = yes; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -$as_echo "yes" >&6; } + echo "$as_me:$LINENO: result: yes" >&5 +echo "${ECHO_T}yes" >&6 SET_MAKE= else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 SET_MAKE="MAKE=${MAKE-make}" fi #-------------------------------------------------------------------- @@ -3683,31 +3052,70 @@ # Determines the correct binary file extension (.o, .obj, .exe etc.) #-------------------------------------------------------------------- + +#-------------------------------------------------------------------- +# Check whether --enable-threads or --disable-threads was given. +#-------------------------------------------------------------------- + + + echo "$as_me:$LINENO: checking for building with threads" >&5 +echo $ECHO_N "checking for building with threads... $ECHO_C" >&6 + # Check whether --enable-threads or --disable-threads was given. +if test "${enable_threads+set}" = set; then + enableval="$enable_threads" + tcl_ok=$enableval +else + tcl_ok=yes +fi; + + if test "$tcl_ok" = "yes"; then + echo "$as_me:$LINENO: result: yes (default)" >&5 +echo "${ECHO_T}yes (default)" >&6 + TCL_THREADS=1 + cat >>confdefs.h <<\_ACEOF +#define TCL_THREADS 1 +_ACEOF + + # USE_THREAD_ALLOC tells us to try the special thread-based + # allocator that significantly reduces lock contention + cat >>confdefs.h <<\_ACEOF +#define USE_THREAD_ALLOC 1 +_ACEOF + + else + TCL_THREADS=0 + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 + fi + + #------------------------------------------------------------------------ # Embedded configuration information, encoding to use for the values, TIP #59 #------------------------------------------------------------------------ -# Check whether --with-encoding was given. -if test "${with_encoding+set}" = set; then : - withval=$with_encoding; with_tcencoding=${withval} -fi - +# Check whether --with-encoding or --without-encoding was given. +if test "${with_encoding+set}" = set; then + withval="$with_encoding" + with_tcencoding=${withval} +fi; if test x"${with_tcencoding}" != x ; then cat >>confdefs.h <<_ACEOF #define TCL_CFGVAL_ENCODING "${with_tcencoding}" _ACEOF else # Default encoding on windows is not "iso8859-1" - $as_echo "#define TCL_CFGVAL_ENCODING \"cp1252\"" >>confdefs.h + cat >>confdefs.h <<\_ACEOF +#define TCL_CFGVAL_ENCODING "cp1252" +_ACEOF fi #-------------------------------------------------------------------- @@ -3714,161 +3122,154 @@ # The statements below define a collection of symbols related to # building libtcl as a shared library instead of a static library. #-------------------------------------------------------------------- - { $as_echo "$as_me:${as_lineno-$LINENO}: checking how to build libraries" >&5 -$as_echo_n "checking how to build libraries... " >&6; } - # Check whether --enable-shared was given. -if test "${enable_shared+set}" = set; then : - enableval=$enable_shared; tcl_ok=$enableval + echo "$as_me:$LINENO: checking how to build libraries" >&5 +echo $ECHO_N "checking how to build libraries... $ECHO_C" >&6 + # Check whether --enable-shared or --disable-shared was given. +if test "${enable_shared+set}" = set; then + enableval="$enable_shared" + tcl_ok=$enableval else tcl_ok=yes -fi - +fi; if test "${enable_shared+set}" = set; then enableval="$enable_shared" tcl_ok=$enableval else tcl_ok=yes fi if test "$tcl_ok" = "yes" ; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: shared" >&5 -$as_echo "shared" >&6; } + echo "$as_me:$LINENO: result: shared" >&5 +echo "${ECHO_T}shared" >&6 SHARED_BUILD=1 else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: static" >&5 -$as_echo "static" >&6; } + echo "$as_me:$LINENO: result: static" >&5 +echo "${ECHO_T}static" >&6 SHARED_BUILD=0 -$as_echo "#define STATIC_BUILD 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define STATIC_BUILD 1 +_ACEOF fi +#-------------------------------------------------------------------- +# Check whether --enable-time64bit was given. +#-------------------------------------------------------------------- + +echo "$as_me:$LINENO: checking force of 64-bit time_t" >&5 +echo $ECHO_N "checking force of 64-bit time_t... $ECHO_C" >&6 +# Check whether --enable-time64bit or --disable-time64bit was given. +if test "${enable_time64bit+set}" = set; then + enableval="$enable_time64bit" + tcl_ok=$enableval +else + tcl_ok=no +fi; +echo "$as_me:$LINENO: result: \"$tcl_ok\"" >&5 +echo "${ECHO_T}\"$tcl_ok\"" >&6 +if test "$tcl_ok" = "yes"; then + CFLAGS="${CFLAGS} -D_USE_64BIT_TIME_T" +fi #-------------------------------------------------------------------- # The statements below define a collection of compile flags. This # macro depends on the value of SHARED_BUILD, and should be called # after SC_ENABLE_SHARED checks the configure switches. #-------------------------------------------------------------------- - -# On IRIX 5.3, sys/types and inttypes.h are conflicting. -for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \ - inttypes.h stdint.h unistd.h -do : - as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` -ac_fn_c_check_header_compile "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default -" -if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : - cat >>confdefs.h <<_ACEOF -#define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 -_ACEOF - -fi - -done - # Step 0: Enable 64 bit support? - { $as_echo "$as_me:${as_lineno-$LINENO}: checking if 64bit support is requested" >&5 -$as_echo_n "checking if 64bit support is requested... " >&6; } - # Check whether --enable-64bit was given. -if test "${enable_64bit+set}" = set; then : - enableval=$enable_64bit; do64bit=$enableval + echo "$as_me:$LINENO: checking if 64bit support is requested" >&5 +echo $ECHO_N "checking if 64bit support is requested... $ECHO_C" >&6 + # Check whether --enable-64bit or --disable-64bit was given. +if test "${enable_64bit+set}" = set; then + enableval="$enable_64bit" + do64bit=$enableval else do64bit=no -fi +fi; + echo "$as_me:$LINENO: result: $do64bit" >&5 +echo "${ECHO_T}$do64bit" >&6 - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $do64bit" >&5 -$as_echo "$do64bit" >&6; } + # Cross-compiling options for Windows/CE builds + + echo "$as_me:$LINENO: checking if Windows/CE build is requested" >&5 +echo $ECHO_N "checking if Windows/CE build is requested... $ECHO_C" >&6 + # Check whether --enable-wince or --disable-wince was given. +if test "${enable_wince+set}" = set; then + enableval="$enable_wince" + doWince=$enableval +else + doWince=no +fi; + echo "$as_me:$LINENO: result: $doWince" >&5 +echo "${ECHO_T}$doWince" >&6 + + echo "$as_me:$LINENO: checking for Windows/CE celib directory" >&5 +echo $ECHO_N "checking for Windows/CE celib directory... $ECHO_C" >&6 + +# Check whether --with-celib or --without-celib was given. +if test "${with_celib+set}" = set; then + withval="$with_celib" + CELIB_DIR=$withval +else + CELIB_DIR=NO_CELIB +fi; + echo "$as_me:$LINENO: result: $CELIB_DIR" >&5 +echo "${ECHO_T}$CELIB_DIR" >&6 # Set some defaults (may get changed below) EXTRA_CFLAGS="" -$as_echo "#define MODULE_SCOPE extern" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define MODULE_SCOPE extern +_ACEOF # Extract the first word of "cygpath", so it can be a program name with args. set dummy cygpath; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_CYGPATH+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_CYGPATH+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$CYGPATH"; then ac_cv_prog_CYGPATH="$CYGPATH" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CYGPATH="cygpath -m" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done - done -IFS=$as_save_IFS +done test -z "$ac_cv_prog_CYGPATH" && ac_cv_prog_CYGPATH="echo" fi fi CYGPATH=$ac_cv_prog_CYGPATH if test -n "$CYGPATH"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CYGPATH" >&5 -$as_echo "$CYGPATH" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - - # Extract the first word of "wine", so it can be a program name with args. -set dummy wine; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_WINE+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$WINE"; then - ac_cv_prog_WINE="$WINE" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_WINE="wine" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - -fi -fi -WINE=$ac_cv_prog_WINE -if test -n "$WINE"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $WINE" >&5 -$as_echo "$WINE" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - + echo "$as_me:$LINENO: result: $CYGPATH" >&5 +echo "${ECHO_T}$CYGPATH" >&6 +else + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 +fi SHLIB_SUFFIX=".dll" # MACHINE is IX86 for LINK, but this is used by the manifest, @@ -3875,16 +3276,20 @@ # which requires x86|amd64|ia64. MACHINE="X86" if test "$GCC" = "yes"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for cross-compile version of gcc" >&5 -$as_echo_n "checking for cross-compile version of gcc... " >&6; } -if ${ac_cv_cross+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking for cross-compile version of gcc" >&5 +echo $ECHO_N "checking for cross-compile version of gcc... $ECHO_C" >&6 +if test "${ac_cv_cross+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #ifndef _WIN32 #error cross-compiler #endif @@ -3895,32 +3300,56 @@ ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then ac_cv_cross=no else - ac_cv_cross=yes + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_cross=yes fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_cross" >&5 -$as_echo "$ac_cv_cross" >&6; } +echo "$as_me:$LINENO: result: $ac_cv_cross" >&5 +echo "${ECHO_T}$ac_cv_cross" >&6 if test "$ac_cv_cross" = "yes"; then case "$do64bit" in amd64|x64|yes) - CC="x86_64-w64-mingw32-gcc" + CC="x86_64-w64-mingw32-${CC}" LD="x86_64-w64-mingw32-ld" AR="x86_64-w64-mingw32-ar" RANLIB="x86_64-w64-mingw32-ranlib" RC="x86_64-w64-mingw32-windres" ;; *) - CC="i686-w64-mingw32-gcc" + CC="i686-w64-mingw32-${CC}" LD="i686-w64-mingw32-ld" AR="i686-w64-mingw32-ar" RANLIB="i686-w64-mingw32-ranlib" RC="i686-w64-mingw32-windres" ;; @@ -3939,24 +3368,24 @@ conftest=/tmp/conftest.rc echo "STRINGTABLE BEGIN" > $conftest echo "101 \"name\"" >> $conftest echo "END" >> $conftest - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for Windows native path bug in windres" >&5 -$as_echo_n "checking for Windows native path bug in windres... " >&6; } + echo "$as_me:$LINENO: checking for Windows native path bug in windres" >&5 +echo $ECHO_N "checking for Windows native path bug in windres... $ECHO_C" >&6 cyg_conftest=`$CYGPATH $conftest` if { ac_try='$RC -o conftest.res.o $cyg_conftest' - { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_try\""; } >&5 + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; }; } ; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } ; then + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -$as_echo "yes" >&6; } + echo "$as_me:$LINENO: result: yes" >&5 +echo "${ECHO_T}yes" >&6 CYGPATH=echo fi conftest= cyg_conftest= fi @@ -3970,16 +3399,20 @@ # set various compiler flags depending on whether we are using gcc or cl if test "${GCC}" = "yes" ; then extra_cflags="-pipe" extra_ldflags="-pipe -static-libgcc" - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for mingw32 version of gcc" >&5 -$as_echo_n "checking for mingw32 version of gcc... " >&6; } -if ${ac_cv_win32+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking for mingw32 version of gcc" >&5 +echo $ECHO_N "checking for mingw32 version of gcc... $ECHO_C" >&6 +if test "${ac_cv_win32+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #ifdef _WIN32 #error win32 #endif @@ -3990,77 +3423,61 @@ ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then ac_cv_win32=no else - ac_cv_win32=yes + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_win32=yes fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_win32" >&5 -$as_echo "$ac_cv_win32" >&6; } +echo "$as_me:$LINENO: result: $ac_cv_win32" >&5 +echo "${ECHO_T}$ac_cv_win32" >&6 if test "$ac_cv_win32" != "yes"; then - as_fn_error $? "${CC} cannot produce win32 executables." "$LINENO" 5 + { { echo "$as_me:$LINENO: error: ${CC} cannot produce win32 executables." >&5 +echo "$as_me: error: ${CC} cannot produce win32 executables." >&2;} + { (exit 1); exit 1; }; } fi hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -mwindows -municode -Dmain=xxmain" - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for working -municode linker flag" >&5 -$as_echo_n "checking for working -municode linker flag... " >&6; } -if ${ac_cv_municode+:} false; then : - $as_echo_n "(cached) " >&6 -else - -# ac_fn_c_try_link LINENO -# ----------------------- -# Try to link conftest.$ac_ext, and return whether this succeeded. -ac_fn_c_try_link () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - rm -f conftest.$ac_objext conftest$ac_exeext - if { { ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_link") 2>conftest.err - ac_status=$? - if test -s conftest.err; then - grep -v '^ *+' conftest.err >conftest.er1 - cat conftest.er1 >&5 - mv -f conftest.er1 conftest.err - fi - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - test -x conftest$ac_exeext - }; then : - ac_retval=0 -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_retval=1 -fi - # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information - # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would - # interfere with the next link command; also delete a directory that is - # left behind by Apple's compiler. We do this before executing the actions. - rm -rf conftest.dSYM conftest_ipa8_conftest.oo - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $ac_retval - -} # ac_fn_c_try_link -cat confdefs.h - <<_ACEOF >conftest.$ac_ext + echo "$as_me:$LINENO: checking for working -municode linker flag" >&5 +echo $ECHO_N "checking for working -municode linker flag... $ECHO_C" >&6 +if test "${ac_cv_municode+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int APIENTRY wWinMain(HINSTANCE a, HINSTANCE b, LPWSTR c, int d) {return 0;} @@ -4070,31 +3487,55 @@ ; return 0; } _ACEOF -if ac_fn_c_try_link "$LINENO"; then : +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then ac_cv_municode=yes else - ac_cv_municode=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_municode=no fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_municode" >&5 -$as_echo "$ac_cv_municode" >&6; } +echo "$as_me:$LINENO: result: $ac_cv_municode" >&5 +echo "${ECHO_T}$ac_cv_municode" >&6 CFLAGS=$hold_cflags if test "$ac_cv_municode" = "yes" ; then extra_ldflags="$extra_ldflags -municode" else extra_cflags="$extra_cflags -DTCL_BROKEN_MAINARGS" fi fi - { $as_echo "$as_me:${as_lineno-$LINENO}: checking compiler flags" >&5 -$as_echo_n "checking compiler flags... " >&6; } + echo "$as_me:$LINENO: checking compiler flags" >&5 +echo $ECHO_N "checking compiler flags... $ECHO_C" >&6 if test "${GCC}" = "yes" ; then SHLIB_LD="" SHLIB_LD_LIBS='${LIBS}' LIBS="-lnetapi32 -lkernel32 -luser32 -ladvapi32 -luserenv -lws2_32" # mingw needs to link ole32 and oleaut32 for [send], but MSVC doesn't @@ -4111,24 +3552,27 @@ MAKE_EXE="\${CC} -o \$@" LIBPREFIX="lib" if test "${SHARED_BUILD}" = "0" ; then # static - { $as_echo "$as_me:${as_lineno-$LINENO}: result: using static flags" >&5 -$as_echo "using static flags" >&6; } + echo "$as_me:$LINENO: result: using static flags" >&5 +echo "${ECHO_T}using static flags" >&6 runtime= LIBRARIES="\${STATIC_LIBRARIES}" EXESUFFIX="s\${DBGX}.exe" else # dynamic - { $as_echo "$as_me:${as_lineno-$LINENO}: result: using shared flags" >&5 -$as_echo "using shared flags" >&6; } + echo "$as_me:$LINENO: result: using shared flags" >&5 +echo "${ECHO_T}using shared flags" >&6 # ad-hoc check to see if CC supports -shared. if "${CC}" -shared 2>&1 | egrep ': -shared not supported' >/dev/null; then - as_fn_error $? "${CC} does not support the -shared option. - You will need to upgrade to a newer version of the toolchain." "$LINENO" 5 + { { echo "$as_me:$LINENO: error: ${CC} does not support the -shared option. + You will need to upgrade to a newer version of the toolchain." >&5 +echo "$as_me: error: ${CC} does not support the -shared option. + You will need to upgrade to a newer version of the toolchain." >&2;} + { (exit 1); exit 1; }; } fi runtime= # Add SHLIB_LD_LIBS to the Make rule, not here. @@ -4138,11 +3582,11 @@ # Link with gcc since ld does not link to default libs like # -luser32 and -lmsvcrt by default. SHLIB_LD='${CC} -shared' SHLIB_LD_LIBS='${LIBS}' MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -o \$@ ${extra_ldflags} \ - -Wl,--out-implib,\$(patsubst %.dll,lib%.a,\$@)" + -Wl,--out-implib,\$(patsubst %.dll,lib%.dll.a,\$@)" # DLLSUFFIX is separate because it is the building block for # users of tclConfig.sh that may build shared or static. DLLSUFFIX="\${DBGX}.dll" LIBSUFFIX="\${DBGX}.a" LIBFLAGSUFFIX="\${DBGX}" @@ -4150,13 +3594,22 @@ EXTRA_CFLAGS="${extra_cflags}" CFLAGS_DEBUG=-g CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer" - CFLAGS_WARNING="-Wall -Wwrite-strings -Wsign-compare -Wdeclaration-after-statement -Wpointer-arith" + CFLAGS_WARNING="-Wall -Wpointer-arith" LDFLAGS_DEBUG= LDFLAGS_OPTIMIZE= + + case "${CC}" in + *++) + CFLAGS_WARNING="${CFLAGS_WARNING} -Wno-format" + ;; + *) + CFLAGS_WARNING="${CFLAGS_WARNING} -Wdeclaration-after-statement" + ;; + esac # Specify the CC output file names based on the target name CC_OBJNAME="-o \$@" CC_EXENAME="-o \$@" @@ -4178,20 +3631,24 @@ LDFLAGS_WINDOW="-mwindows ${extra_ldflags}" case "$do64bit" in amd64|x64|yes) MACHINE="AMD64" ; # assume AMD64 as default 64-bit build - { $as_echo "$as_me:${as_lineno-$LINENO}: result: Using 64-bit $MACHINE mode" >&5 -$as_echo " Using 64-bit $MACHINE mode" >&6; } + echo "$as_me:$LINENO: result: Using 64-bit $MACHINE mode" >&5 +echo "${ECHO_T} Using 64-bit $MACHINE mode" >&6 ;; ia64) MACHINE="IA64" - { $as_echo "$as_me:${as_lineno-$LINENO}: result: Using 64-bit $MACHINE mode" >&5 -$as_echo " Using 64-bit $MACHINE mode" >&6; } + echo "$as_me:$LINENO: result: Using 64-bit $MACHINE mode" >&5 +echo "${ECHO_T} Using 64-bit $MACHINE mode" >&6 ;; *) - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #ifndef _WIN64 #error 32-bit #endif @@ -4202,37 +3659,61 @@ ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_win_64bit=yes else - tcl_win_64bit=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_win_64bit=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext if test "$tcl_win_64bit" = "yes" ; then do64bit=amd64 MACHINE="AMD64" - { $as_echo "$as_me:${as_lineno-$LINENO}: result: Using 64-bit $MACHINE mode" >&5 -$as_echo " Using 64-bit $MACHINE mode" >&6; } + echo "$as_me:$LINENO: result: Using 64-bit $MACHINE mode" >&5 +echo "${ECHO_T} Using 64-bit $MACHINE mode" >&6 fi ;; esac else if test "${SHARED_BUILD}" = "0" ; then # static - { $as_echo "$as_me:${as_lineno-$LINENO}: result: using static flags" >&5 -$as_echo "using static flags" >&6; } + echo "$as_me:$LINENO: result: using static flags" >&5 +echo "${ECHO_T}using static flags" >&6 runtime=-MT LIBRARIES="\${STATIC_LIBRARIES}" EXESUFFIX="s\${DBGX}.exe" else # dynamic - { $as_echo "$as_me:${as_lineno-$LINENO}: result: using shared flags" >&5 -$as_echo "using shared flags" >&6; } + echo "$as_me:$LINENO: result: using shared flags" >&5 +echo "${ECHO_T}using shared flags" >&6 runtime=-MD # Add SHLIB_LD_LIBS to the Make rule, not here. LIBRARIES="\${SHARED_LIBRARIES}" EXESUFFIX="\${DBGX}.exe" case "x`echo \${VisualStudioVersion}`" in @@ -4248,35 +3729,21 @@ # users of tclConfig.sh that may build shared or static. DLLSUFFIX="\${DBGX}.dll" LIBSUFFIX="\${DBGX}.lib" LIBFLAGSUFFIX="\${DBGX}" - # This is a 2-stage check to make sure we have the 64-bit SDK - # We have to know where the SDK is installed. - # This magic is based on MS Platform SDK for Win2003 SP1 - hobbs if test "$do64bit" != "no" ; then - if test "x${MSSDK}x" = "xx" ; then - MSSDK="C:/Progra~1/Microsoft Platform SDK" - fi - MSSDK=`echo "$MSSDK" | sed -e 's!\\\!/!g'` - PATH64="" case "$do64bit" in amd64|x64|yes) MACHINE="AMD64" ; # assume AMD64 as default 64-bit build - PATH64="${MSSDK}/Bin/Win64/x86/AMD64" ;; ia64) MACHINE="IA64" - PATH64="${MSSDK}/Bin/Win64" ;; esac - if test ! -d "${PATH64}" ; then - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Could not find 64-bit $MACHINE SDK" >&5 -$as_echo "$as_me: WARNING: Could not find 64-bit $MACHINE SDK" >&2;} - fi - { $as_echo "$as_me:${as_lineno-$LINENO}: result: Using 64-bit $MACHINE mode" >&5 -$as_echo " Using 64-bit $MACHINE mode" >&6; } + echo "$as_me:$LINENO: result: Using 64-bit $MACHINE mode" >&5 +echo "${ECHO_T} Using 64-bit $MACHINE mode" >&6 fi LIBS="netapi32.lib kernel32.lib user32.lib advapi32.lib userenv.lib ws2_32.lib" case "x`echo \${VisualStudioVersion}`" in @@ -4286,30 +3753,16 @@ *) ;; esac if test "$do64bit" != "no" ; then - # The space-based-path will work for the Makefile, but will - # not work if AC_TRY_COMPILE is called. TEA has the - # TEA_PATH_NOSPACE to avoid this issue. - # Check if _WIN64 is already recognized, and if so we don't - # need to modify CC. - ac_fn_c_check_decl "$LINENO" "_WIN64" "ac_cv_have_decl__WIN64" "$ac_includes_default" -if test "x$ac_cv_have_decl__WIN64" = xyes; then : - -else - CC="\"${PATH64}/cl.exe\" -I\"${MSSDK}/Include\" \ - -I\"${MSSDK}/Include/crt\" \ - -I\"${MSSDK}/Include/crt/sys\"" -fi - - RC="\"${MSSDK}/bin/rc.exe\"" + RC="rc" CFLAGS_DEBUG="-nologo -Zi -Od ${runtime}d" # Do not use -O2 for Win64 - this has proved buggy in code gen. CFLAGS_OPTIMIZE="-nologo -O1 ${runtime}" - lflags="${lflags} -nologo -MACHINE:${MACHINE} -LIBPATH:\"${MSSDK}/Lib/${MACHINE}\"" - LINKBIN="\"${PATH64}/link.exe\"" + lflags="${lflags} -nologo -MACHINE:${MACHINE}" + LINKBIN="link" # Avoid 'unresolved external symbol __security_cookie' errors. # c.f. http://support.microsoft.com/?id=894573 LIBS="$LIBS bufferoverflowU.lib" else RC="rc" @@ -4320,11 +3773,115 @@ CFLAGS_OPTIMIZE="-nologo -O2 ${runtime}" lflags="${lflags} -nologo" LINKBIN="link" fi - LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib shell32.lib uuid.lib" + if test "$doWince" != "no" ; then + # Set defaults for common evc4/PPC2003 setup + # Currently Tcl requires 300+, possibly 420+ for sockets + CEVERSION=420; # could be 211 300 301 400 420 ... + TARGETCPU=ARMV4; # could be ARMV4 ARM MIPS SH3 X86 ... + ARCH=ARM; # could be ARM MIPS X86EM ... + PLATFORM="Pocket PC 2003"; # or "Pocket PC 2002" + if test "$doWince" != "yes"; then + # If !yes then the user specified something + # Reset ARCH to allow user to skip specifying it + ARCH= + eval `echo $doWince | awk -F "," '{ \ + if (length($1)) { printf "CEVERSION=\"%s\"\n", $1; \ + if ($1 < 400) { printf "PLATFORM=\"Pocket PC 2002\"\n" } }; \ + if (length($2)) { printf "TARGETCPU=\"%s\"\n", toupper($2) }; \ + if (length($3)) { printf "ARCH=\"%s\"\n", toupper($3) }; \ + if (length($4)) { printf "PLATFORM=\"%s\"\n", $4 }; \ + }'` + if test "x${ARCH}" = "x" ; then + ARCH=$TARGETCPU; + fi + fi + OSVERSION=WCE$CEVERSION; + if test "x${WCEROOT}" = "x" ; then + WCEROOT="C:/Program Files/Microsoft eMbedded C++ 4.0" + if test ! -d "${WCEROOT}" ; then + WCEROOT="C:/Program Files/Microsoft eMbedded Tools" + fi + fi + if test "x${SDKROOT}" = "x" ; then + SDKROOT="C:/Program Files/Windows CE Tools" + if test ! -d "${SDKROOT}" ; then + SDKROOT="C:/Windows CE Tools" + fi + fi + # The space-based-path will work for the Makefile, but will + # not work if AC_TRY_COMPILE is called. + WCEROOT=`echo "$WCEROOT" | sed -e 's!\\\!/!g'` + SDKROOT=`echo "$SDKROOT" | sed -e 's!\\\!/!g'` + CELIB_DIR=`echo "$CELIB_DIR" | sed -e 's!\\\!/!g'` + if test ! -d "${CELIB_DIR}/inc"; then + { { echo "$as_me:$LINENO: error: Invalid celib directory \"${CELIB_DIR}\"" >&5 +echo "$as_me: error: Invalid celib directory \"${CELIB_DIR}\"" >&2;} + { (exit 1); exit 1; }; } + fi + if test ! -d "${SDKROOT}/${OSVERSION}/${PLATFORM}/Lib/${TARGETCPU}"\ + -o ! -d "${WCEROOT}/EVC/${OSVERSION}/bin"; then + { { echo "$as_me:$LINENO: error: could not find PocketPC SDK or target compiler to enable WinCE mode $CEVERSION,$TARGETCPU,$ARCH,$PLATFORM" >&5 +echo "$as_me: error: could not find PocketPC SDK or target compiler to enable WinCE mode $CEVERSION,$TARGETCPU,$ARCH,$PLATFORM" >&2;} + { (exit 1); exit 1; }; } + else + CEINCLUDE="${SDKROOT}/${OSVERSION}/${PLATFORM}/include" + if test -d "${CEINCLUDE}/${TARGETCPU}" ; then + CEINCLUDE="${CEINCLUDE}/${TARGETCPU}" + fi + CELIBPATH="${SDKROOT}/${OSVERSION}/${PLATFORM}/Lib/${TARGETCPU}" + fi + fi + + if test "$doWince" != "no" ; then + CEBINROOT="${WCEROOT}/EVC/${OSVERSION}/bin" + if test "${TARGETCPU}" = "X86"; then + CC="${CEBINROOT}/cl.exe" + else + CC="${CEBINROOT}/cl${ARCH}.exe" + fi + CC="\"${CC}\" -I\"${CELIB_DIR}/inc\" -I\"${CEINCLUDE}\"" + RC="\"${WCEROOT}/Common/EVC/bin/rc.exe\"" + arch=`echo ${ARCH} | awk '{print tolower($0)}'` + defs="${ARCH} _${ARCH}_ ${arch} PALM_SIZE _MT _DLL _WINDOWS" + for i in $defs ; do + cat >>confdefs.h <<_ACEOF +#define $i 1 +_ACEOF + + done +# if test "${ARCH}" = "X86EM"; then +# AC_DEFINE_UNQUOTED(_WIN32_WCE_EMULATION) +# fi + cat >>confdefs.h <<_ACEOF +#define _WIN32_WCE $CEVERSION +_ACEOF + + cat >>confdefs.h <<_ACEOF +#define UNDER_CE $CEVERSION +_ACEOF + + CFLAGS_DEBUG="-nologo -Zi -Od" + CFLAGS_OPTIMIZE="-nologo -O2" + lversion=`echo ${CEVERSION} | sed -e 's/\(.\)\(..\)/\1\.\2/'` + lflags="-nodefaultlib -MACHINE:${ARCH} -LIBPATH:\"${CELIBPATH}\" -subsystem:windowsce,${lversion} -nologo" + LINKBIN="\"${CEBINROOT}/link.exe\"" + + if test "${CEVERSION}" -lt 400 ; then + LIBS="coredll.lib corelibc.lib winsock.lib" + else + LIBS="coredll.lib corelibc.lib ws2.lib" + fi + # celib currently stuck at wce300 status + #LIBS="$LIBS \${CELIB_DIR}/wince-${ARCH}-pocket-${OSVERSION}-release/celib.lib" + LIBS="$LIBS \"\${CELIB_DIR}/wince-${ARCH}-pocket-wce300-release/celib.lib\"" + LIBS_GUI="commctrl.lib commdlg.lib" + else + LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib shell32.lib uuid.lib" + fi SHLIB_LD="${LINKBIN} -dll -incremental:no ${lflags}" SHLIB_LD_LIBS='${LIBS}' # link -lib only works when -lib is the first arg STLIB_LD="${LINKBIN} -lib ${lflags}" @@ -4351,34 +3908,40 @@ CC_OBJNAME="-Fo\$@" CC_EXENAME="-Fe\"\$(shell \$(CYGPATH) '\$@')\"" # Specify linker flags depending on the type of app being # built -- Console vs. Window. - if test "${TARGETCPU}" != "X86"; then + if test "$doWince" != "no" -a "${TARGETCPU}" != "X86"; then LDFLAGS_CONSOLE="-link ${lflags}" LDFLAGS_WINDOW=${LDFLAGS_CONSOLE} else LDFLAGS_CONSOLE="-link -subsystem:console ${lflags}" LDFLAGS_WINDOW="-link -subsystem:windows ${lflags}" fi fi if test "$do64bit" != "no" ; then - $as_echo "#define TCL_CFG_DO64BIT 1" >>confdefs.h + cat >>confdefs.h <<\_ACEOF +#define TCL_CFG_DO64BIT 1 +_ACEOF fi if test "${GCC}" = "yes" ; then - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for SEH support in compiler" >&5 -$as_echo_n "checking for SEH support in compiler... " >&6; } -if ${tcl_cv_seh+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking for SEH support in compiler" >&5 +echo $ECHO_N "checking for SEH support in compiler... $ECHO_C" >&6 +if test "${tcl_cv_seh+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - if test "$cross_compiling" = yes; then : + if test "$cross_compiling" = yes; then tcl_cv_seh=no else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #define WIN32_LEAN_AND_MEAN #include #undef WIN32_LEAN_AND_MEAN @@ -4393,41 +3956,60 @@ } return 1; } _ACEOF -if ac_fn_c_try_run "$LINENO"; then : +rm -f conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { ac_try='./conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_seh=yes else - tcl_cv_seh=no -fi -rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ - conftest.$ac_objext conftest.beam conftest.$ac_ext + echo "$as_me: program exited with status $ac_status" >&5 +echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +( exit $ac_status ) +tcl_cv_seh=no fi - +rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext +fi fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_seh" >&5 -$as_echo "$tcl_cv_seh" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_seh" >&5 +echo "${ECHO_T}$tcl_cv_seh" >&6 if test "$tcl_cv_seh" = "no" ; then -$as_echo "#define HAVE_NO_SEH 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_NO_SEH 1 +_ACEOF fi # # Check to see if the excpt.h include file provided contains the # definition for EXCEPTION_DISPOSITION; if not, which is the case # with Cygwin's version as of 2002-04-10, define it to be int, # sufficient for getting the current code to work. # - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for EXCEPTION_DISPOSITION support in include files" >&5 -$as_echo_n "checking for EXCEPTION_DISPOSITION support in include files... " >&6; } -if ${tcl_cv_eh_disposition+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking for EXCEPTION_DISPOSITION support in include files" >&5 +echo $ECHO_N "checking for EXCEPTION_DISPOSITION support in include files... $ECHO_C" >&6 +if test "${tcl_cv_eh_disposition+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ # define WIN32_LEAN_AND_MEAN # include # undef WIN32_LEAN_AND_MEAN @@ -4440,36 +4022,66 @@ ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_eh_disposition=yes else - tcl_cv_eh_disposition=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_eh_disposition=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_eh_disposition" >&5 -$as_echo "$tcl_cv_eh_disposition" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_eh_disposition" >&5 +echo "${ECHO_T}$tcl_cv_eh_disposition" >&6 if test "$tcl_cv_eh_disposition" = "no" ; then -$as_echo "#define EXCEPTION_DISPOSITION int" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define EXCEPTION_DISPOSITION int +_ACEOF fi # Check to see if winnt.h defines CHAR, SHORT, and LONG # even if VOID has already been #defined. The win32api # used by mingw and cygwin is known to do this. - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for winnt.h that ignores VOID define" >&5 -$as_echo_n "checking for winnt.h that ignores VOID define... " >&6; } -if ${tcl_cv_winnt_ignore_void+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking for winnt.h that ignores VOID define" >&5 +echo $ECHO_N "checking for winnt.h that ignores VOID define... $ECHO_C" >&6 +if test "${tcl_cv_winnt_ignore_void+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #define VOID void #define WIN32_LEAN_AND_MEAN #include @@ -4485,36 +4097,66 @@ ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_winnt_ignore_void=yes else - tcl_cv_winnt_ignore_void=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_winnt_ignore_void=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_winnt_ignore_void" >&5 -$as_echo "$tcl_cv_winnt_ignore_void" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_winnt_ignore_void" >&5 +echo "${ECHO_T}$tcl_cv_winnt_ignore_void" >&6 if test "$tcl_cv_winnt_ignore_void" = "yes" ; then -$as_echo "#define HAVE_WINNT_IGNORE_VOID 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_WINNT_IGNORE_VOID 1 +_ACEOF fi # See if the compiler supports casting to a union type. # This is used to stop gcc from printing a compiler # warning when initializing a union member. - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for cast to union support" >&5 -$as_echo_n "checking for cast to union support... " >&6; } -if ${tcl_cv_cast_to_union+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking for cast to union support" >&5 +echo $ECHO_N "checking for cast to union support... $ECHO_C" >&6 +if test "${tcl_cv_cast_to_union+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { @@ -4524,23 +4166,49 @@ ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_cast_to_union=yes else - tcl_cv_cast_to_union=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_cast_to_union=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cast_to_union" >&5 -$as_echo "$tcl_cv_cast_to_union" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_cast_to_union" >&5 +echo "${ECHO_T}$tcl_cv_cast_to_union" >&6 if test "$tcl_cv_cast_to_union" = "yes"; then -$as_echo "#define HAVE_CAST_TO_UNION 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_CAST_TO_UNION 1 +_ACEOF fi fi # DL_LIBS is empty, but then we match the Unix version @@ -4563,27 +4231,28 @@ #------------------------------------------------------------------------ # Add stuff for zlib; note that this is mostly done in the makefile now # as we just assume that the platform hasn't got a usable z.lib #------------------------------------------------------------------------ -if test "${enable_shared+set}" = "set"; then : +if test "${enable_shared+set}" = "set"; then enableval="$enable_shared" tcl_ok=$enableval else tcl_ok=yes fi -if test "$tcl_ok" = "yes"; then : + +if test "$tcl_ok" = "yes"; then ZLIB_DLL_FILE=\${ZLIB_DLL_FILE} - if test "$do64bit" != "no"; then : + if test "$do64bit" != "no"; then - if test "$GCC" == "yes"; then : + if test "$GCC" == "yes"; then ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64/libz.dll.a else @@ -4590,69 +4259,230 @@ ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64/zdll.lib fi + else ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win32/zdll.lib fi + else ZLIB_OBJS=\${ZLIB_OBJS} fi -$as_echo "#define HAVE_ZLIB 1" >>confdefs.h + +cat >>confdefs.h <<\_ACEOF +#define HAVE_ZLIB 1 +_ACEOF -ac_fn_c_check_type "$LINENO" "intptr_t" "ac_cv_type_intptr_t" "$ac_includes_default" -if test "x$ac_cv_type_intptr_t" = xyes; then : +# On IRIX 5.3, sys/types and inttypes.h are conflicting. -$as_echo "#define HAVE_INTPTR_T 1" >>confdefs.h + + + + + + + +for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \ + inttypes.h stdint.h unistd.h +do +as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` +echo "$as_me:$LINENO: checking for $ac_header" >&5 +echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default + +#include <$ac_header> +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + eval "$as_ac_Header=yes" +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +eval "$as_ac_Header=no" +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 +if test `eval echo '${'$as_ac_Header'}'` = yes; then + cat >>confdefs.h <<_ACEOF +#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1 +_ACEOF + +fi + +done + + +echo "$as_me:$LINENO: checking for intptr_t" >&5 +echo $ECHO_N "checking for intptr_t... $ECHO_C" >&6 +if test "${ac_cv_type_intptr_t+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +int +main () +{ +if ((intptr_t *) 0) + return 0; +if (sizeof (intptr_t)) + return 0; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_type_intptr_t=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_type_intptr_t=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_type_intptr_t" >&5 +echo "${ECHO_T}$ac_cv_type_intptr_t" >&6 +if test $ac_cv_type_intptr_t = yes; then + + +cat >>confdefs.h <<\_ACEOF +#define HAVE_INTPTR_T 1 +_ACEOF else - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for pointer-size signed integer type" >&5 -$as_echo_n "checking for pointer-size signed integer type... " >&6; } -if ${tcl_cv_intptr_t+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking for pointer-size signed integer type" >&5 +echo $ECHO_N "checking for pointer-size signed integer type... $ECHO_C" >&6 +if test "${tcl_cv_intptr_t+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else for tcl_cv_intptr_t in "int" "long" "long long" none; do if test "$tcl_cv_intptr_t" != none; then - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { static int test_array [1 - 2 * !(sizeof (void *) <= sizeof ($tcl_cv_intptr_t))]; -test_array [0] = 0; -return test_array [0]; +test_array [0] = 0 ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_ok=yes else - tcl_ok=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_ok=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext test "$tcl_ok" = yes && break; fi done fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_intptr_t" >&5 -$as_echo "$tcl_cv_intptr_t" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_intptr_t" >&5 +echo "${ECHO_T}$tcl_cv_intptr_t" >&6 if test "$tcl_cv_intptr_t" != none; then cat >>confdefs.h <<_ACEOF #define intptr_t $tcl_cv_intptr_t _ACEOF @@ -4659,52 +4489,136 @@ fi fi -ac_fn_c_check_type "$LINENO" "uintptr_t" "ac_cv_type_uintptr_t" "$ac_includes_default" -if test "x$ac_cv_type_uintptr_t" = xyes; then : +echo "$as_me:$LINENO: checking for uintptr_t" >&5 +echo $ECHO_N "checking for uintptr_t... $ECHO_C" >&6 +if test "${ac_cv_type_uintptr_t+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +int +main () +{ +if ((uintptr_t *) 0) + return 0; +if (sizeof (uintptr_t)) + return 0; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_type_uintptr_t=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_type_uintptr_t=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_type_uintptr_t" >&5 +echo "${ECHO_T}$ac_cv_type_uintptr_t" >&6 +if test $ac_cv_type_uintptr_t = yes; then -$as_echo "#define HAVE_UINTPTR_T 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_UINTPTR_T 1 +_ACEOF else - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for pointer-size unsigned integer type" >&5 -$as_echo_n "checking for pointer-size unsigned integer type... " >&6; } -if ${tcl_cv_uintptr_t+:} false; then : - $as_echo_n "(cached) " >&6 + echo "$as_me:$LINENO: checking for pointer-size unsigned integer type" >&5 +echo $ECHO_N "checking for pointer-size unsigned integer type... $ECHO_C" >&6 +if test "${tcl_cv_uintptr_t+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else for tcl_cv_uintptr_t in "unsigned int" "unsigned long" "unsigned long long" \ none; do if test "$tcl_cv_uintptr_t" != none; then - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { static int test_array [1 - 2 * !(sizeof (void *) <= sizeof ($tcl_cv_uintptr_t))]; -test_array [0] = 0; -return test_array [0]; +test_array [0] = 0 ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_ok=yes else - tcl_ok=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_ok=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext test "$tcl_ok" = yes && break; fi done fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_uintptr_t" >&5 -$as_echo "$tcl_cv_uintptr_t" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_uintptr_t" >&5 +echo "${ECHO_T}$tcl_cv_uintptr_t" >&6 if test "$tcl_cv_uintptr_t" != none; then cat >>confdefs.h <<_ACEOF #define uintptr_t $tcl_cv_uintptr_t _ACEOF @@ -4712,226 +4626,28 @@ fi fi - -#-------------------------------------------------------------------- -# Zipfs support - Tip 430 -#-------------------------------------------------------------------- -# Check whether --enable-zipfs was given. -if test "${enable_zipfs+set}" = set; then : - enableval=$enable_zipfs; tcl_ok=$enableval -else - tcl_ok=yes -fi - -if test "$tcl_ok" = "yes" ; then - # - # Find a native compiler - # - # Put a plausible default for CC_FOR_BUILD in Makefile. -if test -z "$CC_FOR_BUILD"; then - if test "x$cross_compiling" = "xno"; then - CC_FOR_BUILD='$(CC)' - else - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for gcc" >&5 -$as_echo_n "checking for gcc... " >&6; } - if ${ac_cv_path_cc+:} false; then : - $as_echo_n "(cached) " >&6 -else - - search_path=`echo ${PATH} | sed -e 's/:/ /g'` - for dir in $search_path ; do - for j in `ls -r $dir/gcc 2> /dev/null` \ - `ls -r $dir/gcc 2> /dev/null` ; do - if test x"$ac_cv_path_cc" = x ; then - if test -f "$j" ; then - ac_cv_path_cc=$j - break - fi - fi - done - done - -fi - - fi -fi - -# Also set EXEEXT_FOR_BUILD. -if test "x$cross_compiling" = "xno"; then - EXEEXT_FOR_BUILD='$(EXEEXT)' - OBJEXT_FOR_BUILD='$(OBJEXT)' -else - OBJEXT_FOR_BUILD='.no' - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for build system executable suffix" >&5 -$as_echo_n "checking for build system executable suffix... " >&6; } -if ${bfd_cv_build_exeext+:} false; then : - $as_echo_n "(cached) " >&6 -else - rm -f conftest* - echo 'int main () { return 0; }' > conftest.c - bfd_cv_build_exeext= - ${CC_FOR_BUILD} -o conftest conftest.c 1>&5 2>&5 - for file in conftest.*; do - case $file in - *.c | *.o | *.obj | *.ilk | *.pdb) ;; - *) bfd_cv_build_exeext=`echo $file | sed -e s/conftest//` ;; - esac - done - rm -f conftest* - test x"${bfd_cv_build_exeext}" = x && bfd_cv_build_exeext=no -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $bfd_cv_build_exeext" >&5 -$as_echo "$bfd_cv_build_exeext" >&6; } - EXEEXT_FOR_BUILD="" - test x"${bfd_cv_build_exeext}" != xno && EXEEXT_FOR_BUILD=${bfd_cv_build_exeext} -fi - - # - # Find a native zip implementation - # - - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for tclsh" >&5 -$as_echo_n "checking for tclsh... " >&6; } - - if ${ac_cv_path_tclsh+:} false; then : - $as_echo_n "(cached) " >&6 -else - - search_path=`echo ${PATH} | sed -e 's/:/ /g'` - for dir in $search_path ; do - for j in `ls -r $dir/tclsh[8-9]*.exe 2> /dev/null` \ - `ls -r $dir/tclsh* 2> /dev/null` ; do - if test x"$ac_cv_path_tclsh" = x ; then - if test -f "$j" ; then - ac_cv_path_tclsh=$j - break - fi - fi - done - done - -fi - - - if test -f "$ac_cv_path_tclsh" ; then - TCLSH_PROG="$ac_cv_path_tclsh" - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $TCLSH_PROG" >&5 -$as_echo "$TCLSH_PROG" >&6; } - else - # It is not an error if an installed version of Tcl can't be located. - TCLSH_PROG="" - { $as_echo "$as_me:${as_lineno-$LINENO}: result: No tclsh found on PATH" >&5 -$as_echo "No tclsh found on PATH" >&6; } - fi - - - - ZIP_PROG="" - ZIP_PROG_OPTIONS="" - ZIP_PROG_VFSSEARCH="" - ZIP_INSTALL_OBJS="" - - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for zip" >&5 -$as_echo_n "checking for zip... " >&6; } - if ${ac_cv_path_zip+:} false; then : - $as_echo_n "(cached) " >&6 -else - - search_path=`echo ${PATH} | sed -e 's/:/ /g'` - for dir in $search_path ; do - for j in `ls -r $dir/zip 2> /dev/null` \ - `ls -r $dir/zip 2> /dev/null` ; do - if test x"$ac_cv_path_zip" = x ; then - if test -f "$j" ; then - ac_cv_path_zip=$j - break - fi - fi - done - done - -fi - - if test -f "$ac_cv_path_zip" ; then - ZIP_PROG="$ac_cv_path_zip" - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ZIP_PROG" >&5 -$as_echo "$ZIP_PROG" >&6; } - ZIP_PROG_OPTIONS="-rq" - ZIP_PROG_VFSSEARCH="*" - { $as_echo "$as_me:${as_lineno-$LINENO}: result: Found INFO Zip in environment" >&5 -$as_echo "Found INFO Zip in environment" >&6; } - # Use standard arguments for zip - else - # It is not an error if an installed version of Zip can't be located. - # We can use the locally distributed minizip instead - ZIP_PROG="./minizip${EXEEXT_FOR_BUILD}" - ZIP_PROG_OPTIONS="-o -r" - ZIP_PROG_VFSSEARCH="*" - ZIP_INSTALL_OBJS="minizip${EXEEXT_FOR_BUILD}" - { $as_echo "$as_me:${as_lineno-$LINENO}: result: No zip found on PATH building minizip" >&5 -$as_echo "No zip found on PATH building minizip" >&6; } - fi - - - - - - ZIPFS_BUILD=1 - TCL_ZIP_FILE=libtcl_${TCL_MAJOR_VERSION}_${TCL_MINOR_VERSION}_${TCL_PATCH_LEVEL}.zip -else - ZIPFS_BUILD=0 - TCL_ZIP_FILE= -fi -# Do checking message here to not mess up interleaved configure output -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for building with zipfs" >&5 -$as_echo_n "checking for building with zipfs... " >&6; } -if test "${ZIPFS_BUILD}" = 1; then - if test "${SHARED_BUILD}" = 0; then - ZIPFS_BUILD=2; - -$as_echo "#define ZIPFS_BUILD 2" >>confdefs.h - - INSTALL_LIBRARIES=install-libraries-zipfs-static - { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -$as_echo "yes" >&6; } - else - -$as_echo "#define ZIPFS_BUILD 1" >>confdefs.h -\ - INSTALL_LIBRARIES=install-libraries-zipfs-shared - { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -$as_echo "yes" >&6; } - fi -else -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -INSTALL_LIBRARIES=install-libraries -INSTALL_MSGS=install-msgs -fi - - - - - - #-------------------------------------------------------------------- # Perform additinal compiler tests. #-------------------------------------------------------------------- # See if declarations like FINDEX_INFO_LEVELS are # missing from winbase.h. This is known to be # a problem with VC++ 5.2. -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for FINDEX_INFO_LEVELS in winbase.h" >&5 -$as_echo_n "checking for FINDEX_INFO_LEVELS in winbase.h... " >&6; } -if ${tcl_cv_findex_enums+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for FINDEX_INFO_LEVELS in winbase.h" >&5 +echo $ECHO_N "checking for FINDEX_INFO_LEVELS in winbase.h... $ECHO_C" >&6 +if test "${tcl_cv_findex_enums+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #define WIN32_LEAN_AND_MEAN #include #undef WIN32_LEAN_AND_MEAN @@ -4945,34 +4661,64 @@ ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_findex_enums=yes else - tcl_cv_findex_enums=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_findex_enums=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_findex_enums" >&5 -$as_echo "$tcl_cv_findex_enums" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_findex_enums" >&5 +echo "${ECHO_T}$tcl_cv_findex_enums" >&6 if test "$tcl_cv_findex_enums" = "no"; then -$as_echo "#define HAVE_NO_FINDEX_ENUMS 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_NO_FINDEX_ENUMS 1 +_ACEOF fi # See if the compiler supports intrinsics. -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for intrinsics support in compiler" >&5 -$as_echo_n "checking for intrinsics support in compiler... " >&6; } -if ${tcl_cv_intrinsics+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for intrinsics support in compiler" >&5 +echo $ECHO_N "checking for intrinsics support in compiler... $ECHO_C" >&6 +if test "${tcl_cv_intrinsics+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #define WIN32_LEAN_AND_MEAN #include #undef WIN32_LEAN_AND_MEAN @@ -4986,35 +4732,65 @@ ; return 0; } _ACEOF -if ac_fn_c_try_link "$LINENO"; then : +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_intrinsics=yes else - tcl_cv_intrinsics=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_intrinsics=no fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_intrinsics" >&5 -$as_echo "$tcl_cv_intrinsics" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_intrinsics" >&5 +echo "${ECHO_T}$tcl_cv_intrinsics" >&6 if test "$tcl_cv_intrinsics" = "yes"; then -$as_echo "#define HAVE_INTRIN_H 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_INTRIN_H 1 +_ACEOF fi # See if the header file is present -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for wspiapi.h" >&5 -$as_echo_n "checking for wspiapi.h... " >&6; } -if ${tcl_cv_wspiapi_h+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for wspiapi.h" >&5 +echo $ECHO_N "checking for wspiapi.h... $ECHO_C" >&6 +if test "${tcl_cv_wspiapi_h+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int @@ -5023,36 +4799,66 @@ ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_wspiapi_h=yes else - tcl_cv_wspiapi_h=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_wspiapi_h=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_wspiapi_h" >&5 -$as_echo "$tcl_cv_wspiapi_h" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_wspiapi_h" >&5 +echo "${ECHO_T}$tcl_cv_wspiapi_h" >&6 if test "$tcl_cv_wspiapi_h" = "yes"; then -$as_echo "#define HAVE_WSPIAPI_H 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_WSPIAPI_H 1 +_ACEOF fi # See if declarations like FINDEX_INFO_LEVELS are # missing from winbase.h. This is known to be # a problem with VC++ 5.2. -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for FINDEX_INFO_LEVELS in winbase.h" >&5 -$as_echo_n "checking for FINDEX_INFO_LEVELS in winbase.h... " >&6; } -if ${tcl_cv_findex_enums+:} false; then : - $as_echo_n "(cached) " >&6 +echo "$as_me:$LINENO: checking for FINDEX_INFO_LEVELS in winbase.h" >&5 +echo $ECHO_N "checking for FINDEX_INFO_LEVELS in winbase.h... $ECHO_C" >&6 +if test "${tcl_cv_findex_enums+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #define WIN32_LEAN_AND_MEAN #include #undef WIN32_LEAN_AND_MEAN @@ -5066,23 +4872,49 @@ ; return 0; } _ACEOF -if ac_fn_c_try_compile "$LINENO"; then : +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then tcl_cv_findex_enums=yes else - tcl_cv_findex_enums=no + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_findex_enums=no fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_findex_enums" >&5 -$as_echo "$tcl_cv_findex_enums" >&6; } +echo "$as_me:$LINENO: result: $tcl_cv_findex_enums" >&5 +echo "${ECHO_T}$tcl_cv_findex_enums" >&6 if test "$tcl_cv_findex_enums" = "no"; then -$as_echo "#define HAVE_NO_FINDEX_ENUMS 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define HAVE_NO_FINDEX_ENUMS 1 +_ACEOF fi #-------------------------------------------------------------------- # Set the default compiler switches based on the --enable-symbols @@ -5089,66 +4921,76 @@ # option. This macro depends on C flags, and should be called # after SC_CONFIG_CFLAGS macro is called. #-------------------------------------------------------------------- - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for build with symbols" >&5 -$as_echo_n "checking for build with symbols... " >&6; } - # Check whether --enable-symbols was given. -if test "${enable_symbols+set}" = set; then : - enableval=$enable_symbols; tcl_ok=$enableval + echo "$as_me:$LINENO: checking for build with symbols" >&5 +echo $ECHO_N "checking for build with symbols... $ECHO_C" >&6 + # Check whether --enable-symbols or --disable-symbols was given. +if test "${enable_symbols+set}" = set; then + enableval="$enable_symbols" + tcl_ok=$enableval else tcl_ok=no -fi - +fi; # FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT. if test "$tcl_ok" = "no"; then CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)' LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)' DBGX="" -$as_echo "#define NDEBUG 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define NDEBUG 1 +_ACEOF - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 - $as_echo "#define TCL_CFG_OPTIMIZED 1" >>confdefs.h + cat >>confdefs.h <<\_ACEOF +#define TCL_CFG_OPTIMIZED 1 +_ACEOF else CFLAGS_DEFAULT='$(CFLAGS_DEBUG)' LDFLAGS_DEFAULT='$(LDFLAGS_DEBUG)' DBGX=g if test "$tcl_ok" = "yes"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes (standard debugging)" >&5 -$as_echo "yes (standard debugging)" >&6; } + echo "$as_me:$LINENO: result: yes (standard debugging)" >&5 +echo "${ECHO_T}yes (standard debugging)" >&6 fi fi if test "$tcl_ok" = "mem" -o "$tcl_ok" = "all"; then -$as_echo "#define TCL_MEM_DEBUG 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define TCL_MEM_DEBUG 1 +_ACEOF fi if test "$tcl_ok" = "compile" -o "$tcl_ok" = "all"; then -$as_echo "#define TCL_COMPILE_DEBUG 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define TCL_COMPILE_DEBUG 1 +_ACEOF -$as_echo "#define TCL_COMPILE_STATS 1" >>confdefs.h +cat >>confdefs.h <<\_ACEOF +#define TCL_COMPILE_STATS 1 +_ACEOF fi if test "$tcl_ok" != "yes" -a "$tcl_ok" != "no"; then if test "$tcl_ok" = "all"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: enabled symbols mem compile debugging" >&5 -$as_echo "enabled symbols mem compile debugging" >&6; } + echo "$as_me:$LINENO: result: enabled symbols mem compile debugging" >&5 +echo "${ECHO_T}enabled symbols mem compile debugging" >&6 else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: enabled $tcl_ok debugging" >&5 -$as_echo "enabled $tcl_ok debugging" >&6; } + echo "$as_me:$LINENO: result: enabled $tcl_ok debugging" >&5 +echo "${ECHO_T}enabled $tcl_ok debugging" >&6 fi fi TCL_DBGX=${DBGX} @@ -5156,36 +4998,40 @@ #-------------------------------------------------------------------- # Embed the manifest if we can determine how #-------------------------------------------------------------------- - { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to embed manifest" >&5 -$as_echo_n "checking whether to embed manifest... " >&6; } - # Check whether --enable-embedded-manifest was given. -if test "${enable_embedded_manifest+set}" = set; then : - enableval=$enable_embedded_manifest; embed_ok=$enableval + echo "$as_me:$LINENO: checking whether to embed manifest" >&5 +echo $ECHO_N "checking whether to embed manifest... $ECHO_C" >&6 + # Check whether --enable-embedded-manifest or --disable-embedded-manifest was given. +if test "${enable_embedded_manifest+set}" = set; then + enableval="$enable_embedded_manifest" + embed_ok=$enableval else embed_ok=yes -fi - +fi; VC_MANIFEST_EMBED_DLL= VC_MANIFEST_EMBED_EXE= result=no if test "$embed_ok" = "yes" -a "${SHARED_BUILD}" = "1" \ -a "$GCC" != "yes" ; then # Add the magic to embed the manifest into the dll/exe - cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #if defined(_MSC_VER) && _MSC_VER >= 1400 print("manifest needed") #endif _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - $EGREP "manifest needed" >/dev/null 2>&1; then : + $EGREP "manifest needed" >/dev/null 2>&1; then # Could do a CHECK_PROG for mt, but should always be with MSVC8+ # Could add 'if test -f' check, but manifest should be created # in this compiler case # Add in a manifest argument that may be specified @@ -5200,12 +5046,12 @@ fi rm -f conftest* fi - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $result" >&5 -$as_echo "$result" >&6; } + echo "$as_me:$LINENO: result: $result" >&5 +echo "${ECHO_T}$result" >&6 #------------------------------------------------------------------------ @@ -5216,14 +5062,10 @@ #-------------------------------------------------------------------- # Perform final evaluations of variables with possible substitutions. #-------------------------------------------------------------------- -TCL_SHARED_LIB_SUFFIX="\${NODOT_VERSION}${DLLSUFFIX}" -TCL_UNSHARED_LIB_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}" -TCL_EXPORT_FILE_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}" - eval "TCL_SRC_DIR=\"`cd $srcdir/..; $CYGPATH $(pwd)`\"" eval "TCL_DLL_FILE=tcl${VER}${DLLSUFFIX}" eval "TCL_STUB_LIB_FILE=\"${LIBPREFIX}tclstub${VER}${LIBSUFFIX}\"" @@ -5231,23 +5073,30 @@ eval "TCL_BUILD_STUB_LIB_SPEC=\"-L`$CYGPATH $(pwd)` ${TCL_STUB_LIB_FLAG}\"" eval "TCL_STUB_LIB_SPEC=\"-L${libdir} ${TCL_STUB_LIB_FLAG}\"" eval "TCL_BUILD_STUB_LIB_PATH=\"`$CYGPATH $(pwd)`/${TCL_STUB_LIB_FILE}\"" eval "TCL_STUB_LIB_PATH=\"${libdir}/${TCL_STUB_LIB_FILE}\"" -eval "TCL_LIB_FILE=\"${LIBPREFIX}tcl${VER}${LIBSUFFIX}\"" +if test ${SHARED_BUILD} = 0 ; then + eval "TCL_LIB_FILE=\"${LIBPREFIX}tcl${VER}${LIBSUFFIX}\"" +else + eval "TCL_LIB_FILE=\"${LIBPREFIX}tcl${VER}${DLLSUFFIX}.a\"" +fi eval "TCL_BUILD_LIB_SPEC=\"-L`$CYGPATH $(pwd)` -ltcl${VER}${FLAGSUFFIX}\"" eval "TCL_LIB_SPEC=\"-L${libdir} -ltcl${VER}${FLAGSUFFIX}\"" # Install time header dir can be set via --includedir eval "TCL_INCLUDE_SPEC=\"-I${includedir}\"" - eval "DLLSUFFIX=${DLLSUFFIX}" eval "LIBPREFIX=${LIBPREFIX}" eval "LIBSUFFIX=${LIBSUFFIX}" eval "EXESUFFIX=${EXESUFFIX}" +TCL_SHARED_LIB_SUFFIX="\${NODOT_VERSION}${DLLSUFFIX}" +TCL_UNSHARED_LIB_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}" +TCL_EXPORT_FILE_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}" + CFG_TCL_SHARED_LIB_SUFFIX=${TCL_SHARED_LIB_SUFFIX} CFG_TCL_UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX} CFG_TCL_EXPORT_FILE_SUFFIX=${TCL_EXPORT_FILE_SUFFIX} #-------------------------------------------------------------------- @@ -5275,13 +5124,13 @@ # consists of one directory for machine-dependent binaries and # another for platform-independent scripts. #-------------------------------------------------------------------- if test "$prefix/lib" != "$libdir"; then - TCL_PACKAGE_PATH="${libdir} ${prefix}/lib" + TCL_PACKAGE_PATH="{${libdir}} {${prefix}/lib}" else - TCL_PACKAGE_PATH="${prefix}/lib" + TCL_PACKAGE_PATH="{${prefix}/lib}" fi # The tclsh.exe.manifest requires these # TCL_WIN_VERSION is the 4 dotted pair Windows version format which needs # the release level, and must account for interim release versioning @@ -5388,12 +5237,11 @@ -ac_config_files="$ac_config_files Makefile tclConfig.sh tcl.hpj tclsh.exe.manifest" - + ac_config_files="$ac_config_files Makefile tclConfig.sh tcl.hpj tclsh.exe.manifest" cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure # scripts and configure runs, see configure's option --config-cache. # It is not useful on other systems. If it contains results you don't @@ -5408,653 +5256,512 @@ _ACEOF # The following way of writing the cache mishandles newlines in values, # but we know of no workaround that is simple, portable, and efficient. -# So, we kill variables containing newlines. +# So, don't put newlines in cache variables' values. # Ultrix sh set writes to stderr and can't be redirected directly, # and sets the high bit in the cache file unless we assign to the vars. -( - for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do - eval ac_val=\$$ac_var - case $ac_val in #( - *${as_nl}*) - case $ac_var in #( - *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 -$as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; - esac - case $ac_var in #( - _ | IFS | as_nl) ;; #( - BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( - *) { eval $ac_var=; unset $ac_var;} ;; - esac ;; - esac - done - +{ (set) 2>&1 | - case $as_nl`(ac_space=' '; set) 2>&1` in #( - *${as_nl}ac_space=\ *) - # `set' does not quote correctly, so add quotes: double-quote - # substitution turns \\\\ into \\, and sed turns \\ into \. + case `(ac_space=' '; set | grep ac_space) 2>&1` in + *ac_space=\ *) + # `set' does not quote correctly, so add quotes (double-quote + # substitution turns \\\\ into \\, and sed turns \\ into \). sed -n \ "s/'/'\\\\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" - ;; #( + ;; *) # `set' quotes correctly as required by POSIX, so do not add quotes. - sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" + sed -n \ + "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p" ;; - esac | - sort -) | + esac; +} | sed ' - /^ac_cv_env_/b end t clear - :clear + : clear s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ t end - s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ - :end' >>confcache -if diff "$cache_file" confcache >/dev/null 2>&1; then :; else - if test -w "$cache_file"; then - if test "x$cache_file" != "x/dev/null"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 -$as_echo "$as_me: updating cache $cache_file" >&6;} - if test ! -f "$cache_file" || test -h "$cache_file"; then - cat confcache >"$cache_file" - else - case $cache_file in #( - */* | ?:*) - mv -f confcache "$cache_file"$$ && - mv -f "$cache_file"$$ "$cache_file" ;; #( - *) - mv -f confcache "$cache_file" ;; - esac - fi - fi - else - { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 -$as_echo "$as_me: not updating unwritable cache $cache_file" >&6;} + /^ac_cv_env/!s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ + : end' >>confcache +if diff $cache_file confcache >/dev/null 2>&1; then :; else + if test -w $cache_file; then + test "x$cache_file" != "x/dev/null" && echo "updating cache $cache_file" + cat confcache >$cache_file + else + echo "not updating unwritable cache $cache_file" fi fi rm -f confcache test "x$prefix" = xNONE && prefix=$ac_default_prefix # Let make expand exec_prefix. test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' + +# VPATH may cause trouble with some makes, so we remove $(srcdir), +# ${srcdir} and @srcdir@ from VPATH if srcdir is ".", strip leading and +# trailing colons and then remove the whole line if VPATH becomes empty +# (actually we leave an empty line to preserve line numbers). +if test "x$srcdir" = x.; then + ac_vpsub='/^[ ]*VPATH[ ]*=/{ +s/:*\$(srcdir):*/:/; +s/:*\${srcdir}:*/:/; +s/:*@srcdir@:*/:/; +s/^\([^=]*=[ ]*\):*/\1/; +s/:*$//; +s/^[^=]*=[ ]*$//; +}' +fi # Transform confdefs.h into DEFS. # Protect against shell expansion while executing Makefile rules. # Protect against Makefile macro expansion. # # If the first sed substitution is executed (which looks for macros that -# take arguments), then branch to the quote section. Otherwise, -# look for a macro that doesn't take arguments. -ac_script=' -:mline -/\\$/{ - N - s,\\\n,, - b mline -} -t clear -:clear -s/^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\)/-D\1=\2/g -t quote -s/^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\)/-D\1=\2/g -t quote -b any -:quote -s/[ `~#$^&*(){}\\|;'\''"<>?]/\\&/g -s/\[/\\&/g -s/\]/\\&/g -s/\$/$$/g -H -:any -${ - g - s/^\n// - s/\n/ /g - p -} -' -DEFS=`sed -n "$ac_script" confdefs.h` +# take arguments), then we branch to the quote section. Otherwise, +# look for a macro that doesn't take arguments. +cat >confdef2opt.sed <<\_ACEOF +t clear +: clear +s,^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\),-D\1=\2,g +t quote +s,^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\),-D\1=\2,g +t quote +d +: quote +s,[ `~#$^&*(){}\\|;'"<>?],\\&,g +s,\[,\\&,g +s,\],\\&,g +s,\$,$$,g +p +_ACEOF +# We use echo to avoid assuming a particular line-breaking character. +# The extra dot is to prevent the shell from consuming trailing +# line-breaks from the sub-command output. A line-break within +# single-quotes doesn't work because, if this script is created in a +# platform that uses two characters for line-breaks (e.g., DOS), tr +# would break. +ac_LF_and_DOT=`echo; echo .` +DEFS=`sed -n -f confdef2opt.sed confdefs.h | tr "$ac_LF_and_DOT" ' .'` +rm -f confdef2opt.sed ac_libobjs= ac_ltlibobjs= -U= for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue # 1. Remove the extension, and $U if already installed. - ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' - ac_i=`$as_echo "$ac_i" | sed "$ac_script"` - # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR - # will be set to the directory where LIBOBJS objects are built. - as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" - as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' + ac_i=`echo "$ac_i" | + sed 's/\$U\././;s/\.o$//;s/\.obj$//'` + # 2. Add them. + ac_libobjs="$ac_libobjs $ac_i\$U.$ac_objext" + ac_ltlibobjs="$ac_ltlibobjs $ac_i"'$U.lo' done LIBOBJS=$ac_libobjs LTLIBOBJS=$ac_ltlibobjs -: "${CONFIG_STATUS=./config.status}" -ac_write_fail=0 +: ${CONFIG_STATUS=./config.status} ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files $CONFIG_STATUS" -{ $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 -$as_echo "$as_me: creating $CONFIG_STATUS" >&6;} -as_write_fail=0 -cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 +{ echo "$as_me:$LINENO: creating $CONFIG_STATUS" >&5 +echo "$as_me: creating $CONFIG_STATUS" >&6;} +cat >$CONFIG_STATUS <<_ACEOF #! $SHELL # Generated by $as_me. # Run this file to recreate the current configuration. # Compiler output produced by configure, useful for debugging # configure, is in config.log if it exists. debug=false ac_cs_recheck=false ac_cs_silent=false - SHELL=\${CONFIG_SHELL-$SHELL} -export SHELL -_ASEOF -cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 -## -------------------- ## -## M4sh Initialization. ## -## -------------------- ## - -# Be more Bourne compatible -DUALCASE=1; export DUALCASE # for MKS sh -if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF +## --------------------- ## +## M4sh Initialization. ## +## --------------------- ## + +# Be Bourne compatible +if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then emulate sh NULLCMD=: - # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which + # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' - setopt NO_GLOB_SUBST -else - case `(set -o) 2>/dev/null` in #( - *posix*) : - set -o posix ;; #( - *) : - ;; -esac -fi - - -as_nl=' -' -export as_nl -# Printing a long string crashes Solaris 7 /usr/bin/printf. -as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' -as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo -as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo -# Prefer a ksh shell builtin over an external printf program on Solaris, -# but without wasting forks for bash or zsh. -if test -z "$BASH_VERSION$ZSH_VERSION" \ - && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then - as_echo='print -r --' - as_echo_n='print -rn --' -elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then - as_echo='printf %s\n' - as_echo_n='printf %s' -else - if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then - as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' - as_echo_n='/usr/ucb/echo -n' - else - as_echo_body='eval expr "X$1" : "X\\(.*\\)"' - as_echo_n_body='eval - arg=$1; - case $arg in #( - *"$as_nl"*) - expr "X$arg" : "X\\(.*\\)$as_nl"; - arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; - esac; - expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" - ' - export as_echo_n_body - as_echo_n='sh -c $as_echo_n_body as_echo' - fi - export as_echo_body - as_echo='sh -c $as_echo_body as_echo' -fi - -# The user is always right. -if test "${PATH_SEPARATOR+set}" != set; then - PATH_SEPARATOR=: - (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { - (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || - PATH_SEPARATOR=';' - } -fi - - -# IFS -# We need space, tab and new line, in precisely that order. Quoting is -# there to prevent editors from complaining about space-tab. -# (If _AS_PATH_WALK were called with IFS unset, it would disable word -# splitting by setting IFS to empty value.) -IFS=" "" $as_nl" - -# Find who we are. Look in the path if we contain no directory separator. -as_myself= -case $0 in #(( - *[\\/]* ) as_myself=$0 ;; - *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break - done -IFS=$as_save_IFS - - ;; -esac -# We did not find ourselves, most probably we were run as `sh COMMAND' -# in which case we are not to be found in the path. -if test "x$as_myself" = x; then - as_myself=$0 -fi -if test ! -f "$as_myself"; then - $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 - exit 1 -fi - -# Unset variables that we do not need and which cause bugs (e.g. in -# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" -# suppresses any "Segmentation fault" message there. '((' could -# trigger a bug in pdksh 5.2.14. -for as_var in BASH_ENV ENV MAIL MAILPATH -do eval test x\${$as_var+set} = xset \ - && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : -done +elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then + set -o posix +fi +DUALCASE=1; export DUALCASE # for MKS sh + +# Support unset when possible. +if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then + as_unset=unset +else + as_unset=false +fi + + +# Work around bugs in pre-3.0 UWIN ksh. +$as_unset ENV MAIL MAILPATH PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. -LC_ALL=C -export LC_ALL -LANGUAGE=C -export LANGUAGE - -# CDPATH. -(unset CDPATH) >/dev/null 2>&1 && unset CDPATH - - -# as_fn_error STATUS ERROR [LINENO LOG_FD] -# ---------------------------------------- -# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are -# provided, also output the error to LOG_FD, referencing LINENO. Then exit the -# script with STATUS, using 1 if that was 0. -as_fn_error () -{ - as_status=$1; test $as_status -eq 0 && as_status=1 - if test "$4"; then - as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 +for as_var in \ + LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \ + LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \ + LC_TELEPHONE LC_TIME +do + if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then + eval $as_var=C; export $as_var + else + $as_unset $as_var fi - $as_echo "$as_me: error: $2" >&2 - as_fn_exit $as_status -} # as_fn_error - - -# as_fn_set_status STATUS -# ----------------------- -# Set $? to STATUS, without forking. -as_fn_set_status () -{ - return $1 -} # as_fn_set_status - -# as_fn_exit STATUS -# ----------------- -# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. -as_fn_exit () -{ - set +e - as_fn_set_status $1 - exit $1 -} # as_fn_exit - -# as_fn_unset VAR -# --------------- -# Portably unset VAR. -as_fn_unset () -{ - { eval $1=; unset $1;} -} -as_unset=as_fn_unset -# as_fn_append VAR VALUE -# ---------------------- -# Append the text in VALUE to the end of the definition contained in VAR. Take -# advantage of any shell optimizations that allow amortized linear growth over -# repeated appends, instead of the typical quadratic growth present in naive -# implementations. -if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : - eval 'as_fn_append () - { - eval $1+=\$2 - }' -else - as_fn_append () - { - eval $1=\$$1\$2 - } -fi # as_fn_append - -# as_fn_arith ARG... -# ------------------ -# Perform arithmetic evaluation on the ARGs, and store the result in the -# global $as_val. Take advantage of shells that can avoid forks. The arguments -# must be portable across $(()) and expr. -if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : - eval 'as_fn_arith () - { - as_val=$(( $* )) - }' -else - as_fn_arith () - { - as_val=`expr "$@" || test $? -eq 1` - } -fi # as_fn_arith - - -if expr a : '\(a\)' >/dev/null 2>&1 && - test "X`expr 00001 : '.*\(...\)'`" = X001; then +done + +# Required to use basename. +if expr a : '\(a\)' >/dev/null 2>&1; then as_expr=expr else as_expr=false fi -if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then +if (basename /) >/dev/null 2>&1 && test "X`basename / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi -if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then - as_dirname=dirname -else - as_dirname=false -fi -as_me=`$as_basename -- "$0" || +# Name of the executable. +as_me=`$as_basename "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ - X"$0" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X/"$0" | - sed '/^.*\/\([^/][^/]*\)\/*$/{ - s//\1/ - q - } - /^X\/\(\/\/\)$/{ - s//\1/ - q - } - /^X\/\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - + X"$0" : 'X\(/\)$' \| \ + . : '\(.\)' 2>/dev/null || +echo X/"$0" | + sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/; q; } + /^X\/\(\/\/\)$/{ s//\1/; q; } + /^X\/\(\/\).*/{ s//\1/; q; } + s/.*/./; q'` + + +# PATH needs CR, and LINENO needs CR and PATH. # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits -ECHO_C= ECHO_N= ECHO_T= -case `echo -n x` in #((((( --n*) - case `echo 'xy\c'` in - *c*) ECHO_T=' ';; # ECHO_T is single tab character. - xy) ECHO_C='\c';; - *) echo `echo ksh88 bug on AIX 6.1` > /dev/null - ECHO_T=' ';; - esac;; -*) - ECHO_N='-n';; -esac - -rm -f conf$$ conf$$.exe conf$$.file -if test -d conf$$.dir; then - rm -f conf$$.dir/conf$$.file -else - rm -f conf$$.dir - mkdir conf$$.dir 2>/dev/null -fi -if (echo >conf$$.file) 2>/dev/null; then - if ln -s conf$$.file conf$$ 2>/dev/null; then - as_ln_s='ln -s' - # ... but there are two gotchas: - # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. - # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. - # In both cases, we have to default to `cp -pR'. - ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || - as_ln_s='cp -pR' - elif ln conf$$.file conf$$ 2>/dev/null; then - as_ln_s=ln - else - as_ln_s='cp -pR' - fi -else - as_ln_s='cp -pR' -fi -rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file -rmdir conf$$.dir 2>/dev/null - - -# as_fn_mkdir_p -# ------------- -# Create "$as_dir" as a directory, including parents if necessary. -as_fn_mkdir_p () -{ - - case $as_dir in #( - -*) as_dir=./$as_dir;; - esac - test -d "$as_dir" || eval $as_mkdir_p || { - as_dirs= - while :; do - case $as_dir in #( - *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( - *) as_qdir=$as_dir;; - esac - as_dirs="'$as_qdir' $as_dirs" - as_dir=`$as_dirname -- "$as_dir" || -$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$as_dir" : 'X\(//\)[^/]' \| \ - X"$as_dir" : 'X\(//\)$' \| \ - X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X"$as_dir" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - test -d "$as_dir" && break - done - test -z "$as_dirs" || eval "mkdir $as_dirs" - } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" - - -} # as_fn_mkdir_p -if mkdir -p . 2>/dev/null; then - as_mkdir_p='mkdir -p "$as_dir"' +# The user is always right. +if test "${PATH_SEPARATOR+set}" != set; then + echo "#! /bin/sh" >conf$$.sh + echo "exit 0" >>conf$$.sh + chmod +x conf$$.sh + if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then + PATH_SEPARATOR=';' + else + PATH_SEPARATOR=: + fi + rm -f conf$$.sh +fi + + + as_lineno_1=$LINENO + as_lineno_2=$LINENO + as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` + test "x$as_lineno_1" != "x$as_lineno_2" && + test "x$as_lineno_3" = "x$as_lineno_2" || { + # Find who we are. Look in the path if we contain no path at all + # relative or not. + case $0 in + *[\\/]* ) as_myself=$0 ;; + *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break +done + + ;; + esac + # We did not find ourselves, most probably we were run as `sh COMMAND' + # in which case we are not to be found in the path. + if test "x$as_myself" = x; then + as_myself=$0 + fi + if test ! -f "$as_myself"; then + { { echo "$as_me:$LINENO: error: cannot find myself; rerun with an absolute path" >&5 +echo "$as_me: error: cannot find myself; rerun with an absolute path" >&2;} + { (exit 1); exit 1; }; } + fi + case $CONFIG_SHELL in + '') + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for as_base in sh bash ksh sh5; do + case $as_dir in + /*) + if ("$as_dir/$as_base" -c ' + as_lineno_1=$LINENO + as_lineno_2=$LINENO + as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` + test "x$as_lineno_1" != "x$as_lineno_2" && + test "x$as_lineno_3" = "x$as_lineno_2" ') 2>/dev/null; then + $as_unset BASH_ENV || test "${BASH_ENV+set}" != set || { BASH_ENV=; export BASH_ENV; } + $as_unset ENV || test "${ENV+set}" != set || { ENV=; export ENV; } + CONFIG_SHELL=$as_dir/$as_base + export CONFIG_SHELL + exec "$CONFIG_SHELL" "$0" ${1+"$@"} + fi;; + esac + done +done +;; + esac + + # Create $as_me.lineno as a copy of $as_myself, but with $LINENO + # uniformly replaced by the line number. The first 'sed' inserts a + # line-number line before each line; the second 'sed' does the real + # work. The second script uses 'N' to pair each line-number line + # with the numbered line, and appends trailing '-' during + # substitution so that $LINENO is not a special case at line end. + # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the + # second 'sed' script. Blame Lee E. McMahon for sed's syntax. :-) + sed '=' <$as_myself | + sed ' + N + s,$,-, + : loop + s,^\(['$as_cr_digits']*\)\(.*\)[$]LINENO\([^'$as_cr_alnum'_]\),\1\2\1\3, + t loop + s,-$,, + s,^['$as_cr_digits']*\n,, + ' >$as_me.lineno && + chmod +x $as_me.lineno || + { { echo "$as_me:$LINENO: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&5 +echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2;} + { (exit 1); exit 1; }; } + + # Don't try to exec as it changes $[0], causing all sort of problems + # (the dirname of $[0] is not the place where we might find the + # original and so on. Autoconf is especially sensible to this). + . ./$as_me.lineno + # Exit status is that of the last command. + exit +} + + +case `echo "testing\c"; echo 1,2,3`,`echo -n testing; echo 1,2,3` in + *c*,-n*) ECHO_N= ECHO_C=' +' ECHO_T=' ' ;; + *c*,* ) ECHO_N=-n ECHO_C= ECHO_T= ;; + *) ECHO_N= ECHO_C='\c' ECHO_T= ;; +esac + +if expr a : '\(a\)' >/dev/null 2>&1; then + as_expr=expr +else + as_expr=false +fi + +rm -f conf$$ conf$$.exe conf$$.file +echo >conf$$.file +if ln -s conf$$.file conf$$ 2>/dev/null; then + # We could just check for DJGPP; but this test a) works b) is more generic + # and c) will remain valid once DJGPP supports symlinks (DJGPP 2.04). + if test -f conf$$.exe; then + # Don't use ln at all; we don't have any links + as_ln_s='cp -p' + else + as_ln_s='ln -s' + fi +elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln +else + as_ln_s='cp -p' +fi +rm -f conf$$ conf$$.exe conf$$.file + +if mkdir -p . 2>/dev/null; then + as_mkdir_p=: else test -d ./-p && rmdir ./-p as_mkdir_p=false fi - -# as_fn_executable_p FILE -# ----------------------- -# Test if FILE is an executable regular file. -as_fn_executable_p () -{ - test -f "$1" && test -x "$1" -} # as_fn_executable_p -as_test_x='test -x' -as_executable_p=as_fn_executable_p +as_executable_p="test -f" # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" +# IFS +# We need space, tab and new line, in precisely that order. +as_nl=' +' +IFS=" $as_nl" + +# CDPATH. +$as_unset CDPATH + exec 6>&1 -## ----------------------------------- ## -## Main body of $CONFIG_STATUS script. ## -## ----------------------------------- ## -_ASEOF -test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 - -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -# Save the log message, to keep $0 and so on meaningful, and to + +# Open the log real soon, 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=" +# values after options handling. Logging --version etc. is OK. +exec 5>>config.log +{ + echo + sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX +## Running $as_me. ## +_ASBOX +} >&5 +cat >&5 <<_CSEOF + This file was extended by $as_me, which was -generated by GNU Autoconf 2.69. Invocation command line was +generated by GNU Autoconf 2.59. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS CONFIG_COMMANDS = $CONFIG_COMMANDS $ $0 $@ -on `(hostname || uname -n) 2>/dev/null | sed 1q` -" - +_CSEOF +echo "on `(hostname || uname -n) 2>/dev/null | sed 1q`" >&5 +echo >&5 _ACEOF -case $ac_config_files in *" -"*) set x $ac_config_files; shift; ac_config_files=$*;; -esac - - - -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 # Files that config.status was made for. -config_files="$ac_config_files" +if test -n "$ac_config_files"; then + echo "config_files=\"$ac_config_files\"" >>$CONFIG_STATUS +fi + +if test -n "$ac_config_headers"; then + echo "config_headers=\"$ac_config_headers\"" >>$CONFIG_STATUS +fi + +if test -n "$ac_config_links"; then + echo "config_links=\"$ac_config_links\"" >>$CONFIG_STATUS +fi -_ACEOF +if test -n "$ac_config_commands"; then + echo "config_commands=\"$ac_config_commands\"" >>$CONFIG_STATUS +fi -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +cat >>$CONFIG_STATUS <<\_ACEOF + ac_cs_usage="\ -\`$as_me' instantiates files and other configuration actions -from templates according to the current configuration. Unless the files -and actions are specified as TAGs, all are instantiated by default. +\`$as_me' instantiates files from templates according to the +current configuration. -Usage: $0 [OPTION]... [TAG]... +Usage: $0 [OPTIONS] [FILE]... -h, --help print this help, then exit - -V, --version print version number and configuration settings, then exit - --config print configuration, then exit - -q, --quiet, --silent - do not print progress messages + -V, --version print version number, then exit + -q, --quiet do not print progress messages -d, --debug don't remove temporary files --recheck update $as_me by reconfiguring in the same conditions - --file=FILE[:TEMPLATE] - instantiate the configuration file FILE + --file=FILE[:TEMPLATE] + instantiate the configuration file FILE Configuration files: $config_files -Report bugs to the package provider." - +Report bugs to ." _ACEOF -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" + +cat >>$CONFIG_STATUS <<_ACEOF ac_cs_version="\\ config.status -configured by $0, generated by GNU Autoconf 2.69, - with options \\"\$ac_cs_config\\" +configured by $0, generated by GNU Autoconf 2.59, + with options \\"`echo "$ac_configure_args" | sed 's/[\\""\`\$]/\\\\&/g'`\\" -Copyright (C) 2012 Free Software Foundation, Inc. +Copyright (C) 2003 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." - -ac_pwd='$ac_pwd' -srcdir='$srcdir' -test -n "\$AWK" || AWK=awk +srcdir=$srcdir _ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -# The default lists apply if the user does not specify any file. +cat >>$CONFIG_STATUS <<\_ACEOF +# If no file are specified by the user, then we need to provide default +# value. By we need to know if files were specified by the user. ac_need_defaults=: while test $# != 0 do case $1 in - --*=?*) - ac_option=`expr "X$1" : 'X\([^=]*\)='` - ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` + --*=*) + ac_option=`expr "x$1" : 'x\([^=]*\)='` + ac_optarg=`expr "x$1" : 'x[^=]*=\(.*\)'` ac_shift=: ;; - --*=) - ac_option=`expr "X$1" : 'X\([^=]*\)='` - ac_optarg= - ac_shift=: - ;; - *) + -*) ac_option=$1 ac_optarg=$2 ac_shift=shift ;; + *) # This is not an option, so the user has probably given explicit + # arguments. + ac_option=$1 + ac_need_defaults=false;; esac case $ac_option in # Handling of the options. +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) ac_cs_recheck=: ;; - --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) - $as_echo "$ac_cs_version"; exit ;; - --config | --confi | --conf | --con | --co | --c ) - $as_echo "$ac_cs_config"; exit ;; - --debug | --debu | --deb | --de | --d | -d ) + --version | --vers* | -V ) + echo "$ac_cs_version"; exit 0 ;; + --he | --h) + # Conflict between --help and --header + { { echo "$as_me:$LINENO: error: ambiguous option: $1 +Try \`$0 --help' for more information." >&5 +echo "$as_me: error: ambiguous option: $1 +Try \`$0 --help' for more information." >&2;} + { (exit 1); exit 1; }; };; + --help | --hel | -h ) + echo "$ac_cs_usage"; exit 0 ;; + --debug | --d* | -d ) debug=: ;; --file | --fil | --fi | --f ) $ac_shift - case $ac_optarg in - *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; - '') as_fn_error $? "missing file argument" ;; - esac - as_fn_append CONFIG_FILES " '$ac_optarg'" + CONFIG_FILES="$CONFIG_FILES $ac_optarg" ac_need_defaults=false;; - --he | --h | --help | --hel | -h ) - $as_echo "$ac_cs_usage"; exit ;; + --header | --heade | --head | --hea ) + $ac_shift + CONFIG_HEADERS="$CONFIG_HEADERS $ac_optarg" + ac_need_defaults=false;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil | --si | --s) ac_cs_silent=: ;; # This is an error. - -*) as_fn_error $? "unrecognized option: \`$1' -Try \`$0 --help' for more information." ;; + -*) { { echo "$as_me:$LINENO: error: unrecognized option: $1 +Try \`$0 --help' for more information." >&5 +echo "$as_me: error: unrecognized option: $1 +Try \`$0 --help' for more information." >&2;} + { (exit 1); exit 1; }; } ;; - *) as_fn_append ac_config_targets " $1" - ac_need_defaults=false ;; + *) ac_config_targets="$ac_config_targets $1" ;; esac shift done @@ -6064,50 +5771,36 @@ exec 6>/dev/null ac_configure_extra_args="$ac_configure_extra_args --silent" fi _ACEOF -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +cat >>$CONFIG_STATUS <<_ACEOF if \$ac_cs_recheck; then - set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion - shift - \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6 - CONFIG_SHELL='$SHELL' - export CONFIG_SHELL - exec "\$@" + echo "running $SHELL $0 " $ac_configure_args \$ac_configure_extra_args " --no-create --no-recursion" >&6 + exec $SHELL $0 $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion fi _ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -exec 5>>config.log -{ - echo - sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX -## Running $as_me. ## -_ASBOX - $as_echo "$ac_log" -} >&5 - -_ACEOF -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -_ACEOF - -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 - -# Handling of arguments. + + + + + +cat >>$CONFIG_STATUS <<\_ACEOF for ac_config_target in $ac_config_targets do - case $ac_config_target in - "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;; - "tclConfig.sh") CONFIG_FILES="$CONFIG_FILES tclConfig.sh" ;; - "tcl.hpj") CONFIG_FILES="$CONFIG_FILES tcl.hpj" ;; - "tclsh.exe.manifest") CONFIG_FILES="$CONFIG_FILES tclsh.exe.manifest" ;; - - *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; + case "$ac_config_target" in + # Handling of arguments. + "Makefile" ) CONFIG_FILES="$CONFIG_FILES Makefile" ;; + "tclConfig.sh" ) CONFIG_FILES="$CONFIG_FILES tclConfig.sh" ;; + "tcl.hpj" ) CONFIG_FILES="$CONFIG_FILES tcl.hpj" ;; + "tclsh.exe.manifest" ) CONFIG_FILES="$CONFIG_FILES tclsh.exe.manifest" ;; + *) { { echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5 +echo "$as_me: error: invalid argument: $ac_config_target" >&2;} + { (exit 1); exit 1; }; };; esac done - # If the user did not use the arguments to specify the items to instantiate, # then the envvar interface is used. Set only those that are not. # We use the long form for the default assignment because of an extremely # bizarre bug on SunOS 4.1.3. @@ -6114,417 +5807,424 @@ if $ac_need_defaults; then test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files fi # Have a temporary directory for convenience. Make it in the build tree -# simply because there is no reason against having it here, and in addition, +# simply because there is no reason to put it here, and in addition, # creating and moving files from /tmp can sometimes cause problems. -# Hook for its removal unless debugging. -# Note that there is a small window in which the directory will not be cleaned: -# after its creation but before its name has been assigned to `$tmp'. +# Create a temporary directory, and hook for its removal unless debugging. $debug || { - tmp= ac_tmp= - trap 'exit_status=$? - : "${ac_tmp:=$tmp}" - { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status -' 0 - trap 'as_fn_exit 1' 1 2 13 15 + trap 'exit_status=$?; rm -rf $tmp && exit $exit_status' 0 + trap '{ (exit 1); exit 1; }' 1 2 13 15 } + # Create a (secure) tmp directory for tmp files. { - tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && - test -d "$tmp" + tmp=`(umask 077 && mktemp -d -q "./confstatXXXXXX") 2>/dev/null` && + test -n "$tmp" && test -d "$tmp" } || { - tmp=./conf$$-$RANDOM - (umask 077 && mkdir "$tmp") -} || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 -ac_tmp=$tmp - -# Set up the scripts for CONFIG_FILES section. -# No need to generate them if there are no CONFIG_FILES. -# This happens for instance with `./config.status config.h'. -if test -n "$CONFIG_FILES"; then - - -ac_cr=`echo X | tr X '\015'` -# On cygwin, bash can eat \r inside `` if the user requested igncr. -# But we know of no other shell where ac_cr would be empty at this -# point, so we can use a bashism as a fallback. -if test "x$ac_cr" = x; then - eval ac_cr=\$\'\\r\' -fi -ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` -if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then - ac_cs_awk_cr='\\r' -else - ac_cs_awk_cr=$ac_cr -fi - -echo 'BEGIN {' >"$ac_tmp/subs1.awk" && -_ACEOF - - -{ - echo "cat >conf$$subs.awk <<_ACEOF" && - echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && - echo "_ACEOF" -} >conf$$subs.sh || - as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 -ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` -ac_delim='%!_!# ' -for ac_last_try in false false false false false :; do - . ./conf$$subs.sh || - as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 - - ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` - if test $ac_delim_n = $ac_delim_num; then - break - elif $ac_last_try; then - as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 - else - ac_delim="$ac_delim!$ac_delim _$ac_delim!! " - fi -done -rm -f conf$$subs.sh - -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && -_ACEOF -sed -n ' -h -s/^/S["/; s/!.*/"]=/ -p -g -s/^[^!]*!// -:repl -t repl -s/'"$ac_delim"'$// -t delim -:nl -h -s/\(.\{148\}\)..*/\1/ -t more1 -s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ -p -n -b repl -:more1 -s/["\\]/\\&/g; s/^/"/; s/$/"\\/ -p -g -s/.\{148\}// -t nl -:delim -h -s/\(.\{148\}\)..*/\1/ -t more2 -s/["\\]/\\&/g; s/^/"/; s/$/"/ -p -b -:more2 -s/["\\]/\\&/g; s/^/"/; s/$/"\\/ -p -g -s/.\{148\}// -t delim -' >$CONFIG_STATUS || ac_write_fail=1 -rm -f conf$$subs.awk -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -_ACAWK -cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && - for (key in S) S_is_set[key] = 1 - FS = "" - -} -{ - line = $ 0 - nfields = split(line, field, "@") - substed = 0 - len = length(field[1]) - for (i = 2; i < nfields; i++) { - key = field[i] - keylen = length(key) - if (S_is_set[key]) { - value = S[key] - line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) - len += length(value) + length(field[++i]) - substed = 1 - } else - len += 1 + keylen - } - - print line -} - -_ACAWK -_ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then - sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" -else - cat -fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ - || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 -_ACEOF - -# VPATH may cause trouble with some makes, so we remove sole $(srcdir), -# ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and -# trailing colons and then remove the whole line if VPATH becomes empty -# (actually we leave an empty line to preserve line numbers). -if test "x$srcdir" = x.; then - ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ -h -s/// -s/^/:/ -s/[ ]*$/:/ -s/:\$(srcdir):/:/g -s/:\${srcdir}:/:/g -s/:@srcdir@:/:/g -s/^:*// -s/:*$// -x -s/\(=[ ]*\).*/\1/ -G -s/\n// -s/^[^=]*=[ ]*$// -}' -fi - -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 + tmp=./confstat$$-$RANDOM + (umask 077 && mkdir $tmp) +} || +{ + echo "$me: cannot create a temporary directory in ." >&2 + { (exit 1); exit 1; } +} + +_ACEOF + +cat >>$CONFIG_STATUS <<_ACEOF + +# +# CONFIG_FILES section. +# + +# No need to generate the scripts if there are no CONFIG_FILES. +# This happens for instance when ./config.status config.h +if test -n "\$CONFIG_FILES"; then + # Protect against being on the right side of a sed subst in config.status. + sed 's/,@/@@/; s/@,/@@/; s/,;t t\$/@;t t/; /@;t t\$/s/[\\\\&,]/\\\\&/g; + s/@@/,@/; s/@@/@,/; s/@;t t\$/,;t t/' >\$tmp/subs.sed <<\\CEOF +s,@SHELL@,$SHELL,;t t +s,@PATH_SEPARATOR@,$PATH_SEPARATOR,;t t +s,@PACKAGE_NAME@,$PACKAGE_NAME,;t t +s,@PACKAGE_TARNAME@,$PACKAGE_TARNAME,;t t +s,@PACKAGE_VERSION@,$PACKAGE_VERSION,;t t +s,@PACKAGE_STRING@,$PACKAGE_STRING,;t t +s,@PACKAGE_BUGREPORT@,$PACKAGE_BUGREPORT,;t t +s,@exec_prefix@,$exec_prefix,;t t +s,@prefix@,$prefix,;t t +s,@program_transform_name@,$program_transform_name,;t t +s,@bindir@,$bindir,;t t +s,@sbindir@,$sbindir,;t t +s,@libexecdir@,$libexecdir,;t t +s,@datadir@,$datadir,;t t +s,@sysconfdir@,$sysconfdir,;t t +s,@sharedstatedir@,$sharedstatedir,;t t +s,@localstatedir@,$localstatedir,;t t +s,@libdir@,$libdir,;t t +s,@includedir@,$includedir,;t t +s,@oldincludedir@,$oldincludedir,;t t +s,@infodir@,$infodir,;t t +s,@mandir@,$mandir,;t t +s,@build_alias@,$build_alias,;t t +s,@host_alias@,$host_alias,;t t +s,@target_alias@,$target_alias,;t t +s,@DEFS@,$DEFS,;t t +s,@ECHO_C@,$ECHO_C,;t t +s,@ECHO_N@,$ECHO_N,;t t +s,@ECHO_T@,$ECHO_T,;t t +s,@LIBS@,$LIBS,;t t +s,@CC@,$CC,;t t +s,@CFLAGS@,$CFLAGS,;t t +s,@LDFLAGS@,$LDFLAGS,;t t +s,@CPPFLAGS@,$CPPFLAGS,;t t +s,@ac_ct_CC@,$ac_ct_CC,;t t +s,@EXEEXT@,$EXEEXT,;t t +s,@OBJEXT@,$OBJEXT,;t t +s,@CPP@,$CPP,;t t +s,@EGREP@,$EGREP,;t t +s,@AR@,$AR,;t t +s,@ac_ct_AR@,$ac_ct_AR,;t t +s,@RANLIB@,$RANLIB,;t t +s,@ac_ct_RANLIB@,$ac_ct_RANLIB,;t t +s,@RC@,$RC,;t t +s,@ac_ct_RC@,$ac_ct_RC,;t t +s,@SET_MAKE@,$SET_MAKE,;t t +s,@TCL_THREADS@,$TCL_THREADS,;t t +s,@CYGPATH@,$CYGPATH,;t t +s,@CELIB_DIR@,$CELIB_DIR,;t t +s,@DL_LIBS@,$DL_LIBS,;t t +s,@CFLAGS_DEBUG@,$CFLAGS_DEBUG,;t t +s,@CFLAGS_OPTIMIZE@,$CFLAGS_OPTIMIZE,;t t +s,@CFLAGS_WARNING@,$CFLAGS_WARNING,;t t +s,@ZLIB_DLL_FILE@,$ZLIB_DLL_FILE,;t t +s,@ZLIB_LIBS@,$ZLIB_LIBS,;t t +s,@ZLIB_OBJS@,$ZLIB_OBJS,;t t +s,@CFLAGS_DEFAULT@,$CFLAGS_DEFAULT,;t t +s,@LDFLAGS_DEFAULT@,$LDFLAGS_DEFAULT,;t t +s,@VC_MANIFEST_EMBED_DLL@,$VC_MANIFEST_EMBED_DLL,;t t +s,@VC_MANIFEST_EMBED_EXE@,$VC_MANIFEST_EMBED_EXE,;t t +s,@TCL_WIN_VERSION@,$TCL_WIN_VERSION,;t t +s,@MACHINE@,$MACHINE,;t t +s,@TCL_VERSION@,$TCL_VERSION,;t t +s,@TCL_MAJOR_VERSION@,$TCL_MAJOR_VERSION,;t t +s,@TCL_MINOR_VERSION@,$TCL_MINOR_VERSION,;t t +s,@TCL_PATCH_LEVEL@,$TCL_PATCH_LEVEL,;t t +s,@PKG_CFG_ARGS@,$PKG_CFG_ARGS,;t t +s,@TCL_EXE@,$TCL_EXE,;t t +s,@TCL_LIB_FILE@,$TCL_LIB_FILE,;t t +s,@TCL_LIB_FLAG@,$TCL_LIB_FLAG,;t t +s,@TCL_STATIC_LIB_FILE@,$TCL_STATIC_LIB_FILE,;t t +s,@TCL_STATIC_LIB_FLAG@,$TCL_STATIC_LIB_FLAG,;t t +s,@TCL_IMPORT_LIB_FILE@,$TCL_IMPORT_LIB_FILE,;t t +s,@TCL_IMPORT_LIB_FLAG@,$TCL_IMPORT_LIB_FLAG,;t t +s,@TCL_LIB_SPEC@,$TCL_LIB_SPEC,;t t +s,@TCL_STUB_LIB_FILE@,$TCL_STUB_LIB_FILE,;t t +s,@TCL_STUB_LIB_FLAG@,$TCL_STUB_LIB_FLAG,;t t +s,@TCL_STUB_LIB_SPEC@,$TCL_STUB_LIB_SPEC,;t t +s,@TCL_STUB_LIB_PATH@,$TCL_STUB_LIB_PATH,;t t +s,@TCL_INCLUDE_SPEC@,$TCL_INCLUDE_SPEC,;t t +s,@TCL_BUILD_STUB_LIB_SPEC@,$TCL_BUILD_STUB_LIB_SPEC,;t t +s,@TCL_BUILD_STUB_LIB_PATH@,$TCL_BUILD_STUB_LIB_PATH,;t t +s,@TCL_DLL_FILE@,$TCL_DLL_FILE,;t t +s,@TCL_SRC_DIR@,$TCL_SRC_DIR,;t t +s,@TCL_BIN_DIR@,$TCL_BIN_DIR,;t t +s,@TCL_DBGX@,$TCL_DBGX,;t t +s,@CFG_TCL_SHARED_LIB_SUFFIX@,$CFG_TCL_SHARED_LIB_SUFFIX,;t t +s,@CFG_TCL_UNSHARED_LIB_SUFFIX@,$CFG_TCL_UNSHARED_LIB_SUFFIX,;t t +s,@CFG_TCL_EXPORT_FILE_SUFFIX@,$CFG_TCL_EXPORT_FILE_SUFFIX,;t t +s,@EXTRA_CFLAGS@,$EXTRA_CFLAGS,;t t +s,@DEPARG@,$DEPARG,;t t +s,@CC_OBJNAME@,$CC_OBJNAME,;t t +s,@CC_EXENAME@,$CC_EXENAME,;t t +s,@LDFLAGS_DEBUG@,$LDFLAGS_DEBUG,;t t +s,@LDFLAGS_OPTIMIZE@,$LDFLAGS_OPTIMIZE,;t t +s,@LDFLAGS_CONSOLE@,$LDFLAGS_CONSOLE,;t t +s,@LDFLAGS_WINDOW@,$LDFLAGS_WINDOW,;t t +s,@STLIB_LD@,$STLIB_LD,;t t +s,@SHLIB_LD@,$SHLIB_LD,;t t +s,@SHLIB_LD_LIBS@,$SHLIB_LD_LIBS,;t t +s,@SHLIB_CFLAGS@,$SHLIB_CFLAGS,;t t +s,@SHLIB_SUFFIX@,$SHLIB_SUFFIX,;t t +s,@TCL_SHARED_BUILD@,$TCL_SHARED_BUILD,;t t +s,@LIBS_GUI@,$LIBS_GUI,;t t +s,@DLLSUFFIX@,$DLLSUFFIX,;t t +s,@LIBPREFIX@,$LIBPREFIX,;t t +s,@LIBSUFFIX@,$LIBSUFFIX,;t t +s,@EXESUFFIX@,$EXESUFFIX,;t t +s,@LIBRARIES@,$LIBRARIES,;t t +s,@MAKE_LIB@,$MAKE_LIB,;t t +s,@MAKE_STUB_LIB@,$MAKE_STUB_LIB,;t t +s,@POST_MAKE_LIB@,$POST_MAKE_LIB,;t t +s,@MAKE_DLL@,$MAKE_DLL,;t t +s,@MAKE_EXE@,$MAKE_EXE,;t t +s,@TCL_BUILD_LIB_SPEC@,$TCL_BUILD_LIB_SPEC,;t t +s,@TCL_CC_SEARCH_FLAGS@,$TCL_CC_SEARCH_FLAGS,;t t +s,@TCL_LD_SEARCH_FLAGS@,$TCL_LD_SEARCH_FLAGS,;t t +s,@TCL_NEEDS_EXP_FILE@,$TCL_NEEDS_EXP_FILE,;t t +s,@TCL_BUILD_EXP_FILE@,$TCL_BUILD_EXP_FILE,;t t +s,@TCL_EXP_FILE@,$TCL_EXP_FILE,;t t +s,@TCL_LIB_VERSIONS_OK@,$TCL_LIB_VERSIONS_OK,;t t +s,@TCL_PACKAGE_PATH@,$TCL_PACKAGE_PATH,;t t +s,@TCL_DDE_VERSION@,$TCL_DDE_VERSION,;t t +s,@TCL_DDE_MAJOR_VERSION@,$TCL_DDE_MAJOR_VERSION,;t t +s,@TCL_DDE_MINOR_VERSION@,$TCL_DDE_MINOR_VERSION,;t t +s,@TCL_REG_VERSION@,$TCL_REG_VERSION,;t t +s,@TCL_REG_MAJOR_VERSION@,$TCL_REG_MAJOR_VERSION,;t t +s,@TCL_REG_MINOR_VERSION@,$TCL_REG_MINOR_VERSION,;t t +s,@RC_OUT@,$RC_OUT,;t t +s,@RC_TYPE@,$RC_TYPE,;t t +s,@RC_INCLUDE@,$RC_INCLUDE,;t t +s,@RC_DEFINE@,$RC_DEFINE,;t t +s,@RC_DEFINES@,$RC_DEFINES,;t t +s,@RES@,$RES,;t t +s,@LIBOBJS@,$LIBOBJS,;t t +s,@LTLIBOBJS@,$LTLIBOBJS,;t t +CEOF + +_ACEOF + + cat >>$CONFIG_STATUS <<\_ACEOF + # Split the substitutions into bite-sized pieces for seds with + # small command number limits, like on Digital OSF/1 and HP-UX. + ac_max_sed_lines=48 + ac_sed_frag=1 # Number of current file. + ac_beg=1 # First line for current file. + ac_end=$ac_max_sed_lines # Line after last line for current file. + ac_more_lines=: + ac_sed_cmds= + while $ac_more_lines; do + if test $ac_beg -gt 1; then + sed "1,${ac_beg}d; ${ac_end}q" $tmp/subs.sed >$tmp/subs.frag + else + sed "${ac_end}q" $tmp/subs.sed >$tmp/subs.frag + fi + if test ! -s $tmp/subs.frag; then + ac_more_lines=false + else + # The purpose of the label and of the branching condition is to + # speed up the sed processing (if there are no `@' at all, there + # is no need to browse any of the substitutions). + # These are the two extra sed commands mentioned above. + (echo ':t + /@[a-zA-Z_][a-zA-Z_0-9]*@/!b' && cat $tmp/subs.frag) >$tmp/subs-$ac_sed_frag.sed + if test -z "$ac_sed_cmds"; then + ac_sed_cmds="sed -f $tmp/subs-$ac_sed_frag.sed" + else + ac_sed_cmds="$ac_sed_cmds | sed -f $tmp/subs-$ac_sed_frag.sed" + fi + ac_sed_frag=`expr $ac_sed_frag + 1` + ac_beg=$ac_end + ac_end=`expr $ac_end + $ac_max_sed_lines` + fi + done + if test -z "$ac_sed_cmds"; then + ac_sed_cmds=cat + fi fi # test -n "$CONFIG_FILES" - -eval set X " :F $CONFIG_FILES " -shift -for ac_tag -do - case $ac_tag in - :[FHLC]) ac_mode=$ac_tag; continue;; - esac - case $ac_mode$ac_tag in - :[FHL]*:*);; - :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; - :[FH]-) ac_tag=-:-;; - :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; - esac - ac_save_IFS=$IFS - IFS=: - set x $ac_tag - IFS=$ac_save_IFS - shift - ac_file=$1 - shift - - case $ac_mode in - :L) ac_source=$1;; - :[FH]) - ac_file_inputs= - for ac_f - do - case $ac_f in - -) ac_f="$ac_tmp/stdin";; - *) # Look for the file first in the build tree, then in the source tree - # (if the path is not absolute). The absolute path cannot be DOS-style, - # because $ac_f cannot contain `:'. - test -f "$ac_f" || - case $ac_f in - [\\/$]*) false;; - *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; - esac || - as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; - esac - case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac - as_fn_append ac_file_inputs " '$ac_f'" - done - - # Let's still pretend it is `configure' which instantiates (i.e., don't - # use $as_me), people would be surprised to read: - # /* config.h. Generated by config.status. */ - configure_input='Generated from '` - $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' - `' by configure.' - if test x"$ac_file" != x-; then - configure_input="$ac_file. $configure_input" - { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 -$as_echo "$as_me: creating $ac_file" >&6;} - fi - # Neutralize special characters interpreted by sed in replacement strings. - case $configure_input in #( - *\&* | *\|* | *\\* ) - ac_sed_conf_input=`$as_echo "$configure_input" | - sed 's/[\\\\&|]/\\\\&/g'`;; #( - *) ac_sed_conf_input=$configure_input;; - esac - - case $ac_tag in - *:-:* | *:-) cat >"$ac_tmp/stdin" \ - || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; - esac - ;; - esac - - ac_dir=`$as_dirname -- "$ac_file" || +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF +for ac_file in : $CONFIG_FILES; do test "x$ac_file" = x: && continue + # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in". + case $ac_file in + - | *:- | *:-:* ) # input from stdin + cat >$tmp/stdin + ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'` + ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; + *:* ) ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'` + ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; + * ) ac_file_in=$ac_file.in ;; + esac + + # Compute @srcdir@, @top_srcdir@, and @INSTALL@ for subdirectories. + ac_dir=`(dirname "$ac_file") 2>/dev/null || $as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$ac_file" : 'X\(//\)[^/]' \| \ X"$ac_file" : 'X\(//\)$' \| \ - X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X"$ac_file" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - as_dir="$ac_dir"; as_fn_mkdir_p + X"$ac_file" : 'X\(/\)' \| \ + . : '\(.\)' 2>/dev/null || +echo X"$ac_file" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } + /^X\(\/\/\)[^/].*/{ s//\1/; q; } + /^X\(\/\/\)$/{ s//\1/; q; } + /^X\(\/\).*/{ s//\1/; q; } + s/.*/./; q'` + { if $as_mkdir_p; then + mkdir -p "$ac_dir" + else + as_dir="$ac_dir" + as_dirs= + while test ! -d "$as_dir"; do + as_dirs="$as_dir $as_dirs" + as_dir=`(dirname "$as_dir") 2>/dev/null || +$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_dir" : 'X\(//\)[^/]' \| \ + X"$as_dir" : 'X\(//\)$' \| \ + X"$as_dir" : 'X\(/\)' \| \ + . : '\(.\)' 2>/dev/null || +echo X"$as_dir" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } + /^X\(\/\/\)[^/].*/{ s//\1/; q; } + /^X\(\/\/\)$/{ s//\1/; q; } + /^X\(\/\).*/{ s//\1/; q; } + s/.*/./; q'` + done + test ! -n "$as_dirs" || mkdir $as_dirs + fi || { { echo "$as_me:$LINENO: error: cannot create directory \"$ac_dir\"" >&5 +echo "$as_me: error: cannot create directory \"$ac_dir\"" >&2;} + { (exit 1); exit 1; }; }; } + ac_builddir=. -case "$ac_dir" in -.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; -*) - ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` - # A ".." for each directory in $ac_dir_suffix. - ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` - case $ac_top_builddir_sub in - "") ac_top_builddir_sub=. ac_top_build_prefix= ;; - *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; - esac ;; -esac -ac_abs_top_builddir=$ac_pwd -ac_abs_builddir=$ac_pwd$ac_dir_suffix -# for backward compatibility: -ac_top_builddir=$ac_top_build_prefix +if test "$ac_dir" != .; then + ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'` + # A "../" for each directory in $ac_dir_suffix. + ac_top_builddir=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,../,g'` +else + ac_dir_suffix= ac_top_builddir= +fi case $srcdir in - .) # We are building in place. - ac_srcdir=. - ac_top_srcdir=$ac_top_builddir_sub - ac_abs_top_srcdir=$ac_pwd ;; - [\\/]* | ?:[\\/]* ) # Absolute name. - ac_srcdir=$srcdir$ac_dir_suffix; - ac_top_srcdir=$srcdir - ac_abs_top_srcdir=$srcdir ;; - *) # Relative name. - ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix - ac_top_srcdir=$ac_top_build_prefix$srcdir - ac_abs_top_srcdir=$ac_pwd/$srcdir ;; -esac -ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix - - - case $ac_mode in - :F) - # - # CONFIG_FILE - # - -_ACEOF - -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -# If the template does not know about datarootdir, expand it. -# FIXME: This hack should be removed a few years after 2.60. -ac_datarootdir_hack=; ac_datarootdir_seen= -ac_sed_dataroot=' -/datarootdir/ { - p - q -} -/@datadir@/p -/@docdir@/p -/@infodir@/p -/@localedir@/p -/@mandir@/p' -case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in -*datarootdir*) ac_datarootdir_seen=yes;; -*@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 -$as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} -_ACEOF -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 - ac_datarootdir_hack=' - s&@datadir@&$datadir&g - s&@docdir@&$docdir&g - s&@infodir@&$infodir&g - s&@localedir@&$localedir&g - s&@mandir@&$mandir&g - s&\\\${datarootdir}&$datarootdir&g' ;; -esac -_ACEOF - -# Neutralize VPATH when `$srcdir' = `.'. -# Shell code in configure.ac might set extrasub. -# FIXME: do we really want to maintain this feature? -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -ac_sed_extra="$ac_vpsub + .) # No --srcdir option. We are building in place. + ac_srcdir=. + if test -z "$ac_top_builddir"; then + ac_top_srcdir=. + else + ac_top_srcdir=`echo $ac_top_builddir | sed 's,/$,,'` + fi ;; + [\\/]* | ?:[\\/]* ) # Absolute path. + ac_srcdir=$srcdir$ac_dir_suffix; + ac_top_srcdir=$srcdir ;; + *) # Relative path. + ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix + ac_top_srcdir=$ac_top_builddir$srcdir ;; +esac + +# Do not use `cd foo && pwd` to compute absolute paths, because +# the directories may not exist. +case `pwd` in +.) ac_abs_builddir="$ac_dir";; +*) + case "$ac_dir" in + .) ac_abs_builddir=`pwd`;; + [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";; + *) ac_abs_builddir=`pwd`/"$ac_dir";; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_top_builddir=${ac_top_builddir}.;; +*) + case ${ac_top_builddir}. in + .) ac_abs_top_builddir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;; + *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_srcdir=$ac_srcdir;; +*) + case $ac_srcdir in + .) ac_abs_srcdir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;; + *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_top_srcdir=$ac_top_srcdir;; +*) + case $ac_top_srcdir in + .) ac_abs_top_srcdir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;; + *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;; + esac;; +esac + + + + if test x"$ac_file" != x-; then + { echo "$as_me:$LINENO: creating $ac_file" >&5 +echo "$as_me: creating $ac_file" >&6;} + rm -f "$ac_file" + fi + # Let's still pretend it is `configure' which instantiates (i.e., don't + # use $as_me), people would be surprised to read: + # /* config.h. Generated by config.status. */ + if test x"$ac_file" = x-; then + configure_input= + else + configure_input="$ac_file. " + fi + configure_input=$configure_input"Generated from `echo $ac_file_in | + sed 's,.*/,,'` by configure." + + # First look for the input files in the build tree, otherwise in the + # src tree. + ac_file_inputs=`IFS=: + for f in $ac_file_in; do + case $f in + -) echo $tmp/stdin ;; + [\\/$]*) + # Absolute (can't be DOS-style, as IFS=:) + test -f "$f" || { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 +echo "$as_me: error: cannot find input file: $f" >&2;} + { (exit 1); exit 1; }; } + echo "$f";; + *) # Relative + if test -f "$f"; then + # Build tree + echo "$f" + elif test -f "$srcdir/$f"; then + # Source tree + echo "$srcdir/$f" + else + # /dev/null tree + { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 +echo "$as_me: error: cannot find input file: $f" >&2;} + { (exit 1); exit 1; }; } + fi;; + esac + done` || { (exit 1); exit 1; } +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF + sed "$ac_vpsub $extrasub _ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +cat >>$CONFIG_STATUS <<\_ACEOF :t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b -s|@configure_input@|$ac_sed_conf_input|;t t -s&@top_builddir@&$ac_top_builddir_sub&;t t -s&@top_build_prefix@&$ac_top_build_prefix&;t t -s&@srcdir@&$ac_srcdir&;t t -s&@abs_srcdir@&$ac_abs_srcdir&;t t -s&@top_srcdir@&$ac_top_srcdir&;t t -s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t -s&@builddir@&$ac_builddir&;t t -s&@abs_builddir@&$ac_abs_builddir&;t t -s&@abs_top_builddir@&$ac_abs_top_builddir&;t t -$ac_datarootdir_hack -" -eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ - >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 - -test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && - { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && - { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ - "$ac_tmp/out"`; test -z "$ac_out"; } && - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' -which seems to be undefined. Please make sure it is defined" >&5 -$as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' -which seems to be undefined. Please make sure it is defined" >&2;} - - rm -f "$ac_tmp/stdin" - case $ac_file in - -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; - *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; - esac \ - || as_fn_error $? "could not create $ac_file" "$LINENO" 5 - ;; - - - - esac - -done # for ac_tag - - -as_fn_exit 0 -_ACEOF -ac_clean_files=$ac_clean_files_save - -test $ac_write_fail = 0 || - as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 +s,@configure_input@,$configure_input,;t t +s,@srcdir@,$ac_srcdir,;t t +s,@abs_srcdir@,$ac_abs_srcdir,;t t +s,@top_srcdir@,$ac_top_srcdir,;t t +s,@abs_top_srcdir@,$ac_abs_top_srcdir,;t t +s,@builddir@,$ac_builddir,;t t +s,@abs_builddir@,$ac_abs_builddir,;t t +s,@top_builddir@,$ac_top_builddir,;t t +s,@abs_top_builddir@,$ac_abs_top_builddir,;t t +" $ac_file_inputs | (eval "$ac_sed_cmds") >$tmp/out + rm -f $tmp/stdin + if test x"$ac_file" != x-; then + mv $tmp/out $ac_file + else + cat $tmp/out + rm -f $tmp/out + fi + +done +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF + +{ (exit 0); exit 0; } +_ACEOF +chmod +x $CONFIG_STATUS +ac_clean_files=$ac_clean_files_save # configure is writing to config.log, and then calls config.status. # config.status does its own redirection, appending to config.log. # Unfortunately, on DOS this fails, as config.log is still kept open @@ -6541,13 +6241,9 @@ exec 5>/dev/null $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false exec 5>>config.log # Use ||, not &&, to avoid exiting from the if with $? = 1, which # would make configure fail if this is the last instruction. - $ac_cs_success || as_fn_exit 1 -fi -if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 -$as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} + $ac_cs_success || { (exit 1); exit 1; } fi DELETED win/configure.ac Index: win/configure.ac ================================================================== --- win/configure.ac +++ /dev/null @@ -1,507 +0,0 @@ -#! /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(../generic/tcl.h) -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.0 -TCL_MAJOR_VERSION=9 -TCL_MINOR_VERSION=0 -TCL_PATCH_LEVEL="a0" -VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION - -TCL_DDE_VERSION=1.4 -TCL_DDE_MAJOR_VERSION=1 -TCL_DDE_MINOR_VERSION=4 -DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION - -TCL_REG_VERSION=1.3 -TCL_REG_MAJOR_VERSION=1 -TCL_REG_MINOR_VERSION=3 -REGVER=$TCL_REG_MAJOR_VERSION$TCL_REG_MINOR_VERSION - -PKG_CFG_ARGS=$@ - -#------------------------------------------------------------------------ -# Empty slate for bundled packages, to avoid stale configuration -#------------------------------------------------------------------------ -rm -Rf pkgs - -#------------------------------------------------------------------------ -# Handle the --prefix=... option -#------------------------------------------------------------------------ - -if test "${prefix}" = "NONE"; then - prefix=/usr/local -fi -if test "${exec_prefix}" = "NONE"; then - exec_prefix=$prefix -fi -# libdir must be a fully qualified path (not ${exec_prefix}/lib) -eval libdir="$libdir" - -#------------------------------------------------------------------------ -# Standard compiler checks -#------------------------------------------------------------------------ - -# If the user did not set CFLAGS, set it now to keep -# the AC_PROG_CC macro from adding "-g -O2". -if test "${CFLAGS+set}" != "set" ; then - CFLAGS="" -fi - -AC_PROG_CC -AC_C_INLINE -AC_HEADER_STDC - -AC_CHECK_TOOL(AR, ar) -AC_CHECK_TOOL(RANLIB, ranlib) -AC_CHECK_TOOL(RC, windres) - -#-------------------------------------------------------------------- -# Checks to see if the make program sets the $MAKE variable. -#-------------------------------------------------------------------- - -AC_PROG_MAKE_SET - -#-------------------------------------------------------------------- -# Determines the correct binary file extension (.o, .obj, .exe etc.) -#-------------------------------------------------------------------- - -AC_OBJEXT -AC_EXEEXT - -#------------------------------------------------------------------------ -# Embedded configuration information, encoding to use for the values, TIP #59 -#------------------------------------------------------------------------ - -SC_TCL_CFG_ENCODING - -#-------------------------------------------------------------------- -# The statements below define a collection of symbols related to -# building libtcl as a shared library instead of a static library. -#-------------------------------------------------------------------- - -SC_ENABLE_SHARED - -#-------------------------------------------------------------------- -# The statements below define a collection of compile flags. This -# macro depends on the value of SHARED_BUILD, and should be called -# after SC_ENABLE_SHARED checks the configure switches. -#-------------------------------------------------------------------- - -SC_CONFIG_CFLAGS - -# Cross-compiling -case ${host_alias} in -*mingw32*) - TCL_EXE="tclsh" - ;; -*) - TCL_EXE="TCL_LIBRARY=\"\${LIBRARY_DIR}\"; export TCL_LIBRARY; ./\${TCLSH}" - ;; -esac - -#------------------------------------------------------------------------ -# Add stuff for zlib; note that this is mostly done in the makefile now -# as we just assume that the platform hasn't got a usable z.lib -#------------------------------------------------------------------------ - -AS_IF([test "${enable_shared+set}" = "set"], [ - enableval="$enable_shared" - tcl_ok=$enableval -], [ - tcl_ok=yes -]) -AS_IF([test "$tcl_ok" = "yes"], [ - AC_SUBST(ZLIB_DLL_FILE,[\${ZLIB_DLL_FILE}]) - AS_IF([test "$do64bit" != "no"], [ - AS_IF([test "$GCC" == "yes"],[ - AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64/libz.dll.a]) - ], [ - AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64/zdll.lib]) - ]) - ], [ - AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win32/zdll.lib]) - ]) -], [ - AC_SUBST(ZLIB_OBJS,[\${ZLIB_OBJS}]) -]) -AC_DEFINE(HAVE_ZLIB, 1, [Is there an installed zlib?]) - -AC_CHECK_TYPE([intptr_t], [ - AC_DEFINE([HAVE_INTPTR_T], 1, [Do we have the intptr_t type?])], [ - AC_CACHE_CHECK([for pointer-size signed integer type], tcl_cv_intptr_t, [ - for tcl_cv_intptr_t in "int" "long" "long long" none; do - if test "$tcl_cv_intptr_t" != none; then - AC_COMPILE_IFELSE([AC_LANG_BOOL_COMPILE_TRY([AC_INCLUDES_DEFAULT], - [[sizeof (void *) <= sizeof ($tcl_cv_intptr_t)]])], - [tcl_ok=yes], [tcl_ok=no]) - test "$tcl_ok" = yes && break; fi - done]) - if test "$tcl_cv_intptr_t" != none; then - AC_DEFINE_UNQUOTED([intptr_t], [$tcl_cv_intptr_t], [Signed integer - type wide enough to hold a pointer.]) - fi -]) -AC_CHECK_TYPE([uintptr_t], [ - AC_DEFINE([HAVE_UINTPTR_T], 1, [Do we have the uintptr_t type?])], [ - AC_CACHE_CHECK([for pointer-size unsigned integer type], tcl_cv_uintptr_t, [ - for tcl_cv_uintptr_t in "unsigned int" "unsigned long" "unsigned long long" \ - none; do - if test "$tcl_cv_uintptr_t" != none; then - AC_COMPILE_IFELSE([AC_LANG_BOOL_COMPILE_TRY([AC_INCLUDES_DEFAULT], - [[sizeof (void *) <= sizeof ($tcl_cv_uintptr_t)]])], - [tcl_ok=yes], [tcl_ok=no]) - test "$tcl_ok" = yes && break; fi - done]) - if test "$tcl_cv_uintptr_t" != none; then - AC_DEFINE_UNQUOTED([uintptr_t], [$tcl_cv_uintptr_t], [Unsigned integer - type wide enough to hold a pointer.]) - fi -]) - - -#-------------------------------------------------------------------- -# Zipfs support - Tip 430 -#-------------------------------------------------------------------- -AC_ARG_ENABLE(zipfs, - AC_HELP_STRING([--enable-zipfs], - [build with Zipfs support (default: on)]), - [tcl_ok=$enableval], [tcl_ok=yes]) -if test "$tcl_ok" = "yes" ; then - # - # Find a native compiler - # - AX_CC_FOR_BUILD - # - # Find a native zip implementation - # - SC_PROG_TCLSH - SC_ZIPFS_SUPPORT - ZIPFS_BUILD=1 - TCL_ZIP_FILE=libtcl_${TCL_MAJOR_VERSION}_${TCL_MINOR_VERSION}_${TCL_PATCH_LEVEL}.zip -else - ZIPFS_BUILD=0 - TCL_ZIP_FILE= -fi -# Do checking message here to not mess up interleaved configure output -AC_MSG_CHECKING([for building with zipfs]) -if test "${ZIPFS_BUILD}" = 1; then - if test "${SHARED_BUILD}" = 0; then - ZIPFS_BUILD=2; - AC_DEFINE(ZIPFS_BUILD, 2, [Are we building with zipfs enabled?]) - INSTALL_LIBRARIES=install-libraries-zipfs-static - AC_MSG_RESULT([yes]) - else - AC_DEFINE(ZIPFS_BUILD, 1, [Are we building with zipfs enabled?])\ - INSTALL_LIBRARIES=install-libraries-zipfs-shared - AC_MSG_RESULT([yes]) - fi -else -AC_MSG_RESULT([no]) -INSTALL_LIBRARIES=install-libraries -INSTALL_MSGS=install-msgs -fi -AC_SUBST(ZIPFS_BUILD) -AC_SUBST(TCL_ZIP_FILE) -AC_SUBST(INSTALL_LIBRARIES) -AC_SUBST(INSTALL_MSGS) - - -#-------------------------------------------------------------------- -# Perform additinal compiler tests. -#-------------------------------------------------------------------- - -# See if declarations like FINDEX_INFO_LEVELS are -# missing from winbase.h. This is known to be -# a problem with VC++ 5.2. - -AC_CACHE_CHECK(for FINDEX_INFO_LEVELS in winbase.h, - tcl_cv_findex_enums, -AC_TRY_COMPILE([ -#define WIN32_LEAN_AND_MEAN -#include -#undef WIN32_LEAN_AND_MEAN -], -[ - FINDEX_INFO_LEVELS i; - FINDEX_SEARCH_OPS j; -], - tcl_cv_findex_enums=yes, - tcl_cv_findex_enums=no) -) -if test "$tcl_cv_findex_enums" = "no"; then - AC_DEFINE(HAVE_NO_FINDEX_ENUMS, 1, - [Defined when enums are missing from winbase.h]) -fi - -# See if the compiler supports intrinsics. - -AC_CACHE_CHECK(for intrinsics support in compiler, - tcl_cv_intrinsics, -AC_TRY_LINK([ -#define WIN32_LEAN_AND_MEAN -#include -#undef WIN32_LEAN_AND_MEAN -#include -], -[ - __cpuidex(0,0,0); -], - tcl_cv_intrinsics=yes, - tcl_cv_intrinsics=no) -) -if test "$tcl_cv_intrinsics" = "yes"; then - AC_DEFINE(HAVE_INTRIN_H, 1, - [Defined when the compilers supports intrinsics]) -fi - -# See if the header file is present - -AC_CACHE_CHECK(for wspiapi.h, - tcl_cv_wspiapi_h, -AC_TRY_COMPILE([ -#include -], [], - tcl_cv_wspiapi_h=yes, - tcl_cv_wspiapi_h=no) -) -if test "$tcl_cv_wspiapi_h" = "yes"; then - AC_DEFINE(HAVE_WSPIAPI_H, 1, - [Defined when wspiapi.h exists]) -fi - -# See if declarations like FINDEX_INFO_LEVELS are -# missing from winbase.h. This is known to be -# a problem with VC++ 5.2. - -AC_CACHE_CHECK(for FINDEX_INFO_LEVELS in winbase.h, - tcl_cv_findex_enums, -AC_TRY_COMPILE([ -#define WIN32_LEAN_AND_MEAN -#include -#undef WIN32_LEAN_AND_MEAN -], -[ - FINDEX_INFO_LEVELS i; - FINDEX_SEARCH_OPS j; -], - tcl_cv_findex_enums=yes, - tcl_cv_findex_enums=no) -) -if test "$tcl_cv_findex_enums" = "no"; then - AC_DEFINE(HAVE_NO_FINDEX_ENUMS, 1, - [Defined when enums are missing from winbase.h]) -fi - -#-------------------------------------------------------------------- -# Set the default compiler switches based on the --enable-symbols -# option. This macro depends on C flags, and should be called -# after SC_CONFIG_CFLAGS macro is called. -#-------------------------------------------------------------------- - -SC_ENABLE_SYMBOLS - -TCL_DBGX=${DBGX} - -#-------------------------------------------------------------------- -# Embed the manifest if we can determine how -#-------------------------------------------------------------------- - -SC_EMBED_MANIFEST - -#------------------------------------------------------------------------ -# tclConfig.sh refers to this by a different name -#------------------------------------------------------------------------ - -TCL_SHARED_BUILD=${SHARED_BUILD} - -#-------------------------------------------------------------------- -# Perform final evaluations of variables with possible substitutions. -#-------------------------------------------------------------------- - -TCL_SHARED_LIB_SUFFIX="\${NODOT_VERSION}${DLLSUFFIX}" -TCL_UNSHARED_LIB_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}" -TCL_EXPORT_FILE_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}" - -eval "TCL_SRC_DIR=\"`cd $srcdir/..; $CYGPATH $(pwd)`\"" - -eval "TCL_DLL_FILE=tcl${VER}${DLLSUFFIX}" - -eval "TCL_STUB_LIB_FILE=\"${LIBPREFIX}tclstub${VER}${LIBSUFFIX}\"" -eval "TCL_STUB_LIB_FLAG=\"-ltclstub${VER}${LIBFLAGSUFFIX}\"" -eval "TCL_BUILD_STUB_LIB_SPEC=\"-L`$CYGPATH $(pwd)` ${TCL_STUB_LIB_FLAG}\"" -eval "TCL_STUB_LIB_SPEC=\"-L${libdir} ${TCL_STUB_LIB_FLAG}\"" -eval "TCL_BUILD_STUB_LIB_PATH=\"`$CYGPATH $(pwd)`/${TCL_STUB_LIB_FILE}\"" -eval "TCL_STUB_LIB_PATH=\"${libdir}/${TCL_STUB_LIB_FILE}\"" - -eval "TCL_LIB_FILE=\"${LIBPREFIX}tcl${VER}${LIBSUFFIX}\"" -eval "TCL_BUILD_LIB_SPEC=\"-L`$CYGPATH $(pwd)` -ltcl${VER}${FLAGSUFFIX}\"" -eval "TCL_LIB_SPEC=\"-L${libdir} -ltcl${VER}${FLAGSUFFIX}\"" - -# Install time header dir can be set via --includedir -eval "TCL_INCLUDE_SPEC=\"-I${includedir}\"" - - -eval "DLLSUFFIX=${DLLSUFFIX}" -eval "LIBPREFIX=${LIBPREFIX}" -eval "LIBSUFFIX=${LIBSUFFIX}" -eval "EXESUFFIX=${EXESUFFIX}" - -CFG_TCL_SHARED_LIB_SUFFIX=${TCL_SHARED_LIB_SUFFIX} -CFG_TCL_UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX} -CFG_TCL_EXPORT_FILE_SUFFIX=${TCL_EXPORT_FILE_SUFFIX} - -#-------------------------------------------------------------------- -# Adjust the defines for how the resources are built depending -# on symbols and static vs. shared. -#-------------------------------------------------------------------- - -if test ${SHARED_BUILD} = 0 ; then - if test "${DBGX}" = "g"; then - RC_DEFINES="${RC_DEFINE} STATIC_BUILD ${RC_DEFINE} DEBUG" - else - RC_DEFINES="${RC_DEFINE} STATIC_BUILD" - fi -else - if test "${DBGX}" = "g"; then - RC_DEFINES="${RC_DEFINE} DEBUG" - else - RC_DEFINES="" - fi -fi - -#-------------------------------------------------------------------- -# The statements below define the symbol TCL_PACKAGE_PATH, which -# gives a list of directories that may contain packages. The list -# consists of one directory for machine-dependent binaries and -# another for platform-independent scripts. -#-------------------------------------------------------------------- - -if test "$prefix/lib" != "$libdir"; then - TCL_PACKAGE_PATH="${libdir} ${prefix}/lib" -else - TCL_PACKAGE_PATH="${prefix}/lib" -fi - -# The tclsh.exe.manifest requires these -# TCL_WIN_VERSION is the 4 dotted pair Windows version format which needs -# the release level, and must account for interim release versioning -case "$TCL_PATCH_LEVEL" in - *a*) TCL_RELEASE_LEVEL=0 ;; - *b*) TCL_RELEASE_LEVEL=1 ;; - *) TCL_RELEASE_LEVEL=2 ;; -esac -TCL_WIN_VERSION="$TCL_VERSION.$TCL_RELEASE_LEVEL.`echo $TCL_PATCH_LEVEL | tr -d ab.`" -AC_SUBST(TCL_WIN_VERSION) -# X86|AMD64|IA64 for manifest -AC_SUBST(MACHINE) - -AC_SUBST(TCL_VERSION) -AC_SUBST(TCL_MAJOR_VERSION) -AC_SUBST(TCL_MINOR_VERSION) -AC_SUBST(TCL_PATCH_LEVEL) -AC_SUBST(PKG_CFG_ARGS) -AC_SUBST(TCL_EXE) - -AC_SUBST(TCL_LIB_FILE) -AC_SUBST(TCL_LIB_FLAG) -AC_SUBST(TCL_STATIC_LIB_FILE) -AC_SUBST(TCL_STATIC_LIB_FLAG) -AC_SUBST(TCL_IMPORT_LIB_FILE) -AC_SUBST(TCL_IMPORT_LIB_FLAG) -# empty on win -AC_SUBST(TCL_LIB_SPEC) -AC_SUBST(TCL_STUB_LIB_FILE) -AC_SUBST(TCL_STUB_LIB_FLAG) -AC_SUBST(TCL_STUB_LIB_SPEC) -AC_SUBST(TCL_STUB_LIB_PATH) -AC_SUBST(TCL_INCLUDE_SPEC) -AC_SUBST(TCL_BUILD_STUB_LIB_SPEC) -AC_SUBST(TCL_BUILD_STUB_LIB_PATH) -AC_SUBST(TCL_DLL_FILE) - -AC_SUBST(TCL_SRC_DIR) -AC_SUBST(TCL_BIN_DIR) -AC_SUBST(TCL_DBGX) -AC_SUBST(CFG_TCL_SHARED_LIB_SUFFIX) -AC_SUBST(CFG_TCL_UNSHARED_LIB_SUFFIX) -AC_SUBST(CFG_TCL_EXPORT_FILE_SUFFIX) - -# win/tcl.m4 doesn't set (CFLAGS) -AC_SUBST(CFLAGS_DEFAULT) -AC_SUBST(EXTRA_CFLAGS) -AC_SUBST(CYGPATH) -AC_SUBST(DEPARG) -AC_SUBST(CC_OBJNAME) -AC_SUBST(CC_EXENAME) - -# win/tcl.m4 doesn't set (LDFLAGS) -AC_SUBST(LDFLAGS_DEFAULT) -AC_SUBST(LDFLAGS_DEBUG) -AC_SUBST(LDFLAGS_OPTIMIZE) -AC_SUBST(LDFLAGS_CONSOLE) -AC_SUBST(LDFLAGS_WINDOW) -AC_SUBST(AR) -AC_SUBST(RANLIB) - -AC_SUBST(STLIB_LD) -AC_SUBST(SHLIB_LD) -AC_SUBST(SHLIB_LD_LIBS) -AC_SUBST(SHLIB_CFLAGS) -AC_SUBST(SHLIB_SUFFIX) -AC_SUBST(TCL_SHARED_BUILD) - -AC_SUBST(LIBS) -AC_SUBST(LIBS_GUI) -AC_SUBST(DLLSUFFIX) -AC_SUBST(LIBPREFIX) -AC_SUBST(LIBSUFFIX) -AC_SUBST(EXESUFFIX) -AC_SUBST(LIBRARIES) -AC_SUBST(MAKE_LIB) -AC_SUBST(MAKE_STUB_LIB) -AC_SUBST(POST_MAKE_LIB) -AC_SUBST(MAKE_DLL) -AC_SUBST(MAKE_EXE) - -# empty on win, but needs sub'ing -AC_SUBST(TCL_BUILD_LIB_SPEC) -AC_SUBST(TCL_CC_SEARCH_FLAGS) -AC_SUBST(TCL_LD_SEARCH_FLAGS) -AC_SUBST(TCL_NEEDS_EXP_FILE) -AC_SUBST(TCL_BUILD_EXP_FILE) -AC_SUBST(TCL_EXP_FILE) -AC_SUBST(DL_LIBS) -AC_SUBST(TCL_LIB_VERSIONS_OK) -AC_SUBST(TCL_PACKAGE_PATH) - -# win only -AC_SUBST(TCL_DDE_VERSION) -AC_SUBST(TCL_DDE_MAJOR_VERSION) -AC_SUBST(TCL_DDE_MINOR_VERSION) -AC_SUBST(TCL_REG_VERSION) -AC_SUBST(TCL_REG_MAJOR_VERSION) -AC_SUBST(TCL_REG_MINOR_VERSION) - -AC_SUBST(RC) -AC_SUBST(RC_OUT) -AC_SUBST(RC_TYPE) -AC_SUBST(RC_INCLUDE) -AC_SUBST(RC_DEFINE) -AC_SUBST(RC_DEFINES) -AC_SUBST(RES) - -AC_OUTPUT(Makefile tclConfig.sh tcl.hpj tclsh.exe.manifest) - -dnl Local Variables: -dnl mode: autoconf; -dnl End: ADDED win/configure.in Index: win/configure.in ================================================================== --- /dev/null +++ win/configure.in @@ -0,0 +1,482 @@ +#! /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(../generic/tcl.h) +AC_PREREQ(2.59) + +# 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=8.6 +TCL_MAJOR_VERSION=8 +TCL_MINOR_VERSION=6 +TCL_PATCH_LEVEL=".10" +VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION + +TCL_DDE_VERSION=1.4 +TCL_DDE_MAJOR_VERSION=1 +TCL_DDE_MINOR_VERSION=4 +DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION + +TCL_REG_VERSION=1.3 +TCL_REG_MAJOR_VERSION=1 +TCL_REG_MINOR_VERSION=3 +REGVER=$TCL_REG_MAJOR_VERSION$TCL_REG_MINOR_VERSION + +PKG_CFG_ARGS=$@ + +#------------------------------------------------------------------------ +# Empty slate for bundled packages, to avoid stale configuration +#------------------------------------------------------------------------ +rm -Rf pkgs + +#------------------------------------------------------------------------ +# Handle the --prefix=... option +#------------------------------------------------------------------------ + +if test "${prefix}" = "NONE"; then + prefix=/usr/local +fi +if test "${exec_prefix}" = "NONE"; then + exec_prefix=$prefix +fi +# libdir must be a fully qualified path (not ${exec_prefix}/lib) +eval libdir="$libdir" + +#------------------------------------------------------------------------ +# Standard compiler checks +#------------------------------------------------------------------------ + +# If the user did not set CFLAGS, set it now to keep +# the AC_PROG_CC macro from adding "-g -O2". +if test "${CFLAGS+set}" != "set" ; then + CFLAGS="" +fi + +AC_PROG_CC +AC_C_INLINE +AC_HEADER_STDC + +AC_CHECK_TOOL(AR, ar) +AC_CHECK_TOOL(RANLIB, ranlib) +AC_CHECK_TOOL(RC, windres) + +#-------------------------------------------------------------------- +# Checks to see if the make program sets the $MAKE variable. +#-------------------------------------------------------------------- + +AC_PROG_MAKE_SET + +#-------------------------------------------------------------------- +# Determines the correct binary file extension (.o, .obj, .exe etc.) +#-------------------------------------------------------------------- + +AC_OBJEXT +AC_EXEEXT + +#-------------------------------------------------------------------- +# Check whether --enable-threads or --disable-threads was given. +#-------------------------------------------------------------------- + +SC_ENABLE_THREADS + +#------------------------------------------------------------------------ +# Embedded configuration information, encoding to use for the values, TIP #59 +#------------------------------------------------------------------------ + +SC_TCL_CFG_ENCODING + +#-------------------------------------------------------------------- +# The statements below define a collection of symbols related to +# building libtcl as a shared library instead of a static library. +#-------------------------------------------------------------------- + +SC_ENABLE_SHARED + +#-------------------------------------------------------------------- +# Check whether --enable-time64bit was given. +#-------------------------------------------------------------------- + +AC_MSG_CHECKING([force of 64-bit time_t]) +AC_ARG_ENABLE(time64bit, + AC_HELP_STRING([--enable-time64bit], + [force 64-bit time_t for 32-bit build (default: off)]), + [tcl_ok=$enableval], [tcl_ok=no]) +AC_MSG_RESULT("$tcl_ok") +if test "$tcl_ok" = "yes"; then + CFLAGS="${CFLAGS} -D_USE_64BIT_TIME_T" +fi + +#-------------------------------------------------------------------- +# The statements below define a collection of compile flags. This +# macro depends on the value of SHARED_BUILD, and should be called +# after SC_ENABLE_SHARED checks the configure switches. +#-------------------------------------------------------------------- + +SC_CONFIG_CFLAGS + +# Cross-compiling +case ${host_alias} in +*mingw32*) + TCL_EXE="tclsh" + ;; +*) + TCL_EXE="TCL_LIBRARY=\"\${LIBRARY_DIR}\"; export TCL_LIBRARY; ./\${TCLSH}" + ;; +esac + +#------------------------------------------------------------------------ +# Add stuff for zlib; note that this is mostly done in the makefile now +# as we just assume that the platform hasn't got a usable z.lib +#------------------------------------------------------------------------ + +AS_IF([test "${enable_shared+set}" = "set"], [ + enableval="$enable_shared" + tcl_ok=$enableval +], [ + tcl_ok=yes +]) +AS_IF([test "$tcl_ok" = "yes"], [ + AC_SUBST(ZLIB_DLL_FILE,[\${ZLIB_DLL_FILE}]) + AS_IF([test "$do64bit" != "no"], [ + AS_IF([test "$GCC" == "yes"],[ + AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64/libz.dll.a]) + ], [ + AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64/zdll.lib]) + ]) + ], [ + AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win32/zdll.lib]) + ]) +], [ + AC_SUBST(ZLIB_OBJS,[\${ZLIB_OBJS}]) +]) +AC_DEFINE(HAVE_ZLIB, 1, [Is there an installed zlib?]) + +AC_CHECK_TYPE([intptr_t], [ + AC_DEFINE([HAVE_INTPTR_T], 1, [Do we have the intptr_t type?])], [ + AC_CACHE_CHECK([for pointer-size signed integer type], tcl_cv_intptr_t, [ + for tcl_cv_intptr_t in "int" "long" "long long" none; do + if test "$tcl_cv_intptr_t" != none; then + AC_COMPILE_IFELSE([AC_LANG_BOOL_COMPILE_TRY([AC_INCLUDES_DEFAULT], + [[sizeof (void *) <= sizeof ($tcl_cv_intptr_t)]])], + [tcl_ok=yes], [tcl_ok=no]) + test "$tcl_ok" = yes && break; fi + done]) + if test "$tcl_cv_intptr_t" != none; then + AC_DEFINE_UNQUOTED([intptr_t], [$tcl_cv_intptr_t], [Signed integer + type wide enough to hold a pointer.]) + fi +]) +AC_CHECK_TYPE([uintptr_t], [ + AC_DEFINE([HAVE_UINTPTR_T], 1, [Do we have the uintptr_t type?])], [ + AC_CACHE_CHECK([for pointer-size unsigned integer type], tcl_cv_uintptr_t, [ + for tcl_cv_uintptr_t in "unsigned int" "unsigned long" "unsigned long long" \ + none; do + if test "$tcl_cv_uintptr_t" != none; then + AC_COMPILE_IFELSE([AC_LANG_BOOL_COMPILE_TRY([AC_INCLUDES_DEFAULT], + [[sizeof (void *) <= sizeof ($tcl_cv_uintptr_t)]])], + [tcl_ok=yes], [tcl_ok=no]) + test "$tcl_ok" = yes && break; fi + done]) + if test "$tcl_cv_uintptr_t" != none; then + AC_DEFINE_UNQUOTED([uintptr_t], [$tcl_cv_uintptr_t], [Unsigned integer + type wide enough to hold a pointer.]) + fi +]) + +#-------------------------------------------------------------------- +# Perform additinal compiler tests. +#-------------------------------------------------------------------- + +# See if declarations like FINDEX_INFO_LEVELS are +# missing from winbase.h. This is known to be +# a problem with VC++ 5.2. + +AC_CACHE_CHECK(for FINDEX_INFO_LEVELS in winbase.h, + tcl_cv_findex_enums, +AC_TRY_COMPILE([ +#define WIN32_LEAN_AND_MEAN +#include +#undef WIN32_LEAN_AND_MEAN +], +[ + FINDEX_INFO_LEVELS i; + FINDEX_SEARCH_OPS j; +], + tcl_cv_findex_enums=yes, + tcl_cv_findex_enums=no) +) +if test "$tcl_cv_findex_enums" = "no"; then + AC_DEFINE(HAVE_NO_FINDEX_ENUMS, 1, + [Defined when enums are missing from winbase.h]) +fi + +# See if the compiler supports intrinsics. + +AC_CACHE_CHECK(for intrinsics support in compiler, + tcl_cv_intrinsics, +AC_TRY_LINK([ +#define WIN32_LEAN_AND_MEAN +#include +#undef WIN32_LEAN_AND_MEAN +#include +], +[ + __cpuidex(0,0,0); +], + tcl_cv_intrinsics=yes, + tcl_cv_intrinsics=no) +) +if test "$tcl_cv_intrinsics" = "yes"; then + AC_DEFINE(HAVE_INTRIN_H, 1, + [Defined when the compilers supports intrinsics]) +fi + +# See if the header file is present + +AC_CACHE_CHECK(for wspiapi.h, + tcl_cv_wspiapi_h, +AC_TRY_COMPILE([ +#include +], [], + tcl_cv_wspiapi_h=yes, + tcl_cv_wspiapi_h=no) +) +if test "$tcl_cv_wspiapi_h" = "yes"; then + AC_DEFINE(HAVE_WSPIAPI_H, 1, + [Defined when wspiapi.h exists]) +fi + +# See if declarations like FINDEX_INFO_LEVELS are +# missing from winbase.h. This is known to be +# a problem with VC++ 5.2. + +AC_CACHE_CHECK(for FINDEX_INFO_LEVELS in winbase.h, + tcl_cv_findex_enums, +AC_TRY_COMPILE([ +#define WIN32_LEAN_AND_MEAN +#include +#undef WIN32_LEAN_AND_MEAN +], +[ + FINDEX_INFO_LEVELS i; + FINDEX_SEARCH_OPS j; +], + tcl_cv_findex_enums=yes, + tcl_cv_findex_enums=no) +) +if test "$tcl_cv_findex_enums" = "no"; then + AC_DEFINE(HAVE_NO_FINDEX_ENUMS, 1, + [Defined when enums are missing from winbase.h]) +fi + +#-------------------------------------------------------------------- +# Set the default compiler switches based on the --enable-symbols +# option. This macro depends on C flags, and should be called +# after SC_CONFIG_CFLAGS macro is called. +#-------------------------------------------------------------------- + +SC_ENABLE_SYMBOLS + +TCL_DBGX=${DBGX} + +#-------------------------------------------------------------------- +# Embed the manifest if we can determine how +#-------------------------------------------------------------------- + +SC_EMBED_MANIFEST + +#------------------------------------------------------------------------ +# tclConfig.sh refers to this by a different name +#------------------------------------------------------------------------ + +TCL_SHARED_BUILD=${SHARED_BUILD} + +#-------------------------------------------------------------------- +# Perform final evaluations of variables with possible substitutions. +#-------------------------------------------------------------------- + +eval "TCL_SRC_DIR=\"`cd $srcdir/..; $CYGPATH $(pwd)`\"" + +eval "TCL_DLL_FILE=tcl${VER}${DLLSUFFIX}" + +eval "TCL_STUB_LIB_FILE=\"${LIBPREFIX}tclstub${VER}${LIBSUFFIX}\"" +eval "TCL_STUB_LIB_FLAG=\"-ltclstub${VER}${LIBFLAGSUFFIX}\"" +eval "TCL_BUILD_STUB_LIB_SPEC=\"-L`$CYGPATH $(pwd)` ${TCL_STUB_LIB_FLAG}\"" +eval "TCL_STUB_LIB_SPEC=\"-L${libdir} ${TCL_STUB_LIB_FLAG}\"" +eval "TCL_BUILD_STUB_LIB_PATH=\"`$CYGPATH $(pwd)`/${TCL_STUB_LIB_FILE}\"" +eval "TCL_STUB_LIB_PATH=\"${libdir}/${TCL_STUB_LIB_FILE}\"" + +if test ${SHARED_BUILD} = 0 ; then + eval "TCL_LIB_FILE=\"${LIBPREFIX}tcl${VER}${LIBSUFFIX}\"" +else + eval "TCL_LIB_FILE=\"${LIBPREFIX}tcl${VER}${DLLSUFFIX}.a\"" +fi +eval "TCL_BUILD_LIB_SPEC=\"-L`$CYGPATH $(pwd)` -ltcl${VER}${FLAGSUFFIX}\"" +eval "TCL_LIB_SPEC=\"-L${libdir} -ltcl${VER}${FLAGSUFFIX}\"" + +# Install time header dir can be set via --includedir +eval "TCL_INCLUDE_SPEC=\"-I${includedir}\"" + +eval "DLLSUFFIX=${DLLSUFFIX}" +eval "LIBPREFIX=${LIBPREFIX}" +eval "LIBSUFFIX=${LIBSUFFIX}" +eval "EXESUFFIX=${EXESUFFIX}" + +TCL_SHARED_LIB_SUFFIX="\${NODOT_VERSION}${DLLSUFFIX}" +TCL_UNSHARED_LIB_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}" +TCL_EXPORT_FILE_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}" + +CFG_TCL_SHARED_LIB_SUFFIX=${TCL_SHARED_LIB_SUFFIX} +CFG_TCL_UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX} +CFG_TCL_EXPORT_FILE_SUFFIX=${TCL_EXPORT_FILE_SUFFIX} + +#-------------------------------------------------------------------- +# Adjust the defines for how the resources are built depending +# on symbols and static vs. shared. +#-------------------------------------------------------------------- + +if test ${SHARED_BUILD} = 0 ; then + if test "${DBGX}" = "g"; then + RC_DEFINES="${RC_DEFINE} STATIC_BUILD ${RC_DEFINE} DEBUG" + else + RC_DEFINES="${RC_DEFINE} STATIC_BUILD" + fi +else + if test "${DBGX}" = "g"; then + RC_DEFINES="${RC_DEFINE} DEBUG" + else + RC_DEFINES="" + fi +fi + +#-------------------------------------------------------------------- +# The statements below define the symbol TCL_PACKAGE_PATH, which +# gives a list of directories that may contain packages. The list +# consists of one directory for machine-dependent binaries and +# another for platform-independent scripts. +#-------------------------------------------------------------------- + +if test "$prefix/lib" != "$libdir"; then + TCL_PACKAGE_PATH="{${libdir}} {${prefix}/lib}" +else + TCL_PACKAGE_PATH="{${prefix}/lib}" +fi + +# The tclsh.exe.manifest requires these +# TCL_WIN_VERSION is the 4 dotted pair Windows version format which needs +# the release level, and must account for interim release versioning +case "$TCL_PATCH_LEVEL" in + *a*) TCL_RELEASE_LEVEL=0 ;; + *b*) TCL_RELEASE_LEVEL=1 ;; + *) TCL_RELEASE_LEVEL=2 ;; +esac +TCL_WIN_VERSION="$TCL_VERSION.$TCL_RELEASE_LEVEL.`echo $TCL_PATCH_LEVEL | tr -d ab.`" +AC_SUBST(TCL_WIN_VERSION) +# X86|AMD64|IA64 for manifest +AC_SUBST(MACHINE) + +AC_SUBST(TCL_VERSION) +AC_SUBST(TCL_MAJOR_VERSION) +AC_SUBST(TCL_MINOR_VERSION) +AC_SUBST(TCL_PATCH_LEVEL) +AC_SUBST(PKG_CFG_ARGS) +AC_SUBST(TCL_EXE) + +AC_SUBST(TCL_LIB_FILE) +AC_SUBST(TCL_LIB_FLAG) +AC_SUBST(TCL_STATIC_LIB_FILE) +AC_SUBST(TCL_STATIC_LIB_FLAG) +AC_SUBST(TCL_IMPORT_LIB_FILE) +AC_SUBST(TCL_IMPORT_LIB_FLAG) +# empty on win +AC_SUBST(TCL_LIB_SPEC) +AC_SUBST(TCL_STUB_LIB_FILE) +AC_SUBST(TCL_STUB_LIB_FLAG) +AC_SUBST(TCL_STUB_LIB_SPEC) +AC_SUBST(TCL_STUB_LIB_PATH) +AC_SUBST(TCL_INCLUDE_SPEC) +AC_SUBST(TCL_BUILD_STUB_LIB_SPEC) +AC_SUBST(TCL_BUILD_STUB_LIB_PATH) +AC_SUBST(TCL_DLL_FILE) + +AC_SUBST(TCL_SRC_DIR) +AC_SUBST(TCL_BIN_DIR) +AC_SUBST(TCL_DBGX) +AC_SUBST(CFG_TCL_SHARED_LIB_SUFFIX) +AC_SUBST(CFG_TCL_UNSHARED_LIB_SUFFIX) +AC_SUBST(CFG_TCL_EXPORT_FILE_SUFFIX) + +# win/tcl.m4 doesn't set (CFLAGS) +AC_SUBST(CFLAGS_DEFAULT) +AC_SUBST(EXTRA_CFLAGS) +AC_SUBST(CYGPATH) +AC_SUBST(DEPARG) +AC_SUBST(CC_OBJNAME) +AC_SUBST(CC_EXENAME) + +# win/tcl.m4 doesn't set (LDFLAGS) +AC_SUBST(LDFLAGS_DEFAULT) +AC_SUBST(LDFLAGS_DEBUG) +AC_SUBST(LDFLAGS_OPTIMIZE) +AC_SUBST(LDFLAGS_CONSOLE) +AC_SUBST(LDFLAGS_WINDOW) +AC_SUBST(AR) +AC_SUBST(RANLIB) + +AC_SUBST(STLIB_LD) +AC_SUBST(SHLIB_LD) +AC_SUBST(SHLIB_LD_LIBS) +AC_SUBST(SHLIB_CFLAGS) +AC_SUBST(SHLIB_SUFFIX) +AC_SUBST(TCL_SHARED_BUILD) + +AC_SUBST(LIBS) +AC_SUBST(LIBS_GUI) +AC_SUBST(DLLSUFFIX) +AC_SUBST(LIBPREFIX) +AC_SUBST(LIBSUFFIX) +AC_SUBST(EXESUFFIX) +AC_SUBST(LIBRARIES) +AC_SUBST(MAKE_LIB) +AC_SUBST(MAKE_STUB_LIB) +AC_SUBST(POST_MAKE_LIB) +AC_SUBST(MAKE_DLL) +AC_SUBST(MAKE_EXE) + +# empty on win, but needs sub'ing +AC_SUBST(TCL_BUILD_LIB_SPEC) +AC_SUBST(TCL_CC_SEARCH_FLAGS) +AC_SUBST(TCL_LD_SEARCH_FLAGS) +AC_SUBST(TCL_NEEDS_EXP_FILE) +AC_SUBST(TCL_BUILD_EXP_FILE) +AC_SUBST(TCL_EXP_FILE) +AC_SUBST(DL_LIBS) +AC_SUBST(TCL_LIB_VERSIONS_OK) +AC_SUBST(TCL_PACKAGE_PATH) + +# win only +AC_SUBST(TCL_DDE_VERSION) +AC_SUBST(TCL_DDE_MAJOR_VERSION) +AC_SUBST(TCL_DDE_MINOR_VERSION) +AC_SUBST(TCL_REG_VERSION) +AC_SUBST(TCL_REG_MAJOR_VERSION) +AC_SUBST(TCL_REG_MINOR_VERSION) + +AC_SUBST(RC) +AC_SUBST(RC_OUT) +AC_SUBST(RC_TYPE) +AC_SUBST(RC_INCLUDE) +AC_SUBST(RC_DEFINE) +AC_SUBST(RC_DEFINES) +AC_SUBST(RES) + +AC_OUTPUT(Makefile tclConfig.sh tcl.hpj tclsh.exe.manifest) + +dnl Local Variables: +dnl mode: autoconf; +dnl End: Index: win/makefile.vc ================================================================== --- win/makefile.vc +++ win/makefile.vc @@ -14,11 +14,11 @@ #------------------------------------------------------------------------------ # General usage: # nmake [-nologo] -f makefile.vc [TARGET|MACRODEF [TARGET|MACRODEF] [...]] # -# For MACRODEF, see TIP 477 (https://core.tcl.tk/tips/doc/trunk/tip/477.md) +# For MACRODEF, see TIP 477 (https://core.tcl-lang.org/tips/doc/trunk/tip/477.md) # or examine Sections 6-8 in rules.vc. # # Possible values of TARGET are: # release -- Builds the core, the shell and the dlls. (default) # dlls -- Just builds the windows extensions @@ -48,10 +48,73 @@ # # NOTE: For older (Visual C++ 6 or the 2003 SDK), to use the Platform # SDK (not expressly needed), run setenv.bat after # vcvars32.bat according to the instructions for it. This can also # turn on the 64-bit compiler, if your SDK has it. +# +# Basic macros and options usable on the commandline (see rules.vc for more info): +# OPTS=msvcrt,nothreads,pdbs,profile,static,staticpkg,symbols,thrdalloc,time64bit,unchecked,utfmax,none +# Sets special options for the core. The default is for none. +# Any combination of the above may be used (comma separated). +# 'none' will over-ride everything to nothing. +# +# msvcrt = Affects the static option only to switch it from +# using libcmt(d) as the C runtime [by default] to +# msvcrt(d). This is useful for static embedding +# support. +# nothreads = Turns off full multithreading support (default on). +# pbds = Produce separate debug symbol files. +# profile = Adds profiling hooks. Map file is assumed. +# static = Builds a static library of the core instead of a +# dll. The shell will be static (and large), as well. +# staticpkg = Affects the static option only to switch +# tclshXX.exe to have the dde and reg extension linked +# inside it. +# symbols = Adds symbols for step debugging. +# thrdalloc = Use the thread allocator (shared global free pool). +# time64bit = Forces a build using 64-bit time_t for 32-bit build +# (CRT library should support this). +# unchecked = Allows a symbols build to not use the debug +# enabled runtime (msvcrt.dll not msvcrtd.dll +# or libcmt.lib not libcmtd.lib). +# utfmax = Forces a build allowing 4-byte UTF-8 sequences +# internally. +# +# STATS=compdbg,memdbg,none +# Sets optional memory and bytecode compiler debugging code added +# to the core. The default is for none. Any combination of the +# above may be used (comma separated). 'none' will over-ride +# everything to nothing. +# +# compdbg = Enables byte compilation logging. +# memdbg = Enables the debugging memory allocator. +# +# CHECKS=64bit,fullwarn,nodep,none +# Sets special macros for checking compatibility. +# +# 64bit = Enable 64bit portability warnings (if available) +# fullwarn = Builds with full compiler and link warnings enabled. +# Very verbose. +# nodep = Turns off compatibility macros to ensure the core +# isn't being built with deprecated functions. +# +# MACHINE=(ALPHA|AMD64|IA64|IX86) +# Set the machine type used for the compiler, linker, and +# resource compiler. This hook is needed to tell the tools +# when alternate platforms are requested. IX86 is the default +# when not specified. If the CPU environment variable has been +# set (ie: recent Platform SDK) then MACHINE is set from CPU. +# +# TMP_DIR= +# OUT_DIR= +# Hooks to allow the intermediate and output directories to be +# changed. $(OUT_DIR) is assumed to be +# $(BINROOT)\(Release|Debug) based on if symbols are requested. +# $(TMP_DIR) will de $(OUT_DIR)\ by default. +# +# TESTPAT= +# Reads the tests requested to be run from this file. # # Examples: # c:\tcl_src\win\>nmake -f makefile.vc release # c:\tcl_src\win\>nmake -f makefile.vc test # c:\tcl_src\win\>nmake -f makefile.vc install INSTALLDIR=c:\progra~1\tcl @@ -87,10 +150,13 @@ !if [echo REM = This file is generated from makefile.vc > versions.vc] !endif !if [echo PKG_HTTP_VER = \>> versions.vc] \ && [nmakehlp -V ..\library\http\pkgIndex.tcl http >> versions.vc] !endif +!if [echo PKG_OPT_VER = \>> versions.vc] \ + && [nmakehlp -V ..\library\opt\pkgIndex.tcl opt >> versions.vc] +!endif !if [echo PKG_TCLTEST_VER = \>> versions.vc] \ && [nmakehlp -V ..\library\tcltest\pkgIndex.tcl tcltest >> versions.vc] !endif !if [echo PKG_MSGCAT_VER = \>> versions.vc] \ && [nmakehlp -V ..\library\msgcat\pkgIndex.tcl msgcat >> versions.vc] @@ -121,10 +187,11 @@ TCLDDELIBNAME = $(PROJECT)dde$(DDEVERSION)$(SUFX:t=).$(EXT) TCLDDELIB = $(OUT_DIR)\$(TCLDDELIBNAME) TCLTEST = $(OUT_DIR)\$(PROJECT)test.exe +CAT32 = $(OUT_DIR)\cat32.exe TCLSHOBJS = \ $(TMP_DIR)\tclAppInit.obj \ !if !$(STATIC_BUILD) !if $(TCL_USE_STATIC_PACKAGES) @@ -193,12 +260,12 @@ $(TMP_DIR)\tclIORTrans.obj \ $(TMP_DIR)\tclLink.obj \ $(TMP_DIR)\tclListObj.obj \ $(TMP_DIR)\tclLiteral.obj \ $(TMP_DIR)\tclLoad.obj \ + $(TMP_DIR)\tclMainW.obj \ $(TMP_DIR)\tclMain.obj \ - $(TMP_DIR)\tclMain2.obj \ $(TMP_DIR)\tclNamesp.obj \ $(TMP_DIR)\tclNotify.obj \ $(TMP_DIR)\tclOO.obj \ $(TMP_DIR)\tclOOBasic.obj \ $(TMP_DIR)\tclOOCall.obj \ @@ -215,11 +282,10 @@ $(TMP_DIR)\tclPkg.obj \ $(TMP_DIR)\tclPkgConfig.obj \ $(TMP_DIR)\tclPosixStr.obj \ $(TMP_DIR)\tclPreserve.obj \ $(TMP_DIR)\tclProc.obj \ - $(TMP_DIR)\tclProcess.obj \ $(TMP_DIR)\tclRegexp.obj \ $(TMP_DIR)\tclResolve.obj \ $(TMP_DIR)\tclResult.obj \ $(TMP_DIR)\tclScan.obj \ $(TMP_DIR)\tclStringObj.obj \ @@ -233,11 +299,10 @@ $(TMP_DIR)\tclTomMathInterface.obj \ $(TMP_DIR)\tclTrace.obj \ $(TMP_DIR)\tclUtf.obj \ $(TMP_DIR)\tclUtil.obj \ $(TMP_DIR)\tclVar.obj \ - $(TMP_DIR)\tclZipfs.obj \ $(TMP_DIR)\tclZlib.obj ZLIBOBJS = \ $(TMP_DIR)\adler32.obj \ $(TMP_DIR)\compress.obj \ @@ -250,13 +315,10 @@ $(TMP_DIR)\trees.obj \ $(TMP_DIR)\uncompr.obj \ $(TMP_DIR)\zutil.obj TOMMATHOBJS = \ - $(TMP_DIR)\bn_reverse.obj \ - $(TMP_DIR)\bn_fast_s_mp_mul_digs.obj \ - $(TMP_DIR)\bn_fast_s_mp_sqr.obj \ $(TMP_DIR)\bn_mp_add.obj \ $(TMP_DIR)\bn_mp_add_d.obj \ $(TMP_DIR)\bn_mp_and.obj \ $(TMP_DIR)\bn_mp_clamp.obj \ $(TMP_DIR)\bn_mp_clear.obj \ @@ -271,25 +333,17 @@ $(TMP_DIR)\bn_mp_div_d.obj \ $(TMP_DIR)\bn_mp_div_2.obj \ $(TMP_DIR)\bn_mp_div_2d.obj \ $(TMP_DIR)\bn_mp_div_3.obj \ $(TMP_DIR)\bn_mp_exch.obj \ - $(TMP_DIR)\bn_mp_expt_d.obj \ - $(TMP_DIR)\bn_mp_expt_d_ex.obj \ - $(TMP_DIR)\bn_s_mp_get_bit.obj \ - $(TMP_DIR)\bn_mp_get_int.obj \ - $(TMP_DIR)\bn_mp_get_long.obj \ - $(TMP_DIR)\bn_mp_get_long_long.obj \ + $(TMP_DIR)\bn_mp_expt_u32.obj \ $(TMP_DIR)\bn_mp_grow.obj \ $(TMP_DIR)\bn_mp_init.obj \ $(TMP_DIR)\bn_mp_init_copy.obj \ $(TMP_DIR)\bn_mp_init_multi.obj \ $(TMP_DIR)\bn_mp_init_set.obj \ - $(TMP_DIR)\bn_mp_init_set_int.obj \ $(TMP_DIR)\bn_mp_init_size.obj \ - $(TMP_DIR)\bn_mp_karatsuba_mul.obj \ - $(TMP_DIR)\bn_mp_karatsuba_sqr.obj \ $(TMP_DIR)\bn_mp_lshd.obj \ $(TMP_DIR)\bn_mp_mod.obj \ $(TMP_DIR)\bn_mp_mod_2d.obj \ $(TMP_DIR)\bn_mp_mul.obj \ $(TMP_DIR)\bn_mp_mul_2.obj \ @@ -300,31 +354,33 @@ $(TMP_DIR)\bn_mp_radix_size.obj \ $(TMP_DIR)\bn_mp_radix_smap.obj \ $(TMP_DIR)\bn_mp_read_radix.obj \ $(TMP_DIR)\bn_mp_rshd.obj \ $(TMP_DIR)\bn_mp_set.obj \ - $(TMP_DIR)\bn_mp_set_int.obj \ - $(TMP_DIR)\bn_mp_set_long.obj \ - $(TMP_DIR)\bn_mp_set_long_long.obj \ $(TMP_DIR)\bn_mp_shrink.obj \ $(TMP_DIR)\bn_mp_sqr.obj \ $(TMP_DIR)\bn_mp_sqrt.obj \ $(TMP_DIR)\bn_mp_sub.obj \ $(TMP_DIR)\bn_mp_sub_d.obj \ $(TMP_DIR)\bn_mp_signed_rsh.obj \ - $(TMP_DIR)\bn_mp_to_unsigned_bin.obj \ - $(TMP_DIR)\bn_mp_to_unsigned_bin_n.obj \ - $(TMP_DIR)\bn_mp_toom_mul.obj \ - $(TMP_DIR)\bn_mp_toom_sqr.obj \ - $(TMP_DIR)\bn_mp_toradix_n.obj \ - $(TMP_DIR)\bn_mp_unsigned_bin_size.obj \ + $(TMP_DIR)\bn_mp_to_ubin.obj \ + $(TMP_DIR)\bn_mp_to_radix.obj \ + $(TMP_DIR)\bn_mp_ubin_size.obj \ $(TMP_DIR)\bn_mp_xor.obj \ $(TMP_DIR)\bn_mp_zero.obj \ $(TMP_DIR)\bn_s_mp_add.obj \ + $(TMP_DIR)\bn_s_mp_balance_mul.obj \ + $(TMP_DIR)\bn_s_mp_karatsuba_mul.obj \ + $(TMP_DIR)\bn_s_mp_karatsuba_sqr.obj \ $(TMP_DIR)\bn_s_mp_mul_digs.obj \ + $(TMP_DIR)\bn_s_mp_mul_digs_fast.obj \ + $(TMP_DIR)\bn_s_mp_reverse.obj \ $(TMP_DIR)\bn_s_mp_sqr.obj \ - $(TMP_DIR)\bn_s_mp_sub.obj + $(TMP_DIR)\bn_s_mp_sqr_fast.obj \ + $(TMP_DIR)\bn_s_mp_sub.obj \ + $(TMP_DIR)\bn_s_mp_toom_sqr.obj \ + $(TMP_DIR)\bn_s_mp_toom_mul.obj PLATFORMOBJS = \ $(TMP_DIR)\tclWin32Dll.obj \ $(TMP_DIR)\tclWinChan.obj \ $(TMP_DIR)\tclWinConsole.obj \ @@ -349,22 +405,21 @@ TCLOBJS = $(COREOBJS) $(ZLIBOBJS) $(TOMMATHOBJS) $(PLATFORMOBJS) TCLSTUBOBJS = \ $(TMP_DIR)\tclStubLib.obj \ $(TMP_DIR)\tclTomMathStubLib.obj \ - $(TMP_DIR)\tclOOStubLib.obj \ - $(TMP_DIR)\tclWinPanic.obj + $(TMP_DIR)\tclOOStubLib.obj ### The following paths CANNOT have spaces in them as they appear on ### the left side of implicit rules. TOMMATHDIR = $(ROOT)\libtommath PKGSDIR = $(ROOT)\pkgs # Additional include and C macro definitions for the implicit rules # defined in rules.vc PRJ_INCLUDES = -I"$(TOMMATHDIR)" -PRJ_DEFINES = -DTCL_TOMMATH -DMP_PREC=4 -Dinline=__inline -DHAVE_ZLIB=1 -D_CRT_SECURE_NO_DEPRECATE -D_CRT_NONSTDC_NO_DEPRECATE +PRJ_DEFINES = /DTCL_TOMMATH /DMP_PREC=4 /Dinline=__inline /DHAVE_ZLIB=1 /D_CRT_SECURE_NO_DEPRECATE /D_CRT_NONSTDC_NO_DEPRECATE /DMP_FIXED_CUTOFFS # Additional Link libraries needed beyond those in rules.vc PRJ_LIBS = netapi32.lib user32.lib userenv.lib ws2_32.lib #--------------------------------------------------------------------- @@ -382,27 +437,27 @@ release: setup $(TCLSH) $(TCLSTUBLIB) dlls pkgs core: setup $(TCLLIB) $(TCLSTUBLIB) shell: setup $(TCLSH) dlls: setup $(TCLREGLIB) $(TCLDDELIB) -all: setup $(TCLSH) $(TCLSTUBLIB) dlls pkgs -tcltest: setup $(TCLTEST) dlls +all: setup $(TCLSH) $(TCLSTUBLIB) dlls $(CAT32) pkgs +tcltest: setup $(TCLTEST) dlls $(CAT32) install: install-binaries install-libraries install-docs install-pkgs !if $(SYMBOLS) install: install-pdbs !endif setup: default-setup test: test-core test-pkgs -test-core: setup $(TCLTEST) dlls +test-core: setup $(TCLTEST) dlls $(CAT32) set TCL_LIBRARY=$(ROOT:\=/)/library $(DEBUGGER) $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << - package ifneeded dde 1.4.1 [list load "$(TCLDDELIB:\=/)" dde] - package ifneeded registry 1.3.3 [list load "$(TCLREGLIB:\=/)" registry] + package ifneeded dde 1.4.3 [list load "$(TCLDDELIB:\=/)" Dde] + package ifneeded registry 1.3.5 [list load "$(TCLREGLIB:\=/)" Registry] << -runtest: setup $(TCLTEST) dlls +runtest: setup $(TCLTEST) dlls $(CAT32) set TCL_LIBRARY=$(ROOT:\=/)/library $(DEBUGGER) $(TCLTEST) $(SCRIPT) runshell: setup $(TCLSH) dlls set TCL_LIBRARY=$(ROOT:\=/)/library @@ -485,10 +540,16 @@ @if exist "%~fd\win\makefile.vc" ( \ pushd "%~fd\win" & \ $(MAKE) -$(MAKEFLAGS) -f makefile.vc TCLDIR=$(ROOT) clean &\ popd \ ) + +$(CAT32): $(WIN_DIR)\cat.c + $(cc32) $(cflags) $(crt) /D_CRT_NONSTDC_NO_DEPRECATE /DCONSOLE \ + /DUNICODE /D_UNICODE -Fo$(TMP_DIR)\ $? + $(CONEXECMD) -stack:16384 $(TMP_DIR)\cat.obj + $(_VC_MANIFEST_EMBED_EXE) #--------------------------------------------------------------------- # Regenerate the stubs files. [Development use only] #--------------------------------------------------------------------- @@ -579,22 +640,22 @@ tcl-nmake: $(OUT_DIR)\tcl.nmake $(OUT_DIR)\tcl.nmake: @type << >$@ CORE_MACHINE = $(MACHINE) CORE_DEBUG = $(DEBUG) +CORE_TCL_THREADS = $(TCL_THREADS) CORE_USE_THREAD_ALLOC = $(USE_THREAD_ALLOC) -CORE_USE_WIDECHAR_API = $(USE_WIDECHAR_API) << #--------------------------------------------------------------------- # Build tclConfig.sh for the TEA build system. #--------------------------------------------------------------------- tclConfig: $(OUT_DIR)\tclConfig.sh # TBD - is this tclConfig.sh file ever used? The values are incorrect! -$(OUT_DIR)\tclConfig.sh: $(WINDIR)\tclConfig.sh.in +$(OUT_DIR)\tclConfig.sh: $(WIN_DIR)\tclConfig.sh.in @echo Creating tclConfig.sh @nmakehlp -s << $** >$@ @TCL_DLL_FILE@ $(TCLLIBNAME) @TCL_VERSION@ $(DOTVERSION) @TCL_MAJOR_VERSION@ $(TCL_MAJOR_VERSION) @@ -634,10 +695,11 @@ @TCL_SRC_DIR@ $(ROOT) @TCL_PACKAGE_PATH@ @TCL_STUB_LIB_FILE@ $(TCLSTUBLIBNAME) @TCL_STUB_LIB_FLAG@ $(TCLSTUBLIBNAME) @TCL_STUB_LIB_SPEC@ -L$(LIB_INSTALL_DIR) $(TCLSTUBLIBNAME) +@TCL_THREADS@ $(TCL_THREADS) @TCL_BUILD_STUB_LIB_SPEC@ -L$(OUT_DIR) $(TCLSTUBLIBNAME) @TCL_BUILD_STUB_LIB_PATH@ $(TCLSTUBLIB) @TCL_STUB_LIB_PATH@ $(LIB_INSTALL_DIR)\$(TCLSTUBLIBNAME) @CFG_TCL_EXPORT_FILE_SUFFIX@ $(VERSION)$(SUFX).lib @CFG_TCL_SHARED_LIB_SUFFIX@ $(VERSION)$(SUFX).dll @@ -665,71 +727,59 @@ #--------------------------------------------------------------------- # Special case object file targets #--------------------------------------------------------------------- -$(TMP_DIR)\testMain.obj: $(WINDIR)\tclAppInit.c - $(cc32) $(appcflags) -DTCL_TEST \ - -DTCL_USE_STATIC_PACKAGES=$(TCL_USE_STATIC_PACKAGES) \ +$(TMP_DIR)\testMain.obj: $(WIN_DIR)\tclAppInit.c + $(cc32) $(appcflags) /DTCL_TEST /DUNICODE /D_UNICODE \ + /DTCL_USE_STATIC_PACKAGES=$(TCL_USE_STATIC_PACKAGES) \ -Fo$@ $? -$(TMP_DIR)\tclMain2.obj: $(GENERICDIR)\tclMain.c - $(cc32) $(pkgcflags) -DTCL_ASCII_MAIN \ +$(TMP_DIR)\tclMainW.obj: $(GENERICDIR)\tclMain.c + $(cc32) $(pkgcflags) /DUNICODE /D_UNICODE \ -Fo$@ $? $(TMP_DIR)\tclTest.obj: $(GENERICDIR)\tclTest.c $(cc32) $(appcflags) -Fo$@ $? $(TMP_DIR)\tclTestObj.obj: $(GENERICDIR)\tclTestObj.c $(cc32) $(appcflags) -Fo$@ $? -$(TMP_DIR)\tclWinTest.obj: $(WINDIR)\tclWinTest.c +$(TMP_DIR)\tclWinTest.obj: $(WIN_DIR)\tclWinTest.c $(CCAPPCMD) $? -$(TMP_DIR)\tclZipfs.obj: $(GENERICDIR)\tclZipfs.c - $(cc32) $(pkgcflags) -I$(COMPATDIR)\zlib -I$(COMPATDIR)\zlib\contrib\minizip -Fo$@ $? - $(TMP_DIR)\tclZlib.obj: $(GENERICDIR)\tclZlib.c $(cc32) $(pkgcflags) -I$(COMPATDIR)\zlib -Fo$@ $? $(TMP_DIR)\tclPkgConfig.obj: $(GENERICDIR)\tclPkgConfig.c $(cc32) $(pkgcflags) \ - -DCFG_INSTALL_LIBDIR="\"$(LIB_INSTALL_DIR:\=\\)\"" \ - -DCFG_INSTALL_BINDIR="\"$(BIN_INSTALL_DIR:\=\\)\"" \ - -DCFG_INSTALL_SCRDIR="\"$(SCRIPT_INSTALL_DIR:\=\\)\"" \ - -DCFG_INSTALL_INCDIR="\"$(INCLUDE_INSTALL_DIR:\=\\)\"" \ - -DCFG_INSTALL_DOCDIR="\"$(DOC_INSTALL_DIR:\=\\)\"" \ - -DCFG_RUNTIME_LIBDIR="\"$(LIB_INSTALL_DIR:\=\\)\"" \ - -DCFG_RUNTIME_BINDIR="\"$(BIN_INSTALL_DIR:\=\\)\"" \ - -DCFG_RUNTIME_SCRDIR="\"$(SCRIPT_INSTALL_DIR:\=\\)\"" \ - -DCFG_RUNTIME_INCDIR="\"$(INCLUDE_INSTALL_DIR:\=\\)\"" \ - -DCFG_RUNTIME_DOCDIR="\"$(DOC_INSTALL_DIR:\=\\)\"" \ - -DCFG_RUNTIME_DLLFILE="\"$(CFG_RUNTIME_DLLFILE:\=\\)\"" \ - -DCFG_RUNTIME_ZIPFILE="\"$(CFG_RUNTIME_ZIPFILE:\=\\)\"" \ + /DCFG_INSTALL_LIBDIR="\"$(LIB_INSTALL_DIR:\=\\)\"" \ + /DCFG_INSTALL_BINDIR="\"$(BIN_INSTALL_DIR:\=\\)\"" \ + /DCFG_INSTALL_SCRDIR="\"$(SCRIPT_INSTALL_DIR:\=\\)\"" \ + /DCFG_INSTALL_INCDIR="\"$(INCLUDE_INSTALL_DIR:\=\\)\"" \ + /DCFG_INSTALL_DOCDIR="\"$(DOC_INSTALL_DIR:\=\\)\"" \ + /DCFG_RUNTIME_LIBDIR="\"$(LIB_INSTALL_DIR:\=\\)\"" \ + /DCFG_RUNTIME_BINDIR="\"$(BIN_INSTALL_DIR:\=\\)\"" \ + /DCFG_RUNTIME_SCRDIR="\"$(SCRIPT_INSTALL_DIR:\=\\)\"" \ + /DCFG_RUNTIME_INCDIR="\"$(INCLUDE_INSTALL_DIR:\=\\)\"" \ + /DCFG_RUNTIME_DOCDIR="\"$(DOC_INSTALL_DIR:\=\\)\"" \ -Fo$@ $? -$(TMP_DIR)\tclAppInit.obj: $(WINDIR)\tclAppInit.c - $(cc32) $(appcflags) \ - -DTCL_USE_STATIC_PACKAGES=$(TCL_USE_STATIC_PACKAGES) \ +$(TMP_DIR)\tclAppInit.obj: $(WIN_DIR)\tclAppInit.c + $(cc32) $(appcflags) /DUNICODE /D_UNICODE \ + /DTCL_USE_STATIC_PACKAGES=$(TCL_USE_STATIC_PACKAGES) \ -Fo$@ $? ### The following objects should be built using the stub interfaces - -$(TMP_DIR)\tclWinReg.obj: $(WINDIR)\tclWinReg.c -!if $(STATIC_BUILD) - $(cc32) $(appcflags) -DSTATIC_BUILD -Fo$@ $? -!else - $(cc32) $(appcflags) -DUSE_TCL_STUBS -Fo$@ $? -!endif - - -$(TMP_DIR)\tclWinDde.obj: $(WINDIR)\tclWinDde.c -!if $(STATIC_BUILD) - $(cc32) $(appcflags) -DSTATIC_BUILD -Fo$@ $? -!else - $(cc32) $(appcflags) -DUSE_TCL_STUBS -Fo$@ $? -!endif +### *ALL* extensions need to built with /DTCL_THREADS=1 + +$(TMP_DIR)\tclWinReg.obj: $(WIN_DIR)\tclWinReg.c + $(cc32) $(appcflags) /DUSE_TCL_STUBS -Fo$@ $? + + +$(TMP_DIR)\tclWinDde.obj: $(WIN_DIR)\tclWinDde.c + $(cc32) $(appcflags) /DUSE_TCL_STUBS -Fo$@ $? ### The following objects are part of the stub library and should not ### be built as DLL objects. -Zl is used to avoid a dependency on any ### specific C run-time. @@ -741,14 +791,11 @@ $(cc32) $(stubscflags) -Fo$@ $? $(TMP_DIR)\tclOOStubLib.obj: $(GENERICDIR)\tclOOStubLib.c $(cc32) $(stubscflags) -Fo$@ $? -$(TMP_DIR)\tclWinPanic.obj: $(WINDIR)\tclWinPanic.c - $(cc32) $(stubscflags) -Fo$@ $? - -$(TMP_DIR)\tclsh.exe.manifest: $(WINDIR)\tclsh.exe.manifest.in +$(TMP_DIR)\tclsh.exe.manifest: $(WIN_DIR)\tclsh.exe.manifest.in @nmakehlp -s << $** >$@ @MACHINE@ $(MACHINE:IX86=X86) @TCL_WIN_VERSION@ $(DOTVERSION).0.0 << @@ -763,12 +810,12 @@ depend: !if !exist($(TCLSH)) @echo Build tclsh first! !else $(TCLSH) $(TOOLSDIR:\=/)/mkdepend.tcl -vc32 -out:"$(OUT_DIR)\depend.mk" \ - -passthru:"-DBUILD_tcl $(TCL_INCLUDES) $(PRJ_INCLUDES)" $(GENERICDIR),$$(GENERICDIR) \ - $(COMPATDIR),$$(COMPATDIR) $(TOMMATHDIR),$$(TOMMATHDIR) $(WINDIR),$$(WINDIR) @<< + -passthru:"/DBUILD_tcl $(TCL_INCLUDES) $(PRJ_INCLUDES)" $(GENERICDIR),$$(GENERICDIR) \ + $(COMPATDIR),$$(COMPATDIR) $(TOMMATHDIR),$$(TOMMATHDIR) $(WIN_DIR),$$(WIN_DIR) @<< $(TCLOBJS) << !endif #--------------------------------------------------------------------- @@ -801,11 +848,11 @@ {$(COMPATDIR)\zlib}.c{$(TMP_DIR)}.obj:: $(cc32) $(pkgcflags) -Fo$(TMP_DIR)\ @<< $< << -$(TMP_DIR)\tclsh.res: $(TMP_DIR)\tclsh.exe.manifest $(WINDIR)\tclsh.rc +$(TMP_DIR)\tclsh.res: $(TMP_DIR)\tclsh.exe.manifest $(WIN_DIR)\tclsh.rc #--------------------------------------------------------------------- # Installation. #--------------------------------------------------------------------- @@ -825,26 +872,32 @@ @$(CPY) "$(TCLSTUBLIB)" "$(LIB_INSTALL_DIR)\" install-libraries: tclConfig tcl-nmake install-msgs install-tzdata @if not exist "$(SCRIPT_INSTALL_DIR)" \ $(MKDIR) "$(SCRIPT_INSTALL_DIR)" - @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl9$(NULL)" \ - $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl9" - @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl9\9.0$(NULL)" \ - $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl9\9.0" - @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl9\9.0\platform$(NULL)" \ - $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl9\9.0\platform" + @if not exist "$(SCRIPT_INSTALL_DIR)\opt0.4" \ + $(MKDIR) "$(SCRIPT_INSTALL_DIR)\opt0.4" + @if not exist "$(MODULE_INSTALL_DIR)" \ + $(MKDIR) "$(MODULE_INSTALL_DIR)" + @if not exist "$(MODULE_INSTALL_DIR)\8.4" \ + $(MKDIR) "$(MODULE_INSTALL_DIR)\8.4" + @if not exist "$(MODULE_INSTALL_DIR)\8.4\platform" \ + $(MKDIR) "$(MODULE_INSTALL_DIR)\8.4\platform" + @if not exist "$(MODULE_INSTALL_DIR)\8.5" \ + $(MKDIR) "$(MODULE_INSTALL_DIR)\8.5" + @if not exist "$(MODULE_INSTALL_DIR)\8.6" \ + $(MKDIR) "$(MODULE_INSTALL_DIR)\8.6" + @if not exist "$(LIB_INSTALL_DIR)\nmake" \ + $(MKDIR) "$(LIB_INSTALL_DIR)\nmake" @echo Installing header files @$(CPY) "$(GENERICDIR)\tcl.h" "$(INCLUDE_INSTALL_DIR)\" @$(CPY) "$(GENERICDIR)\tclDecls.h" "$(INCLUDE_INSTALL_DIR)\" @$(CPY) "$(GENERICDIR)\tclOO.h" "$(INCLUDE_INSTALL_DIR)\" @$(CPY) "$(GENERICDIR)\tclOODecls.h" "$(INCLUDE_INSTALL_DIR)\" @$(CPY) "$(GENERICDIR)\tclPlatDecls.h" "$(INCLUDE_INSTALL_DIR)\" @$(CPY) "$(GENERICDIR)\tclTomMath.h" "$(INCLUDE_INSTALL_DIR)\" @$(CPY) "$(GENERICDIR)\tclTomMathDecls.h" "$(INCLUDE_INSTALL_DIR)\" - @$(CPY) "$(TOMMATHDIR)\tommath_class.h" "$(INCLUDE_INSTALL_DIR)\" - @$(CPY) "$(TOMMATHDIR)\tommath_superclass.h" "$(INCLUDE_INSTALL_DIR)\" @echo Installing library files to $(SCRIPT_INSTALL_DIR) @$(CPY) "$(ROOT)\library\history.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\init.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\clock.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\tm.tcl" "$(SCRIPT_INSTALL_DIR)\" @@ -853,33 +906,36 @@ @$(CPY) "$(ROOT)\library\tclIndex" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\package.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\word.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\auto.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(OUT_DIR)\tclConfig.sh" "$(LIB_INSTALL_DIR)\" - @$(CPY) "$(WINDIR)\tclooConfig.sh" "$(LIB_INSTALL_DIR)\" - @$(CPY) "$(WINDIR)\rules.vc" "$(LIB_INSTALL_DIR)\nmake\" - @$(CPY) "$(WINDIR)\targets.vc" "$(LIB_INSTALL_DIR)\nmake\" - @$(CPY) "$(WINDIR)\nmakehlp.c" "$(LIB_INSTALL_DIR)\nmake\" + @$(CPY) "$(WIN_DIR)\tclooConfig.sh" "$(LIB_INSTALL_DIR)\" + @$(CPY) "$(WIN_DIR)\rules.vc" "$(LIB_INSTALL_DIR)\nmake\" + @$(CPY) "$(WIN_DIR)\targets.vc" "$(LIB_INSTALL_DIR)\nmake\" + @$(CPY) "$(WIN_DIR)\nmakehlp.c" "$(LIB_INSTALL_DIR)\nmake\" @$(CPY) "$(OUT_DIR)\tcl.nmake" "$(LIB_INSTALL_DIR)\nmake\" - @echo Installing library opt0.4 directory + @echo Installing package http 1.0 (obsolete) + @$(CPY) "$(ROOT)\library\http1.0\*.tcl" \ + "$(SCRIPT_INSTALL_DIR)\http1.0\" + @echo Installing package opt $(PKG_OPT_VER) @$(CPY) "$(ROOT)\library\opt\*.tcl" \ "$(SCRIPT_INSTALL_DIR)\opt0.4\" @echo Installing package http $(PKG_HTTP_VER) as a Tcl Module @$(COPY) "$(ROOT)\library\http\http.tcl" \ - "$(SCRIPT_INSTALL_DIR)\..\tcl9\9.0\http-$(PKG_HTTP_VER).tm" + "$(MODULE_INSTALL_DIR)\8.6\http-$(PKG_HTTP_VER).tm" @echo Installing package msgcat $(PKG_MSGCAT_VER) as a Tcl Module @$(COPY) "$(ROOT)\library\msgcat\msgcat.tcl" \ - "$(SCRIPT_INSTALL_DIR)\..\tcl9\9.0\msgcat-$(PKG_MSGCAT_VER).tm" + "$(MODULE_INSTALL_DIR)\8.5\msgcat-$(PKG_MSGCAT_VER).tm" @echo Installing package tcltest $(PKG_TCLTEST_VER) as a Tcl Module @$(COPY) "$(ROOT)\library\tcltest\tcltest.tcl" \ - "$(SCRIPT_INSTALL_DIR)\..\tcl9\9.0\tcltest-$(PKG_TCLTEST_VER).tm" + "$(MODULE_INSTALL_DIR)\8.5\tcltest-$(PKG_TCLTEST_VER).tm" @echo Installing package platform $(PKG_PLATFORM_VER) as a Tcl Module @$(COPY) "$(ROOT)\library\platform\platform.tcl" \ - "$(SCRIPT_INSTALL_DIR)\..\tcl9\9.0\platform-$(PKG_PLATFORM_VER).tm" + "$(MODULE_INSTALL_DIR)\8.4\platform-$(PKG_PLATFORM_VER).tm" @echo Installing package platform::shell $(PKG_SHELL_VER) as a Tcl Module @$(COPY) "$(ROOT)\library\platform\shell.tcl" \ - "$(SCRIPT_INSTALL_DIR)\..\tcl9\9.0\platform\shell-$(PKG_SHELL_VER).tm" + "$(MODULE_INSTALL_DIR)\8.4\platform\shell-$(PKG_SHELL_VER).tm" @echo Installing $(TCLDDELIBNAME) !if $(STATIC_BUILD) !if !$(TCL_USE_STATIC_PACKAGES) @$(CPY) "$(TCLDDELIB)" "$(LIB_INSTALL_DIR)\" !endif Index: win/nmakehlp.c ================================================================== --- win/nmakehlp.c +++ win/nmakehlp.c @@ -641,11 +641,11 @@ } fclose(sp); } /* debug: dump the list */ -#ifdef _DEBUG +#ifndef NDEBUG { int n = 0; list_item_t *p = NULL; for (p = substPtr; p != NULL; p = p->nextPtr, ++n) { fprintf(stderr, "% 3d '%s' => '%s'\n", n, p->key, p->value); @@ -706,11 +706,11 @@ QualifyPath( const char *szPath) { char szCwd[MAX_PATH + 1]; - GetFullPathName(szPath, sizeof(szCwd)-1, szCwd, NULL); + GetFullPathName(szPath, sizeof(szCwd)-1, szCwd, NULL); printf("%s\n", szCwd); return 0; } /* Index: win/rules.vc ================================================================== --- win/rules.vc +++ win/rules.vc @@ -4,11 +4,11 @@ # Part of the nmake based build system for Tcl and its extensions. # This file does all the hard work in terms of parsing build options, # compiler switches, defining common targets and macros. The Tcl makefile # directly includes this. Extensions include it via "rules-ext.vc". # -# See TIP 477 (https://core.tcl.tk/tips/doc/trunk/tip/477.md) for +# See TIP 477 (https://core.tcl-lang.org/tips/doc/trunk/tip/477.md) for # detailed documentation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # @@ -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 = 3 +RULES_VERSION_MINOR = 6 # 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 @@ -160,11 +160,11 @@ # The fragment will set the following macros: # ROOT - root of this module sources # COMPATDIR - source directory that holds compatibility sources # DOCDIR - source directory containing documentation files # GENERICDIR - platform-independent source directory -# WINDIR - Windows-specific source directory +# WIN_DIR - Windows-specific source directory # TESTDIR - directory containing test files # TOOLSDIR - directory containing build tools # _TCLDIR - root of the Tcl installation OR the Tcl sources. Not set # when building Tcl itself. # _INSTALLDIR - native form of the installation path. For Tcl @@ -213,21 +213,19 @@ DEMODIR = $(LIBDIR)\demos !else DEMODIR = $(ROOT)\demos !endif !endif # ifndef DEMODIR -# Do NOT enclose WINDIR in a !ifndef because Windows always defines -# WINDIR env var to point to c:\windows! -# TBD - This is a potentially dangerous conflict, rename WINDIR to -# something else -WINDIR = $(ROOT)\win +# Do NOT use WINDIR because it is Windows internal environment +# variable to point to c:\windows! +WIN_DIR = $(ROOT)\win !ifndef RCDIR -!if exist("$(WINDIR)\rc") -RCDIR = $(WINDIR)\rc +!if exist("$(WIN_DIR)\rc") +RCDIR = $(WIN_DIR)\rc !else -RCDIR = $(WINDIR) +RCDIR = $(WIN_DIR) !endif !endif RCDIR = $(RCDIR:/=\) # The target directory where the built packages and binaries will be installed. @@ -302,11 +300,11 @@ # NOTE: we will be resetting _INSTALLDIR to _INSTALLDIR/lib for extensions # later so the \.. accounts for the /lib _TCLDIR = $(_INSTALLDIR)\.. _TCL_H = $(_TCLDIR)\include\tcl.h -!else # exist(...) && ! $(NEED_TCL_SOURCE) +!else # exist(...) && !$(NEED_TCL_SOURCE) !if [echo _TCLDIR = \> nmakehlp.out] \ || [nmakehlp -L generic\tcl.h >> nmakehlp.out] !error *** Could not locate Tcl source directory. !endif @@ -313,11 +311,11 @@ !include nmakehlp.out TCLINSTALL = 0 TCLDIR = $(_TCLDIR) _TCL_H = $(_TCLDIR)\generic\tcl.h -!endif # exist(...) && ! $(NEED_TCL_SOURCE) +!endif # exist(...) && !$(NEED_TCL_SOURCE) !endif # TCLDIR !ifndef _TCL_H MSG =^ @@ -415,13 +413,10 @@ # output directory names. # ARCH - set to IX86 or AMD64 depending on 32- or 64-bit target # NATIVE_ARCH - set to IX86 or AMD64 for the host machine # MACHINE - same as $(ARCH) - legacy # _VC_MANIFEST_EMBED_{DLL,EXE} - commands for embedding a manifest if needed -# CFG_ENCODING - set to an character encoding. -# TBD - this is passed to compiler as TCL_CFGVAL_ENCODING but can't -# see where it is used cc32 = $(CC) # built-in default. link32 = link lib32 = lib rc32 = $(RC) # built-in default. @@ -503,22 +498,18 @@ !if $(VCVERSION) >= 1400 _VC_MANIFEST_EMBED_EXE=if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;1 _VC_MANIFEST_EMBED_DLL=if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;2 !endif -!ifndef CFG_ENCODING -CFG_ENCODING = \"cp1252\" -!endif - ################################################################ # 4. Build the nmakehlp program # This is a helper app we need to overcome nmake's limiting # environment. We will call out to it to get various bits of # information about supported compiler options etc. # # Tcl itself will always use the nmakehlp.c program which is -# in its own source. This is the "master" copy and kept updated. +# in its own source. It will be kept updated there. # # Extensions built against an installed Tcl will use the installed # copy of Tcl's nmakehlp.c if there is one and their own version # otherwise. In the latter case, they would also be using their own # rules.vc. Note that older versions of Tcl do not install nmakehlp.c @@ -537,11 +528,11 @@ !if !$(DOING_TCL) !if $(TCLINSTALL) !if exist("$(_TCLDIR)\lib\nmake\nmakehlp.c") NMAKEHLPC = $(_TCLDIR)\lib\nmake\nmakehlp.c !endif -!else # ! $(TCLINSTALL) +!else # !$(TCLINSTALL) !if exist("$(_TCLDIR)\win\nmakehlp.c") NMAKEHLPC = $(_TCLDIR)\win\nmakehlp.c !endif !endif # $(TCLINSTALL) !endif # !$(DOING_TCL) @@ -684,10 +675,14 @@ # UNCHECKED - 1 -> when doing a debug build with symbols, use the release # C runtime, 0 -> use the debug C runtime. # USE_STUBS - 1 -> compile to use stubs interfaces, 0 -> direct linking # CONFIG_CHECK - 1 -> check current build configuration against Tcl # configuration (ignored for Tcl itself) +# _USE_64BIT_TIME_T - forces a build using 64-bit time_t for 32-bit build +# (CRT library should support this, not needed for Tcl 9.x) +# TCL_UTF_MAX=4 - forces a build allowing 4-byte UTF-8 sequences internally. +# (Not needed for Tcl 9.x) # Further, LINKERFLAGS are modified based on above. # Default values for all the above STATIC_BUILD = 0 TCL_THREADS = 1 @@ -726,25 +721,38 @@ !message *** Doing nomsvcrt MSVCRT = 0 !else !if [nmakehlp -f $(OPTS) "msvcrt"] !message *** Doing msvcrt -MSVCRT = 1 !else -!if !$(STATIC_BUILD) -MSVCRT = 1 -!else +!if $(STATIC_BUILD) MSVCRT = 0 !endif !endif !endif # [nmakehlp -f $(OPTS) "nomsvcrt"] !if [nmakehlp -f $(OPTS) "staticpkg"] && $(STATIC_BUILD) !message *** Doing staticpkg TCL_USE_STATIC_PACKAGES = 1 -!else -TCL_USE_STATIC_PACKAGES = 0 +!endif + +!if [nmakehlp -f $(OPTS) "nothreads"] +!message *** Compile explicitly for non-threaded tcl +TCL_THREADS = 0 +USE_THREAD_ALLOC= 0 +!endif + +!if "$(TCL_MAJOR_VERSION)" == "8" +!if [nmakehlp -f $(OPTS) "time64bit"] +!message *** Force 64-bit time_t +_USE_64BIT_TIME_T = 1 +!endif + +!if [nmakehlp -f $(OPTS) "utfmax"] +!message *** Force allowing 4-byte UTF-8 sequences internally +TCL_UTF_MAX = 4 +!endif !endif # Yes, it's weird that the "symbols" option controls DEBUG and # the "pdbs" option controls SYMBOLS. That's historical. !if [nmakehlp -f $(OPTS) "symbols"] @@ -779,10 +787,16 @@ !endif !if [nmakehlp -f $(OPTS) "loimpact"] !message *** Warning: ignoring option "loimpact" - deprecated on modern Windows. !endif + +# TBD - should get rid of this option +!if [nmakehlp -f $(OPTS) "thrdalloc"] +!message *** Doing thrdalloc +USE_THREAD_ALLOC = 1 +!endif !if [nmakehlp -f $(OPTS) "tclalloc"] USE_THREAD_ALLOC = 0 !endif @@ -962,10 +976,23 @@ !include versions.vc !endif # DOTVERSION VERSION = $(DOTVERSION:.=) !endif # $(DOING_TCL) ... etc. + +# Windows RC files have 3 version components. Ensure this irrespective +# of how many components the package has specified. Basically, ensure +# minimum 4 components by appending 4 0's and then pick out the first 4. +# Also take care of the fact that DOTVERSION may have "a" or "b" instead +# of "." separating the version components. +DOTSEPARATED=$(DOTVERSION:a=.) +DOTSEPARATED=$(DOTSEPARATED:b=.) +!if [echo RCCOMMAVERSION = \> versions.vc] \ + || [for /f "tokens=1,2,3,4,5* delims=." %a in ("$(DOTSEPARATED).0.0.0.0") do echo %a,%b,%c,%d >> versions.vc] +!error *** Could not generate RCCOMMAVERSION *** +!endif +!include versions.vc ################################################################ # 10. Construct output directory and file paths # Figure-out how to name our intermediate and output directories. # In order to avoid inadvertent mixing of object files built using @@ -1007,11 +1034,11 @@ !endif !if $(VCVER) > 6 BUILDDIRTOP =$(BUILDDIRTOP)_VC$(VCVER) !endif -!if !$(DEBUG) || $(DEBUG) && $(UNCHECKED) +!if !$(DEBUG) || $(TCL_VERSION) > 86 || $(DEBUG) && $(UNCHECKED) SUFX = $(SUFX:g=) !endif TMP_DIRFULL = .\$(BUILDDIRTOP)\$(PROJECT)_ThreadedDynamicStaticX @@ -1069,13 +1096,13 @@ TCLLIBNAME = $(PROJECT)$(VERSION)$(SUFX).$(EXT) TCLLIB = $(OUT_DIR)\$(TCLLIBNAME) TCLSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib TCLSTUBLIB = $(OUT_DIR)\$(TCLSTUBLIBNAME) -TCL_INCLUDES = -I"$(WINDIR)" -I"$(GENERICDIR)" +TCL_INCLUDES = -I"$(WIN_DIR)" -I"$(GENERICDIR)" -!else # ! $(DOING_TCL) +!else # !$(DOING_TCL) !if $(TCLINSTALL) # Building against an installed Tcl # When building extensions, we need to locate tclsh. Depending on version # of Tcl we are building against, this may or may not have a "t" suffix. @@ -1144,11 +1171,11 @@ !if $(DOING_TK) WISH = $(OUT_DIR)\$(WISHNAME) TKSTUBLIB = $(OUT_DIR)\$(TKSTUBLIBNAME) TKIMPLIB = $(OUT_DIR)\$(TKIMPLIBNAME) TKLIB = $(OUT_DIR)\$(TKLIBNAME) -TK_INCLUDES = -I"$(WINDIR)" -I"$(GENERICDIR)" +TK_INCLUDES = -I"$(WIN_DIR)" -I"$(GENERICDIR)" !else # effectively NEED_TK !if $(TKINSTALL) # Building against installed Tk WISH = $(_TKDIR)\bin\$(WISHNAME) @@ -1177,12 +1204,12 @@ !endif # $(DOING_TK) !endif # $(DOING_TK) || $(NEED_TK) # Various output paths -PRJIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX:t=).lib -PRJLIBNAME = $(PROJECT)$(VERSION)$(SUFX:t=).$(EXT) +PRJIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib +PRJLIBNAME = $(PROJECT)$(VERSION)$(SUFX).$(EXT) PRJLIB = $(OUT_DIR)\$(PRJLIBNAME) PRJSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib PRJSTUBLIB = $(OUT_DIR)\$(PRJSTUBLIBNAME) @@ -1211,10 +1238,11 @@ LIB_INSTALL_DIR = $(_INSTALLDIR)\lib BIN_INSTALL_DIR = $(_INSTALLDIR)\bin DOC_INSTALL_DIR = $(_INSTALLDIR)\doc !if $(DOING_TCL) SCRIPT_INSTALL_DIR = $(_INSTALLDIR)\lib\$(PROJECT)$(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION) +MODULE_INSTALL_DIR = $(_INSTALLDIR)\lib\tcl$(TCL_MAJOR_VERSION) !else # DOING_TK SCRIPT_INSTALL_DIR = $(_INSTALLDIR)\lib\$(PROJECT)$(TK_MAJOR_VERSION).$(TK_MINOR_VERSION) !endif DEMO_INSTALL_DIR = $(SCRIPT_INSTALL_DIR)\demos INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\include @@ -1255,86 +1283,91 @@ # conlflags - complete linker switches for console program (subsumes lflags) # guilflags - complete linker switches for GUI program (subsumes lflags) # baselibs - minimum Windows libraries required. Parent makefile can # define PRJ_LIBS before including rules.rc if additional libs are needed -OPTDEFINES = -DTCL_CFGVAL_ENCODING=$(CFG_ENCODING) -DSTDC_HEADERS +OPTDEFINES = /DSTDC_HEADERS +!if $(VCVERSION) >= 1600 +OPTDEFINES = $(OPTDEFINES) /DHAVE_STDINT_H=1 +!else +OPTDEFINES = $(OPTDEFINES) /DMP_NO_STDINT=1 +!endif +!if $(VCVERSION) >= 1800 +OPTDEFINES = $(OPTDEFINES) /DHAVE_INTTYPES_H=1 /DHAVE_STDBOOL_H=1 +!endif !if $(TCL_MEM_DEBUG) -OPTDEFINES = $(OPTDEFINES) -DTCL_MEM_DEBUG +OPTDEFINES = $(OPTDEFINES) /DTCL_MEM_DEBUG !endif !if $(TCL_COMPILE_DEBUG) -OPTDEFINES = $(OPTDEFINES) -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS +OPTDEFINES = $(OPTDEFINES) /DTCL_COMPILE_DEBUG /DTCL_COMPILE_STATS !endif -!if $(TCL_THREADS) && $(TCL_VERSION) < 86 -OPTDEFINES = $(OPTDEFINES) -DTCL_THREADS=1 -!if $(USE_THREAD_ALLOC) -OPTDEFINES = $(OPTDEFINES) -DUSE_THREAD_ALLOC=1 +!if $(TCL_THREADS) && $(TCL_VERSION) < 87 +OPTDEFINES = $(OPTDEFINES) /DTCL_THREADS=1 +!if $(USE_THREAD_ALLOC) && $(TCL_VERSION) < 87 +OPTDEFINES = $(OPTDEFINES) /DUSE_THREAD_ALLOC=1 !endif !endif !if $(STATIC_BUILD) -OPTDEFINES = $(OPTDEFINES) -DSTATIC_BUILD +OPTDEFINES = $(OPTDEFINES) /DSTATIC_BUILD +!elseif $(TCL_VERSION) > 86 +OPTDEFINES = $(OPTDEFINES) /DTCL_WITH_EXTERNAL_TOMMATH +!if "$(MACHINE)" == "AMD64" +OPTDEFINES = $(OPTDEFINES) /DMP_64BIT +!endif !endif !if $(TCL_NO_DEPRECATED) -OPTDEFINES = $(OPTDEFINES) -DTCL_NO_DEPRECATED +OPTDEFINES = $(OPTDEFINES) /DTCL_NO_DEPRECATED !endif !if $(USE_STUBS) # Note we do not define USE_TCL_STUBS even when building tk since some # test targets in tk do not use stubs -!if ! $(DOING_TCL) -USE_STUBS_DEFS = -DUSE_TCL_STUBS -DUSE_TCLOO_STUBS +!if !$(DOING_TCL) +USE_STUBS_DEFS = /DUSE_TCL_STUBS /DUSE_TCLOO_STUBS !if $(NEED_TK) -USE_STUBS_DEFS = $(USE_STUBS_DEFS) -DUSE_TK_STUBS +USE_STUBS_DEFS = $(USE_STUBS_DEFS) /DUSE_TK_STUBS !endif !endif !endif # USE_STUBS !if !$(DEBUG) -OPTDEFINES = $(OPTDEFINES) -DNDEBUG +OPTDEFINES = $(OPTDEFINES) /DNDEBUG !if $(OPTIMIZING) -OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_OPTIMIZED +OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_OPTIMIZED !endif !endif !if $(PROFILE) -OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_PROFILED +OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_PROFILED !endif !if "$(MACHINE)" == "AMD64" -OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_DO64BIT +OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_DO64BIT !endif !if $(VCVERSION) < 1300 -OPTDEFINES = $(OPTDEFINES) -DNO_STRTOI64 +OPTDEFINES = $(OPTDEFINES) /DNO_STRTOI64=1 +!endif + +!if "$(TCL_MAJOR_VERSION)" == "8" +!if "$(_USE_64BIT_TIME_T)" == "1" +OPTDEFINES = $(OPTDEFINES) /D_USE_64BIT_TIME_T=1 +!endif +!if "$(TCL_UTF_MAX)" == "4" +OPTDEFINES = $(OPTDEFINES) /DTCL_UTF_MAX=4 !endif # _ATL_XP_TARGETING - Newer SDK's need this to build for XP COMPILERFLAGS = /D_ATL_XP_TARGETING - -# Following is primarily for the benefit of extensions. Tcl 8.5 builds -# Tcl without /DUNICODE, while 8.6 builds with it defined. When building -# an extension, it is advisable (but not mandated) to use the same Windows -# API as the Tcl build. This is accordingly defaulted below. A particular -# extension can override this by pre-definining USE_WIDECHAR_API. -!ifndef USE_WIDECHAR_API -!if $(TCL_VERSION) > 85 -USE_WIDECHAR_API = 1 -!else -USE_WIDECHAR_API = 0 -!endif -!endif - -!if $(USE_WIDECHAR_API) -COMPILERFLAGS = $(COMPILERFLAGS) /DUNICODE /D_UNICODE !endif # Like the TEA system only set this non empty for non-Tk extensions # Note: some extensions use PACKAGE_NAME and others use PACKAGE_TCLNAME # so we pass both !if !$(DOING_TCL) && !$(DOING_TK) -PKGNAMEFLAGS = -DPACKAGE_NAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \ - -DPACKAGE_TCLNAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \ - -DPACKAGE_VERSION="\"$(DOTVERSION)\"" \ - -DMODULE_SCOPE=extern +PKGNAMEFLAGS = /DPACKAGE_NAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \ + /DPACKAGE_TCLNAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \ + /DPACKAGE_VERSION="\"$(DOTVERSION)\"" \ + /DMODULE_SCOPE=extern !endif # crt picks the C run time based on selected OPTS !if $(MSVCRT) !if $(DEBUG) && !$(UNCHECKED) @@ -1377,11 +1410,11 @@ cwarn = $(cwarn) -wd4311 -wd4312 !endif ### Common compiler options that are architecture specific !if "$(MACHINE)" == "ARM" -carch = -D_ARM_WINAPI_PARTITION_DESKTOP_SDK_AVAILABLE +carch = /D_ARM_WINAPI_PARTITION_DESKTOP_SDK_AVAILABLE !else carch = !endif !if $(DEBUG) @@ -1389,11 +1422,11 @@ cwarn = $(cwarn) -WX !endif INCLUDES = $(TCL_INCLUDES) $(TK_INCLUDES) $(PRJ_INCLUDES) !if !$(DOING_TCL) && !$(DOING_TK) -INCLUDES = $(INCLUDES) -I"$(GENERICDIR)" -I"$(WINDIR)" -I"$(COMPATDIR)" +INCLUDES = $(INCLUDES) -I"$(GENERICDIR)" -I"$(WIN_DIR)" -I"$(COMPATDIR)" !endif # These flags are defined roughly in the order of the pre-reform # rules.vc/makefile.vc to help visually compare that the pre- and # post-reform build logs @@ -1405,27 +1438,27 @@ # object files (e.g. tclsh, or wish) pkgcflags contains $(cflags) plus # flags used for building shared object files The two differ in the # BUILD_$(PROJECT) macro which should be defined only for the shared # library *implementation* and not for its caller interface -appcflags = $(cflags) $(crt) $(INCLUDES) $(TCL_DEFINES) $(PRJ_DEFINES) $(OPTDEFINES) $(USE_STUBS_DEFS) appcflags_nostubs = $(cflags) $(crt) $(INCLUDES) $(TCL_DEFINES) $(PRJ_DEFINES) $(OPTDEFINES) -pkgcflags = $(appcflags) $(PKGNAMEFLAGS) -DBUILD_$(PROJECT) -pkgcflags_nostubs = $(appcflags_nostubs) $(PKGNAMEFLAGS) -DBUILD_$(PROJECT) +appcflags = $(appcflags_nostubs) $(USE_STUBS_DEFS) +pkgcflags = $(appcflags) $(PKGNAMEFLAGS) /DBUILD_$(PROJECT) +pkgcflags_nostubs = $(appcflags_nostubs) $(PKGNAMEFLAGS) /DBUILD_$(PROJECT) # stubscflags contains $(cflags) plus flags used for building a stubs -# library for the package. Note: -DSTATIC_BUILD is defined in +# library for the package. Note: /DSTATIC_BUILD is defined in # $(OPTDEFINES) only if the OPTS configuration indicates a static # library. However the stubs library is ALWAYS static hence included # here irrespective of the OPTS setting. # # TBD - tclvfs has a comment that stubs libs should not be compiled with -GL # without stating why. Tcl itself compiled stubs libs with this flag. # so we do not remove it from cflags. -GL may prevent extensions # compiled with one VC version to fail to link against stubs library # compiled with another VC version. Check for this and fix accordingly. -stubscflags = $(cflags) $(PKGNAMEFLAGS) $(PRJ_DEFINES) $(OPTDEFINES) -Zl -DSTATIC_BUILD $(INCLUDES) +stubscflags = $(cflags) $(PKGNAMEFLAGS) $(PRJ_DEFINES) $(OPTDEFINES) -Zl /DSTATIC_BUILD $(INCLUDES) $(USE_STUBS_DEFS) # Link flags !if $(DEBUG) ldebug = -debug -debugtype:cv @@ -1445,10 +1478,22 @@ lflags = -nologo -machine:$(MACHINE) $(LINKERFLAGS) $(ldebug) !if $(MSVCRT) && !($(DEBUG) && !$(UNCHECKED)) && $(VCVERSION) >= 1900 lflags = $(lflags) -nodefaultlib:libucrt.lib !endif + +# Old linkers (Visual C++ 6 in particular) will link for fast loading +# on Win98. Since we do not support Win98 any more, we specify nowin98 +# as recommended for NT and later. However, this is only required by +# IX86 on older compilers and only needed if we are not doing a static build. + +!if "$(MACHINE)" == "IX86" && !$(STATIC_BUILD) +!if [nmakehlp -l -opt:nowin98 $(LINKER_TESTFLAGS)] +# Align sections for PE size savings. +lflags = $(lflags) -opt:nowin98 +!endif +!endif dlllflags = $(lflags) -dll conlflags = $(lflags) -subsystem:console guilflags = $(lflags) -subsystem:windows @@ -1486,17 +1531,17 @@ CONEXECMD = $(link32) $(conlflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs) GUIEXECMD = $(link32) $(guilflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs) RESCMD = $(rc32) -fo $@ -r -i "$(GENERICDIR)" -i "$(TMP_DIR)" \ $(TCL_INCLUDES) \ - -DDEBUG=$(DEBUG) -d UNCHECKED=$(UNCHECKED) \ - -DCOMMAVERSION=$(DOTVERSION:.=,),0 \ - -DDOTVERSION=\"$(DOTVERSION)\" \ - -DVERSION=\"$(VERSION)\" \ - -DSUFX=\"$(SUFX:t=)\" \ - -DPROJECT=\"$(PROJECT)\" \ - -DPRJLIBNAME=\"$(PRJLIBNAME)\" + /DDEBUG=$(DEBUG) -d UNCHECKED=$(UNCHECKED) \ + /DCOMMAVERSION=$(RCCOMMAVERSION) \ + /DDOTVERSION=\"$(DOTVERSION)\" \ + /DVERSION=\"$(VERSION)\" \ + /DSUFX=\"$(SUFX)\" \ + /DPROJECT=\"$(PROJECT)\" \ + /DPRJLIBNAME=\"$(PRJLIBNAME)\" !ifndef DEFAULT_BUILD_TARGET DEFAULT_BUILD_TARGET = $(PROJECT) !endif @@ -1571,24 +1616,24 @@ @if exist $(DEMODIR) $(CPYDIR) "$(DEMODIR)" "$(DEMO_INSTALL_DIR)" default-clean: @echo Cleaning $(TMP_DIR)\* ... @if exist $(TMP_DIR)\nul $(RMDIR) $(TMP_DIR) - @echo Cleaning $(WINDIR)\nmakehlp.obj, nmakehlp.exe ... - @if exist $(WINDIR)\nmakehlp.obj del $(WINDIR)\nmakehlp.obj - @if exist $(WINDIR)\nmakehlp.exe del $(WINDIR)\nmakehlp.exe - @if exist $(WINDIR)\nmakehlp.out del $(WINDIR)\nmakehlp.out - @echo Cleaning $(WINDIR)\nmhlp-out.txt ... - @if exist $(WINDIR)\nmhlp-out.txt del $(WINDIR)\nmhlp-out.txt - @echo Cleaning $(WINDIR)\_junk.pch ... - @if exist $(WINDIR)\_junk.pch del $(WINDIR)\_junk.pch - @echo Cleaning $(WINDIR)\vercl.x, vercl.i ... - @if exist $(WINDIR)\vercl.x del $(WINDIR)\vercl.x - @if exist $(WINDIR)\vercl.i del $(WINDIR)\vercl.i - @echo Cleaning $(WINDIR)\versions.vc, version.vc ... - @if exist $(WINDIR)\versions.vc del $(WINDIR)\versions.vc - @if exist $(WINDIR)\version.vc del $(WINDIR)\version.vc + @echo Cleaning $(WIN_DIR)\nmakehlp.obj, nmakehlp.exe ... + @if exist $(WIN_DIR)\nmakehlp.obj del $(WIN_DIR)\nmakehlp.obj + @if exist $(WIN_DIR)\nmakehlp.exe del $(WIN_DIR)\nmakehlp.exe + @if exist $(WIN_DIR)\nmakehlp.out del $(WIN_DIR)\nmakehlp.out + @echo Cleaning $(WIN_DIR)\nmhlp-out.txt ... + @if exist $(WIN_DIR)\nmhlp-out.txt del $(WIN_DIR)\nmhlp-out.txt + @echo Cleaning $(WIN_DIR)\_junk.pch ... + @if exist $(WIN_DIR)\_junk.pch del $(WIN_DIR)\_junk.pch + @echo Cleaning $(WIN_DIR)\vercl.x, vercl.i ... + @if exist $(WIN_DIR)\vercl.x del $(WIN_DIR)\vercl.x + @if exist $(WIN_DIR)\vercl.i del $(WIN_DIR)\vercl.i + @echo Cleaning $(WIN_DIR)\versions.vc, version.vc ... + @if exist $(WIN_DIR)\versions.vc del $(WIN_DIR)\versions.vc + @if exist $(WIN_DIR)\version.vc del $(WIN_DIR)\version.vc default-hose: default-clean @echo Hosing $(OUT_DIR)\* ... @if exist $(OUT_DIR)\nul $(RMDIR) $(OUT_DIR) @@ -1615,11 +1660,11 @@ # Generation of Windows version resource !ifdef RCFILE # Note: don't use $** in below rule because there may be other dependencies -# and only the "master" rc must be passed to the resource compiler +# and only the "main" rc must be passed to the resource compiler $(TMP_DIR)\$(PROJECT).res: $(RCDIR)\$(PROJECT).rc $(RESCMD) $(RCDIR)\$(PROJECT).rc !else @@ -1669,18 +1714,18 @@ DISABLE_IMPLICIT_RULES = 0 !endif !if !$(DISABLE_IMPLICIT_RULES) # Implicit rule definitions - only for building library objects. For stubs and -# main application, the master makefile should define explicit rules. +# main application, the makefile should define explicit rules. {$(ROOT)}.c{$(TMP_DIR)}.obj:: $(CCPKGCMD) @<< $< << -{$(WINDIR)}.c{$(TMP_DIR)}.obj:: +{$(WIN_DIR)}.c{$(TMP_DIR)}.obj:: $(CCPKGCMD) @<< $< << {$(GENERICDIR)}.c{$(TMP_DIR)}.obj:: @@ -1694,11 +1739,11 @@ << {$(RCDIR)}.rc{$(TMP_DIR)}.res: $(RESCMD) $< -{$(WINDIR)}.rc{$(TMP_DIR)}.res: +{$(WIN_DIR)}.rc{$(TMP_DIR)}.res: $(RESCMD) $< {$(TMP_DIR)}.rc{$(TMP_DIR)}.res: $(RESCMD) $< @@ -1710,17 +1755,17 @@ ################################################################ # 14. Sanity check selected options against Tcl build options # When building an extension, certain configuration options should # match the ones used when Tcl was built. Here we check and # warn on a mismatch. -!if ! $(DOING_TCL) +!if !$(DOING_TCL) !if $(TCLINSTALL) # Building against an installed Tcl !if exist("$(_TCLDIR)\lib\nmake\tcl.nmake") TCLNMAKECONFIG = "$(_TCLDIR)\lib\nmake\tcl.nmake" !endif -!else # ! $(TCLINSTALL) - building against Tcl source +!else # !$(TCLINSTALL) - building against Tcl source !if exist("$(OUT_DIR)\tcl.nmake") TCLNMAKECONFIG = "$(OUT_DIR)\tcl.nmake" !endif !endif # TCLINSTALL @@ -1729,18 +1774,21 @@ !include $(TCLNMAKECONFIG) !if defined(CORE_MACHINE) && "$(CORE_MACHINE)" != "$(MACHINE)" !error ERROR: Build target ($(MACHINE)) does not match the Tcl library architecture ($(CORE_MACHINE)). !endif +!if $(TCL_VERSION) < 87 && defined(CORE_USE_THREAD_ALLOC) && $(CORE_USE_THREAD_ALLOC) != $(USE_THREAD_ALLOC) +!message WARNING: Value of USE_THREAD_ALLOC ($(USE_THREAD_ALLOC)) does not match its Tcl core value ($(CORE_USE_THREAD_ALLOC)). +!endif !if defined(CORE_DEBUG) && $(CORE_DEBUG) != $(DEBUG) !message WARNING: Value of DEBUG ($(DEBUG)) does not match its Tcl library configuration ($(DEBUG)). !endif !endif !endif # TCLNMAKECONFIG -!endif # ! $(DOING_TCL) +!endif # !$(DOING_TCL) #---------------------------------------------------------- # Display stats being used. #---------------------------------------------------------- Index: win/targets.vc ================================================================== --- win/targets.vc +++ win/targets.vc @@ -2,11 +2,11 @@ # targets.vc -- # # Part of the nmake based build system for Tcl and its extensions. # This file defines some standard targets for the convenience of extensions # and can be optionally included by the extension makefile. -# See TIP 477 (https://core.tcl.tk/tips/doc/trunk/tip/477.md) for docs. +# See TIP 477 (https://core.tcl-lang.org/tips/doc/trunk/tip/477.md) for docs. $(PROJECT): setup pkgindex $(PRJLIB) !ifdef PRJ_STUBOBJS $(PROJECT): $(PRJSTUBLIB) Index: win/tcl.dsp ================================================================== --- win/tcl.dsp +++ win/tcl.dsp @@ -34,20 +34,20 @@ # PROP BASE Use_Debug_Libraries 0 # PROP BASE Output_Dir "Release" # PROP BASE Intermediate_Dir "Release\tcl_Dynamic" # PROP BASE Cmd_Line "nmake -nologo -f makefile.vc OPTS=none MSVCDIR=IDE" # PROP BASE Rebuild_Opt "-a" -# PROP BASE Target_File "Release\tclsh90.exe" +# PROP BASE Target_File "Release\tclsh86.exe" # PROP BASE Bsc_Name "" # PROP BASE Target_Dir "" # PROP Use_MFC 0 # PROP Use_Debug_Libraries 0 # PROP Output_Dir "Release" # PROP Intermediate_Dir "Release\tcl_Dynamic" # PROP Cmd_Line "nmake -nologo -f makefile.vc OPTS=threads MSVCDIR=IDE" # PROP Rebuild_Opt "clean release" -# PROP Target_File "Release\tclsh90t.exe" +# PROP Target_File "Release\tclsh86t.exe" # PROP Bsc_Name "" # PROP Target_Dir "" !ELSEIF "$(CFG)" == "tcl - Win32 Debug" @@ -55,20 +55,20 @@ # PROP BASE Use_Debug_Libraries 1 # PROP BASE Output_Dir "Debug" # PROP BASE Intermediate_Dir "Debug\tcl_Dynamic" # PROP BASE Cmd_Line "nmake -nologo -f makefile.vc OPTS=symbols MSVCDIR=IDE" # PROP BASE Rebuild_Opt "-a" -# PROP BASE Target_File "Debug\tclsh90g.exe" +# PROP BASE Target_File "Debug\tclsh86g.exe" # PROP BASE Bsc_Name "" # PROP BASE Target_Dir "" # PROP Use_MFC 0 # PROP Use_Debug_Libraries 1 # PROP Output_Dir "Debug" # PROP Intermediate_Dir "Debug\tcl_Dynamic" # PROP Cmd_Line "nmake -nologo -f makefile.vc OPTS=threads,symbols MSVCDIR=IDE" # PROP Rebuild_Opt "clean release" -# PROP Target_File "Debug\tclsh90tg.exe" +# PROP Target_File "Debug\tclsh86tg.exe" # PROP Bsc_Name "" # PROP Target_Dir "" !ELSEIF "$(CFG)" == "tcl - Win32 Debug Static" @@ -76,20 +76,20 @@ # PROP BASE Use_Debug_Libraries 1 # PROP BASE Output_Dir "Debug" # PROP BASE Intermediate_Dir "Debug\tcl_Static" # PROP BASE Cmd_Line "nmake -nologo -f makefile.vc OPTS=symbols,static MSVCDIR=IDE" # PROP BASE Rebuild_Opt "-a" -# PROP BASE Target_File "Debug\tclsh90sg.exe" +# PROP BASE Target_File "Debug\tclsh86sg.exe" # PROP BASE Bsc_Name "" # PROP BASE Target_Dir "" # PROP Use_MFC 0 # PROP Use_Debug_Libraries 1 # PROP Output_Dir "Debug" # PROP Intermediate_Dir "Debug\tcl_Static" # PROP Cmd_Line "nmake -nologo -f makefile.vc OPTS=symbols,static MSVCDIR=IDE" # PROP Rebuild_Opt "-a" -# PROP Target_File "Debug\tclsh90sg.exe" +# PROP Target_File "Debug\tclsh86sg.exe" # PROP Bsc_Name "" # PROP Target_Dir "" !ELSEIF "$(CFG)" == "tcl - Win32 Release Static" @@ -97,20 +97,20 @@ # PROP BASE Use_Debug_Libraries 0 # PROP BASE Output_Dir "Release" # PROP BASE Intermediate_Dir "Release\tcl_Static" # PROP BASE Cmd_Line "nmake -nologo -f makefile.vc OPTS=static MSVCDIR=IDE" # PROP BASE Rebuild_Opt "-a" -# PROP BASE Target_File "Release\tclsh90s.exe" +# PROP BASE Target_File "Release\tclsh86s.exe" # PROP BASE Bsc_Name "" # PROP BASE Target_Dir "" # PROP Use_MFC 0 # PROP Use_Debug_Libraries 0 # PROP Output_Dir "Release" # PROP Intermediate_Dir "Release\tcl_Static" # PROP Cmd_Line "nmake -nologo -f makefile.vc OPTS=static MSVCDIR=IDE" # PROP Rebuild_Opt "-a" -# PROP Target_File "Release\tclsh90s.exe" +# PROP Target_File "Release\tclsh86s.exe" # PROP Bsc_Name "" # PROP Target_Dir "" !ENDIF @@ -149,10 +149,14 @@ # Begin Source File SOURCE=..\compat\fixstrtod.c # End Source File # Begin Source File + +SOURCE=..\compat\float.h +# End Source File +# Begin Source File SOURCE=..\compat\gettod.c # End Source File # Begin Source File @@ -201,10 +205,14 @@ # Begin Source File SOURCE=..\compat\tclErrno.h # End Source File # Begin Source File + +SOURCE=..\compat\unistd.h +# End Source File +# Begin Source File SOURCE=..\compat\waitpid.c # End Source File # End Group # Begin Group "doc" @@ -354,11 +362,11 @@ SOURCE=..\doc\CrtObjCmd.3 # End Source File # Begin Source File -SOURCE=..\doc\CrtSlave.3 +SOURCE=..\doc\CrtAlias.3 # End Source File # Begin Source File SOURCE=..\doc\CrtTimerHdlr.3 # End Source File @@ -1258,14 +1266,10 @@ SOURCE=..\generic\tclProc.c # End Source File # Begin Source File -SOURCE=..\generic\tclProcess.c -# End Source File -# Begin Source File - SOURCE=..\generic\tclRegexp.c # End Source File # Begin Source File SOURCE=..\generic\tclRegexp.h @@ -1418,11 +1422,11 @@ SOURCE=.\configure # End Source File # Begin Source File -SOURCE=.\configure.ac +SOURCE=.\configure.in # End Source File # Begin Source File SOURCE=.\Makefile.in # End Source File @@ -1520,14 +1524,10 @@ # End Source File # Begin Source File SOURCE=.\tclWinNotify.c # End Source File -# Begin Source File - -SOURCE=.\tclWinPanic.c -# End Source File # Begin Source File SOURCE=.\tclWinPipe.c # End Source File # Begin Source File Index: win/tcl.hpj.in ================================================================== --- win/tcl.hpj.in +++ win/tcl.hpj.in @@ -3,13 +3,13 @@ [OPTIONS] HCW=0 LCID=0x409 0x0 0x0 ;English (United States) REPORT=Yes TITLE=Tcl/Tk Reference Manual -CNT=tcl90.cnt +CNT=tcl86.cnt COPYRIGHT=Copyright © 2000 Ajuba Solutions -HLP=tcl90.hlp +HLP=tcl86.hlp [FILES] tcl.rtf [WINDOWS] Index: win/tcl.m4 ================================================================== --- win/tcl.m4 +++ win/tcl.m4 @@ -249,11 +249,10 @@ # # Substitutes the following vars: # TCL_BIN_DIR # TCL_SRC_DIR # TCL_LIB_FILE -# TCL_ZIP_FILE # #------------------------------------------------------------------------ AC_DEFUN([SC_LOAD_TCLCONFIG], [ AC_MSG_CHECKING([for existence of ${TCL_BIN_DIR}/tclConfig.sh]) @@ -282,11 +281,10 @@ # # eval is required to do the TCL_DBGX substitution # - eval "TCL_ZIP_FILE=\"${TCL_ZIP_FILE}\"" eval "TCL_LIB_FILE=\"${TCL_LIB_FILE}\"" eval "TCL_LIB_FLAG=\"${TCL_LIB_FLAG}\"" eval "TCL_LIB_SPEC=\"${TCL_LIB_SPEC}\"" eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\"" @@ -295,11 +293,10 @@ AC_SUBST(TCL_VERSION) AC_SUBST(TCL_BIN_DIR) AC_SUBST(TCL_SRC_DIR) - AC_SUBST(TCL_ZIP_FILE) AC_SUBST(TCL_LIB_FILE) AC_SUBST(TCL_LIB_FLAG) AC_SUBST(TCL_LIB_SPEC) AC_SUBST(TCL_STUB_LIB_FILE) @@ -381,11 +378,46 @@ else AC_MSG_RESULT([static]) SHARED_BUILD=0 AC_DEFINE(STATIC_BUILD, 1, [Is this a static build?]) fi - AC_SUBST(SHARED_BUILD) +]) + +#------------------------------------------------------------------------ +# SC_ENABLE_THREADS -- +# +# Specify if thread support should be enabled +# +# Arguments: +# none +# +# Results: +# +# Adds the following arguments to configure: +# --enable-threads=yes|no +# +# Defines the following vars: +# TCL_THREADS +#------------------------------------------------------------------------ + +AC_DEFUN([SC_ENABLE_THREADS], [ + AC_MSG_CHECKING(for building with threads) + AC_ARG_ENABLE(threads, [ --enable-threads build with threads (default: on)], + [tcl_ok=$enableval], [tcl_ok=yes]) + + if test "$tcl_ok" = "yes"; then + AC_MSG_RESULT([yes (default)]) + TCL_THREADS=1 + AC_DEFINE(TCL_THREADS) + # USE_THREAD_ALLOC tells us to try the special thread-based + # allocator that significantly reduces lock contention + AC_DEFINE(USE_THREAD_ALLOC) + else + TCL_THREADS=0 + AC_MSG_RESULT(no) + fi + AC_SUBST(TCL_THREADS) ]) #------------------------------------------------------------------------ # SC_ENABLE_SYMBOLS -- # @@ -509,17 +541,27 @@ # Step 0: Enable 64 bit support? AC_MSG_CHECKING([if 64bit support is requested]) AC_ARG_ENABLE(64bit,[ --enable-64bit enable 64bit support (where applicable)], [do64bit=$enableval], [do64bit=no]) AC_MSG_RESULT($do64bit) + + # Cross-compiling options for Windows/CE builds + + AC_MSG_CHECKING([if Windows/CE build is requested]) + AC_ARG_ENABLE(wince,[ --enable-wince enable Win/CE support (where applicable)], [doWince=$enableval], [doWince=no]) + AC_MSG_RESULT($doWince) + + AC_MSG_CHECKING([for Windows/CE celib directory]) + AC_ARG_WITH(celib,[ --with-celib=DIR use Windows/CE support library from DIR], + CELIB_DIR=$withval, CELIB_DIR=NO_CELIB) + AC_MSG_RESULT([$CELIB_DIR]) # Set some defaults (may get changed below) EXTRA_CFLAGS="" AC_DEFINE(MODULE_SCOPE, [extern], [No need to mark inidividual symbols as hidden]) AC_CHECK_PROG(CYGPATH, cygpath, cygpath -m, echo) - AC_CHECK_PROG(WINE, wine, wine,) SHLIB_SUFFIX=".dll" # MACHINE is IX86 for LINK, but this is used by the manifest, # which requires x86|amd64|ia64. @@ -539,18 +581,18 @@ ) if test "$ac_cv_cross" = "yes"; then case "$do64bit" in amd64|x64|yes) - CC="x86_64-w64-mingw32-gcc" + CC="x86_64-w64-mingw32-${CC}" LD="x86_64-w64-mingw32-ld" AR="x86_64-w64-mingw32-ar" RANLIB="x86_64-w64-mingw32-ranlib" RC="x86_64-w64-mingw32-windres" ;; *) - CC="i686-w64-mingw32-gcc" + CC="i686-w64-mingw32-${CC}" LD="i686-w64-mingw32-ld" AR="i686-w64-mingw32-ar" RANLIB="i686-w64-mingw32-ranlib" RC="i686-w64-mingw32-windres" ;; @@ -671,11 +713,11 @@ # Link with gcc since ld does not link to default libs like # -luser32 and -lmsvcrt by default. SHLIB_LD='${CC} -shared' SHLIB_LD_LIBS='${LIBS}' MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -o \[$]@ ${extra_ldflags} \ - -Wl,--out-implib,\$(patsubst %.dll,lib%.a,\[$]@)" + -Wl,--out-implib,\$(patsubst %.dll,lib%.dll.a,\[$]@)" # DLLSUFFIX is separate because it is the building block for # users of tclConfig.sh that may build shared or static. DLLSUFFIX="\${DBGX}.dll" LIBSUFFIX="\${DBGX}.a" LIBFLAGSUFFIX="\${DBGX}" @@ -683,13 +725,22 @@ EXTRA_CFLAGS="${extra_cflags}" CFLAGS_DEBUG=-g CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer" - CFLAGS_WARNING="-Wall -Wwrite-strings -Wsign-compare -Wdeclaration-after-statement -Wpointer-arith" + CFLAGS_WARNING="-Wall -Wpointer-arith" LDFLAGS_DEBUG= LDFLAGS_OPTIMIZE= + + case "${CC}" in + *++) + CFLAGS_WARNING="${CFLAGS_WARNING} -Wno-format" + ;; + *) + CFLAGS_WARNING="${CFLAGS_WARNING} -Wdeclaration-after-statement" + ;; + esac # Specify the CC output file names based on the target name CC_OBJNAME="-o \[$]@" CC_EXENAME="-o \[$]@" @@ -762,32 +813,19 @@ # users of tclConfig.sh that may build shared or static. DLLSUFFIX="\${DBGX}.dll" LIBSUFFIX="\${DBGX}.lib" LIBFLAGSUFFIX="\${DBGX}" - # This is a 2-stage check to make sure we have the 64-bit SDK - # We have to know where the SDK is installed. - # This magic is based on MS Platform SDK for Win2003 SP1 - hobbs if test "$do64bit" != "no" ; then - if test "x${MSSDK}x" = "xx" ; then - MSSDK="C:/Progra~1/Microsoft Platform SDK" - fi - MSSDK=`echo "$MSSDK" | sed -e 's!\\\!/!g'` - PATH64="" case "$do64bit" in amd64|x64|yes) MACHINE="AMD64" ; # assume AMD64 as default 64-bit build - PATH64="${MSSDK}/Bin/Win64/x86/AMD64" ;; ia64) MACHINE="IA64" - PATH64="${MSSDK}/Bin/Win64" ;; esac - if test ! -d "${PATH64}" ; then - AC_MSG_WARN([Could not find 64-bit $MACHINE SDK]) - fi AC_MSG_RESULT([ Using 64-bit $MACHINE mode]) fi LIBS="netapi32.lib kernel32.lib user32.lib advapi32.lib userenv.lib ws2_32.lib" @@ -798,25 +836,16 @@ *) ;; esac if test "$do64bit" != "no" ; then - # The space-based-path will work for the Makefile, but will - # not work if AC_TRY_COMPILE is called. TEA has the - # TEA_PATH_NOSPACE to avoid this issue. - # Check if _WIN64 is already recognized, and if so we don't - # need to modify CC. - AC_CHECK_DECL([_WIN64], [], - [CC="\"${PATH64}/cl.exe\" -I\"${MSSDK}/Include\" \ - -I\"${MSSDK}/Include/crt\" \ - -I\"${MSSDK}/Include/crt/sys\""]) - RC="\"${MSSDK}/bin/rc.exe\"" + RC="rc" CFLAGS_DEBUG="-nologo -Zi -Od ${runtime}d" # Do not use -O2 for Win64 - this has proved buggy in code gen. CFLAGS_OPTIMIZE="-nologo -O1 ${runtime}" - lflags="${lflags} -nologo -MACHINE:${MACHINE} -LIBPATH:\"${MSSDK}/Lib/${MACHINE}\"" - LINKBIN="\"${PATH64}/link.exe\"" + lflags="${lflags} -nologo -MACHINE:${MACHINE}" + LINKBIN="link" # Avoid 'unresolved external symbol __security_cookie' errors. # c.f. http://support.microsoft.com/?id=894573 LIBS="$LIBS bufferoverflowU.lib" else RC="rc" @@ -827,11 +856,102 @@ CFLAGS_OPTIMIZE="-nologo -O2 ${runtime}" lflags="${lflags} -nologo" LINKBIN="link" fi - LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib shell32.lib uuid.lib" + if test "$doWince" != "no" ; then + # Set defaults for common evc4/PPC2003 setup + # Currently Tcl requires 300+, possibly 420+ for sockets + CEVERSION=420; # could be 211 300 301 400 420 ... + TARGETCPU=ARMV4; # could be ARMV4 ARM MIPS SH3 X86 ... + ARCH=ARM; # could be ARM MIPS X86EM ... + PLATFORM="Pocket PC 2003"; # or "Pocket PC 2002" + if test "$doWince" != "yes"; then + # If !yes then the user specified something + # Reset ARCH to allow user to skip specifying it + ARCH= + eval `echo $doWince | awk -F "," '{ \ + if (length([$]1)) { printf "CEVERSION=\"%s\"\n", [$]1; \ + if ([$]1 < 400) { printf "PLATFORM=\"Pocket PC 2002\"\n" } }; \ + if (length([$]2)) { printf "TARGETCPU=\"%s\"\n", toupper([$]2) }; \ + if (length([$]3)) { printf "ARCH=\"%s\"\n", toupper([$]3) }; \ + if (length([$]4)) { printf "PLATFORM=\"%s\"\n", [$]4 }; \ + }'` + if test "x${ARCH}" = "x" ; then + ARCH=$TARGETCPU; + fi + fi + OSVERSION=WCE$CEVERSION; + if test "x${WCEROOT}" = "x" ; then + WCEROOT="C:/Program Files/Microsoft eMbedded C++ 4.0" + if test ! -d "${WCEROOT}" ; then + WCEROOT="C:/Program Files/Microsoft eMbedded Tools" + fi + fi + if test "x${SDKROOT}" = "x" ; then + SDKROOT="C:/Program Files/Windows CE Tools" + if test ! -d "${SDKROOT}" ; then + SDKROOT="C:/Windows CE Tools" + fi + fi + # The space-based-path will work for the Makefile, but will + # not work if AC_TRY_COMPILE is called. + WCEROOT=`echo "$WCEROOT" | sed -e 's!\\\!/!g'` + SDKROOT=`echo "$SDKROOT" | sed -e 's!\\\!/!g'` + CELIB_DIR=`echo "$CELIB_DIR" | sed -e 's!\\\!/!g'` + if test ! -d "${CELIB_DIR}/inc"; then + AC_MSG_ERROR([Invalid celib directory "${CELIB_DIR}"]) + fi + if test ! -d "${SDKROOT}/${OSVERSION}/${PLATFORM}/Lib/${TARGETCPU}"\ + -o ! -d "${WCEROOT}/EVC/${OSVERSION}/bin"; then + AC_MSG_ERROR([could not find PocketPC SDK or target compiler to enable WinCE mode [$CEVERSION,$TARGETCPU,$ARCH,$PLATFORM]]) + else + CEINCLUDE="${SDKROOT}/${OSVERSION}/${PLATFORM}/include" + if test -d "${CEINCLUDE}/${TARGETCPU}" ; then + CEINCLUDE="${CEINCLUDE}/${TARGETCPU}" + fi + CELIBPATH="${SDKROOT}/${OSVERSION}/${PLATFORM}/Lib/${TARGETCPU}" + fi + fi + + if test "$doWince" != "no" ; then + CEBINROOT="${WCEROOT}/EVC/${OSVERSION}/bin" + if test "${TARGETCPU}" = "X86"; then + CC="${CEBINROOT}/cl.exe" + else + CC="${CEBINROOT}/cl${ARCH}.exe" + fi + CC="\"${CC}\" -I\"${CELIB_DIR}/inc\" -I\"${CEINCLUDE}\"" + RC="\"${WCEROOT}/Common/EVC/bin/rc.exe\"" + arch=`echo ${ARCH} | awk '{print tolower([$]0)}'` + defs="${ARCH} _${ARCH}_ ${arch} PALM_SIZE _MT _DLL _WINDOWS" + for i in $defs ; do + AC_DEFINE_UNQUOTED($i) + done +# if test "${ARCH}" = "X86EM"; then +# AC_DEFINE_UNQUOTED(_WIN32_WCE_EMULATION) +# fi + AC_DEFINE_UNQUOTED(_WIN32_WCE, $CEVERSION) + AC_DEFINE_UNQUOTED(UNDER_CE, $CEVERSION) + CFLAGS_DEBUG="-nologo -Zi -Od" + CFLAGS_OPTIMIZE="-nologo -O2" + lversion=`echo ${CEVERSION} | sed -e 's/\(.\)\(..\)/\1\.\2/'` + lflags="-nodefaultlib -MACHINE:${ARCH} -LIBPATH:\"${CELIBPATH}\" -subsystem:windowsce,${lversion} -nologo" + LINKBIN="\"${CEBINROOT}/link.exe\"" + AC_SUBST(CELIB_DIR) + if test "${CEVERSION}" -lt 400 ; then + LIBS="coredll.lib corelibc.lib winsock.lib" + else + LIBS="coredll.lib corelibc.lib ws2.lib" + fi + # celib currently stuck at wce300 status + #LIBS="$LIBS \${CELIB_DIR}/wince-${ARCH}-pocket-${OSVERSION}-release/celib.lib" + LIBS="$LIBS \"\${CELIB_DIR}/wince-${ARCH}-pocket-wce300-release/celib.lib\"" + LIBS_GUI="commctrl.lib commdlg.lib" + else + LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib shell32.lib uuid.lib" + fi SHLIB_LD="${LINKBIN} -dll -incremental:no ${lflags}" SHLIB_LD_LIBS='${LIBS}' # link -lib only works when -lib is the first arg STLIB_LD="${LINKBIN} -lib ${lflags}" @@ -858,11 +978,11 @@ CC_OBJNAME="-Fo\[$]@" CC_EXENAME="-Fe\"\$(shell \$(CYGPATH) '\[$]@')\"" # Specify linker flags depending on the type of app being # built -- Console vs. Window. - if test "${TARGETCPU}" != "X86"; then + if test "$doWince" != "no" -a "${TARGETCPU}" != "X86"; then LDFLAGS_CONSOLE="-link ${lflags}" LDFLAGS_WINDOW=${LDFLAGS_CONSOLE} else LDFLAGS_CONSOLE="-link -subsystem:console ${lflags}" LDFLAGS_WINDOW="-link -subsystem:windows ${lflags}" @@ -991,17 +1111,17 @@ # Defines the following vars: # TCL_BIN_DIR Full path to the tcl build dir. #------------------------------------------------------------------------ AC_DEFUN([SC_WITH_TCL], [ - if test -d ../../tcl9.0$1/win; then - TCL_BIN_DEFAULT=../../tcl9.0$1/win + if test -d ../../tcl8.6$1/win; then + TCL_BIN_DEFAULT=../../tcl8.6$1/win else - TCL_BIN_DEFAULT=../../tcl9.0/win + TCL_BIN_DEFAULT=../../tcl8.6/win fi - AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl 9.0 binaries from DIR], + AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl 8.6 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 @@ -1162,128 +1282,5 @@ fi AC_MSG_RESULT([$result]) AC_SUBST(VC_MANIFEST_EMBED_DLL) AC_SUBST(VC_MANIFEST_EMBED_EXE) ]) - -#------------------------------------------------------------------------ -# SC_CC_FOR_BUILD -# For cross compiles, locate a C compiler that can generate native binaries. -# -# Arguments: -# none -# -# Results: -# Substitutes the following vars: -# CC_FOR_BUILD -# EXEEXT_FOR_BUILD -#------------------------------------------------------------------------ - -dnl Get a default for CC_FOR_BUILD to put into Makefile. -AC_DEFUN([AX_CC_FOR_BUILD], -[# Put a plausible default for CC_FOR_BUILD in Makefile. -if test -z "$CC_FOR_BUILD"; then - if test "x$cross_compiling" = "xno"; then - CC_FOR_BUILD='$(CC)' - else - AC_MSG_CHECKING([for gcc]) - AC_CACHE_VAL(ac_cv_path_cc, [ - search_path=`echo ${PATH} | sed -e 's/:/ /g'` - for dir in $search_path ; do - for j in `ls -r $dir/gcc 2> /dev/null` \ - `ls -r $dir/gcc 2> /dev/null` ; do - if test x"$ac_cv_path_cc" = x ; then - if test -f "$j" ; then - ac_cv_path_cc=$j - break - fi - fi - done - done - ]) - fi -fi -AC_SUBST(CC_FOR_BUILD) -# Also set EXEEXT_FOR_BUILD. -if test "x$cross_compiling" = "xno"; then - EXEEXT_FOR_BUILD='$(EXEEXT)' - OBJEXT_FOR_BUILD='$(OBJEXT)' -else - OBJEXT_FOR_BUILD='.no' - AC_CACHE_CHECK([for build system executable suffix], bfd_cv_build_exeext, - [rm -f conftest* - echo 'int main () { return 0; }' > conftest.c - bfd_cv_build_exeext= - ${CC_FOR_BUILD} -o conftest conftest.c 1>&5 2>&5 - for file in conftest.*; do - case $file in - *.c | *.o | *.obj | *.ilk | *.pdb) ;; - *) bfd_cv_build_exeext=`echo $file | sed -e s/conftest//` ;; - esac - done - rm -f conftest* - test x"${bfd_cv_build_exeext}" = x && bfd_cv_build_exeext=no]) - EXEEXT_FOR_BUILD="" - test x"${bfd_cv_build_exeext}" != xno && EXEEXT_FOR_BUILD=${bfd_cv_build_exeext} -fi -AC_SUBST(EXEEXT_FOR_BUILD)])dnl -AC_SUBST(OBJEXT_FOR_BUILD)])dnl - - - -#------------------------------------------------------------------------ -# SC_ZIPFS_SUPPORT -# Locate a zip encoder installed on the system path, or none. -# -# Arguments: -# none -# -# Results: -# Substitutes the following vars: -# ZIP_PROG -# ZIP_PROG_OPTIONS -# ZIP_PROG_VFSSEARCH -# ZIP_INSTALL_OBJS -#------------------------------------------------------------------------ - -AC_DEFUN([SC_ZIPFS_SUPPORT], [ - ZIP_PROG="" - ZIP_PROG_OPTIONS="" - ZIP_PROG_VFSSEARCH="" - ZIP_INSTALL_OBJS="" - - AC_MSG_CHECKING([for zip]) - AC_CACHE_VAL(ac_cv_path_zip, [ - search_path=`echo ${PATH} | sed -e 's/:/ /g'` - for dir in $search_path ; do - for j in `ls -r $dir/zip 2> /dev/null` \ - `ls -r $dir/zip 2> /dev/null` ; do - if test x"$ac_cv_path_zip" = x ; then - if test -f "$j" ; then - ac_cv_path_zip=$j - break - fi - fi - done - done - ]) - if test -f "$ac_cv_path_zip" ; then - ZIP_PROG="$ac_cv_path_zip" - AC_MSG_RESULT([$ZIP_PROG]) - ZIP_PROG_OPTIONS="-rq" - ZIP_PROG_VFSSEARCH="*" - AC_MSG_RESULT([Found INFO Zip in environment]) - # Use standard arguments for zip - else - # It is not an error if an installed version of Zip can't be located. - # We can use the locally distributed minizip instead - ZIP_PROG="./minizip${EXEEXT_FOR_BUILD}" - ZIP_PROG_OPTIONS="-o -r" - ZIP_PROG_VFSSEARCH="*" - ZIP_INSTALL_OBJS="minizip${EXEEXT_FOR_BUILD}" - AC_MSG_RESULT([No zip found on PATH building minizip]) - fi - AC_SUBST(ZIP_PROG) - AC_SUBST(ZIP_PROG_OPTIONS) - AC_SUBST(ZIP_PROG_VFSSEARCH) - AC_SUBST(ZIP_INSTALL_OBJS) -]) Index: win/tcl.rc ================================================================== --- win/tcl.rc +++ win/tcl.rc @@ -5,17 +5,23 @@ #include // // build-up the name suffix that defines the type of build this is. // +#if TCL_THREADS +#define SUFFIX_THREADS "t" +#else +#define SUFFIX_THREADS "" +#endif + #if DEBUG && !UNCHECKED #define SUFFIX_DEBUG "g" #else #define SUFFIX_DEBUG "" #endif -#define SUFFIX SUFFIX_DEBUG +#define SUFFIX SUFFIX_THREADS SUFFIX_DEBUG LANGUAGE 0x9, 0x1 /* LANG_ENGLISH, SUBLANG_DEFAULT */ VS_VERSION_INFO VERSIONINFO Index: win/tclAppInit.c ================================================================== --- win/tclAppInit.c +++ win/tclAppInit.c @@ -27,11 +27,11 @@ #ifdef TCL_TEST extern Tcl_PackageInitProc Tcltest_Init; extern Tcl_PackageInitProc Tcltest_SafeInit; #endif /* TCL_TEST */ -#if defined(STATIC_BUILD) && TCL_USE_STATIC_PACKAGES +#if defined(STATIC_BUILD) && defined(TCL_USE_STATIC_PACKAGES) && TCL_USE_STATIC_PACKAGES extern Tcl_PackageInitProc Registry_Init; extern Tcl_PackageInitProc Dde_Init; extern Tcl_PackageInitProc Dde_SafeInit; #endif @@ -124,13 +124,10 @@ } } #ifdef TCL_LOCAL_MAIN_HOOK TCL_LOCAL_MAIN_HOOK(&argc, &argv); -#elif !defined(_WIN32) || defined(UNICODE) - /* This doesn't work on Windows without UNICODE */ - TclZipfs_AppHook(&argc, &argv); #endif Tcl_Main(argc, argv, TCL_LOCAL_APPINIT); return 0; /* Needed only to prevent compiler warning. */ } @@ -160,20 +157,20 @@ { if ((Tcl_Init)(interp) == TCL_ERROR) { return TCL_ERROR; } -#if defined(STATIC_BUILD) && TCL_USE_STATIC_PACKAGES +#if defined(STATIC_BUILD) && defined(TCL_USE_STATIC_PACKAGES) && TCL_USE_STATIC_PACKAGES if (Registry_Init(interp) == TCL_ERROR) { return TCL_ERROR; } - Tcl_StaticPackage(interp, "registry", Registry_Init, NULL); + Tcl_StaticPackage(interp, "Registry", Registry_Init, NULL); if (Dde_Init(interp) == TCL_ERROR) { return TCL_ERROR; } - Tcl_StaticPackage(interp, "dde", Dde_Init, Dde_SafeInit); + Tcl_StaticPackage(interp, "Dde", Dde_Init, Dde_SafeInit); #endif #ifdef TCL_TEST if (Tcltest_Init(interp) == TCL_ERROR) { return TCL_ERROR; @@ -265,14 +262,15 @@ break; } } } - /* Make sure we don't call Tcl_Alloc through the (not yet initialized) stub table */ -# undef Tcl_Alloc + /* Make sure we don't call ckalloc through the (not yet initialized) stub table */ + #undef Tcl_Alloc + #undef Tcl_DbCkalloc - argSpace = Tcl_Alloc(size * sizeof(char *) + argSpace = (TCHAR *)ckalloc(size * sizeof(char *) + (_tcslen(cmdLine) * sizeof(TCHAR)) + sizeof(TCHAR)); argv = (TCHAR **) argSpace; argSpace += size * (sizeof(char *)/sizeof(TCHAR)); size--; Index: win/tclConfig.sh.in ================================================================== --- win/tclConfig.sh.in +++ win/tclConfig.sh.in @@ -39,13 +39,10 @@ TCL_SHARED_BUILD=@TCL_SHARED_BUILD@ # The name of the Tcl library (may be either a .a file or a shared library): TCL_LIB_FILE='@TCL_LIB_FILE@' -# The name of a zip containing the /library and /encodings (may be either a .zip file or a shared library): -TCL_ZIP_FILE='@TCL_ZIP_FILE@' - # Flag to indicate whether shared libraries need export files. TCL_NEEDS_EXP_FILE=@TCL_NEEDS_EXP_FILE@ # String that can be evaluated to generate the part of the export file # name that comes after the "libxxx" (includes version number, if any, @@ -78,11 +75,11 @@ # Base command to use for combining object files into a static library: TCL_STLIB_LD='@STLIB_LD@' # Either '$LIBS' (if dependent libraries should be included when linking -# shared libraries) or an empty string. See Tcl's configure.ac for more +# shared libraries) or an empty string. See Tcl's configure.in for more # explanation. TCL_SHLIB_LD_LIBS='@SHLIB_LD_LIBS@' # Suffix to use for the name of a shared library. TCL_SHLIB_SUFFIX='@SHLIB_SUFFIX@' @@ -176,5 +173,9 @@ # Path to the Tcl stub library in the build directory. TCL_BUILD_STUB_LIB_PATH='@TCL_BUILD_STUB_LIB_PATH@' # Path to the Tcl stub library in the install directory. TCL_STUB_LIB_PATH='@TCL_STUB_LIB_PATH@' + +# Flag, 1: we built Tcl with threads enabled, 0 we didn't +TCL_THREADS=@TCL_THREADS@ + Index: win/tclWin32Dll.c ================================================================== --- win/tclWin32Dll.c +++ win/tclWin32Dll.c @@ -117,10 +117,12 @@ DllMain( HINSTANCE hInst, /* Library instance handle. */ DWORD reason, /* Reason this function is being called. */ LPVOID reserved) /* Not used. */ { + (void)reserved; + switch (reason) { case DLL_PROCESS_ATTACH: DisableThreadLibraryCalls(hInst); TclWinInit(hInst); return TRUE; @@ -191,10 +193,34 @@ if (os.dwPlatformId != VER_PLATFORM_WIN32_NT) { Tcl_Panic("Windows NT is the only supported platform"); } } + +/* + *---------------------------------------------------------------------- + * + * TclWinGetPlatformId -- + * + * Determines whether running under NT, 95, or Win32s, to allow runtime + * conditional code. + * + * Results: + * The return value is always: + * VER_PLATFORM_WIN32_NT Win32 on Windows NT, 2000, XP + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclWinGetPlatformId(void) +{ + return VER_PLATFORM_WIN32_NT; +} /* *------------------------------------------------------------------------- * * TclWinNoBackslash -- @@ -253,15 +279,35 @@ Tcl_MutexLock(&mountPointMap); dlIter = driveLetterLookup; while (dlIter != NULL) { dlIter2 = dlIter->nextPtr; - Tcl_Free(dlIter->volumeName); - Tcl_Free(dlIter); + ckfree(dlIter->volumeName); + ckfree(dlIter); dlIter = dlIter2; } Tcl_MutexUnlock(&mountPointMap); +} + +/* + *--------------------------------------------------------------------------- + * + * TclWinResetInterfaces -- + * + * Called during finalization to reset us to a safe state for reuse. + * + * Results: + * None. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ +void +TclWinResetInterfaces(void) +{ } /* *-------------------------------------------------------------------- * @@ -288,11 +334,11 @@ TclWinDriveLetterForVolMountPoint( const WCHAR *mountPoint) { MountPointMap *dlIter, *dlPtr2; WCHAR Target[55]; /* Target of mount at mount point */ - WCHAR drive[4] = TEXT("A:\\"); + WCHAR drive[4] = L"A:\\"; /* * Detect the volume mounted there. Unfortunately, there is no simple way * to map a unique volume name to a DOS drive letter. So, we have to build * an associative array. @@ -312,11 +358,11 @@ /* * Try to read the volume mount point and see where it points. */ - if (GetVolumeNameForVolumeMountPoint(drive, + if (GetVolumeNameForVolumeMountPointW(drive, Target, 55) != 0) { if (wcscmp(dlIter->volumeName, Target) == 0) { /* * Nothing has changed. */ @@ -347,12 +393,12 @@ /* * Now dlPtr2 points to the structure to free. */ - Tcl_Free(dlPtr2->volumeName); - Tcl_Free(dlPtr2); + ckfree(dlPtr2->volumeName); + ckfree(dlPtr2); /* * Restart the loop - we could try to be clever and continue half * way through, but the logic is a bit messy, so it's cleanest * just to restart. @@ -366,16 +412,16 @@ /* * We couldn't find it, so we must iterate over the letters. */ - for (drive[0] = L'A'; drive[0] <= L'Z'; drive[0]++) { + for (drive[0] = 'A'; drive[0] <= 'Z'; drive[0]++) { /* * Try to read the volume mount point and see where it points. */ - if (GetVolumeNameForVolumeMountPoint(drive, + if (GetVolumeNameForVolumeMountPointW(drive, Target, 55) != 0) { int alreadyStored = 0; for (dlIter = driveLetterLookup; dlIter != NULL; dlIter = dlIter->nextPtr) { @@ -383,12 +429,12 @@ alreadyStored = 1; break; } } if (!alreadyStored) { - dlPtr2 = Tcl_Alloc(sizeof(MountPointMap)); - dlPtr2->volumeName = TclNativeDupInternalRep(Target); + dlPtr2 = (MountPointMap *)ckalloc(sizeof(MountPointMap)); + dlPtr2->volumeName = (WCHAR *)TclNativeDupInternalRep(Target); dlPtr2->driveLetter = (char) drive[0]; dlPtr2->nextPtr = driveLetterLookup; driveLetterLookup = dlPtr2; } } @@ -409,12 +455,12 @@ /* * The volume doesn't appear to correspond to a drive letter - we remember * that fact and store '-1' so we don't have to look it up each time. */ - dlPtr2 = Tcl_Alloc(sizeof(MountPointMap)); - dlPtr2->volumeName = TclNativeDupInternalRep((ClientData) mountPoint); + dlPtr2 = (MountPointMap *)ckalloc(sizeof(MountPointMap)); + dlPtr2->volumeName = (WCHAR *)TclNativeDupInternalRep((void *)mountPoint); dlPtr2->driveLetter = -1; dlPtr2->nextPtr = driveLetterLookup; driveLetterLookup = dlPtr2; Tcl_MutexUnlock(&mountPointMap); return -1; @@ -461,43 +507,135 @@ * None. * *--------------------------------------------------------------------------- */ -WCHAR * +TCHAR * Tcl_WinUtfToTChar( const char *string, /* Source string in UTF-8. */ - size_t len, /* Source string length in bytes, or -1 - * for strlen(). */ + int len, /* Source string length in bytes, or -1 for + * strlen(). */ Tcl_DString *dsPtr) /* Uninitialized or free DString in which the * converted string is stored. */ { +#if TCL_UTF_MAX > 4 + Tcl_UniChar ch = 0; + TCHAR *w, *wString; + const char *p, *end; + int oldLength; +#endif + Tcl_DStringInit(dsPtr); if (!string) { return NULL; } - return TclUtfToWCharDString(string, len, dsPtr); +#if TCL_UTF_MAX > 4 + + if (len < 0) { + len = strlen(string); + } + + /* + * Unicode string length in Tcl_UniChars will be <= UTF-8 string length in + * bytes. + */ + + oldLength = Tcl_DStringLength(dsPtr); + + Tcl_DStringSetLength(dsPtr, + oldLength + (int) ((len + 1) * sizeof(TCHAR))); + wString = (TCHAR *) (Tcl_DStringValue(dsPtr) + oldLength); + + w = wString; + p = string; + end = string + len - 4; + while (p < end) { + p += TclUtfToUniChar(p, &ch); + if (ch > 0xFFFF) { + *w++ = (WCHAR) (0xD800 + ((ch -= 0x10000) >> 10)); + *w++ = (WCHAR) (0xDC00 | (ch & 0x3FF)); + } else { + *w++ = ch; + } + } + end += 4; + while (p < end) { + if (Tcl_UtfCharComplete(p, end-p)) { + p += TclUtfToUniChar(p, &ch); + } else { + ch = UCHAR(*p++); + } + if (ch > 0xFFFF) { + *w++ = (WCHAR) (0xD800 + ((ch -= 0x10000) >> 10)); + *w++ = (WCHAR) (0xDC00 | (ch & 0x3FF)); + } else { + *w++ = ch; + } + } + *w = '\0'; + Tcl_DStringSetLength(dsPtr, + oldLength + ((char *) w - (char *) wString)); + + return wString; +#else + return (TCHAR *)Tcl_UtfToUniCharDString(string, len, dsPtr); +#endif } char * Tcl_WinTCharToUtf( - const WCHAR *string, /* Source string in Unicode. */ - size_t len, /* Source string length in bytes, or -1 - * for platform-specific string length. */ + const TCHAR *string, /* Source string in Unicode. */ + int len, /* Source string length in bytes, or -1 for + * platform-specific string length. */ Tcl_DString *dsPtr) /* Uninitialized or free DString in which the * converted string is stored. */ { +#if TCL_UTF_MAX > 4 + const WCHAR *w, *wEnd; + char *p, *result; + int oldLength, blen = 1; +#endif + Tcl_DStringInit(dsPtr); if (!string) { return NULL; } - if (len == TCL_AUTO_LENGTH) { + if (len < 0) { len = wcslen((WCHAR *)string); } else { len /= 2; } - return TclWCharToUtfDString((unsigned short *)string, len, dsPtr); +#if TCL_UTF_MAX > 4 + oldLength = Tcl_DStringLength(dsPtr); + Tcl_DStringSetLength(dsPtr, oldLength + (len + 1) * 4); + result = Tcl_DStringValue(dsPtr) + oldLength; + + p = result; + wEnd = (WCHAR *)string + len; + for (w = (WCHAR *)string; w < wEnd; ) { + if (!blen && ((*w & 0xFC00) != 0xDC00)) { + /* Special case for handling high surrogates. */ + p += Tcl_UniCharToUtf(-1, p); + } + blen = Tcl_UniCharToUtf(*w, p); + p += blen; + if ((*w >= 0xD800) && (blen < 3)) { + /* Indication that high surrogate is handled */ + blen = 0; + } + w++; + } + if (!blen) { + /* Special case for handling high surrogates. */ + p += Tcl_UniCharToUtf(-1, p); + } + Tcl_DStringSetLength(dsPtr, oldLength + (p - result)); + + return result; +#else + return Tcl_UniCharToUtfDString((Tcl_UniChar *)string, len, dsPtr); +#endif } /* *------------------------------------------------------------------------ * @@ -516,12 +654,12 @@ *---------------------------------------------------------------------- */ int TclWinCPUID( - int index, /* Which CPUID value to retrieve. */ - int *regsPtr) /* Registers after the CPUID. */ + unsigned int index, /* Which CPUID value to retrieve. */ + unsigned int *regsPtr) /* Registers after the CPUID. */ { int status = TCL_ERROR; #if defined(HAVE_INTRIN_H) && defined(_WIN64) @@ -545,11 +683,11 @@ "movl %[index], %%eax" "\n\t" "cpuid" "\n\t" "movl %%eax, 0x0(%%edi)" "\n\t" "movl %%ebx, 0x4(%%edi)" "\n\t" "movl %%ecx, 0x8(%%edi)" "\n\t" - "movl %%edx, 0xc(%%edi)" "\n\t" + "movl %%edx, 0xC(%%edi)" "\n\t" : /* No outputs */ : [index] "m" (index), @@ -577,11 +715,11 @@ "movl %%fs:0, %%eax" "\n\t" "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ "leal 1f, %%eax" "\n\t" "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ - "movl %%esp, 0xc(%%edx)" "\n\t" /* esp */ + "movl %%esp, 0xC(%%edx)" "\n\t" /* esp */ "movl %[error], 0x10(%%edx)" "\n\t" /* status */ /* * Link the TCLEXCEPTION_REGISTRATION on the chain */ @@ -597,11 +735,11 @@ "movl %[index], %%eax" "\n\t" "cpuid" "\n\t" "movl %%eax, 0x0(%%edi)" "\n\t" "movl %%ebx, 0x4(%%edi)" "\n\t" "movl %%ecx, 0x8(%%edi)" "\n\t" - "movl %%edx, 0xc(%%edi)" "\n\t" + "movl %%edx, 0xC(%%edi)" "\n\t" /* * Come here on a normal exit. Recover the TCLEXCEPTION_REGISTRATION and * store a TCL_OK status. */ @@ -624,11 +762,11 @@ * Come here however we exited. Restore context from the * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" - "movl 0xc(%%edx), %%esp" "\n\t" + "movl 0xC(%%edx), %%esp" "\n\t" "movl 0x8(%%edx), %%ebp" "\n\t" "movl 0x0(%%edx), %%eax" "\n\t" "movl %%eax, %%fs:0" "\n\t" : Index: win/tclWinChan.c ================================================================== --- win/tclWinChan.c +++ win/tclWinChan.c @@ -23,12 +23,11 @@ #define FILE_TYPE_SERIAL (FILE_TYPE_PIPE+1) #define FILE_TYPE_CONSOLE (FILE_TYPE_PIPE+2) /* - * The following structure contains per-instance data for a file based - * channel. + * The following structure contains per-instance data for a file based channel. */ typedef struct FileInfo { Tcl_Channel channel; /* Pointer to channel structure. */ int validMask; /* OR'ed combination of TCL_READABLE, @@ -42,11 +41,11 @@ struct FileInfo *nextPtr; /* Pointer to next registered file. */ int dirty; /* Boolean flag. Set if the OS may have data * pending on the channel. */ } FileInfo; -typedef struct { +typedef struct ThreadSpecificData { /* * List of all file channels currently open. */ FileInfo *firstFilePtr; @@ -57,11 +56,11 @@ /* * The following structure is what is added to the Tcl event queue when file * events are generated. */ -typedef struct { +typedef struct FileEvent { Tcl_Event header; /* Information that is standard for all * events. */ FileInfo *infoPtr; /* Pointer to file info structure. Note that * we still have to verify that the file * exists before dereferencing this @@ -75,10 +74,12 @@ static int FileBlockProc(ClientData instanceData, int mode); static void FileChannelExitHandler(ClientData clientData); static void FileCheckProc(ClientData clientData, int flags); static int FileCloseProc(ClientData instanceData, Tcl_Interp *interp); +static int FileClose2Proc(ClientData instanceData, + Tcl_Interp *interp, int flags); static int FileEventProc(Tcl_Event *evPtr, int flags); static int FileGetHandleProc(ClientData instanceData, int direction, ClientData *handlePtr); static ThreadSpecificData *FileInit(void); static int FileInputProc(ClientData instanceData, char *buf, @@ -95,11 +96,10 @@ int action); static int FileTruncateProc(ClientData instanceData, Tcl_WideInt length); static DWORD FileGetType(HANDLE handle); static int NativeIsComPort(const WCHAR *nativeName); - /* * This structure describes the channel type structure for file based IO. */ static const Tcl_ChannelType fileChannelType = { @@ -111,26 +111,18 @@ FileSeekProc, /* Seek proc. */ NULL, /* Set option proc. */ NULL, /* Get option proc. */ FileWatchProc, /* Set up the notifier to watch the channel. */ FileGetHandleProc, /* Get an OS handle from channel. */ - NULL, /* close2proc. */ + FileClose2Proc, /* close2proc. */ FileBlockProc, /* Set blocking or non-blocking mode.*/ NULL, /* flush proc. */ NULL, /* handler proc. */ FileWideSeekProc, /* Wide seek proc. */ FileThreadActionProc, /* Thread action proc. */ FileTruncateProc /* Truncate proc. */ }; - -/* - * General useful clarification macros. - */ - -#define SET_FLAG(var, flag) ((var) |= (flag)) -#define CLEAR_FLAG(var, flag) ((var) &= ~(flag)) -#define TEST_FLAG(value, flag) (((value) & (flag)) != 0) /* *---------------------------------------------------------------------- * * FileInit -- @@ -148,11 +140,11 @@ static ThreadSpecificData * FileInit(void) { ThreadSpecificData *tsdPtr = - (ThreadSpecificData *) TclThreadDataKeyGet(&dataKey); + (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); if (tsdPtr == NULL) { tsdPtr = TCL_TSD_INIT(&dataKey); tsdPtr->firstFilePtr = NULL; Tcl_CreateEventSource(FileSetupProc, FileCheckProc, NULL); @@ -209,11 +201,11 @@ { FileInfo *infoPtr; Tcl_Time blockTime = { 0, 0 }; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - if (!TEST_FLAG(flags, TCL_FILE_EVENTS)) { + if (!(flags & TCL_FILE_EVENTS)) { return; } /* * Check to see if there is a ready file. If so, poll. @@ -252,11 +244,11 @@ { FileEvent *evPtr; FileInfo *infoPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - if (!TEST_FLAG(flags, TCL_FILE_EVENTS)) { + if (!(flags & TCL_FILE_EVENTS)) { return; } /* * Queue events for any ready files that don't already have events queued @@ -263,13 +255,13 @@ * (caused by persistent states that won't generate WinSock events). */ for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { - if (infoPtr->watchMask && !TEST_FLAG(infoPtr->flags, FILE_PENDING)) { - SET_FLAG(infoPtr->flags, FILE_PENDING); - evPtr = Tcl_Alloc(sizeof(FileEvent)); + if (infoPtr->watchMask && !(infoPtr->flags & FILE_PENDING)) { + infoPtr->flags |= FILE_PENDING; + evPtr = ckalloc(sizeof(FileEvent)); evPtr->header.proc = FileEventProc; evPtr->infoPtr = infoPtr; Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); } } @@ -304,11 +296,11 @@ { FileEvent *fileEvPtr = (FileEvent *)evPtr; FileInfo *infoPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - if (!TEST_FLAG(flags, TCL_FILE_EVENTS)) { + if (!(flags & TCL_FILE_EVENTS)) { return 0; } /* * Search through the list of watched files for the one whose handle @@ -318,11 +310,11 @@ */ for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if (fileEvPtr->infoPtr == infoPtr) { - CLEAR_FLAG(infoPtr->flags, FILE_PENDING); + infoPtr->flags &= ~(FILE_PENDING); Tcl_NotifyChannel(infoPtr->channel, infoPtr->watchMask); break; } } return 1; @@ -358,21 +350,21 @@ * function by checking against a bit in the state. We set or unset the * bit here to cause the input function to emulate the correct behavior. */ if (mode == TCL_MODE_NONBLOCKING) { - SET_FLAG(infoPtr->flags, FILE_ASYNC); + infoPtr->flags |= FILE_ASYNC; } else { - CLEAR_FLAG(infoPtr->flags, FILE_ASYNC); + infoPtr->flags &= ~(FILE_ASYNC); } return 0; } /* *---------------------------------------------------------------------- * - * FileCloseProc -- + * FileCloseProc/FileClose2Proc -- * * Closes the IO channel. * * Results: * 0 if successful, the value of errno if failed. @@ -432,13 +424,25 @@ FileThreadActionProc(fileInfoPtr,TCL_CHANNEL_THREAD_REMOVE); break; } } - Tcl_Free(fileInfoPtr); + ckfree(fileInfoPtr); return errorCode; } + +static int +FileClose2Proc( + ClientData instanceData, /* Pointer to FileInfo structure. */ + Tcl_Interp *interp, /* Not used. */ + int flags) +{ + if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) == 0) { + return FileCloseProc(instanceData, interp); + } + return EINVAL; +} /* *---------------------------------------------------------------------- * * FileSeekProc -- @@ -480,11 +484,11 @@ * Save our current place in case we need to roll-back the seek. */ oldPosHigh = 0; oldPos = SetFilePointer(infoPtr->handle, 0, &oldPosHigh, FILE_CURRENT); - if (oldPos == (LONG) INVALID_SET_FILE_POINTER) { + if (oldPos == (LONG)INVALID_SET_FILE_POINTER) { DWORD winError = GetLastError(); if (winError != NO_ERROR) { TclWinConvertError(winError); *errorCodePtr = errno; @@ -492,11 +496,11 @@ } } newPosHigh = (offset < 0 ? -1 : 0); newPos = SetFilePointer(infoPtr->handle, offset, &newPosHigh, moveMethod); - if (newPos == (LONG) INVALID_SET_FILE_POINTER) { + if (newPos == (LONG)INVALID_SET_FILE_POINTER) { DWORD winError = GetLastError(); if (winError != NO_ERROR) { TclWinConvertError(winError); *errorCodePtr = errno; @@ -552,24 +556,23 @@ moveMethod = FILE_CURRENT; } else { moveMethod = FILE_END; } - newPosHigh = (LONG)(offset >> 32); - newPos = SetFilePointer(infoPtr->handle, (LONG)offset, + newPosHigh = Tcl_WideAsLong(offset >> 32); + newPos = SetFilePointer(infoPtr->handle, Tcl_WideAsLong(offset), &newPosHigh, moveMethod); - if (newPos == (LONG) INVALID_SET_FILE_POINTER) { + if (newPos == (LONG)INVALID_SET_FILE_POINTER) { DWORD winError = GetLastError(); if (winError != NO_ERROR) { TclWinConvertError(winError); *errorCodePtr = errno; return -1; } } - return (((Tcl_WideInt)((unsigned)newPos)) - | ((Tcl_WideInt)newPosHigh << 32)); + return (((Tcl_WideInt)((unsigned)newPos)) | (Tcl_LongAsWide(newPosHigh) << 32)); } /* *---------------------------------------------------------------------- * @@ -598,13 +601,12 @@ * Save where we were... */ oldPosHigh = 0; oldPos = SetFilePointer(infoPtr->handle, 0, &oldPosHigh, FILE_CURRENT); - if (oldPos == (LONG) INVALID_SET_FILE_POINTER) { + if (oldPos == (LONG)INVALID_SET_FILE_POINTER) { DWORD winError = GetLastError(); - if (winError != NO_ERROR) { TclWinConvertError(winError); return errno; } } @@ -611,16 +613,15 @@ /* * Move to where we want to truncate */ - newPosHigh = (LONG)(length >> 32); - newPos = SetFilePointer(infoPtr->handle, (LONG)length, + newPosHigh = Tcl_WideAsLong(length >> 32); + newPos = SetFilePointer(infoPtr->handle, Tcl_WideAsLong(length), &newPosHigh, FILE_BEGIN); - if (newPos == (LONG) INVALID_SET_FILE_POINTER) { + if (newPos == (LONG)INVALID_SET_FILE_POINTER) { DWORD winError = GetLastError(); - if (winError != NO_ERROR) { TclWinConvertError(winError); return errno; } } @@ -673,13 +674,13 @@ DWORD bytesRead; *errorCode = 0; /* - * TODO: This comment appears to be out of date. We *do* have a console - * driver, over in tclWinConsole.c. After some Windows developer confirms, - * this comment should be revised. + * TODO: This comment appears to be out of date. We *do* have a + * console driver, over in tclWinConsole.c. After some Windows + * developer confirms, this comment should be revised. * * Note that we will block on reads from a console buffer until a full * line has been entered. The only way I know of to get around this is to * write a console driver. We should probably do this at some point, but * for now, we just block. The same problem exists for files being read @@ -732,11 +733,11 @@ /* * If we are writing to a file that was opened with O_APPEND, we need to * seek to the end of the file before writing the current buffer. */ - if (TEST_FLAG(infoPtr->flags, FILE_APPEND)) { + if (infoPtr->flags & FILE_APPEND) { SetFilePointer(infoPtr->handle, 0, NULL, FILE_END); } if (WriteFile(infoPtr->handle, (LPVOID) buf, (DWORD) toWrite, &bytesWritten, (LPOVERLAPPED) NULL) == FALSE) { @@ -809,16 +810,16 @@ int direction, /* TCL_READABLE or TCL_WRITABLE */ ClientData *handlePtr) /* Where to store the handle. */ { FileInfo *infoPtr = instanceData; - if (!TEST_FLAG(direction, infoPtr->validMask)) { + if (direction & infoPtr->validMask) { + *handlePtr = (ClientData) infoPtr->handle; + return TCL_OK; + } else { return TCL_ERROR; } - - *handlePtr = (ClientData) infoPtr->handle; - return TCL_OK; } /* *---------------------------------------------------------------------- * @@ -854,14 +855,14 @@ char channelName[16 + TCL_INTEGER_SPACE]; TclFile readFile = NULL, writeFile = NULL; nativeName = Tcl_FSGetNativePath(pathPtr); if (nativeName == NULL) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't open \"%s\": filename is invalid on this platform", - TclGetString(pathPtr))); + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "couldn't open \"", + TclGetString(pathPtr), "\": filename is invalid on this platform", + NULL); } return NULL; } switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) { @@ -905,50 +906,49 @@ createMode = OPEN_EXISTING; break; } /* - * [2413550] Avoid double-open of serial ports on Windows. Special - * handling for Windows serial ports by a "name-hint" to directly open it - * with the OVERLAPPED flag set. + * [2413550] Avoid double-open of serial ports on Windows + * Special handling for Windows serial ports by a "name-hint" + * to directly open it with the OVERLAPPED flag set. */ - if (NativeIsComPort(nativeName)) { + if( NativeIsComPort(nativeName) ) { + handle = TclWinSerialOpen(INVALID_HANDLE_VALUE, nativeName, accessMode); if (handle == INVALID_HANDLE_VALUE) { TclWinConvertError(GetLastError()); - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't open serial \"%s\": %s", - TclGetString(pathPtr), Tcl_PosixError(interp))); + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "couldn't open serial \"", + TclGetString(pathPtr), "\": ", + Tcl_PosixError(interp), NULL); } return NULL; } /* - * For natively named Windows serial ports we are done. - */ - + * For natively named Windows serial ports we are done. + */ channel = TclWinOpenSerialChannel(handle, channelName, channelPermissions); return channel; } - /* * If the file is being created, get the file attributes from the * permissions argument, else use the existing file attributes. */ - if (TEST_FLAG(mode, O_CREAT)) { - if (TEST_FLAG(permissions, S_IWRITE)) { + if (mode & O_CREAT) { + if (permissions & S_IWRITE) { flags = FILE_ATTRIBUTE_NORMAL; } else { flags = FILE_ATTRIBUTE_READONLY; } } else { - flags = GetFileAttributes(nativeName); + flags = GetFileAttributesW(nativeName); if (flags == 0xFFFFFFFF) { flags = 0; } } @@ -960,22 +960,21 @@ /* * Now we get to create the file. */ - handle = CreateFile(nativeName, accessMode, shareMode, + handle = CreateFileW(nativeName, accessMode, shareMode, NULL, createMode, flags, (HANDLE) NULL); if (handle == INVALID_HANDLE_VALUE) { DWORD err = GetLastError(); - if ((err & 0xffffL) == ERROR_OPEN_FAILED) { - err = TEST_FLAG(mode, O_CREAT) ? ERROR_FILE_EXISTS - : ERROR_FILE_NOT_FOUND; + if ((err & 0xFFFFL) == ERROR_OPEN_FAILED) { + err = (mode & O_CREAT) ? ERROR_FILE_EXISTS : ERROR_FILE_NOT_FOUND; } TclWinConvertError(err); - if (interp) { + if (interp != (Tcl_Interp *) NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't open \"%s\": %s", TclGetString(pathPtr), Tcl_PosixError(interp))); } return NULL; @@ -984,22 +983,22 @@ channel = NULL; switch (FileGetType(handle)) { case FILE_TYPE_SERIAL: /* - * Natively named serial ports "com1-9", "\\\\.\\comXX" are already - * done with the code above. Here we handle all other serial port - * names. + * Natively named serial ports "com1-9", "\\\\.\\comXX" are + * already done with the code above. + * Here we handle all other serial port names. * * Reopen channel for OVERLAPPED operation. Normally this shouldn't * fail, because the channel exists. */ handle = TclWinSerialOpen(handle, nativeName, accessMode); if (handle == INVALID_HANDLE_VALUE) { TclWinConvertError(GetLastError()); - if (interp) { + if (interp != (Tcl_Interp *) NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't reopen serial \"%s\": %s", TclGetString(pathPtr), Tcl_PosixError(interp))); } return NULL; @@ -1010,24 +1009,23 @@ case FILE_TYPE_CONSOLE: channel = TclWinOpenConsoleChannel(handle, channelName, channelPermissions); break; case FILE_TYPE_PIPE: - if (TEST_FLAG(channelPermissions, TCL_READABLE)) { + if (channelPermissions & TCL_READABLE) { readFile = TclWinMakeFile(handle); } - if (TEST_FLAG(channelPermissions, TCL_WRITABLE)) { + if (channelPermissions & TCL_WRITABLE) { writeFile = TclWinMakeFile(handle); } channel = TclpCreateCommandChannel(readFile, writeFile, NULL, 0, NULL); break; case FILE_TYPE_CHAR: case FILE_TYPE_DISK: case FILE_TYPE_UNKNOWN: channel = TclWinOpenFileChannel(handle, channelName, - channelPermissions, - TEST_FLAG(mode, O_APPEND) ? FILE_APPEND : 0); + channelPermissions, (mode & O_APPEND) ? FILE_APPEND : 0); break; default: /* * The handle is of an unknown type, probably /dev/nul equivalent or @@ -1066,11 +1064,11 @@ Tcl_MakeFileChannel( ClientData rawHandle, /* OS level handle */ int mode) /* ORed combination of TCL_READABLE and * TCL_WRITABLE to indicate file mode. */ { -#if defined(HAVE_NO_SEH) && !defined(_WIN64) +#if defined(HAVE_NO_SEH) && !defined(_WIN64) && !defined(__clang__) TCLEXCEPTION_REGISTRATION registration; #endif char channelName[16 + TCL_INTEGER_SPACE]; Tcl_Channel channel = NULL; HANDLE handle = (HANDLE) rawHandle; @@ -1088,14 +1086,14 @@ break; case FILE_TYPE_CONSOLE: channel = TclWinOpenConsoleChannel(handle, channelName, mode); break; case FILE_TYPE_PIPE: - if (TEST_FLAG(mode, TCL_READABLE)) { + if (mode & TCL_READABLE) { readFile = TclWinMakeFile(handle); } - if (TEST_FLAG(mode, TCL_WRITABLE)) { + if (mode & TCL_WRITABLE) { writeFile = TclWinMakeFile(handle); } channel = TclpCreateCommandChannel(readFile, writeFile, NULL, 0, NULL); break; @@ -1119,11 +1117,11 @@ GetCurrentProcess(), &dupedHandle, 0, FALSE, DUPLICATE_SAME_ACCESS); if (result == 0) { /* - * Unable to make a duplicate. It's definately invalid at this + * Unable to make a duplicate. It's definitely invalid at this * point. */ return NULL; } @@ -1132,11 +1130,11 @@ * Use structured exception handling (Win32 SEH) to protect the close * of this duped handle which might throw EXCEPTION_INVALID_HANDLE. */ result = 0; -#if defined(HAVE_NO_SEH) && !defined(_WIN64) +#if defined(HAVE_NO_SEH) && !defined(_WIN64) && !defined(__clang__) /* * Don't have SEH available, do things the hard way. Note that this * needs to be one block of asm, to avoid stack imbalance; also, it is * illegal for one asm block to contain a jump to another. */ @@ -1158,11 +1156,11 @@ "movl %%fs:0, %%eax" "\n\t" "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ "leal 1f, %%eax" "\n\t" "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ - "movl %%esp, 0xc(%%edx)" "\n\t" /* esp */ + "movl %%esp, 0xC(%%edx)" "\n\t" /* esp */ "movl $0, 0x10(%%edx)" "\n\t" /* status */ /* * Link the TCLEXCEPTION_REGISTRATION on the chain. */ @@ -1198,11 +1196,11 @@ * Come here however we exited. Restore context from the * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" - "movl 0xc(%%edx), %%esp" "\n\t" + "movl 0xC(%%edx), %%esp" "\n\t" "movl 0x8(%%edx), %%ebp" "\n\t" "movl 0x0(%%edx), %%eax" "\n\t" "movl %%eax, %%fs:0" "\n\t" : @@ -1363,11 +1361,11 @@ if (infoPtr->handle == (HANDLE) handle) { return (permissions==infoPtr->validMask) ? infoPtr->channel : NULL; } } - infoPtr = Tcl_Alloc(sizeof(FileInfo)); + infoPtr = ckalloc(sizeof(FileInfo)); /* * TIP #218. Removed the code inserting the new structure into the global * list. This is now handled in the thread action callbacks, and only * there. @@ -1538,15 +1536,14 @@ /* *---------------------------------------------------------------------- * * NativeIsComPort -- * - * Determines if a path refers to a Windows serial port. A simple and - * efficient solution is to use a "name hint" to detect COM ports by - * their filename instead of resorting to a syscall to detect serialness - * after the fact. - * + * Determines if a path refers to a Windows serial port. + * A simple and efficient solution is to use a "name hint" to detect + * COM ports by their filename instead of resorting to a syscall + * to detect serialness after the fact. * The following patterns cover common serial port names: * COM[1-9] * \\.\COM[0-9]+ * * Results: @@ -1564,16 +1561,16 @@ /* * 1. Look for com[1-9]:? */ - if ((len == 4) && (_wcsnicmp(p, L"com", 3) == 0)) { + if ( (len == 4) && (_wcsnicmp(p, L"com", 3) == 0) ) { /* - * The 4th character must be a digit 1..9 - */ + * The 4th character must be a digit 1..9 + */ - if ((p[3] < L'1') || (p[3] > L'9')) { + if ( (p[3] < L'1') || (p[3] > L'9') ) { return 0; } return 1; } @@ -1581,15 +1578,15 @@ * 2. Look for \\.\com[0-9]+ */ if ((len >= 8) && (_wcsnicmp(p, L"\\\\.\\com", 7) == 0)) { /* - * Charaters 8..end must be a digits 0..9 - */ + * Charaters 8..end must be a digits 0..9 + */ - for (i=7; i '9')) { + for ( i=7; i '9') ) { return 0; } } return 1; } Index: win/tclWinConsole.c ================================================================== --- win/tclWinConsole.c +++ win/tclWinConsole.c @@ -29,14 +29,12 @@ /* * Bit masks used in the flags field of the ConsoleInfo structure below. */ -#define CONSOLE_PENDING (1<<0) /* Message is pending in the queue. */ -#define CONSOLE_ASYNC (1<<1) /* Channel is non-blocking. */ -#define CONSOLE_READ_OPS (1<<4) /* Channel supports read-related ops. */ -#define CONSOLE_RESET (1<<5) /* Console mode needs to be reset. */ +#define CONSOLE_PENDING (1<<0) /* Message is pending in the queue. */ +#define CONSOLE_ASYNC (1<<1) /* Channel is non-blocking. */ /* * Bit masks used in the sharedFlags field of the ConsoleInfo structure below. */ @@ -49,11 +47,11 @@ /* * Structure containing handles associated with one of the special console * threads. */ -typedef struct { +typedef struct ConsoleThreadInfo { HANDLE thread; /* Handle to reader or writer thread. */ HANDLE readyEvent; /* Manual-reset event to signal _to_ the main * thread when the worker thread has finished * waiting for its normal work to happen. */ TclPipeThreadInfo *TI; /* Thread info structure of writer and reader. */ @@ -102,16 +100,15 @@ int readFlags; /* Flags that are shared with the reader * thread. Access is synchronized with the * readable object. */ int bytesRead; /* Number of bytes in the buffer. */ int offset; /* Number of bytes read out of the buffer. */ - DWORD initMode; /* Initial console mode. */ char buffer[CONSOLE_BUFFER_SIZE]; /* Data consumed by reader thread. */ } ConsoleInfo; -typedef struct { +typedef struct ThreadSpecificData { /* * The following pointer refers to the head of the list of consoles that * are being watched for file events. */ @@ -123,11 +120,11 @@ /* * The following structure is what is added to the Tcl event queue when * console events are generated. */ -typedef struct { +typedef struct ConsoleEvent { Tcl_Event header; /* Information that is standard for all * events. */ ConsoleInfo *infoPtr; /* Pointer to console info structure. Note * that we still have to verify that the * console exists before dereferencing this @@ -141,26 +138,22 @@ static int ConsoleBlockModeProc(ClientData instanceData, int mode); static void ConsoleCheckProc(ClientData clientData, int flags); static int ConsoleCloseProc(ClientData instanceData, Tcl_Interp *interp); +static int ConsoleClose2Proc(ClientData instanceData, + Tcl_Interp *interp, int flags); static int ConsoleEventProc(Tcl_Event *evPtr, int flags); static void ConsoleExitHandler(ClientData clientData); static int ConsoleGetHandleProc(ClientData instanceData, int direction, ClientData *handlePtr); -static int ConsoleGetOptionProc(ClientData instanceData, - Tcl_Interp *interp, const char *optionName, - Tcl_DString *dsPtr); static void ConsoleInit(void); static int ConsoleInputProc(ClientData instanceData, char *buf, int toRead, int *errorCode); static int ConsoleOutputProc(ClientData instanceData, const char *buf, int toWrite, int *errorCode); static DWORD WINAPI ConsoleReaderThread(LPVOID arg); -static int ConsoleSetOptionProc(ClientData instanceData, - Tcl_Interp *interp, const char *optionName, - const char *value); static void ConsoleSetupProc(ClientData clientData, int flags); static void ConsoleWatchProc(ClientData instanceData, int mask); static DWORD WINAPI ConsoleWriterThread(LPVOID arg); static void ProcExitHandler(ClientData clientData); static int WaitForRead(ConsoleInfo *infoPtr, int blocking); @@ -182,15 +175,15 @@ TCL_CHANNEL_VERSION_5, /* v5 channel */ ConsoleCloseProc, /* Close proc. */ ConsoleInputProc, /* Input proc. */ ConsoleOutputProc, /* Output proc. */ NULL, /* Seek proc. */ - ConsoleSetOptionProc, /* Set option proc. */ - ConsoleGetOptionProc, /* Get option proc. */ + NULL, /* Set option proc. */ + NULL, /* Get option proc. */ ConsoleWatchProc, /* Set up notifier to watch the channel. */ ConsoleGetHandleProc, /* Get an OS handle from channel. */ - NULL, /* close2proc. */ + ConsoleClose2Proc, /* close2proc. */ ConsoleBlockModeProc, /* Set blocking or non-blocking mode. */ NULL, /* Flush proc. */ NULL, /* Handler proc. */ NULL, /* Wide seek proc. */ ConsoleThreadActionProc, /* Thread action proc. */ @@ -200,12 +193,12 @@ /* *---------------------------------------------------------------------- * * ReadConsoleBytes, WriteConsoleBytes -- * - * Wrapper for ReadConsole{A,W}, that takes and returns number of bytes - * instead of number of TCHARS. + * Wrapper for ReadConsoleW, that takes and returns number of bytes + * instead of number of WCHARS. * *---------------------------------------------------------------------- */ static BOOL @@ -215,11 +208,10 @@ DWORD nbytes, LPDWORD nbytesread) { DWORD ntchars; BOOL result; - int tcharsize = sizeof(TCHAR); /* * If user types a Ctrl-Break or Ctrl-C, ReadConsole will return * success with ntchars == 0 and GetLastError() will be * ERROR_OPERATION_ABORTED. We do not want to treat this case @@ -228,15 +220,15 @@ * thread will terminate the program. If a Ctrl signal handler * has been established (through an extension for example), it * will run and take whatever action it deems appropriate. */ do { - result = ReadConsole(hConsole, lpBuffer, nbytes / tcharsize, &ntchars, + result = ReadConsoleW(hConsole, lpBuffer, nbytes / sizeof(WCHAR), &ntchars, NULL); } while (result && ntchars == 0 && GetLastError() == ERROR_OPERATION_ABORTED); if (nbytesread != NULL) { - *nbytesread = ntchars * tcharsize; + *nbytesread = ntchars * sizeof(WCHAR); } return result; } static BOOL @@ -246,16 +238,15 @@ DWORD nbytes, LPDWORD nbyteswritten) { DWORD ntchars; BOOL result; - int tcharsize = sizeof(TCHAR); - result = WriteConsole(hConsole, lpBuffer, nbytes / tcharsize, &ntchars, + result = WriteConsoleW(hConsole, lpBuffer, nbytes / sizeof(WCHAR), &ntchars, NULL); if (nbyteswritten != NULL) { - *nbyteswritten = ntchars * tcharsize; + *nbyteswritten = ntchars * sizeof(WCHAR); } return result; } /* @@ -462,11 +453,11 @@ needEvent = 1; } } if (needEvent) { - ConsoleEvent *evPtr = Tcl_Alloc(sizeof(ConsoleEvent)); + ConsoleEvent *evPtr = ckalloc(sizeof(ConsoleEvent)); infoPtr->flags |= CONSOLE_PENDING; evPtr->header.proc = ConsoleEventProc; evPtr->infoPtr = infoPtr; Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); @@ -515,11 +506,11 @@ } /* *---------------------------------------------------------------------- * - * ConsoleCloseProc -- + * ConsoleCloseProc/ConsoleClose2Proc -- * * Closes a console based IO channel. * * Results: * 0 on success, errno otherwise. @@ -575,21 +566,10 @@ CloseHandle(consolePtr->writer.readyEvent); consolePtr->writer.thread = NULL; } consolePtr->validMask &= ~TCL_WRITABLE; - /* - * If the user has been tinkering with the mode, reset it now. We ignore - * any errors from this; we're quite possibly about to close or exit - * anyway. - */ - - if ((consolePtr->flags & CONSOLE_READ_OPS) && - (consolePtr->flags & CONSOLE_RESET)) { - SetConsoleMode(consolePtr->handle, consolePtr->initMode); - } - /* * Don't close the Win32 handle if the handle is a standard channel during * the thread exit process. Otherwise, one thread may kill the stdio of * another. */ @@ -608,26 +588,38 @@ /* * Remove the file from the list of watched files. */ - for (nextPtrPtr = &tsdPtr->firstConsolePtr, infoPtr = *nextPtrPtr; + for (nextPtrPtr = &(tsdPtr->firstConsolePtr), infoPtr = *nextPtrPtr; infoPtr != NULL; nextPtrPtr = &infoPtr->nextPtr, infoPtr = *nextPtrPtr) { if (infoPtr == (ConsoleInfo *) consolePtr) { *nextPtrPtr = infoPtr->nextPtr; break; } } if (consolePtr->writeBuf != NULL) { - Tcl_Free(consolePtr->writeBuf); + ckfree(consolePtr->writeBuf); consolePtr->writeBuf = 0; } - Tcl_Free(consolePtr); + ckfree(consolePtr); return errorCode; } + +static int +ConsoleClose2Proc( + ClientData instanceData, /* Pointer to ConsoleInfo structure. */ + Tcl_Interp *interp, /* For error reporting. */ + int flags) +{ + if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) == 0) { + return ConsoleCloseProc(instanceData, interp); + } + return EINVAL; +} /* *---------------------------------------------------------------------- * * ConsoleInputProc -- @@ -784,14 +776,14 @@ /* * Reallocate the buffer to be large enough to hold the data. */ if (infoPtr->writeBuf) { - Tcl_Free(infoPtr->writeBuf); + ckfree(infoPtr->writeBuf); } infoPtr->writeBufLen = toWrite; - infoPtr->writeBuf = Tcl_Alloc(toWrite); + infoPtr->writeBuf = ckalloc(toWrite); } memcpy(infoPtr->writeBuf, buf, toWrite); infoPtr->toWrite = toWrite; ResetEvent(threadInfo->readyEvent); TclPipeThreadSignal(&threadInfo->TI); @@ -1055,11 +1047,11 @@ if (infoPtr->readFlags & CONSOLE_EOF) { return 1; } - if (PeekConsoleInput(handle, &input, 1, &count) == FALSE) { + if (PeekConsoleInputW(handle, &input, 1, &count) == FALSE) { /* * Check to see if the peek failed because of EOF. */ TclWinConvertError(GetLastError()); @@ -1321,11 +1313,11 @@ /* * See if a channel with this handle already exists. */ - infoPtr = Tcl_Alloc(sizeof(ConsoleInfo)); + infoPtr = ckalloc(sizeof(ConsoleInfo)); memset(infoPtr, 0, sizeof(ConsoleInfo)); infoPtr->validMask = permissions; infoPtr->handle = handle; infoPtr->channel = (Tcl_Channel) NULL; @@ -1350,27 +1342,25 @@ * Make sure the console input buffer is ready for only character * input notifications and the buffer is set for line buffering. IOW, * we only want to catch when complete lines are ready for reading. */ - infoPtr->flags |= CONSOLE_READ_OPS; - GetConsoleMode(infoPtr->handle, &infoPtr->initMode); - modes = infoPtr->initMode; + GetConsoleMode(infoPtr->handle, &modes); modes &= ~(ENABLE_WINDOW_INPUT | ENABLE_MOUSE_INPUT); modes |= ENABLE_LINE_INPUT; SetConsoleMode(infoPtr->handle, modes); - infoPtr->reader.readyEvent = CreateEvent(NULL, TRUE, TRUE, NULL); + infoPtr->reader.readyEvent = CreateEventW(NULL, TRUE, TRUE, NULL); infoPtr->reader.thread = CreateThread(NULL, 256, ConsoleReaderThread, TclPipeThreadCreateTI(&infoPtr->reader.TI, infoPtr, infoPtr->reader.readyEvent), 0, NULL); SetThreadPriority(infoPtr->reader.thread, THREAD_PRIORITY_HIGHEST); } if (permissions & TCL_WRITABLE) { - infoPtr->writer.readyEvent = CreateEvent(NULL, TRUE, TRUE, NULL); + infoPtr->writer.readyEvent = CreateEventW(NULL, TRUE, TRUE, NULL); infoPtr->writer.thread = CreateThread(NULL, 256, ConsoleWriterThread, TclPipeThreadCreateTI(&infoPtr->writer.TI, infoPtr, infoPtr->writer.readyEvent), 0, NULL); SetThreadPriority(infoPtr->writer.thread, THREAD_PRIORITY_HIGHEST); } @@ -1433,220 +1423,13 @@ } else { infoPtr->threadId = NULL; } Tcl_MutexUnlock(&consoleMutex); } - -/* - *---------------------------------------------------------------------- - * - * ConsoleSetOptionProc -- - * - * Sets an option on a channel. - * - * Results: - * A standard Tcl result. Also sets the interp's result on error if - * interp is not NULL. - * - * Side effects: - * May modify an option on a console. Sets Error message if needed (by - * calling Tcl_BadChannelOption). - * - *---------------------------------------------------------------------- - */ - -static int -ConsoleSetOptionProc( - ClientData instanceData, /* File state. */ - Tcl_Interp *interp, /* For error reporting - can be NULL. */ - const char *optionName, /* Which option to set? */ - const char *value) /* New value for option. */ -{ - ConsoleInfo *infoPtr = instanceData; - int len = strlen(optionName); - int vlen = strlen(value); - - /* - * Option -inputmode normal|password|raw - */ - - if ((infoPtr->flags & CONSOLE_READ_OPS) && (len > 1) && - (strncmp(optionName, "-inputmode", len) == 0)) { - DWORD mode; - - if (GetConsoleMode(infoPtr->handle, &mode) == 0) { - TclWinConvertError(GetLastError()); - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't read console mode: %s", - Tcl_PosixError(interp))); - } - return TCL_ERROR; - } - if (Tcl_UtfNcasecmp(value, "NORMAL", vlen) == 0) { - mode |= ENABLE_ECHO_INPUT | ENABLE_LINE_INPUT; - } else if (Tcl_UtfNcasecmp(value, "PASSWORD", vlen) == 0) { - mode |= ENABLE_LINE_INPUT; - mode &= ~ENABLE_ECHO_INPUT; - } else if (Tcl_UtfNcasecmp(value, "RAW", vlen) == 0) { - mode &= ~(ENABLE_ECHO_INPUT | ENABLE_LINE_INPUT); - } else if (Tcl_UtfNcasecmp(value, "RESET", vlen) == 0) { - /* - * Reset to the initial mode, whatever that is. - */ - - mode = infoPtr->initMode; - } else { - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad mode \"%s\" for -inputmode: must be" - " normal, password, raw, or reset", value)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", - "VALUE", NULL); - } - return TCL_ERROR; - } - if (SetConsoleMode(infoPtr->handle, mode) == 0) { - TclWinConvertError(GetLastError()); - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't set console mode: %s", - Tcl_PosixError(interp))); - } - return TCL_ERROR; - } - - /* - * If we've changed the mode from default, schedule a reset later. - */ - - if (mode == infoPtr->initMode) { - infoPtr->flags &= ~CONSOLE_RESET; - } else { - infoPtr->flags |= CONSOLE_RESET; - } - return TCL_OK; - } - - if (infoPtr->flags & CONSOLE_READ_OPS) { - return Tcl_BadChannelOption(interp, optionName, "inputmode"); - } else { - return Tcl_BadChannelOption(interp, optionName, ""); - } -} - -/* - *---------------------------------------------------------------------- - * - * ConsoleGetOptionProc -- - * - * Gets a mode associated with an IO channel. If the optionName arg is - * non-NULL, retrieves the value of that option. If the optionName arg is - * NULL, retrieves a list of alternating option names and values for the - * given channel. - * - * Results: - * A standard Tcl result. Also sets the supplied DString to the string - * value of the option(s) returned. Sets error message if needed - * (by calling Tcl_BadChannelOption). - * - *---------------------------------------------------------------------- - */ - -static int -ConsoleGetOptionProc( - ClientData instanceData, /* File state. */ - Tcl_Interp *interp, /* For error reporting - can be NULL. */ - const char *optionName, /* Option to get. */ - Tcl_DString *dsPtr) /* Where to store value(s). */ -{ - ConsoleInfo *infoPtr = instanceData; - int valid = 0; /* Flag if valid option parsed. */ - unsigned int len; - char buf[TCL_INTEGER_SPACE]; - - if (optionName == NULL) { - len = 0; - } else { - len = strlen(optionName); - } - - /* - * Get option -inputmode - * - * This is a great simplification of the underlying reality, but actually - * represents what almost all scripts really want to know. - */ - - if (infoPtr->flags & CONSOLE_READ_OPS) { - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-inputmode"); - } - if (len==0 || (len>1 && strncmp(optionName, "-inputmode", len)==0)) { - DWORD mode; - - valid = 1; - if (GetConsoleMode(infoPtr->handle, &mode) == 0) { - TclWinConvertError(GetLastError()); - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't read console mode: %s", - Tcl_PosixError(interp))); - } - return TCL_ERROR; - } - if (mode & ENABLE_LINE_INPUT) { - if (mode & ENABLE_ECHO_INPUT) { - Tcl_DStringAppendElement(dsPtr, "normal"); - } else { - Tcl_DStringAppendElement(dsPtr, "password"); - } - } else { - Tcl_DStringAppendElement(dsPtr, "raw"); - } - } - } - - /* - * Get option -winsize - * Option is readonly and returned by [fconfigure chan -winsize] but not - * returned by [fconfigure chan] without explicit option name. - */ - - if ((len > 1) && (strncmp(optionName, "-winsize", len) == 0)) { - CONSOLE_SCREEN_BUFFER_INFO consoleInfo; - - valid = 1; - if (!GetConsoleScreenBufferInfo(infoPtr->handle, &consoleInfo)) { - TclWinConvertError(GetLastError()); - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't read console size: %s", - Tcl_PosixError(interp))); - } - return TCL_ERROR; - } - sprintf(buf, "%d", - consoleInfo.srWindow.Right - consoleInfo.srWindow.Left + 1); - Tcl_DStringAppendElement(dsPtr, buf); - sprintf(buf, "%d", - consoleInfo.srWindow.Bottom - consoleInfo.srWindow.Top + 1); - Tcl_DStringAppendElement(dsPtr, buf); - } - - if (valid) { - return TCL_OK; - } - if (infoPtr->flags & CONSOLE_READ_OPS) { - return Tcl_BadChannelOption(interp, optionName, "inputmode winsize"); - } else { - return Tcl_BadChannelOption(interp, optionName, ""); - } -} /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: win/tclWinDde.c ================================================================== --- win/tclWinDde.c +++ win/tclWinDde.c @@ -32,11 +32,11 @@ typedef struct RegisteredInterp { struct RegisteredInterp *nextPtr; /* The next interp this application knows * about. */ - TCHAR *name; /* Interpreter's name (malloc-ed). */ + WCHAR *name; /* Interpreter's name (malloc-ed). */ Tcl_Obj *handlerPtr; /* The server handler command */ Tcl_Interp *interp; /* The interpreter attached to this name. */ } RegisteredInterp; /* @@ -77,14 +77,14 @@ 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.4.1" +#define TCL_DDE_VERSION "1.4.3" #define TCL_DDE_PACKAGE_NAME "dde" -#define TCL_DDE_SERVICE_NAME TEXT("TclEval") -#define TCL_DDE_EXECUTE_RESULT TEXT("$TCLEVAL$EXECUTE$RESULT") +#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 @@ -97,27 +97,37 @@ static LRESULT CALLBACK DdeClientWindowProc(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lParam); static int DdeCreateClient(DdeEnumServices *es); static BOOL CALLBACK DdeEnumWindowsCallback(HWND hwndTarget, LPARAM lParam); -static void DdeExitProc(ClientData clientData); +static void DdeExitProc(void *clientData); static int DdeGetServicesList(Tcl_Interp *interp, - const TCHAR *serviceName, const TCHAR *topicName); + const WCHAR *serviceName, const WCHAR *topicName); static HDDEDATA CALLBACK DdeServerProc(UINT uType, UINT uFmt, HCONV hConv, HSZ ddeTopic, HSZ ddeItem, HDDEDATA hData, DWORD dwData1, DWORD dwData2); static LRESULT DdeServicesOnAck(HWND hwnd, WPARAM wParam, LPARAM lParam); -static void DeleteProc(ClientData clientData); +static void DeleteProc(void *clientData); static Tcl_Obj * ExecuteRemoteObject(RegisteredInterp *riPtr, Tcl_Obj *ddeObjectPtr); static int MakeDdeConnection(Tcl_Interp *interp, - const TCHAR *name, HCONV *ddeConvPtr); + const WCHAR *name, HCONV *ddeConvPtr); static void SetDdeError(Tcl_Interp *interp); -static int DdeObjCmd(ClientData clientData, +static int DdeObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); + +#if (TCL_MAJOR_VERSION < 9) && (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 +#endif static unsigned char * getByteArrayFromObj( Tcl_Obj *objPtr, size_t *lengthPtr @@ -134,12 +144,18 @@ /* 32-bit or without TIP #494 */ *lengthPtr = (size_t) (unsigned) length; return result; } +#ifdef __cplusplus +extern "C" { +#endif DLLEXPORT int Dde_Init(Tcl_Interp *interp); DLLEXPORT int Dde_SafeInit(Tcl_Interp *interp); +#ifdef __cplusplus +} +#endif /* *---------------------------------------------------------------------- * * Dde_Init -- @@ -157,17 +173,17 @@ int Dde_Init( Tcl_Interp *interp) { - if (!Tcl_InitStubs(interp, "8.1", 0)) { + if (!Tcl_InitStubs(interp, "8.5", 0)) { return TCL_ERROR; } Tcl_CreateObjCommand(interp, "dde", DdeObjCmd, NULL, NULL); Tcl_CreateExitHandler(DdeExitProc, NULL); - return Tcl_PkgProvide(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION); + return Tcl_PkgProvideEx(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION, NULL); } /* *---------------------------------------------------------------------- * @@ -233,11 +249,11 @@ */ if (ddeInstance == 0) { Tcl_MutexLock(&ddeMutex); if (ddeInstance == 0) { - if (DdeInitialize(&ddeInstance, (PFNCALLBACK) DdeServerProc, + if (DdeInitializeW(&ddeInstance, (PFNCALLBACK)(void *)DdeServerProc, CBF_SKIP_REGISTRATIONS | CBF_SKIP_UNREGISTRATIONS | CBF_FAIL_POKES, 0) != DMLERR_NO_ERROR) { ddeInstance = 0; } } @@ -246,11 +262,11 @@ if ((ddeServiceGlobal == 0) && (nameFound != 0)) { Tcl_MutexLock(&ddeMutex); if ((ddeServiceGlobal == 0) && (nameFound != 0)) { ddeIsServer = 1; Tcl_CreateExitHandler(DdeExitProc, NULL); - ddeServiceGlobal = DdeCreateStringHandle(ddeInstance, + ddeServiceGlobal = DdeCreateStringHandleW(ddeInstance, TCL_DDE_SERVICE_NAME, CP_WINUNICODE); DdeNameService(ddeInstance, ddeServiceGlobal, 0L, DNS_REGISTER); } else { ddeIsServer = 0; } @@ -281,24 +297,24 @@ * deleted or the "send" command is removed. * *---------------------------------------------------------------------- */ -static const TCHAR * +static const WCHAR * DdeSetServerName( Tcl_Interp *interp, - const TCHAR *name, /* The name that will be used to refer to the + const WCHAR *name, /* The name that will be used to refer to the * interpreter in later "send" commands. Must * be globally unique. */ int flags, /* DDE_FLAG_FORCE or 0 */ Tcl_Obj *handlerPtr) /* Name of the optional proc/command to handle * incoming Dde eval's */ { int suffix, offset; RegisteredInterp *riPtr, *prevPtr; Tcl_DString dString; - const TCHAR *actualName; + const WCHAR *actualName; Tcl_Obj *srvListPtr = NULL, **srvPtrPtr = NULL; int n, srvCount = 0, lastSuffix, r = TCL_OK; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* @@ -332,11 +348,11 @@ /* * The name was NULL, so the caller is asking for the name of the * current interp, but it doesn't have a name. */ - return TEXT(""); + return L""; } /* * Get the list of currently registered Tcl interpreters by calling the * internal implementation of the 'dde services' command. @@ -353,12 +369,12 @@ if (r == TCL_OK) { r = Tcl_ListObjGetElements(interp, srvListPtr, &srvCount, &srvPtrPtr); } if (r != TCL_OK) { - Tcl_WinUtfToTChar(Tcl_GetStringResult(interp), -1, &dString); - OutputDebugString((TCHAR *) Tcl_DStringValue(&dString)); + Tcl_DStringInit(&dString); + OutputDebugStringW(Tcl_UtfToWCharDString(Tcl_GetString(Tcl_GetObjResult(interp)), -1, &dString)); Tcl_DStringFree(&dString); return NULL; } /* @@ -372,18 +388,18 @@ while (suffix != lastSuffix) { lastSuffix = suffix; if (suffix > 1) { if (suffix == 2) { - Tcl_DStringAppend(&dString, (char *)name, _tcslen(name) * sizeof(TCHAR)); - Tcl_DStringAppend(&dString, (char *)TEXT(" #"), 2 * sizeof(TCHAR)); + Tcl_DStringAppend(&dString, (char *)name, wcslen(name) * sizeof(WCHAR)); + Tcl_DStringAppend(&dString, (char *)L" #", 2 * sizeof(WCHAR)); offset = Tcl_DStringLength(&dString); - Tcl_DStringSetLength(&dString, offset + sizeof(TCHAR) * TCL_INTEGER_SPACE); - actualName = (TCHAR *) Tcl_DStringValue(&dString); + Tcl_DStringSetLength(&dString, offset + sizeof(WCHAR) * TCL_INTEGER_SPACE); + actualName = (WCHAR *) Tcl_DStringValue(&dString); } - _sntprintf((TCHAR *) (Tcl_DStringValue(&dString) + offset), - TCL_INTEGER_SPACE, TEXT("%d"), suffix); + _snwprintf((WCHAR *) (Tcl_DStringValue(&dString) + offset), + TCL_INTEGER_SPACE, L"%d", suffix); } /* * See if the name is already in use, if so increment suffix. */ @@ -391,12 +407,13 @@ for (n = 0; n < srvCount; ++n) { Tcl_Obj* namePtr; Tcl_DString ds; Tcl_ListObjIndex(interp, srvPtrPtr[n], 1, &namePtr); - Tcl_WinUtfToTChar(Tcl_GetString(namePtr), -1, &ds); - if (_tcscmp(actualName, (TCHAR *)Tcl_DStringValue(&ds)) == 0) { + Tcl_DStringInit(&ds); + Tcl_UtfToWCharDString(Tcl_GetString(namePtr), -1, &ds); + if (wcscmp(actualName, (WCHAR *)Tcl_DStringValue(&ds)) == 0) { suffix++; Tcl_DStringFree(&ds); break; } Tcl_DStringFree(&ds); @@ -408,18 +425,18 @@ * We have found a unique name. Now add it to the registry. */ riPtr = (RegisteredInterp *) Tcl_Alloc(sizeof(RegisteredInterp)); riPtr->interp = interp; - riPtr->name = (TCHAR *) Tcl_Alloc((_tcslen(actualName) + 1) * sizeof(TCHAR)); + riPtr->name = (WCHAR *) Tcl_Alloc((wcslen(actualName) + 1) * sizeof(WCHAR)); riPtr->nextPtr = tsdPtr->interpListPtr; riPtr->handlerPtr = handlerPtr; if (riPtr->handlerPtr != NULL) { Tcl_IncrRefCount(riPtr->handlerPtr); } tsdPtr->interpListPtr = riPtr; - _tcscpy(riPtr->name, actualName); + wcscpy(riPtr->name, actualName); if (Tcl_IsSafe(interp)) { Tcl_ExposeCommand(interp, "dde", "dde"); } @@ -487,12 +504,11 @@ *---------------------------------------------------------------------- */ static void DeleteProc( - ClientData clientData) /* The interp we are deleting passed as - * ClientData. */ + void *clientData) /* The interp we are deleting. */ { RegisteredInterp *riPtr = (RegisteredInterp *) clientData; RegisteredInterp *searchPtr, *prevPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -625,40 +641,42 @@ HCONV hConv, /* The conversation associated with the * current transaction. */ HSZ ddeTopic, HSZ ddeItem, /* String handles. Transaction-type * dependent. */ HDDEDATA hData, /* DDE data. Transaction-type dependent. */ - DWORD dwData1, DWORD dwData2) + DWORD unused1, DWORD unused2) /* Transaction-dependent data. */ { Tcl_DString dString; size_t len; DWORD dlen; - TCHAR *utilString; + WCHAR *utilString; Tcl_Obj *ddeObjectPtr; HDDEDATA ddeReturn = NULL; RegisteredInterp *riPtr; Conversation *convPtr, *prevConvPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + (void)unused1; + (void)unused2; switch(uType) { case XTYP_CONNECT: /* * Dde is trying to initialize a conversation with us. Check and make * sure we have a valid topic. */ - len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, CP_WINUNICODE); + len = DdeQueryStringW(ddeInstance, ddeTopic, NULL, 0, CP_WINUNICODE); Tcl_DStringInit(&dString); - Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); - utilString = (TCHAR *) Tcl_DStringValue(&dString); - DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1, + Tcl_DStringSetLength(&dString, (len + 1) * sizeof(WCHAR) - 1); + utilString = (WCHAR *) Tcl_DStringValue(&dString); + DdeQueryStringW(ddeInstance, ddeTopic, utilString, (DWORD) len + 1, CP_WINUNICODE); for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; riPtr = riPtr->nextPtr) { - if (_tcsicmp(utilString, riPtr->name) == 0) { + if (_wcsicmp(utilString, riPtr->name) == 0) { Tcl_DStringFree(&dString); return (HDDEDATA) TRUE; } } @@ -670,19 +688,19 @@ * Dde has decided that we can connect, so it gives us a conversation * handle. We need to keep track of it so we know which execution * result to return in an XTYP_REQUEST. */ - len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, CP_WINUNICODE); + len = DdeQueryStringW(ddeInstance, ddeTopic, NULL, 0, CP_WINUNICODE); Tcl_DStringInit(&dString); - Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); - utilString = (TCHAR *) Tcl_DStringValue(&dString); - DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1, + Tcl_DStringSetLength(&dString, (len + 1) * sizeof(WCHAR) - 1); + utilString = (WCHAR *) Tcl_DStringValue(&dString); + DdeQueryStringW(ddeInstance, ddeTopic, utilString, (DWORD) len + 1, CP_WINUNICODE); for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; riPtr = riPtr->nextPtr) { - if (_tcsicmp(riPtr->name, utilString) == 0) { + if (_wcsicmp(riPtr->name, utilString) == 0) { convPtr = (Conversation *) Tcl_Alloc(sizeof(Conversation)); convPtr->nextPtr = tsdPtr->currentConversations; convPtr->returnPackagePtr = NULL; convPtr->hConv = hConv; convPtr->riPtr = riPtr; @@ -738,25 +756,26 @@ if (convPtr != NULL) { Tcl_DString dsBuf; char *returnString; - len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE); + len = DdeQueryStringW(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE); Tcl_DStringInit(&dString); Tcl_DStringInit(&dsBuf); - Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); - utilString = (TCHAR *) Tcl_DStringValue(&dString); - DdeQueryString(ddeInstance, ddeItem, utilString, (DWORD) len + 1, + Tcl_DStringSetLength(&dString, (len + 1) * sizeof(WCHAR) - 1); + utilString = (WCHAR *) Tcl_DStringValue(&dString); + DdeQueryStringW(ddeInstance, ddeItem, utilString, (DWORD) len + 1, CP_WINUNICODE); - if (_tcsicmp(utilString, TCL_DDE_EXECUTE_RESULT) == 0) { + if (_wcsicmp(utilString, TCL_DDE_EXECUTE_RESULT) == 0) { returnString = Tcl_GetString(convPtr->returnPackagePtr); len = convPtr->returnPackagePtr->length; if (uFmt != CF_TEXT) { - Tcl_WinUtfToTChar(returnString, len, &dsBuf); + Tcl_DStringInit(&dsBuf); + Tcl_UtfToWCharDString(returnString, len, &dsBuf); returnString = Tcl_DStringValue(&dsBuf); - len = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR) - 1; + len = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR) - 1; } ddeReturn = DdeCreateDataHandle(ddeInstance, (BYTE *)returnString, (DWORD) len+1, 0, ddeItem, uFmt, 0); } else { if (Tcl_IsSafe(convPtr->riPtr->interp)) { @@ -763,21 +782,23 @@ ddeReturn = NULL; } else { Tcl_DString ds; Tcl_Obj *variableObjPtr; - Tcl_WinTCharToUtf(utilString, -1, &ds); + Tcl_DStringInit(&ds); + Tcl_WCharToUtfDString(utilString, wcslen(utilString), &ds); variableObjPtr = Tcl_GetVar2Ex( convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL, TCL_GLOBAL_ONLY); if (variableObjPtr != NULL) { returnString = Tcl_GetString(variableObjPtr); len = variableObjPtr->length; if (uFmt != CF_TEXT) { - Tcl_WinUtfToTChar(returnString, len, &dsBuf); + Tcl_DStringInit(&dsBuf); + Tcl_UtfToWCharDString(returnString, len, &dsBuf); returnString = Tcl_DStringValue(&dsBuf); - len = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR) - 1; + len = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR) - 1; } ddeReturn = DdeCreateDataHandle(ddeInstance, (BYTE *)returnString, (DWORD) len+1, 0, ddeItem, uFmt, 0); } else { @@ -815,21 +836,23 @@ Tcl_Obj *variableObjPtr; DWORD len2; Tcl_DStringInit(&dString); Tcl_DStringInit(&ds2); - len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE); - Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); - utilString = (TCHAR *) Tcl_DStringValue(&dString); - DdeQueryString(ddeInstance, ddeItem, utilString, (DWORD) len + 1, + len = DdeQueryStringW(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE); + Tcl_DStringSetLength(&dString, (len + 1) * sizeof(WCHAR) - 1); + utilString = (WCHAR *) Tcl_DStringValue(&dString); + DdeQueryStringW(ddeInstance, ddeItem, utilString, (DWORD) len + 1, CP_WINUNICODE); - Tcl_WinTCharToUtf(utilString, -1, &ds); - utilString = (TCHAR *) DdeAccessData(hData, &len2); + Tcl_DStringInit(&ds); + Tcl_WCharToUtfDString(utilString, wcslen(utilString), &ds); + utilString = (WCHAR *) DdeAccessData(hData, &len2); len = len2; if (uFmt != CF_TEXT) { - Tcl_WinTCharToUtf(utilString, -1, &ds2); - utilString = (TCHAR *) Tcl_DStringValue(&ds2); + Tcl_DStringInit(&ds2); + Tcl_WCharToUtfDString(utilString, wcslen(utilString), &ds2); + utilString = (WCHAR *) Tcl_DStringValue(&ds2); } variableObjPtr = Tcl_NewStringObj((char *)utilString, -1); Tcl_SetVar2Ex(convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL, variableObjPtr, TCL_GLOBAL_ONLY); @@ -860,11 +883,11 @@ if (convPtr == NULL) { return (HDDEDATA) DDE_FNOTPROCESSED; } - utilString = (TCHAR *) DdeAccessData(hData, &dlen); + utilString = (WCHAR *) DdeAccessData(hData, &dlen); string = (char *) utilString; if (!dlen) { /* Empty binary array. */ ddeObjectPtr = Tcl_NewObj(); } else if ((dlen & 1) || utilString[(dlen>>1)-1]) { @@ -875,11 +898,12 @@ ddeObjectPtr = Tcl_NewStringObj(string, dlen); } else { /* unicode */ Tcl_DString dsBuf; - Tcl_WinTCharToUtf(utilString, dlen - sizeof(TCHAR), &dsBuf); + Tcl_DStringInit(&dsBuf); + Tcl_WCharToUtfDString(utilString, (dlen>>1) - 1, &dsBuf); ddeObjectPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsBuf), Tcl_DStringLength(&dsBuf)); Tcl_DStringFree(&dsBuf); } Tcl_IncrRefCount(ddeObjectPtr); @@ -930,13 +954,13 @@ (numItems + 1) * sizeof(HSZPAIR), 0, 0, 0, 0); returnPtr = (HSZPAIR *) DdeAccessData(ddeReturn, &dlen); len = dlen; for (i = 0, riPtr = tsdPtr->interpListPtr; i < numItems; i++, riPtr = riPtr->nextPtr) { - returnPtr[i].hszSvc = DdeCreateStringHandle(ddeInstance, + returnPtr[i].hszSvc = DdeCreateStringHandleW(ddeInstance, TCL_DDE_SERVICE_NAME, CP_WINUNICODE); - returnPtr[i].hszTopic = DdeCreateStringHandle(ddeInstance, + returnPtr[i].hszTopic = DdeCreateStringHandleW(ddeInstance, riPtr->name, CP_WINUNICODE); } returnPtr[i].hszSvc = NULL; returnPtr[i].hszTopic = NULL; DdeUnaccessData(ddeReturn); @@ -964,12 +988,13 @@ *---------------------------------------------------------------------- */ static void DdeExitProc( - ClientData clientData) /* Not used in this handler. */ + void *dummy) /* Not used. */ { + (void)dummy; DdeNameService(ddeInstance, NULL, 0, DNS_UNREGISTER); DdeUninitialize(ddeInstance); ddeInstance = 0; } @@ -991,28 +1016,29 @@ */ static int MakeDdeConnection( Tcl_Interp *interp, /* Used to report errors. */ - const TCHAR *name, /* The connection to use. */ + const WCHAR *name, /* The connection to use. */ HCONV *ddeConvPtr) { HSZ ddeTopic, ddeService; HCONV ddeConv; - ddeService = DdeCreateStringHandle(ddeInstance, TCL_DDE_SERVICE_NAME, CP_WINUNICODE); - ddeTopic = DdeCreateStringHandle(ddeInstance, name, CP_WINUNICODE); + ddeService = DdeCreateStringHandleW(ddeInstance, TCL_DDE_SERVICE_NAME, CP_WINUNICODE); + ddeTopic = DdeCreateStringHandleW(ddeInstance, name, CP_WINUNICODE); ddeConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); DdeFreeStringHandle(ddeInstance, ddeService); DdeFreeStringHandle(ddeInstance, ddeTopic); if (ddeConv == (HCONV) NULL) { if (interp != NULL) { Tcl_DString dString; - Tcl_WinTCharToUtf(name, -1, &dString); + Tcl_DStringInit(&dString); + Tcl_WCharToUtfDString(name, wcslen(name), &dString); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "no registered server named \"%s\"", Tcl_DStringValue(&dString))); Tcl_DStringFree(&dString); Tcl_SetErrorCode(interp, "TCL", "DDE", "NO_SERVER", NULL); } @@ -1045,13 +1071,13 @@ static int DdeCreateClient( DdeEnumServices *es) { - WNDCLASSEX wc; - static const TCHAR *szDdeClientClassName = TEXT("TclEval client class"); - static const TCHAR *szDdeClientWindowName = TEXT("TclEval client window"); + WNDCLASSEXW wc; + static const WCHAR *szDdeClientClassName = L"TclEval client class"; + static const WCHAR *szDdeClientWindowName = L"TclEval client window"; memset(&wc, 0, sizeof(wc)); wc.cbSize = sizeof(wc); wc.lpfnWndProc = DdeClientWindowProc; wc.lpszClassName = szDdeClientClassName; @@ -1059,12 +1085,12 @@ /* * Register and create the callback window. */ - RegisterClassEx(&wc); - es->hwnd = CreateWindowEx(0, szDdeClientClassName, szDdeClientWindowName, + RegisterClassExW(&wc); + es->hwnd = CreateWindowExW(0, szDdeClientClassName, szDdeClientWindowName, WS_POPUP, 0, 0, 0, 0, NULL, NULL, NULL, (LPVOID)es); return TCL_OK; } static LRESULT CALLBACK @@ -1079,20 +1105,20 @@ LPCREATESTRUCT lpcs = (LPCREATESTRUCT) lParam; DdeEnumServices *es = (DdeEnumServices *) lpcs->lpCreateParams; #ifdef _WIN64 - SetWindowLongPtr(hwnd, GWLP_USERDATA, (LONG_PTR) es); + SetWindowLongPtrW(hwnd, GWLP_USERDATA, (LONG_PTR) es); #else - SetWindowLong(hwnd, GWL_USERDATA, (LONG) es); + SetWindowLongW(hwnd, GWL_USERDATA, (LONG) es); #endif return (LRESULT) 0L; } case WM_DDE_ACK: return DdeServicesOnAck(hwnd, wParam, lParam); default: - return DefWindowProc(hwnd, uMsg, wParam, lParam); + return DefWindowProcW(hwnd, uMsg, wParam, lParam); } } static LRESULT DdeServicesOnAck( @@ -1102,30 +1128,32 @@ { HWND hwndRemote = (HWND)wParam; ATOM service = (ATOM)LOWORD(lParam); ATOM topic = (ATOM)HIWORD(lParam); DdeEnumServices *es; - TCHAR sz[255]; + WCHAR sz[255]; Tcl_DString dString; #ifdef _WIN64 - es = (DdeEnumServices *) GetWindowLongPtr(hwnd, GWLP_USERDATA); + es = (DdeEnumServices *) GetWindowLongPtrW(hwnd, GWLP_USERDATA); #else - es = (DdeEnumServices *) GetWindowLong(hwnd, GWL_USERDATA); + es = (DdeEnumServices *) GetWindowLongW(hwnd, GWL_USERDATA); #endif if (((es->service == (ATOM)0) || (es->service == service)) && ((es->topic == (ATOM)0) || (es->topic == topic))) { Tcl_Obj *matchPtr = Tcl_NewListObj(0, NULL); Tcl_Obj *resultPtr = Tcl_GetObjResult(es->interp); - GlobalGetAtomName(service, sz, 255); - Tcl_WinTCharToUtf(sz, -1, &dString); + GlobalGetAtomNameW(service, sz, 255); + Tcl_DStringInit(&dString); + Tcl_WCharToUtfDString(sz, wcslen(sz), &dString); Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), -1)); Tcl_DStringFree(&dString); - GlobalGetAtomName(topic, sz, 255); - Tcl_WinTCharToUtf(sz, -1, &dString); + GlobalGetAtomNameW(topic, sz, 255); + Tcl_DStringInit(&dString); + Tcl_WCharToUtfDString(sz, wcslen(sz), &dString); Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), -1)); Tcl_DStringFree(&dString); /* * Adding the hwnd as a third list element provides a unique @@ -1149,11 +1177,11 @@ /* * Tell the server we are no longer interested. */ - PostMessage(hwndRemote, WM_DDE_TERMINATE, (WPARAM)hwnd, 0L); + PostMessageW(hwndRemote, WM_DDE_TERMINATE, (WPARAM)hwnd, 0L); return 0L; } static BOOL CALLBACK DdeEnumWindowsCallback( @@ -1161,29 +1189,29 @@ LPARAM lParam) { DWORD_PTR dwResult = 0; DdeEnumServices *es = (DdeEnumServices *) lParam; - SendMessageTimeout(hwndTarget, WM_DDE_INITIATE, (WPARAM)es->hwnd, + SendMessageTimeoutW(hwndTarget, WM_DDE_INITIATE, (WPARAM)es->hwnd, MAKELONG(es->service, es->topic), SMTO_ABORTIFHUNG, 1000, &dwResult); return TRUE; } static int DdeGetServicesList( Tcl_Interp *interp, - const TCHAR *serviceName, - const TCHAR *topicName) + const WCHAR *serviceName, + const WCHAR *topicName) { DdeEnumServices es; es.interp = interp; es.result = TCL_OK; es.service = (serviceName == NULL) - ? (ATOM)0 : GlobalAddAtom(serviceName); - es.topic = (topicName == NULL) ? (ATOM)0 : GlobalAddAtom(topicName); + ? (ATOM)0 : GlobalAddAtomW(serviceName); + es.topic = (topicName == NULL) ? (ATOM)0 : GlobalAddAtomW(topicName); Tcl_ResetResult(interp); /* our list is to be appended to result. */ DdeCreateClient(&es); EnumWindows(DdeEnumWindowsCallback, (LPARAM)&es); @@ -1263,11 +1291,11 @@ *---------------------------------------------------------------------- */ static int DdeObjCmd( - ClientData clientData, /* Used only for deletion */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* The interp we are sending from */ int objc, /* Number of arguments */ Tcl_Obj *const *objv) /* The arguments */ { static const char *const ddeCommands[] = { @@ -1300,15 +1328,16 @@ size_t length; int flags = 0, result = TCL_OK, firstArg = 0; HSZ ddeService = NULL, ddeTopic = NULL, ddeItem = NULL, ddeCookie = NULL; HDDEDATA ddeData = NULL, ddeItemData = NULL, ddeReturn; HCONV hConv = NULL; - const TCHAR *serviceName = NULL, *topicName = NULL; + const WCHAR *serviceName = NULL, *topicName = NULL; const char *string; DWORD ddeResult; Tcl_Obj *objPtr, *handlerPtr = NULL; Tcl_DString serviceBuf, topicBuf, itemBuf; + (void)dummy; /* * Initialize DDE server/client */ @@ -1460,34 +1489,36 @@ if (firstArg != 1) { const char *src = Tcl_GetString(objv[firstArg]); length = objv[firstArg]->length; - Tcl_WinUtfToTChar(src, length, &serviceBuf); - serviceName = (TCHAR *) Tcl_DStringValue(&serviceBuf); - length = Tcl_DStringLength(&serviceBuf) / sizeof(TCHAR); + Tcl_DStringInit(&serviceBuf); + Tcl_UtfToWCharDString(src, length, &serviceBuf); + serviceName = (WCHAR *) Tcl_DStringValue(&serviceBuf); + length = Tcl_DStringLength(&serviceBuf) / sizeof(WCHAR); } else { length = 0; } if (length == 0) { serviceName = NULL; } else if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) { - ddeService = DdeCreateStringHandle(ddeInstance, (void *) serviceName, + ddeService = DdeCreateStringHandleW(ddeInstance, serviceName, CP_WINUNICODE); } if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) { const char *src = Tcl_GetString(objv[firstArg + 1]); length = objv[firstArg + 1]->length; - topicName = Tcl_WinUtfToTChar(src, length, &topicBuf); - length = Tcl_DStringLength(&topicBuf) / sizeof(TCHAR); + Tcl_DStringInit(&topicBuf); + topicName = Tcl_UtfToWCharDString(src, length, &topicBuf); + length = Tcl_DStringLength(&topicBuf) / sizeof(WCHAR); if (length == 0) { topicName = NULL; } else { - ddeTopic = DdeCreateStringHandle(ddeInstance, (void *) topicName, + ddeTopic = DdeCreateStringHandleW(ddeInstance, topicName, CP_WINUNICODE); } } switch ((enum DdeSubcommands) index) { @@ -1495,11 +1526,12 @@ serviceName = DdeSetServerName(interp, serviceName, flags, handlerPtr); if (serviceName != NULL) { Tcl_DString dsBuf; - Tcl_WinTCharToUtf(serviceName, -1, &dsBuf); + Tcl_DStringInit(&dsBuf); + Tcl_WCharToUtfDString(serviceName, wcslen(serviceName), &dsBuf); Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_DStringValue(&dsBuf), Tcl_DStringLength(&dsBuf))); Tcl_DStringFree(&dsBuf); } else { Tcl_ResetResult(interp); @@ -1518,13 +1550,14 @@ } else { const char *src; src = Tcl_GetString(objv[firstArg + 2]); dataLength = objv[firstArg + 2]->length; - dataString = (const TCHAR *) - Tcl_WinUtfToTChar(src, dataLength, &dsBuf); - dataLength = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR); + Tcl_DStringInit(&dsBuf); + dataString = + Tcl_UtfToWCharDString(src, dataLength, &dsBuf); + dataLength = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR); } if (dataLength + 1 < 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj("cannot execute null data", -1)); @@ -1566,17 +1599,18 @@ } Tcl_DStringFree(&dsBuf); break; } case DDE_REQUEST: { - const TCHAR *itemString; + const WCHAR *itemString; const char *src; src = Tcl_GetString(objv[firstArg + 2]); length = objv[firstArg + 2]->length; - itemString = Tcl_WinUtfToTChar(src, length, &itemBuf); - length = Tcl_DStringLength(&itemBuf) / sizeof(TCHAR); + Tcl_DStringInit(&itemBuf); + itemString = Tcl_UtfToWCharDString(src, length, &itemBuf); + length = Tcl_DStringLength(&itemBuf) / sizeof(WCHAR); if (length == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("cannot request value of null data", -1)); Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL); @@ -1590,33 +1624,34 @@ if (hConv == NULL) { SetDdeError(interp); result = TCL_ERROR; } else { Tcl_Obj *returnObjPtr; - ddeItem = DdeCreateStringHandle(ddeInstance, (void *) itemString, + ddeItem = DdeCreateStringHandleW(ddeInstance, itemString, CP_WINUNICODE); if (ddeItem != NULL) { ddeData = DdeClientTransaction(NULL, 0, hConv, ddeItem, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_REQUEST, 5000, NULL); if (ddeData == NULL) { SetDdeError(interp); result = TCL_ERROR; } else { DWORD tmp; - TCHAR *dataString = (TCHAR *) DdeAccessData(ddeData, &tmp); + WCHAR *dataString = (WCHAR *) DdeAccessData(ddeData, &tmp); if (flags & DDE_FLAG_BINARY) { returnObjPtr = Tcl_NewByteArrayObj((BYTE *) dataString, tmp); } else { Tcl_DString dsBuf; - if ((tmp >= sizeof(TCHAR)) - && !dataString[tmp / sizeof(TCHAR) - 1]) { - tmp -= sizeof(TCHAR); + if ((tmp >= sizeof(WCHAR)) + && !dataString[tmp / sizeof(WCHAR) - 1]) { + tmp -= sizeof(WCHAR); } - Tcl_WinTCharToUtf(dataString, tmp, &dsBuf); + Tcl_DStringInit(&dsBuf); + Tcl_WCharToUtfDString(dataString, tmp>>1, &dsBuf); returnObjPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsBuf), Tcl_DStringLength(&dsBuf)); Tcl_DStringFree(&dsBuf); } @@ -1631,18 +1666,19 @@ } break; } case DDE_POKE: { Tcl_DString dsBuf; - const TCHAR *itemString; + const WCHAR *itemString; BYTE *dataString; const char *src; src = Tcl_GetString(objv[firstArg + 2]); length = objv[firstArg + 2]->length; - itemString = Tcl_WinUtfToTChar(src, length, &itemBuf); - length = Tcl_DStringLength(&itemBuf) / sizeof(TCHAR); + Tcl_DStringInit(&itemBuf); + itemString = Tcl_UtfToWCharDString(src, length, &itemBuf); + length = Tcl_DStringLength(&itemBuf) / sizeof(WCHAR); if (length == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("cannot have a null item", -1)); Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL); result = TCL_ERROR; @@ -1654,13 +1690,14 @@ getByteArrayFromObj(objv[firstArg + 3], &length); } else { const char *data = Tcl_GetString(objv[firstArg + 3]); length = objv[firstArg + 3]->length; + Tcl_DStringInit(&dsBuf); dataString = (BYTE *) - Tcl_WinUtfToTChar(data, length, &dsBuf); - length = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR); + Tcl_UtfToWCharDString(data, length, &dsBuf); + length = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR); } hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); DdeFreeStringHandle(ddeInstance, ddeService); DdeFreeStringHandle(ddeInstance, ddeTopic); @@ -1667,11 +1704,11 @@ if (hConv == NULL) { SetDdeError(interp); result = TCL_ERROR; } else { - ddeItem = DdeCreateStringHandle(ddeInstance, (void *) itemString, + ddeItem = DdeCreateStringHandleW(ddeInstance, itemString, CP_WINUNICODE); if (ddeItem != NULL) { ddeData = DdeClientTransaction(dataString, (DWORD) length, hConv, ddeItem, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_POKE, 5000, NULL); if (ddeData == NULL) { @@ -1715,11 +1752,11 @@ * bytecode structure would be referring to deallocated objects. */ for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; riPtr = riPtr->nextPtr) { - if (_tcsicmp(serviceName, riPtr->name) == 0) { + if (_wcsicmp(serviceName, riPtr->name) == 0) { break; } } if (riPtr != NULL) { @@ -1818,13 +1855,14 @@ } objPtr = Tcl_ConcatObj(objc, objv); string = Tcl_GetString(objPtr); length = objPtr->length; - Tcl_WinUtfToTChar(string, length, &dsBuf); + Tcl_DStringInit(&dsBuf); + Tcl_UtfToWCharDString(string, length, &dsBuf); string = Tcl_DStringValue(&dsBuf); - length = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR); + length = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR); ddeItemData = DdeCreateDataHandle(ddeInstance, (BYTE *) string, (DWORD) length, 0, 0, CF_UNICODETEXT, 0); Tcl_DStringFree(&dsBuf); if (flags & DDE_FLAG_ASYNC) { @@ -1835,11 +1873,11 @@ } else { ddeData = DdeClientTransaction((LPBYTE) ddeItemData, 0xFFFFFFFF, hConv, 0, CF_UNICODETEXT, XTYP_EXECUTE, 30000, NULL); if (ddeData != 0) { - ddeCookie = DdeCreateStringHandle(ddeInstance, + ddeCookie = DdeCreateStringHandleW(ddeInstance, TCL_DDE_EXECUTE_RESULT, CP_WINUNICODE); ddeData = DdeClientTransaction(NULL, 0, hConv, ddeCookie, CF_UNICODETEXT, XTYP_REQUEST, 30000, NULL); } } @@ -1852,11 +1890,11 @@ goto cleanup; } if (!(flags & DDE_FLAG_ASYNC)) { Tcl_Obj *resultPtr; - TCHAR *ddeDataString; + WCHAR *ddeDataString; /* * The return handle has a two or four element list in it. The * first element is the return code (TCL_OK, TCL_ERROR, etc.). * The second is the result of the script. If the return code @@ -1864,16 +1902,17 @@ * variable "errorCode", and the fourth is the value of the * variable "errorInfo". */ length = DdeGetData(ddeData, NULL, 0, 0); - ddeDataString = (TCHAR *) Tcl_Alloc(length); + ddeDataString = (WCHAR *) Tcl_Alloc(length); DdeGetData(ddeData, (BYTE *) ddeDataString, (DWORD) length, 0); - if (length > sizeof(TCHAR)) { - length -= sizeof(TCHAR); + if (length > sizeof(WCHAR)) { + length -= sizeof(WCHAR); } - Tcl_WinTCharToUtf(ddeDataString, length, &dsBuf); + Tcl_DStringInit(&dsBuf); + Tcl_WCharToUtfDString(ddeDataString, length>>1, &dsBuf); resultPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsBuf), Tcl_DStringLength(&dsBuf)); Tcl_DStringFree(&dsBuf); Tcl_Free((char *) ddeDataString); Index: win/tclWinError.c ================================================================== --- win/tclWinError.c +++ win/tclWinError.c @@ -379,21 +379,21 @@ * None. * *---------------------------------------------------------------------- */ -void +TCL_NORETURN void tclWinDebugPanic( const char *format, ...) { #define TCL_MAX_WARN_LEN 1024 va_list argList; va_start(argList, format); if (IsDebuggerPresent()) { WCHAR msgString[TCL_MAX_WARN_LEN]; - char buf[TCL_MAX_WARN_LEN * 3]; + char buf[TCL_MAX_WARN_LEN * TCL_UTF_MAX]; vsnprintf(buf, sizeof(buf), format, argList); msgString[TCL_MAX_WARN_LEN-1] = L'\0'; MultiByteToWideChar(CP_UTF8, 0, buf, -1, msgString, TCL_MAX_WARN_LEN); @@ -404,17 +404,20 @@ if (msgString[TCL_MAX_WARN_LEN-1] != L'\0') { memcpy(msgString + (TCL_MAX_WARN_LEN - 5), L" ...", 5 * sizeof(WCHAR)); } OutputDebugStringW(msgString); } else { - if (!isatty(fileno(stderr))) { - fprintf(stderr, "\xef\xbb\xbf"); - } vfprintf(stderr, format, argList); fprintf(stderr, "\n"); fflush(stderr); } +# if defined(__GNUC__) + __builtin_trap(); +# else + DebugBreak(); +# endif + abort(); } #endif /* * Local Variables: * mode: c Index: win/tclWinFCmd.c ================================================================== --- win/tclWinFCmd.c +++ win/tclWinFCmd.c @@ -161,11 +161,11 @@ #endif DWORD srcAttr, dstAttr; int retval = -1; /* - * The MoveFile API acts differently under Win95/98 and NT WRT NULL and + * The MoveFileW API acts differently under Win95/98 and NT WRT NULL and * "". Avoid passing these values. */ if (nativeSrc == NULL || nativeSrc[0] == '\0' || nativeDst == NULL || nativeDst[0] == '\0') { @@ -172,11 +172,11 @@ Tcl_SetErrno(ENOENT); return TCL_ERROR; } /* - * The MoveFile API would throw an exception under NT if one of the + * The MoveFileW API would throw an exception under NT if one of the * arguments is a char block device. */ #if defined(HAVE_NO_SEH) && !defined(_WIN64) /* @@ -193,40 +193,40 @@ "movl %[nativeDst], %%ebx" "\n\t" "movl %[nativeSrc], %%ecx" "\n\t" /* * Construct an TCLEXCEPTION_REGISTRATION to protect the call to - * MoveFile. + * MoveFileW. */ "leal %[registration], %%edx" "\n\t" "movl %%fs:0, %%eax" "\n\t" "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ "leal 1f, %%eax" "\n\t" "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ - "movl %%esp, 0xc(%%edx)" "\n\t" /* esp */ + "movl %%esp, 0xC(%%edx)" "\n\t" /* esp */ "movl $0, 0x10(%%edx)" "\n\t" /* status */ /* * Link the TCLEXCEPTION_REGISTRATION on the chain. */ "movl %%edx, %%fs:0" "\n\t" /* - * Call MoveFile(nativeSrc, nativeDst) + * Call MoveFileW(nativeSrc, nativeDst) */ "pushl %%ebx" "\n\t" "pushl %%ecx" "\n\t" - "movl %[moveFile], %%eax" "\n\t" + "movl %[moveFileW], %%eax" "\n\t" "call *%%eax" "\n\t" /* * Come here on normal exit. Recover the TCLEXCEPTION_REGISTRATION and - * put the status return from MoveFile into it. + * put the status return from MoveFileW into it. */ "movl %%fs:0, %%edx" "\n\t" "movl %%eax, 0x10(%%edx)" "\n\t" "jmp 2f" "\n" @@ -243,11 +243,11 @@ * Come here however we exited. Restore context from the * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" - "movl 0xc(%%edx), %%esp" "\n\t" + "movl 0xC(%%edx), %%esp" "\n\t" "movl 0x8(%%edx), %%ebp" "\n\t" "movl 0x0(%%edx), %%eax" "\n\t" "movl %%eax, %%fs:0" "\n\t" : @@ -254,11 +254,11 @@ /* No outputs */ : [registration] "m" (registration), [nativeDst] "m" (nativeDst), [nativeSrc] "m" (nativeSrc), - [moveFile] "r" (MoveFile) + [moveFileW] "r" (MoveFileW) : "%eax", "%ebx", "%ecx", "%edx", "memory" ); if (registration.status != FALSE) { retval = TCL_OK; @@ -265,11 +265,11 @@ } #else #ifndef HAVE_NO_SEH __try { #endif - if ((*MoveFile)(nativeSrc, nativeDst) != FALSE) { + if ((*MoveFileW)(nativeSrc, nativeDst) != FALSE) { retval = TCL_OK; } #ifndef HAVE_NO_SEH } __except (EXCEPTION_EXECUTE_HANDLER) {} #endif @@ -279,22 +279,22 @@ return retval; } TclWinConvertError(GetLastError()); - srcAttr = GetFileAttributes(nativeSrc); - dstAttr = GetFileAttributes(nativeDst); - if (srcAttr == 0xffffffff) { - if (GetFullPathName(nativeSrc, 0, NULL, + srcAttr = GetFileAttributesW(nativeSrc); + dstAttr = GetFileAttributesW(nativeDst); + if (srcAttr == 0xFFFFFFFF) { + if (GetFullPathNameW(nativeSrc, 0, NULL, NULL) >= MAX_PATH) { errno = ENAMETOOLONG; return TCL_ERROR; } srcAttr = 0; } - if (dstAttr == 0xffffffff) { - if (GetFullPathName(nativeDst, 0, NULL, + if (dstAttr == 0xFFFFFFFF) { + if (GetFullPathNameW(nativeDst, 0, NULL, NULL) >= MAX_PATH) { errno = ENAMETOOLONG; return TCL_ERROR; } dstAttr = 0; @@ -313,25 +313,25 @@ WCHAR nativeSrcPath[MAX_PATH]; WCHAR nativeDstPath[MAX_PATH]; Tcl_DString srcString, dstString; const char *src, *dst; - size = GetFullPathName(nativeSrc, MAX_PATH, + size = GetFullPathNameW(nativeSrc, MAX_PATH, nativeSrcPath, &nativeSrcRest); if ((size == 0) || (size > MAX_PATH)) { return TCL_ERROR; } - size = GetFullPathName(nativeDst, MAX_PATH, + size = GetFullPathNameW(nativeDst, MAX_PATH, nativeDstPath, &nativeDstRest); if ((size == 0) || (size > MAX_PATH)) { return TCL_ERROR; } - CharLower(nativeSrcPath); - CharLower(nativeDstPath); + CharLowerW(nativeSrcPath); + CharLowerW(nativeDstPath); - src = Tcl_WinTCharToUtf(nativeSrcPath, -1, &srcString); - dst = Tcl_WinTCharToUtf(nativeDstPath, -1, &dstString); + src = Tcl_WinTCharToUtf((TCHAR *)nativeSrcPath, -1, &srcString); + dst = Tcl_WinTCharToUtf((TCHAR *)nativeDstPath, -1, &dstString); /* * Check whether the destination path is actually inside the * source path. This is true if the prefix matches, and the next * character is either end-of-string or a directory separator @@ -367,19 +367,19 @@ /* * If src is a directory and dst filesystem != src filesystem, * errno should be EXDEV. It is very important to get this * behavior, so that the caller can respond to a cross * filesystem rename by simulating it with copy and delete. - * The MoveFile system call already handles the case of moving + * The MoveFileW system call already handles the case of moving * a file between filesystems. */ Tcl_SetErrno(EXDEV); } - Tcl_Free((void *)srcArgv); - Tcl_Free((void *)dstArgv); + ckfree(srcArgv); + ckfree(dstArgv); } /* * Other types of access failure is that dst is a read-only * filesystem, that an open file referred to src or dest, or that src @@ -406,11 +406,11 @@ * Now that that empty directory is gone, we can try * renaming again. If that fails, we'll put this empty * directory back, for completeness. */ - if (MoveFile(nativeSrc, + if (MoveFileW(nativeSrc, nativeDst) != FALSE) { return TCL_OK; } /* @@ -417,12 +417,12 @@ * Some new error has occurred. Don't know what it could * be, but report this one. */ TclWinConvertError(GetLastError()); - CreateDirectory(nativeDst, NULL); - SetFileAttributes(nativeDst, dstAttr); + CreateDirectoryW(nativeDst, NULL); + SetFileAttributesW(nativeDst, dstAttr); if (Tcl_GetErrno() == EACCES) { /* * Decode the EACCES to a more meaningful error. */ @@ -447,39 +447,39 @@ WCHAR *nativeRest, *nativeTmp, *nativePrefix; int result, size; WCHAR tempBuf[MAX_PATH]; - size = GetFullPathName(nativeDst, MAX_PATH, + size = GetFullPathNameW(nativeDst, MAX_PATH, tempBuf, &nativeRest); if ((size == 0) || (size > MAX_PATH) || (nativeRest == NULL)) { return TCL_ERROR; } nativeTmp = (WCHAR *) tempBuf; nativeRest[0] = L'\0'; result = TCL_ERROR; nativePrefix = (WCHAR *) L"tclr"; - if (GetTempFileName(nativeTmp, nativePrefix, + if (GetTempFileNameW(nativeTmp, nativePrefix, 0, tempBuf) != 0) { /* * Strictly speaking, need the following DeleteFile and - * MoveFile to be joined as an atomic operation so no + * MoveFileW to be joined as an atomic operation so no * other app comes along in the meantime and creates the * same temp file. */ nativeTmp = tempBuf; - DeleteFile(nativeTmp); - if (MoveFile(nativeDst, nativeTmp) != FALSE) { - if (MoveFile(nativeSrc, nativeDst) != FALSE) { - SetFileAttributes(nativeTmp, FILE_ATTRIBUTE_NORMAL); - DeleteFile(nativeTmp); + DeleteFileW(nativeTmp); + if (MoveFileW(nativeDst, nativeTmp) != FALSE) { + if (MoveFileW(nativeSrc, nativeDst) != FALSE) { + SetFileAttributesW(nativeTmp, FILE_ATTRIBUTE_NORMAL); + DeleteFileW(nativeTmp); return TCL_OK; } else { - DeleteFile(nativeDst); - MoveFile(nativeTmp, nativeDst); + DeleteFileW(nativeDst); + MoveFileW(nativeTmp, nativeDst); } } /* * Can't backup dst file or move src file. Return that @@ -589,24 +589,24 @@ "movl %%fs:0, %%eax" "\n\t" "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ "leal 1f, %%eax" "\n\t" "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ - "movl %%esp, 0xc(%%edx)" "\n\t" /* esp */ + "movl %%esp, 0xC(%%edx)" "\n\t" /* esp */ "movl $0, 0x10(%%edx)" "\n\t" /* status */ /* * Link the TCLEXCEPTION_REGISTRATION on the chain. */ "movl %%edx, %%fs:0" "\n\t" /* - * Call CopyFile(nativeSrc, nativeDst, 0) + * Call CopyFileW(nativeSrc, nativeDst, 0) */ - "movl %[copyFile], %%eax" "\n\t" + "movl %[copyFileW], %%eax" "\n\t" "pushl $0" "\n\t" "pushl %%ebx" "\n\t" "pushl %%ecx" "\n\t" "call *%%eax" "\n\t" @@ -631,11 +631,11 @@ * Come here however we exited. Restore context from the * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" - "movl 0xc(%%edx), %%esp" "\n\t" + "movl 0xC(%%edx), %%esp" "\n\t" "movl 0x8(%%edx), %%ebp" "\n\t" "movl 0x0(%%edx), %%eax" "\n\t" "movl %%eax, %%fs:0" "\n\t" : @@ -642,11 +642,11 @@ /* No outputs */ : [registration] "m" (registration), [nativeDst] "m" (nativeDst), [nativeSrc] "m" (nativeSrc), - [copyFile] "r" (CopyFile) + [copyFileW] "r" (CopyFileW) : "%eax", "%ebx", "%ecx", "%edx", "memory" ); if (registration.status != FALSE) { retval = TCL_OK; @@ -653,11 +653,11 @@ } #else #ifndef HAVE_NO_SEH __try { #endif - if (CopyFile(nativeSrc, nativeDst, 0) != FALSE) { + if (CopyFileW(nativeSrc, nativeDst, 0) != FALSE) { retval = TCL_OK; } #ifndef HAVE_NO_SEH } __except (EXCEPTION_EXECUTE_HANDLER) {} #endif @@ -673,14 +673,14 @@ return TCL_ERROR; } if (Tcl_GetErrno() == EACCES) { DWORD srcAttr, dstAttr; - srcAttr = GetFileAttributes(nativeSrc); - dstAttr = GetFileAttributes(nativeDst); - if (srcAttr != 0xffffffff) { - if (dstAttr == 0xffffffff) { + srcAttr = GetFileAttributesW(nativeSrc); + dstAttr = GetFileAttributesW(nativeDst); + if (srcAttr != 0xFFFFFFFF) { + if (dstAttr == 0xFFFFFFFF) { dstAttr = 0; } if ((srcAttr & FILE_ATTRIBUTE_DIRECTORY) || (dstAttr & FILE_ATTRIBUTE_DIRECTORY)) { if (srcAttr & FILE_ATTRIBUTE_REPARSE_POINT) { @@ -690,13 +690,13 @@ } } Tcl_SetErrno(EISDIR); } if (dstAttr & FILE_ATTRIBUTE_READONLY) { - SetFileAttributes(nativeDst, + SetFileAttributesW(nativeDst, dstAttr & ~((DWORD)FILE_ATTRIBUTE_READONLY)); - if (CopyFile(nativeSrc, nativeDst, + if (CopyFileW(nativeSrc, nativeDst, 0) != FALSE) { return TCL_OK; } /* @@ -703,11 +703,11 @@ * Still can't copy onto dst. Return that error, and restore * attributes of dst. */ TclWinConvertError(GetLastError()); - SetFileAttributes(nativeDst, dstAttr); + SetFileAttributesW(nativeDst, dstAttr); } } } return TCL_ERROR; } @@ -759,18 +759,18 @@ if (path == NULL || path[0] == '\0') { Tcl_SetErrno(ENOENT); return TCL_ERROR; } - if (DeleteFile(path) != FALSE) { + if (DeleteFileW(path) != FALSE) { return TCL_OK; } TclWinConvertError(GetLastError()); if (Tcl_GetErrno() == EACCES) { - attr = GetFileAttributes(path); - if (attr != 0xffffffff) { + attr = GetFileAttributesW(path); + if (attr != 0xFFFFFFFF) { if (attr & FILE_ATTRIBUTE_DIRECTORY) { if (attr & FILE_ATTRIBUTE_REPARSE_POINT) { /* * It is a symbolic link - remove it. */ @@ -786,26 +786,26 @@ * of EISDIR. */ Tcl_SetErrno(EISDIR); } else if (attr & FILE_ATTRIBUTE_READONLY) { - int res = SetFileAttributes(path, + int res = SetFileAttributesW(path, attr & ~((DWORD) FILE_ATTRIBUTE_READONLY)); if ((res != 0) && - (DeleteFile(path) != FALSE)) { + (DeleteFileW(path) != FALSE)) { return TCL_OK; } TclWinConvertError(GetLastError()); if (res != 0) { - SetFileAttributes(path, attr); + SetFileAttributesW(path, attr); } } } } else if (Tcl_GetErrno() == ENOENT) { - attr = GetFileAttributes(path); - if (attr != 0xffffffff) { + attr = GetFileAttributesW(path); + if (attr != 0xFFFFFFFF) { if (attr & FILE_ATTRIBUTE_DIRECTORY) { /* * Windows 95 reports removing a directory as ENOENT instead * of EISDIR. */ @@ -859,11 +859,11 @@ static int DoCreateDirectory( const WCHAR *nativePath) /* Pathname of directory to create (native). */ { - if (CreateDirectory(nativePath, NULL) == 0) { + if (CreateDirectoryW(nativePath, NULL) == 0) { DWORD error = GetLastError(); TclWinConvertError(error); return TCL_ERROR; } @@ -909,12 +909,12 @@ normDestPtr = Tcl_FSGetNormalizedPath(NULL,destPathPtr); if ((normSrcPtr == NULL) || (normDestPtr == NULL)) { return TCL_ERROR; } - Tcl_WinUtfToTChar(TclGetString(normSrcPtr), -1, &srcString); - Tcl_WinUtfToTChar(TclGetString(normDestPtr), -1, &dstString); + Tcl_WinUtfToTChar(Tcl_GetString(normSrcPtr), -1, &srcString); + Tcl_WinUtfToTChar(Tcl_GetString(normDestPtr), -1, &dstString); ret = TraverseWinTree(TraversalCopy, &srcString, &dstString, &ds); Tcl_DStringFree(&srcString); Tcl_DStringFree(&dstString); @@ -982,11 +982,11 @@ Tcl_DString native; normPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); if (normPtr == NULL) { return TCL_ERROR; } - Tcl_WinUtfToTChar(TclGetString(normPtr), -1, &native); + Tcl_WinUtfToTChar(Tcl_GetString(normPtr), -1, &native); ret = DoRemoveDirectory(&native, recursive, &ds); Tcl_DStringFree(&native); } else { ret = DoRemoveJustDirectory(Tcl_FSGetNativePath(pathPtr), 0, &ds); } @@ -1028,11 +1028,11 @@ Tcl_SetErrno(ENOENT); Tcl_DStringInit(errorPtr); return TCL_ERROR; } - attr = GetFileAttributes(nativePath); + attr = GetFileAttributesW(nativePath); if (attr & FILE_ATTRIBUTE_REPARSE_POINT) { /* * It is a symbolic link - remove it. */ @@ -1042,20 +1042,20 @@ } else { /* * Ordinary directory. */ - if (RemoveDirectory(nativePath) != FALSE) { + if (RemoveDirectoryW(nativePath) != FALSE) { return TCL_OK; } } TclWinConvertError(GetLastError()); if (Tcl_GetErrno() == EACCES) { - attr = GetFileAttributes(nativePath); - if (attr != 0xffffffff) { + attr = GetFileAttributesW(nativePath); + if (attr != 0xFFFFFFFF) { if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) { /* * Windows 95 reports calling RemoveDirectory on a file as an * EACCES, not an ENOTDIR. */ @@ -1074,19 +1074,19 @@ } } if (attr & FILE_ATTRIBUTE_READONLY) { attr &= ~FILE_ATTRIBUTE_READONLY; - if (SetFileAttributes(nativePath, + if (SetFileAttributesW(nativePath, attr) == FALSE) { goto end; } - if (RemoveDirectory(nativePath) != FALSE) { + if (RemoveDirectoryW(nativePath) != FALSE) { return TCL_OK; } TclWinConvertError(GetLastError()); - SetFileAttributes(nativePath, + SetFileAttributesW(nativePath, attr | FILE_ATTRIBUTE_READONLY); } } } @@ -1107,11 +1107,11 @@ return TCL_ERROR; } end: if (errorPtr != NULL) { - char *p = Tcl_WinTCharToUtf(nativePath, -1, errorPtr); + char *p = Tcl_WinTCharToUtf((TCHAR *)nativePath, -1, errorPtr); for (; *p; ++p) { if (*p == '\\') *p = '/'; } } return TCL_ERROR; @@ -1181,11 +1181,11 @@ { DWORD sourceAttr; WCHAR *nativeSource, *nativeTarget, *nativeErrfile; int result, found, sourceLen, targetLen = 0, oldSourceLen, oldTargetLen; HANDLE handle; - WIN32_FIND_DATA data; + WIN32_FIND_DATAW data; nativeErrfile = NULL; result = TCL_OK; oldTargetLen = 0; /* lint. */ @@ -1192,12 +1192,12 @@ nativeSource = (WCHAR *) Tcl_DStringValue(sourcePtr); nativeTarget = (WCHAR *) (targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr)); oldSourceLen = Tcl_DStringLength(sourcePtr); - sourceAttr = GetFileAttributes(nativeSource); - if (sourceAttr == 0xffffffff) { + sourceAttr = GetFileAttributesW(nativeSource); + if (sourceAttr == 0xFFFFFFFF) { nativeErrfile = nativeSource; goto end; } if (sourceAttr & FILE_ATTRIBUTE_REPARSE_POINT) { @@ -1219,11 +1219,11 @@ Tcl_DStringAppend(sourcePtr, (char *) L"\\*.*", 4 * sizeof(WCHAR) + 1); Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1); nativeSource = (WCHAR *) Tcl_DStringValue(sourcePtr); - handle = FindFirstFile(nativeSource, &data); + handle = FindFirstFileW(nativeSource, &data); if (handle == INVALID_HANDLE_VALUE) { /* * Can't read directory. */ @@ -1252,13 +1252,13 @@ Tcl_DStringAppend(targetPtr, (char *) L"\\", sizeof(WCHAR) + 1); Tcl_DStringSetLength(targetPtr, targetLen); } found = 1; - for (; found; found = FindNextFile(handle, &data)) { + for (; found; found = FindNextFileW(handle, &data)) { WCHAR *nativeName; - int len; + size_t len; WCHAR *wp = data.cFileName; if (*wp == '.') { wp++; if (*wp == '.') { @@ -1321,11 +1321,11 @@ end: if (nativeErrfile != NULL) { TclWinConvertError(GetLastError()); if (errorPtr != NULL) { - Tcl_WinTCharToUtf(nativeErrfile, -1, errorPtr); + Tcl_WinTCharToUtf((TCHAR *)nativeErrfile, -1, errorPtr); } result = TCL_ERROR; } return result; @@ -1367,13 +1367,13 @@ return TCL_OK; } break; case DOTREE_PRED: if (DoCreateDirectory(nativeDst) == TCL_OK) { - DWORD attr = GetFileAttributes(nativeSrc); + DWORD attr = GetFileAttributesW(nativeSrc); - if (SetFileAttributes(nativeDst, + if (SetFileAttributesW(nativeDst, attr) != FALSE) { return TCL_OK; } TclWinConvertError(GetLastError()); } @@ -1386,11 +1386,11 @@ * There shouldn't be a problem with src, because we already checked it to * get here. */ if (errorPtr != NULL) { - Tcl_WinTCharToUtf(nativeDst, -1, errorPtr); + Tcl_WinTCharToUtf((TCHAR *)nativeDst, -1, errorPtr); } return TCL_ERROR; } /* @@ -1441,11 +1441,11 @@ } break; } if (errorPtr != NULL) { - Tcl_WinTCharToUtf(nativeSrc, -1, errorPtr); + Tcl_WinTCharToUtf((TCHAR *)nativeSrc, -1, errorPtr); } return TCL_ERROR; } /* @@ -1505,13 +1505,13 @@ DWORD result; const WCHAR *nativeName; int attr; nativeName = Tcl_FSGetNativePath(fileName); - result = GetFileAttributes(nativeName); + result = GetFileAttributesW(nativeName); - if (result == 0xffffffff) { + if (result == 0xFFFFFFFF) { StatError(interp, fileName); return TCL_ERROR; } attr = (int)(result & attributeArray[objIndex]); @@ -1522,12 +1522,12 @@ * they are not (and cannot be). * * We test for, and fix that case, here. */ - size_t len; - const char *str = TclGetStringFromObj(fileName, &len); + int len; + const char *str = Tcl_GetStringFromObj(fileName,&len); if (len < 4) { if (len == 0) { /* * Not sure if this is possible, but we pass it on anyway. @@ -1547,11 +1547,11 @@ attr = 0; } } } - *attributePtrPtr = Tcl_NewWideIntObj(attr != 0); + *attributePtrPtr = Tcl_NewBooleanObj(attr); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -1584,19 +1584,18 @@ int longShort, /* 0 to short name, 1 to long name. */ Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ { int pathc, i; Tcl_Obj *splitPath; - size_t length; splitPath = Tcl_FSSplitPath(fileName, &pathc); if (splitPath == NULL || pathc == 0) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "could not read \"%s\": no such file or directory", - TclGetString(fileName))); + Tcl_GetString(fileName))); errno = ENOENT; Tcl_PosixError(interp); } goto cleanup; } @@ -1609,15 +1608,16 @@ Tcl_IncrRefCount(splitPath); for (i = 0; i < pathc; i++) { Tcl_Obj *elt; char *pathv; + int pathLen; Tcl_ListObjIndex(NULL, splitPath, i, &elt); - pathv = TclGetStringFromObj(elt, &length); - if ((pathv[0] == '/') || ((length == 3) && (pathv[1] == ':')) + pathv = Tcl_GetStringFromObj(elt, &pathLen); + if ((pathv[0] == '/') || ((pathLen == 3) && (pathv[1] == ':')) || (strcmp(pathv, ".") == 0) || (strcmp(pathv, "..") == 0)) { /* * Handle "/", "//machine/export", "c:/", "." or ".." by just * copying the string literally. Uppercase the drive letter, just * because it looks better under Windows to do so. @@ -1636,11 +1636,12 @@ Tcl_Obj *tempPath; Tcl_DString ds; Tcl_DString dsTemp; const WCHAR *nativeName; const char *tempString; - WIN32_FIND_DATA data; + int tempLen; + WIN32_FIND_DATAW data; HANDLE handle; DWORD attr; tempPath = Tcl_FSJoinPath(splitPath, i+1); Tcl_IncrRefCount(tempPath); @@ -1648,23 +1649,24 @@ /* * We'd like to call Tcl_FSGetNativePath(tempPath) but that is * likely to lead to infinite loops. */ - tempString = TclGetStringFromObj(tempPath, &length); - nativeName = Tcl_WinUtfToTChar(tempString, length, &ds); + Tcl_DStringInit(&ds); + tempString = Tcl_GetStringFromObj(tempPath,&tempLen); + nativeName = (WCHAR *)Tcl_WinUtfToTChar(tempString, tempLen, &ds); Tcl_DecrRefCount(tempPath); - handle = FindFirstFile(nativeName, &data); + handle = FindFirstFileW(nativeName, &data); if (handle == INVALID_HANDLE_VALUE) { /* - * FindFirstFile() doesn't like root directories. We would + * FindFirstFileW() doesn't like root directories. We would * only get a root directory here if the caller specified "c:" * or "c:." and the current directory on the drive was the * root directory */ - attr = GetFileAttributes(nativeName); + attr = GetFileAttributesW(nativeName); if ((attr!=0xFFFFFFFF) && (attr & FILE_ATTRIBUTE_DIRECTORY)) { Tcl_DStringFree(&ds); goto simple; } } @@ -1698,11 +1700,11 @@ * fprintf(stderr, "%d\n", data.w.cAlternateFileName[0]); * fprintf(stderr, "%d\n", ((WCHAR *) nativeName)[0]); */ Tcl_DStringInit(&dsTemp); - Tcl_WinTCharToUtf(nativeName, -1, &dsTemp); + Tcl_WinTCharToUtf((TCHAR *)nativeName, -1, &dsTemp); Tcl_DStringFree(&ds); /* * Deal with issues of tildes being absolute. */ @@ -1830,13 +1832,13 @@ DWORD fileAttributes, old; int yesNo, result; const WCHAR *nativeName; nativeName = Tcl_FSGetNativePath(fileName); - fileAttributes = old = GetFileAttributes(nativeName); + fileAttributes = old = GetFileAttributesW(nativeName); - if (fileAttributes == 0xffffffff) { + if (fileAttributes == 0xFFFFFFFF) { StatError(interp, fileName); return TCL_ERROR; } result = Tcl_GetBooleanFromObj(interp, attributePtr, &yesNo); @@ -1849,11 +1851,11 @@ } else { fileAttributes &= ~(attributeArray[objIndex]); } if ((fileAttributes != old) - && !SetFileAttributes(nativeName, fileAttributes)) { + && !SetFileAttributesW(nativeName, fileAttributes)) { StatError(interp, fileName); return TCL_ERROR; } return result; @@ -1882,11 +1884,11 @@ Tcl_Obj *fileName, /* The name of the file. */ Tcl_Obj *attributePtr) /* The new value of the attribute. */ { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "cannot set attribute \"%s\" for file \"%s\": attribute is readonly", - tclpFileAttrStrings[objIndex], TclGetString(fileName))); + tclpFileAttrStrings[objIndex], Tcl_GetString(fileName))); errno = EINVAL; Tcl_PosixError(interp); return TCL_ERROR; } @@ -1912,24 +1914,24 @@ Tcl_Obj *resultPtr, *elemPtr; char buf[40 * 4]; /* There couldn't be more than 30 drives??? */ int i; char *p; - resultPtr = Tcl_NewObj(); + TclNewObj(resultPtr); /* * On Win32s: * GetLogicalDriveStrings() isn't implemented. * GetLogicalDrives() returns incorrect information. */ if (GetLogicalDriveStringsA(sizeof(buf), buf) == 0) { /* - * GetVolumeInformation() will detects all drives, but causes + * GetVolumeInformationW() will detect all drives, but causes * chattering on empty floppy drives. We only do this if * GetLogicalDriveStrings() didn't work. It has also been reported - * that on some laptops it takes a while for GetVolumeInformation() to + * that on some laptops it takes a while for GetVolumeInformationW() to * return when pinging an empty floppy drive, another reason to try to * avoid calling it. */ buf[1] = ':'; @@ -1953,128 +1955,13 @@ } Tcl_IncrRefCount(resultPtr); return resultPtr; } - -/* - *---------------------------------------------------------------------- - * - * TclpCreateTemporaryDirectory -- - * - * Creates a temporary directory, possibly based on the supplied bits and - * pieces of template supplied in the arguments. - * - * Results: - * An object (refcount 0) containing the name of the newly-created - * directory, or NULL on failure. - * - * Side effects: - * Accesses the native filesystem. Makes a directory. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclpCreateTemporaryDirectory( - Tcl_Obj *dirObj, - Tcl_Obj *basenameObj) -{ - Tcl_DString base, name; /* Contains WCHARs */ - int baseLen; - DWORD error; - WCHAR tempBuf[MAX_PATH + 1]; - DWORD len = GetTempPathW(MAX_PATH, tempBuf); - - /* - * Build the path in writable memory from the user-supplied pieces and - * some defaults. First, the parent temporary directory. - */ - - if (dirObj) { - Tcl_GetString(dirObj); - if (dirObj->length < 1) { - goto useSystemTemp; - } - Tcl_WinUtfToTChar(Tcl_GetString(dirObj), -1, &base); - if (dirObj->bytes[dirObj->length - 1] != '\\') { - TclUtfToWCharDString("\\", -1, &base); - } - } else { - useSystemTemp: - Tcl_DStringInit(&base); - Tcl_DStringAppend(&base, (char *) tempBuf, len * sizeof(WCHAR)); - } - - /* - * Next, the base of the directory name. - */ - -#define DEFAULT_TEMP_DIR_PREFIX "tcl" -#define SUFFIX_LENGTH 8 - - if (basenameObj) { - Tcl_WinUtfToTChar(Tcl_GetString(basenameObj), -1, &name); - TclDStringAppendDString(&base, &name); - Tcl_DStringFree(&name); - } else { - TclUtfToWCharDString(DEFAULT_TEMP_DIR_PREFIX, -1, &base); - } - TclUtfToWCharDString("_", -1, &base); - - /* - * Now we keep on trying random suffixes until we get one that works - * (i.e., that doesn't trigger the ERROR_ALREADY_EXISTS error). Note that - * SUFFIX_LENGTH is longer than on Unix because we expect to be not on a - * case-sensitive filesystem. - */ - - baseLen = Tcl_DStringLength(&base); - do { - char tempbuf[SUFFIX_LENGTH + 1]; - int i; - static const char randChars[] = - "QWERTYUIOPASDFGHJKLZXCVBNM1234567890"; - static const int numRandChars = sizeof(randChars) - 1; - - /* - * Put a random suffix on the end. - */ - - error = ERROR_SUCCESS; - tempbuf[SUFFIX_LENGTH] = '\0'; - for (i = 0 ; i < SUFFIX_LENGTH; i++) { - tempbuf[i] = randChars[(int) (rand() % numRandChars)]; - } - Tcl_DStringSetLength(&base, baseLen); - TclUtfToWCharDString(tempbuf, -1, &base); - } while (!CreateDirectoryW((LPCWSTR) Tcl_DStringValue(&base), NULL) - && (error = GetLastError()) == ERROR_ALREADY_EXISTS); - - /* - * Check for other errors. The big ones are ERROR_PATH_NOT_FOUND and - * ERROR_ACCESS_DENIED. - */ - - if (error != ERROR_SUCCESS) { - TclWinConvertError(error); - Tcl_DStringFree(&base); - return NULL; - } - - /* - * We actually made the directory, so we're done! Report what we made back - * as a (clean) Tcl_Obj. - */ - - Tcl_WinTCharToUtf((LPCWSTR) Tcl_DStringValue(&base), -1, &name); - Tcl_DStringFree(&base); - return TclDStringToObj(&name); -} /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: win/tclWinFile.c ================================================================== --- win/tclWinFile.c +++ win/tclWinFile.c @@ -175,11 +175,11 @@ static Tcl_Obj * WinReadLinkDirectory(const WCHAR *LinkDirectory); static int WinLink(const WCHAR *LinkSource, const WCHAR *LinkTarget, int linkAction); static int WinSymLinkDirectory(const WCHAR *LinkDirectory, const WCHAR *LinkTarget); -MODULE_SCOPE void tclWinDebugPanic(const char *format, ...); +MODULE_SCOPE TCL_NORETURN void tclWinDebugPanic(const char *format, ...); /* *-------------------------------------------------------------------- * * WinLink -- @@ -201,11 +201,11 @@ /* * Get the full path referenced by the target. */ - if (!GetFullPathName(linkTargetPath, MAX_PATH, tempFileName, + if (!GetFullPathNameW(linkTargetPath, MAX_PATH, tempFileName, &tempFilePart)) { /* * Invalid file. */ @@ -215,21 +215,21 @@ /* * Make sure source file doesn't exist. */ - attr = GetFileAttributes(linkSourcePath); + attr = GetFileAttributesW(linkSourcePath); if (attr != INVALID_FILE_ATTRIBUTES) { Tcl_SetErrno(EEXIST); return -1; } /* * Get the full path referenced by the source file/directory. */ - if (!GetFullPathName(linkSourcePath, MAX_PATH, tempFileName, + if (!GetFullPathNameW(linkSourcePath, MAX_PATH, tempFileName, &tempFilePart)) { /* * Invalid file. */ @@ -239,11 +239,11 @@ /* * Check the target. */ - attr = GetFileAttributes(linkTargetPath); + attr = GetFileAttributesW(linkTargetPath); if (attr == INVALID_FILE_ATTRIBUTES) { /* * The target doesn't exist. */ @@ -252,11 +252,11 @@ /* * It is a file. */ if (linkAction & TCL_CREATE_HARD_LINK) { - if (CreateHardLink(linkSourcePath, linkTargetPath, NULL)) { + if (CreateHardLinkW(linkSourcePath, linkTargetPath, NULL)) { /* * Success! */ return 0; @@ -314,11 +314,11 @@ /* * Get the full path referenced by the target. */ - if (!GetFullPathName(linkSourcePath, MAX_PATH, tempFileName, + if (!GetFullPathNameW(linkSourcePath, MAX_PATH, tempFileName, &tempFilePart)) { /* * Invalid file. */ @@ -328,11 +328,11 @@ /* * Make sure source file does exist. */ - attr = GetFileAttributes(linkSourcePath); + attr = GetFileAttributesW(linkSourcePath); if (attr == INVALID_FILE_ATTRIBUTES) { /* * The source doesn't exist. */ @@ -393,15 +393,15 @@ * forward slashes everything appears to work, but the resulting symlink * is useless! */ for (loop = nativeTarget; *loop != 0; loop++) { - if (*loop == L'/') { - *loop = L'\\'; + if (*loop == '/') { + *loop = '\\'; } } - if ((nativeTarget[len-1] == L'\\') && (nativeTarget[len-2] != L':')) { + if ((nativeTarget[len-1] == '\\') && (nativeTarget[len-2] != ':')) { nativeTarget[len-1] = 0; } /* * Build the reparse info. @@ -485,11 +485,11 @@ HANDLE hFile; DWORD returnedLength; memset(reparseBuffer, 0, sizeof(DUMMY_REPARSE_BUFFER)); reparseBuffer->ReparseTag = IO_REPARSE_TAG_MOUNT_POINT; - hFile = CreateFile(linkOrigPath, GENERIC_WRITE, 0, NULL, OPEN_EXISTING, + hFile = CreateFileW(linkOrigPath, GENERIC_WRITE, 0, NULL, OPEN_EXISTING, FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, NULL); if (hFile != INVALID_HANDLE_VALUE) { if (!DeviceIoControl(hFile, FSCTL_DELETE_REPARSE_POINT, reparseBuffer, REPARSE_MOUNTPOINT_HEADER_SIZE,NULL,0,&returnedLength,NULL)) { @@ -500,11 +500,11 @@ TclWinConvertError(GetLastError()); CloseHandle(hFile); } else { CloseHandle(hFile); if (!linkOnly) { - RemoveDirectory(linkOrigPath); + RemoveDirectoryW(linkOrigPath); } return 0; } } return -1; @@ -545,11 +545,11 @@ REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER *) &dummy; Tcl_Obj *retVal; Tcl_DString ds; const char *copy; - attr = GetFileAttributes(linkDirPath); + attr = GetFileAttributesW(linkDirPath); if (!(attr & FILE_ATTRIBUTE_REPARSE_POINT)) { goto invalidError; } if (NativeReadReparse(linkDirPath, reparseBuffer, 0)) { return NULL; @@ -570,11 +570,11 @@ * which support reparse tags at present. If that changes in the * future, this code will have to be generalised. */ offset = 0; - if (reparseBuffer->MountPointReparseBuffer.PathBuffer[0] == L'\\') { + if (reparseBuffer->MountPointReparseBuffer.PathBuffer[0] == '\\') { /* * Check whether this is a mounted volume. */ if (wcsncmp(reparseBuffer->MountPointReparseBuffer.PathBuffer, @@ -584,11 +584,11 @@ /* * There is some confusion between \??\ and \\?\ which we have * to fix here. It doesn't seem very well documented. */ - reparseBuffer->MountPointReparseBuffer.PathBuffer[1]=L'\\'; + reparseBuffer->MountPointReparseBuffer.PathBuffer[1] = '\\'; /* * Check if a corresponding drive letter exists, and use that * if it is found */ @@ -632,11 +632,11 @@ offset = 4; } } - Tcl_WinTCharToUtf( + Tcl_WinTCharToUtf((TCHAR *) reparseBuffer->MountPointReparseBuffer.PathBuffer, reparseBuffer->MountPointReparseBuffer .SubstituteNameLength, &ds); copy = Tcl_DStringValue(&ds)+offset; @@ -678,11 +678,11 @@ DWORD desiredAccess) { HANDLE hFile; DWORD returnedLength; - hFile = CreateFile(linkDirPath, desiredAccess, FILE_SHARE_READ, NULL, + hFile = CreateFileW(linkDirPath, desiredAccess, FILE_SHARE_READ, NULL, OPEN_EXISTING, FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, NULL); if (hFile == INVALID_HANDLE_VALUE) { /* @@ -738,19 +738,19 @@ /* * Create the directory - it must not already exist. */ - if (CreateDirectory(linkDirPath, NULL) == 0) { + if (CreateDirectoryW(linkDirPath, NULL) == 0) { /* * Error creating directory. */ TclWinConvertError(GetLastError()); return -1; } - hFile = CreateFile(linkDirPath, GENERIC_WRITE, 0, NULL, + hFile = CreateFileW(linkDirPath, GENERIC_WRITE, 0, NULL, OPEN_EXISTING, FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, NULL); if (hFile == INVALID_HANDLE_VALUE) { /* * Error creating directory. @@ -771,11 +771,11 @@ * Error setting junction. */ TclWinConvertError(GetLastError()); CloseHandle(hFile); - RemoveDirectory(linkDirPath); + RemoveDirectoryW(linkDirPath); return -1; } CloseHandle(hFile); /* @@ -800,11 +800,11 @@ * None. * *---------------------------------------------------------------------- */ -void +TCL_NORETURN void tclWinDebugPanic( const char *format, ...) { #define TCL_MAX_WARN_LEN 1024 va_list argList; @@ -812,28 +812,38 @@ WCHAR msgString[TCL_MAX_WARN_LEN]; va_start(argList, format); vsnprintf(buf, sizeof(buf), format, argList); - msgString[TCL_MAX_WARN_LEN-1] = L'\0'; + msgString[TCL_MAX_WARN_LEN-1] = '\0'; MultiByteToWideChar(CP_UTF8, 0, buf, -1, msgString, TCL_MAX_WARN_LEN); /* * Truncate MessageBox string if it is too long to not overflow the screen * and cause possible oversized window error. */ - if (msgString[TCL_MAX_WARN_LEN-1] != L'\0') { + if (msgString[TCL_MAX_WARN_LEN-1] != '\0') { memcpy(msgString + (TCL_MAX_WARN_LEN - 5), L" ...", 5 * sizeof(WCHAR)); } if (IsDebuggerPresent()) { OutputDebugStringW(msgString); } else { MessageBeep(MB_ICONEXCLAMATION); MessageBoxW(NULL, msgString, L"Fatal Error", MB_ICONSTOP | MB_OK | MB_TASKMODAL | MB_SETFOREGROUND); } +#if defined(__GNUC__) + __builtin_trap(); +#elif defined(_WIN64) + __debugbreak(); +#elif defined(_MSC_VER) && defined (_M_IX86) + _asm {int 3} +#else + DebugBreak(); +#endif + abort(); } /* *--------------------------------------------------------------------------- * @@ -856,10 +866,19 @@ const char *argv0) /* If NULL, install PanicMessageBox, otherwise * ignore. */ { WCHAR wName[MAX_PATH]; char name[MAX_PATH * 3]; + + /* + * Under Windows we ignore argv0, and return the path for the file used to + * create this process. Only if it is NULL, install a new panic handler. + */ + + if (argv0 == NULL) { + Tcl_SetPanicProc(tclWinDebugPanic); + } GetModuleFileNameW(NULL, wName, MAX_PATH); WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, sizeof(name), NULL, NULL); TclWinNoBackslash(name); TclSetObjNameOfExecutable(Tcl_NewStringObj(name, -1), NULL); @@ -910,35 +929,35 @@ if (norm != NULL) { /* * Match a single file directly. */ + int len; DWORD attr; WIN32_FILE_ATTRIBUTE_DATA data; - size_t length = 0; - const char *str = TclGetStringFromObj(norm, &length); + const char *str = Tcl_GetStringFromObj(norm,&len); native = Tcl_FSGetNativePath(pathPtr); - if (GetFileAttributesEx(native, + if (GetFileAttributesExW(native, GetFileExInfoStandard, &data) != TRUE) { return TCL_OK; } attr = data.dwFileAttributes; - if (NativeMatchType(WinIsDrive(str, length), attr, native, types)) { + if (NativeMatchType(WinIsDrive(str,len), attr, native, types)) { Tcl_ListObjAppendElement(interp, resultPtr, pathPtr); } } return TCL_OK; } else { DWORD attr; HANDLE handle; - WIN32_FIND_DATA data; + WIN32_FIND_DATAW data; const char *dirName; /* UTF-8 dir name, later with pattern * appended. */ - size_t dirLength; + int dirLength; int matchSpecialDots; Tcl_DString ds; /* Native encoding of dir, also used * temporarily for other things. */ Tcl_DString dsOrig; /* UTF-8 encoding of dir. */ Tcl_Obj *fileNamePtr; @@ -960,11 +979,11 @@ native = Tcl_FSGetNativePath(pathPtr); if (native == NULL) { return TCL_OK; } - attr = GetFileAttributes(native); + attr = GetFileAttributesW(native); if ((attr == INVALID_FILE_ATTRIBUTES) || ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0)) { return TCL_OK; } @@ -973,11 +992,11 @@ * Build up the directory name for searching, including a trailing * directory separator. */ Tcl_DStringInit(&dsOrig); - dirName = TclGetStringFromObj(fileNamePtr, &dirLength); + dirName = Tcl_GetStringFromObj(fileNamePtr, &dirLength); Tcl_DStringAppend(&dsOrig, dirName, dirLength); lastChar = dirName[dirLength -1]; if ((lastChar != '\\') && (lastChar != '/') && (lastChar != ':')) { TclDStringAppendLiteral(&dsOrig, "/"); @@ -1001,19 +1020,19 @@ dirName = Tcl_DStringAppend(&dsOrig, pattern, -1); } else { dirName = TclDStringAppendLiteral(&dsOrig, "*.*"); } - native = Tcl_WinUtfToTChar(dirName, -1, &ds); + native = (WCHAR *)Tcl_WinUtfToTChar(dirName, -1, &ds); if ((types == NULL) || (types->type != TCL_GLOB_TYPE_DIR)) { - handle = FindFirstFile(native, &data); + handle = FindFirstFileW(native, &data); } else { /* * We can be more efficient, for pure directory requests. */ - handle = FindFirstFileEx(native, + handle = FindFirstFileExW(native, FindExInfoStandard, &data, FindExSearchLimitToDirectories, NULL, 0); } if (handle == INVALID_HANDLE_VALUE) { @@ -1070,15 +1089,14 @@ */ do { const char *utfname; int checkDrive = 0, isDrive; - DWORD attr; native = data.cFileName; attr = data.dwFileAttributes; - utfname = Tcl_WinTCharToUtf(native, -1, &ds); + utfname = Tcl_WinTCharToUtf((TCHAR *)native, -1, &ds); if (!matchSpecialDots) { /* * If it is exactly '.' or '..' then we ignore it. */ @@ -1134,11 +1152,11 @@ /* * Free ds here to ensure that native is valid above. */ Tcl_DStringFree(&ds); - } while (FindNextFile(handle, &data) == TRUE); + } while (FindNextFileW(handle, &data) == TRUE); FindClose(handle); Tcl_DStringFree(&dsOrig); return TCL_OK; } @@ -1420,11 +1438,10 @@ Tcl_DString ds; int nameLen = -1; int rc = 0; const char *domain; WCHAR *wName, *wHomeDir, *wDomain; - WCHAR buf[MAX_PATH]; Tcl_DStringInit(bufferPtr); wDomain = NULL; domain = Tcl_UtfFindFirst(name, '@'); @@ -1448,19 +1465,17 @@ result = Tcl_DStringValue(bufferPtr); } } Tcl_DStringFree(&ds); } else { - Tcl_DStringInit(&ds); - wName = TclUtfToWCharDString(domain + 1, -1, &ds); + wName = (WCHAR *)Tcl_WinUtfToTChar(domain + 1, -1, &ds); rc = NetGetDCName(NULL, wName, (LPBYTE *) &wDomain); Tcl_DStringFree(&ds); nameLen = domain - name; } if (rc == 0) { - Tcl_DStringInit(&ds); - wName = TclUtfToWCharDString(name, nameLen, &ds); + wName = (WCHAR *)Tcl_WinUtfToTChar(name, nameLen, &ds); while (NetUserGetInfo(wDomain, wName, 1, (LPBYTE *) &uiPtr) != 0) { /* * User does not exist; if domain was not specified, try again * using current domain. */ @@ -1482,21 +1497,22 @@ } if (rc == 0) { DWORD i, size = MAX_PATH; wHomeDir = uiPtr->usri1_home_dir; - if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) { + if ((wHomeDir != NULL) && (wHomeDir[0] != '\0')) { size = lstrlenW(wHomeDir); - TclWCharToUtfDString(wHomeDir, size, bufferPtr); + Tcl_WinTCharToUtf((TCHAR *)wHomeDir, size*sizeof(WCHAR), bufferPtr); } else { + WCHAR buf[MAX_PATH]; /* * User exists but has no home dir. Return * "{GetProfilesDirectory}/". */ GetProfilesDirectoryW(buf, &size); - TclWCharToUtfDString(buf, size-1, bufferPtr); + Tcl_WinTCharToUtf((TCHAR *)buf, (size-1)*sizeof(WCHAR), bufferPtr); Tcl_DStringAppend(bufferPtr, "/", 1); Tcl_DStringAppend(bufferPtr, name, nameLen); } result = Tcl_DStringValue(bufferPtr); @@ -1568,11 +1584,11 @@ const WCHAR *nativePath, /* Path of file to access, native encoding. */ int mode) /* Permission setting. */ { DWORD attr; - attr = GetFileAttributes(nativePath); + attr = GetFileAttributesW(nativePath); if (attr == INVALID_FILE_ATTRIBUTES) { /* * File might not exist. */ @@ -1637,11 +1653,11 @@ } if (mode & X_OK) { mask |= GENERIC_EXECUTE; } - hFile = CreateFile(nativePath, mask, + hFile = CreateFileW(nativePath, mask, FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE, NULL, OPEN_EXISTING, FILE_FLAG_NO_BUFFERING, NULL); if (hFile != INVALID_HANDLE_VALUE) { CloseHandle(hFile); return 0; @@ -1687,11 +1703,11 @@ /* * First find out how big the buffer needs to be. */ size = 0; - GetFileSecurity(nativePath, + GetFileSecurityW(nativePath, OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION | LABEL_SECURITY_INFORMATION, 0, 0, &size); /* @@ -1718,14 +1734,14 @@ if (sdPtr == NULL) { goto accessError; } /* - * Call GetFileSecurity() for real. + * Call GetFileSecurityW() for real. */ - if (!GetFileSecurity(nativePath, + if (!GetFileSecurityW(nativePath, OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION | LABEL_SECURITY_INFORMATION, sdPtr, size, &size)) { /* * Error getting owner SD @@ -1851,11 +1867,11 @@ static int NativeIsExec( const WCHAR *path) { - int len = wcslen(path); + size_t len = wcslen(path); if (len < 5) { return 0; } @@ -1862,15 +1878,15 @@ if (path[len-4] != '.') { return 0; } path += len-3; - if ((wcsicmp(path, L"exe") == 0) - || (wcsicmp(path, L"com") == 0) - || (wcsicmp(path, L"cmd") == 0) - || (wcsicmp(path, L"cmd") == 0) - || (wcsicmp(path, L"bat") == 0)) { + if ((_wcsicmp(path, L"exe") == 0) + || (_wcsicmp(path, L"com") == 0) + || (_wcsicmp(path, L"cmd") == 0) + || (_wcsicmp(path, L"cmd") == 0) + || (_wcsicmp(path, L"bat") == 0)) { return 1; } return 0; } @@ -1900,11 +1916,11 @@ nativePath = Tcl_FSGetNativePath(pathPtr); if (!nativePath) { return -1; } - result = SetCurrentDirectory(nativePath); + result = SetCurrentDirectoryW(nativePath); if (result == 0) { TclWinConvertError(GetLastError()); return -1; } @@ -1941,11 +1957,11 @@ { WCHAR buffer[MAX_PATH]; char *p; WCHAR *native; - if (GetCurrentDirectory(MAX_PATH, buffer) == 0) { + if (GetCurrentDirectoryW(MAX_PATH, buffer) == 0) { TclWinConvertError(GetLastError()); if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "error getting working directory name: %s", Tcl_PosixError(interp))); @@ -1960,11 +1976,11 @@ native = (WCHAR *) buffer; if ((native[0] != '\0') && (native[1] == ':') && (native[2] == '\\') && (native[3] == '\\')) { native += 2; } - Tcl_WinTCharToUtf(native, -1, bufferPtr); + Tcl_WinTCharToUtf((TCHAR *) native, -1, bufferPtr); /* * Convert to forward slashes for easier use in scripts. */ @@ -2041,11 +2057,11 @@ * default). However the subsequent GetFileInformationByHandle will * fail. We do a WinIsReserved to see if it is one of the special names, * and if successful, mock up a BY_HANDLE_FILE_INFORMATION structure. */ - fileHandle = CreateFile(nativePath, GENERIC_READ, + fileHandle = CreateFileW(nativePath, GENERIC_READ, FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE, NULL, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OPEN_REPARSE_POINT, NULL); if (fileHandle != INVALID_HANDLE_VALUE) { @@ -2099,21 +2115,21 @@ * Fall back on the less capable routines. This means no nlink or ino. */ WIN32_FILE_ATTRIBUTE_DATA data; - if (GetFileAttributesEx(nativePath, + if (GetFileAttributesExW(nativePath, GetFileExInfoStandard, &data) != TRUE) { HANDLE hFind; - WIN32_FIND_DATA ffd; + WIN32_FIND_DATAW ffd; DWORD lasterror = GetLastError(); if (lasterror != ERROR_SHARING_VIOLATION) { TclWinConvertError(lasterror); return -1; } - hFind = FindFirstFile(nativePath, &ffd); + hFind = FindFirstFileW(nativePath, &ffd); if (hFind == INVALID_HANDLE_VALUE) { TclWinConvertError(GetLastError()); return -1; } memcpy(&data, &ffd, sizeof(data)); @@ -2167,12 +2183,12 @@ Tcl_DString ds; WCHAR nativeFullPath[MAX_PATH]; WCHAR *nativePart; const char *fullPath; - GetFullPathName(nativePath, MAX_PATH, nativeFullPath, &nativePart); - fullPath = Tcl_WinTCharToUtf(nativeFullPath, -1, &ds); + GetFullPathNameW(nativePath, MAX_PATH, nativeFullPath, &nativePart); + fullPath = Tcl_WinTCharToUtf((TCHAR *)nativeFullPath, -1, &ds); if ((fullPath[0] == '\\') && (fullPath[1] == '\\')) { const char *p; DWORD dw; const WCHAR *nativeVol; @@ -2189,17 +2205,17 @@ fullPath = TclDStringAppendLiteral(&ds, "\\"); p = fullPath + Tcl_DStringLength(&ds); } else { p++; } - nativeVol = Tcl_WinUtfToTChar(fullPath, p - fullPath, &volString); + nativeVol = (WCHAR *)Tcl_WinUtfToTChar(fullPath, p - fullPath, &volString); dw = (DWORD) -1; - GetVolumeInformation(nativeVol, NULL, 0, &dw, NULL, NULL, NULL, 0); + GetVolumeInformationW(nativeVol, NULL, 0, &dw, NULL, NULL, NULL, 0); /* - * GetFullPathName() turns special devices like "NUL" into "\\.\NUL", - * but GetVolumeInformation() returns failure for "\\.\NUL". This will + * GetFullPathNameW() turns special devices like "NUL" into "\\.\NUL", + * but GetVolumeInformationW() returns failure for "\\.\NUL". This will * cause "NUL" to get a drive number of -1, which makes about as much * sense as anything since the special devices don't live on any * drive. */ @@ -2337,11 +2353,11 @@ TclpGetNativeCwd( ClientData clientData) { WCHAR buffer[MAX_PATH]; - if (GetCurrentDirectory(MAX_PATH, buffer) == 0) { + if (GetCurrentDirectoryW(MAX_PATH, buffer) == 0) { TclWinConvertError(GetLastError()); return NULL; } if (clientData != NULL) { @@ -2446,34 +2462,34 @@ Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr); if (normPath == NULL) { return NULL; } - path = TclGetString(normPath); + path = Tcl_GetString(normPath); if (path == NULL) { return NULL; } firstSeparator = strchr(path, '/'); if (firstSeparator == NULL) { - found = GetVolumeInformation(Tcl_FSGetNativePath(pathPtr), + found = GetVolumeInformationW(Tcl_FSGetNativePath(pathPtr), NULL, 0, NULL, NULL, NULL, volType, VOL_BUF_SIZE); } else { Tcl_Obj *driveName = Tcl_NewStringObj(path, firstSeparator - path+1); Tcl_IncrRefCount(driveName); - found = GetVolumeInformation(Tcl_FSGetNativePath(driveName), + found = GetVolumeInformationW(Tcl_FSGetNativePath(driveName), NULL, 0, NULL, NULL, NULL, volType, VOL_BUF_SIZE); Tcl_DecrRefCount(driveName); } if (found == 0) { return NULL; } else { Tcl_DString ds; - Tcl_WinTCharToUtf(volType, -1, &ds); + Tcl_WinTCharToUtf((TCHAR *)volType, -1, &ds); return TclDStringToObj(&ds); } #undef VOL_BUF_SIZE } @@ -2513,22 +2529,23 @@ */ int TclpObjNormalizePath( Tcl_Interp *interp, - Tcl_Obj *pathPtr, - int nextCheckpoint) + Tcl_Obj *pathPtr, /* An unshared object containing the path to + * normalize */ + 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_DStringInit(&dsNorm); - path = TclGetString(pathPtr); + path = Tcl_GetString(pathPtr); currentPathEndPosition = path + nextCheckpoint; if (*currentPathEndPosition == '/') { currentPathEndPosition++; } @@ -2539,14 +2556,14 @@ /* * Reached directory separator, or end of string. */ WIN32_FILE_ATTRIBUTE_DATA data; - const WCHAR *nativePath = Tcl_WinUtfToTChar(path, + const WCHAR *nativePath = (WCHAR *)Tcl_WinUtfToTChar(path, currentPathEndPosition - path, &ds); - if (GetFileAttributesEx(nativePath, + if (GetFileAttributesExW(nativePath, GetFileExInfoStandard, &data) != TRUE) { /* * File doesn't exist. */ @@ -2561,12 +2578,12 @@ int i; for (i=0 ; i= L'a') { - wc -= (L'a' - L'A'); + if (wc >= 'a') { + wc -= ('a' - 'A'); ((WCHAR *) nativePath)[i] = wc; } } Tcl_DStringAppend(&dsNorm, (const char *)nativePath, @@ -2619,16 +2636,16 @@ /* * Convert link to forward slashes. */ - for (path = TclGetString(to); *path != 0; path++) { + for (path = Tcl_GetString(to); *path != 0; path++) { if (*path == '\\') { *path = '/'; } } - path = TclGetString(to); + path = Tcl_GetString(to); currentPathEndPosition = path + nextCheckpoint; if (temp != NULL) { Tcl_DecrRefCount(temp); } temp = to; @@ -2652,12 +2669,12 @@ */ if (isDrive) { WCHAR drive = ((WCHAR *) nativePath)[0]; - if (drive >= L'a') { - drive -= (L'a' - L'A'); + if (drive >= 'a') { + drive -= ('a' - 'A'); ((WCHAR *) nativePath)[0] = drive; } Tcl_DStringAppend(&dsNorm, (const char *)nativePath, Tcl_DStringLength(&ds)); } else { @@ -2750,12 +2767,12 @@ /* * We have to make the drive letter uppercase. */ - if (wpath[0] >= L'a') { - wpath[0] -= (L'a' - L'A'); + if (wpath[0] >= 'a') { + wpath[0] -= ('a' - 'A'); } Tcl_DStringAppend(&dsNorm, (const char *) wpath, wpathlen * sizeof(WCHAR)); Tcl_DStringFree(&ds); } @@ -2772,27 +2789,26 @@ * Concatenate the normalized string in dsNorm with the tail of the * path which we didn't recognise. The string in dsNorm is in the * native encoding, so we have to convert it to Utf. */ - Tcl_WinTCharToUtf((const WCHAR *) Tcl_DStringValue(&dsNorm), + Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&dsNorm), Tcl_DStringLength(&dsNorm), &ds); nextCheckpoint = Tcl_DStringLength(&ds); if (*lastValidPathEnd != 0) { /* * Not the end of the string. */ - char *path; + int len; Tcl_Obj *tmpPathPtr; - size_t length; tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), nextCheckpoint); Tcl_AppendToObj(tmpPathPtr, lastValidPathEnd, -1); - path = TclGetStringFromObj(tmpPathPtr, &length); - Tcl_SetStringObj(pathPtr, path, length); + path = Tcl_GetStringFromObj(tmpPathPtr, &len); + Tcl_SetStringObj(pathPtr, path, len); Tcl_DecrRefCount(tmpPathPtr); } else { /* * End of string was reached above. */ @@ -2856,11 +2872,11 @@ /* * Path of form /foo/bar which is a path in the root directory of the * current volume. */ - const char *drive = TclGetString(useThisCwd); + const char *drive = Tcl_GetString(useThisCwd); absolutePath = Tcl_NewStringObj(drive,2); Tcl_AppendToObj(absolutePath, path, -1); Tcl_IncrRefCount(absolutePath); @@ -2871,12 +2887,13 @@ /* * Path of form C:foo/bar, but this only makes sense if the cwd is * also on drive C. */ - size_t cwdLen; - const char *drive = TclGetStringFromObj(useThisCwd, &cwdLen); + int cwdLen; + const char *drive = + Tcl_GetStringFromObj(useThisCwd, &cwdLen); char drive_cur = path[0]; if (drive_cur >= 'a') { drive_cur -= ('a' - 'A'); } @@ -2945,14 +2962,14 @@ TclpNativeToNormalized( ClientData clientData) { Tcl_DString ds; Tcl_Obj *objPtr; - size_t len; + int len; char *copy, *p; - Tcl_WinTCharToUtf((const WCHAR *) clientData, -1, &ds); + Tcl_WinTCharToUtf((TCHAR *) clientData, -1, &ds); copy = Tcl_DStringValue(&ds); len = Tcl_DStringLength(&ds); /* * Certain native path representations on Windows have this special prefix @@ -2995,11 +3012,11 @@ * * Results: * The nativePath representation. * * Side effects: - * Memory will be allocated. The path may need to be normalized. + * Memory will be allocated. The path might be normalized. * *--------------------------------------------------------------------------- */ ClientData @@ -3044,11 +3061,12 @@ */ Tcl_IncrRefCount(validPathPtr); } - str = TclGetStringFromObj(validPathPtr, &len); + str = Tcl_GetString(validPathPtr); + len = validPathPtr->length; if (strlen(str) != len) { /* * String contains NUL-bytes. This is invalid. */ @@ -3075,11 +3093,11 @@ /* * Overallocate 6 chars, making some room for extended paths */ - wp = nativePathPtr = Tcl_Alloc((len + 6) * sizeof(WCHAR)); + wp = nativePathPtr = ckalloc((len + 6) * sizeof(WCHAR)); if (nativePathPtr==0) { goto done; } MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, nativePathPtr, len + 1); @@ -3173,11 +3191,11 @@ return NULL; } len = sizeof(WCHAR) * (wcslen((const WCHAR *) clientData) + 1); - copy = Tcl_Alloc(len); + copy = ckalloc(len); memcpy(copy, clientData, len); return copy; } /* @@ -3212,11 +3230,11 @@ FromCTime(tval->actime, &lastAccessTime); FromCTime(tval->modtime, &lastModTime); native = Tcl_FSGetNativePath(pathPtr); - attr = GetFileAttributes(native); + attr = GetFileAttributesW(native); if (attr != INVALID_FILE_ATTRIBUTES && attr & FILE_ATTRIBUTE_DIRECTORY) { flags = FILE_FLAG_BACKUP_SEMANTICS; } @@ -3223,11 +3241,11 @@ /* * We use the native APIs (not 'utime') because there are some daylight * savings complications that utime gets wrong. */ - fileHandle = CreateFile(native, FILE_WRITE_ATTRIBUTES, 0, NULL, + fileHandle = CreateFileW(native, FILE_WRITE_ATTRIBUTES, 0, NULL, OPEN_EXISTING, flags, NULL); if (fileHandle == INVALID_HANDLE_VALUE || !SetFileTime(fileHandle, NULL, &lastAccessTime, &lastModTime)) { TclWinConvertError(GetLastError()); @@ -3263,11 +3281,11 @@ DWORD bufsz; int owned = 0; native = Tcl_FSGetNativePath(pathPtr); - if (GetNamedSecurityInfo((LPTSTR) native, SE_FILE_OBJECT, + if (GetNamedSecurityInfoW((LPWSTR) native, SE_FILE_OBJECT, OWNER_SECURITY_INFORMATION, &ownerSid, NULL, NULL, NULL, &secd) != ERROR_SUCCESS) { /* * Either not a file, or we do not have access to it in which case we * are in all likelihood not the owner. @@ -3289,11 +3307,11 @@ */ bufsz = 0; GetTokenInformation(token, TokenUser, NULL, 0, &bufsz); if (bufsz) { - buf = Tcl_Alloc(bufsz); + buf = ckalloc(bufsz); if (GetTokenInformation(token, TokenUser, buf, bufsz, &bufsz)) { owned = EqualSid(ownerSid, ((PTOKEN_USER) buf)->User.Sid); } } CloseHandle(token); @@ -3305,11 +3323,11 @@ if (secd) { LocalFree(secd); /* Also frees ownerSid */ } if (buf) { - Tcl_Free(buf); + ckfree(buf); } return (owned != 0); /* Convert non-0 to 1 */ } Index: win/tclWinInit.c ================================================================== --- win/tclWinInit.c +++ win/tclWinInit.c @@ -15,11 +15,11 @@ #include #include #include /* - * GetUserName() is found in advapi32.dll + * GetUserNameW() is found in advapi32.dll */ #ifdef _MSC_VER # pragma comment(lib, "advapi32.lib") #endif @@ -81,14 +81,13 @@ * Windows version dependend functions */ TclWinProcs tclWinProcs; /* - * The following arrays contain the human readable strings for the Windows + * The following arrays contain the human readable strings for the * processor values. */ - #define NUMPROCESSORS 11 static const char *const processors[NUMPROCESSORS] = { "intel", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil", "amd64", "ia32_on_win64" @@ -105,17 +104,23 @@ static TclInitProcessGlobalValueProc InitializeSourceLibraryDir; static ProcessGlobalValue sourceLibraryDir = {0, 0, NULL, NULL, InitializeSourceLibraryDir, NULL, NULL}; static void AppendEnvironment(Tcl_Obj *listPtr, const char *lib); + +#if TCL_UTF_MAX < 4 +static void ToUtf(const WCHAR *wSrc, char *dst); +#else +#define ToUtf(wSrc, dst) WideCharToMultiByte(CP_UTF8, 0, wSrc, -1, dst, MAX_PATH * TCL_UTF_MAX, NULL, NULL) +#endif /* *--------------------------------------------------------------------------- * * TclpInitPlatform -- * - * Initialize all the platform-dependant things like signals, + * Initialize all the platform-dependent things like signals, * floating-point error handling and sockets. * * Called at process initialization time. * * Results: @@ -147,19 +152,19 @@ * If we are in a statically linked executable, then we need to explicitly * initialize the Windows function tables here since DllMain() will not be * invoked. */ - TclWinInit(GetModuleHandle(NULL)); + TclWinInit(GetModuleHandleW(NULL)); #endif /* * Fill available functions depending on windows version */ - handle = GetModuleHandle(L"KERNEL32"); + handle = GetModuleHandleW(L"KERNEL32"); tclWinProcs.cancelSynchronousIo = - (BOOL (WINAPI *)(HANDLE)) GetProcAddress(handle, + (BOOL (WINAPI *)(HANDLE))(void *)GetProcAddress(handle, "CancelSynchronousIo"); } /* *------------------------------------------------------------------------- @@ -179,20 +184,19 @@ */ void TclpInitLibraryPath( char **valuePtr, - size_t *lengthPtr, + int *lengthPtr, Tcl_Encoding *encodingPtr) { #define LIBRARY_SIZE 64 Tcl_Obj *pathPtr; char installLib[LIBRARY_SIZE]; const char *bytes; - size_t length; - pathPtr = Tcl_NewObj(); + TclNewObj(pathPtr); /* * Initialize the substring used when locating the script library. The * installLib variable computes the script library path relative to the * installed DLL. @@ -222,14 +226,13 @@ Tcl_ListObjAppendElement(NULL, pathPtr, TclGetProcessGlobalValue(&sourceLibraryDir)); *encodingPtr = NULL; - bytes = TclGetStringFromObj(pathPtr, &length); - *lengthPtr = length++; - *valuePtr = Tcl_Alloc(length); - memcpy(*valuePtr, bytes, length); + bytes = Tcl_GetStringFromObj(pathPtr, lengthPtr); + *valuePtr = (char *)ckalloc(*lengthPtr + 1); + memcpy(*valuePtr, bytes, *lengthPtr + 1); Tcl_DecrRefCount(pathPtr); } /* *--------------------------------------------------------------------------- @@ -284,22 +287,26 @@ /* * The "L" preceeding the TCL_LIBRARY string is used to tell VC++ that * this is a unicode string. */ - GetEnvironmentVariableW(L"TCL_LIBRARY", wBuf, MAX_PATH); - WideCharToMultiByte(CP_UTF8, 0, wBuf, -1, buf, MAX_PATH * 3, NULL, NULL); + if (GetEnvironmentVariableW(L"TCL_LIBRARY", wBuf, MAX_PATH) == 0) { + buf[0] = '\0'; + GetEnvironmentVariableA("TCL_LIBRARY", buf, MAX_PATH); + } else { + ToUtf(wBuf, buf); + } if (buf[0] != '\0') { objPtr = Tcl_NewStringObj(buf, -1); Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); TclWinNoBackslash(buf); Tcl_SplitPath(buf, &pathc, &pathv); /* - * The lstrcmpi() will work even if pathv[pathc-1] is random UTF-8 + * The lstrcmpiA() will work even if pathv[pathc-1] is random UTF-8 * chars because I know shortlib is ascii. */ if ((pathc > 0) && (lstrcmpiA(shortlib, pathv[pathc - 1]) != 0)) { /* @@ -315,11 +322,11 @@ objPtr = TclDStringToObj(&ds); } else { objPtr = Tcl_NewStringObj(buf, -1); } Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); - Tcl_Free((void *)pathv); + ckfree(pathv); } } /* *--------------------------------------------------------------------------- @@ -339,20 +346,23 @@ */ static void InitializeDefaultLibraryDir( char **valuePtr, - size_t *lengthPtr, + int *lengthPtr, Tcl_Encoding *encodingPtr) { HMODULE hModule = TclWinGetTclInstance(); WCHAR wName[MAX_PATH + LIBRARY_SIZE]; char name[(MAX_PATH + LIBRARY_SIZE) * 3]; char *end, *p; - GetModuleFileNameW(hModule, wName, MAX_PATH); - WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, MAX_PATH * 3, NULL, NULL); + if (GetModuleFileNameW(hModule, wName, MAX_PATH) == 0) { + GetModuleFileNameA(hModule, name, MAX_PATH); + } else { + ToUtf(wName, name); + } end = strrchr(name, '\\'); *end = '\0'; p = strrchr(name, '\\'); if (p != NULL) { @@ -361,11 +371,11 @@ *end = '\\'; TclWinNoBackslash(name); sprintf(end + 1, "lib/tcl%s", TCL_VERSION); *lengthPtr = strlen(name); - *valuePtr = Tcl_Alloc(*lengthPtr + 1); + *valuePtr = (char *)ckalloc(*lengthPtr + 1); *encodingPtr = NULL; memcpy(*valuePtr, name, *lengthPtr + 1); } /* @@ -387,20 +397,23 @@ */ static void InitializeSourceLibraryDir( char **valuePtr, - size_t *lengthPtr, + int *lengthPtr, Tcl_Encoding *encodingPtr) { HMODULE hModule = TclWinGetTclInstance(); WCHAR wName[MAX_PATH + LIBRARY_SIZE]; - char name[(MAX_PATH + LIBRARY_SIZE) * 3]; + char name[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX]; char *end, *p; - GetModuleFileNameW(hModule, wName, MAX_PATH); - WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, MAX_PATH * 3, NULL, NULL); + if (GetModuleFileNameW(hModule, wName, MAX_PATH) == 0) { + GetModuleFileNameA(hModule, name, MAX_PATH); + } else { + ToUtf(wName, name); + } end = strrchr(name, '\\'); *end = '\0'; p = strrchr(name, '\\'); if (p != NULL) { @@ -409,15 +422,45 @@ *end = '\\'; TclWinNoBackslash(name); sprintf(end + 1, "../library"); *lengthPtr = strlen(name); - *valuePtr = Tcl_Alloc(*lengthPtr + 1); + *valuePtr = (char *)ckalloc(*lengthPtr + 1); *encodingPtr = NULL; memcpy(*valuePtr, name, *lengthPtr + 1); } +/* + *--------------------------------------------------------------------------- + * + * ToUtf -- + * + * Convert a wchar string to a UTF string. + * + * Results: + * None. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +#if TCL_UTF_MAX < 4 +static void +ToUtf( + const WCHAR *wSrc, + char *dst) +{ + while (*wSrc != '\0') { + dst += Tcl_UniCharToUtf(*wSrc, dst); + wSrc++; + } + *dst = '\0'; +} +#endif + /* *--------------------------------------------------------------------------- * * TclpSetInitialEncodings -- * @@ -447,19 +490,31 @@ Tcl_SetSystemEncoding(NULL, Tcl_GetEncodingNameFromEnvironment(&encodingName)); Tcl_DStringFree(&encodingName); } + +void TclWinSetInterfaces( + int dummy) /* Not used. */ +{ + (void)dummy; +} const char * Tcl_GetEncodingNameFromEnvironment( Tcl_DString *bufPtr) { + UINT acp = GetACP(); + Tcl_DStringInit(bufPtr); - Tcl_DStringSetLength(bufPtr, 2+TCL_INTEGER_SPACE); - wsprintfA(Tcl_DStringValue(bufPtr), "cp%d", GetACP()); - Tcl_DStringSetLength(bufPtr, strlen(Tcl_DStringValue(bufPtr))); + if (acp == CP_UTF8) { + Tcl_DStringAppend(bufPtr, "utf-8", 5); + } else { + Tcl_DStringSetLength(bufPtr, 2+TCL_INTEGER_SPACE); + wsprintfA(Tcl_DStringValue(bufPtr), "cp%d", GetACP()); + Tcl_DStringSetLength(bufPtr, strlen(Tcl_DStringValue(bufPtr))); + } return Tcl_DStringValue(bufPtr); } const char * TclpGetUserName( @@ -470,16 +525,16 @@ if (TclGetEnv("USERNAME", bufferPtr) == NULL) { WCHAR szUserName[UNLEN+1]; DWORD cchUserNameLen = UNLEN; - if (!GetUserName(szUserName, &cchUserNameLen)) { + if (!GetUserNameW(szUserName, &cchUserNameLen)) { return NULL; } cchUserNameLen--; cchUserNameLen *= sizeof(WCHAR); - Tcl_WinTCharToUtf(szUserName, cchUserNameLen, bufferPtr); + Tcl_WinTCharToUtf((TCHAR *)szUserName, cchUserNameLen, bufferPtr); } return Tcl_DStringValue(bufferPtr); } /* @@ -515,13 +570,13 @@ Tcl_SetVar2Ex(interp, "tclDefaultLibrary", NULL, TclGetProcessGlobalValue(&defaultLibraryDir), TCL_GLOBAL_ONLY); if (!osInfoInitialized) { - HMODULE handle = GetModuleHandle(L"NTDLL"); + HMODULE handle = GetModuleHandleW(L"NTDLL"); int(__stdcall *getversion)(void *) = - (int(__stdcall *)(void *)) GetProcAddress(handle, "RtlGetVersion"); + (int(__stdcall *)(void *))(void *)GetProcAddress(handle, "RtlGetVersion"); osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW); if (!getversion || getversion(&osInfo)) { GetVersionExW(&osInfo); } osInfoInitialized = 1; @@ -532,20 +587,21 @@ * Define the tcl_platform array. */ Tcl_SetVar2(interp, "tcl_platform", "platform", "windows", TCL_GLOBAL_ONLY); - Tcl_SetVar2(interp, "tcl_platform", "os", "Windows NT", TCL_GLOBAL_ONLY); + Tcl_SetVar2(interp, "tcl_platform", "os", + "Windows NT", TCL_GLOBAL_ONLY); wsprintfA(buffer, "%d.%d", osInfo.dwMajorVersion, osInfo.dwMinorVersion); Tcl_SetVar2(interp, "tcl_platform", "osVersion", buffer, TCL_GLOBAL_ONLY); if (sys.oemId.wProcessorArchitecture < NUMPROCESSORS) { Tcl_SetVar2(interp, "tcl_platform", "machine", processors[sys.oemId.wProcessorArchitecture], TCL_GLOBAL_ONLY); } -#ifdef _DEBUG +#ifndef NDEBUG /* * The existence of the "debug" element of the tcl_platform array * indicates that this particular Tcl shell has been compiled with debug * information. Using "info exists tcl_platform(debug)" a Tcl script can * direct the interpreter to load debug versions of DLLs with the load @@ -606,58 +662,60 @@ * Locate the entry in environ for a given name. On Unix this routine is * case sensitive, on Windows this matches mixed case. * * Results: * The return value is the index in environ of an entry with the name - * "name", or TCL_IO_FAILURE if there is no such entry. The integer - * at *lengthPtr is filled in with the length of name (if a matching - * entry is found) or the length of the environ array (if no - * matching entry is found). + * "name", or -1 if there is no such entry. The integer at *lengthPtr is + * filled in with the length of name (if a matching entry is found) or + * the length of the environ array (if no matching entry is found). * * Side effects: * None. * *---------------------------------------------------------------------- */ -size_t +int TclpFindVariable( const char *name, /* Name of desired environment variable * (UTF-8). */ - size_t *lengthPtr) /* Used to return length of name (for + int *lengthPtr) /* Used to return length of name (for * successful searches) or number of non-NULL * entries in environ (for unsuccessful * searches). */ { - size_t i, length, result = TCL_IO_FAILURE; - register const char *env, *p1, *p2; + int i, length, result = -1; + const WCHAR *env; + const char *p1, *p2; char *envUpper, *nameUpper; Tcl_DString envString; /* * Convert the name to all upper case for the case insensitive comparison. */ length = strlen(name); - nameUpper = Tcl_Alloc(length + 1); + nameUpper = (char *)ckalloc(length + 1); memcpy(nameUpper, name, length+1); Tcl_UtfToUpper(nameUpper); Tcl_DStringInit(&envString); - for (i = 0, env = environ[i]; env != NULL; i++, env = environ[i]) { + for (i = 0, env = _wenviron[i]; + env != NULL; + i++, env = _wenviron[i]) { /* * Chop the env string off after the equal sign, then Convert the name * to all upper case, so we do not have to convert all the characters * after the equal sign. */ - envUpper = Tcl_ExternalToUtfDString(NULL, env, -1, &envString); + envUpper = Tcl_WinTCharToUtf((TCHAR *)env, -1, &envString); p1 = strchr(envUpper, '='); if (p1 == NULL) { continue; } - length = p1 - envUpper; + length = (int) (p1 - envUpper); Tcl_DStringSetLength(&envString, length+1); Tcl_UtfToUpper(envUpper); p1 = envUpper; p2 = nameUpper; @@ -675,11 +733,11 @@ *lengthPtr = i; done: Tcl_DStringFree(&envString); - Tcl_Free(nameUpper); + ckfree(nameUpper); return result; } /* * Local Variables: Index: win/tclWinInt.h ================================================================== --- win/tclWinInt.h +++ win/tclWinInt.h @@ -38,18 +38,44 @@ BOOL (WINAPI *cancelSynchronousIo)(HANDLE); } TclWinProcs; MODULE_SCOPE TclWinProcs tclWinProcs; +/* + * Some versions of Borland C have a define for the OSVERSIONINFO for + * Win32s and for NT, but not for Windows 95. + * Define VER_PLATFORM_WIN32_CE for those without newer headers. + */ + +#ifndef VER_PLATFORM_WIN32_WINDOWS +#define VER_PLATFORM_WIN32_WINDOWS 1 +#endif +#ifndef VER_PLATFORM_WIN32_CE +#define VER_PLATFORM_WIN32_CE 3 +#endif + +#ifndef TCL_Z_MODIFIER +# ifdef _WIN64 +# if defined(__USE_MINGW_ANSI_STDIO) && __USE_MINGW_ANSI_STDIO +# define TCL_Z_MODIFIER "ll" +# else +# define TCL_Z_MODIFIER "I" +# endif +# else +# define TCL_Z_MODIFIER "" +# endif +#endif +#define TCL_I_MODIFIER TCL_Z_MODIFIER + /* * Declarations of functions that are not accessible by way of the * stubs table. */ MODULE_SCOPE char TclWinDriveLetterForVolMountPoint( const WCHAR *mountPoint); -MODULE_SCOPE void TclWinEncodingsCleanup(); +MODULE_SCOPE void TclWinEncodingsCleanup(void); MODULE_SCOPE void TclWinInit(HINSTANCE hInst); MODULE_SCOPE TclFile TclWinMakeFile(HANDLE handle); MODULE_SCOPE Tcl_Channel TclWinOpenConsoleChannel(HANDLE handle, char *channelName, int permissions); MODULE_SCOPE Tcl_Channel TclWinOpenFileChannel(HANDLE handle, char *channelName, @@ -56,15 +82,22 @@ int permissions, int appendMode); MODULE_SCOPE Tcl_Channel TclWinOpenSerialChannel(HANDLE handle, char *channelName, int permissions); MODULE_SCOPE HANDLE TclWinSerialOpen(HANDLE handle, const WCHAR *name, DWORD access); -MODULE_SCOPE int TclWinSymLinkCopyDirectory(const TCHAR *LinkOriginal, - const TCHAR *LinkCopy); -MODULE_SCOPE int TclWinSymLinkDelete(const TCHAR *LinkOriginal, +MODULE_SCOPE int TclWinSymLinkCopyDirectory(const WCHAR *LinkOriginal, + const WCHAR *LinkCopy); +MODULE_SCOPE int TclWinSymLinkDelete(const WCHAR *LinkOriginal, int linkOnly); MODULE_SCOPE int TclWinFileOwned(Tcl_Obj *); +#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) +MODULE_SCOPE void TclWinFreeAllocCache(void); +MODULE_SCOPE void TclFreeAllocCache(void *); +MODULE_SCOPE Tcl_Mutex *TclpNewAllocMutex(void); +MODULE_SCOPE void * TclpGetAllocCache(void); +MODULE_SCOPE void TclpSetAllocCache(void *); +#endif /* TCL_THREADS */ MODULE_SCOPE const char*TclpGetUserName(Tcl_DString *bufferPtr); /* Needed by tclWinFile.c and tclWinFCmd.c */ #ifndef FILE_ATTRIBUTE_REPARSE_POINT @@ -83,16 +116,16 @@ HANDLE evControl; /* Auto-reset event used by the main thread to * signal when the pipe thread should attempt * to do read/write operation. Additionally * used as signal to stop (state set to -1) */ volatile LONG state; /* Indicates current state of the thread */ - void *clientData; /* Referenced data of the main thread */ + ClientData clientData; /* Referenced data of the main thread */ HANDLE evWakeUp; /* Optional wake-up event worker set by shutdown */ } TclPipeThreadInfo; -/* If pipe-workers will use some tcl subsystem, we can use Tcl_Alloc without +/* If pipe-workers will use some tcl subsystem, we can use ckalloc without * more overhead for finalize thread (should be executed anyway) * * #define _PTI_USE_CKALLOC 1 */ @@ -110,11 +143,11 @@ #define PTI_STATE_DOWN 8 /* worker is down */ MODULE_SCOPE TclPipeThreadInfo * TclPipeThreadCreateTI(TclPipeThreadInfo **pipeTIPtr, - void *clientData, HANDLE wakeEvent); + ClientData clientData, HANDLE wakeEvent); MODULE_SCOPE int TclPipeThreadWaitForSignal(TclPipeThreadInfo **pipeTIPtr); static inline void TclPipeThreadSignal( TclPipeThreadInfo **pipeTIPtr) Index: win/tclWinLoad.c ================================================================== --- win/tclWinLoad.c +++ win/tclWinLoad.c @@ -62,23 +62,24 @@ * function which should be used for this * file. */ int flags) { HINSTANCE hInstance = NULL; - const TCHAR *nativeName; + const WCHAR *nativeName; Tcl_LoadHandle handlePtr; DWORD firstError; + (void)flags; /* * First try the full path the user gave us. This is particularly * important if the cwd is inside a vfs, and we are trying to load using a * relative path. */ - nativeName = Tcl_FSGetNativePath(pathPtr); + nativeName = (const WCHAR *)Tcl_FSGetNativePath(pathPtr); if (nativeName != NULL) { - hInstance = LoadLibraryEx(nativeName, NULL, + hInstance = LoadLibraryExW(nativeName, NULL, LOAD_WITH_ALTERED_SEARCH_PATH); } if (hInstance == NULL) { /* * Let the OS loader examine the binary search path for whatever @@ -93,12 +94,12 @@ * second load attempt below also fails. */ firstError = (nativeName == NULL) ? ERROR_MOD_NOT_FOUND : GetLastError(); - nativeName = Tcl_WinUtfToTChar(TclGetString(pathPtr), -1, &ds); - hInstance = LoadLibraryEx(nativeName, NULL, + nativeName = (WCHAR *)Tcl_WinUtfToTChar(Tcl_GetString(pathPtr), -1, &ds); + hInstance = LoadLibraryExW(nativeName, NULL, LOAD_WITH_ALTERED_SEARCH_PATH); Tcl_DStringFree(&ds); } if (hInstance == NULL) { @@ -115,11 +116,11 @@ lastError = GetLastError(); else lastError = firstError; errMsg = Tcl_ObjPrintf("couldn't load library \"%s\": ", - TclGetString(pathPtr)); + Tcl_GetString(pathPtr)); /* * Check for possible DLL errors. This doesn't work quite right, * because Windows seems to only return ERROR_MOD_NOT_FOUND for just * about any problem, but it's better than nothing. It'd be even @@ -168,11 +169,11 @@ /* * Succeded; package everything up for Tcl. */ - handlePtr = Tcl_Alloc(sizeof(struct Tcl_LoadHandle_)); + handlePtr = (Tcl_LoadHandle)ckalloc(sizeof(struct Tcl_LoadHandle_)); handlePtr->clientData = (ClientData) hInstance; handlePtr->findSymbolProcPtr = &FindSymbol; handlePtr->unloadFileProcPtr = &UnloadFile; *loadHandle = handlePtr; *unloadProcPtr = &UnloadFile; @@ -200,26 +201,26 @@ Tcl_Interp *interp, Tcl_LoadHandle loadHandle, const char *symbol) { HINSTANCE hInstance = (HINSTANCE) loadHandle->clientData; - Tcl_PackageInitProc *proc = NULL; + void *proc = NULL; /* * For each symbol, check for both Symbol and _Symbol, since Borland * generates C symbols with a leading '_' by default. */ - proc = (void *) GetProcAddress(hInstance, symbol); + proc = (void *)GetProcAddress(hInstance, symbol); if (proc == NULL) { Tcl_DString ds; const char *sym2; Tcl_DStringInit(&ds); TclDStringAppendLiteral(&ds, "_"); sym2 = Tcl_DStringAppend(&ds, symbol, -1); - proc = (Tcl_PackageInitProc *) GetProcAddress(hInstance, sym2); + proc = (void *)GetProcAddress(hInstance, sym2); Tcl_DStringFree(&ds); } if (proc == NULL && interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "cannot find symbol \"%s\"", symbol)); @@ -253,11 +254,11 @@ * that represents the loaded file. */ { HINSTANCE hInstance = (HINSTANCE) loadHandle->clientData; FreeLibrary(hInstance); - Tcl_Free(loadHandle); + ckfree(loadHandle); } /* *---------------------------------------------------------------------- * @@ -283,10 +284,13 @@ const char *fileName, /* Name of file containing package (already * translated to local form if needed). */ Tcl_DString *bufPtr) /* Initialized empty dstring. Append package * name to this if possible. */ { + (void)fileName; + (void)bufPtr; + return 0; } /* *---------------------------------------------------------------------- @@ -414,11 +418,11 @@ /* * Store our computed value in the global. */ copyToGlobalBuffer: - dllDirectoryName = Tcl_Alloc((nameLen+1) * sizeof(WCHAR)); + dllDirectoryName = (WCHAR *)ckalloc((nameLen+1) * sizeof(WCHAR)); wcscpy(dllDirectoryName, name); return TCL_OK; } /* Index: win/tclWinNotify.c ================================================================== --- win/tclWinNotify.c +++ win/tclWinNotify.c @@ -25,19 +25,20 @@ * The following static structure contains the state information for the * Windows implementation of the Tcl notifier. One of these structures is * created for each thread that is using the notifier. */ -typedef struct { +typedef struct ThreadSpecificData { CRITICAL_SECTION crit; /* Monitor for this notifier. */ DWORD thread; /* Identifier for thread associated with this * notifier. */ HANDLE event; /* Event object used to wake up the notifier * thread. */ int pending; /* Alert message pending, this field is locked * by the notifierMutex. */ HWND hwnd; /* Messaging window. */ + int timeout; /* Current timeout value. */ int timerActive; /* 1 if interval timer is running. */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; @@ -47,13 +48,12 @@ * * You must hold the notifierMutex lock before accessing this variable. */ static int notifierCount = 0; -static const TCHAR className[] = TEXT("TclNotifier"); -static int initialized = 0; -static CRITICAL_SECTION notifierMutex; +static const WCHAR classname[] = L"TclNotifier"; +TCL_DECLARE_MUTEX(notifierMutex) /* * Static routines defined in this file. */ @@ -81,52 +81,45 @@ { if (tclNotifierHooks.initNotifierProc) { return tclNotifierHooks.initNotifierProc(); } else { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - WNDCLASS class; - - TclpMasterLock(); - if (!initialized) { - initialized = 1; - InitializeCriticalSection(¬ifierMutex); - } - TclpMasterUnlock(); + WNDCLASSW windowClass; /* * Register Notifier window class if this is the first thread to use * this module. */ - EnterCriticalSection(¬ifierMutex); + Tcl_MutexLock(¬ifierMutex); if (notifierCount == 0) { - class.style = 0; - class.cbClsExtra = 0; - class.cbWndExtra = 0; - class.hInstance = TclWinGetTclInstance(); - class.hbrBackground = NULL; - class.lpszMenuName = NULL; - class.lpszClassName = className; - class.lpfnWndProc = NotifierProc; - class.hIcon = NULL; - class.hCursor = NULL; - - if (!RegisterClass(&class)) { + windowClass.style = 0; + windowClass.cbClsExtra = 0; + windowClass.cbWndExtra = 0; + windowClass.hInstance = TclWinGetTclInstance(); + windowClass.hbrBackground = NULL; + windowClass.lpszMenuName = NULL; + windowClass.lpszClassName = classname; + windowClass.lpfnWndProc = NotifierProc; + windowClass.hIcon = NULL; + windowClass.hCursor = NULL; + + if (!RegisterClassW(&windowClass)) { Tcl_Panic("Unable to register TclNotifier window class"); } } notifierCount++; - LeaveCriticalSection(¬ifierMutex); + Tcl_MutexUnlock(¬ifierMutex); tsdPtr->pending = 0; tsdPtr->timerActive = 0; InitializeCriticalSection(&tsdPtr->crit); tsdPtr->hwnd = NULL; tsdPtr->thread = GetCurrentThreadId(); - tsdPtr->event = CreateEvent(NULL, TRUE /* manual */, + tsdPtr->event = CreateEventW(NULL, TRUE /* manual */, FALSE /* !signaled */, NULL); return tsdPtr; } } @@ -188,18 +181,16 @@ /* * If this is the last thread to use the notifier, unregister the * notifier window class. */ - EnterCriticalSection(¬ifierMutex); - if (notifierCount) { - notifierCount--; - if (notifierCount == 0) { - UnregisterClass(className, TclWinGetTclInstance()); - } - } - LeaveCriticalSection(¬ifierMutex); + Tcl_MutexLock(¬ifierMutex); + notifierCount--; + if (notifierCount == 0) { + UnregisterClassW(classname, TclWinGetTclInstance()); + } + Tcl_MutexUnlock(¬ifierMutex); } } /* *---------------------------------------------------------------------- @@ -244,11 +235,11 @@ * We do need to lock around access to the pending flag. */ EnterCriticalSection(&tsdPtr->crit); if (!tsdPtr->pending) { - PostMessage(tsdPtr->hwnd, WM_WAKEUP, 0, 0); + PostMessageW(tsdPtr->hwnd, WM_WAKEUP, 0, 0); } tsdPtr->pending = 1; LeaveCriticalSection(&tsdPtr->crit); } else { SetEvent(tsdPtr->event); @@ -306,14 +297,15 @@ timeout = timePtr->sec * 1000 + timePtr->usec / 1000; if (timeout == 0) { timeout = 1; } } + tsdPtr->timeout = timeout; if (timeout != 0) { tsdPtr->timerActive = 1; SetTimer(tsdPtr->hwnd, INTERVAL_TIMER, - timeout, NULL); + (unsigned long) tsdPtr->timeout, NULL); } else { tsdPtr->timerActive = 0; KillTimer(tsdPtr->hwnd, INTERVAL_TIMER); } } @@ -356,11 +348,11 @@ * destroying the window if we leave the modal loop, but for now we'll * leave it around. */ if (mode == TCL_SERVICE_ALL && !tsdPtr->hwnd) { - tsdPtr->hwnd = CreateWindow(className, className, + tsdPtr->hwnd = CreateWindowW(classname, classname, WS_TILED, 0, 0, 0, 0, NULL, NULL, TclWinGetTclInstance(), NULL); /* * Send an initial message to the window to ensure that we wake up @@ -404,11 +396,11 @@ if (message == WM_WAKEUP) { EnterCriticalSection(&tsdPtr->crit); tsdPtr->pending = 0; LeaveCriticalSection(&tsdPtr->crit); } else if (message != WM_TIMER) { - return DefWindowProc(hwnd, message, wParam, lParam); + return DefWindowProcW(hwnd, message, wParam, lParam); } /* * Process all of the runnable events. */ @@ -476,11 +468,11 @@ * Check to see if there are any messages in the queue before waiting * because MsgWaitForMultipleObjects will not wake up if there are * events currently sitting in the queue. */ - if (!PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE)) { + if (!PeekMessageW(&msg, NULL, 0, 0, PM_NOREMOVE)) { /* * Wait for something to happen (a signal from another thread, a * message, or timeout) or loop servicing asynchronous procedure * calls queued to this thread. */ @@ -498,16 +490,16 @@ /* * Check to see if there are any messages to process. */ - if (PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE)) { + if (PeekMessageW(&msg, NULL, 0, 0, PM_NOREMOVE)) { /* * Retrieve and dispatch the first message. */ - result = GetMessage(&msg, NULL, 0, 0); + result = GetMessageW(&msg, NULL, 0, 0); if (result == 0) { /* * We received a request to exit this thread (WM_QUIT), so * propagate the quit message and start unwinding. */ @@ -521,11 +513,11 @@ */ status = -1; } else { TranslateMessage(&msg); - DispatchMessage(&msg); + DispatchMessageW(&msg); status = 1; } } else { status = 0; } DELETED win/tclWinPanic.c Index: win/tclWinPanic.c ================================================================== --- win/tclWinPanic.c +++ /dev/null @@ -1,88 +0,0 @@ - /* - * tclWinPanic.c -- - * - * Contains the Windows-specific command-line panic proc. - * - * Copyright (c) 2013 by Jan Nijtmans. - * All rights reserved. - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#include "tclInt.h" -/* - *---------------------------------------------------------------------- - * - * Tcl_ConsolePanic -- - * - * Display a message. If a debugger is present, present it directly to - * the debugger, otherwise send it to stderr. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -TCL_NORETURN1 void -Tcl_ConsolePanic( - const char *format, ...) -{ -#define TCL_MAX_WARN_LEN 26000 - va_list argList; - WCHAR msgString[TCL_MAX_WARN_LEN]; - char buf[TCL_MAX_WARN_LEN * 3]; - HANDLE handle = GetStdHandle(STD_ERROR_HANDLE); - DWORD dummy; - - va_start(argList, format); - vsnprintf(buf+3, sizeof(buf)-3, format, argList); - buf[sizeof(buf)-1] = 0; - msgString[TCL_MAX_WARN_LEN-1] = L'\0'; - MultiByteToWideChar(CP_UTF8, 0, buf+3, -1, msgString, TCL_MAX_WARN_LEN); - - /* - * Truncate MessageBox string if it is too long to not overflow the buffer. - */ - - if (msgString[TCL_MAX_WARN_LEN-1] != L'\0') { - memcpy(msgString + (TCL_MAX_WARN_LEN - 5), L" ...", 5 * sizeof(WCHAR)); - } - - if (IsDebuggerPresent()) { - OutputDebugStringW(msgString); - } else if (_isatty(2)) { - WriteConsoleW(handle, msgString, wcslen(msgString), &dummy, 0); - } else { - buf[0] = '\xEF'; buf[1] = '\xBB'; buf[2] = '\xBF'; /* UTF-8 bom */ - WriteFile(handle, buf, strlen(buf), &dummy, 0); - WriteFile(handle, "\n", 1, &dummy, 0); - FlushFileBuffers(handle); - } -# if defined(__GNUC__) - __builtin_trap(); -# elif defined(_WIN64) - __debugbreak(); -# elif defined(_MSC_VER) - _asm {int 3} -# else - DebugBreak(); -# endif -#if defined(_WIN32) - ExitProcess(1); -#else - abort(); -#endif -} -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * tab-width: 8 - * End: - */ Index: win/tclWinPipe.c ================================================================== --- win/tclWinPipe.c +++ win/tclWinPipe.c @@ -59,11 +59,11 @@ * This list is used to map from pids to process handles. */ typedef struct ProcInfo { HANDLE hProcess; - size_t dwProcessId; + DWORD dwProcessId; struct ProcInfo *nextPtr; } ProcInfo; static ProcInfo *procList; @@ -400,11 +400,11 @@ needEvent = 1; } if (needEvent) { infoPtr->flags |= PIPE_PENDING; - evPtr = Tcl_Alloc(sizeof(PipeEvent)); + evPtr = ckalloc(sizeof(PipeEvent)); evPtr->header.proc = PipeEventProc; evPtr->infoPtr = infoPtr; Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); } } @@ -431,11 +431,11 @@ TclWinMakeFile( HANDLE handle) /* Type-specific data. */ { WinFile *filePtr; - filePtr = Tcl_Alloc(sizeof(WinFile)); + filePtr = ckalloc(sizeof(WinFile)); filePtr->type = WIN_FILE; filePtr->handle = handle; return (TclFile)filePtr; } @@ -464,18 +464,18 @@ TempFileName( WCHAR name[MAX_PATH]) /* Buffer in which name for temporary file * gets stored. */ { const WCHAR *prefix = L"TCL"; - if (GetTempPath(MAX_PATH, name) != 0) { - if (GetTempFileName(name, prefix, 0, name) != 0) { + if (GetTempPathW(MAX_PATH, name) != 0) { + if (GetTempFileNameW(name, prefix, 0, name) != 0) { return 1; } } name[0] = '.'; name[1] = '\0'; - return GetTempFileName(name, prefix, 0, name); + return GetTempFileNameW(name, prefix, 0, name); } /* *---------------------------------------------------------------------- * @@ -575,19 +575,19 @@ default: createMode = OPEN_EXISTING; break; } - nativePath = Tcl_WinUtfToTChar(path, -1, &ds); + nativePath = (WCHAR *)Tcl_WinUtfToTChar(path, -1, &ds); /* * If the file is not being created, use the existing file attributes. */ flags = 0; if (!(mode & O_CREAT)) { - flags = GetFileAttributes(nativePath); + flags = GetFileAttributesW(nativePath); if (flags == 0xFFFFFFFF) { flags = 0; } } @@ -599,19 +599,19 @@ /* * Now we get to create the file. */ - handle = CreateFile(nativePath, accessMode, shareMode, + handle = CreateFileW(nativePath, accessMode, shareMode, NULL, createMode, flags, NULL); Tcl_DStringFree(&ds); if (handle == INVALID_HANDLE_VALUE) { DWORD err; err = GetLastError(); - if ((err & 0xffffL) == ERROR_OPEN_FAILED) { + if ((err & 0xFFFFL) == ERROR_OPEN_FAILED) { err = (mode & O_CREAT) ? ERROR_FILE_EXISTS : ERROR_FILE_NOT_FOUND; } TclWinConvertError(err); return NULL; } @@ -656,11 +656,11 @@ if (TempFileName(name) == 0) { return NULL; } - handle = CreateFile(name, + handle = CreateFileW(name, GENERIC_READ | GENERIC_WRITE, 0, NULL, CREATE_ALWAYS, FILE_ATTRIBUTE_TEMPORARY|FILE_FLAG_DELETE_ON_CLOSE, NULL); if (handle == INVALID_HANDLE_VALUE) { goto error; } @@ -718,11 +718,11 @@ Tcl_DStringFree(&dstring); } TclWinConvertError(GetLastError()); CloseHandle(handle); - DeleteFile(name); + DeleteFileW(name); return NULL; } /* *---------------------------------------------------------------------- @@ -823,21 +823,21 @@ && (GetStdHandle(STD_OUTPUT_HANDLE) != filePtr->handle) && (GetStdHandle(STD_ERROR_HANDLE) != filePtr->handle))) { if (filePtr->handle != NULL && CloseHandle(filePtr->handle) == FALSE) { TclWinConvertError(GetLastError()); - Tcl_Free(filePtr); + ckfree(filePtr); return -1; } } break; default: Tcl_Panic("TclpCloseFile: unexpected file type"); } - Tcl_Free(filePtr); + ckfree(filePtr); return 0; } /* *-------------------------------------------------------------------------- @@ -848,35 +848,35 @@ * child process. * * Results: * Returns the process id for the child process. If the pid was not known * by Tcl, either because the pid was not created by Tcl or the child - * process has already been reaped, TCL_IO_FAILURE is returned. + * process has already been reaped, -1 is returned. * * Side effects: * None. * *-------------------------------------------------------------------------- */ -size_t +int TclpGetPid( Tcl_Pid pid) /* The HANDLE of the child process. */ { ProcInfo *infoPtr; PipeInit(); Tcl_MutexLock(&pipeMutex); for (infoPtr = procList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { - if (infoPtr->dwProcessId == (size_t) pid) { + if (infoPtr->hProcess == (HANDLE) pid) { Tcl_MutexUnlock(&pipeMutex); return infoPtr->dwProcessId; } } Tcl_MutexUnlock(&pipeMutex); - return TCL_IO_FAILURE; + return (unsigned long) -1; } /* *---------------------------------------------------------------------- * @@ -934,15 +934,15 @@ * filled with the process id of the child * process. */ { int result, applType, createFlags; Tcl_DString cmdLine; /* Complete command line (WCHAR). */ - STARTUPINFO startInfo; + STARTUPINFOW startInfo; PROCESS_INFORMATION procInfo; SECURITY_ATTRIBUTES secAtts; HANDLE hProcess, h, inputHandle, outputHandle, errorHandle; - char execPath[MAX_PATH * 3]; + char execPath[MAX_PATH * TCL_UTF_MAX]; WinFile *filePtr; PipeInit(); applType = ApplicationType(interp, argv[0], execPath); @@ -1045,11 +1045,11 @@ * * Fortunately, the helper application will detect a closed pipe as a * sink. */ - startInfo.hStdOutput = CreateFile(L"NUL:", GENERIC_WRITE, 0, + startInfo.hStdOutput = CreateFileW(L"NUL:", GENERIC_WRITE, 0, &secAtts, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL); } else { DuplicateHandle(hProcess, outputHandle, hProcess, &startInfo.hStdOutput, 0, TRUE, DUPLICATE_SAME_ACCESS); } @@ -1065,11 +1065,11 @@ /* * If handle was not set, errors should be sent to an infinitely deep * sink. */ - startInfo.hStdError = CreateFile(L"NUL:", GENERIC_WRITE, 0, + startInfo.hStdError = CreateFileW(L"NUL:", GENERIC_WRITE, 0, &secAtts, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); } else { DuplicateHandle(hProcess, errorHandle, hProcess, &startInfo.hStdError, 0, TRUE, DUPLICATE_SAME_ACCESS); } @@ -1092,27 +1092,44 @@ * If we are starting a GUI process, they don't automatically get a * console, so it doesn't matter if they are started as foreground or * detached processes. The GUI window will still pop up to the foreground. */ - if (HasConsole()) { + if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_NT) { + if (HasConsole()) { + createFlags = 0; + } else if (applType == APPL_DOS) { + /* + * Under NT, 16-bit DOS applications will not run unless they can + * be attached to a console. If we are running without a console, + * run the 16-bit program as an normal process inside of a hidden + * console application, and then run that hidden console as a + * detached process. + */ + + startInfo.wShowWindow = SW_HIDE; + startInfo.dwFlags |= STARTF_USESHOWWINDOW; + createFlags = CREATE_NEW_CONSOLE; + TclDStringAppendLiteral(&cmdLine, "cmd.exe /c"); + } else { + createFlags = DETACHED_PROCESS; + } + } else { + if (HasConsole()) { createFlags = 0; - } else if (applType == APPL_DOS) { - /* - * Under NT, 16-bit DOS applications will not run unless they can - * be attached to a console. If we are running without a console, - * run the 16-bit program as an normal process inside of a hidden - * console application, and then run that hidden console as a - * detached process. - */ - - startInfo.wShowWindow = SW_HIDE; - startInfo.dwFlags |= STARTF_USESHOWWINDOW; - createFlags = CREATE_NEW_CONSOLE; - TclDStringAppendLiteral(&cmdLine, "cmd.exe /c"); - } else { - createFlags = DETACHED_PROCESS; + } else { + createFlags = DETACHED_PROCESS; + } + + if (applType == APPL_DOS) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "DOS application process not supported on this platform", + -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "DOS_APP", + NULL); + goto end; + } } /* * cmdLine gets the full command line used to invoke the executable, * including the name of the executable itself. The command line arguments @@ -1131,11 +1148,11 @@ * ab~1.def instead of "a b.default"). */ BuildCommandLine(execPath, argc, argv, &cmdLine); - if (CreateProcess(NULL, (WCHAR *) Tcl_DStringValue(&cmdLine), + if (CreateProcessW(NULL, (WCHAR *) Tcl_DStringValue(&cmdLine), NULL, NULL, TRUE, (DWORD) createFlags, NULL, NULL, &startInfo, &procInfo) == 0) { TclWinConvertError(GetLastError()); Tcl_SetObjResult(interp, Tcl_ObjPrintf("couldn't execute \"%s\": %s", argv[0], Tcl_PosixError(interp))); @@ -1160,11 +1177,11 @@ */ WaitForInputIdle(procInfo.hProcess, 5000); CloseHandle(procInfo.hThread); - *pidPtr = (Tcl_Pid) (size_t) procInfo.dwProcessId; + *pidPtr = (Tcl_Pid) procInfo.hProcess; if (*pidPtr != 0) { TclWinAddProcess(procInfo.hProcess, procInfo.dwProcessId); } result = TCL_OK; @@ -1202,11 +1219,11 @@ static BOOL HasConsole(void) { HANDLE handle; - handle = CreateFileA("CONOUT$", GENERIC_WRITE, FILE_SHARE_WRITE, + handle = CreateFileW(L"CONOUT$", GENERIC_WRITE, FILE_SHARE_WRITE, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); if (handle != INVALID_HANDLE_VALUE) { CloseHandle(handle); return TRUE; @@ -1272,14 +1289,14 @@ /* * Look for the program as an external program. First try the name as it * is, then try adding .com, .exe, .bat and .cmd, in that order, to the name, * looking for an executable. * - * Using the raw SearchPath() function doesn't do quite what is necessary. + * Using the raw SearchPathW() function doesn't do quite what is necessary. * If the name of the executable already contains a '.' character, it will * not try appending the specified extension when searching (in other - * words, SearchPath will not find the program "a.b.exe" if the arguments + * words, SearchPathW will not find the program "a.b.exe" if the arguments * specified "a.b" and ".exe"). So, first look for the file as it is * named. Then manually append the extensions, looking for a match. */ applType = APPL_NONE; @@ -1288,13 +1305,13 @@ nameLen = Tcl_DStringLength(&nameBuf); for (i = 0; i < (int) (sizeof(extensions) / sizeof(extensions[0])); i++) { Tcl_DStringSetLength(&nameBuf, nameLen); Tcl_DStringAppend(&nameBuf, extensions[i], -1); - nativeName = Tcl_WinUtfToTChar(Tcl_DStringValue(&nameBuf), + nativeName = (WCHAR *)Tcl_WinUtfToTChar(Tcl_DStringValue(&nameBuf), Tcl_DStringLength(&nameBuf), &ds); - found = SearchPath(NULL, nativeName, NULL, MAX_PATH, + found = SearchPathW(NULL, nativeName, NULL, MAX_PATH, nativeFullPath, &rest); Tcl_DStringFree(&ds); if (found == 0) { continue; } @@ -1302,25 +1319,25 @@ /* * Ignore matches on directories or data files, return if identified a * known type. */ - attr = GetFileAttributes(nativeFullPath); - if ((attr == 0xffffffff) || (attr & FILE_ATTRIBUTE_DIRECTORY)) { + attr = GetFileAttributesW(nativeFullPath); + if ((attr == 0xFFFFFFFF) || (attr & FILE_ATTRIBUTE_DIRECTORY)) { continue; } - strcpy(fullName, Tcl_WinTCharToUtf(nativeFullPath, -1, &ds)); + strcpy(fullName, Tcl_WinTCharToUtf((TCHAR *)nativeFullPath, -1, &ds)); Tcl_DStringFree(&ds); ext = strrchr(fullName, '.'); if ((ext != NULL) && (strcasecmp(ext, ".cmd") == 0 || strcasecmp(ext, ".bat") == 0)) { applType = APPL_DOS; break; } - hFile = CreateFile(nativeFullPath, + hFile = CreateFileW(nativeFullPath, GENERIC_READ, FILE_SHARE_READ, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); if (hFile == INVALID_HANDLE_VALUE) { continue; } @@ -1396,12 +1413,12 @@ * 16-bit applications. Otherwise the application may not be able to * correctly parse its own command line to separate off the * application name from the arguments. */ - GetShortPathName(nativeFullPath, nativeFullPath, MAX_PATH); - strcpy(fullName, Tcl_WinTCharToUtf(nativeFullPath, -1, &ds)); + GetShortPathNameW(nativeFullPath, nativeFullPath, MAX_PATH); + strcpy(fullName, Tcl_WinTCharToUtf((TCHAR *)nativeFullPath, -1, &ds)); Tcl_DStringFree(&ds); } return applType; } @@ -1756,11 +1773,11 @@ * can be read. */ int numPids, /* The number of pids in the pid array. */ Tcl_Pid *pidPtr) /* An array of process identifiers. */ { char channelName[16 + TCL_INTEGER_SPACE]; - PipeInfo *infoPtr = Tcl_Alloc(sizeof(PipeInfo)); + PipeInfo *infoPtr = ckalloc(sizeof(PipeInfo)); PipeInit(); infoPtr->watchMask = 0; infoPtr->flags = 0; @@ -1782,11 +1799,11 @@ if (readFile != NULL) { /* * Start the background reader thread. */ - infoPtr->readable = CreateEvent(NULL, TRUE, TRUE, NULL); + infoPtr->readable = CreateEventW(NULL, TRUE, TRUE, NULL); infoPtr->readThread = CreateThread(NULL, 256, PipeReaderThread, TclPipeThreadCreateTI(&infoPtr->readTI, infoPtr, infoPtr->readable), 0, NULL); SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST); infoPtr->validMask |= TCL_READABLE; @@ -1797,11 +1814,11 @@ if (writeFile != NULL) { /* * Start the background writer thread. */ - infoPtr->writable = CreateEvent(NULL, TRUE, TRUE, NULL); + infoPtr->writable = CreateEventW(NULL, TRUE, TRUE, NULL); infoPtr->writeThread = CreateThread(NULL, 256, PipeWriterThread, TclPipeThreadCreateTI(&infoPtr->writeTI, infoPtr, infoPtr->writable), 0, NULL); SetThreadPriority(infoPtr->writeThread, THREAD_PRIORITY_HIGHEST); infoPtr->validMask |= TCL_WRITABLE; @@ -1914,17 +1931,17 @@ pipePtr = Tcl_GetChannelInstanceData(chan); TclNewObj(pidsObj); for (i = 0; i < pipePtr->numPids; i++) { Tcl_ListObjAppendElement(NULL, pidsObj, - Tcl_NewWideIntObj( + Tcl_NewWideIntObj((unsigned) TclpGetPid(pipePtr->pidPtr[i]))); Tcl_DetachPids(1, &pipePtr->pidPtr[i]); } Tcl_SetObjResult(interp, pidsObj); if (pipePtr->numPids > 0) { - Tcl_Free(pipePtr->pidPtr); + ckfree(pipePtr->pidPtr); pipePtr->numPids = 0; } } /* @@ -2107,28 +2124,28 @@ if (pipePtr->errorFile) { WinFile *filePtr = (WinFile *) pipePtr->errorFile; errChan = Tcl_MakeFileChannel((ClientData) filePtr->handle, TCL_READABLE); - Tcl_Free(filePtr); + ckfree(filePtr); } else { errChan = NULL; } result = TclCleanupChildren(interp, pipePtr->numPids, pipePtr->pidPtr, errChan); } if (pipePtr->numPids > 0) { - Tcl_Free(pipePtr->pidPtr); + ckfree(pipePtr->pidPtr); } if (pipePtr->writeBuf != NULL) { - Tcl_Free(pipePtr->writeBuf); + ckfree(pipePtr->writeBuf); } - Tcl_Free(pipePtr); + ckfree(pipePtr); if (errorCode == 0) { return result; } return errorCode; @@ -2293,14 +2310,14 @@ /* * Reallocate the buffer to be large enough to hold the data. */ if (infoPtr->writeBuf) { - Tcl_Free(infoPtr->writeBuf); + ckfree(infoPtr->writeBuf); } infoPtr->writeBufLen = toWrite; - infoPtr->writeBuf = Tcl_Alloc(toWrite); + infoPtr->writeBuf = ckalloc(toWrite); } memcpy(infoPtr->writeBuf, buf, toWrite); infoPtr->toWrite = toWrite; ResetEvent(infoPtr->writable); TclPipeThreadSignal(&infoPtr->writeTI); @@ -2558,11 +2575,11 @@ Tcl_MutexLock(&pipeMutex); prevPtrPtr = &procList; for (infoPtr = procList; infoPtr != NULL; prevPtrPtr = &infoPtr->nextPtr, infoPtr = infoPtr->nextPtr) { - if (infoPtr->dwProcessId == (size_t) pid) { + if (infoPtr->hProcess == (HANDLE) pid) { *prevPtrPtr = infoPtr->nextPtr; break; } } Tcl_MutexUnlock(&pipeMutex); @@ -2676,11 +2693,11 @@ /* * Officially close the process handle. */ CloseHandle(infoPtr->hProcess); - Tcl_Free(infoPtr); + ckfree(infoPtr); return result; } /* @@ -2702,13 +2719,13 @@ */ void TclWinAddProcess( void *hProcess, /* Handle to process */ - size_t id) /* Global process identifier */ + unsigned long id) /* Global process identifier */ { - ProcInfo *procPtr = Tcl_Alloc(sizeof(ProcInfo)); + ProcInfo *procPtr = ckalloc(sizeof(ProcInfo)); PipeInit(); procPtr->hProcess = hProcess; procPtr->dwProcessId = id; @@ -2733,11 +2750,10 @@ * See the user documentation. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ int Tcl_PidObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ @@ -2754,11 +2770,11 @@ return TCL_ERROR; } if (objc == 1) { Tcl_SetObjResult(interp, Tcl_NewWideIntObj((unsigned) getpid())); } else { - chan = Tcl_GetChannel(interp, TclGetString(objv[1]), + chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } chanTypePtr = Tcl_GetChannelType(chan); @@ -2765,11 +2781,11 @@ if (chanTypePtr != &pipeChannelType) { return TCL_OK; } pipePtr = (PipeInfo *) Tcl_GetChannelInstanceData(chan); - resultPtr = Tcl_NewObj(); + TclNewObj(resultPtr); for (i = 0; i < pipePtr->numPids; i++) { Tcl_ListObjAppendElement(/*interp*/ NULL, resultPtr, Tcl_NewWideIntObj((unsigned) TclpGetPid(pipePtr->pidPtr[i]))); } @@ -3191,28 +3207,27 @@ { WCHAR name[MAX_PATH]; char *namePtr; HANDLE handle; DWORD flags = FILE_ATTRIBUTE_TEMPORARY; - size_t length; - int counter, counter2; + int length, counter, counter2; Tcl_DString buf; if (!resultingNameObj) { flags |= FILE_FLAG_DELETE_ON_CLOSE; } namePtr = (char *) name; - length = GetTempPath(MAX_PATH, name); + length = GetTempPathW(MAX_PATH, name); if (length == 0) { goto gotError; } namePtr += length * sizeof(WCHAR); if (basenameObj) { - const char *string = TclGetStringFromObj(basenameObj, &length); + const char *string = Tcl_GetString(basenameObj); - Tcl_WinUtfToTChar(string, length, &buf); + Tcl_WinUtfToTChar(string, basenameObj->length, &buf); memcpy(namePtr, Tcl_DStringValue(&buf), Tcl_DStringLength(&buf)); namePtr += Tcl_DStringLength(&buf); Tcl_DStringFree(&buf); } else { const WCHAR *baseStr = L"TCL"; @@ -3233,11 +3248,11 @@ Tcl_WinUtfToTChar(number, strlen(number), &buf); Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf) + 1); memcpy(namePtr, Tcl_DStringValue(&buf), Tcl_DStringLength(&buf) + 1); Tcl_DStringFree(&buf); - handle = CreateFile(name, + handle = CreateFileW(name, GENERIC_READ|GENERIC_WRITE, 0, NULL, CREATE_NEW, flags, NULL); } while (handle == INVALID_HANDLE_VALUE && --counter2 > 0 && GetLastError() == ERROR_FILE_EXISTS); if (handle == INVALID_HANDLE_VALUE) { @@ -3280,13 +3295,13 @@ { TclPipeThreadInfo *pipeTI; #ifndef _PTI_USE_CKALLOC pipeTI = malloc(sizeof(TclPipeThreadInfo)); #else - pipeTI = Tcl_Alloc(sizeof(TclPipeThreadInfo)); + pipeTI = ckalloc(sizeof(TclPipeThreadInfo)); #endif /* !_PTI_USE_CKALLOC */ - pipeTI->evControl = CreateEvent(NULL, FALSE, FALSE, NULL); + pipeTI->evControl = CreateEventW(NULL, FALSE, FALSE, NULL); pipeTI->state = PTI_STATE_IDLE; pipeTI->clientData = clientData; pipeTI->evWakeUp = wakeEvent; return (*pipeTIPtr = pipeTI); } @@ -3429,10 +3444,11 @@ * Thread was idle/waiting, notify it goes teardown */ SetEvent(evControl); *pipeTIPtr = NULL; + /* FALLTHRU */ case PTI_STATE_DOWN: return 1; default: /* @@ -3642,11 +3658,11 @@ } CloseHandle(pipeTI->evControl); #ifndef _PTI_USE_CKALLOC free(pipeTI); #else - Tcl_Free(pipeTI); + ckfree(pipeTI); #endif /* !_PTI_USE_CKALLOC */ } } /* @@ -3692,11 +3708,11 @@ SetEvent(pipeTI->evWakeUp); } #ifndef _PTI_USE_CKALLOC free(pipeTI); #else - Tcl_Free(pipeTI); + ckfree(pipeTI); /* be sure all subsystems used are finalized */ Tcl_FinalizeThread(); #endif /* !_PTI_USE_CKALLOC */ } } Index: win/tclWinPort.h ================================================================== --- win/tclWinPort.h +++ win/tclWinPort.h @@ -12,13 +12,13 @@ */ #ifndef _TCLWINPORT #define _TCLWINPORT -#if !defined(_WIN64) && defined(BUILD_tcl) +#if !defined(_WIN64) && !defined(__MINGW_USE_VC2005_COMPAT) /* See [Bug 3354324]: file mtime sets wrong time */ -# define _USE_32BIT_TIME_T +# define __MINGW_USE_VC2005_COMPAT #endif /* * We must specify the lower version we intend to support. * @@ -43,17 +43,28 @@ #endif /* * Ask for the winsock function typedefs, also. */ -#define INCL_WINSOCK_API_TYPEDEFS 1 +#ifndef INCL_WINSOCK_API_TYPEDEFS +# define INCL_WINSOCK_API_TYPEDEFS 1 +#endif #include #include #ifdef HAVE_WSPIAPI_H # include #endif +#ifdef CHECK_UNICODE_CALLS +# define _UNICODE +# define UNICODE +# define __TCHAR_DEFINED + typedef float *_TCHAR; +# define _TCHAR_DEFINED + typedef float *TCHAR; +#endif /* CHECK_UNICODE_CALLS */ + /* * Pull in the typedef of TCHAR for windows. */ #include #ifndef _TCHAR_DEFINED @@ -80,10 +91,13 @@ #include #include #include #include #include +#ifdef HAVE_INTTYPES_H +# include +#endif #include #ifndef __GNUC__ # define strncasecmp _strnicmp # define strcasecmp _stricmp @@ -281,11 +295,11 @@ /* * Supply definitions for macros to query wait status, if not already * defined in header files above. */ -#if TCL_UNION_WAIT +#ifdef TCL_UNION_WAIT # define WAIT_STATUS_TYPE union wait #else # define WAIT_STATUS_TYPE int #endif /* TCL_UNION_WAIT */ @@ -300,19 +314,19 @@ #ifndef WIFSIGNALED # define WIFSIGNALED(stat) ((*((int *) &(stat))) & 0xC0000000) #endif #ifndef WTERMSIG -# define WTERMSIG(stat) ((*((int *) &(stat))) & 0x7f) +# define WTERMSIG(stat) ((*((int *) &(stat))) & 0x7F) #endif #ifndef WIFSTOPPED # define WIFSTOPPED(stat) 0 #endif #ifndef WSTOPSIG -# define WSTOPSIG(stat) (((*((int *) &(stat))) >> 8) & 0xff) +# define WSTOPSIG(stat) (((*((int *) &(stat))) >> 8) & 0xFF) #endif /* * Define constants for waitpid() system call if they aren't defined * by a system header file. @@ -423,14 +437,14 @@ /* * Define pid_t and uid_t if they're not already defined. */ -#if ! TCL_PID_T +#if !defined(TCL_PID_T) # define pid_t int #endif /* !TCL_PID_T */ -#if ! TCL_UID_T +#if !defined(TCL_UID_T) # define uid_t int #endif /* !TCL_UID_T */ /* * Visual C++ has some odd names for common functions, so we need to @@ -470,10 +484,11 @@ * MSVC 8.0 started to mark many standard C library functions depreciated * including the *printf family and others. Tell it to shut up. * (_MSC_VER is 1200 for VC6, 1300 or 1310 for vc7.net, 1400 for 8.0) */ #if defined(_MSC_VER) +# pragma warning(disable:4146) # pragma warning(disable:4244) # if _MSC_VER >= 1400 # pragma warning(disable:4267) # pragma warning(disable:4996) # endif @@ -526,11 +541,11 @@ /* * The following defines wrap the system memory allocation routines for * use by tclAlloc.c. */ -#define TclpSysAlloc(size) ((void*)HeapAlloc(GetProcessHeap(), \ +#define TclpSysAlloc(size, isBin) ((void*)HeapAlloc(GetProcessHeap(), \ (DWORD)0, (DWORD)size)) #define TclpSysFree(ptr) (HeapFree(GetProcessHeap(), \ (DWORD)0, (HGLOBAL)ptr)) #define TclpSysRealloc(ptr, size) ((void*)HeapReAlloc(GetProcessHeap(), \ (DWORD)0, (LPVOID)ptr, (DWORD)size)) @@ -542,11 +557,11 @@ /* * The following macros have trivial definitions, allowing generic code to * address platform-specific issues. */ -#define TclpReleaseFile(file) Tcl_Free(file) +#define TclpReleaseFile(file) ckfree((char *) file) /* * The following macros and declarations wrap the C runtime library * functions. */ @@ -558,7 +573,10 @@ #endif /* INVALID_SET_FILE_POINTER */ #ifndef LABEL_SECURITY_INFORMATION # define LABEL_SECURITY_INFORMATION (0x00000010L) #endif + +#define Tcl_DirEntry void +#define TclDIR void #endif /* _TCLWINPORT */ Index: win/tclWinReg.c ================================================================== --- win/tclWinReg.c +++ win/tclWinReg.c @@ -92,11 +92,11 @@ static void AppendSystemError(Tcl_Interp *interp, DWORD error); static int BroadcastValue(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static DWORD ConvertDWORD(DWORD type, DWORD value); -static void DeleteCmd(ClientData clientData); +static void DeleteCmd(void *clientData); static int DeleteKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj, REGSAM mode); static int DeleteValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj, Tcl_Obj *valueNameObj, REGSAM mode); static int GetKeyNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj, @@ -114,17 +114,27 @@ HKEY *keyPtr); static int ParseKeyName(Tcl_Interp *interp, char *name, char **hostNamePtr, HKEY *rootKeyPtr, char **keyNamePtr); static DWORD RecursiveDeleteKey(HKEY hStartKey, - const TCHAR * pKeyName, REGSAM mode); -static int RegistryObjCmd(ClientData clientData, + const WCHAR * pKeyName, REGSAM mode); +static int RegistryObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int SetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj, Tcl_Obj *valueNameObj, Tcl_Obj *dataObj, Tcl_Obj *typeObj, REGSAM mode); + +#if (TCL_MAJOR_VERSION < 9) && (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 +#endif static unsigned char * getByteArrayFromObj( Tcl_Obj *objPtr, size_t *lengthPtr @@ -141,12 +151,18 @@ /* 32-bit or without TIP #494 */ *lengthPtr = (size_t) (unsigned) length; return result; } +#ifdef __cplusplus +extern "C" { +#endif DLLEXPORT int Registry_Init(Tcl_Interp *interp); DLLEXPORT int Registry_Unload(Tcl_Interp *interp, int flags); +#ifdef __cplusplus +} +#endif /* *---------------------------------------------------------------------- * * Registry_Init -- @@ -173,11 +189,11 @@ } cmd = Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd, interp, DeleteCmd); Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, cmd); - return Tcl_PkgProvide(interp, "registry", "1.3.3"); + return Tcl_PkgProvideEx(interp, "registry", "1.3.5", NULL); } /* *---------------------------------------------------------------------- * @@ -199,10 +215,11 @@ Tcl_Interp *interp, /* Interpreter for unloading */ int flags) /* Flags passed by the unload system */ { Tcl_Command cmd; Tcl_Obj *objv[3]; + (void)flags; /* * Unregister the registry package. There is no Tcl_PkgForget() */ @@ -213,11 +230,11 @@ /* * Delete the originally registered command. */ - cmd = Tcl_GetAssocData(interp, REGISTRY_ASSOC_KEY, NULL); + cmd = (Tcl_Command)Tcl_GetAssocData(interp, REGISTRY_ASSOC_KEY, NULL); if (cmd != NULL) { Tcl_DeleteCommandFromToken(interp, cmd); } return TCL_OK; @@ -240,13 +257,13 @@ *---------------------------------------------------------------------- */ static void DeleteCmd( - ClientData clientData) + void *clientData) { - Tcl_Interp *interp = clientData; + Tcl_Interp *interp = (Tcl_Interp *)clientData; Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, NULL); } /* @@ -265,11 +282,11 @@ *---------------------------------------------------------------------- */ static int RegistryObjCmd( - ClientData clientData, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument values. */ { int n = 1; @@ -284,10 +301,11 @@ BroadcastIdx, DeleteIdx, GetIdx, KeysIdx, SetIdx, TypeIdx, ValuesIdx }; static const char *const modes[] = { "-32bit", "-64bit", NULL }; + (void)dummy; if (objc < 2) { wrongArgs: Tcl_WrongNumArgs(interp, 1, objv, "?-32bit|-64bit? option ?arg ...?"); return TCL_ERROR; @@ -413,11 +431,11 @@ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Obj *keyNameObj, /* Name of key to delete. */ REGSAM mode) /* Mode flags to pass. */ { char *tail, *buffer, *hostName, *keyName; - const TCHAR *nativeTail; + const WCHAR *nativeTail; HKEY rootKey, subkey; DWORD result; Tcl_DString buf; REGSAM saveMode = mode; @@ -424,11 +442,11 @@ /* * Find the parent of the key being deleted and open it. */ keyName = Tcl_GetString(keyNameObj); - buffer = Tcl_Alloc(keyNameObj->length + 1); + buffer = (char *)Tcl_Alloc(keyNameObj->length + 1); strcpy(buffer, keyName); if (ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName) != TCL_OK) { Tcl_Free(buffer); @@ -466,11 +484,12 @@ /* * Now we recursively delete the key and everything below it. */ - nativeTail = Tcl_WinUtfToTChar(tail, -1, &buf); + Tcl_DStringInit(&buf); + nativeTail = Tcl_UtfToWCharDString(tail, -1, &buf); result = RecursiveDeleteKey(subkey, nativeTail, saveMode); Tcl_DStringFree(&buf); if (result != ERROR_SUCCESS && result != ERROR_FILE_NOT_FOUND) { Tcl_SetObjResult(interp, @@ -522,12 +541,13 @@ if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) { return TCL_ERROR; } valueName = Tcl_GetString(valueNameObj); - Tcl_WinUtfToTChar(valueName, valueNameObj->length, &ds); - result = RegDeleteValue(key, (const TCHAR *)Tcl_DStringValue(&ds)); + Tcl_DStringInit(&ds); + Tcl_UtfToWCharDString(valueName, valueNameObj->length, &ds); + result = RegDeleteValueW(key, (const WCHAR *)Tcl_DStringValue(&ds)); Tcl_DStringFree(&ds); if (result != ERROR_SUCCESS) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unable to delete value \"%s\" from key \"%s\": ", Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj))); @@ -566,11 +586,11 @@ Tcl_Obj *patternObj, /* Optional match pattern. */ REGSAM mode) /* Mode flags to pass. */ { const char *pattern; /* Pattern being matched against subkeys */ HKEY key; /* Handle to the key being examined */ - TCHAR buffer[MAX_KEY_LENGTH]; + WCHAR buffer[MAX_KEY_LENGTH]; /* Buffer to hold the subkey name */ DWORD bufSize; /* Size of the buffer */ DWORD index; /* Position of the current subkey */ char *name; /* Subkey name */ Tcl_Obj *resultPtr; /* List of subkeys being accumulated */ @@ -597,11 +617,11 @@ */ resultPtr = Tcl_NewObj(); for (index = 0;; ++index) { bufSize = MAX_KEY_LENGTH; - result = RegEnumKeyEx(key, index, buffer, &bufSize, + result = RegEnumKeyExW(key, index, buffer, &bufSize, NULL, NULL, NULL, NULL); if (result != ERROR_SUCCESS) { if (result == ERROR_NO_MORE_ITEMS) { result = TCL_OK; } else { @@ -611,11 +631,12 @@ AppendSystemError(interp, result); result = TCL_ERROR; } break; } - name = Tcl_WinTCharToUtf(buffer, bufSize * sizeof(TCHAR), &ds); + Tcl_DStringInit(&ds); + name = Tcl_WCharToUtfDString(buffer, bufSize, &ds); if (pattern && !Tcl_StringMatch(name, pattern)) { Tcl_DStringFree(&ds); continue; } result = Tcl_ListObjAppendElement(interp, resultPtr, @@ -661,11 +682,11 @@ { HKEY key; DWORD result, type; Tcl_DString ds; const char *valueName; - const TCHAR *nativeValue; + const WCHAR *nativeValue; /* * Attempt to open the key for reading. */ @@ -677,12 +698,13 @@ /* * Get the type of the value. */ valueName = Tcl_GetString(valueNameObj); - nativeValue = Tcl_WinUtfToTChar(valueName, valueNameObj->length, &ds); - result = RegQueryValueEx(key, nativeValue, NULL, &type, + Tcl_DStringInit(&ds); + nativeValue = Tcl_UtfToWCharDString(valueName, valueNameObj->length, &ds); + result = RegQueryValueExW(key, nativeValue, NULL, &type, NULL, NULL); Tcl_DStringFree(&ds); RegCloseKey(key); if (result != ERROR_SUCCESS) { @@ -730,11 +752,11 @@ Tcl_Obj *valueNameObj, /* Name of value to get. */ REGSAM mode) /* Mode flags to pass. */ { HKEY key; const char *valueName; - const TCHAR *nativeValue; + const WCHAR *nativeValue; DWORD result, length, type; Tcl_DString data, buf; /* * Attempt to open the key for reading. @@ -755,27 +777,28 @@ * Longer values need a second call with an expanded DString. */ Tcl_DStringInit(&data); Tcl_DStringSetLength(&data, TCL_DSTRING_STATIC_SIZE - 1); - length = TCL_DSTRING_STATIC_SIZE/sizeof(TCHAR) - 1; + length = TCL_DSTRING_STATIC_SIZE/sizeof(WCHAR) - 1; valueName = Tcl_GetString(valueNameObj); - nativeValue = Tcl_WinUtfToTChar(valueName, valueNameObj->length, &buf); + Tcl_DStringInit(&buf); + nativeValue = Tcl_UtfToWCharDString(valueName, valueNameObj->length, &buf); - result = RegQueryValueEx(key, nativeValue, NULL, &type, + result = RegQueryValueExW(key, nativeValue, NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length); while (result == ERROR_MORE_DATA) { /* * The Windows docs say that in this error case, we just need to * expand our buffer and request more data. Required for * HKEY_PERFORMANCE_DATA */ - length = Tcl_DStringLength(&data) * (2 / sizeof(TCHAR)); - Tcl_DStringSetLength(&data, (int) length * sizeof(TCHAR)); - result = RegQueryValueEx(key, nativeValue, + length = Tcl_DStringLength(&data) * (2 / sizeof(WCHAR)); + Tcl_DStringSetLength(&data, (int) length * sizeof(WCHAR)); + result = RegQueryValueExW(key, nativeValue, NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length); } Tcl_DStringFree(&buf); RegCloseKey(key); if (result != ERROR_SUCCESS) { @@ -807,25 +830,27 @@ * terminated by two null characters. Also do a bounds check in case * we get bogus data. */ while ((p < end) && *((WCHAR *) p) != 0) { - WCHAR *wp; + WCHAR *wp = (WCHAR *) p; - Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf); + Tcl_DStringInit(&buf); + Tcl_WCharToUtfDString(wp, wcslen(wp), &buf); Tcl_ListObjAppendElement(interp, resultPtr, Tcl_NewStringObj(Tcl_DStringValue(&buf), Tcl_DStringLength(&buf))); - wp = (WCHAR *) p; while (*wp++ != 0) {/* empty body */} p = (char *) wp; Tcl_DStringFree(&buf); } Tcl_SetObjResult(interp, resultPtr); } else if ((type == REG_SZ) || (type == REG_EXPAND_SZ)) { - Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&data), -1, &buf); + WCHAR *wp = (WCHAR *) Tcl_DStringValue(&data); + Tcl_DStringInit(&buf); + Tcl_WCharToUtfDString((const WCHAR *)Tcl_DStringValue(&data), wcslen(wp), &buf); Tcl_DStringResult(interp, &buf); } else { /* * Save binary data as a byte array. */ @@ -878,11 +903,11 @@ return TCL_ERROR; } resultPtr = Tcl_NewObj(); Tcl_DStringInit(&buffer); - Tcl_DStringSetLength(&buffer, (int) (MAX_KEY_LENGTH * sizeof(TCHAR))); + Tcl_DStringSetLength(&buffer, (int) (MAX_KEY_LENGTH * sizeof(WCHAR))); index = 0; result = TCL_OK; if (patternObj) { pattern = Tcl_GetString(patternObj); @@ -895,16 +920,15 @@ * indicating the end of the list. Note that we need to reset size after * each iteration because RegEnumValue smashes the old value. */ size = MAX_KEY_LENGTH; - while (RegEnumValue(key,index, (TCHAR *)Tcl_DStringValue(&buffer), + while (RegEnumValueW(key,index, (WCHAR *)Tcl_DStringValue(&buffer), &size, NULL, NULL, NULL, NULL) == ERROR_SUCCESS) { - size *= sizeof(TCHAR); - Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&buffer), (int) size, - &ds); + Tcl_DStringInit(&ds); + Tcl_WCharToUtfDString((const WCHAR *)Tcl_DStringValue(&buffer), size, &ds); name = Tcl_DStringValue(&ds); if (!pattern || Tcl_StringMatch(name, pattern)) { result = Tcl_ListObjAppendElement(interp, resultPtr, Tcl_NewStringObj(name, Tcl_DStringLength(&ds))); if (result != TCL_OK) { @@ -951,11 +975,11 @@ char *keyName, *buffer, *hostName; HKEY rootKey; DWORD result; keyName = Tcl_GetString(keyNameObj); - buffer = Tcl_Alloc(keyNameObj->length + 1); + buffer = (char *)Tcl_Alloc(keyNameObj->length + 1); strcpy(buffer, keyName); result = ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName); if (result == TCL_OK) { result = OpenSubKey(hostName, rootKey, keyName, mode, flags, keyPtr); @@ -1006,12 +1030,13 @@ /* * Attempt to open the root key on a remote host if necessary. */ if (hostName) { - hostName = (char *) Tcl_WinUtfToTChar(hostName, -1, &buf); - result = RegConnectRegistry((TCHAR *)hostName, rootKey, + Tcl_DStringInit(&buf); + hostName = (char *) Tcl_UtfToWCharDString(hostName, -1, &buf); + result = RegConnectRegistryW((WCHAR *)hostName, rootKey, &rootKey); Tcl_DStringFree(&buf); if (result != ERROR_SUCCESS) { return result; } @@ -1021,16 +1046,17 @@ * Now open the specified key with the requested permissions. Note that * this key must be closed by the caller. */ if (keyName) { - keyName = (char *) Tcl_WinUtfToTChar(keyName, -1, &buf); + Tcl_DStringInit(&buf); + keyName = (char *) Tcl_UtfToWCharDString(keyName, -1, &buf); } if (flags & REG_CREATE) { DWORD create; - result = RegCreateKeyEx(rootKey, (TCHAR *)keyName, 0, NULL, + result = RegCreateKeyExW(rootKey, (WCHAR *)keyName, 0, NULL, REG_OPTION_NON_VOLATILE, mode, NULL, keyPtr, &create); } else if (rootKey == HKEY_PERFORMANCE_DATA) { /* * Here we fudge it for this special root key. See MSDN for more info * on HKEY_PERFORMANCE_DATA and the peculiarities surrounding it. @@ -1037,11 +1063,11 @@ */ *keyPtr = HKEY_PERFORMANCE_DATA; result = ERROR_SUCCESS; } else { - result = RegOpenKeyEx(rootKey, (TCHAR *)keyName, 0, mode, + result = RegOpenKeyExW(rootKey, (WCHAR *)keyName, 0, mode, keyPtr); } if (keyName) { Tcl_DStringFree(&buf); } @@ -1157,20 +1183,20 @@ */ static DWORD RecursiveDeleteKey( HKEY startKey, /* Parent of key to be deleted. */ - const TCHAR *keyName, /* Name of key to be deleted in external + const WCHAR *keyName, /* Name of key to be deleted in external * encoding, not UTF. */ REGSAM mode) /* Mode flags to pass. */ { DWORD result, size; Tcl_DString subkey; HKEY hKey; REGSAM saveMode = mode; static int checkExProc = 0; - static FARPROC regDeleteKeyExProc = NULL; + static LONG (* regDeleteKeyExProc) (HKEY, LPCWSTR, REGSAM, DWORD) = (LONG (*) (HKEY, LPCWSTR, REGSAM, DWORD)) NULL; /* * Do not allow NULL or empty key name. */ @@ -1177,26 +1203,26 @@ if (!keyName || *keyName == '\0') { return ERROR_BADKEY; } mode |= KEY_ENUMERATE_SUB_KEYS | DELETE | KEY_QUERY_VALUE; - result = RegOpenKeyEx(startKey, keyName, 0, mode, &hKey); + result = RegOpenKeyExW(startKey, keyName, 0, mode, &hKey); if (result != ERROR_SUCCESS) { return result; } Tcl_DStringInit(&subkey); - Tcl_DStringSetLength(&subkey, (int) (MAX_KEY_LENGTH * sizeof(TCHAR))); + Tcl_DStringSetLength(&subkey, (int) (MAX_KEY_LENGTH * sizeof(WCHAR))); mode = saveMode; while (result == ERROR_SUCCESS) { /* * Always get index 0 because key deletion changes ordering. */ size = MAX_KEY_LENGTH; - result = RegEnumKeyEx(hKey, 0, (TCHAR *)Tcl_DStringValue(&subkey), + result = RegEnumKeyExW(hKey, 0, (WCHAR *)Tcl_DStringValue(&subkey), &size, NULL, NULL, NULL, NULL); if (result == ERROR_NO_MORE_ITEMS) { /* * RegDeleteKeyEx doesn't exist on non-64bit XP platforms, so we * can't compile with it in. We need to check for it at runtime @@ -1205,23 +1231,23 @@ if (mode && !checkExProc) { HMODULE handle; checkExProc = 1; - handle = GetModuleHandle(TEXT("ADVAPI32")); - regDeleteKeyExProc = (FARPROC) - GetProcAddress(handle, "RegDeleteKeyExW"); + handle = GetModuleHandleW(L"ADVAPI32"); + regDeleteKeyExProc = (LONG (*) (HKEY, LPCWSTR, REGSAM, DWORD)) + (void *)GetProcAddress(handle, "RegDeleteKeyExW"); } if (mode && regDeleteKeyExProc) { result = regDeleteKeyExProc(startKey, keyName, mode, 0); } else { - result = RegDeleteKey(startKey, keyName); + result = RegDeleteKeyW(startKey, keyName); } break; } else if (result == ERROR_SUCCESS) { result = RecursiveDeleteKey(hKey, - (const TCHAR *) Tcl_DStringValue(&subkey), mode); + (const WCHAR *) Tcl_DStringValue(&subkey), mode); } } Tcl_DStringFree(&subkey); RegCloseKey(hKey); return result; @@ -1273,11 +1299,12 @@ if (OpenKey(interp, keyNameObj, mode, 1, &key) != TCL_OK) { return TCL_ERROR; } valueName = Tcl_GetString(valueNameObj); - valueName = (char *) Tcl_WinUtfToTChar(valueName, valueNameObj->length, &nameBuf); + Tcl_DStringInit(&nameBuf); + valueName = (char *) Tcl_UtfToWCharDString(valueName, valueNameObj->length, &nameBuf); if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) { int value; if (Tcl_GetIntFromObj(interp, dataObj, &value) != TCL_OK) { @@ -1285,11 +1312,11 @@ Tcl_DStringFree(&nameBuf); return TCL_ERROR; } value = ConvertDWORD((DWORD) type, (DWORD) value); - result = RegSetValueEx(key, (TCHAR *) valueName, 0, + result = RegSetValueExW(key, (WCHAR *) valueName, 0, (DWORD) type, (BYTE *) &value, sizeof(DWORD)); } else if (type == REG_MULTI_SZ) { Tcl_DString data, buf; int objc, i; Tcl_Obj **objv; @@ -1317,30 +1344,32 @@ */ Tcl_DStringAppend(&data, "", 1); /* NUL-terminated string */ } - Tcl_WinUtfToTChar(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1, + Tcl_DStringInit(&buf); + Tcl_UtfToWCharDString(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1, &buf); - result = RegSetValueEx(key, (TCHAR *) valueName, 0, + result = RegSetValueExW(key, (WCHAR *) valueName, 0, (DWORD) type, (BYTE *) Tcl_DStringValue(&buf), (DWORD) Tcl_DStringLength(&buf)); Tcl_DStringFree(&data); Tcl_DStringFree(&buf); } else if (type == REG_SZ || type == REG_EXPAND_SZ) { Tcl_DString buf; const char *data = Tcl_GetString(dataObj); - data = (char *) Tcl_WinUtfToTChar(data, dataObj->length, &buf); + Tcl_DStringInit(&buf); + data = (char *) Tcl_UtfToWCharDString(data, dataObj->length, &buf); /* * Include the null in the length, padding if needed for WCHAR. */ Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1); - result = RegSetValueEx(key, (TCHAR *) valueName, 0, + result = RegSetValueExW(key, (WCHAR *) valueName, 0, (DWORD) type, (BYTE *) data, (DWORD) Tcl_DStringLength(&buf) + 1); Tcl_DStringFree(&buf); } else { BYTE *data; size_t bytelength; @@ -1348,11 +1377,11 @@ /* * Store binary data in the registry. */ data = (BYTE *) getByteArrayFromObj(dataObj, &bytelength); - result = RegSetValueEx(key, (TCHAR *) valueName, 0, + result = RegSetValueExW(key, (WCHAR *) valueName, 0, (DWORD) type, data, (DWORD) bytelength); } Tcl_DStringFree(&nameBuf); RegCloseKey(key); @@ -1408,20 +1437,21 @@ return TCL_ERROR; } } str = Tcl_GetString(objv[0]); - wstr = (WCHAR *) Tcl_WinUtfToTChar(str, objv[0]->length, &ds); + Tcl_DStringInit(&ds); + wstr = Tcl_UtfToWCharDString(str, objv[0]->length, &ds); if (Tcl_DStringLength(&ds) == 0) { wstr = NULL; } /* * Use the ignore the result. */ - result = SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, + result = SendMessageTimeoutW(HWND_BROADCAST, WM_SETTINGCHANGE, (WPARAM) 0, (LPARAM) wstr, SMTO_ABORTIFHUNG, (UINT) timeout, &sendResult); Tcl_DStringFree(&ds); objPtr = Tcl_NewObj(); Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewWideIntObj((Tcl_WideInt) result)); @@ -1452,30 +1482,31 @@ AppendSystemError( Tcl_Interp *interp, /* Current interpreter. */ DWORD error) /* Result code from error. */ { int length; - TCHAR *tMsgPtr, **tMsgPtrPtr = &tMsgPtr; + WCHAR *tMsgPtr, **tMsgPtrPtr = &tMsgPtr; const char *msg; char id[TCL_INTEGER_SPACE], msgBuf[24 + TCL_INTEGER_SPACE]; Tcl_DString ds; Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); if (Tcl_IsShared(resultPtr)) { resultPtr = Tcl_DuplicateObj(resultPtr); } - length = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM + length = FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error, - MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (TCHAR *) tMsgPtrPtr, + MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (WCHAR *) tMsgPtrPtr, 0, NULL); if (length == 0) { sprintf(msgBuf, "unknown error: %ld", error); msg = msgBuf; } else { char *msgPtr; - Tcl_WinTCharToUtf(tMsgPtr, -1, &ds); + Tcl_DStringInit(&ds); + Tcl_WCharToUtfDString(tMsgPtr, wcslen(tMsgPtr), &ds); LocalFree(tMsgPtr); msgPtr = Tcl_DStringValue(&ds); length = Tcl_DStringLength(&ds); Index: win/tclWinSerial.c ================================================================== --- win/tclWinSerial.c +++ win/tclWinSerial.c @@ -41,19 +41,10 @@ */ #define SERIAL_EOF (1<<2) /* Serial has reached EOF. */ #define SERIAL_ERROR (1<<4) -/* - * Bit masks used for noting whether to drain or discard output on close. They - * are disjoint from each other; at most one may be set at a time. - */ - -#define SERIAL_CLOSE_DRAIN (1<<6) /* Drain all output on close. */ -#define SERIAL_CLOSE_DISCARD (1<<7) /* Discard all output on close. */ -#define SERIAL_CLOSE_MASK (3<<6) /* Both two bits above. */ - /* * Default time to block between checking status on the serial port. */ #define SERIAL_DEFAULT_BLOCKTIME 10 /* 10 msec */ @@ -122,11 +113,11 @@ int writeQueue; /* Number of bytes pending in output queue. * Offset to DCB.cbInQue. Used to query * [fconfigure -queue] */ } SerialInfo; -typedef struct { +typedef struct ThreadSpecificData { /* * The following pointer refers to the head of the list of serials that * are being watched for file events. */ @@ -138,11 +129,11 @@ /* * The following structure is what is added to the Tcl event queue when serial * events are generated. */ -typedef struct { +typedef struct SerialEvent { Tcl_Event header; /* Information that is standard for all * events. */ SerialInfo *infoPtr; /* Pointer to serial info structure. Note that * we still have to verify that the serial * exists before dereferencing this @@ -167,10 +158,12 @@ static int SerialBlockProc(ClientData instanceData, int mode); static void SerialCheckProc(ClientData clientData, int flags); static int SerialCloseProc(ClientData instanceData, Tcl_Interp *interp); +static int SerialClose2Proc(ClientData instanceData, + Tcl_Interp *interp, int flags); static int SerialEventProc(Tcl_Event *evPtr, int flags); static void SerialExitHandler(ClientData clientData); static int SerialGetHandleProc(ClientData instanceData, int direction, ClientData *handlePtr); static ThreadSpecificData *SerialInit(void); @@ -210,11 +203,11 @@ NULL, /* Seek proc. */ SerialSetOptionProc, /* Set option proc. */ SerialGetOptionProc, /* Get option proc. */ SerialWatchProc, /* Set up notifier to watch the channel. */ SerialGetHandleProc, /* Get an OS handle from channel. */ - NULL, /* close2proc. */ + SerialClose2Proc, /* close2proc. */ SerialBlockProc, /* Set blocking or non-blocking mode.*/ NULL, /* flush proc. */ NULL, /* handler proc. */ NULL, /* wide seek proc */ SerialThreadActionProc, /* thread action proc */ @@ -529,11 +522,11 @@ * Queue an event if the serial is signaled for reading or writing. */ if (needEvent) { infoPtr->flags |= SERIAL_PENDING; - evPtr = Tcl_Alloc(sizeof(SerialEvent)); + evPtr = ckalloc(sizeof(SerialEvent)); evPtr->header.proc = SerialEventProc; evPtr->infoPtr = infoPtr; Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); } } @@ -579,11 +572,11 @@ } /* *---------------------------------------------------------------------- * - * SerialCloseProc -- + * SerialCloseProc/SerialClose2Proc -- * * Closes a serial based IO channel. * * Results: * 0 on success, errno otherwise. @@ -611,10 +604,11 @@ CloseHandle(serialPtr->osRead.hEvent); } serialPtr->validMask &= ~TCL_READABLE; if (serialPtr->writeThread) { + TclPipeThreadStop(&serialPtr->writeTI, serialPtr->writeThread); CloseHandle(serialPtr->osWrite.hEvent); CloseHandle(serialPtr->evWritable); CloseHandle(serialPtr->writeThread); @@ -660,20 +654,32 @@ /* * Wrap the error file into a channel and give it to the cleanup routine. */ if (serialPtr->writeBuf != NULL) { - Tcl_Free(serialPtr->writeBuf); + ckfree(serialPtr->writeBuf); serialPtr->writeBuf = NULL; } - Tcl_Free(serialPtr); + ckfree(serialPtr); if (errorCode == 0) { return result; } return errorCode; } + +static int +SerialClose2Proc( + ClientData instanceData, /* Pointer to SerialInfo structure. */ + Tcl_Interp *interp, /* For error reporting. */ + int flags) +{ + if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) == 0) { + return SerialCloseProc(instanceData, interp); + } + return EINVAL; +} /* *---------------------------------------------------------------------- * * SerialBlockingRead -- @@ -1025,14 +1031,14 @@ /* * Reallocate the buffer to be large enough to hold the data. */ if (infoPtr->writeBuf) { - Tcl_Free(infoPtr->writeBuf); + ckfree(infoPtr->writeBuf); } infoPtr->writeBufLen = toWrite; - infoPtr->writeBuf = Tcl_Alloc(toWrite); + infoPtr->writeBuf = ckalloc(toWrite); } memcpy(infoPtr->writeBuf, buf, toWrite); infoPtr->toWrite = toWrite; ResetEvent(infoPtr->evWritable); TclPipeThreadSignal(&infoPtr->writeTI); @@ -1284,16 +1290,16 @@ */ if (!TclPipeThreadWaitForSignal(&pipeTI)) { /* exit */ break; } - infoPtr = (SerialInfo *) pipeTI->clientData; + infoPtr = (SerialInfo *)pipeTI->clientData; buf = infoPtr->writeBuf; toWrite = infoPtr->toWrite; - myWrite.hEvent = CreateEvent(NULL, TRUE, FALSE, NULL); + myWrite.hEvent = CreateEventW(NULL, TRUE, FALSE, NULL); /* * Loop until all of the bytes are written or an error occurs. */ @@ -1348,29 +1354,11 @@ Tcl_ThreadAlert(infoPtr->threadId); } Tcl_MutexUnlock(&serialMutex); } - /* - * We're about to close, so do any drain or discard required. - */ - - if (infoPtr) { - switch (infoPtr->flags & SERIAL_CLOSE_MASK) { - case SERIAL_CLOSE_DRAIN: - FlushFileBuffers(infoPtr->handle); - break; - case SERIAL_CLOSE_DISCARD: - PurgeComm(infoPtr->handle, PURGE_TXABORT | PURGE_TXCLEAR); - break; - } - } - - /* - * Worker exit, so inform the main thread or free TI-structure (if owned). - */ - + /* Worker exit, so inform the main thread or free TI-structure (if owned) */ TclPipeThreadExit(&pipeTI); return 0; } @@ -1411,11 +1399,11 @@ * Multithreaded I/O needs the overlapped flag set otherwise * ClearCommError blocks under Windows NT/2000 until serial output is * finished */ - handle = CreateFile(name, access, 0, 0, OPEN_EXISTING, + handle = CreateFileW(name, access, 0, 0, OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0); return handle; } @@ -1445,11 +1433,11 @@ { SerialInfo *infoPtr; SerialInit(); - infoPtr = Tcl_Alloc(sizeof(SerialInfo)); + infoPtr = ckalloc(sizeof(SerialInfo)); memset(infoPtr, 0, sizeof(SerialInfo)); infoPtr->validMask = permissions; infoPtr->handle = handle; infoPtr->channel = (Tcl_Channel) NULL; @@ -1484,19 +1472,19 @@ SetCommTimeouts(handle, &no_timeout); InitializeCriticalSection(&infoPtr->csWrite); if (permissions & TCL_READABLE) { - infoPtr->osRead.hEvent = CreateEvent(NULL, TRUE, FALSE, NULL); + infoPtr->osRead.hEvent = CreateEventW(NULL, TRUE, FALSE, NULL); } if (permissions & TCL_WRITABLE) { /* * Initially the channel is writable and the writeThread is idle. */ - infoPtr->osWrite.hEvent = CreateEvent(NULL, TRUE, FALSE, NULL); - infoPtr->evWritable = CreateEvent(NULL, TRUE, TRUE, NULL); + infoPtr->osWrite.hEvent = CreateEventW(NULL, TRUE, FALSE, NULL); + infoPtr->evWritable = CreateEventW(NULL, TRUE, TRUE, NULL); infoPtr->writeThread = CreateThread(NULL, 256, SerialWriterThread, TclPipeThreadCreateTI(&infoPtr->writeTI, infoPtr, infoPtr->evWritable), 0, NULL); } @@ -1633,46 +1621,20 @@ */ len = strlen(optionName); vlen = strlen(value); - /* - * Option -closemode drain|discard|default - */ - - if ((len > 2) && (strncmp(optionName, "-closemode", len) == 0)) { - if (Tcl_UtfNcasecmp(value, "DEFAULT", vlen) == 0) { - infoPtr->flags &= ~SERIAL_CLOSE_MASK; - } else if (Tcl_UtfNcasecmp(value, "DRAIN", vlen) == 0) { - infoPtr->flags &= ~SERIAL_CLOSE_MASK; - infoPtr->flags |= SERIAL_CLOSE_DRAIN; - } else if (Tcl_UtfNcasecmp(value, "DISCARD", vlen) == 0) { - infoPtr->flags &= ~SERIAL_CLOSE_MASK; - infoPtr->flags |= SERIAL_CLOSE_DISCARD; - } else { - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad mode \"%s\" for -closemode: must be" - " default, discard, or drain", value)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", - "VALUE", NULL); - } - return TCL_ERROR; - } - return TCL_OK; - } - /* * Option -mode baud,parity,databits,stopbits */ if ((len > 2) && (strncmp(optionName, "-mode", len) == 0)) { if (!GetCommState(infoPtr->handle, &dcb)) { goto getStateFailed; } - native = Tcl_WinUtfToTChar(value, -1, &ds); - result = BuildCommDCB(native, &dcb); + native = (const WCHAR *)Tcl_WinUtfToTChar(value, -1, &ds); + result = BuildCommDCBW(native, &dcb); Tcl_DStringFree(&ds); if (result == FALSE) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -1768,14 +1730,14 @@ if (argc != 2) { badXchar: if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -xchar: should be a list of" - " two elements with each a single 8-bit character", -1)); + " two elements with each a single character", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "XCHAR", NULL); } - Tcl_Free((void *)argv); + ckfree(argv); return TCL_ERROR; } /* * These dereferences are safe, even in the zero-length string cases, @@ -1788,25 +1750,25 @@ */ dcb.XonChar = argv[0][0]; dcb.XoffChar = argv[1][0]; if (argv[0][0] & 0x80 || argv[1][0] & 0x80) { - Tcl_UniChar character = 0; + int character; int charLen; - charLen = Tcl_UtfToUniChar(argv[0], &character); - if ((character > 0xFF) || argv[0][charLen]) { + charLen = TclUtfToUCS4(argv[0], &character); + if ((character & ~0xFF) || argv[0][charLen]) { goto badXchar; } dcb.XonChar = (char) character; - charLen = Tcl_UtfToUniChar(argv[1], &character); - if ((character > 0xFF) || argv[1][charLen]) { + charLen = TclUtfToUCS4(argv[1], &character); + if ((character & ~0xFF) || argv[1][charLen]) { goto badXchar; } dcb.XoffChar = (char) character; } - Tcl_Free((void *)argv); + ckfree(argv); if (!SetCommState(infoPtr->handle, &dcb)) { goto setStateFailed; } return TCL_OK; @@ -1815,11 +1777,11 @@ /* * Option -ttycontrol {DTR 1 RTS 0 BREAK 0} */ if ((len > 4) && (strncmp(optionName, "-ttycontrol", len) == 0)) { - int i, result = TCL_OK; + int i, res = TCL_OK; if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) { return TCL_ERROR; } if ((argc % 2) == 1) { @@ -1827,17 +1789,17 @@ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad value \"%s\" for -ttycontrol: should be " "a list of signal,value pairs", value)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "TTYCONTROL", NULL); } - Tcl_Free((void *)argv); + ckfree(argv); return TCL_ERROR; } for (i = 0; i < argc - 1; i += 2) { if (Tcl_GetBoolean(interp, argv[i+1], &flag) == TCL_ERROR) { - result = TCL_ERROR; + res = TCL_ERROR; break; } if (strncasecmp(argv[i], "DTR", strlen(argv[i])) == 0) { if (!EscapeCommFunction(infoPtr->handle, (DWORD) (flag ? SETDTR : CLRDTR))) { @@ -1845,11 +1807,11 @@ Tcl_SetObjResult(interp, Tcl_NewStringObj( "can't set DTR signal", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "TTY_SIGNAL", NULL); } - result = TCL_ERROR; + res = TCL_ERROR; break; } } else if (strncasecmp(argv[i], "RTS", strlen(argv[i])) == 0) { if (!EscapeCommFunction(infoPtr->handle, (DWORD) (flag ? SETRTS : CLRRTS))) { @@ -1857,11 +1819,11 @@ Tcl_SetObjResult(interp, Tcl_NewStringObj( "can't set RTS signal", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "TTY_SIGNAL", NULL); } - result = TCL_ERROR; + res = TCL_ERROR; break; } } else if (strncasecmp(argv[i], "BREAK", strlen(argv[i])) == 0) { if (!EscapeCommFunction(infoPtr->handle, (DWORD) (flag ? SETBREAK : CLRBREAK))) { @@ -1869,11 +1831,11 @@ Tcl_SetObjResult(interp, Tcl_NewStringObj( "can't set BREAK signal", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "TTY_SIGNAL", NULL); } - result = TCL_ERROR; + res = TCL_ERROR; break; } } else { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -1880,17 +1842,17 @@ "bad signal name \"%s\" for -ttycontrol: must be" " DTR, RTS or BREAK", argv[i])); Tcl_SetErrorCode(interp, "TCL", "VALUE", "TTY_SIGNAL", NULL); } - result = TCL_ERROR; + res = TCL_ERROR; break; } } - Tcl_Free((void *)argv); - return result; + ckfree(argv); + return res; } /* * Option -sysbuffer {read_size write_size} * Option -sysbuffer read_size @@ -1899,11 +1861,11 @@ if ((len > 1) && (strncmp(optionName, "-sysbuffer", len) == 0)) { /* * -sysbuffer 4096 or -sysbuffer {64536 4096} */ - int inSize = -1, outSize = -1; + size_t inSize = (size_t) -1, outSize = (size_t) -1; if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) { return TCL_ERROR; } if (argc == 1) { @@ -1911,11 +1873,11 @@ outSize = infoPtr->sysBufWrite; } else if (argc == 2) { inSize = atoi(argv[0]); outSize = atoi(argv[1]); } - Tcl_Free((void *)argv); + ckfree(argv); if ((argc < 1) || (argc > 2) || (inSize <= 0) || (outSize <= 0)) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad value \"%s\" for -sysbuffer: should be " @@ -1988,12 +1950,11 @@ return TCL_OK; } return Tcl_BadChannelOption(interp, optionName, - "closemode mode handshake pollinterval sysbuffer timeout " - "ttycontrol xchar"); + "mode handshake pollinterval sysbuffer timeout ttycontrol xchar"); getStateFailed: if (interp != NULL) { TclWinConvertError(GetLastError()); Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -2047,31 +2008,10 @@ if (optionName == NULL) { len = 0; } else { len = strlen(optionName); - } - - /* - * Get option -closemode - */ - - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-closemode"); - } - if (len==0 || (len>1 && strncmp(optionName, "-closemode", len)==0)) { - switch (infoPtr->flags & SERIAL_CLOSE_MASK) { - case SERIAL_CLOSE_DRAIN: - Tcl_DStringAppendElement(dsPtr, "drain"); - break; - case SERIAL_CLOSE_DISCARD: - Tcl_DStringAppendElement(dsPtr, "discard"); - break; - default: - Tcl_DStringAppendElement(dsPtr, "default"); - break; - } } /* * Get option -mode */ @@ -2149,11 +2089,11 @@ if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-xchar"); Tcl_DStringStartSublist(dsPtr); } if (len==0 || (len>1 && strncmp(optionName, "-xchar", len) == 0)) { - char buf[TCL_UTF_MAX]; + char buf[4]; valid = 1; if (!GetCommState(infoPtr->handle, &dcb)) { if (interp != NULL) { TclWinConvertError(GetLastError()); @@ -2160,13 +2100,13 @@ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't get comm state: %s", Tcl_PosixError(interp))); } return TCL_ERROR; } - buf[Tcl_UniCharToUtf(UCHAR(dcb.XonChar), buf)] = '\0'; + sprintf(buf, "%c", dcb.XonChar); Tcl_DStringAppendElement(dsPtr, buf); - buf[Tcl_UniCharToUtf(UCHAR(dcb.XoffChar), buf)] = '\0'; + sprintf(buf, "%c", dcb.XoffChar); Tcl_DStringAppendElement(dsPtr, buf); } if (len == 0) { Tcl_DStringEndSublist(dsPtr); } @@ -2246,12 +2186,11 @@ if (valid) { return TCL_OK; } return Tcl_BadChannelOption(interp, optionName, - "closemode mode pollinterval lasterror queue sysbuffer ttystatus " - "xchar"); + "mode pollinterval lasterror queue sysbuffer ttystatus xchar"); } /* *---------------------------------------------------------------------- * Index: win/tclWinSock.c ================================================================== --- win/tclWinSock.c +++ win/tclWinSock.c @@ -59,19 +59,27 @@ * currently disabled. */ #undef TCL_FEATURE_KEEPALIVE_NAGLE +/* + * Make sure to remove the redirection defines set in tclWinPort.h that is in + * use in other sections of the core, except for us. + */ + +#undef getservbyname +#undef getsockopt +#undef setsockopt + /* * Helper macros to make parts of this file clearer. The macros do exactly * what they say on the tin. :-) They also only ever refer to their arguments * once, and so can be used without regard to side effects. */ #define SET_BITS(var, bits) ((var) |= (bits)) #define CLEAR_BITS(var, bits) ((var) &= ~(bits)) -#define GOT_BITS(var, bits) (((var) & (bits)) != 0) /* "sock" + a pointer in hex + \0 */ #define SOCK_CHAN_LENGTH (4 + sizeof(void *) * 2 + 1) #define SOCK_TEMPLATE "sock%p" @@ -80,11 +88,11 @@ * initialized. If 1, initialization of sockets was successful, if -1 then * socket initialization failed (WSAStartup failed). */ static int initialized = 0; -static const WCHAR className[] = L"TclSocket"; +static const WCHAR classname[] = L"TclSocket"; TCL_DECLARE_MUTEX(socketMutex) /* * The following defines declare the messages used on socket windows. */ @@ -123,12 +131,10 @@ struct TcpFdList *next; } TcpFdList; struct TcpState { Tcl_Channel channel; /* Channel associated with this socket. */ - int testFlags; /* bit field for tests. Is set by testsocket - * test procedure */ struct TcpFdList *sockets; /* Windows SOCKET handle. */ int flags; /* Bit field comprised of the flags described * below. */ int watchEvents; /* OR'ed combination of FD_READ, FD_WRITE, * FD_CLOSE, FD_ACCEPT and FD_CONNECT that @@ -184,19 +190,10 @@ * process an async connect. This * flag indicates that reentry is * still pending */ #define TCP_ASYNC_FAILED (1<<5) /* An async connect finally failed */ -/* - * These bits may be ORed together into the "testFlags" field of a TcpState - * structure. - */ - -#define TCP_ASYNC_TEST_MODE (1<<0) /* Async testing activated. Do not - * automatically continue connection - * process */ - /* * The following structure is what is added to the Tcl event queue when a * socket event occurs. */ @@ -233,11 +230,11 @@ TcpState *socketList; /* Every open socket in this thread has an * entry on this list. */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; -static WNDCLASS windowClass; +static WNDCLASSW windowClass; /* * Static routines for this file: */ @@ -302,43 +299,26 @@ */ static TclInitProcessGlobalValueProc InitializeHostName; static ProcessGlobalValue hostName = {0, 0, NULL, NULL, InitializeHostName, NULL, NULL}; - -/* - * Simple wrapper round the SendMessage syscall. - */ - -#define SendSelectMessage(tsdPtr, message, payload) \ - SendMessage((tsdPtr)->hwnd, SOCKET_SELECT, \ - (WPARAM) (message), (LPARAM) (payload)) - /* * Address print debug functions */ #if 0 -void -printaddrinfo( - struct addrinfo *ai, - char *prefix) +void printaddrinfo(struct addrinfo *ai, char *prefix) { char host[NI_MAXHOST], port[NI_MAXSERV]; - getnameinfo(ai->ai_addr, ai->ai_addrlen, - host, sizeof(host), port, sizeof(port), - NI_NUMERICHOST|NI_NUMERICSERV); -} - -void -printaddrinfolist( - struct addrinfo *addrlist, - char *prefix) + host, sizeof(host), + port, sizeof(port), + NI_NUMERICHOST|NI_NUMERICSERV); +} +void printaddrinfolist(struct addrinfo *addrlist, char *prefix) { struct addrinfo *ai; - for (ai = addrlist; ai != NULL; ai = ai->ai_next) { printaddrinfo(ai, prefix); } } #endif @@ -358,23 +338,23 @@ */ void InitializeHostName( char **valuePtr, - size_t *lengthPtr, + int *lengthPtr, Tcl_Encoding *encodingPtr) { - WCHAR tbuf[MAX_COMPUTERNAME_LENGTH + 1]; - DWORD length = MAX_COMPUTERNAME_LENGTH + 1; + WCHAR wbuf[256]; + DWORD length = sizeof(wbuf)/sizeof(WCHAR); Tcl_DString ds; - if (GetComputerName(tbuf, &length) != 0) { + if (GetComputerNameExW(ComputerNamePhysicalDnsFullyQualified, wbuf, &length) != 0) { /* * Convert string from native to UTF then change to lowercase. */ - Tcl_UtfToLower(Tcl_WinTCharToUtf(tbuf, -1, &ds)); + Tcl_UtfToLower(Tcl_WinTCharToUtf((TCHAR *)wbuf, -1, &ds)); } else { Tcl_DStringInit(&ds); if (TclpHasSockets(NULL) == TCL_OK) { /* @@ -395,11 +375,11 @@ } } *encodingPtr = Tcl_GetEncoding(NULL, "utf-8"); *lengthPtr = Tcl_DStringLength(&ds); - *valuePtr = Tcl_Alloc(*lengthPtr + 1); + *valuePtr = ckalloc((*lengthPtr) + 1); memcpy(*valuePtr, Tcl_DStringValue(&ds), *lengthPtr + 1); Tcl_DStringFree(&ds); } /* @@ -499,11 +479,11 @@ return; } if (tsdPtr->socketThread != NULL) { if (tsdPtr->hwnd != NULL) { - PostMessage(tsdPtr->hwnd, SOCKET_TERMINATE, 0, 0); + PostMessageW(tsdPtr->hwnd, SOCKET_TERMINATE, 0, 0); /* * Wait for the thread to exit. This ensures that we are * completely cleaned up before we leave this function. */ @@ -540,11 +520,10 @@ * Sets the device into blocking or nonblocking mode. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int TcpBlockModeProc( ClientData instanceData, /* Socket state. */ int mode) /* The mode to set. Can be one of * TCL_MODE_BLOCKING or @@ -551,91 +530,78 @@ * TCL_MODE_NONBLOCKING. */ { TcpState *statePtr = instanceData; if (mode == TCL_MODE_NONBLOCKING) { - SET_BITS(statePtr->flags, TCP_NONBLOCKING); + statePtr->flags |= TCP_NONBLOCKING; } else { - CLEAR_BITS(statePtr->flags, TCP_NONBLOCKING); + statePtr->flags &= ~(TCP_NONBLOCKING); } return 0; } /* *---------------------------------------------------------------------- * * WaitForConnect -- * - * Check the state of an async connect process. If a connection attempt - * terminated, process it, which may finalize it or may start the next - * attempt. If a connect error occures, it is saved in - * statePtr->connectError to be reported by 'fconfigure -error'. + * Check the state of an async connect process. If a connection + * attempt terminated, process it, which may finalize it or may + * start the next attempt. If a connect error occures, it is saved + * in statePtr->connectError to be reported by 'fconfigure -error'. * * There are two modes of operation, defined by errorCodePtr: - * * non-NULL: Called by explicite read/write command. Block if socket - * is blocking. + * * non-NULL: Called by explicite read/write command. block if + * socket is blocking. * May return two error codes: * * EWOULDBLOCK: if connect is still in progress - * * ENOTCONN: if connect failed. This would be the error message - * of a rect or sendto syscall so this is emulated here. - * * Null: Called by a backround operation. Do not block and don't - * return any error code. + * * ENOTCONN: if connect failed. This would be the error + * message of a rect or sendto syscall so this is + * emulated here. + * * Null: Called by a backround operation. Do not block and + * don't return any error code. * * Results: - * 0 if the connection has completed, -1 if still in progress or there is - * an error. + * 0 if the connection has completed, -1 if still in progress + * or there is an error. * * Side effects: - * Processes socket events off the system queue. May process - * asynchroneous connect. + * Processes socket events off the system queue. + * May process asynchroneous connect. * *---------------------------------------------------------------------- */ static int WaitForConnect( TcpState *statePtr, /* State of the socket. */ - int *errorCodePtr) /* Where to store errors? A passed - * null-pointer activates background mode. */ + int *errorCodePtr) /* Where to store errors? + * A passed null-pointer activates background mode. + */ { int result; int oldMode; ThreadSpecificData *tsdPtr; /* - * Check if an async connect failed already and error reporting is - * demanded, return the error ENOTCONN. + * Check if an async connect failed already and error reporting is demanded, + * return the error ENOTCONN */ - if (errorCodePtr != NULL && GOT_BITS(statePtr->flags, TCP_ASYNC_FAILED)) { + if (errorCodePtr != NULL && (statePtr->flags & TCP_ASYNC_FAILED)) { *errorCodePtr = ENOTCONN; return -1; } /* * Check if an async connect is running. If not return ok */ - if (!GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) { + if (!(statePtr->flags & TCP_ASYNC_CONNECT)) { return 0; } - /* - * In socket test mode do not continue with the connect - * Exceptions are: - * - Call by recv/send and blocking socket - * (errorCodePtr != NULL && !GOT_BITS(flags, TCP_NONBLOCKING)) - * - Call by the event queue (errorCodePtr == NULL) - */ - - if (GOT_BITS(statePtr->testFlags, TCP_ASYNC_TEST_MODE) - && errorCodePtr != NULL - && GOT_BITS(statePtr->flags, TCP_NONBLOCKING)) { - *errorCodePtr = EWOULDBLOCK; - return -1; - } - /* * Be sure to disable event servicing so we are truly modal. */ oldMode = Tcl_SetServiceMode(TCL_SERVICE_NONE); @@ -643,108 +609,89 @@ /* * Loop in the blocking case until the connect signal is present */ while (1) { - /* - * Get the statePtr lock. - */ + /* get statePtr lock */ tsdPtr = TclThreadDataKeyGet(&dataKey); WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - /* - * Check for connect event. - */ - - if (GOT_BITS(statePtr->readyEvents, FD_CONNECT)) { - /* - * Consume the connect event. - */ - - CLEAR_BITS(statePtr->readyEvents, FD_CONNECT); - - /* - * For blocking sockets and foreground processing, disable async - * connect as we continue now synchoneously. - */ - - if (errorCodePtr != NULL && - !GOT_BITS(statePtr->flags, TCP_NONBLOCKING)) { + /* Check for connect event */ + if (statePtr->readyEvents & FD_CONNECT) { + + /* Consume the connect event */ + statePtr->readyEvents &= ~(FD_CONNECT); + + /* + * For blocking sockets and foreground processing + * disable async connect as we continue now synchoneously + */ + if ( errorCodePtr != NULL && + ! (statePtr->flags & TCP_NONBLOCKING) ) { CLEAR_BITS(statePtr->flags, TCP_ASYNC_CONNECT); } - /* - * Free list lock. - */ - + /* Free list lock */ SetEvent(tsdPtr->socketListLock); /* - * Continue connect. If switched to synchroneous connect, the - * connect is terminated. + * Continue connect. + * If switched to synchroneous connect, the connect is terminated. */ - result = TcpConnect(NULL, statePtr); - /* - * Restore event service mode. - */ - + /* Restore event service mode */ (void) Tcl_SetServiceMode(oldMode); /* * Check for Succesfull connect or async connect restart */ if (result == TCL_OK) { /* - * Check for async connect restart (not possible for - * foreground blocking operation) + * Check for async connect restart + * (not possible for foreground blocking operation) */ - - if (GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) { + if ( statePtr->flags & TCP_ASYNC_PENDING ) { if (errorCodePtr != NULL) { *errorCodePtr = EWOULDBLOCK; } return -1; } return 0; } /* - * Connect finally failed. For foreground operation return - * ENOTCONN. + * Connect finally failed. + * For foreground operation return ENOTCONN. */ if (errorCodePtr != NULL) { *errorCodePtr = ENOTCONN; } return -1; } - /* - * Free list lock. - */ - + /* Free list lock */ SetEvent(tsdPtr->socketListLock); /* * Background operation returns with no action as there was no connect * event */ - if (errorCodePtr == NULL) { + if ( errorCodePtr == NULL ) { return -1; } /* * A non blocking socket waiting for an asynchronous connect * returns directly the error EWOULDBLOCK */ - if (GOT_BITS(statePtr->flags, TCP_NONBLOCKING)) { + if (statePtr->flags & TCP_NONBLOCKING) { *errorCodePtr = EWOULDBLOCK; return -1; } /* @@ -772,11 +719,10 @@ * Reads input from the input device of the channel. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int TcpInputProc( ClientData instanceData, /* Socket state. */ char *buf, /* Where to store data read. */ int bufSize, /* How much space is available in the @@ -804,11 +750,11 @@ /* * First check to see if EOF was already detected, to prevent calling the * socket stack after the first time EOF is detected. */ - if (GOT_BITS(statePtr->flags, SOCKET_EOF)) { + if (statePtr->flags & SOCKET_EOF) { return 0; } /* * Check if there is an async connect running. @@ -827,26 +773,22 @@ * read. We have to simulate blocking behavior here since we are always * using non-blocking sockets. */ while (1) { - SendSelectMessage(tsdPtr, UNSELECT, statePtr); - - /* - * Single fd operation: this proc is only called for a connected - * socket. - */ - + SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, + (WPARAM) UNSELECT, (LPARAM) statePtr); + /* single fd operation: this proc is only called for a connected socket. */ bytesRead = recv(statePtr->sockets->fd, buf, bufSize, 0); - CLEAR_BITS(statePtr->readyEvents, FD_READ); + statePtr->readyEvents &= ~(FD_READ); /* * Check for end-of-file condition or successful read. */ if (bytesRead == 0) { - SET_BITS(statePtr->flags, SOCKET_EOF); + statePtr->flags |= SOCKET_EOF; } if (bytesRead != SOCKET_ERROR) { break; } @@ -853,12 +795,12 @@ /* * If an error occurs after the FD_CLOSE has arrived, then ignore the * error and report an EOF. */ - if (GOT_BITS(statePtr->readyEvents, FD_CLOSE)) { - SET_BITS(statePtr->flags, SOCKET_EOF); + if (statePtr->readyEvents & FD_CLOSE) { + statePtr->flags |= SOCKET_EOF; bytesRead = 0; break; } error = WSAGetLastError(); @@ -867,21 +809,20 @@ * If an RST comes, then ignore the error and report an EOF just like * on unix. */ if (error == WSAECONNRESET) { - SET_BITS(statePtr->flags, SOCKET_EOF); + statePtr->flags |= SOCKET_EOF; bytesRead = 0; break; } /* * Check for error condition or underflow in non-blocking case. */ - if (GOT_BITS(statePtr->flags, TCP_NONBLOCKING) - || (error != WSAEWOULDBLOCK)) { + if ((statePtr->flags & TCP_NONBLOCKING) || (error != WSAEWOULDBLOCK)) { TclWinConvertError(error); *errorCodePtr = Tcl_GetErrno(); bytesRead = -1; break; } @@ -895,11 +836,11 @@ bytesRead = -1; break; } } - SendSelectMessage(tsdPtr, SELECT, statePtr); + SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)statePtr); return bytesRead; } /* @@ -953,28 +894,24 @@ if (WaitForConnect(statePtr, errorCodePtr) != 0) { return -1; } while (1) { - SendSelectMessage(tsdPtr, UNSELECT, statePtr); + SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, + (WPARAM) UNSELECT, (LPARAM) statePtr); - /* - * Single fd operation: this proc is only called for a connected - * socket. - */ - + /* single fd operation: this proc is only called for a connected socket. */ written = send(statePtr->sockets->fd, buf, toWrite, 0); if (written != SOCKET_ERROR) { /* * Since Windows won't generate a new write event until we hit an * overflow condition, we need to force the event loop to poll * until the condition changes. */ - if (GOT_BITS(statePtr->watchEvents, FD_WRITE)) { + if (statePtr->watchEvents & FD_WRITE) { Tcl_Time blockTime = { 0, 0 }; - Tcl_SetMaxBlockTime(&blockTime); } break; } @@ -985,12 +922,12 @@ * send fails with WSAEWOULDBLOCK. */ error = WSAGetLastError(); if (error == WSAEWOULDBLOCK) { - CLEAR_BITS(statePtr->readyEvents, FD_WRITE); - if (GOT_BITS(statePtr->flags, TCP_NONBLOCKING)) { + statePtr->readyEvents &= ~(FD_WRITE); + if (statePtr->flags & TCP_NONBLOCKING) { *errorCodePtr = EWOULDBLOCK; written = -1; break; } } else { @@ -1009,11 +946,11 @@ written = -1; break; } } - SendSelectMessage(tsdPtr, SELECT, statePtr); + SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)statePtr); return written; } /* @@ -1032,11 +969,10 @@ * Closes the socket. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int TcpCloseProc( ClientData instanceData, /* The socket to close. */ Tcl_Interp *interp) /* Unused. */ { @@ -1056,19 +992,19 @@ * Clean up the OS socket handle. The default Windows setting for a * socket is SO_DONTLINGER, which does a graceful shutdown in the * background. */ - while (statePtr->sockets != NULL) { + while ( statePtr->sockets != NULL ) { TcpFdList *thisfd = statePtr->sockets; - statePtr->sockets = thisfd->next; + if (closesocket(thisfd->fd) == SOCKET_ERROR) { TclWinConvertError((DWORD) WSAGetLastError()); errorCode = Tcl_GetErrno(); } - Tcl_Free(thisfd); + ckfree(thisfd); } } if (statePtr->addrlist != NULL) { freeaddrinfo(statePtr->addrlist); @@ -1077,29 +1013,22 @@ freeaddrinfo(statePtr->myaddrlist); } /* * Clear an eventual tsd info list pointer. - * * This may be called, if an async socket connect fails or is closed * between connect and thread action callback. */ - if (tsdPtr->pendingTcpState != NULL && tsdPtr->pendingTcpState == statePtr) { - /* - * Get infoPtr lock, because this concerns the notifier thread. - */ + /* get infoPtr lock, because this concerns the notifier thread */ WaitForSingleObject(tsdPtr->socketListLock, INFINITE); tsdPtr->pendingTcpState = NULL; - /* - * Free list lock. - */ - + /* Free list lock */ SetEvent(tsdPtr->socketListLock); } /* * TIP #218. Removed the code removing the structure from the global @@ -1106,11 +1035,11 @@ * socket list. This is now done by the thread action callbacks, and only * there. This happens before this code is called. We can free without * fear of damaging the list. */ - Tcl_Free(statePtr); + ckfree(statePtr); return errorCode; } /* *---------------------------------------------------------------------- @@ -1134,43 +1063,32 @@ ClientData instanceData, /* The socket to close. */ Tcl_Interp *interp, /* For error reporting. */ int flags) /* Flags that indicate which side to close. */ { TcpState *statePtr = instanceData; - int errorCode = 0; - int sd; + int readError = 0; + int writeError = 0; /* * Shutdown the OS socket handle. */ - switch(flags) { - case TCL_CLOSE_READ: - sd = SD_RECEIVE; - break; - case TCL_CLOSE_WRITE: - sd = SD_SEND; - break; - default: - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "socket close2proc called bidirectionally", -1)); - } - return TCL_ERROR; - } - - /* - * Single fd operation: Tcl_OpenTcpServer() does not set TCL_READABLE or - * TCL_WRITABLE so this should never be called for a server socket. - */ - - if (shutdown(statePtr->sockets->fd, sd) == SOCKET_ERROR) { + if ((flags & (TCL_CLOSE_READ|TCL_CLOSE_WRITE)) == 0) { + return TcpCloseProc(instanceData, interp); + } + + /* single fd operation: Tcl_OpenTcpServer() does not set TCL_READABLE or + * TCL_WRITABLE so this should never be called for a server socket. */ + if ((flags & TCL_CLOSE_READ) && (shutdown(statePtr->sockets->fd, SD_RECEIVE) == SOCKET_ERROR)) { + TclWinConvertError((DWORD) WSAGetLastError()); + readError = Tcl_GetErrno(); + } + if ((flags & TCL_CLOSE_WRITE) && (shutdown(statePtr->sockets->fd, SD_SEND) == SOCKET_ERROR)) { TclWinConvertError((DWORD) WSAGetLastError()); - errorCode = Tcl_GetErrno(); + writeError = Tcl_GetErrno(); } - - return errorCode; + return (readError != 0) ? readError : writeError; } /* *---------------------------------------------------------------------- * @@ -1212,11 +1130,11 @@ } return TCL_ERROR; } #ifdef TCL_FEATURE_KEEPALIVE_NAGLE -#error "TCL_FEATURE_KEEPALIVE_NAGLE not reviewed for whether to treat statePtr->sockets as single fd or list" + #error "TCL_FEATURE_KEEPALIVE_NAGLE not reviewed for whether to treat statePtr->sockets as single fd or list" sock = statePtr->sockets->fd; if (!strcasecmp(optionName, "-keepalive")) { BOOL val = FALSE; int boolVar, rtn; @@ -1321,118 +1239,109 @@ return TCL_ERROR; } /* * Go one step in async connect - * - * If any error is thrown save it as backround error to report eventually - * below. + * If any error is thrown save it as backround error to report eventually below */ - - if (!GOT_BITS(statePtr->testFlags, TCP_ASYNC_TEST_MODE)) { - WaitForConnect(statePtr, NULL); - } + WaitForConnect(statePtr, NULL); sock = statePtr->sockets->fd; if (optionName != NULL) { len = strlen(optionName); } if ((len > 1) && (optionName[1] == 'e') && (strncmp(optionName, "-error", len) == 0)) { + /* - * Do not return any errors if async connect is running. - */ + * Do not return any errors if async connect is running + */ + if ( ! (statePtr->flags & TCP_ASYNC_PENDING) ) { - if (!GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) { - if (GOT_BITS(statePtr->flags, TCP_ASYNC_FAILED)) { + + if ( statePtr->flags & TCP_ASYNC_FAILED ) { + /* * In case of a failed async connect, eventually report the - * connect error only once. Do not report the system error, - * as this comes again and again. + * connect error only once. + * Do not report the system error, as this comes again and again. */ - if (statePtr->connectError != 0) { + if ( statePtr->connectError != 0 ) { Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(statePtr->connectError), -1); statePtr->connectError = 0; } + } else { + /* - * Report an eventual last error of the socket system. + * Report an eventual last error of the socket system */ int optlen; int ret; DWORD err; /* - * Populate the err variable with a POSIX error + * Populater the err Variable with a possix error */ - optlen = sizeof(int); ret = getsockopt(sock, SOL_SOCKET, SO_ERROR, (char *)&err, &optlen); - /* - * The error was not returned directly but should be taken - * from WSA. + * The error was not returned directly but should be + * taken from WSA */ - if (ret == SOCKET_ERROR) { err = WSAGetLastError(); } - /* - * Return error message. + * Return error message */ - if (err) { TclWinConvertError(err); - Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(Tcl_GetErrno()), - -1); + Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(Tcl_GetErrno()), -1); } } } return TCL_OK; } if ((len > 1) && (optionName[1] == 'c') && (strncmp(optionName, "-connecting", len) == 0)) { + Tcl_DStringAppend(dsPtr, - GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING) + (statePtr->flags & TCP_ASYNC_PENDING) ? "1" : "0", -1); return TCL_OK; } - if (interp != NULL - && Tcl_GetVar2(interp, SUPPRESS_RDNS_VAR, NULL, 0) != NULL) { + if (interp != NULL && Tcl_GetVar(interp, SUPPRESS_RDNS_VAR, 0) != NULL) { reverseDNS = NI_NUMERICHOST; } if ((len == 0) || ((len > 1) && (optionName[1] == 'p') && (strncmp(optionName, "-peername", len) == 0))) { address peername; socklen_t size = sizeof(peername); - if (GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) { + if ( (statePtr->flags & TCP_ASYNC_PENDING) ) { /* * In async connect output an empty string */ - if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-peername"); Tcl_DStringAppendElement(dsPtr, ""); } else { return TCL_OK; } - } else if (getpeername(sock, (LPSOCKADDR) &(peername.sa), - &size) == 0) { + } else if ( getpeername(sock, (LPSOCKADDR) &(peername.sa), &size) == 0) { /* * Peername fetch succeeded - output list */ - if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-peername"); Tcl_DStringStartSublist(dsPtr); } @@ -1477,16 +1386,15 @@ if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-sockname"); Tcl_DStringStartSublist(dsPtr); } - if (GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) { + if ( (statePtr->flags & TCP_ASYNC_PENDING ) ) { /* * In async connect output an empty string */ - - found = 1; + found = 1; } else { for (fds = statePtr->sockets; fds != NULL; fds = fds->next) { sock = fds->fd; size = sizeof(sockname); if (getsockname(sock, &(sockname.sa), &size) >= 0) { @@ -1496,15 +1404,13 @@ getnameinfo(&sockname.sa, size, host, sizeof(host), NULL, 0, NI_NUMERICHOST); Tcl_DStringAppendElement(dsPtr, host); /* - * We don't want to resolve INADDR_ANY and sin6addr_any; - * they can sometimes cause problems (and never have a - * name). + * We don't want to resolve INADDR_ANY and sin6addr_any; they + * can sometimes cause problems (and never have a name). */ - flags |= NI_NUMERICSERV; if (sockname.sa.sa_family == AF_INET) { if (sockname.sa4.sin_addr.s_addr == INADDR_ANY) { flags |= NI_NUMERICHOST; } @@ -1584,12 +1490,11 @@ if (len > 0) { #ifdef TCL_FEATURE_KEEPALIVE_NAGLE return Tcl_BadChannelOption(interp, optionName, "connecting peername sockname keepalive nagle"); #else - return Tcl_BadChannelOption(interp, optionName, - "connecting peername sockname"); + return Tcl_BadChannelOption(interp, optionName, "connecting peername sockname"); #endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/ } return TCL_OK; } @@ -1626,15 +1531,15 @@ * socket. [Bug 557878] */ if (!statePtr->acceptProc) { statePtr->watchEvents = 0; - if (GOT_BITS(mask, TCL_READABLE)) { - SET_BITS(statePtr->watchEvents, FD_READ | FD_CLOSE); + if (mask & TCL_READABLE) { + statePtr->watchEvents |= (FD_READ|FD_CLOSE); } - if (GOT_BITS(mask, TCL_WRITABLE)) { - SET_BITS(statePtr->watchEvents, FD_WRITE | FD_CLOSE); + if (mask & TCL_WRITABLE) { + statePtr->watchEvents |= (FD_WRITE|FD_CLOSE); } /* * If there are any conditions already set, then tell the notifier to * poll rather than block. @@ -1664,11 +1569,10 @@ * None. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int TcpGetHandleProc( ClientData instanceData, /* The socket state. */ int direction, /* Not used. */ ClientData *handlePtr) /* Where to store the handle. */ @@ -1721,28 +1625,29 @@ TcpConnect( Tcl_Interp *interp, /* For error reporting; can be NULL. */ TcpState *statePtr) { DWORD error; - int async_connect = GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT); - /* We are started with async connect and the - * connect notification was not yet - * received. */ - int async_callback = GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING); - /* We were called by the event procedure and - * continue our loop. */ + /* + * We are started with async connect and the connect notification + * was not jet received + */ + int async_connect = statePtr->flags & TCP_ASYNC_CONNECT; + /* We were called by the event procedure and continue our loop */ + int async_callback = statePtr->flags & TCP_ASYNC_PENDING; ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); if (async_callback) { goto reenter; } for (statePtr->addr = statePtr->addrlist; statePtr->addr != NULL; - statePtr->addr = statePtr->addr->ai_next) { - for (statePtr->myaddr = statePtr->myaddrlist; - statePtr->myaddr != NULL; - statePtr->myaddr = statePtr->myaddr->ai_next) { + statePtr->addr = statePtr->addr->ai_next) { + + for (statePtr->myaddr = statePtr->myaddrlist; statePtr->myaddr != NULL; + statePtr->myaddr = statePtr->myaddr->ai_next) { + /* * No need to try combinations of local and remote addresses * of different families. */ @@ -1752,41 +1657,29 @@ /* * Close the socket if it is still open from the last unsuccessful * iteration. */ - if (statePtr->sockets->fd != INVALID_SOCKET) { closesocket(statePtr->sockets->fd); } - /* - * Get statePtr lock. - */ - + /* get statePtr lock */ WaitForSingleObject(tsdPtr->socketListLock, INFINITE); /* * Reset last error from last try */ - statePtr->notifierConnectError = 0; Tcl_SetErrno(0); - statePtr->sockets->fd = socket(statePtr->myaddr->ai_family, - SOCK_STREAM, 0); + statePtr->sockets->fd = socket(statePtr->myaddr->ai_family, SOCK_STREAM, 0); - /* - * Free list lock. - */ - + /* Free list lock */ SetEvent(tsdPtr->socketListLock); - /* - * Continue on socket creation error. - */ - + /* continue on socket creation error */ if (statePtr->sockets->fd == INVALID_SOCKET) { TclWinConvertError((DWORD) WSAGetLastError()); continue; } @@ -1793,54 +1686,46 @@ /* * Win-NT has a misfeature that sockets are inherited in child * processes by default. Turn off the inherit bit. */ - SetHandleInformation((HANDLE) statePtr->sockets->fd, - HANDLE_FLAG_INHERIT, 0); + SetHandleInformation((HANDLE) statePtr->sockets->fd, HANDLE_FLAG_INHERIT, 0); /* * Set kernel space buffering */ - TclSockMinimumBuffers((void *) statePtr->sockets->fd, - TCP_BUFFER_SIZE); + TclSockMinimumBuffers((void *) statePtr->sockets->fd, TCP_BUFFER_SIZE); /* * Try to bind to a local port. */ if (bind(statePtr->sockets->fd, statePtr->myaddr->ai_addr, - statePtr->myaddr->ai_addrlen) == SOCKET_ERROR) { + statePtr->myaddr->ai_addrlen) == SOCKET_ERROR) { TclWinConvertError((DWORD) WSAGetLastError()); continue; } - /* * For asynchroneous connect set the socket in nonblocking mode * and activate connect notification */ - if (async_connect) { TcpState *statePtr2; int in_socket_list = 0; - - /* - * Get statePtr lock. - */ - + /* get statePtr lock */ WaitForSingleObject(tsdPtr->socketListLock, INFINITE); /* * Bugfig for 336441ed59 to not ignore notifications until the * infoPtr is in the list. * Check if my statePtr is already in the tsdPtr->socketList * It is set after this call by TcpThreadActionProc and is set * on a second round. * - * If not, we buffer my statePtr in the tsd memory so it is - * not lost by the event procedure + * If not, we buffer my statePtr in the tsd memory so it is not + * lost by the event procedure */ for (statePtr2 = tsdPtr->socketList; statePtr2 != NULL; statePtr2 = statePtr2->nextPtr) { if (statePtr2 == statePtr) { @@ -1849,31 +1734,25 @@ } } if (!in_socket_list) { tsdPtr->pendingTcpState = statePtr; } - - /* - * Set connect mask to connect events - * - * This is activated by a SOCKET_SELECT message to the - * notifier thread. - */ - - SET_BITS(statePtr->selectEvents, FD_CONNECT); - - /* - * Free list lock. - */ - - SetEvent(tsdPtr->socketListLock); - - /* - * Activate accept notification. - */ - - SendSelectMessage(tsdPtr, SELECT, statePtr); + /* + * Set connect mask to connect events + * This is activated by a SOCKET_SELECT message to the notifier + * thread. + */ + statePtr->selectEvents |= FD_CONNECT; + + /* + * Free list lock + */ + SetEvent(tsdPtr->socketListLock); + + /* activate accept notification */ + SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, + (LPARAM) statePtr); } /* * Attempt to connect to the remote socket. */ @@ -1885,66 +1764,49 @@ TclWinConvertError(error); if (async_connect && error == WSAEWOULDBLOCK) { /* * Asynchroneous connect - * + */ + + /* * Remember that we jump back behind this next round */ - - SET_BITS(statePtr->flags, TCP_ASYNC_PENDING); + statePtr->flags |= TCP_ASYNC_PENDING; return TCL_OK; reenter: /* * Re-entry point for async connect after connect event or * blocking operation * * Clear the reenter flag */ - - CLEAR_BITS(statePtr->flags, TCP_ASYNC_PENDING); - - /* - * Get statePtr lock. - */ - + statePtr->flags &= ~(TCP_ASYNC_PENDING); + /* get statePtr lock */ WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - - /* - * Get signaled connect error. - */ - + /* Get signaled connect error */ TclWinConvertError((DWORD) statePtr->notifierConnectError); - - /* - * Clear eventual connect flag. - */ - - CLEAR_BITS(statePtr->selectEvents, FD_CONNECT); - - /* - * Free list lock. - */ - + /* Clear eventual connect flag */ + statePtr->selectEvents &= ~(FD_CONNECT); + /* Free list lock */ SetEvent(tsdPtr->socketListLock); } /* * Clear the tsd socket list pointer if we did not wait for * the FD_CONNECT asynchroneously */ - tsdPtr->pendingTcpState = NULL; if (Tcl_GetErrno() == 0) { goto out; } } } - out: +out: /* * Socket connected or connection failed */ /* @@ -1951,74 +1813,53 @@ * Async connect terminated */ CLEAR_BITS(statePtr->flags, TCP_ASYNC_CONNECT); - if (Tcl_GetErrno() == 0) { + if ( Tcl_GetErrno() == 0 ) { /* * Succesfully connected - * + */ + /* * Set up the select mask for read/write events. */ - statePtr->selectEvents = FD_READ | FD_WRITE | FD_CLOSE; /* * Register for interest in events in the select mask. Note that this * automatically places the socket into non-blocking mode. */ - SendSelectMessage(tsdPtr, SELECT, statePtr); + SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, + (LPARAM) statePtr); } else { /* * Connect failed - * + */ + + /* * For async connect schedule a writable event to report the fail. */ - if (async_callback) { /* * Set up the select mask for read/write events. */ - statePtr->selectEvents = FD_WRITE|FD_READ; - - /* - * Get statePtr lock. - */ - + /* get statePtr lock */ WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - - /* - * Signal ready readable and writable events. - */ - - SET_BITS(statePtr->readyEvents, FD_WRITE | FD_READ); - - /* - * Flag error to event routine. - */ - - SET_BITS(statePtr->flags, TCP_ASYNC_FAILED); - - /* - * Save connect error to be reported by 'fconfigure -error'. - */ - + /* Signal ready readable and writable events */ + statePtr->readyEvents |= FD_WRITE | FD_READ; + /* Flag error to event routine */ + statePtr->flags |= TCP_ASYNC_FAILED; + /* Save connect error to be reported by 'fconfigure -error' */ statePtr->connectError = Tcl_GetErrno(); - - /* - * Free list lock. - */ - + /* Free list lock */ SetEvent(tsdPtr->socketListLock); } - /* * Error message on synchroneous connect */ - if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't open socket: %s", Tcl_PosixError(interp))); } return TCL_ERROR; @@ -2092,11 +1933,11 @@ statePtr = NewSocketInfo(INVALID_SOCKET); statePtr->addrlist = addrlist; statePtr->myaddrlist = myaddrlist; if (async) { - SET_BITS(statePtr->flags, TCP_ASYNC_CONNECT); + statePtr->flags |= TCP_ASYNC_CONNECT; } /* * Create a new client socket and wrap it in a channel. */ @@ -2162,11 +2003,11 @@ /* * Start watching for read/write events on the socket. */ statePtr->selectEvents = FD_READ | FD_CLOSE | FD_WRITE; - SendSelectMessage(tsdPtr, SELECT, statePtr); + SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)statePtr); sprintf(channelName, SOCK_TEMPLATE, statePtr); statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, statePtr, (TCL_READABLE | TCL_WRITABLE)); Tcl_SetChannelOption(NULL, statePtr->channel, "-translation", "auto crlf"); @@ -2174,11 +2015,11 @@ } /* *---------------------------------------------------------------------- * - * Tcl_OpenTcpServerEx -- + * Tcl_OpenTcpServer -- * * Opens a TCP server socket and creates a channel around it. * * Results: * The channel or NULL if failed. If an error occurred, an error message @@ -2189,15 +2030,14 @@ * *---------------------------------------------------------------------- */ Tcl_Channel -Tcl_OpenTcpServerEx( +Tcl_OpenTcpServer( Tcl_Interp *interp, /* For error reporting - may be NULL. */ - const char *service, /* Port number to open. */ + int port, /* Port number to open. */ const char *myHost, /* Name of local host. */ - unsigned int flags, /* Flags. */ Tcl_TcpAcceptProc *acceptProc, /* Callback for accepting connections from new * clients. */ ClientData acceptProcData) /* Data for the callback. */ { @@ -2207,11 +2047,10 @@ struct addrinfo *addrPtr; /* Socket address to listen on. */ TcpState *statePtr = NULL; /* The returned value. */ char channelName[SOCK_CHAN_LENGTH]; u_long flag = 1; /* Indicates nonblocking mode. */ const char *errorMsg = NULL; - int optvalue, port; if (TclpHasSockets(interp) != TCL_OK) { return NULL; } @@ -2227,17 +2066,11 @@ /* * Construct the addresses for each end of the socket. */ - if (TclSockGetPort(interp, service, "tcp", &port) != TCL_OK) { - errorMsg = "invalid port number"; - goto error; - } - - if (!TclCreateSocketAddress(interp, &addrlist, myHost, port, 1, - &errorMsg)) { + if (!TclCreateSocketAddress(interp, &addrlist, myHost, port, 1, &errorMsg)) { goto error; } for (addrPtr = addrlist; addrPtr != NULL; addrPtr = addrPtr->ai_next) { sock = socket(addrPtr->ai_family, addrPtr->ai_socktype, @@ -2272,30 +2105,21 @@ ((struct sockaddr_in *) addrPtr->ai_addr)->sin_port = htons(chosenport); } /* - * The SO_REUSEADDR option on Windows behaves like SO_REUSEPORT on - * unix systems. - */ - - if (GOT_BITS(flags, TCL_TCPSERVER_REUSEPORT)) { - optvalue = 1; - (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, - (char *) &optvalue, sizeof(optvalue)); - } - - /* - * Bind to the specified port. + * Bind to the specified port. Note that we must not call + * setsockopt with SO_REUSEADDR because Microsoft allows addresses + * to be reused even if they are still in use. * * Bind should not be affected by the socket having already been * set into nonblocking mode. If there is trouble, this is one * place to look for bugs. */ - if (bind(sock, addrPtr->ai_addr, - addrPtr->ai_addrlen) == SOCKET_ERROR) { + if (bind(sock, addrPtr->ai_addr, addrPtr->ai_addrlen) + == SOCKET_ERROR) { TclWinConvertError((DWORD) WSAGetLastError()); closesocket(sock); continue; } if (port == 0 && chosenport == 0) { @@ -2326,18 +2150,17 @@ if (statePtr == NULL) { /* * Add this socket to the global list of sockets. */ - statePtr = NewSocketInfo(sock); } else { - AddSocketInfoFd(statePtr, sock); + AddSocketInfoFd( statePtr, sock ); } } - error: +error: if (addrlist != NULL) { freeaddrinfo(addrlist); } if (statePtr != NULL) { @@ -2358,11 +2181,12 @@ * Register for interest in events in the select mask. Note that this * automatically places the socket into non-blocking mode. */ ioctlsocket(sock, (long) FIONBIO, &flag); - SendSelectMessage(tsdPtr, SELECT, statePtr); + SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, + (LPARAM) statePtr); if (Tcl_SetChannelOption(interp, statePtr->channel, "-eofchar", "") == TCL_ERROR) { Tcl_Close(NULL, statePtr->channel); return NULL; } @@ -2395,11 +2219,10 @@ * connection acceptance mechanism. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ static void TcpAccept( TcpFdList *fds, /* Server socket that accepted newSocket. */ SOCKET newSocket, /* Newly accepted socket. */ address addr) /* Address of new socket. */ @@ -2427,11 +2250,12 @@ /* * Select on read/write events and create the channel. */ newInfoPtr->selectEvents = (FD_READ | FD_WRITE | FD_CLOSE); - SendSelectMessage(tsdPtr, SELECT, newInfoPtr); + SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, + (LPARAM) newInfoPtr); sprintf(channelName, SOCK_TEMPLATE, newInfoPtr); newInfoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, newInfoPtr, (TCL_READABLE | TCL_WRITABLE)); if (Tcl_SetChannelOption(NULL, newInfoPtr->channel, "-translation", @@ -2497,16 +2321,16 @@ windowClass.cbClsExtra = 0; windowClass.cbWndExtra = 0; windowClass.hInstance = TclWinGetTclInstance(); windowClass.hbrBackground = NULL; windowClass.lpszMenuName = NULL; - windowClass.lpszClassName = className; + windowClass.lpszClassName = classname; windowClass.lpfnWndProc = SocketProc; windowClass.hIcon = NULL; windowClass.hCursor = NULL; - if (!RegisterClass(&windowClass)) { + if (!RegisterClassW(&windowClass)) { TclWinConvertError(GetLastError()); goto initFailure; } } @@ -2527,15 +2351,15 @@ tsdPtr = TCL_TSD_INIT(&dataKey); tsdPtr->pendingTcpState = NULL; tsdPtr->socketList = NULL; tsdPtr->hwnd = NULL; tsdPtr->threadId = Tcl_GetCurrentThread(); - tsdPtr->readyEvent = CreateEvent(NULL, FALSE, FALSE, NULL); + tsdPtr->readyEvent = CreateEventW(NULL, FALSE, FALSE, NULL); if (tsdPtr->readyEvent == NULL) { goto initFailure; } - tsdPtr->socketListLock = CreateEvent(NULL, FALSE, TRUE, NULL); + tsdPtr->socketListLock = CreateEventW(NULL, FALSE, TRUE, NULL); if (tsdPtr->socketListLock == NULL) { goto initFailure; } tsdPtr->socketThread = CreateThread(NULL, 256, SocketThread, tsdPtr, 0, &id); @@ -2584,11 +2408,10 @@ * None. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int SocketsEnabled(void) { int enabled; @@ -2614,11 +2437,10 @@ * None. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ static void SocketExitHandler( ClientData clientData) /* Not used. */ { Tcl_MutexLock(&socketMutex); @@ -2627,11 +2449,11 @@ * Make sure the socket event handling window is cleaned-up for, at * most, this thread. */ TclpFinalizeSockets(); - UnregisterClass(className, TclWinGetTclInstance()); + UnregisterClassW(classname, TclWinGetTclInstance()); initialized = 0; Tcl_MutexUnlock(&socketMutex); } /* @@ -2658,22 +2480,23 @@ { TcpState *statePtr; Tcl_Time blockTime = { 0, 0 }; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - if (!GOT_BITS(flags, TCL_FILE_EVENTS)) { + if (!(flags & TCL_FILE_EVENTS)) { return; } /* * Check to see if there is a ready socket. If so, poll. */ WaitForSingleObject(tsdPtr->socketListLock, INFINITE); for (statePtr = tsdPtr->socketList; statePtr != NULL; statePtr = statePtr->nextPtr) { - if (GOT_BITS(statePtr->readyEvents, - statePtr->watchEvents | FD_CONNECT | FD_ACCEPT)) { + if (statePtr->readyEvents & + (statePtr->watchEvents | FD_CONNECT | FD_ACCEPT) + ) { Tcl_SetMaxBlockTime(&blockTime); break; } } SetEvent(tsdPtr->socketListLock); @@ -2703,11 +2526,11 @@ { TcpState *statePtr; SocketEvent *evPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - if (!GOT_BITS(flags, TCL_FILE_EVENTS)) { + if (!(flags & TCL_FILE_EVENTS)) { return; } /* * Queue events for any ready sockets that don't already have events @@ -2716,15 +2539,16 @@ */ WaitForSingleObject(tsdPtr->socketListLock, INFINITE); for (statePtr = tsdPtr->socketList; statePtr != NULL; statePtr = statePtr->nextPtr) { - if (GOT_BITS(statePtr->readyEvents, - statePtr->watchEvents | FD_CONNECT | FD_ACCEPT) - && !GOT_BITS(statePtr->flags, SOCKET_PENDING)) { - SET_BITS(statePtr->flags, SOCKET_PENDING); - evPtr = Tcl_Alloc(sizeof(SocketEvent)); + if ((statePtr->readyEvents & + (statePtr->watchEvents | FD_CONNECT | FD_ACCEPT)) + && !(statePtr->flags & SOCKET_PENDING) + ) { + statePtr->flags |= SOCKET_PENDING; + evPtr = ckalloc(sizeof(SocketEvent)); evPtr->header.proc = SocketEventProc; evPtr->socket = statePtr->sockets->fd; Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); } } @@ -2765,11 +2589,11 @@ TcpFdList *fds; SOCKET newSocket; address addr; int len; - if (!GOT_BITS(flags, TCL_FILE_EVENTS)) { + if (!(flags & TCL_FILE_EVENTS)) { return 0; } /* * Find the specified socket on the socket list. @@ -2794,55 +2618,55 @@ /* * Clear flag that (this) event is pending */ - CLEAR_BITS(statePtr->flags, SOCKET_PENDING); + statePtr->flags &= ~SOCKET_PENDING; /* * Continue async connect if pending and ready */ - if (GOT_BITS(statePtr->readyEvents, FD_CONNECT)) { - if (GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) { + if ( statePtr->readyEvents & FD_CONNECT ) { + if ( statePtr->flags & TCP_ASYNC_PENDING ) { + /* * Do one step and save eventual connect error */ SetEvent(tsdPtr->socketListLock); WaitForConnect(statePtr,NULL); + } else { + /* * No async connect reenter pending. Just clear event. */ - CLEAR_BITS(statePtr->readyEvents, FD_CONNECT); + statePtr->readyEvents &= ~(FD_CONNECT); SetEvent(tsdPtr->socketListLock); } return 1; } /* * Handle connection requests directly. */ - - if (GOT_BITS(statePtr->readyEvents, FD_ACCEPT)) { + if (statePtr->readyEvents & FD_ACCEPT) { for (fds = statePtr->sockets; fds != NULL; fds = fds->next) { + /* - * Accept the incoming connection request. - */ - + * Accept the incoming connection request. + */ len = sizeof(address); + newSocket = accept(fds->fd, &(addr.sa), &len); - /* - * On Tcl server sockets with multiple OS fds we loop over the fds - * trying an accept() on each, so we expect INVALID_SOCKET. There - * are also other network stack conditions that can result in - * FD_ACCEPT but a subsequent failure on accept() by the time we - * get around to it. - * + /* On Tcl server sockets with multiple OS fds we loop over the fds trying + * an accept() on each, so we expect INVALID_SOCKET. There are also other + * network stack conditions that can result in FD_ACCEPT but a subsequent + * failure on accept() by the time we get around to it. * Access to sockets (acceptEventCount, readyEvents) in socketList * is still protected by the lock (prevents reintroduction of * SF Tcl Bug 3056775. */ @@ -2850,44 +2674,39 @@ /* int err = WSAGetLastError(); */ continue; } /* - * It is possible that more than one FD_ACCEPT has been sent, so - * an extra count must be kept. Decrement the count, and reset the - * readyEvent bit if the count is no longer > 0. + * It is possible that more than one FD_ACCEPT has been sent, so an extra + * count must be kept. Decrement the count, and reset the readyEvent bit + * if the count is no longer > 0. */ - statePtr->acceptEventCount--; if (statePtr->acceptEventCount <= 0) { - CLEAR_BITS(statePtr->readyEvents, FD_ACCEPT); + statePtr->readyEvents &= ~(FD_ACCEPT); } SetEvent(tsdPtr->socketListLock); - /* - * Caution: TcpAccept() has the side-effect of evaluating the - * server accept script (via AcceptCallbackProc() in tclIOCmd.c), - * which can close the server socket and invalidate statePtr and - * fds. If TcpAccept() accepts a socket we must return immediately - * and let SocketCheckProc queue additional FD_ACCEPT events. + /* Caution: TcpAccept() has the side-effect of evaluating the server + * accept script (via AcceptCallbackProc() in tclIOCmd.c), which can + * close the server socket and invalidate statePtr and fds. + * If TcpAccept() accepts a socket we must return immediately and let + * SocketCheckProc queue additional FD_ACCEPT events. */ - TcpAccept(fds, newSocket, addr); return 1; } - /* - * Loop terminated with no sockets accepted; clear the ready mask so + /* Loop terminated with no sockets accepted; clear the ready mask so * we can detect the next connection request. Note that connection * requests are level triggered, so if there is a request already * pending, a new event will be generated. */ - statePtr->acceptEventCount = 0; - CLEAR_BITS(statePtr->readyEvents, FD_ACCEPT); + statePtr->readyEvents &= ~(FD_ACCEPT); SetEvent(tsdPtr->socketListLock); return 1; } @@ -2898,11 +2717,11 @@ * notify the channel. */ events = statePtr->readyEvents & statePtr->watchEvents; - if (GOT_BITS(events, FD_CLOSE)) { + if (events & FD_CLOSE) { /* * If the socket was closed and the channel is still interested in * read events, then we need to ensure that we keep polling for this * event until someone does something with the channel. Note that we * do this before calling Tcl_NotifyChannel so we don't have to watch @@ -2912,18 +2731,21 @@ */ Tcl_Time blockTime = { 0, 0 }; Tcl_SetMaxBlockTime(&blockTime); - SET_BITS(mask, TCL_READABLE | TCL_WRITABLE); - } else if (GOT_BITS(events, FD_READ)) { + mask |= TCL_READABLE|TCL_WRITABLE; + } else if (events & FD_READ) { + /* * Throw the readable event if an async connect failed. */ - if (GOT_BITS(statePtr->flags, TCP_ASYNC_FAILED)) { - SET_BITS(mask, TCL_READABLE); + if ( statePtr->flags & TCP_ASYNC_FAILED ) { + + mask |= TCL_READABLE; + } else { fd_set readFds; struct timeval timeout; /* @@ -2932,32 +2754,34 @@ * notification so select will work correctly. If the socket is * still readable, notify the channel driver, otherwise reset the * async select handler and keep waiting. */ - SendSelectMessage(tsdPtr, UNSELECT, statePtr); + SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, + (WPARAM) UNSELECT, (LPARAM) statePtr); FD_ZERO(&readFds); FD_SET(statePtr->sockets->fd, &readFds); timeout.tv_usec = 0; timeout.tv_sec = 0; if (select(0, &readFds, NULL, NULL, &timeout) != 0) { - SET_BITS(mask, TCL_READABLE); + mask |= TCL_READABLE; } else { - CLEAR_BITS(statePtr->readyEvents, FD_READ); - SendSelectMessage(tsdPtr, SELECT, statePtr); + statePtr->readyEvents &= ~(FD_READ); + SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, + (WPARAM) SELECT, (LPARAM) statePtr); } } } /* * writable event */ - if (GOT_BITS(events, FD_WRITE)) { - SET_BITS(mask, TCL_WRITABLE); + if (events & FD_WRITE) { + mask |= TCL_WRITABLE; } /* * Call registered event procedures */ @@ -2990,34 +2814,25 @@ TcpState *statePtr, SOCKET socket) { TcpFdList *fds = statePtr->sockets; - if (fds == NULL) { - /* - * Add the first FD. - */ - - statePtr->sockets = Tcl_Alloc(sizeof(TcpFdList)); - fds = statePtr->sockets; - } else { - /* - * Find end of list and append FD. - */ - - while (fds->next != NULL) { - fds = fds->next; - } - - fds->next = Tcl_Alloc(sizeof(TcpFdList)); - fds = fds->next; - } - - /* - * Populate new FD. - */ - + if ( fds == NULL ) { + /* Add the first FD */ + statePtr->sockets = ckalloc(sizeof(TcpFdList)); + fds = statePtr->sockets; + } else { + /* Find end of list and append FD */ + while ( fds->next != NULL ) { + fds = fds->next; + } + + fds->next = ckalloc(sizeof(TcpFdList)); + fds = fds->next; + } + + /* Populate new FD */ fds->fd = socket; fds->statePtr = statePtr; fds->next = NULL; } @@ -3039,11 +2854,11 @@ */ static TcpState * NewSocketInfo(SOCKET socket) { - TcpState *statePtr = Tcl_Alloc(sizeof(TcpState)); + TcpState *statePtr = ckalloc(sizeof(TcpState)); memset(statePtr, 0, sizeof(TcpState)); /* * TIP #218. Removed the code inserting the new structure into the global @@ -3083,11 +2898,10 @@ int *errorCodePtr) /* Where to store errors? */ { int result = 1; int oldMode; ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); - /* * Be sure to disable event servicing so we are truly modal. */ oldMode = Tcl_SetServiceMode(TCL_SERVICE_NONE); @@ -3094,46 +2908,33 @@ /* * Reset WSAAsyncSelect so we have a fresh set of events pending. */ - SendSelectMessage(tsdPtr, UNSELECT, statePtr); - SendSelectMessage(tsdPtr, SELECT, statePtr); + SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) UNSELECT, + (LPARAM) statePtr); + SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, + (LPARAM) statePtr); while (1) { int event_found; - /* - * Get statePtr lock. - */ - + /* get statePtr lock */ WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - /* - * Check if event occured. - */ - - event_found = GOT_BITS(statePtr->readyEvents, events); - - /* - * Free list lock. - */ - + /* Check if event occured */ + event_found = (statePtr->readyEvents & events); + + /* Free list lock */ SetEvent(tsdPtr->socketListLock); - /* - * Exit loop if event occured. - */ - + /* exit loop if event occured */ if (event_found) { break; } - /* - * Exit loop if event did not occur but this is a non-blocking channel - */ - + /* Exit loop if event did not occur but this is a non-blocking channel */ if (statePtr->flags & TCP_NONBLOCKING) { *errorCodePtr = EWOULDBLOCK; result = 0; break; } @@ -3174,11 +2975,11 @@ /* * Create a dummy window receiving socket events. */ - tsdPtr->hwnd = CreateWindow(className, className, WS_TILED, 0, 0, 0, 0, + tsdPtr->hwnd = CreateWindowW(classname, classname, WS_TILED, 0, 0, 0, 0, NULL, NULL, windowClass.hInstance, arg); /* * Signalize thread creator that we are done creating the window. */ @@ -3194,15 +2995,15 @@ } /* * Process all messages on the socket window until WM_QUIT. This threads * exits only when instructed to do so by the call to - * PostMessage(SOCKET_TERMINATE) in TclpFinalizeSockets(). + * PostMessageW(SOCKET_TERMINATE) in TclpFinalizeSockets(). */ - while (GetMessage(&msg, NULL, 0, 0) > 0) { - DispatchMessage(&msg); + while (GetMessageW(&msg, NULL, 0, 0) > 0) { + DispatchMessageW(&msg); } /* * This releases waiters on thread exit in TclpFinalizeSockets() */ @@ -3243,31 +3044,31 @@ TcpState *statePtr; int info_found = 0; TcpFdList *fds = NULL; ThreadSpecificData *tsdPtr = (ThreadSpecificData *) #ifdef _WIN64 - GetWindowLongPtr(hwnd, GWLP_USERDATA); + GetWindowLongPtrW(hwnd, GWLP_USERDATA); #else - GetWindowLong(hwnd, GWL_USERDATA); + GetWindowLongW(hwnd, GWL_USERDATA); #endif switch (message) { default: - return DefWindowProc(hwnd, message, wParam, lParam); + return DefWindowProcW(hwnd, message, wParam, lParam); break; case WM_CREATE: /* * Store the initial tsdPtr, it's from a different thread, so it's not * directly accessible, but needed. */ #ifdef _WIN64 - SetWindowLongPtr(hwnd, GWLP_USERDATA, + SetWindowLongPtrW(hwnd, GWLP_USERDATA, (LONG_PTR) ((LPCREATESTRUCT)lParam)->lpCreateParams); #else - SetWindowLong(hwnd, GWL_USERDATA, + SetWindowLongW(hwnd, GWL_USERDATA, (LONG) ((LPCREATESTRUCT)lParam)->lpCreateParams); #endif break; case WM_DESTROY: @@ -3286,63 +3087,59 @@ * eventState flag. */ for (statePtr = tsdPtr->socketList; statePtr != NULL; statePtr = statePtr->nextPtr) { - if (FindFDInList(statePtr, socket)) { + if ( FindFDInList(statePtr,socket) ) { info_found = 1; break; } } - /* - * Check if there is a pending info structure not jet in the list. + * Check if there is a pending info structure not jet in the + * list */ - - if (!info_found + if ( !info_found && tsdPtr->pendingTcpState != NULL - && FindFDInList(tsdPtr->pendingTcpState, socket)) { + && FindFDInList(tsdPtr->pendingTcpState,socket) ) { statePtr = tsdPtr->pendingTcpState; info_found = 1; } if (info_found) { + /* * Update the socket state. * * A count of FD_ACCEPTS is stored, so if an FD_CLOSE event - * happens, then clear the FD_ACCEPT count. Otherwise, increment - * the count if the current event is an FD_ACCEPT. + * happens, then clear the FD_ACCEPT count. Otherwise, + * increment the count if the current event is an FD_ACCEPT. */ - if (GOT_BITS(event, FD_CLOSE)) { + if (event & FD_CLOSE) { statePtr->acceptEventCount = 0; - CLEAR_BITS(statePtr->readyEvents, FD_WRITE | FD_ACCEPT); - } else if (GOT_BITS(event, FD_ACCEPT)) { + statePtr->readyEvents &= ~(FD_WRITE|FD_ACCEPT); + } else if (event & FD_ACCEPT) { statePtr->acceptEventCount++; } - if (GOT_BITS(event, FD_CONNECT)) { + if (event & FD_CONNECT) { /* * Remember any error that occurred so we can report * connection failures. */ - if (error != ERROR_SUCCESS) { statePtr->notifierConnectError = error; } } - /* * Inform main thread about signaled events */ - - SET_BITS(statePtr->readyEvents, event); + statePtr->readyEvents |= event; /* * Wake up the Main Thread. */ - SetEvent(tsdPtr->readyEvent); Tcl_ThreadAlert(tsdPtr->threadId); } SetEvent(tsdPtr->socketListLock); break; @@ -3398,10 +3195,70 @@ return 1; } } return 0; } + +/* + *---------------------------------------------------------------------- + * + * TclWinGetSockOpt, et al. -- + * + * Those functions are historically exported by the stubs table and + * just use the original system calls now. + * + * Warning: + * Those functions are depreciated and will be removed with TCL 9.0. + * + * Results: + * As defined for each function. + * + * Side effects: + * As defined for each function. + * + *---------------------------------------------------------------------- + */ + +#undef TclWinGetSockOpt +int +TclWinGetSockOpt( + SOCKET s, + int level, + int optname, + char *optval, + int *optlen) +{ + + return getsockopt(s, level, optname, optval, optlen); +} +#undef TclWinSetSockOpt +int +TclWinSetSockOpt( + SOCKET s, + int level, + int optname, + const char *optval, + int optlen) +{ + return setsockopt(s, level, optname, optval, optlen); +} + +#undef TclpInetNtoa +char * +TclpInetNtoa( + struct in_addr addr) +{ + return inet_ntoa(addr); +} +#undef TclWinGetServByName +struct servent * +TclWinGetServByName( + const char *name, + const char *proto) +{ + return getservbyname(name, proto); +} /* *---------------------------------------------------------------------- * * TcpThreadActionProc -- @@ -3487,11 +3344,12 @@ /* * Ensure that, or stop, notifications for the socket occur in this * thread. */ - SendSelectMessage(tsdPtr, notifyCmd, statePtr); + SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, + (WPARAM) notifyCmd, (LPARAM) statePtr); } /* * Local Variables: * mode: c Index: win/tclWinTest.c ================================================================== --- win/tclWinTest.c +++ win/tclWinTest.c @@ -39,10 +39,12 @@ Tcl_Obj *const objv[]); static int TestwinclockCmd(ClientData dummy, Tcl_Interp* interp, int objc, Tcl_Obj *const objv[]); static int TestwinsleepCmd(ClientData dummy, Tcl_Interp* interp, int objc, Tcl_Obj *const objv[]); +static int TestSizeCmd(ClientData dummy, Tcl_Interp* interp, + int objc, Tcl_Obj *const objv[]); static Tcl_ObjCmdProc TestExceptionCmd; static int TestplatformChmod(const char *nativePath, int pmode); static int TestchmodCmd(ClientData dummy, Tcl_Interp* interp, int objc, Tcl_Obj *const objv[]); @@ -76,10 +78,11 @@ Tcl_CreateObjCommand(interp, "testvolumetype", TestvolumetypeCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testwinclock", TestwinclockCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testwinsleep", TestwinsleepCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testexcept", TestExceptionCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testsize", TestSizeCmd, NULL, NULL); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -134,21 +137,21 @@ done = 0; while (!done) { MSG msg; - if (!GetMessage(&msg, NULL, 0, 0)) { + if (!GetMessageW(&msg, NULL, 0, 0)) { /* * The application is exiting, so repost the quit message and * start unwinding. */ PostQuitMessage((int) msg.wParam); break; } TranslateMessage(&msg); - DispatchMessage(&msg); + DispatchMessageW(&msg); } (void) Tcl_SetServiceMode(oldMode); framePtr = oldFramePtr; } else { Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]), @@ -274,15 +277,15 @@ QueryPerformanceCounter(&p2); result = Tcl_NewObj(); Tcl_ListObjAppendElement(interp, result, - Tcl_NewWideIntObj(t2.QuadPart / 10000000)); + Tcl_NewIntObj((int) (t2.QuadPart / 10000000))); Tcl_ListObjAppendElement(interp, result, - Tcl_NewWideIntObj((t2.QuadPart / 10) % 1000000)); - Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(tclTime.sec)); - Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(tclTime.usec)); + Tcl_NewIntObj((int) ((t2.QuadPart / 10) % 1000000))); + Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(tclTime.sec)); + Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(tclTime.usec)); Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(p1.QuadPart)); Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(p2.QuadPart)); Tcl_SetObjResult(interp, result); @@ -307,10 +310,35 @@ return TCL_ERROR; } Sleep((DWORD) ms); return TCL_OK; } + +static int +TestSizeCmd( + ClientData clientData, /* Unused */ + Tcl_Interp* interp, /* Tcl interpreter */ + int objc, /* Parameter count */ + Tcl_Obj *const * objv) /* Parameter vector */ +{ + if (objc != 2) { + goto syntax; + } + if (strcmp(Tcl_GetString(objv[1]), "time_t") == 0) { + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(sizeof(time_t))); + return TCL_OK; + } + if (strcmp(Tcl_GetString(objv[1]), "st_mtime") == 0) { + Tcl_StatBuf *statPtr; + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(sizeof(statPtr->st_mtime))); + return TCL_OK; + } + +syntax: + Tcl_WrongNumArgs(interp, 1, objv, "time_t|st_mtime"); + return TCL_ERROR; +} /* *---------------------------------------------------------------------- * * TestExceptionCmd -- @@ -431,11 +459,11 @@ /* * nativePath not found */ - if (attr == 0xffffffff) { + if (attr == 0xFFFFFFFF) { res = -1; goto done; } /* @@ -463,11 +491,11 @@ if (GetLastError() != ERROR_INSUFFICIENT_BUFFER) { goto done; } - secDesc = Tcl_Alloc(secDescLen); + secDesc = ckalloc(secDescLen); if (!GetFileSecurityA(nativePath, infoBits, (PSECURITY_DESCRIPTOR) secDesc, secDescLen, &secDescLen2) || (secDescLen < secDescLen2)) { goto done; } @@ -475,11 +503,11 @@ /* * Get the World SID. */ - userSid = Tcl_Alloc(GetSidLengthRequired((UCHAR) 1)); + userSid = ckalloc(GetSidLengthRequired((UCHAR) 1)); InitializeSid(userSid, &userSidAuthority, (BYTE) 1); *(GetSidSubAuthority(userSid, 0)) = SECURITY_WORLD_RID; /* * If curAclPresent == false then curAcl and curAclDefaulted not valid. @@ -501,11 +529,11 @@ * Allocate memory for the new ACL. */ newAclSize = ACLSize.AclBytesInUse + sizeof(ACCESS_DENIED_ACE) + GetLengthSid(userSid) - sizeof(DWORD); - newAcl = Tcl_Alloc(newAclSize); + newAcl = ckalloc(newAclSize); /* * Initialize the new ACL. */ @@ -578,20 +606,20 @@ res = 0; } done: if (secDesc) { - Tcl_Free(secDesc); + ckfree(secDesc); } if (newAcl) { - Tcl_Free(newAcl); + ckfree(newAcl); } if (userSid) { - Tcl_Free(userSid); + ckfree(userSid); } if (userDomain) { - Tcl_Free(userDomain); + ckfree(userDomain); } if (res != 0) { return res; } Index: win/tclWinThrd.c ================================================================== --- win/tclWinThrd.c +++ win/tclWinThrd.c @@ -10,10 +10,12 @@ * 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 /* Workaround for mingw versions which don't provide this in float.h */ #ifndef _MCW_EM # define _MCW_EM 0x0008001F /* Error masks */ # define _MCW_RC 0x00000300 /* Rounding */ @@ -20,30 +22,33 @@ # define _MCW_PC 0x00030000 /* Precision */ _CRTIMP unsigned int __cdecl _controlfp (unsigned int unNew, unsigned int unMask); #endif /* - * This is the master lock used to serialize access to other serialization + * This is the global lock used to serialize access to other serialization * data structures. */ -static CRITICAL_SECTION masterLock; -static int initialized = 0; +static CRITICAL_SECTION globalLock; +static int init = 0; +#define GLOBAL_LOCK TclpGlobalLock() +#define GLOBAL_UNLOCK TclpGlobalUnlock() + /* - * This is the master lock used to serialize initialization and finalization + * This is the global lock used to serialize initialization and finalization * of Tcl as a whole. */ static CRITICAL_SECTION initLock; /* * allocLock is used by Tcl's version of malloc for synchronization. For - * obvious reasons, cannot use any dyamically allocated storage. + * obvious reasons, cannot use any dynamically allocated storage. */ -#if TCL_THREADS +#ifdef TCL_THREADS static struct Tcl_Mutex_ { CRITICAL_SECTION crit; } allocLock; static Tcl_Mutex allocLockPtr = &allocLock; @@ -74,11 +79,11 @@ /* * The per-thread event and queue pointers. */ -#if TCL_THREADS +#ifdef TCL_THREADS typedef struct ThreadSpecificData { HANDLE condEvent; /* Per-thread condition event */ struct ThreadSpecificData *nextPtr; /* Queue pointers */ struct ThreadSpecificData *prevPtr; @@ -103,11 +108,11 @@ /* * The per condition queue pointers and the Mutex used to serialize access to * the queue. */ -typedef struct { +typedef struct WinCondition { CRITICAL_SECTION condLock; /* Lock to serialize queuing on the * condition. */ struct ThreadSpecificData *firstPtr; /* Queue pointers */ struct ThreadSpecificData *lastPtr; } WinCondition; @@ -115,13 +120,14 @@ /* * Additions by AOL for specialized thread memory allocator. */ #ifdef USE_THREAD_ALLOC +static int once; static DWORD tlsKey; -typedef struct { +typedef struct allocMutex { Tcl_Mutex tlock; CRITICAL_SECTION wlock; } allocMutex; #endif /* USE_THREAD_ALLOC */ @@ -128,11 +134,11 @@ /* * The per thread data passed from TclpThreadCreate * to TclWinThreadStart. */ -typedef struct { +typedef struct WinThread { LPTHREAD_START_ROUTINE lpStartAddress; /* Original startup routine */ LPVOID lpParameter; /* Original startup data */ unsigned int fpControl; /* Floating point control word from the * main thread */ } WinThread; @@ -176,11 +182,11 @@ ); lpOrigStartAddress = winThreadPtr->lpStartAddress; lpOrigParameter = winThreadPtr->lpParameter; - Tcl_Free(winThreadPtr); + ckfree((char *)winThreadPtr); return lpOrigStartAddress(lpOrigParameter); } /* *---------------------------------------------------------------------- @@ -202,18 +208,18 @@ int TclpThreadCreate( Tcl_ThreadId *idPtr, /* Return, the ID of the thread. */ Tcl_ThreadCreateProc *proc, /* Main() function of the thread. */ ClientData clientData, /* The one argument to Main(). */ - size_t stackSize, /* Size of stack for the new thread. */ + int stackSize, /* Size of stack for the new thread. */ int flags) /* Flags controlling behaviour of the new * thread. */ { WinThread *winThreadPtr; /* Per-thread startup info */ HANDLE tHandle; - winThreadPtr = (WinThread *)Tcl_Alloc(sizeof(WinThread)); + winThreadPtr = (WinThread *)ckalloc(sizeof(WinThread)); winThreadPtr->lpStartAddress = (LPTHREAD_START_ROUTINE) proc; winThreadPtr->lpParameter = clientData; winThreadPtr->fpControl = _controlfp(0, 0); EnterCriticalSection(&joinLock); @@ -349,22 +355,22 @@ */ void TclpInitLock(void) { - if (!initialized) { + if (!init) { /* * There is a fundamental race here that is solved by creating the * first Tcl interpreter in a single threaded environment. Once the * interpreter has been created, it is safe to create more threads * that create interpreters in parallel. */ - initialized = 1; + init = 1; InitializeCriticalSection(&joinLock); InitializeCriticalSection(&initLock); - InitializeCriticalSection(&masterLock); + InitializeCriticalSection(&globalLock); } EnterCriticalSection(&initLock); } /* @@ -391,11 +397,11 @@ } /* *---------------------------------------------------------------------- * - * TclpMasterLock + * TclpGlobalLock * * This procedure is used to grab a lock that serializes creation of * mutexes, condition variables, and thread local storage keys. * * This lock must be different than the initLock because the initLock is @@ -403,64 +409,64 @@ * * Results: * None. * * Side effects: - * Acquire the master mutex. + * Acquire the global mutex. * *---------------------------------------------------------------------- */ void -TclpMasterLock(void) +TclpGlobalLock(void) { - if (!initialized) { + if (!init) { /* * There is a fundamental race here that is solved by creating the * first Tcl interpreter in a single threaded environment. Once the * interpreter has been created, it is safe to create more threads * that create interpreters in parallel. */ - initialized = 1; + init = 1; InitializeCriticalSection(&joinLock); InitializeCriticalSection(&initLock); - InitializeCriticalSection(&masterLock); + InitializeCriticalSection(&globalLock); } - EnterCriticalSection(&masterLock); + EnterCriticalSection(&globalLock); } /* *---------------------------------------------------------------------- * - * TclpMasterUnlock + * TclpGlobalUnlock * * This procedure is used to release a lock that serializes creation and * deletion of synchronization objects. * * Results: * None. * * Side effects: - * Release the master mutex. + * Release the global mutex. * *---------------------------------------------------------------------- */ void -TclpMasterUnlock(void) +TclpGlobalUnlock(void) { - LeaveCriticalSection(&masterLock); + LeaveCriticalSection(&globalLock); } /* *---------------------------------------------------------------------- * * Tcl_GetAllocMutex * * This procedure returns a pointer to a statically initialized mutex for - * use by the memory allocator. The alloctor must use this lock, because + * use by the memory allocator. The allocator must use this lock, because * all other locks are allocated... * * Results: * A pointer to a mutex that is suitable for passing to Tcl_MutexLock and * Tcl_MutexUnlock. @@ -472,11 +478,11 @@ */ Tcl_Mutex * Tcl_GetAllocMutex(void) { -#if TCL_THREADS +#ifdef TCL_THREADS if (!allocOnce) { InitializeCriticalSection(&allocLock.crit); allocOnce = 1; } return &allocLockPtr; @@ -486,11 +492,11 @@ } /* *---------------------------------------------------------------------- * - * TclFinalizeLock + * TclpFinalizeLock * * This procedure is used to destroy all private resources used in this * file. * * Results: @@ -504,21 +510,21 @@ */ void TclFinalizeLock(void) { - TclpMasterLock(); + GLOBAL_LOCK; DeleteCriticalSection(&joinLock); /* * Destroy the critical section that we are holding! */ - DeleteCriticalSection(&masterLock); - initialized = 0; + DeleteCriticalSection(&globalLock); + init = 0; -#if TCL_THREADS +#ifdef TCL_THREADS if (allocOnce) { DeleteCriticalSection(&allocLock.crit); allocOnce = 0; } #endif @@ -530,11 +536,11 @@ */ DeleteCriticalSection(&initLock); } -#if TCL_THREADS +#ifdef TCL_THREADS /* locally used prototype */ static void FinalizeConditionEvent(ClientData data); /* @@ -559,23 +565,23 @@ Tcl_Mutex *mutexPtr) /* The lock */ { CRITICAL_SECTION *csPtr; if (*mutexPtr == NULL) { - TclpMasterLock(); + GLOBAL_LOCK; /* - * Double inside master lock check to avoid a race. + * Double inside global lock check to avoid a race. */ if (*mutexPtr == NULL) { - csPtr = Tcl_Alloc(sizeof(CRITICAL_SECTION)); + csPtr = ckalloc(sizeof(CRITICAL_SECTION)); InitializeCriticalSection(csPtr); *mutexPtr = (Tcl_Mutex)csPtr; TclRememberMutex(mutexPtr); } - TclpMasterUnlock(); + GLOBAL_UNLOCK; } csPtr = *((CRITICAL_SECTION **)mutexPtr); EnterCriticalSection(csPtr); } @@ -627,11 +633,11 @@ { CRITICAL_SECTION *csPtr = *(CRITICAL_SECTION **)mutexPtr; if (csPtr != NULL) { DeleteCriticalSection(csPtr); - Tcl_Free(csPtr); + ckfree(csPtr); *mutexPtr = NULL; } } /* @@ -673,54 +679,54 @@ * Self initialize the two parts of the condition. The per-condition and * per-thread parts need to be handled independently. */ if (tsdPtr->flags == WIN_THREAD_UNINIT) { - TclpMasterLock(); + GLOBAL_LOCK; /* * Create the per-thread event and queue pointers. */ if (tsdPtr->flags == WIN_THREAD_UNINIT) { - tsdPtr->condEvent = CreateEvent(NULL, TRUE /* manual reset */, + tsdPtr->condEvent = CreateEventW(NULL, TRUE /* manual reset */, FALSE /* non signaled */, NULL); tsdPtr->nextPtr = NULL; tsdPtr->prevPtr = NULL; tsdPtr->flags = WIN_THREAD_RUNNING; doExit = 1; } - TclpMasterUnlock(); + GLOBAL_UNLOCK; if (doExit) { /* * Create a per-thread exit handler to clean up the condEvent. We - * must be careful to do this outside the Master Lock because + * must be careful to do this outside the Global Lock because * Tcl_CreateThreadExitHandler uses its own ThreadSpecificData, - * and initializing that may drop back into the Master Lock. + * and initializing that may drop back into the Global Lock. */ Tcl_CreateThreadExitHandler(FinalizeConditionEvent, tsdPtr); } } if (*condPtr == NULL) { - TclpMasterLock(); + GLOBAL_LOCK; /* * Initialize the per-condition queue pointers and Mutex. */ if (*condPtr == NULL) { - winCondPtr = Tcl_Alloc(sizeof(WinCondition)); + winCondPtr = ckalloc(sizeof(WinCondition)); InitializeCriticalSection(&winCondPtr->condLock); winCondPtr->firstPtr = NULL; winCondPtr->lastPtr = NULL; *condPtr = (Tcl_Condition) winCondPtr; TclRememberCondition(condPtr); } - TclpMasterUnlock(); + GLOBAL_UNLOCK; } csPtr = *((CRITICAL_SECTION **)mutexPtr); winCondPtr = *((WinCondition **)condPtr); if (timePtr == NULL) { wtime = INFINITE; @@ -894,11 +900,11 @@ * TclpFinalizeCondition -- * * This procedure is invoked to clean up a condition variable. This is * only safe to call at the end of time. * - * This assumes the Master Lock is held. + * This assumes the Global Lock is held. * * Results: * None. * * Side effects: @@ -920,11 +926,11 @@ * reclaimed. */ if (winCondPtr != NULL) { DeleteCriticalSection(&winCondPtr->condLock); - Tcl_Free(winCondPtr); + ckfree(winCondPtr); *condPtr = NULL; } } @@ -936,13 +942,13 @@ #ifdef USE_THREAD_ALLOC Tcl_Mutex * TclpNewAllocMutex(void) { - allocMutex *lockPtr; + struct allocMutex *lockPtr; - lockPtr = malloc(sizeof(allocMutex)); + lockPtr = malloc(sizeof(struct allocMutex)); if (lockPtr == NULL) { Tcl_Panic("could not allocate lock"); } lockPtr->tlock = (Tcl_Mutex) &lockPtr->wlock; InitializeCriticalSection(&lockPtr->wlock); @@ -960,28 +966,28 @@ } DeleteCriticalSection(&lockPtr->wlock); free(lockPtr); } -void -TclpInitAllocCache(void) -{ - /* - * We need to make sure that TclpFreeAllocCache is called on each - * thread that calls this, but only on threads that call this. - */ - - tlsKey = TlsAlloc(); - if (tlsKey == TLS_OUT_OF_INDEXES) { - Tcl_Panic("could not allocate thread local storage"); - } -} - void * TclpGetAllocCache(void) { void *result; + + if (!once) { + /* + * We need to make sure that TclpFreeAllocCache is called on each + * thread that calls this, but only on threads that call this. + */ + + tlsKey = TlsAlloc(); + once = 1; + if (tlsKey == TLS_OUT_OF_INDEXES) { + Tcl_Panic("could not allocate thread local storage"); + } + } + result = TlsGetValue(tlsKey); if ((result == NULL) && (GetLastError() != NO_ERROR)) { Tcl_Panic("TlsGetValue failed from TclpGetAllocCache"); } return result; @@ -1015,31 +1021,33 @@ TclFreeAllocCache(ptr); success = TlsSetValue(tlsKey, NULL); if (!success) { Tcl_Panic("TlsSetValue failed from TclpFreeAllocCache"); } - } else { + } else if (once) { /* * Called by us in TclFinalizeThreadAlloc() during the library * finalization initiated from Tcl_Finalize() */ success = TlsFree(tlsKey); if (!success) { Tcl_Panic("TlsFree failed from TclpFreeAllocCache"); } + once = 0; /* reset for next time. */ } + } #endif /* USE_THREAD_ALLOC */ void * TclpThreadCreateKey(void) { DWORD *key; - key = TclpSysAlloc(sizeof *key); + key = TclpSysAlloc(sizeof *key, 0); if (key == NULL) { Tcl_Panic("unable to allocate thread key!"); } *key = TlsAlloc(); @@ -1063,23 +1071,23 @@ TclpSysFree(keyPtr); } void -TclpThreadSetMasterTSD( +TclpThreadSetGlobalTSD( void *tsdKeyPtr, void *ptr) { DWORD *key = tsdKeyPtr; if (!TlsSetValue(*key, ptr)) { - Tcl_Panic("unable to set master TSD value"); + Tcl_Panic("unable to set global TSD value"); } } void * -TclpThreadGetMasterTSD( +TclpThreadGetGlobalTSD( void *tsdKeyPtr) { DWORD *key = tsdKeyPtr; return TlsGetValue(*key); Index: win/tclWinTime.c ================================================================== --- win/tclWinTime.c +++ win/tclWinTime.c @@ -10,21 +10,44 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" +#define SECSPERDAY (60L * 60L * 24L) +#define SECSPERYEAR (SECSPERDAY * 365L) +#define SECSPER4YEAR (SECSPERYEAR * 4L + SECSPERDAY) + /* * Number of samples over which to estimate the performance counter. */ #define SAMPLES 64 +/* + * The following arrays contain the day of year for the last day of each + * month, where index 1 is January. + */ + +static const int normalDays[] = { + -1, 30, 58, 89, 119, 150, 180, 211, 242, 272, 303, 333, 364 +}; + +static const int leapDays[] = { + -1, 30, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365 +}; + +typedef struct ThreadSpecificData { + char tzName[64]; /* Time zone name */ + struct tm tm; /* time information */ +} ThreadSpecificData; +static Tcl_ThreadDataKey dataKey; + /* * Data for managing high-resolution timers. */ -typedef struct { +typedef struct TimeInfo { CRITICAL_SECTION cs; /* Mutex guarding this structure. */ int initialized; /* Flag == 1 if this structure is * initialized. */ int perfCounterAvailable; /* Flag == 1 if the hardware has a performance * counter. */ @@ -97,17 +120,18 @@ */ static struct { int initialized; /* 1 if initialized, 0 otherwise */ int perfCounter; /* 1 if performance counter usable for wide clicks */ double microsecsScale; /* Denominator scale between clock / microsecs */ -} wideClick = {0, 0.0}; +} wideClick = {0, 0, 0.0}; /* * Declarations for functions defined later in this file. */ +static struct tm * ComputeGMT(const time_t *tp); static void StopCalibration(ClientData clientData); static DWORD WINAPI CalibrationThread(LPVOID arg); static void UpdateTimeEachSecond(void); static void ResetCounterSamples(Tcl_WideUInt fileTime, Tcl_WideInt perfCounter, Tcl_WideInt perfFreq); @@ -142,11 +166,11 @@ * None. * *---------------------------------------------------------------------- */ -Tcl_WideUInt +unsigned long TclpGetSeconds(void) { Tcl_WideInt usecSincePosixEpoch; /* Try to use high resolution timer */ @@ -168,11 +192,11 @@ * TclpGetClicks -- * * This procedure returns a value that represents the highest resolution * clock available on the system. There are no guarantees on what the * resolution will be. In Tcl we will call this value a "click". The - * start time is also system dependant. + * start time is also system dependent. * * Results: * Number of clicks from some start time. * * Side effects: @@ -179,30 +203,30 @@ * None. * *---------------------------------------------------------------------- */ -Tcl_WideUInt +unsigned long TclpGetClicks(void) { Tcl_WideInt usecSincePosixEpoch; /* Try to use high resolution timer */ if ( tclGetTimeProcPtr == NativeGetTime && (usecSincePosixEpoch = NativeGetMicroseconds()) ) { - return (Tcl_WideUInt)usecSincePosixEpoch; + return (unsigned long)usecSincePosixEpoch; } else { /* * Use the Tcl_GetTime abstraction to get the time in microseconds, as * nearly as we can, and return it. */ Tcl_Time now; /* Current Tcl time */ tclGetTimeProcPtr(&now, tclTimeClientData); /* Tcl_GetTime inlined */ - return (Tcl_WideUInt)(now.sec * 1000000) + now.usec; + return (unsigned long)(now.sec * 1000000) + now.usec; } } /* *---------------------------------------------------------------------- @@ -489,23 +513,23 @@ * presuming that everyone's TSC is locked to the same * oscillator. */ SYSTEM_INFO systemInfo; - int regs[4]; + unsigned int regs[4]; GetSystemInfo(&systemInfo); if (TclWinCPUID(0, regs) == TCL_OK - && regs[1] == 0x756e6547 /* "Genu" */ - && regs[3] == 0x49656e69 /* "ineI" */ - && regs[2] == 0x6c65746e /* "ntel" */ + && regs[1] == 0x756E6547 /* "Genu" */ + && regs[3] == 0x49656E69 /* "ineI" */ + && regs[2] == 0x6C65746E /* "ntel" */ && TclWinCPUID(1, regs) == TCL_OK && ((regs[0]&0x00000F00) == 0x00000F00 /* Pentium 4 */ || ((regs[0] & 0x00F00000) /* Extended family */ && (regs[3] & 0x10000000))) /* Hyperthread */ && (((regs[1]&0x00FF0000) >> 16)/* CPU count */ - == (int)systemInfo.dwNumberOfProcessors)) { + == systemInfo.dwNumberOfProcessors)) { timeInfo.perfCounterAvailable = TRUE; } else { timeInfo.perfCounterAvailable = FALSE; } } @@ -518,12 +542,12 @@ if (timeInfo.perfCounterAvailable) { DWORD id; InitializeCriticalSection(&timeInfo.cs); - timeInfo.readyEvent = CreateEvent(NULL, FALSE, FALSE, NULL); - timeInfo.exitEvent = CreateEvent(NULL, FALSE, FALSE, NULL); + timeInfo.readyEvent = CreateEventW(NULL, FALSE, FALSE, NULL); + timeInfo.exitEvent = CreateEventW(NULL, FALSE, FALSE, NULL); timeInfo.calibrationThread = CreateThread(NULL, 256, CalibrationThread, (LPVOID) NULL, 0, &id); SetThreadPriority(timeInfo.calibrationThread, THREAD_PRIORITY_HIGHEST); @@ -677,10 +701,245 @@ WaitForSingleObject(timeInfo.calibrationThread, 100); CloseHandle(timeInfo.exitEvent); CloseHandle(timeInfo.calibrationThread); } + +/* + *---------------------------------------------------------------------- + * + * TclpGetDate -- + * + * This function converts between seconds and struct tm. If useGMT is + * true, then the returned date will be in Greenwich Mean Time (GMT). + * Otherwise, it will be in the local time zone. + * + * Results: + * Returns a static tm structure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +struct tm * +TclpGetDate( + const time_t *t, + int useGMT) +{ + struct tm *tmPtr; + time_t time; +#if defined(_WIN64) || (defined(_USE_64BIT_TIME_T) || (defined(_MSC_VER) && _MSC_VER < 1400)) +# define t2 *t /* no need to cripple time to 32-bit */ +#else + time_t t2 = *(__time32_t *)t; +#endif + + if (!useGMT) { +#if defined(_MSC_VER) && (_MSC_VER >= 1900) +# undef timezone /* prevent conflict with timezone() function */ + long timezone = 0; +#endif + + tzset(); + + /* + * If we are in the valid range, let the C run-time library handle it. + * Otherwise we need to fake it. Note that this algorithm ignores + * daylight savings time before the epoch. + */ + + /* + * Hm, Borland's localtime manages to return NULL under certain + * circumstances (e.g. wintime.test, test 1.2). Nobody tests for this, + * since 'localtime' isn't supposed to do this, possibly leading to + * crashes. + * + * Patch: We only call this function if we are at least one day into + * the epoch, else we handle it ourselves (like we do for times < 0). + * H. Giese, June 2003 + */ + +#ifdef __BORLANDC__ +#define LOCALTIME_VALIDITY_BOUNDARY SECSPERDAY +#else +#define LOCALTIME_VALIDITY_BOUNDARY 0 +#endif + + if (t2 >= LOCALTIME_VALIDITY_BOUNDARY) { + return TclpLocaltime(&t2); + } + +#if defined(_MSC_VER) && (_MSC_VER >= 1900) + _get_timezone(&timezone); +#endif + + time = t2 - timezone; + + /* + * If we aren't near to overflowing the long, just add the bias and + * use the normal calculation. Otherwise we will need to adjust the + * result at the end. + */ + + if (t2 < (LONG_MAX - 2*SECSPERDAY) && t2 > (LONG_MIN + 2*SECSPERDAY)) { + tmPtr = ComputeGMT(&time); + } else { + tmPtr = ComputeGMT(&t2); + + tzset(); + + /* + * Add the bias directly to the tm structure to avoid overflow. + * Propagate seconds overflow into minutes, hours and days. + */ + + time = tmPtr->tm_sec - timezone; + tmPtr->tm_sec = (int)(time % 60); + if (tmPtr->tm_sec < 0) { + tmPtr->tm_sec += 60; + time -= 60; + } + + time = tmPtr->tm_min + time/60; + tmPtr->tm_min = (int)(time % 60); + if (tmPtr->tm_min < 0) { + tmPtr->tm_min += 60; + time -= 60; + } + + time = tmPtr->tm_hour + time/60; + tmPtr->tm_hour = (int)(time % 24); + if (tmPtr->tm_hour < 0) { + tmPtr->tm_hour += 24; + time -= 24; + } + + time /= 24; + tmPtr->tm_mday += (int)time; + tmPtr->tm_yday += (int)time; + tmPtr->tm_wday = (tmPtr->tm_wday + (int)time) % 7; + } + } else { + tmPtr = ComputeGMT(&t2); + } + return tmPtr; +} + +/* + *---------------------------------------------------------------------- + * + * ComputeGMT -- + * + * This function computes GMT given the number of seconds since the epoch + * (midnight Jan 1 1970). + * + * Results: + * Returns a (per thread) statically allocated struct tm. + * + * Side effects: + * Updates the values of the static struct tm. + * + *---------------------------------------------------------------------- + */ + +static struct tm * +ComputeGMT( + const time_t *tp) +{ + struct tm *tmPtr; + long tmp, rem; + int isLeap; + const int *days; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + tmPtr = &tsdPtr->tm; + + /* + * Compute the 4 year span containing the specified time. + */ + + tmp = (long)(*tp / SECSPER4YEAR); + rem = (long)(*tp % SECSPER4YEAR); + + /* + * Correct for weird mod semantics so the remainder is always positive. + */ + + if (rem < 0) { + tmp--; + rem += SECSPER4YEAR; + } + + /* + * Compute the year after 1900 by taking the 4 year span and adjusting for + * the remainder. This works because 2000 is a leap year, and 1900/2100 + * are out of the range. + */ + + tmp = (tmp * 4) + 70; + isLeap = 0; + if (rem >= SECSPERYEAR) { /* 1971, etc. */ + tmp++; + rem -= SECSPERYEAR; + if (rem >= SECSPERYEAR) { /* 1972, etc. */ + tmp++; + rem -= SECSPERYEAR; + if (rem >= SECSPERYEAR + SECSPERDAY) { /* 1973, etc. */ + tmp++; + rem -= SECSPERYEAR + SECSPERDAY; + } else { + isLeap = 1; + } + } + } + tmPtr->tm_year = tmp; + + /* + * Compute the day of year and leave the seconds in the current day in the + * remainder. + */ + + tmPtr->tm_yday = rem / SECSPERDAY; + rem %= SECSPERDAY; + + /* + * Compute the time of day. + */ + + tmPtr->tm_hour = rem / 3600; + rem %= 3600; + tmPtr->tm_min = rem / 60; + tmPtr->tm_sec = rem % 60; + + /* + * Compute the month and day of month. + */ + + days = (isLeap) ? leapDays : normalDays; + for (tmp = 1; days[tmp] < tmPtr->tm_yday; tmp++) { + /* empty body */ + } + tmPtr->tm_mon = --tmp; + tmPtr->tm_mday = tmPtr->tm_yday - days[tmp]; + + /* + * Compute day of week. Epoch started on a Thursday. + */ + + tmPtr->tm_wday = (long)(*tp / SECSPERDAY) + 4; + if ((*tp % SECSPERDAY) < 0) { + tmPtr->tm_wday--; + } + tmPtr->tm_wday %= 7; + if (tmPtr->tm_wday < 0) { + tmPtr->tm_wday += 7; + } + + return tmPtr; +} /* *---------------------------------------------------------------------- * * CalibrationThread -- @@ -1066,10 +1325,79 @@ } return estFreq; } } + +/* + *---------------------------------------------------------------------- + * + * TclpGmtime -- + * + * Wrapper around the 'gmtime' library function to make it thread safe. + * + * Results: + * Returns a pointer to a 'struct tm' in thread-specific data. + * + * Side effects: + * Invokes gmtime or gmtime_r as appropriate. + * + *---------------------------------------------------------------------- + */ + +struct tm * +TclpGmtime( + const time_t *timePtr) /* Pointer to the number of seconds since the + * local system's epoch */ +{ + /* + * The MS implementation of gmtime is thread safe because it returns the + * time in a block of thread-local storage, and Windows does not provide a + * Posix gmtime_r function. + */ + +#if defined(_WIN64) || defined(_USE_64BIT_TIME_T) || (defined(_MSC_VER) && _MSC_VER < 1400) + return gmtime(timePtr); +#else + return _gmtime32((const __time32_t *)timePtr); +#endif +} + +/* + *---------------------------------------------------------------------- + * + * TclpLocaltime -- + * + * Wrapper around the 'localtime' library function to make it thread + * safe. + * + * Results: + * Returns a pointer to a 'struct tm' in thread-specific data. + * + * Side effects: + * Invokes localtime or localtime_r as appropriate. + * + *---------------------------------------------------------------------- + */ + +struct tm * +TclpLocaltime( + const time_t *timePtr) /* Pointer to the number of seconds since the + * local system's epoch */ +{ + /* + * The MS implementation of localtime is thread safe because it returns + * the time in a block of thread-local storage, and Windows does not + * provide a Posix localtime_r function. + */ + +#if defined(_WIN64) || defined(_USE_64BIT_TIME_T) || (defined(_MSC_VER) && _MSC_VER < 1400) + return localtime(timePtr); +#else + return _localtime32((const __time32_t *)timePtr); +#endif +} /* *---------------------------------------------------------------------- * * Tcl_SetTimeProc -- Index: win/tclooConfig.sh ================================================================== --- win/tclooConfig.sh +++ win/tclooConfig.sh @@ -14,6 +14,6 @@ TCLOO_LIB_SPEC="" TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS="" -TCLOO_VERSION=1.2.0 +TCLOO_VERSION=1.1.0 Index: win/tclsh.rc ================================================================== --- win/tclsh.rc +++ win/tclsh.rc @@ -6,10 +6,16 @@ #include // // build-up the name suffix that defines the type of build this is. // +#if TCL_THREADS +#define SUFFIX_THREADS "t" +#else +#define SUFFIX_THREADS "" +#endif + #if STATIC_BUILD #define SUFFIX_STATIC "s" #else #define SUFFIX_STATIC "" #endif @@ -18,11 +24,11 @@ #define SUFFIX_DEBUG "g" #else #define SUFFIX_DEBUG "" #endif -#define SUFFIX SUFFIX_STATIC SUFFIX_DEBUG +#define SUFFIX SUFFIX_THREADS SUFFIX_STATIC SUFFIX_DEBUG LANGUAGE 0x9, 0x1 /* LANG_ENGLISH, SUBLANG_DEFAULT */ VS_VERSION_INFO VERSIONINFO